commit 9d0de424e8988dd067fa673b4351529a32797c56 Author: Dalibor Marković Date: Sun Mar 31 20:49:04 2024 +0200 Init Signed-off-by: Dalibor Marković diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..9532800 --- /dev/null +++ b/.gitignore @@ -0,0 +1,69 @@ +# Uncomment these types if you want even more clean repository. But be careful. +# It can make harm to an existing project source. Read explanations below. +# +# Resource files are binaries containing manifest, project icon and version info. +# They can not be viewed as text or compared by diff-tools. Consider replacing them with .rc files. +#*.res +# +# Type library file (binary). In old Delphi versions it should be stored. +# Since Delphi 2009 it is produced from .ridl file and can safely be ignored. +#*.tlb +# +# Diagram Portfolio file. Used by the diagram editor up to Delphi 7. +# Uncomment this if you are not using diagrams or use newer Delphi version. +#*.ddp +# +# Visual LiveBindings file. Added in Delphi XE2. +# Uncomment this if you are not using LiveBindings Designer. +#*.vlb +# +# Deployment Manager configuration file for your project. Added in Delphi XE2. +# Uncomment this if it is not mobile development and you do not use remote debug feature. +#*.deployproj +# +# C++ object files produced when C/C++ Output file generation is configured. +# Uncomment this if you are not using external objects (zlib library for example). +#*.obj +# + +# Delphi compiler-generated binaries (safe to delete) +*.exe +*.dll +*.bpl +*.bpi +*.dcp +*.so +*.apk +*.drc +*.map +*.dres +*.rsm +*.tds +*.dcu +*.lib +*.a +*.o +*.ocx + +# Delphi autogenerated files (duplicated info) +*.cfg +*.hpp +*Resource.rc + +# Delphi local files (user-specific info) +*.local +*.identcache +*.projdata +*.tvsconfig +*.dsk + +# Delphi history and backups +__history/ +__recovery/ +*.~* + +# Castalia statistics file (since XE7 Castalia is distributed with Delphi) +*.stat + +# Boss dependency manager vendor folder https://github.com/HashLoad/boss +modules/ diff --git a/Demos/ANOTHER_DEMOS/IMPORT/IMPORT_ActiveX.pas b/Demos/ANOTHER_DEMOS/IMPORT/IMPORT_ActiveX.pas new file mode 100644 index 0000000..7b7c89e --- /dev/null +++ b/Demos/ANOTHER_DEMOS/IMPORT/IMPORT_ActiveX.pas @@ -0,0 +1,50 @@ +{$I PaxCompiler.def} + +unit IMPORT_ActiveX; +interface +{$IFDEF MACOS} +procedure Register_ActiveX; +implementation +procedure Register_ActiveX; +begin +end; +end. +{$ENDIF} + +uses +{$IFDEF DPULSAR} + Winapi.ActiveX, + System.Win.ComObj, +{$ELSE} + ActiveX, + ComObj, +{$ENDIF} + PAXCOMP_OLE, + PAXCOMP_CONSTANTS, + PAXCOMP_BASESYMBOL_TABLE, + PaxRegister, + PaxCompiler; + +procedure Register_ActiveX; + + + +implementation + +procedure Register_ActiveX; +begin + CoInitialize(nil); + + RegisterHeader(0, 'function CreateOleObject(const ClassName: string): IDispatch;', + @CreateOleObject); + RegisterHeader(0, 'function GetActiveOleObject(const ClassName: string): IDispatch;', + @GetActiveOleObject); + + RegisterRoutine(0, _strGetOLEProperty, _typeVOID, @ _GetOLEProperty, _ccSTDCALL); + RegisterRoutine(0, _strSetOLEProperty, _typeVOID, @ _SetOLEProperty, _ccSTDCALL); + + GetOlePropProc := _GetOLEProperty; + PutOlePropProc := _SetOLEProperty; +end; + +end. diff --git a/Demos/ANOTHER_DEMOS/IMPORT/IMPORT_COMMON.pas b/Demos/ANOTHER_DEMOS/IMPORT/IMPORT_COMMON.pas new file mode 100644 index 0000000..885130a --- /dev/null +++ b/Demos/ANOTHER_DEMOS/IMPORT/IMPORT_COMMON.pas @@ -0,0 +1,26 @@ +unit IMPORT_COMMON; +interface +uses + IMPORT_ActiveX, + IMPORT_Variants, + IMPORT_SysUtils, + IMPORT_Classes, + IMPORT_Controls, + IMPORT_StdCtrls, + IMPORT_Forms, + IMPORT_Menus, + IMPORT_Dialogs; + +implementation + +begin + Register_ActiveX; + Register_Variants; + Register_SysUtils; + Register_Classes; + Register_Controls; + Register_StdCtrls; + Register_Forms; + Register_Menus; + Register_Dialogs; +end. diff --git a/Demos/ANOTHER_DEMOS/IMPORT/IMPORT_Classes.pas b/Demos/ANOTHER_DEMOS/IMPORT/IMPORT_Classes.pas new file mode 100644 index 0000000..accda38 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/IMPORT/IMPORT_Classes.pas @@ -0,0 +1,774 @@ +unit IMPORT_Classes; +interface +uses + Classes, + SysUtils, + PaxRegister, + PaxCompiler; + +procedure Register_Classes; + +implementation + + +// TList ----------------------------------------------------------------------- + +function TList_GetCapacity(Self: TList): Integer; +begin + result := Self.Capacity; +end; + +procedure TList_SetCapacity(Self: TList; Value: Integer); +begin + Self.Capacity := Value; +end; + +function TList_GetCount(Self: TList): Integer; +begin + result := Self.Count; +end; + +function TList_GetItem(Self: TList; I: Integer): Pointer; +begin + result := Self.Items[I]; +end; + +procedure TList_SetItem(Self: TList; I: Integer; Value: Pointer); +begin + Self.Items[I] := Value; +end; + +{ +function TList_GetList(Self: TList): PPointerList; +begin + result := Self.List; +end; +} + +// TBits ----------------------------------------------------------------------- + +function TBits_GetBit(Self: TBits; I: Integer): Boolean; +begin + result := Self.Bits[I]; +end; + +procedure TBits_SetBit(Self: TBits; I: Integer; Value: Boolean); +begin + Self.Bits[I] := Value; +end; + +function TBits_GetSize(Self: TBits): Integer; +begin + result := Self.Size; +end; + +// TCollectionItem ------------------------------------------------------------- + +function TCollectionItem_GetCollection(Self: TCollectionItem): TCollection; +begin + result := Self.Collection; +end; + +procedure TCollectionItem_SetCollection(Self: TCollectionItem; Value: TCollection); +begin + Self.Collection := Value; +end; + +function TCollectionItem_GetID(Self: TCollectionItem): Integer; +begin + result := Self.ID; +end; + +function TCollectionItem_GetIndex(Self: TCollectionItem): Integer; +begin + result := Self.Index; +end; + +procedure TCollectionItem_SetIndex(Self: TCollectionItem; Value: Integer); +begin + Self.Index := Value; +end; + +function TCollectionItem_GetDisplayName(Self: TCollectionItem): String; +begin + result := Self.DisplayName; +end; + +procedure TCollectionItem_SetDisplayName(Self: TCollectionItem; const Value: String); +begin + Self.DisplayName := Value; +end; + +// TCollection ----------------------------------------------------------------- + +function TCollection_GetCount(Self: TCollection): Integer; +begin + result := Self.Count; +end; + +function TCollection_GetItemClass(Self: TCollection): TCollectionItemClass; +begin + result := Self.ItemClass; +end; + +function TCollection_GetItem(Self: TCollection; I: Integer): TCollectionItem; +begin + result := Self.Items[I]; +end; + +procedure TCollection_SetItem(Self: TCollection; I: Integer; Value: TCollectionItem); +begin + Self.Items[I] := Value; +end; + +// TStrings -------------------------------------------------------------------- + +function TStrings_GetCapacity(Self: TStrings): Integer; +begin + result := Self.Capacity; +end; + +procedure TStrings_SetCapacity(Self: TStrings; Value: Integer); +begin + Self.Capacity := Value; +end; + +function TStrings_GetCommaText(Self: TStrings): String; +begin + result := Self.CommaText; +end; + +procedure TStrings_SetCommaText(Self: TStrings; const Value: String); +begin + Self.CommaText := Value; +end; + +function TStrings_GetCount(Self: TStrings): Integer; +begin + result := Self.Count; +end; + +function TStrings_GetName(Self: TStrings; I: Integer): String; +begin + result := Self.Names[I]; +end; + +function TStrings_GetObject(Self: TStrings; I: Integer): TObject; +begin + result := Self.Objects[I]; +end; + +procedure TStrings_SetObject(Self: TStrings; I: Integer; Value: TObject); +begin + Self.Objects[I] := Value; +end; + +function TStrings_GetValue(Self: TStrings; const I: String): String; +begin + result := Self.Values[I]; +end; + +procedure TStrings_SetValue(Self: TStrings; const I: String; const Value: String); +begin + Self.Values[I] := Value; +end; + +function TStrings_GetString(Self: TStrings; I: Integer): String; +begin + result := Self.Strings[I]; +end; + +procedure TStrings_SetString(Self: TStrings; I: Integer; const Value: String); +begin + Self.Strings[I] := Value; +end; + +function TStrings_GetText(Self: TStrings): String; +begin + result := Self.Text; +end; + +procedure TStrings_SetText(Self: TStrings; const Value: String); +begin + Self.Text := Value; +end; + +{ +procedure TStrings_Clear(Self: TStrings); +begin + self.Clear; +end; +} + +// TStringList ----------------------------------------------------------------- + +function TStringList_GetDuplicates(Self: TStringList): TDuplicates; +begin + result := Self.Duplicates; +end; + +procedure TStringList_SetDuplicates(Self: TStringList; Value: TDuplicates); +begin + Self.Duplicates := Value; +end; + +function TStringList_GetSorted(Self: TStringList): Boolean; +begin + result := Self.Sorted; +end; + +procedure TStringList_SetSorted(Self: TStringList; Value: Boolean); +begin + Self.Sorted := Value; +end; + +// TStream --------------------------------------------------------------------- + +function TStream_GetPosition(Self: TStream): Integer; +begin + result := Self.Position; +end; + +procedure TStream_SetPosition(Self: TStream; Value: Integer); +begin + Self.Position := Value; +end; + +function TStream_GetSize(Self: TStream): Longint; +begin + result := Self.Size; +end; + +procedure TStream_SetSize(Self: TStream; Value: Longint); +begin + Self.Size := Value; +end; + +// TStream --------------------------------------------------------------------- + +function THandleStream_GetHandle(Self: THandleStream): Integer; +begin + result := Self.Handle; +end; + +// TCustomMemoryStream --------------------------------------------------------- + +function TCustomMemoryStream_GetMemory(Self: TCustomMemoryStream): Pointer; +begin + result := Self.Memory; +end; + +// TParser --------------------------------------------------------------------- + +function TParser_GetFloatType(Self: TParser): Char; +begin + result := Self.FloatType; +end; + +function TParser_GetSourceLine(Self: TParser): Integer; +begin + result := Self.SourceLine; +end; + +function TParser_GetToken(Self: TParser): Char; +begin + result := Self.Token; +end; + +// TComponent ------------------------------------------------------------------ + +function TComponent_GetComponent(Self: TComponent; I: Integer): TComponent; +begin + result := Self.Components[I]; +end; + +function TComponent_GetComponentCount(Self: TComponent): Integer; +begin + result := Self.ComponentCount; +end; + +function TComponent_GetComponentIndex(Self: TComponent): Integer; +begin + result := Self.ComponentIndex; +end; + +procedure TComponent_SetComponentIndex(Self: TComponent; Value: Integer); +begin + Self.ComponentIndex := Value; +end; + +function TComponent_GetComponentState(Self: TComponent): TComponentState; +begin + result := Self.ComponentState; +end; + +function TComponent_GetComponentStyle(Self: TComponent): TComponentStyle; +begin + result := Self.ComponentStyle; +end; + +function TComponent_GetDesignInfo(Self: TComponent): Integer; +begin + result := Self.DesignInfo; +end; + +procedure TComponent_SetDesignInfo(Self: TComponent; Value: Integer); +begin + Self.DesignInfo := Value; +end; + +function TComponent_GetOwner(Self: TComponent): TComponent; +begin + result := Self.Owner; +end; + +//------------------------------------------------------------------------------ + +function TStringStream_GetDataString(Self: TStringStream): String; +begin + result := Self.DataString; +end; + + +procedure Register_Classes; +var + H, G, J: Integer; +begin + H := RegisterNamespace(0, 'Classes'); + +{ Maximum TList size } + + RegisterConstant(H, 'MaxListSize', MaxListSize); + +{ TStream seek origins } + + RegisterConstant(H, 'soFromBeginning', soFromBeginning); + RegisterConstant(H, 'soFromCurrent', soFromCurrent); + RegisterConstant(H, 'soFromEnd', soFromEnd); + +{ TFileStream create mode } + + RegisterConstant(H, 'fmCreate', fmCreate); + +{ TParser special tokens } + + RegisterConstant(H, 'toEOF', toEOF); + RegisterConstant(H, 'toSymbol', toSymbol); + RegisterConstant(H, 'toString', toString); + RegisterConstant(H, 'toInteger', toInteger); + RegisterConstant(H, 'toFloat', toFloat); + RegisterConstant(H, 'toWString', toWString); + +{ Text alignment types } + + J := RegisterRTTIType(H, TypeInfo(TAlignment)); +// RegisterRTTIType(H, TypeInfo(TLeftRight)); + RegisterSubrangeType(H, 'TLeftRight', J, + Ord(taLeftJustify), Ord(taRightJustify)); + + RegisterRTTIType(H, TypeInfo(TBiDiMode)); + +{ Types used by standard events } + + RegisterRTTIType(H, TypeInfo(TShiftState)); + RegisterRTTIType(H, TypeInfo(THelpContext)); + +{ Duplicate management } + + RegisterRTTIType(H, TypeInfo(TDuplicates)); + + RegisterClassType(H, TComponent); + RegisterClassType(H, TStream); + RegisterClassType(H, TFiler); + RegisterClassType(H, TReader); + RegisterClassType(H, TWriter); + +// TList ----------------------------------------------------------------------- + + G := RegisterArrayType(H, 'TPointerList', + RegisterSubrangeType(H, '', _typeINTEGER, 0, MaxListSize - 1), + _typePOINTER); + RegisterPointerType(H, 'PPointerList', G); + + G := RegisterHeader(H, 'function __TListSortCompare(Item1, Item2: Pointer): Integer;', nil); + RegisterProceduralType(H, 'TListSortCompare', G); + RegisterRTTIType(H, TypeInfo(TListNotification)); + + G := RegisterClassType(H, TList); + + RegisterHeader(G, 'constructor Create;', @TList.Create); + RegisterHeader(G, 'function Add(Item: Pointer): Integer;', @TList.Add); + RegisterHeader(G, 'procedure Clear; virtual;', @TList.Clear); + RegisterHeader(G, 'procedure Delete(Index: Integer);', @TList.Delete); + RegisterHeader(G, 'procedure Exchange(Index1, Index2: Integer);', @TList.Exchange); + RegisterHeader(G, 'function Expand: TList;', @TList.Expand); + RegisterHeader(G, 'function Extract(Item: Pointer): Pointer;', @TList.Extract); + RegisterHeader(G, 'function First: Pointer;', @TList.First); + RegisterHeader(G, 'function IndexOf(Item: Pointer): Integer;', @TList.IndexOf); + RegisterHeader(G, 'procedure Insert(Index: Integer; Item: Pointer);', @TList.Insert); + RegisterHeader(G, 'function Last: Pointer;', @TList.Last); + RegisterHeader(G, 'procedure Move(CurIndex, NewIndex: Integer);', @TList.Move); + RegisterHeader(G, 'function Remove(Item: Pointer): Integer;', @TList.Remove); + RegisterHeader(G, 'procedure Pack;', @TList.Pack); + RegisterHeader(G, 'procedure Sort(Compare: TListSortCompare);', @TList.Sort); + + RegisterFakeHeader(G, 'function _GetCapacity: Integer;', @TList_GetCapacity); + RegisterFakeHeader(G, 'procedure _SetCapacity(Value: Integer);', @TList_SetCapacity); + RegisterProperty(G, 'property Capacity: Integer read _GetCapacity write _SetCapacity;'); + + RegisterFakeHeader(G, 'function _GetCount: Integer;', @TList_GetCount); + RegisterProperty(G, 'property Count: Integer read _GetCount;'); + + RegisterFakeHeader(G, 'function _GetItem(I: Integer): Pointer;', @TList_GetItem); + RegisterFakeHeader(G, 'procedure _SetItem(I: Integer; Value: Pointer);', @TList_SetItem); + RegisterProperty(G, 'property Items[Index: Integer]: Pointer read _GetItem write _SetItem; default;'); + +// RegisterHeader(G, 'function _GetList: PPointerList;', @TList_GetList); +// RegisterProperty(G, 'property List: PPointerList read _GetList;'); + +// TBits ----------------------------------------------------------------------- + + G := RegisterClassType(H, TBits); + RegisterHeader(G, 'constructor Create;', @TBits.Create); + RegisterHeader(G, 'function OpenBit: Integer;', @TBits.OpenBit); + + RegisterFakeHeader(G, 'function _GetBit(I: Integer): Boolean;', @TBits_GetBit); + RegisterFakeHeader(G, 'procedure _SetBit(I: Integer; Value: Boolean);', @TBits_SetBit); + RegisterProperty(G, 'property Bits[Index: Integer]: Boolean read _GetBit write _SetBit; default;'); + + RegisterFakeHeader(G, 'function _GetSize: Integer;', @TBits_GetSize); + RegisterProperty(G, 'property Size: Integer read _GetSize;'); + +// TPersistent ----------------------------------------------------------------- + + G := RegisterClassType(H, TPersistent); + RegisterClassReferenceType(H, 'TPersistentClass', G); + + RegisterHeader(G, 'constructor Create;', @TPersistent.Create); + RegisterHeader(G, 'procedure Assign(Source: TPersistent); virtual;', @TPersistent.Assign); + RegisterHeader(G, 'function GetNamePath: string; dynamic;', @TPersistent.GetNamePath); + +// TCollectionItem ------------------------------------------------------------- + + RegisterClassType(H, TCollection); + G := RegisterClassType(H, TCollectionItem); + RegisterClassReferenceType(H, 'TCollectionItemClass', G); + + RegisterHeader(G, 'constructor Create(Collection: TCollection); virtual;', @TCollectionItem.Create); + RegisterHeader(G, 'function GetNamePath: string; override;', @TCollectionItem.GetNamePath); + + RegisterFakeHeader(G, 'function _GetCollection: TCollection;', @TCollectionItem_GetCollection); + RegisterFakeHeader(G, 'procedure _SetCollection(Value: TCollection);', @TCollectionItem_SetCollection); + RegisterProperty(G, 'property Collection: TCollection read _GetCollection write _SetCollection;'); + + RegisterFakeHeader(G, 'function _GetID: Integer;', @TCollectionItem_GetID); + RegisterProperty(G, 'property ID: Integer read _GetID;'); + + RegisterFakeHeader(G, 'function _GetIndex: Integer;', @TCollectionItem_GetIndex); + RegisterFakeHeader(G, 'procedure _SetIndex(Value: Integer);', @TCollectionItem_SetIndex); + RegisterProperty(G, 'property Index: Integer read _GetIndex write _SetIndex;'); + + RegisterFakeHeader(G, 'function _GetDisplayName: String;', @TCollectionItem_GetDisplayName); + RegisterFakeHeader(G, 'procedure _SetDisplayName(const Value: String);', @TCollectionItem_SetDisplayName); + RegisterProperty(G, 'property DisplayName: string read _GetDisplayName write _SetDisplayName;'); + +// TCollection ----------------------------------------------------------------- + + G := RegisterClassType(H, TCollection); + + RegisterHeader(G, 'constructor Create(ItemClass: TCollectionItemClass);', @TCollection.Create); + RegisterHeader(G, 'function Add: TCollectionItem;', @TCollection.Add); + RegisterHeader(G, 'procedure Assign(Source: TPersistent); override;', @TCollection.Assign); + RegisterHeader(G, 'procedure BeginUpdate; virtual;', @TCollection.BeginUpdate); + RegisterHeader(G, 'procedure Clear;', @TCollection.Clear); + RegisterHeader(G, 'procedure Delete(Index: Integer);', @TCollection.Delete); + RegisterHeader(G, 'procedure EndUpdate; virtual;', @TCollection.EndUpdate); + RegisterHeader(G, 'function FindItemID(ID: Integer): TCollectionItem;', @TCollection.FindItemId); + RegisterHeader(G, 'function GetNamePath: string; override;', @TCollection.GetNamePath); + RegisterHeader(G, 'function Insert(Index: Integer): TCollectionItem;', @TCollection.Insert); + + RegisterFakeHeader(G, 'function _GetCount: Integer;', @TCollection_GetCount); + RegisterProperty(G, 'property Count: Integer read _GetCount;'); + + RegisterFakeHeader(G, 'function _GetItemClass: TCollectionItemClass;', + @TCollection_GetItemClass); + RegisterProperty(G, 'property ItemClass: TCollectionItemClass read _GetItemClass;'); + + RegisterFakeHeader(G, 'function _GetItem(I: Integer): TCollectionItem;', @TCollection_GetItem); + RegisterFakeHeader(G, 'procedure _SetItem(I: Integer; Value: TCollectionItem);', @TCollection_SetItem); + RegisterProperty(G, 'property Items[Index: Integer]: TCollectionItem read _GetItem write _SetItem;'); + +// TStrings -------------------------------------------------------------------- + + G := RegisterClassType(H, TStrings); + + RegisterHeader(G, 'constructor Create;', @TStrings.Create); + + RegisterHeader(G, 'function Get(Index: Integer): string; virtual; abstract;', nil); + RegisterHeader(G, 'function GetCount: Integer; virtual; abstract;', nil); + + RegisterHeader(G, 'function Add(const S: string): Integer; virtual;', @TStrings.Add); + RegisterHeader(G, 'function AddObject(const S: string; AObject: TObject): Integer; virtual;', @TStrings.AddObject); + RegisterHeader(G, 'procedure Append(const S: string);', @TStrings.Append); + RegisterHeader(G, 'procedure AddStrings(Strings: TStrings); virtual;', @TStrings.AddStrings); + RegisterHeader(G, 'procedure Assign(Source: TPersistent); override;', @TStrings.Assign); + RegisterHeader(G, 'procedure BeginUpdate;', @TStrings.BeginUpdate); + RegisterHeader(G, 'procedure Clear; virtual; abstract;', nil); + + RegisterHeader(G, 'procedure Delete(Index: Integer); virtual; abstract;', nil); + RegisterHeader(G, 'procedure EndUpdate;', @TStrings.EndUpdate); + RegisterHeader(G, 'function Equals(Strings: TStrings): Boolean;', @TStrings.Equals); + RegisterHeader(G, 'procedure Exchange(Index1, Index2: Integer); virtual;', @TStrings.Exchange); + RegisterHeader(G, 'function GetText: PChar; virtual;', @TStrings.GetText); + RegisterHeader(G, 'function IndexOf(const S: string): Integer; virtual;', @TStrings.IndexOf); + RegisterHeader(G, 'function IndexOfName(const Name: string): Integer;', @TStrings.IndexOfName); + RegisterHeader(G, 'function IndexOfObject(AObject: TObject): Integer;', @TStrings.IndexOfObject); + RegisterHeader(G, 'procedure Insert(Index: Integer; const S: string); virtual; abstract;', nil); + RegisterHeader(G, 'procedure InsertObject(Index: Integer; const S: string; AObject: TObject);', @TStrings.InsertObject); + RegisterHeader(G, 'procedure LoadFromFile(const FileName: string); virtual;', @TStrings.LoadFromFile); + RegisterHeader(G, 'procedure LoadFromStream(Stream: TStream); virtual;', @TStrings.LoadFromStream); + RegisterHeader(G, 'procedure Move(CurIndex, NewIndex: Integer); virtual;', @TStrings.Move); + RegisterHeader(G, 'procedure SaveToFile(const FileName: string); virtual;', @TStrings.SaveToFile); + RegisterHeader(G, 'procedure SaveToStream(Stream: TStream); virtual;', @TStrings.SaveToStream); + RegisterHeader(G, 'procedure SetText(Text: PChar); virtual;', @TStrings.SetText); + + RegisterFakeHeader(G, 'function _GetCapacity: Integer;', @TStrings_GetCapacity); + RegisterFakeHeader(G, 'procedure _SetCapacity(Value: Integer);', @TStrings_SetCapacity); + RegisterProperty(G, 'property Capacity: Integer read _GetCapacity write _SetCapacity;'); + + RegisterFakeHeader(G, 'function _GetCommaText: String;', @TStrings_GetCommaText); + RegisterFakeHeader(G, 'procedure _SetCommaText(const Value: String);', @TStrings_SetCommaText); + RegisterProperty(G, 'property CommaText: string read _GetCommaText write _SetCommaText;'); + + RegisterFakeHeader(G, 'function _GetCount: Integer;', @TStrings_GetCount); + RegisterProperty(G, 'property Count: Integer read _GetCount;'); + + RegisterFakeHeader(G, 'function _GetName(I: Integer): String;', @TStrings_GetName); + RegisterProperty(G, 'property Names[Index: Integer]: string read _GetName;'); + + RegisterFakeHeader(G, 'function GetObjects(I: Integer): TObject;', @TStrings_GetObject); + RegisterFakeHeader(G, 'procedure SetObjects(I: Integer; Value: TObject);', @TStrings_SetObject); + RegisterProperty(G, 'property Objects[Index: Integer]: TObject read GetObjects write SetObjects;'); + + RegisterFakeHeader(G, 'function _GetValue(const I: String): String;', @TStrings_GetValue); + RegisterFakeHeader(G, 'procedure _SetValue(const I: String; const Value: String);', @TStrings_GetValue); + RegisterProperty(G, 'property Values[const Name: string]: string read _GetValue write _SetValue;'); + + RegisterFakeHeader(G, 'function _GetString(I: Integer): String;', @TStrings_GetString); + RegisterFakeHeader(G, 'procedure _SetString(I: Integer; const Value: String);', @TStrings_SetString); + RegisterProperty(G, 'property Strings[Index: Integer]: string read _GetString write _SetString; default;'); + + RegisterFakeHeader(G, 'function _GetText: String;', @TStrings_GetText); + RegisterFakeHeader(G, 'procedure _SetText(const Value: String);', @TStrings_SetText); + RegisterProperty(G, 'property Text: string read _GetText write _SetText;'); + +// TStringList ----------------------------------------------------------------- + + G := RegisterClassType(H, TStringList); + + RegisterProceduralType(H, 'TStringListSortCompare', RegisterHeader(H, 'function __TStringListSortCompare(List: TStringList; Index1, Index2: Integer): Integer;', nil)); + + RegisterHeader(G, 'constructor Create;', @TStringList.Create); + RegisterHeader(G, 'function Add(const S: string): Integer; override;', @TStringList.Add); + RegisterHeader(G, 'procedure Clear; override;', @TStringList.Clear); + RegisterHeader(G, 'procedure Delete(Index: Integer); override;', @TStringList.Delete); + RegisterHeader(G, 'procedure Exchange(Index1, Index2: Integer); override;', @TStringList.Exchange); + RegisterHeader(G, 'function Find(const S: string; var Index: Integer): Boolean; virtual;', @TStringList.Find); + RegisterHeader(G, 'function IndexOf(const S: string): Integer; override;', @TStringList.IndexOf); + RegisterHeader(G, 'procedure Insert(Index: Integer; const S: string); override;', @TStringList.Insert); + RegisterHeader(G, 'procedure Sort; virtual;', @TStringList.Sort); + RegisterHeader(G, 'procedure CustomSort(Compare: TStringListSortCompare); virtual;', @TStringList.CustomSort); + + RegisterFakeHeader(G, 'function _GetDuplicates: TDuplicates;', @TStringList_GetDuplicates); + RegisterFakeHeader(G, 'procedure _SetDuplicates(Value: TDuplicates);', @TStringList_SetDuplicates); + RegisterProperty(G, 'property Duplicates: TDuplicates read _GetDuplicates write _SetDuplicates;'); + + RegisterFakeHeader(G, 'function _GetSorted: Boolean;', @TStringList_GetSorted); + RegisterFakeHeader(G, 'procedure _SetSorted(Value: Boolean);', @TStringList_SetSorted); + RegisterProperty(G, 'property Sorted: Boolean read _GetSorted write _SetSorted;'); + +// TStream --------------------------------------------------------------------- + + G := RegisterClassType(H, TStream); + + RegisterHeader(G, 'constructor Create;', @TStream.Create); + RegisterHeader(G, 'function Read(var Buffer; Count: Longint): Longint; virtual; abstract;', nil); + RegisterHeader(G, 'function Write(const Buffer; Count: Longint): Longint; virtual; abstract;', nil); + RegisterHeader(G, 'function Seek(Offset: Longint; Origin: Word): Longint; virtual; abstract;', nil); + RegisterHeader(G, 'procedure ReadBuffer(var Buffer; Count: Longint);', @TStream.ReadBuffer); + RegisterHeader(G, 'procedure WriteBuffer(const Buffer; Count: Longint);', @TStream.WriteBuffer); + RegisterHeader(G, 'function CopyFrom(Source: TStream; Count: Longint): Longint;', @TStream.CopyFrom); + RegisterHeader(G, 'function ReadComponent(Instance: TComponent): TComponent;', @TStream.ReadComponent); + RegisterHeader(G, 'function ReadComponentRes(Instance: TComponent): TComponent;', @TStream.ReadComponentRes); + RegisterHeader(G, 'procedure WriteComponent(Instance: TComponent);', @TStream.WriteComponent); + RegisterHeader(G, 'procedure WriteResourceHeader(const ResName: string; out FixupInfo: Integer);', @TStream.WriteResourceHeader); + RegisterHeader(G, 'procedure FixupResourceHeader(FixupInfo: Integer);', @TStream.FixupResourceHeader); + RegisterHeader(G, 'procedure ReadResHeader;', @TStream.ReadResHeader); + + RegisterFakeHeader(G, 'function _GetPosition: Integer;', @TStream_GetPosition); + RegisterFakeHeader(G, 'procedure _SetPosition(Value: Integer);', @TStream_SetPosition); + RegisterProperty(G, 'property Position: Longint read _GetPosition write _SetPosition;'); + + RegisterFakeHeader(G, 'function _GetSize: Longint;', @TStream_GetSize); + RegisterFakeHeader(G, 'procedure _SetSize(Value: Longint);', @TStream_SetSize); + RegisterProperty(G, 'property Size: Longint read _GetSize write _SetSize;'); + +// THandleStream --------------------------------------------------------------- + + G := RegisterClassType(H, THandleStream); + + RegisterHeader(G, 'constructor Create(AHandle: Integer);', @THandleStream.Create); + RegisterHeader(G, 'function Read(var Buffer; Count: Longint): Longint; override;', @THandleStream.Read); + RegisterHeader(G, 'function Write(const Buffer; Count: Longint): Longint; override;', @THandleStream.Write); + RegisterHeader(G, 'function Seek(Offset: Longint; Origin: Word): Longint; override;', @THandleStream.Seek); + + RegisterFakeHeader(G, 'function _GetHandle: Integer;', @THandleStream_GetHandle); + RegisterProperty(G, 'property Handle: Integer read _GetHandle;'); + +// TFileStream ----------------------------------------------------------------- + + G := RegisterClassType(H, TFileStream); + + RegisterHeader(G, 'constructor Create(const FileName: string; Mode: Word);', @TFileStream.Create); + +// TCustomMemoryStream --------------------------------------------------------- + + G := RegisterClassType(H, TCustomMemoryStream); + + RegisterHeader(G, 'constructor Create;', @TCustomMemoryStream.Create); + RegisterHeader(G, 'function Read(var Buffer; Count: Longint): Longint; override;', @TCustomMemoryStream.Read); + RegisterHeader(G, 'function Seek(Offset: Longint; Origin: Word): Longint; override;', @TCustomMemoryStream.Seek); + RegisterHeader(G, 'procedure SaveToStream(Stream: TStream);', @TCustomMemoryStream.SaveToStream); + RegisterHeader(G, 'procedure SaveToFile(const FileName: string);', @TCustomMemoryStream.SaveToFile); + + RegisterFakeHeader(G, 'function _GetMemory: Pointer;', @TCustomMemoryStream_GetMemory); + RegisterProperty(G, 'property Memory: Pointer read _GetMemory;'); + +// TMemoryStream --------------------------------------------------------------- + + G := RegisterClassType(H, TMemoryStream); + + RegisterHeader(G, 'constructor Create;', @TMemoryStream.Create); + RegisterHeader(G, 'procedure Clear;', @TMemoryStream.Clear); + RegisterHeader(G, 'procedure LoadFromStream(Stream: TStream);', @TMemoryStream.LoadFromStream); + RegisterHeader(G, 'procedure LoadFromFile(const FileName: string);', @TMemoryStream.LoadFromFile); + RegisterHeader(G, 'procedure SetSize(NewSize: Longint); override;', @TMemoryStream.SetSize); + RegisterHeader(G, 'function Write(const Buffer; Count: Longint): Longint; override;', @TMemoryStream.Write); + +// TStringStream --------------------------------------------------------------- + + G := RegisterClassType(H, TStringStream); + + RegisterHeader(G, 'constructor Create(const AString: string); overload;', @TStringStream.Create); + + RegisterHeader(G, 'function Read(var Buffer; Count: Longint): Longint; override;', @TStringStream.Read); + RegisterHeader(G, 'function ReadString(Count: Longint): string;', @TStringStream.ReadString); + RegisterHeader(G, 'function Seek(Offset: Longint; Origin: Word): Longint; override;', @TStringStream.Seek); + RegisterHeader(G, 'function Write(const Buffer; Count: Longint): Longint; override;', @TStringStream.Write); + RegisterHeader(G, 'procedure WriteString(const AString: string);', @TStringStream.WriteString); + + RegisterFakeHeader(G, 'function _GetDataString: String;', @TStringStream_GetDataString); + RegisterProperty(G, 'property DataString: string read _GetDataString;'); + +// TResourceStream ------------------------------------------------------------- + + G := RegisterClassType(H, TResourceStream); + + RegisterHeader(G, 'constructor Create(Instance: THandle; const ResName: string; ResType: PChar);', @TResourceStream.Create); + RegisterHeader(G, 'constructor CreateFromID(Instance: THandle; ResID: Integer; ResType: PChar);', @TResourceStream.CreateFromID); + RegisterHeader(G, 'function Write(const Buffer; Count: Longint): Longint; override;', @TResourceStream.Write); + +// TParser --------------------------------------------------------------------- + + G := RegisterClassType(H, TParser); + + RegisterHeader(G, 'constructor Create(Stream: TStream);', @TParser.Create); + RegisterHeader(G, 'procedure CheckToken(T: Char);', @TParser.CheckToken); + RegisterHeader(G, 'procedure CheckTokenSymbol(const S: string);', @TParser.CheckTokenSymbol); + RegisterHeader(G, 'procedure Error(const Ident: string);', @TParser.Error); + RegisterHeader(G, 'procedure ErrorStr(const Message: string);', @TParser.ErrorStr); + RegisterHeader(G, 'procedure HexToBinary(Stream: TStream);', @TParser.HexToBinary); + RegisterHeader(G, 'function NextToken: Char;', @TParser.NextToken); + RegisterHeader(G, 'function SourcePos: Longint;', @TParser.SourcePos); + RegisterHeader(G, 'function TokenComponentIdent: string;', @TParser.TokenComponentIdent); + RegisterHeader(G, 'function TokenFloat: Extended;', @TParser.TokenFloat); + RegisterHeader(G, 'function TokenString: string;', @TParser.TokenString); + RegisterHeader(G, 'function TokenSymbolIs(const S: string): Boolean;', @TParser.TokenSymbolIs); + + RegisterFakeHeader(G, 'function _GetFloatType: Char;', @TParser_GetFloatType); + RegisterProperty(G, 'property FloatType: Char read _GetFloatType;'); + + RegisterFakeHeader(G, 'function _GetSourceLine: Integer;', @TParser_GetSourceLine); + RegisterProperty(G, 'property SourceLine: Integer read _GetSourceLine;'); + + RegisterFakeHeader(G, 'function _GetToken: Char;', @TParser_GetToken); + RegisterProperty(G, 'property Token: Char read _GetToken;'); + +// TComponent ------------------------------------------------------------------ + + RegisterClassType(H, TBasicAction); + RegisterRTTIType(H, TypeInfo(TComponentState)); + RegisterRTTIType(H, TypeInfo(TComponentStyle)); + + G := RegisterClassType(H, TComponent); + + RegisterHeader(G, 'constructor Create(AOwner: TComponent); virtual;', @TComponent.Create); + RegisterHeader(G, 'procedure BeforeDestruction; override;', @TComponent.BeforeDestruction); + RegisterHeader(G, 'procedure DestroyComponents;', @TComponent.DestroyComponents); + RegisterHeader(G, 'procedure Destroying;', @TComponent.Destroying); + RegisterHeader(G, 'function ExecuteAction(Action: TBasicAction): Boolean; dynamic;', @TComponent.ExecuteAction); + RegisterHeader(G, 'function FindComponent(const AName: string): TComponent;', @TComponent.FindComponent); + RegisterHeader(G, 'procedure FreeNotification(AComponent: TComponent);', @TComponent.FreeNotification); + RegisterHeader(G, 'procedure RemoveFreeNotification(AComponent: TComponent);', @TComponent.RemoveFreeNotification); + RegisterHeader(G, 'procedure FreeOnRelease;', @TComponent.FreeOnRelease); + RegisterHeader(G, 'function GetParentComponent: TComponent; dynamic;', @TComponent.GetParentComponent); + RegisterHeader(G, 'function GetNamePath: string; override;', @TComponent.GetNamePath); + RegisterHeader(G, 'function HasParent: Boolean; dynamic;', @TComponent.HasParent); + RegisterHeader(G, 'procedure InsertComponent(AComponent: TComponent);', @TComponent.InsertComponent); + RegisterHeader(G, 'procedure RemoveComponent(AComponent: TComponent);', @TComponent.RemoveComponent); + RegisterHeader(G, 'function SafeCallException(ExceptObject: TObject; ExceptAddr: Pointer): HResult; override;', @TComponent.SafeCallException); + RegisterHeader(G, 'function UpdateAction(Action: TBasicAction): Boolean; dynamic;', @TComponent.UpdateAction); + + RegisterFakeHeader(G, 'function _GetComponent(I: Integer): TComponent;', @TComponent_GetComponent); + RegisterProperty(G, 'property Components[Index: Integer]: TComponent read _GetComponent;'); + + RegisterFakeHeader(G, 'function _GetComponentCount: Integer;', @TComponent_GetComponentCount); + RegisterProperty(G, 'property ComponentCount: Integer read _GetComponentCount;'); + + RegisterFakeHeader(G, 'function _GetComponentIndex: Integer;', @TComponent_GetComponentIndex); + RegisterFakeHeader(G, 'procedure _SetComponentIndex(Value: Integer);', @TComponent_SetComponentIndex); + RegisterProperty(G, 'property ComponentIndex: Integer read _GetComponentIndex write _SetComponentIndex;'); + + RegisterFakeHeader(G, 'function _GetComponentState: TComponentState;', @TComponent_GetComponentState); + RegisterProperty(G, 'property ComponentState: TComponentState read _GetComponentState;'); + + RegisterFakeHeader(G, 'function _GetComponentStyle: TComponentStyle;', @TComponent_GetComponentStyle); + RegisterProperty(G, 'property ComponentStyle: TComponentStyle read _GetComponentStyle;'); + + RegisterFakeHeader(G, 'function _GetDesignInfo: Integer;', @TComponent_GetDesignInfo); + RegisterFakeHeader(G, 'procedure _SetDesignInfo(Value: Integer);', @TComponent_SetDesignInfo); + RegisterProperty(G, 'property DesignInfo: Longint read _GetDesignInfo write _SetDesignInfo;'); + + RegisterFakeHeader(G, 'function _GetOwner: TComponent;', @TComponent_GetOwner); + RegisterProperty(G, 'property Owner: TComponent read _GetOwner;'); + +{ Point and rectangle constructors } + + RegisterHeader(H, 'function Point(AX, AY: Integer): TPoint;', @Point); + RegisterHeader(H, 'function Rect(ALeft, ATop, ARight, ABottom: Integer): TRect;', @Rect); + RegisterHeader(H, 'function Bounds(ALeft, ATop, AWidth, AHeight: Integer): TRect;', @Bounds); + +{ Class registration routines } + + RegisterHeader(H, 'procedure RegisterClass(AClass: TPersistentClass);', @RegisterClass); + RegisterHeader(H, 'procedure UnRegisterClass(AClass: TPersistentClass);', @UnRegisterClass); + RegisterHeader(H, 'function FindClass(const ClassName: string): TPersistentClass;', @FindClass); + RegisterHeader(H, 'function GetClass(const AClassName: string): TPersistentClass;', @GetClass); + + RegisterRTTIType(H, TypeInfo(TOperation)); + + +end; + + +end. diff --git a/Demos/ANOTHER_DEMOS/IMPORT/IMPORT_Controls.pas b/Demos/ANOTHER_DEMOS/IMPORT/IMPORT_Controls.pas new file mode 100644 index 0000000..ff00008 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/IMPORT/IMPORT_Controls.pas @@ -0,0 +1,1440 @@ +{$I PaxCompiler.def} + +unit IMPORT_Controls; +interface +uses +// MultiMon, + Classes, + SysUtils, +{$IFDEF DPULSAR} + {$IFDEF MACOS} + FMX.Messages, + FMX.Menus, + FMX.ActnList, + FMX.Controls, + {$ELSE} + Winapi.Messages, + Winapi.Windows, + Vcl.Graphics, + Vcl.Menus, + Vcl.ImgList, + Vcl.ActnList, + Vcl.Controls, + Winapi.CommCtrl, + {$ENDIF} +{$ELSE} + Messages, + Windows, + Graphics, + Menus, + ImgList, + ActnList, + Controls, + CommCtrl, +{$ENDIF} + Variants, + PaxRegister, + PaxCompiler; +procedure Register_Controls; +implementation +{$IFDEF MACOS} +{$ELSE} +function TDragObject_GetCancelling(Self:TDragObject):Boolean; +begin + result := Self.Cancelling; +end; +procedure TDragObject_PutCancelling(Self:TDragObject;const Value: Boolean); +begin + Self.Cancelling := Value; +end; +function TDragObject_GetDragPos(Self:TDragObject):TPoint; +begin + result := Self.DragPos; +end; +procedure TDragObject_PutDragPos(Self:TDragObject;const Value: TPoint); +begin + Self.DragPos := Value; +end; +function TDragObject_GetDragTargetPos(Self:TDragObject):TPoint; +begin + result := Self.DragTargetPos; +end; +procedure TDragObject_PutDragTargetPos(Self:TDragObject;const Value: TPoint); +begin + Self.DragTargetPos := Value; +end; +function TDragObject_GetDragTarget(Self:TDragObject):Pointer; +begin + result := Self.DragTarget; +end; +procedure TDragObject_PutDragTarget(Self:TDragObject;const Value: Pointer); +begin + Self.DragTarget := Value; +end; +function TDragObject_GetDropped(Self:TDragObject):Boolean; +begin + result := Self.Dropped; +end; +function TDragObject_GetMouseDeltaX(Self:TDragObject):Double; +begin + result := Self.MouseDeltaX; +end; +function TDragObject_GetMouseDeltaY(Self:TDragObject):Double; +begin + result := Self.MouseDeltaY; +end; +function TBaseDragControlObject_GetControl(Self:TBaseDragControlObject):TControl; +begin + result := Self.Control; +end; +procedure TBaseDragControlObject_PutControl(Self:TBaseDragControlObject;const Value: TControl); +begin + Self.Control := Value; +end; +function TDragDockObject_GetDockRect(Self:TDragDockObject):TRect; +begin + result := Self.DockRect; +end; +procedure TDragDockObject_PutDockRect(Self:TDragDockObject;const Value: TRect); +begin + Self.DockRect := Value; +end; +function TDragDockObject_GetDropAlign(Self:TDragDockObject):TAlign; +begin + result := Self.DropAlign; +end; +function TDragDockObject_GetDropOnControl(Self:TDragDockObject):TControl; +begin + result := Self.DropOnControl; +end; +function TDragDockObject_GetFloating(Self:TDragDockObject):Boolean; +begin + result := Self.Floating; +end; +procedure TDragDockObject_PutFloating(Self:TDragDockObject;const Value: Boolean); +begin + Self.Floating := Value; +end; +function TDragDockObject_GetFrameWidth(Self:TDragDockObject):Integer; +begin + result := Self.FrameWidth; +end; +function TControlCanvas_GetControl(Self:TControlCanvas):TControl; +begin + result := Self.Control; +end; +procedure TControlCanvas_PutControl(Self:TControlCanvas;const Value: TControl); +begin + Self.Control := Value; +end; +{$ENDIF} +function TControl_GetEnabled(Self:TControl):Boolean; +begin + result := Self.Enabled; +end; +procedure TControl_PutEnabled(Self:TControl;const Value: Boolean); +begin + Self.Enabled := Value; +end; +function TControl_GetAlign(Self:TControl):TAlign; +begin + result := Self.Align; +end; +procedure TControl_PutAlign(Self:TControl;const Value: TAlign); +begin + Self.Align := Value; +end; +function TControl_GetBoundsRect(Self:TControl):TRect; +begin + result := Self.BoundsRect; +end; +procedure TControl_PutBoundsRect(Self:TControl;const Value: TRect); +begin + Self.BoundsRect := Value; +end; +function TControl_GetClientHeight(Self:TControl):Integer; +begin + result := Self.ClientHeight; +end; +procedure TControl_PutClientHeight(Self:TControl;const Value: Integer); +begin + Self.ClientHeight := Value; +end; +function TControl_GetClientOrigin(Self:TControl):TPoint; +begin + result := Self.ClientOrigin; +end; +function TControl_GetClientRect(Self:TControl):TRect; +begin + result := Self.ClientRect; +end; +function TControl_GetClientWidth(Self:TControl):Integer; +begin + result := Self.ClientWidth; +end; +procedure TControl_PutClientWidth(Self:TControl;const Value: Integer); +begin + Self.ClientWidth := Value; +end; +function TControl_GetConstraints(Self:TControl):TSizeConstraints; +begin + result := Self.Constraints; +end; +procedure TControl_PutConstraints(Self:TControl;const Value: TSizeConstraints); +begin + Self.Constraints := Value; +end; +function TControl_GetControlState(Self:TControl):TControlState; +begin + result := Self.ControlState; +end; +procedure TControl_PutControlState(Self:TControl;const Value: TControlState); +begin + Self.ControlState := Value; +end; +function TControl_GetControlStyle(Self:TControl):TControlStyle; +begin + result := Self.ControlStyle; +end; +procedure TControl_PutControlStyle(Self:TControl;const Value: TControlStyle); +begin + Self.ControlStyle := Value; +end; +function TControl_GetDockOrientation(Self:TControl):TDockOrientation; +begin + result := Self.DockOrientation; +end; +procedure TControl_PutDockOrientation(Self:TControl;const Value: TDockOrientation); +begin + Self.DockOrientation := Value; +end; +function TControl_GetFloating(Self:TControl):Boolean; +begin + result := Self.Floating; +end; +function TControl_GetFloatingDockSiteClass(Self:TControl):TWinControlClass; +begin + result := Self.FloatingDockSiteClass; +end; +procedure TControl_PutFloatingDockSiteClass(Self:TControl;const Value: TWinControlClass); +begin + Self.FloatingDockSiteClass := Value; +end; +function TControl_GetHostDockSite(Self:TControl):TWinControl; +begin + result := Self.HostDockSite; +end; +procedure TControl_PutHostDockSite(Self:TControl;const Value: TWinControl); +begin + Self.HostDockSite := Value; +end; +function TControl_GetLRDockWidth(Self:TControl):Integer; +begin + result := Self.LRDockWidth; +end; +procedure TControl_PutLRDockWidth(Self:TControl;const Value: Integer); +begin + Self.LRDockWidth := Value; +end; +function TControl_GetParent(Self:TControl):TWinControl; +begin + result := Self.Parent; +end; +procedure TControl_PutParent(Self:TControl;const Value: TWinControl); +begin + Self.Parent := Value; +end; +function TControl_GetShowHint(Self:TControl):Boolean; +begin + result := Self.ShowHint; +end; +procedure TControl_PutShowHint(Self:TControl;const Value: Boolean); +begin + Self.ShowHint := Value; +end; +function TControl_GetTBDockHeight(Self:TControl):Integer; +begin + result := Self.TBDockHeight; +end; +procedure TControl_PutTBDockHeight(Self:TControl;const Value: Integer); +begin + Self.TBDockHeight := Value; +end; +function TControl_GetUndockHeight(Self:TControl):Integer; +begin + result := Self.UndockHeight; +end; +procedure TControl_PutUndockHeight(Self:TControl;const Value: Integer); +begin + Self.UndockHeight := Value; +end; +function TControl_GetUndockWidth(Self:TControl):Integer; +begin + result := Self.UndockWidth; +end; +procedure TControl_PutUndockWidth(Self:TControl;const Value: Integer); +begin + Self.UndockWidth := Value; +end; +function TControl_GetVisible(Self:TControl):Boolean; +begin + result := Self.Visible; +end; +procedure TControl_PutVisible(Self:TControl;const Value: Boolean); +begin + Self.Visible := Value; +end; +function TWinControl_GetDockClientCount(Self:TWinControl):Integer; +begin + result := Self.DockClientCount; +end; +function TWinControl_GetDockClients(Self:TWinControl;Index: Integer):TControl; +begin + result := Self.DockClients[Index]; +end; +function TWinControl_GetDoubleBuffered(Self:TWinControl):Boolean; +begin + result := Self.DoubleBuffered; +end; +procedure TWinControl_PutDoubleBuffered(Self:TWinControl;const Value: Boolean); +begin + Self.DoubleBuffered := Value; +end; +function TWinControl_GetAlignDisabled(Self:TWinControl):Boolean; +begin + result := Self.AlignDisabled; +end; +function TWinControl_GetVisibleDockClientCount(Self:TWinControl):Integer; +begin + result := Self.VisibleDockClientCount; +end; +function TWinControl_GetControls(Self:TWinControl;Index: Integer):TControl; +begin + result := Self.Controls[Index]; +end; +function TWinControl_GetControlCount(Self:TWinControl):Integer; +begin + result := Self.ControlCount; +end; +function TWinControl_GetShowing(Self:TWinControl):Boolean; +begin + result := Self.Showing; +end; +function TWinControl_GetTabOrder(Self:TWinControl):TTabOrder; +begin + result := Self.TabOrder; +end; +procedure TWinControl_PutTabOrder(Self:TWinControl;const Value: TTabOrder); +begin + Self.TabOrder := Value; +end; +function TWinControl_GetTabStop(Self:TWinControl):Boolean; +begin + result := Self.TabStop; +end; +procedure TWinControl_PutTabStop(Self:TWinControl;const Value: Boolean); +begin + Self.TabStop := Value; +end; +function TDragImageList_GetDragCursor(Self:TDragImageList):TCursor; +begin + result := Self.DragCursor; +end; +procedure TDragImageList_PutDragCursor(Self:TDragImageList;const Value: TCursor); +begin + Self.DragCursor := Value; +end; +function TDragImageList_GetDragging(Self:TDragImageList):Boolean; +begin + result := Self.Dragging; +end; +function TDockZone_GetChildCount(Self:TDockZone):Integer; +begin + result := Self.ChildCount; +end; +function TDockZone_GetHeight(Self:TDockZone):Integer; +begin + result := Self.Height; +end; +function TDockZone_GetLeft(Self:TDockZone):Integer; +begin + result := Self.Left; +end; +function TDockZone_GetLimitBegin(Self:TDockZone):Integer; +begin + result := Self.LimitBegin; +end; +function TDockZone_GetLimitSize(Self:TDockZone):Integer; +begin + result := Self.LimitSize; +end; +function TDockZone_GetTop(Self:TDockZone):Integer; +begin + result := Self.Top; +end; +function TDockZone_GetVisible(Self:TDockZone):Boolean; +begin + result := Self.Visible; +end; +function TDockZone_GetVisibleChildCount(Self:TDockZone):Integer; +begin + result := Self.VisibleChildCount; +end; +function TDockZone_GetWidth(Self:TDockZone):Integer; +begin + result := Self.Width; +end; +function TDockZone_GetZoneLimit(Self:TDockZone):Integer; +begin + result := Self.ZoneLimit; +end; +procedure TDockZone_PutZoneLimit(Self:TDockZone;const Value: Integer); +begin + Self.ZoneLimit := Value; +end; +function TMouse_GetCursorPos(Self:TMouse):TPoint; +begin + result := Self.CursorPos; +end; +procedure TMouse_PutCursorPos(Self:TMouse;const Value: TPoint); +begin + Self.CursorPos := Value; +end; +function TMouse_GetDragImmediate(Self:TMouse):Boolean; + +begin + result := Self.DragImmediate; +end; +procedure TMouse_PutDragImmediate(Self:TMouse;const Value: Boolean); +begin + Self.DragImmediate := Value; +end; +function TMouse_GetDragThreshold(Self:TMouse):Integer; +begin + result := Self.DragThreshold; +end; +procedure TMouse_PutDragThreshold(Self:TMouse;const Value: Integer); +begin + Self.DragThreshold := Value; +end; +function TMouse_GetMousePresent(Self:TMouse):Boolean; +begin + result := Self.MousePresent; +end; +function TMouse_GetIsDragging(Self:TMouse):Boolean; +begin + result := Self.IsDragging; +end; +function TMouse_GetWheelPresent(Self:TMouse):Boolean; +begin + result := Self.WheelPresent; +end; +function TMouse_GetWheelScrollLines(Self:TMouse):Integer; +begin + result := Self.WheelScrollLines; +end; +function TCustomListControl_GetItemIndex(Self:TCustomListControl):Integer; +begin + result := Self.ItemIndex; +end; +procedure TCustomListControl_PutItemIndex(Self:TCustomListControl;const Value: Integer); +begin + Self.ItemIndex := Value; +end; +function TCustomMultiSelectListControl_GetMultiSelect(Self:TCustomMultiSelectListControl):Boolean; +begin + result := Self.MultiSelect; +end; +procedure TCustomMultiSelectListControl_PutMultiSelect(Self:TCustomMultiSelectListControl;const Value: Boolean); +begin + Self.MultiSelect := Value; +end; +function TCustomMultiSelectListControl_GetSelCount(Self:TCustomMultiSelectListControl):Integer; +begin + result := Self.SelCount; +end; +procedure Register_Controls; +var G, H: Integer; +begin + H := RegisterNamespace(0, 'Controls'); + RegisterConstant(H, 'CM_BASE', $B000); + RegisterConstant(H, 'CN_BASE', $BC00); + RegisterConstant(H, 'mrNone', 0); + RegisterRTTIType(H, TypeInfo(TCursor)); + // Begin of class TDragObject + G := RegisterClassType(H, TDragObject); + // End of class TDragObject + // Begin of class TControl + G := RegisterClassType(H, TControl); + // End of class TControl + // Begin of class TWinControl + G := RegisterClassType(H, TWinControl); + // End of class TWinControl + // Begin of class TDragImageList + G := RegisterClassType(H, TDragImageList); + // End of class TDragImageList + RegisterClassReferenceType(H, 'TWinControlClass'); + RegisterRTTIType(H, TypeInfo(TDragMessage)); + // Begin of class TDragDockObject + G := RegisterClassType(H, TDragDockObject); + // End of class TDragDockObject + RegisterRTTIType(H, TypeInfo(TAlign)); + RegisterRTTIType(H, TypeInfo(TAlignSet)); + // Begin of class TDragObject + G := RegisterClassType(H, TDragObject); + RegisterHeader(G, + 'procedure AfterConstruction; override;', + @TDragObject.AfterConstruction); + RegisterHeader(G, + 'procedure Assign(Source: TDragObject); virtual;', + @TDragObject.Assign); + RegisterHeader(G, + 'procedure BeforeDestruction; override;', + @TDragObject.BeforeDestruction); + RegisterHeader(G, + 'function GetName: string; virtual;', + @TDragObject.GetName); + RegisterHeader(G, + 'procedure HideDragImage; virtual;', + @TDragObject.HideDragImage); + RegisterHeader(G, + 'function Instance: THandle; virtual;', + @TDragObject.Instance); + RegisterHeader(G, + 'procedure ShowDragImage; virtual;', + @TDragObject.ShowDragImage); + RegisterFakeHeader(G, + 'function TDragObject_GetCancelling:Boolean;', + @TDragObject_GetCancelling); + RegisterFakeHeader(G, + 'procedure TDragObject_PutCancelling(const Value: Boolean);', + @TDragObject_PutCancelling); + RegisterProperty(G, + 'property Cancelling:Boolean read TDragObject_GetCancelling write TDragObject_PutCancelling;'); + RegisterFakeHeader(G, + 'function TDragObject_GetDragPos:TPoint;', + @TDragObject_GetDragPos); + RegisterFakeHeader(G, + 'procedure TDragObject_PutDragPos(const Value: TPoint);', + @TDragObject_PutDragPos); + RegisterProperty(G, + 'property DragPos:TPoint read TDragObject_GetDragPos write TDragObject_PutDragPos;'); + RegisterFakeHeader(G, + 'function TDragObject_GetDragTargetPos:TPoint;', + @TDragObject_GetDragTargetPos); + RegisterFakeHeader(G, + 'procedure TDragObject_PutDragTargetPos(const Value: TPoint);', + @TDragObject_PutDragTargetPos); + RegisterProperty(G, + 'property DragTargetPos:TPoint read TDragObject_GetDragTargetPos write TDragObject_PutDragTargetPos;'); + RegisterFakeHeader(G, + 'function TDragObject_GetDragTarget:Pointer;', + @TDragObject_GetDragTarget); + RegisterFakeHeader(G, + 'procedure TDragObject_PutDragTarget(const Value: Pointer);', + @TDragObject_PutDragTarget); + RegisterProperty(G, + 'property DragTarget:Pointer read TDragObject_GetDragTarget write TDragObject_PutDragTarget;'); + RegisterFakeHeader(G, + 'function TDragObject_GetDropped:Boolean;', + @TDragObject_GetDropped); + RegisterProperty(G, + 'property Dropped:Boolean read TDragObject_GetDropped;'); + RegisterFakeHeader(G, + 'function TDragObject_GetMouseDeltaX:Double;', + @TDragObject_GetMouseDeltaX); + RegisterProperty(G, + 'property MouseDeltaX:Double read TDragObject_GetMouseDeltaX;'); + RegisterFakeHeader(G, + 'function TDragObject_GetMouseDeltaY:Double;', + @TDragObject_GetMouseDeltaY); + RegisterProperty(G, + 'property MouseDeltaY:Double read TDragObject_GetMouseDeltaY;'); + RegisterHeader(G, + 'constructor Create;', + @TDragObject.Create); + // End of class TDragObject + RegisterClassReferenceType(H, 'TDragObjectClass'); + // Begin of class TDragObjectEx + G := RegisterClassType(H, TDragObjectEx); + RegisterHeader(G, + 'procedure BeforeDestruction; override;', + @TDragObjectEx.BeforeDestruction); + RegisterHeader(G, + 'constructor Create;', + @TDragObjectEx.Create); + // End of class TDragObjectEx + // Begin of class TBaseDragControlObject + G := RegisterClassType(H, TBaseDragControlObject); + RegisterHeader(G, + 'constructor Create(AControl: TControl); virtual;', + @TBaseDragControlObject.Create); + RegisterHeader(G, + 'procedure Assign(Source: TDragObject); override;', + @TBaseDragControlObject.Assign); + RegisterFakeHeader(G, + 'function TBaseDragControlObject_GetControl:TControl;', + @TBaseDragControlObject_GetControl); + RegisterFakeHeader(G, + 'procedure TBaseDragControlObject_PutControl(const Value: TControl);', + @TBaseDragControlObject_PutControl); + RegisterProperty(G, + 'property Control:TControl read TBaseDragControlObject_GetControl write TBaseDragControlObject_PutControl;'); + // End of class TBaseDragControlObject + // Begin of class TDragControlObject + G := RegisterClassType(H, TDragControlObject); + RegisterHeader(G, + 'procedure HideDragImage; override;', + @TDragControlObject.HideDragImage); + RegisterHeader(G, + 'procedure ShowDragImage; override;', + @TDragControlObject.ShowDragImage); + RegisterHeader(G, + 'constructor Create(AControl: TControl); virtual;', + @TDragControlObject.Create); + // End of class TDragControlObject + // Begin of class TDragControlObjectEx + G := RegisterClassType(H, TDragControlObjectEx); + RegisterHeader(G, + 'procedure BeforeDestruction; override;', + @TDragControlObjectEx.BeforeDestruction); + RegisterHeader(G, + 'constructor Create(AControl: TControl); virtual;', + @TDragControlObjectEx.Create); + // End of class TDragControlObjectEx + // Begin of class TDragDockObject + G := RegisterClassType(H, TDragDockObject); + RegisterHeader(G, + 'constructor Create(AControl: TControl); override;', + @TDragDockObject.Create); + RegisterHeader(G, + 'destructor Destroy; override;', + @TDragDockObject.Destroy); + RegisterHeader(G, + 'procedure Assign(Source: TDragObject); override;', + @TDragDockObject.Assign); + RegisterFakeHeader(G, + 'function TDragDockObject_GetDockRect:TRect;', + @TDragDockObject_GetDockRect); + RegisterFakeHeader(G, + 'procedure TDragDockObject_PutDockRect(const Value: TRect);', + @TDragDockObject_PutDockRect); + RegisterProperty(G, + 'property DockRect:TRect read TDragDockObject_GetDockRect write TDragDockObject_PutDockRect;'); + RegisterFakeHeader(G, + 'function TDragDockObject_GetDropAlign:TAlign;', + @TDragDockObject_GetDropAlign); + RegisterProperty(G, + 'property DropAlign:TAlign read TDragDockObject_GetDropAlign;'); + RegisterFakeHeader(G, + 'function TDragDockObject_GetDropOnControl:TControl;', + @TDragDockObject_GetDropOnControl); + RegisterProperty(G, + 'property DropOnControl:TControl read TDragDockObject_GetDropOnControl;'); + RegisterFakeHeader(G, + 'function TDragDockObject_GetFloating:Boolean;', + @TDragDockObject_GetFloating); + RegisterFakeHeader(G, + 'procedure TDragDockObject_PutFloating(const Value: Boolean);', + @TDragDockObject_PutFloating); + RegisterProperty(G, + 'property Floating:Boolean read TDragDockObject_GetFloating write TDragDockObject_PutFloating;'); + RegisterFakeHeader(G, + 'function TDragDockObject_GetFrameWidth:Integer;', + @TDragDockObject_GetFrameWidth); + RegisterProperty(G, + 'property FrameWidth:Integer read TDragDockObject_GetFrameWidth;'); + // End of class TDragDockObject + // Begin of class TDragDockObjectEx + G := RegisterClassType(H, TDragDockObjectEx); + RegisterHeader(G, + 'procedure BeforeDestruction; override;', + @TDragDockObjectEx.BeforeDestruction); + RegisterHeader(G, + 'constructor Create;', + @TDragDockObjectEx.Create); + // End of class TDragDockObjectEx + // Begin of class TControlCanvas + G := RegisterClassType(H, TControlCanvas); + RegisterHeader(G, + 'destructor Destroy; override;', + @TControlCanvas.Destroy); + RegisterHeader(G, + 'procedure FreeHandle;', + @TControlCanvas.FreeHandle); + RegisterHeader(G, + 'procedure UpdateTextFlags;', + @TControlCanvas.UpdateTextFlags); + RegisterFakeHeader(G, + 'function TControlCanvas_GetControl:TControl;', + @TControlCanvas_GetControl); + RegisterFakeHeader(G, + 'procedure TControlCanvas_PutControl(const Value: TControl);', + @TControlCanvas_PutControl); + RegisterProperty(G, + 'property Control:TControl read TControlCanvas_GetControl write TControlCanvas_PutControl;'); + RegisterHeader(G, + 'constructor Create(AOwner: TComponent); virtual;', + @TControlCanvas.Create); + // End of class TControlCanvas + // Begin of class TControlActionLink + G := RegisterClassType(H, TControlActionLink); + RegisterHeader(G, + 'constructor Create(AOwner: TComponent); virtual;', + @TControlActionLink.Create); + // End of class TControlActionLink + RegisterClassReferenceType(H, 'TControlActionLinkClass'); + RegisterRTTIType(H, TypeInfo(TControlState)); + RegisterRTTIType(H, TypeInfo(TControlStyle)); + RegisterRTTIType(H, TypeInfo(TMouseButton)); + RegisterRTTIType(H, TypeInfo(TDragMode)); + RegisterRTTIType(H, TypeInfo(TDragState)); + RegisterRTTIType(H, TypeInfo(TDragKind)); + RegisterRTTIType(H, TypeInfo(TTabOrder)); + RegisterTypeAlias(H, 'TCaption:string'); + RegisterTypeAlias(H, 'TDate:TDateTime'); + RegisterTypeAlias(H, 'TTime:TDateTime'); + RegisterRTTIType(H, TypeInfo(TScalingFlags)); + RegisterRTTIType(H, TypeInfo(TAnchorKind)); + RegisterRTTIType(H, TypeInfo(TAnchors)); + RegisterRTTIType(H, TypeInfo(TConstraintSize)); + // Begin of class TSizeConstraints + G := RegisterClassType(H, TSizeConstraints); + RegisterHeader(G, + 'constructor Create(Control: TControl); virtual;', + @TSizeConstraints.Create); + // End of class TSizeConstraints + RegisterRTTIType(H, TypeInfo(TDockOrientation)); + // Begin of class TControl + G := RegisterClassType(H, TControl); + RegisterHeader(G, + 'constructor Create(AOwner: TComponent); override;', + @TControl.Create); + RegisterHeader(G, + 'destructor Destroy; override;', + @TControl.Destroy); + RegisterHeader(G, + 'procedure BeginDrag(Immediate: Boolean; Threshold: Integer = -1);', + @TControl.BeginDrag); + RegisterHeader(G, + 'procedure BringToFront;', + @TControl.BringToFront); + RegisterHeader(G, + 'function ClientToScreen(const Point: TPoint): TPoint;', + @TControl.ClientToScreen); + RegisterHeader(G, + 'function ClientToParent(const Point: TPoint; AParent: TWinControl = nil): TPoint;', + @TControl.ClientToParent); + RegisterHeader(G, + 'procedure Dock(NewDockSite: TWinControl; ARect: TRect); dynamic;', + @TControl.Dock); + RegisterHeader(G, + 'procedure DefaultHandler(var Message); override;', + @TControl.DefaultHandler); + RegisterHeader(G, + 'function Dragging: Boolean;', + @TControl.Dragging); + RegisterHeader(G, + 'procedure DragDrop(Source: TObject; X, Y: Integer); dynamic;', + @TControl.DragDrop); + RegisterHeader(G, + 'function DrawTextBiDiModeFlags(Flags: Longint): Longint;', + @TControl.DrawTextBiDiModeFlags); + RegisterHeader(G, + 'function DrawTextBiDiModeFlagsReadingOnly: Longint;', + @TControl.DrawTextBiDiModeFlagsReadingOnly); + RegisterFakeHeader(G, + 'function TControl_GetEnabled:Boolean;', + @TControl_GetEnabled); + RegisterFakeHeader(G, + 'procedure TControl_PutEnabled(const Value: Boolean);', + @TControl_PutEnabled); + RegisterProperty(G, + 'property Enabled:Boolean read TControl_GetEnabled write TControl_PutEnabled;'); + RegisterHeader(G, + 'procedure EndDrag(Drop: Boolean);', + @TControl.EndDrag); + RegisterHeader(G, + 'function GetParentComponent: TComponent; override;', + @TControl.GetParentComponent); + RegisterHeader(G, + 'function GetTextBuf(Buffer: PChar; BufSize: Integer): Integer;', + @TControl.GetTextBuf); + RegisterHeader(G, + 'function GetTextLen: Integer;', + @TControl.GetTextLen); + RegisterHeader(G, + 'function HasParent: Boolean; override;', + @TControl.HasParent); + RegisterHeader(G, + 'procedure Hide;', + @TControl.Hide); + RegisterHeader(G, + 'procedure InitiateAction; virtual;', + @TControl.InitiateAction); + RegisterHeader(G, + 'procedure Invalidate; virtual;', + @TControl.Invalidate); + RegisterHeader(G, + 'function IsRightToLeft: Boolean;', + @TControl.IsRightToLeft); + RegisterHeader(G, + 'function ManualFloat(ScreenPos: TRect): Boolean;', + @TControl.ManualFloat); + RegisterHeader(G, + 'function Perform(Msg: Cardinal; WParam, LParam: Longint): Longint;', + @TControl.Perform); + RegisterHeader(G, + 'procedure Refresh;', + @TControl.Refresh); + RegisterHeader(G, + 'procedure Repaint; virtual;', + @TControl.Repaint); + RegisterHeader(G, + 'function ReplaceDockedControl(Control: TControl; NewDockSite: TWinControl; DropControl: TControl; ControlSide: TAlign): Boolean;', + @TControl.ReplaceDockedControl); + RegisterHeader(G, + 'function ScreenToClient(const Point: TPoint): TPoint;', + @TControl.ScreenToClient); + RegisterHeader(G, + 'function ParentToClient(const Point: TPoint; AParent: TWinControl = nil): TPoint;', + @TControl.ParentToClient); + RegisterHeader(G, + 'procedure SendToBack;', + @TControl.SendToBack); + RegisterHeader(G, + 'procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); virtual;', + @TControl.SetBounds); + RegisterHeader(G, + 'procedure SetTextBuf(Buffer: PChar);', + @TControl.SetTextBuf); + RegisterHeader(G, + 'procedure Show;', + @TControl.Show); + RegisterHeader(G, + 'procedure Update; virtual;', + @TControl.Update); + RegisterHeader(G, + 'function UseRightToLeftAlignment: Boolean; dynamic;', + @TControl.UseRightToLeftAlignment); + RegisterHeader(G, + 'function UseRightToLeftReading: Boolean;', + @TControl.UseRightToLeftReading); + RegisterHeader(G, + 'function UseRightToLeftScrollBar: Boolean;', + @TControl.UseRightToLeftScrollBar); + RegisterFakeHeader(G, + 'function TControl_GetAlign:TAlign;', + @TControl_GetAlign); + RegisterFakeHeader(G, + 'procedure TControl_PutAlign(const Value: TAlign);', + @TControl_PutAlign); + RegisterProperty(G, + 'property Align:TAlign read TControl_GetAlign write TControl_PutAlign;'); + RegisterFakeHeader(G, + 'function TControl_GetBoundsRect:TRect;', + @TControl_GetBoundsRect); + RegisterFakeHeader(G, + 'procedure TControl_PutBoundsRect(const Value: TRect);', + @TControl_PutBoundsRect); + RegisterProperty(G, + 'property BoundsRect:TRect read TControl_GetBoundsRect write TControl_PutBoundsRect;'); + RegisterFakeHeader(G, + 'function TControl_GetClientHeight:Integer;', + @TControl_GetClientHeight); + RegisterFakeHeader(G, + 'procedure TControl_PutClientHeight(const Value: Integer);', + @TControl_PutClientHeight); + RegisterProperty(G, + 'property ClientHeight:Integer read TControl_GetClientHeight write TControl_PutClientHeight;'); + RegisterFakeHeader(G, + 'function TControl_GetClientOrigin:TPoint;', + @TControl_GetClientOrigin); + RegisterProperty(G, + 'property ClientOrigin:TPoint read TControl_GetClientOrigin;'); + RegisterFakeHeader(G, + 'function TControl_GetClientRect:TRect;', + @TControl_GetClientRect); + RegisterProperty(G, + 'property ClientRect:TRect read TControl_GetClientRect;'); + RegisterFakeHeader(G, + 'function TControl_GetClientWidth:Integer;', + @TControl_GetClientWidth); + RegisterFakeHeader(G, + 'procedure TControl_PutClientWidth(const Value: Integer);', + @TControl_PutClientWidth); + RegisterProperty(G, + 'property ClientWidth:Integer read TControl_GetClientWidth write TControl_PutClientWidth;'); + RegisterFakeHeader(G, + 'function TControl_GetConstraints:TSizeConstraints;', + @TControl_GetConstraints); + RegisterFakeHeader(G, + 'procedure TControl_PutConstraints(const Value: TSizeConstraints);', + @TControl_PutConstraints); + RegisterProperty(G, + 'property Constraints:TSizeConstraints read TControl_GetConstraints write TControl_PutConstraints;'); + RegisterFakeHeader(G, + 'function TControl_GetControlState:TControlState;', + @TControl_GetControlState); + RegisterFakeHeader(G, + 'procedure TControl_PutControlState(const Value: TControlState);', + @TControl_PutControlState); + RegisterProperty(G, + 'property ControlState:TControlState read TControl_GetControlState write TControl_PutControlState;'); + RegisterFakeHeader(G, + 'function TControl_GetControlStyle:TControlStyle;', + @TControl_GetControlStyle); + RegisterFakeHeader(G, + 'procedure TControl_PutControlStyle(const Value: TControlStyle);', + @TControl_PutControlStyle); + RegisterProperty(G, + 'property ControlStyle:TControlStyle read TControl_GetControlStyle write TControl_PutControlStyle;'); + RegisterFakeHeader(G, + 'function TControl_GetDockOrientation:TDockOrientation;', + @TControl_GetDockOrientation); + RegisterFakeHeader(G, + 'procedure TControl_PutDockOrientation(const Value: TDockOrientation);', + @TControl_PutDockOrientation); + RegisterProperty(G, + 'property DockOrientation:TDockOrientation read TControl_GetDockOrientation write TControl_PutDockOrientation;'); + RegisterFakeHeader(G, + 'function TControl_GetFloating:Boolean;', + @TControl_GetFloating); + RegisterProperty(G, + 'property Floating:Boolean read TControl_GetFloating;'); + RegisterFakeHeader(G, + 'function TControl_GetFloatingDockSiteClass:TWinControlClass;', + @TControl_GetFloatingDockSiteClass); + RegisterFakeHeader(G, + 'procedure TControl_PutFloatingDockSiteClass(const Value: TWinControlClass);', + @TControl_PutFloatingDockSiteClass); + RegisterProperty(G, + 'property FloatingDockSiteClass:TWinControlClass read TControl_GetFloatingDockSiteClass write TControl_PutFloatingDockSiteClass;'); + RegisterFakeHeader(G, + 'function TControl_GetHostDockSite:TWinControl;', + @TControl_GetHostDockSite); + RegisterFakeHeader(G, + 'procedure TControl_PutHostDockSite(const Value: TWinControl);', + @TControl_PutHostDockSite); + RegisterProperty(G, + 'property HostDockSite:TWinControl read TControl_GetHostDockSite write TControl_PutHostDockSite;'); + RegisterFakeHeader(G, + 'function TControl_GetLRDockWidth:Integer;', + @TControl_GetLRDockWidth); + RegisterFakeHeader(G, + 'procedure TControl_PutLRDockWidth(const Value: Integer);', + @TControl_PutLRDockWidth); + RegisterProperty(G, + 'property LRDockWidth:Integer read TControl_GetLRDockWidth write TControl_PutLRDockWidth;'); + RegisterFakeHeader(G, + 'function TControl_GetParent:TWinControl;', + @TControl_GetParent); + RegisterFakeHeader(G, + 'procedure TControl_PutParent(const Value: TWinControl);', + @TControl_PutParent); + RegisterProperty(G, + 'property Parent:TWinControl read TControl_GetParent write TControl_PutParent;'); + RegisterFakeHeader(G, + 'function TControl_GetShowHint:Boolean;', + @TControl_GetShowHint); + RegisterFakeHeader(G, + 'procedure TControl_PutShowHint(const Value: Boolean);', + @TControl_PutShowHint); + RegisterProperty(G, + 'property ShowHint:Boolean read TControl_GetShowHint write TControl_PutShowHint;'); + RegisterFakeHeader(G, + 'function TControl_GetTBDockHeight:Integer;', + @TControl_GetTBDockHeight); + RegisterFakeHeader(G, + 'procedure TControl_PutTBDockHeight(const Value: Integer);', + @TControl_PutTBDockHeight); + RegisterProperty(G, + 'property TBDockHeight:Integer read TControl_GetTBDockHeight write TControl_PutTBDockHeight;'); + RegisterFakeHeader(G, + 'function TControl_GetUndockHeight:Integer;', + @TControl_GetUndockHeight); + RegisterFakeHeader(G, + 'procedure TControl_PutUndockHeight(const Value: Integer);', + @TControl_PutUndockHeight); + RegisterProperty(G, + 'property UndockHeight:Integer read TControl_GetUndockHeight write TControl_PutUndockHeight;'); + RegisterFakeHeader(G, + 'function TControl_GetUndockWidth:Integer;', + @TControl_GetUndockWidth); + RegisterFakeHeader(G, + 'procedure TControl_PutUndockWidth(const Value: Integer);', + @TControl_PutUndockWidth); + RegisterProperty(G, + 'property UndockWidth:Integer read TControl_GetUndockWidth write TControl_PutUndockWidth;'); + RegisterFakeHeader(G, + 'function TControl_GetVisible:Boolean;', + @TControl_GetVisible); + RegisterFakeHeader(G, + 'procedure TControl_PutVisible(const Value: Boolean);', + @TControl_PutVisible); + RegisterProperty(G, + 'property Visible:Boolean read TControl_GetVisible write TControl_PutVisible;'); + // End of class TControl + RegisterClassReferenceType(H, 'TControlClass'); + // Begin of class TWinControlActionLink + G := RegisterClassType(H, TWinControlActionLink); + RegisterHeader(G, + 'constructor Create(AOwner: TComponent); virtual;', + @TWinControlActionLink.Create); + // End of class TWinControlActionLink + RegisterClassReferenceType(H, 'TWinControlActionLinkClass'); + RegisterRTTIType(H, TypeInfo(TImeMode)); + RegisterTypeAlias(H, 'TImeName:string'); + RegisterRTTIType(H, TypeInfo(TBorderWidth)); + RegisterRTTIType(H, TypeInfo(TBevelCut)); + RegisterRTTIType(H, TypeInfo(TBevelEdge)); + RegisterRTTIType(H, TypeInfo(TBevelEdges)); + RegisterRTTIType(H, TypeInfo(TBevelKind)); + RegisterRTTIType(H, TypeInfo(TBevelWidth)); + // Begin of interface IDockManager + G := RegisterInterfaceType(H, 'IDockManager',IDockManager); + RegisterHeader(G, + 'procedure BeginUpdate;', nil,4); + RegisterHeader(G, + 'procedure EndUpdate;', nil,5); + RegisterHeader(G, + 'procedure GetControlBounds(Control: TControl; out CtlBounds: TRect);', nil,6); + RegisterHeader(G, + 'procedure InsertControl(Control: TControl; InsertAt: TAlign; DropCtl: TControl);', nil,7); + RegisterHeader(G, + 'procedure PositionDockRect(Client, DropCtl: TControl; DropAlign: TAlign; var DockRect: TRect);', nil,10); + RegisterHeader(G, + 'procedure RemoveControl(Control: TControl);', nil,11); + RegisterHeader(G, + 'procedure ResetBounds(Force: Boolean);', nil,12); + RegisterHeader(G, + 'procedure SetReplacingControl(Control: TControl);', nil,14); + // End of interface IDockManager + // Begin of class TWinControl + G := RegisterClassType(H, TWinControl); + RegisterHeader(G, + 'constructor Create(AOwner: TComponent); override;', + @TWinControl.Create); + RegisterHeader(G, + 'destructor Destroy; override;', + @TWinControl.Destroy); + RegisterHeader(G, + 'procedure Broadcast(var Message);', + @TWinControl.Broadcast); + RegisterHeader(G, + 'function CanFocus: Boolean; dynamic;', + @TWinControl.CanFocus); + RegisterHeader(G, + 'function ContainsControl(Control: TControl): Boolean;', + @TWinControl.ContainsControl); + RegisterHeader(G, + 'function ControlAtPos(const Pos: TPoint; AllowDisabled: Boolean; AllowWinControls: Boolean = False): TControl;', + @TWinControl.ControlAtPos); + RegisterHeader(G, + 'procedure DefaultHandler(var Message); override;', + @TWinControl.DefaultHandler); + RegisterHeader(G, + 'procedure DisableAlign;', + @TWinControl.DisableAlign); + RegisterFakeHeader(G, + 'function TWinControl_GetDockClientCount:Integer;', + @TWinControl_GetDockClientCount); + RegisterProperty(G, + 'property DockClientCount:Integer read TWinControl_GetDockClientCount;'); + RegisterFakeHeader(G, + 'function TWinControl_GetDockClients(Index: Integer):TControl;', + @TWinControl_GetDockClients); + RegisterProperty(G, + 'property DockClients[Index: Integer]:TControl read TWinControl_GetDockClients;'); + RegisterHeader(G, + 'procedure DockDrop(Source: TDragDockObject; X, Y: Integer); dynamic;', + @TWinControl.DockDrop); + RegisterFakeHeader(G, + 'function TWinControl_GetDoubleBuffered:Boolean;', + @TWinControl_GetDoubleBuffered); + RegisterFakeHeader(G, + 'procedure TWinControl_PutDoubleBuffered(const Value: Boolean);', + @TWinControl_PutDoubleBuffered); + RegisterProperty(G, + 'property DoubleBuffered:Boolean read TWinControl_GetDoubleBuffered write TWinControl_PutDoubleBuffered;'); + RegisterHeader(G, + 'procedure EnableAlign;', + @TWinControl.EnableAlign); + RegisterHeader(G, + 'function FindChildControl(const ControlName: string): TControl;', + @TWinControl.FindChildControl); + RegisterHeader(G, + 'procedure FlipChildren(AllLevels: Boolean); dynamic;', + @TWinControl.FlipChildren); + RegisterHeader(G, + 'function Focused: Boolean; dynamic;', + @TWinControl.Focused); + RegisterHeader(G, + 'function HandleAllocated: Boolean;', + @TWinControl.HandleAllocated); + RegisterHeader(G, + 'procedure HandleNeeded;', + @TWinControl.HandleNeeded); + RegisterHeader(G, + 'procedure InsertControl(AControl: TControl);', + @TWinControl.InsertControl); + RegisterHeader(G, + 'procedure Invalidate; override;', + @TWinControl.Invalidate); + RegisterHeader(G, + 'procedure RemoveControl(AControl: TControl);', + @TWinControl.RemoveControl); + RegisterHeader(G, + 'procedure Realign;', + @TWinControl.Realign); + RegisterHeader(G, + 'procedure Repaint; override;', + @TWinControl.Repaint); + RegisterHeader(G, + 'procedure ScaleBy(M, D: Integer);', + @TWinControl.ScaleBy); + RegisterHeader(G, + 'procedure ScrollBy(DeltaX, DeltaY: Integer);', + @TWinControl.ScrollBy); + RegisterHeader(G, + 'procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;', + @TWinControl.SetBounds); + RegisterHeader(G, + 'procedure SetFocus; virtual;', + @TWinControl.SetFocus); + RegisterHeader(G, + 'procedure Update; override;', + @TWinControl.Update); + RegisterHeader(G, + 'procedure UpdateControlState;', + @TWinControl.UpdateControlState); + RegisterFakeHeader(G, + 'function TWinControl_GetAlignDisabled:Boolean;', + @TWinControl_GetAlignDisabled); + RegisterProperty(G, + 'property AlignDisabled:Boolean read TWinControl_GetAlignDisabled;'); + RegisterFakeHeader(G, + 'function TWinControl_GetVisibleDockClientCount:Integer;', + @TWinControl_GetVisibleDockClientCount); + RegisterProperty(G, + 'property VisibleDockClientCount:Integer read TWinControl_GetVisibleDockClientCount;'); + RegisterFakeHeader(G, + 'function TWinControl_GetControls(Index: Integer):TControl;', + @TWinControl_GetControls); + RegisterProperty(G, + 'property Controls[Index: Integer]:TControl read TWinControl_GetControls;'); + RegisterFakeHeader(G, + 'function TWinControl_GetControlCount:Integer;', + @TWinControl_GetControlCount); + RegisterProperty(G, + 'property ControlCount:Integer read TWinControl_GetControlCount;'); + RegisterFakeHeader(G, + 'function TWinControl_GetShowing:Boolean;', + @TWinControl_GetShowing); + RegisterProperty(G, + 'property Showing:Boolean read TWinControl_GetShowing;'); + RegisterFakeHeader(G, + 'function TWinControl_GetTabOrder:TTabOrder;', + @TWinControl_GetTabOrder); + RegisterFakeHeader(G, + 'procedure TWinControl_PutTabOrder(const Value: TTabOrder);', + @TWinControl_PutTabOrder); + RegisterProperty(G, + 'property TabOrder:TTabOrder read TWinControl_GetTabOrder write TWinControl_PutTabOrder;'); + RegisterFakeHeader(G, + 'function TWinControl_GetTabStop:Boolean;', + @TWinControl_GetTabStop); + RegisterFakeHeader(G, + 'procedure TWinControl_PutTabStop(const Value: Boolean);', + @TWinControl_PutTabStop); + RegisterProperty(G, + 'property TabStop:Boolean read TWinControl_GetTabStop write TWinControl_PutTabStop;'); + // End of class TWinControl + // Begin of class TGraphicControl + G := RegisterClassType(H, TGraphicControl); + RegisterHeader(G, + 'constructor Create(AOwner: TComponent); override;', + @TGraphicControl.Create); + RegisterHeader(G, + 'destructor Destroy; override;', + @TGraphicControl.Destroy); + // End of class TGraphicControl + // Begin of class TCustomControl + G := RegisterClassType(H, TCustomControl); + RegisterHeader(G, + 'constructor Create(AOwner: TComponent); override;', + @TCustomControl.Create); + RegisterHeader(G, + 'destructor Destroy; override;', + @TCustomControl.Destroy); + // End of class TCustomControl + // Begin of class THintWindow + G := RegisterClassType(H, THintWindow); + RegisterHeader(G, + 'constructor Create(AOwner: TComponent); override;', + @THintWindow.Create); + RegisterHeader(G, + 'procedure ActivateHint(Rect: TRect; const AHint: string); virtual;', + @THintWindow.ActivateHint); + RegisterHeader(G, + 'procedure ActivateHintData(Rect: TRect; const AHint: string; AData: Pointer); virtual;', + @THintWindow.ActivateHintData); + RegisterHeader(G, + 'function CalcHintRect(MaxWidth: Integer; const AHint: string; AData: Pointer): TRect; virtual;', + @THintWindow.CalcHintRect); + RegisterHeader(G, + 'procedure ReleaseHandle;', + @THintWindow.ReleaseHandle); + // End of class THintWindow + RegisterClassReferenceType(H, 'THintWindowClass'); + // Begin of class TDragImageList + G := RegisterClassType(H, TDragImageList); + RegisterHeader(G, + 'function DragMove(X, Y: Integer): Boolean;', + @TDragImageList.DragMove); + RegisterHeader(G, + 'procedure DragUnlock;', + @TDragImageList.DragUnlock); + RegisterHeader(G, + 'function EndDrag: Boolean;', + @TDragImageList.EndDrag); + RegisterHeader(G, + 'function GetHotSpot: TPoint; override;', + @TDragImageList.GetHotSpot); + RegisterHeader(G, + 'procedure HideDragImage;', + @TDragImageList.HideDragImage); + RegisterHeader(G, + 'function SetDragImage(Index, HotSpotX, HotSpotY: Integer): Boolean;', + @TDragImageList.SetDragImage); + RegisterHeader(G, + 'procedure ShowDragImage;', + @TDragImageList.ShowDragImage); + RegisterFakeHeader(G, + 'function TDragImageList_GetDragCursor:TCursor;', + @TDragImageList_GetDragCursor); + RegisterFakeHeader(G, + 'procedure TDragImageList_PutDragCursor(const Value: TCursor);', + @TDragImageList_PutDragCursor); + RegisterProperty(G, + 'property DragCursor:TCursor read TDragImageList_GetDragCursor write TDragImageList_PutDragCursor;'); + RegisterFakeHeader(G, + 'function TDragImageList_GetDragging:Boolean;', + @TDragImageList_GetDragging); + RegisterProperty(G, + 'property Dragging:Boolean read TDragImageList_GetDragging;'); + RegisterHeader(G, + 'constructor Create(AOwner: TComponent); virtual;', + @TDragImageList.Create); + // End of class TDragImageList + // Begin of class TImageList + G := RegisterClassType(H, TImageList); + RegisterHeader(G, + 'constructor Create;', + @TImageList.Create); + // End of class TImageList + // Begin of class TDockTree + G := RegisterClassType(H, TDockTree); + // End of class TDockTree + // Begin of class TDockZone + G := RegisterClassType(H, TDockZone); + RegisterHeader(G, + 'constructor Create(Tree: TDockTree);', + @TDockZone.Create); + RegisterHeader(G, + 'procedure ExpandZoneLimit(NewLimit: Integer);', + @TDockZone.ExpandZoneLimit); + RegisterHeader(G, + 'function FirstVisibleChild: TDockZone;', + @TDockZone.FirstVisibleChild); + RegisterHeader(G, + 'function NextVisible: TDockZone;', + @TDockZone.NextVisible); + RegisterHeader(G, + 'function PrevVisible: TDockZone;', + @TDockZone.PrevVisible); + RegisterHeader(G, + 'procedure ResetChildren;', + @TDockZone.ResetChildren); + RegisterHeader(G, + 'procedure ResetZoneLimits;', + @TDockZone.ResetZoneLimits); + RegisterHeader(G, + 'procedure Update;', + @TDockZone.Update); + RegisterFakeHeader(G, + 'function TDockZone_GetChildCount:Integer;', + @TDockZone_GetChildCount); + RegisterProperty(G, + 'property ChildCount:Integer read TDockZone_GetChildCount;'); + RegisterFakeHeader(G, + 'function TDockZone_GetHeight:Integer;', + @TDockZone_GetHeight); + RegisterProperty(G, + 'property Height:Integer read TDockZone_GetHeight;'); + RegisterFakeHeader(G, + 'function TDockZone_GetLeft:Integer;', + @TDockZone_GetLeft); + RegisterProperty(G, + 'property Left:Integer read TDockZone_GetLeft;'); + RegisterFakeHeader(G, + 'function TDockZone_GetLimitBegin:Integer;', + @TDockZone_GetLimitBegin); + RegisterProperty(G, + 'property LimitBegin:Integer read TDockZone_GetLimitBegin;'); + RegisterFakeHeader(G, + 'function TDockZone_GetLimitSize:Integer;', + @TDockZone_GetLimitSize); + RegisterProperty(G, + 'property LimitSize:Integer read TDockZone_GetLimitSize;'); + RegisterFakeHeader(G, + 'function TDockZone_GetTop:Integer;', + @TDockZone_GetTop); + RegisterProperty(G, + 'property Top:Integer read TDockZone_GetTop;'); + RegisterFakeHeader(G, + 'function TDockZone_GetVisible:Boolean;', + @TDockZone_GetVisible); + RegisterProperty(G, + 'property Visible:Boolean read TDockZone_GetVisible;'); + RegisterFakeHeader(G, + 'function TDockZone_GetVisibleChildCount:Integer;', + @TDockZone_GetVisibleChildCount); + RegisterProperty(G, + 'property VisibleChildCount:Integer read TDockZone_GetVisibleChildCount;'); + RegisterFakeHeader(G, + 'function TDockZone_GetWidth:Integer;', + @TDockZone_GetWidth); + RegisterProperty(G, + 'property Width:Integer read TDockZone_GetWidth;'); + RegisterFakeHeader(G, + 'function TDockZone_GetZoneLimit:Integer;', + @TDockZone_GetZoneLimit); + RegisterFakeHeader(G, + 'procedure TDockZone_PutZoneLimit(const Value: Integer);', + @TDockZone_PutZoneLimit); + RegisterProperty(G, + 'property ZoneLimit:Integer read TDockZone_GetZoneLimit write TDockZone_PutZoneLimit;'); + // End of class TDockZone + RegisterClassReferenceType(H, 'TDockTreeClass'); + // Begin of class TDockTree + G := RegisterClassType(H, TDockTree); + RegisterHeader(G, + 'constructor Create(DockSite: TWinControl); virtual;', + @TDockTree.Create); + RegisterHeader(G, + 'destructor Destroy; override;', + @TDockTree.Destroy); + // End of class TDockTree + // Begin of class TMouse + G := RegisterClassType(H, TMouse); + RegisterHeader(G, + 'constructor Create;', + @TMouse.Create); + RegisterHeader(G, + 'destructor Destroy; override;', + @TMouse.Destroy); + RegisterHeader(G, + 'procedure SettingChanged(Setting: Integer);', + @TMouse.SettingChanged); + RegisterFakeHeader(G, + 'function TMouse_GetCursorPos:TPoint;', + @TMouse_GetCursorPos); + RegisterFakeHeader(G, + 'procedure TMouse_PutCursorPos(const Value: TPoint);', + @TMouse_PutCursorPos); + RegisterProperty(G, + 'property CursorPos:TPoint read TMouse_GetCursorPos write TMouse_PutCursorPos;'); + RegisterFakeHeader(G, + 'function TMouse_GetDragImmediate:Boolean;', + @TMouse_GetDragImmediate); + RegisterFakeHeader(G, + 'procedure TMouse_PutDragImmediate(const Value: Boolean);', + @TMouse_PutDragImmediate); + RegisterProperty(G, + 'property DragImmediate:Boolean read TMouse_GetDragImmediate write TMouse_PutDragImmediate;'); + RegisterFakeHeader(G, + 'function TMouse_GetDragThreshold:Integer;', + @TMouse_GetDragThreshold); + RegisterFakeHeader(G, + 'procedure TMouse_PutDragThreshold(const Value: Integer);', + @TMouse_PutDragThreshold); + RegisterProperty(G, + 'property DragThreshold:Integer read TMouse_GetDragThreshold write TMouse_PutDragThreshold;'); + RegisterFakeHeader(G, + 'function TMouse_GetMousePresent:Boolean;', + @TMouse_GetMousePresent); + RegisterProperty(G, + 'property MousePresent:Boolean read TMouse_GetMousePresent;'); + RegisterFakeHeader(G, + 'function TMouse_GetIsDragging:Boolean;', + @TMouse_GetIsDragging); + RegisterProperty(G, + 'property IsDragging:Boolean read TMouse_GetIsDragging;'); + RegisterFakeHeader(G, + 'function TMouse_GetWheelPresent:Boolean;', + @TMouse_GetWheelPresent); + RegisterProperty(G, + 'property WheelPresent:Boolean read TMouse_GetWheelPresent;'); + RegisterFakeHeader(G, + 'function TMouse_GetWheelScrollLines:Integer;', + @TMouse_GetWheelScrollLines); + RegisterProperty(G, + 'property WheelScrollLines:Integer read TMouse_GetWheelScrollLines;'); + // End of class TMouse + // Begin of class TCustomListControl + G := RegisterClassType(H, TCustomListControl); + RegisterHeader(G, + 'procedure MoveSelection(Destination: TCustomListControl); virtual;', + @TCustomListControl.MoveSelection); + RegisterFakeHeader(G, + 'function TCustomListControl_GetItemIndex:Integer;', + @TCustomListControl_GetItemIndex); + RegisterFakeHeader(G, + 'procedure TCustomListControl_PutItemIndex(const Value: Integer);', + @TCustomListControl_PutItemIndex); + RegisterProperty(G, + 'property ItemIndex:Integer read TCustomListControl_GetItemIndex write TCustomListControl_PutItemIndex;'); + RegisterHeader(G, + 'constructor Create;', + @TCustomListControl.Create); + // End of class TCustomListControl + // Begin of class TCustomMultiSelectListControl + G := RegisterClassType(H, TCustomMultiSelectListControl); + RegisterFakeHeader(G, + 'function TCustomMultiSelectListControl_GetMultiSelect:Boolean;', + @TCustomMultiSelectListControl_GetMultiSelect); + RegisterFakeHeader(G, + 'procedure TCustomMultiSelectListControl_PutMultiSelect(const Value: Boolean);', + @TCustomMultiSelectListControl_PutMultiSelect); + RegisterProperty(G, + 'property MultiSelect:Boolean read TCustomMultiSelectListControl_GetMultiSelect write TCustomMultiSelectListControl_PutMultiSelect;'); + RegisterFakeHeader(G, + 'function TCustomMultiSelectListControl_GetSelCount:Integer;', + @TCustomMultiSelectListControl_GetSelCount); + RegisterProperty(G, + 'property SelCount:Integer read TCustomMultiSelectListControl_GetSelCount;'); + RegisterHeader(G, + 'constructor Create;', + @TCustomMultiSelectListControl.Create); + // End of class TCustomMultiSelectListControl + RegisterVariable(H, 'Mouse: TMouse;',@Mouse); + RegisterHeader(H, 'function IsDragObject(Sender: TObject): Boolean;', @IsDragObject); + RegisterHeader(H, 'function FindVCLWindow(const Pos: TPoint): TWinControl;', @FindVCLWindow); + RegisterHeader(H, 'function FindDragTarget(const Pos: TPoint; AllowDisabled: Boolean): TControl;', @FindDragTarget); + RegisterHeader(H, 'function GetCaptureControl: TControl;', @GetCaptureControl); + RegisterHeader(H, 'procedure SetCaptureControl(Control: TControl);', @SetCaptureControl); + RegisterHeader(H, 'procedure CancelDrag;', @CancelDrag); + RegisterHeader(H, 'function CursorToString(Cursor: TCursor): string;', @CursorToString); + RegisterHeader(H, 'function StringToCursor(const S: string): TCursor;', @StringToCursor); + RegisterHeader(H, 'function CursorToIdent(Cursor: Longint; var Ident: string): Boolean;', @CursorToIdent); + RegisterHeader(H, 'function IdentToCursor(const Ident: string; var Cursor: Longint): Boolean;', @IdentToCursor); + RegisterHeader(H, 'function GetShortHint(const Hint: string): string;', @GetShortHint); + RegisterHeader(H, 'function GetLongHint(const Hint: string): string;', @GetLongHint); + RegisterConstant(H, 'CTL3D_ALL', $FFFF); + RegisterVariable(H, 'NewStyleControls: Boolean;',@NewStyleControls); + RegisterHeader(H, 'function SendAppMessage(Msg: Cardinal; WParam, LParam: Longint): Longint;', @SendAppMessage); + RegisterHeader(H, 'procedure SetImeName(Name: TImeName);', @SetImeName); + RegisterHeader(H, 'procedure DragDone(Drop: Boolean);', @DragDone); +end; +end. diff --git a/Demos/ANOTHER_DEMOS/IMPORT/IMPORT_Dialogs.pas b/Demos/ANOTHER_DEMOS/IMPORT/IMPORT_Dialogs.pas new file mode 100644 index 0000000..948006f --- /dev/null +++ b/Demos/ANOTHER_DEMOS/IMPORT/IMPORT_Dialogs.pas @@ -0,0 +1,244 @@ +{$I PaxCompiler.def} + +unit IMPORT_Dialogs; +interface +uses + SysUtils, + Classes, +{$IFDEF DPULSAR} + Winapi.Windows, + Winapi.Messages, + Winapi.CommDlg, + Vcl.Printers, + Vcl.Graphics, + Vcl.Controls, + Vcl.Forms, + Vcl.StdCtrls, + Vcl.Dialogs, +{$ELSE} + CommDlg, + Windows, + Messages, + Printers, + Graphics, + Controls, + Forms, + StdCtrls, + Dialogs, +{$ENDIF} + Variants, + PaxRegister, + PaxCompiler; +procedure Register_Dialogs; +implementation +function TOpenDialog_GetFileEditStyle(Self:TOpenDialog):TFileEditStyle; +begin + result := Self.FileEditStyle; +end; +procedure TOpenDialog_PutFileEditStyle(Self:TOpenDialog;const Value: TFileEditStyle); +begin + Self.FileEditStyle := Value; +end; +function TFindDialog_GetLeft(Self:TFindDialog):Integer; +begin + result := Self.Left; +end; +procedure TFindDialog_PutLeft(Self:TFindDialog;const Value: Integer); +begin + Self.Left := Value; +end; +function TFindDialog_GetPosition(Self:TFindDialog):TPoint; +begin + result := Self.Position; +end; +procedure TFindDialog_PutPosition(Self:TFindDialog;const Value: TPoint); +begin + Self.Position := Value; +end; +function TFindDialog_GetTop(Self:TFindDialog):Integer; +begin + result := Self.Top; +end; +procedure TFindDialog_PutTop(Self:TFindDialog;const Value: Integer); +begin + Self.Top := Value; +end; +procedure Register_Dialogs; +var G, H: Integer; +begin + H := RegisterNamespace(0, 'Dialogs'); + RegisterConstant(H, 'MaxCustomColors', 16); + // Begin of class TCommonDialog + G := RegisterClassType(H, TCommonDialog); + RegisterHeader(G, + 'constructor Create(AOwner: TComponent); override;', + @TCommonDialog.Create); + RegisterHeader(G, + 'destructor Destroy; override;', + @TCommonDialog.Destroy); + RegisterHeader(G, + 'procedure DefaultHandler(var Message); override;', + @TCommonDialog.DefaultHandler); + // End of class TCommonDialog + RegisterRTTIType(H, TypeInfo(TOpenOption)); + RegisterRTTIType(H, TypeInfo(TOpenOptions)); + RegisterRTTIType(H, TypeInfo(TOpenOptionEx)); + RegisterRTTIType(H, TypeInfo(TOpenOptionsEx)); + RegisterRTTIType(H, TypeInfo(TFileEditStyle)); + // Begin of class TOpenDialog + G := RegisterClassType(H, TOpenDialog); + RegisterHeader(G, + 'constructor Create(AOwner: TComponent); override;', + @TOpenDialog.Create); + RegisterHeader(G, + 'destructor Destroy; override;', + @TOpenDialog.Destroy); + RegisterHeader(G, + 'function Execute: Boolean; override;', + @TOpenDialog.Execute); + RegisterFakeHeader(G, + 'function TOpenDialog_GetFileEditStyle:TFileEditStyle;', + @TOpenDialog_GetFileEditStyle); + RegisterFakeHeader(G, + 'procedure TOpenDialog_PutFileEditStyle(const Value: TFileEditStyle);', + @TOpenDialog_PutFileEditStyle); + RegisterProperty(G, + 'property FileEditStyle:TFileEditStyle read TOpenDialog_GetFileEditStyle write TOpenDialog_PutFileEditStyle;'); + // End of class TOpenDialog + // Begin of class TSaveDialog + G := RegisterClassType(H, TSaveDialog); + RegisterHeader(G, + 'function Execute: Boolean; override;', + @TSaveDialog.Execute); + RegisterHeader(G, + 'constructor Create(AOwner: TComponent); override;', + @TSaveDialog.Create); + // End of class TSaveDialog + RegisterRTTIType(H, TypeInfo(TColorDialogOption)); + RegisterRTTIType(H, TypeInfo(TColorDialogOptions)); + // Begin of class TColorDialog + G := RegisterClassType(H, TColorDialog); + RegisterHeader(G, + 'constructor Create(AOwner: TComponent); override;', + @TColorDialog.Create); + RegisterHeader(G, + 'destructor Destroy; override;', + @TColorDialog.Destroy); + RegisterHeader(G, + 'function Execute: Boolean; override;', + @TColorDialog.Execute); + // End of class TColorDialog + RegisterRTTIType(H, TypeInfo(TFontDialogOption)); + RegisterRTTIType(H, TypeInfo(TFontDialogOptions)); + RegisterRTTIType(H, TypeInfo(TFontDialogDevice)); + // Begin of class TFontDialog + G := RegisterClassType(H, TFontDialog); + RegisterHeader(G, + 'constructor Create(AOwner: TComponent); override;', + @TFontDialog.Create); + RegisterHeader(G, + 'destructor Destroy; override;', + @TFontDialog.Destroy); + RegisterHeader(G, + 'function Execute: Boolean; override;', + @TFontDialog.Execute); + // End of class TFontDialog + // Begin of class TPrinterSetupDialog + G := RegisterClassType(H, TPrinterSetupDialog); + RegisterHeader(G, + 'function Execute: Boolean; override;', + @TPrinterSetupDialog.Execute); + RegisterHeader(G, + 'constructor Create(AOwner: TComponent); override;', + @TPrinterSetupDialog.Create); + // End of class TPrinterSetupDialog + RegisterRTTIType(H, TypeInfo(TPrintRange)); + RegisterRTTIType(H, TypeInfo(TPrintDialogOption)); + RegisterRTTIType(H, TypeInfo(TPrintDialogOptions)); + // Begin of class TPrintDialog + G := RegisterClassType(H, TPrintDialog); + RegisterHeader(G, + 'function Execute: Boolean; override;', + @TPrintDialog.Execute); + RegisterHeader(G, + 'constructor Create(AOwner: TComponent); override;', + @TPrintDialog.Create); + // End of class TPrintDialog + RegisterRTTIType(H, TypeInfo(TPageSetupDialogOption)); + RegisterRTTIType(H, TypeInfo(TPageSetupDialogOptions)); + RegisterRTTIType(H, TypeInfo(TPrinterKind)); + RegisterRTTIType(H, TypeInfo(TPageType)); + RegisterRTTIType(H, TypeInfo(TPageMeasureUnits)); + // Begin of class TPageSetupDialog + G := RegisterClassType(H, TPageSetupDialog); + RegisterHeader(G, + 'constructor Create(AOwner: TComponent); override;', + @TPageSetupDialog.Create); + RegisterHeader(G, + 'function Execute: Boolean; override;', + @TPageSetupDialog.Execute); + RegisterHeader(G, + 'function GetDefaults: Boolean;', + @TPageSetupDialog.GetDefaults); + // End of class TPageSetupDialog + RegisterRTTIType(H, TypeInfo(TFindOption)); + RegisterRTTIType(H, TypeInfo(TFindOptions)); + // Begin of class TFindDialog + G := RegisterClassType(H, TFindDialog); + RegisterHeader(G, + 'constructor Create(AOwner: TComponent); override;', + @TFindDialog.Create); + RegisterHeader(G, + 'destructor Destroy; override;', + @TFindDialog.Destroy); + RegisterHeader(G, + 'procedure CloseDialog;', + @TFindDialog.CloseDialog); + RegisterHeader(G, + 'function Execute: Boolean; override;', + @TFindDialog.Execute); + RegisterFakeHeader(G, + 'function TFindDialog_GetLeft:Integer;', + @TFindDialog_GetLeft); + RegisterFakeHeader(G, + 'procedure TFindDialog_PutLeft(const Value: Integer);', + @TFindDialog_PutLeft); + RegisterProperty(G, + 'property Left:Integer read TFindDialog_GetLeft write TFindDialog_PutLeft;'); + RegisterFakeHeader(G, + 'function TFindDialog_GetPosition:TPoint;', + @TFindDialog_GetPosition); + RegisterFakeHeader(G, + 'procedure TFindDialog_PutPosition(const Value: TPoint);', + @TFindDialog_PutPosition); + RegisterProperty(G, + 'property Position:TPoint read TFindDialog_GetPosition write TFindDialog_PutPosition;'); + RegisterFakeHeader(G, + 'function TFindDialog_GetTop:Integer;', + @TFindDialog_GetTop); + RegisterFakeHeader(G, + 'procedure TFindDialog_PutTop(const Value: Integer);', + @TFindDialog_PutTop); + RegisterProperty(G, + 'property Top:Integer read TFindDialog_GetTop write TFindDialog_PutTop;'); + // End of class TFindDialog + // Begin of class TReplaceDialog + G := RegisterClassType(H, TReplaceDialog); + RegisterHeader(G, + 'constructor Create(AOwner: TComponent); override;', + @TReplaceDialog.Create); + // End of class TReplaceDialog + RegisterRTTIType(H, TypeInfo(TMsgDlgType)); + RegisterRTTIType(H, TypeInfo(TMsgDlgBtn)); + RegisterRTTIType(H, TypeInfo(TMsgDlgButtons)); + RegisterHeader(H, 'function MessageDlg(const Msg: string; DlgType: TMsgDlgType; Buttons: TMsgDlgButtons; HelpCtx: Longint): Integer;', @MessageDlg); + RegisterHeader(H, 'function MessageDlgPos(const Msg: string; DlgType: TMsgDlgType; Buttons: TMsgDlgButtons; HelpCtx: Longint; X, Y: Integer): Integer;', @MessageDlgPos); + RegisterHeader(H, 'function MessageDlgPosHelp(const Msg: string; DlgType: TMsgDlgType; Buttons: TMsgDlgButtons; HelpCtx: Longint; X, Y: Integer; const HelpFileName: string): Integer;', @MessageDlgPosHelp); + RegisterHeader(H, 'procedure ShowMessage(const Msg: string);', @ShowMessage); + RegisterHeader(H, 'procedure ShowMessageFmt(const Msg: string; Params: array of const);', @ShowMessageFmt); + RegisterHeader(H, 'procedure ShowMessagePos(const Msg: string; X, Y: Integer);', @ShowMessagePos); + RegisterHeader(H, 'function InputBox(const ACaption, APrompt, ADefault: string): string;', @InputBox); + RegisterHeader(H, 'function InputQuery(const ACaption, APrompt: string; var Value: string): Boolean;', @InputQuery); + RegisterHeader(H, 'function PromptForFileName(var AFileName: string; const AFilter: string = ''''; const ADefaultExt: string = ''''; const ATitle: string = ''''; const AInitialDir: string = ''''; SaveDialog: Boolean = False): Boolean;', @PromptForFileName); +end; +end. diff --git a/Demos/ANOTHER_DEMOS/IMPORT/IMPORT_Forms.pas b/Demos/ANOTHER_DEMOS/IMPORT/IMPORT_Forms.pas new file mode 100644 index 0000000..cd9ce74 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/IMPORT/IMPORT_Forms.pas @@ -0,0 +1,1113 @@ +{$I PaxCompiler.def} + +unit IMPORT_Forms; +interface +uses + SysUtils, + Classes, +{$IFDEF DPULSAR} + Winapi.Messages, + Winapi.Windows, + Vcl.Graphics, + Vcl.Menus, + Vcl.Controls, + Vcl.ActnList, + Vcl.Forms, +{$ELSE} + Messages, + Windows, + Graphics, + Menus, + Controls, + ActnList, + Forms, +{$ENDIF} + HelpIntfs, + Variants, + PaxRegister, + PaxCompiler; +procedure Register_Forms; +implementation +function TControlScrollBar_GetKind(Self:TControlScrollBar):TScrollBarKind; +begin + result := Self.Kind; +end; +function TControlScrollBar_GetScrollPos(Self:TControlScrollBar):Integer; +begin + result := Self.ScrollPos; +end; +function TCustomForm_GetActive(Self:TCustomForm):Boolean; +begin + result := Self.Active; +end; +function TCustomForm_GetBorderStyle(Self:TCustomForm):TFormBorderStyle; +begin + result := Self.BorderStyle; +end; +procedure TCustomForm_PutBorderStyle(Self:TCustomForm;const Value: TFormBorderStyle); +begin + Self.BorderStyle := Value; +end; +function TCustomForm_GetDesigner(Self:TCustomForm):IDesignerHook; +begin + result := Self.Designer; +end; +procedure TCustomForm_PutDesigner(Self:TCustomForm;const Value: IDesignerHook); +begin + Self.Designer := Value; +end; +function TCustomForm_GetDropTarget(Self:TCustomForm):Boolean; +begin + result := Self.DropTarget; +end; +procedure TCustomForm_PutDropTarget(Self:TCustomForm;const Value: Boolean); +begin + Self.DropTarget := Value; +end; +function TCustomForm_GetFormState(Self:TCustomForm):TFormState; +begin + result := Self.FormState; +end; +function TCustomForm_GetHelpFile(Self:TCustomForm):string; +begin + result := Self.HelpFile; +end; +procedure TCustomForm_PutHelpFile(Self:TCustomForm;const Value: string); +begin + Self.HelpFile := Value; +end; +function TCustomForm_GetKeyPreview(Self:TCustomForm):Boolean; +begin + result := Self.KeyPreview; +end; +procedure TCustomForm_PutKeyPreview(Self:TCustomForm;const Value: Boolean); +begin + Self.KeyPreview := Value; +end; +function TCustomForm_GetMonitor(Self:TCustomForm):TMonitor; +begin + result := Self.Monitor; +end; +function TCustomForm_GetOleFormObject(Self:TCustomForm):IOleForm; +begin + result := Self.OleFormObject; +end; +procedure TCustomForm_PutOleFormObject(Self:TCustomForm;const Value: IOleForm); +begin + Self.OleFormObject := Value; +end; +function TCustomForm_GetScreenSnap(Self:TCustomForm):Boolean; +begin + result := Self.ScreenSnap; +end; +procedure TCustomForm_PutScreenSnap(Self:TCustomForm;const Value: Boolean); +begin + Self.ScreenSnap := Value; +end; +function TCustomForm_GetSnapBuffer(Self:TCustomForm):Integer; +begin + result := Self.SnapBuffer; +end; +procedure TCustomForm_PutSnapBuffer(Self:TCustomForm;const Value: Integer); +begin + Self.SnapBuffer := Value; +end; +function TCustomForm_GetWindowState(Self:TCustomForm):TWindowState; +begin + result := Self.WindowState; +end; +procedure TCustomForm_PutWindowState(Self:TCustomForm;const Value: TWindowState); +begin + Self.WindowState := Value; +end; +function TMonitor_GetMonitorNum(Self:TMonitor):Integer; +begin + result := Self.MonitorNum; +end; +function TMonitor_GetLeft(Self:TMonitor):Integer; +begin + result := Self.Left; +end; +function TMonitor_GetHeight(Self:TMonitor):Integer; +begin + result := Self.Height; +end; +function TMonitor_GetTop(Self:TMonitor):Integer; +begin + result := Self.Top; +end; +function TMonitor_GetWidth(Self:TMonitor):Integer; +begin + result := Self.Width; +end; +function TMonitor_GetBoundsRect(Self:TMonitor):TRect; +begin + result := Self.BoundsRect; +end; +function TMonitor_GetWorkareaRect(Self:TMonitor):TRect; +begin + result := Self.WorkareaRect; +end; +function TMonitor_GetPrimary(Self:TMonitor):Boolean; +begin + result := Self.Primary; +end; +function TScreen_GetActiveCustomForm(Self:TScreen):TCustomForm; +begin + result := Self.ActiveCustomForm; +end; +function TScreen_GetActiveForm(Self:TScreen):TForm; +begin + result := Self.ActiveForm; +end; +function TScreen_GetCustomFormCount(Self:TScreen):Integer; +begin + result := Self.CustomFormCount; +end; +function TScreen_GetCustomForms(Self:TScreen;Index: Integer):TCustomForm; +begin + result := Self.CustomForms[Index]; +end; +function TScreen_GetDataModuleCount(Self:TScreen):Integer; +begin + result := Self.DataModuleCount; +end; +function TScreen_GetMonitorCount(Self:TScreen):Integer; +begin + result := Self.MonitorCount; +end; +function TScreen_GetMonitors(Self:TScreen;Index: Integer):TMonitor; +begin + result := Self.Monitors[Index]; +end; +function TScreen_GetDesktopRect(Self:TScreen):TRect; +begin + result := Self.DesktopRect; +end; +function TScreen_GetDesktopHeight(Self:TScreen):Integer; +begin + result := Self.DesktopHeight; +end; +function TScreen_GetDesktopLeft(Self:TScreen):Integer; +begin + result := Self.DesktopLeft; +end; +function TScreen_GetDesktopTop(Self:TScreen):Integer; +begin + result := Self.DesktopTop; +end; +function TScreen_GetDesktopWidth(Self:TScreen):Integer; +begin + result := Self.DesktopWidth; +end; +function TScreen_GetWorkAreaRect(Self:TScreen):TRect; +begin + result := Self.WorkAreaRect; +end; +function TScreen_GetWorkAreaHeight(Self:TScreen):Integer; +begin + result := Self.WorkAreaHeight; +end; +function TScreen_GetWorkAreaLeft(Self:TScreen):Integer; +begin + result := Self.WorkAreaLeft; +end; +function TScreen_GetWorkAreaTop(Self:TScreen):Integer; +begin + result := Self.WorkAreaTop; +end; +function TScreen_GetWorkAreaWidth(Self:TScreen):Integer; +begin + result := Self.WorkAreaWidth; +end; +function TScreen_GetFormCount(Self:TScreen):Integer; +begin + result := Self.FormCount; +end; +function TScreen_GetForms(Self:TScreen;Index: Integer):TForm; +begin + result := Self.Forms[Index]; +end; +function TScreen_GetDefaultIme(Self:TScreen):string; +begin + result := Self.DefaultIme; +end; +function TScreen_GetHeight(Self:TScreen):Integer; +begin + result := Self.Height; +end; +function TScreen_GetPixelsPerInch(Self:TScreen):Integer; +begin + result := Self.PixelsPerInch; +end; +function TScreen_GetWidth(Self:TScreen):Integer; +begin + result := Self.Width; +end; +function TApplication_GetActive(Self:TApplication):Boolean; +begin + result := Self.Active; +end; +function TApplication_GetAllowTesting(Self:TApplication):Boolean; +begin + result := Self.AllowTesting; +end; +procedure TApplication_PutAllowTesting(Self:TApplication;const Value: Boolean); +begin + Self.AllowTesting := Value; +end; +function TApplication_GetAutoDragDocking(Self:TApplication):Boolean; +begin + result := Self.AutoDragDocking; +end; +procedure TApplication_PutAutoDragDocking(Self:TApplication;const Value: Boolean); +begin + Self.AutoDragDocking := Value; +end; +function TApplication_GetCurrentHelpFile(Self:TApplication):string; +begin + result := Self.CurrentHelpFile; +end; +function TApplication_GetExeName(Self:TApplication):string; +begin + result := Self.ExeName; +end; +function TApplication_GetHelpFile(Self:TApplication):string; +begin + result := Self.HelpFile; +end; +procedure TApplication_PutHelpFile(Self:TApplication;const Value: string); +begin + Self.HelpFile := Value; +end; +function TApplication_GetHint(Self:TApplication):string; +begin + result := Self.Hint; +end; +procedure TApplication_PutHint(Self:TApplication;const Value: string); +begin + Self.Hint := Value; +end; +function TApplication_GetHintHidePause(Self:TApplication):Integer; +begin + result := Self.HintHidePause; +end; +procedure TApplication_PutHintHidePause(Self:TApplication;const Value: Integer); +begin + Self.HintHidePause := Value; +end; +function TApplication_GetHintPause(Self:TApplication):Integer; +begin + result := Self.HintPause; +end; +procedure TApplication_PutHintPause(Self:TApplication;const Value: Integer); +begin + Self.HintPause := Value; +end; +function TApplication_GetHintShortCuts(Self:TApplication):Boolean; +begin + result := Self.HintShortCuts; +end; +procedure TApplication_PutHintShortCuts(Self:TApplication;const Value: Boolean); +begin + Self.HintShortCuts := Value; +end; +function TApplication_GetHintShortPause(Self:TApplication):Integer; +begin + result := Self.HintShortPause; +end; +procedure TApplication_PutHintShortPause(Self:TApplication;const Value: Integer); +begin + Self.HintShortPause := Value; +end; +function TApplication_GetMainForm(Self:TApplication):TForm; +begin + result := Self.MainForm; +end; +function TApplication_GetBiDiKeyboard(Self:TApplication):string; +begin + result := Self.BiDiKeyboard; +end; +procedure TApplication_PutBiDiKeyboard(Self:TApplication;const Value: string); +begin + Self.BiDiKeyboard := Value; +end; +function TApplication_GetNonBiDiKeyboard(Self:TApplication):string; +begin + result := Self.NonBiDiKeyboard; +end; +procedure TApplication_PutNonBiDiKeyboard(Self:TApplication;const Value: string); +begin + Self.NonBiDiKeyboard := Value; +end; +function TApplication_GetShowHint(Self:TApplication):Boolean; +begin + result := Self.ShowHint; +end; +procedure TApplication_PutShowHint(Self:TApplication;const Value: Boolean); +begin + Self.ShowHint := Value; +end; +function TApplication_GetShowMainForm(Self:TApplication):Boolean; +begin + result := Self.ShowMainForm; +end; +procedure TApplication_PutShowMainForm(Self:TApplication;const Value: Boolean); +begin + Self.ShowMainForm := Value; +end; +function TApplication_GetTerminated(Self:TApplication):Boolean; +begin + result := Self.Terminated; +end; +function TApplication_GetTitle(Self:TApplication):string; +begin + result := Self.Title; +end; +procedure TApplication_PutTitle(Self:TApplication;const Value: string); +begin + Self.Title := Value; +end; +function TApplication_GetUpdateFormatSettings(Self:TApplication):Boolean; +begin + result := Self.UpdateFormatSettings; +end; +procedure TApplication_PutUpdateFormatSettings(Self:TApplication;const Value: Boolean); +begin + Self.UpdateFormatSettings := Value; +end; +function TApplication_GetUpdateMetricSettings(Self:TApplication):Boolean; +begin + result := Self.UpdateMetricSettings; +end; +procedure TApplication_PutUpdateMetricSettings(Self:TApplication;const Value: Boolean); +begin + Self.UpdateMetricSettings := Value; +end; +procedure Register_Forms; +var G, H: Integer; +begin + H := RegisterNamespace(0, 'Forms'); + // Begin of class TScrollingWinControl + G := RegisterClassType(H, TScrollingWinControl); + // End of class TScrollingWinControl + // Begin of class TCustomForm + G := RegisterClassType(H, TCustomForm); + // End of class TCustomForm + // Begin of class TForm + G := RegisterClassType(H, TForm); + // End of class TForm + // Begin of class TMonitor + G := RegisterClassType(H, TMonitor); + // End of class TMonitor + RegisterRTTIType(H, TypeInfo(TScrollBarKind)); + RegisterRTTIType(H, TypeInfo(TScrollBarInc)); + RegisterRTTIType(H, TypeInfo(TScrollBarStyle)); + // Begin of class TControlScrollBar + G := RegisterClassType(H, TControlScrollBar); + RegisterHeader(G, + 'procedure Assign(Source: TPersistent); override;', + @TControlScrollBar.Assign); + RegisterHeader(G, + 'procedure ChangeBiDiPosition;', + @TControlScrollBar.ChangeBiDiPosition); + RegisterFakeHeader(G, + 'function TControlScrollBar_GetKind:TScrollBarKind;', + @TControlScrollBar_GetKind); + RegisterProperty(G, + 'property Kind:TScrollBarKind read TControlScrollBar_GetKind;'); + RegisterHeader(G, + 'function IsScrollBarVisible: Boolean;', + @TControlScrollBar.IsScrollBarVisible); + RegisterFakeHeader(G, + 'function TControlScrollBar_GetScrollPos:Integer;', + @TControlScrollBar_GetScrollPos); + RegisterProperty(G, + 'property ScrollPos:Integer read TControlScrollBar_GetScrollPos;'); + RegisterHeader(G, + 'constructor Create;', + @TControlScrollBar.Create); + // End of class TControlScrollBar + RegisterRTTIType(H, TypeInfo(TWindowState)); + // Begin of class TScrollingWinControl + G := RegisterClassType(H, TScrollingWinControl); + RegisterHeader(G, + 'constructor Create(AOwner: TComponent); override;', + @TScrollingWinControl.Create); + RegisterHeader(G, + 'destructor Destroy; override;', + @TScrollingWinControl.Destroy); + RegisterHeader(G, + 'procedure DisableAutoRange;', + @TScrollingWinControl.DisableAutoRange); + RegisterHeader(G, + 'procedure EnableAutoRange;', + @TScrollingWinControl.EnableAutoRange); + // End of class TScrollingWinControl + RegisterRTTIType(H, TypeInfo(TFormBorderStyle)); + RegisterRTTIType(H, TypeInfo(TBorderStyle)); + // Begin of class TScrollBox + G := RegisterClassType(H, TScrollBox); + RegisterHeader(G, + 'constructor Create(AOwner: TComponent); override;', + @TScrollBox.Create); + // End of class TScrollBox + // Begin of class TCustomFrame + G := RegisterClassType(H, TCustomFrame); + RegisterHeader(G, + 'constructor Create(AOwner: TComponent); override;', + @TCustomFrame.Create); + // End of class TCustomFrame + RegisterClassReferenceType(H, 'TCustomFrameClass'); + // Begin of class TFrame + G := RegisterClassType(H, TFrame); + RegisterHeader(G, + 'constructor Create(AOwner: TComponent); override;', + @TFrame.Create); + // End of class TFrame + // Begin of interface IDesignerHook + G := RegisterInterfaceType(H, 'IDesignerHook',IDesignerHook); + RegisterSupportedInterface(G, 'IDesignerNotify', IDesignerNotify); + RegisterHeader(G, + 'function GetCustomForm: TCustomForm;', nil,1); + RegisterHeader(G, + 'procedure SetCustomForm(Value: TCustomForm);', nil,2); + RegisterHeader(G, + 'function GetIsControl: Boolean;', nil,3); + RegisterHeader(G, + 'procedure SetIsControl(Value: Boolean);', nil,4); + RegisterHeader(G, + 'procedure PaintGrid;', nil,6); + RegisterHeader(G, + 'procedure ValidateRename(AComponent: TComponent; const CurName, NewName: string);', nil,7); + RegisterHeader(G, + 'function UniqueName(const BaseName: string): string;', nil,8); + RegisterHeader(G, + 'function GetRoot: TComponent;', nil,9); + RegisterHeader(G,'property IsControl: Boolean read GetIsControl write SetIsControl;', nil); + RegisterHeader(G,'property Form: TCustomForm read GetCustomForm write SetCustomForm;', nil); + // End of interface IDesignerHook + // Begin of interface IOleForm + G := RegisterInterfaceType(H, 'IOleForm',IOleForm); + RegisterHeader(G, + 'procedure OnDestroy;', nil,4); + RegisterHeader(G, + 'procedure OnResize;', nil,5); + // End of interface IOleForm + RegisterRTTIType(H, TypeInfo(TFormStyle)); + RegisterRTTIType(H, TypeInfo(TBorderIcon)); + RegisterRTTIType(H, TypeInfo(TBorderIcons)); + RegisterRTTIType(H, TypeInfo(TPosition)); + RegisterRTTIType(H, TypeInfo(TDefaultMonitor)); + RegisterRTTIType(H, TypeInfo(TPrintScale)); + RegisterRTTIType(H, TypeInfo(TShowAction)); + RegisterRTTIType(H, TypeInfo(TTileMode)); + RegisterRTTIType(H, TypeInfo(TCloseAction)); + RegisterRTTIType(H, TypeInfo(TFormState)); + // Begin of class TCustomForm + G := RegisterClassType(H, TCustomForm); + RegisterHeader(G, + 'constructor Create(AOwner: TComponent); override;', + @TCustomForm.Create); + RegisterHeader(G, + 'constructor CreateNew(AOwner: TComponent; Dummy: Integer = 0); virtual;', + @TCustomForm.CreateNew); + RegisterHeader(G, + 'destructor Destroy; override;', + @TCustomForm.Destroy); + RegisterHeader(G, + 'procedure AfterConstruction; override;', + @TCustomForm.AfterConstruction); + RegisterHeader(G, + 'procedure BeforeDestruction; override;', + @TCustomForm.BeforeDestruction); + RegisterHeader(G, + 'procedure Close;', + @TCustomForm.Close); + RegisterHeader(G, + 'function CloseQuery: Boolean; virtual;', + @TCustomForm.CloseQuery); + RegisterHeader(G, + 'procedure DefaultHandler(var Message); override;', + @TCustomForm.DefaultHandler); + RegisterHeader(G, + 'procedure Hide;', + @TCustomForm.Hide); + RegisterHeader(G, + 'procedure MakeFullyVisible(AMonitor: TMonitor = nil);', + @TCustomForm.MakeFullyVisible); + RegisterHeader(G, + 'procedure Print;', + @TCustomForm.Print); + RegisterHeader(G, + 'procedure Release;', + @TCustomForm.Release); + RegisterHeader(G, + 'procedure SetFocus; override;', + @TCustomForm.SetFocus); + RegisterHeader(G, + 'procedure Show;', + @TCustomForm.Show); + RegisterHeader(G, + 'function ShowModal: Integer; virtual;', + @TCustomForm.ShowModal); + RegisterFakeHeader(G, + 'function TCustomForm_GetActive:Boolean;', + @TCustomForm_GetActive); + RegisterProperty(G, + 'property Active:Boolean read TCustomForm_GetActive;'); + RegisterFakeHeader(G, + 'function TCustomForm_GetBorderStyle:TFormBorderStyle;', + @TCustomForm_GetBorderStyle); + RegisterFakeHeader(G, + 'procedure TCustomForm_PutBorderStyle(const Value: TFormBorderStyle);', + @TCustomForm_PutBorderStyle); + RegisterProperty(G, + 'property BorderStyle:TFormBorderStyle read TCustomForm_GetBorderStyle write TCustomForm_PutBorderStyle;'); + RegisterFakeHeader(G, + 'function TCustomForm_GetDesigner:IDesignerHook;', + @TCustomForm_GetDesigner); + RegisterFakeHeader(G, + 'procedure TCustomForm_PutDesigner(const Value: IDesignerHook);', + @TCustomForm_PutDesigner); + RegisterProperty(G, + 'property Designer:IDesignerHook read TCustomForm_GetDesigner write TCustomForm_PutDesigner;'); + RegisterFakeHeader(G, + 'function TCustomForm_GetDropTarget:Boolean;', + @TCustomForm_GetDropTarget); + RegisterFakeHeader(G, + 'procedure TCustomForm_PutDropTarget(const Value: Boolean);', + @TCustomForm_PutDropTarget); + RegisterProperty(G, + 'property DropTarget:Boolean read TCustomForm_GetDropTarget write TCustomForm_PutDropTarget;'); + RegisterFakeHeader(G, + 'function TCustomForm_GetFormState:TFormState;', + @TCustomForm_GetFormState); + RegisterProperty(G, + 'property FormState:TFormState read TCustomForm_GetFormState;'); + RegisterFakeHeader(G, + 'function TCustomForm_GetHelpFile:string;', + @TCustomForm_GetHelpFile); + RegisterFakeHeader(G, + 'procedure TCustomForm_PutHelpFile(const Value: string);', + @TCustomForm_PutHelpFile); + RegisterProperty(G, + 'property HelpFile:string read TCustomForm_GetHelpFile write TCustomForm_PutHelpFile;'); + RegisterFakeHeader(G, + 'function TCustomForm_GetKeyPreview:Boolean;', + @TCustomForm_GetKeyPreview); + RegisterFakeHeader(G, + 'procedure TCustomForm_PutKeyPreview(const Value: Boolean);', + @TCustomForm_PutKeyPreview); + RegisterProperty(G, + 'property KeyPreview:Boolean read TCustomForm_GetKeyPreview write TCustomForm_PutKeyPreview;'); + RegisterFakeHeader(G, + 'function TCustomForm_GetMonitor:TMonitor;', + @TCustomForm_GetMonitor); + RegisterProperty(G, + 'property Monitor:TMonitor read TCustomForm_GetMonitor;'); + RegisterFakeHeader(G, + 'function TCustomForm_GetOleFormObject:IOleForm;', + @TCustomForm_GetOleFormObject); + RegisterFakeHeader(G, + 'procedure TCustomForm_PutOleFormObject(const Value: IOleForm);', + @TCustomForm_PutOleFormObject); + RegisterProperty(G, + 'property OleFormObject:IOleForm read TCustomForm_GetOleFormObject write TCustomForm_PutOleFormObject;'); + RegisterFakeHeader(G, + 'function TCustomForm_GetScreenSnap:Boolean;', + @TCustomForm_GetScreenSnap); + RegisterFakeHeader(G, + 'procedure TCustomForm_PutScreenSnap(const Value: Boolean);', + @TCustomForm_PutScreenSnap); + RegisterProperty(G, + 'property ScreenSnap:Boolean read TCustomForm_GetScreenSnap write TCustomForm_PutScreenSnap;'); + RegisterFakeHeader(G, + 'function TCustomForm_GetSnapBuffer:Integer;', + @TCustomForm_GetSnapBuffer); + RegisterFakeHeader(G, + 'procedure TCustomForm_PutSnapBuffer(const Value: Integer);', + @TCustomForm_PutSnapBuffer); + RegisterProperty(G, + 'property SnapBuffer:Integer read TCustomForm_GetSnapBuffer write TCustomForm_PutSnapBuffer;'); + RegisterFakeHeader(G, + 'function TCustomForm_GetWindowState:TWindowState;', + @TCustomForm_GetWindowState); + RegisterFakeHeader(G, + 'procedure TCustomForm_PutWindowState(const Value: TWindowState);', + @TCustomForm_PutWindowState); + RegisterProperty(G, + 'property WindowState:TWindowState read TCustomForm_GetWindowState write TCustomForm_PutWindowState;'); + // End of class TCustomForm + RegisterClassReferenceType(H, 'TCustomFormClass'); + RegisterRTTIType(H, TypeInfo(TActiveFormBorderStyle)); + // Begin of class TCustomActiveForm + G := RegisterClassType(H, TCustomActiveForm); + RegisterHeader(G, + 'constructor Create(AOwner: TComponent); override;', + @TCustomActiveForm.Create); + // End of class TCustomActiveForm + // Begin of class TForm + G := RegisterClassType(H, TForm); + RegisterHeader(G, + 'procedure ArrangeIcons;', + @TForm.ArrangeIcons); + RegisterHeader(G, + 'procedure Cascade;', + @TForm.Cascade); + RegisterHeader(G, + 'procedure Next;', + @TForm.Next); + RegisterHeader(G, + 'procedure Previous;', + @TForm.Previous); + RegisterHeader(G, + 'procedure Tile;', + @TForm.Tile); + RegisterHeader(G, + 'constructor CreateNew(AOwner: TComponent; Dummy: Integer = 0); override;', + @TForm.CreateNew); + RegisterHeader(G, + 'constructor Create(AOwner: TComponent); override;', + @TForm.Create); + // End of class TForm + RegisterClassReferenceType(H, 'TFormClass'); + // Begin of class TCustomDockForm + G := RegisterClassType(H, TCustomDockForm); + RegisterHeader(G, + 'constructor Create(AOwner: TComponent); override;', + @TCustomDockForm.Create); + // End of class TCustomDockForm + // Begin of class TMonitor + G := RegisterClassType(H, TMonitor); + RegisterFakeHeader(G, + 'function TMonitor_GetMonitorNum:Integer;', + @TMonitor_GetMonitorNum); + RegisterProperty(G, + 'property MonitorNum:Integer read TMonitor_GetMonitorNum;'); + RegisterFakeHeader(G, + 'function TMonitor_GetLeft:Integer;', + @TMonitor_GetLeft); + RegisterProperty(G, + 'property Left:Integer read TMonitor_GetLeft;'); + RegisterFakeHeader(G, + 'function TMonitor_GetHeight:Integer;', + @TMonitor_GetHeight); + RegisterProperty(G, + 'property Height:Integer read TMonitor_GetHeight;'); + RegisterFakeHeader(G, + 'function TMonitor_GetTop:Integer;', + @TMonitor_GetTop); + RegisterProperty(G, + 'property Top:Integer read TMonitor_GetTop;'); + RegisterFakeHeader(G, + 'function TMonitor_GetWidth:Integer;', + @TMonitor_GetWidth); + RegisterProperty(G, + 'property Width:Integer read TMonitor_GetWidth;'); + RegisterFakeHeader(G, + 'function TMonitor_GetBoundsRect:TRect;', + @TMonitor_GetBoundsRect); + RegisterProperty(G, + 'property BoundsRect:TRect read TMonitor_GetBoundsRect;'); + RegisterFakeHeader(G, + 'function TMonitor_GetWorkareaRect:TRect;', + @TMonitor_GetWorkareaRect); + RegisterProperty(G, + 'property WorkareaRect:TRect read TMonitor_GetWorkareaRect;'); + RegisterFakeHeader(G, + 'function TMonitor_GetPrimary:Boolean;', + @TMonitor_GetPrimary); + RegisterProperty(G, + 'property Primary:Boolean read TMonitor_GetPrimary;'); + RegisterHeader(G, + 'constructor Create;', + @TMonitor.Create); + // End of class TMonitor + RegisterRTTIType(H, TypeInfo(TMonitorDefaultTo)); + // Begin of class TScreen + G := RegisterClassType(H, TScreen); + RegisterHeader(G, + 'constructor Create(AOwner: TComponent); override;', + @TScreen.Create); + RegisterHeader(G, + 'destructor Destroy; override;', + @TScreen.Destroy); + RegisterHeader(G, + 'procedure DisableAlign;', + @TScreen.DisableAlign); + RegisterHeader(G, + 'procedure EnableAlign;', + @TScreen.EnableAlign); + RegisterHeader(G, + 'procedure Realign;', + @TScreen.Realign); + RegisterHeader(G, + 'procedure ResetFonts;', + @TScreen.ResetFonts); + RegisterFakeHeader(G, + 'function TScreen_GetActiveCustomForm:TCustomForm;', + @TScreen_GetActiveCustomForm); + RegisterProperty(G, + 'property ActiveCustomForm:TCustomForm read TScreen_GetActiveCustomForm;'); + RegisterFakeHeader(G, + 'function TScreen_GetActiveForm:TForm;', + @TScreen_GetActiveForm); + RegisterProperty(G, + 'property ActiveForm:TForm read TScreen_GetActiveForm;'); + RegisterFakeHeader(G, + 'function TScreen_GetCustomFormCount:Integer;', + @TScreen_GetCustomFormCount); + RegisterProperty(G, + 'property CustomFormCount:Integer read TScreen_GetCustomFormCount;'); + RegisterFakeHeader(G, + 'function TScreen_GetCustomForms(Index: Integer):TCustomForm;', + @TScreen_GetCustomForms); + RegisterProperty(G, + 'property CustomForms[Index: Integer]:TCustomForm read TScreen_GetCustomForms;'); + RegisterFakeHeader(G, + 'function TScreen_GetDataModuleCount:Integer;', + @TScreen_GetDataModuleCount); + RegisterProperty(G, + 'property DataModuleCount:Integer read TScreen_GetDataModuleCount;'); + RegisterFakeHeader(G, + 'function TScreen_GetMonitorCount:Integer;', + @TScreen_GetMonitorCount); + RegisterProperty(G, + 'property MonitorCount:Integer read TScreen_GetMonitorCount;'); + RegisterFakeHeader(G, + 'function TScreen_GetMonitors(Index: Integer):TMonitor;', + @TScreen_GetMonitors); + RegisterProperty(G, + 'property Monitors[Index: Integer]:TMonitor read TScreen_GetMonitors;'); + RegisterFakeHeader(G, + 'function TScreen_GetDesktopRect:TRect;', + @TScreen_GetDesktopRect); + RegisterProperty(G, + 'property DesktopRect:TRect read TScreen_GetDesktopRect;'); + RegisterFakeHeader(G, + 'function TScreen_GetDesktopHeight:Integer;', + @TScreen_GetDesktopHeight); + RegisterProperty(G, + 'property DesktopHeight:Integer read TScreen_GetDesktopHeight;'); + RegisterFakeHeader(G, + 'function TScreen_GetDesktopLeft:Integer;', + @TScreen_GetDesktopLeft); + RegisterProperty(G, + 'property DesktopLeft:Integer read TScreen_GetDesktopLeft;'); + RegisterFakeHeader(G, + 'function TScreen_GetDesktopTop:Integer;', + @TScreen_GetDesktopTop); + RegisterProperty(G, + 'property DesktopTop:Integer read TScreen_GetDesktopTop;'); + RegisterFakeHeader(G, + 'function TScreen_GetDesktopWidth:Integer;', + @TScreen_GetDesktopWidth); + RegisterProperty(G, + 'property DesktopWidth:Integer read TScreen_GetDesktopWidth;'); + RegisterFakeHeader(G, + 'function TScreen_GetWorkAreaRect:TRect;', + @TScreen_GetWorkAreaRect); + RegisterProperty(G, + 'property WorkAreaRect:TRect read TScreen_GetWorkAreaRect;'); + RegisterFakeHeader(G, + 'function TScreen_GetWorkAreaHeight:Integer;', + @TScreen_GetWorkAreaHeight); + RegisterProperty(G, + 'property WorkAreaHeight:Integer read TScreen_GetWorkAreaHeight;'); + RegisterFakeHeader(G, + 'function TScreen_GetWorkAreaLeft:Integer;', + @TScreen_GetWorkAreaLeft); + RegisterProperty(G, + 'property WorkAreaLeft:Integer read TScreen_GetWorkAreaLeft;'); + RegisterFakeHeader(G, + 'function TScreen_GetWorkAreaTop:Integer;', + @TScreen_GetWorkAreaTop); + RegisterProperty(G, + 'property WorkAreaTop:Integer read TScreen_GetWorkAreaTop;'); + RegisterFakeHeader(G, + 'function TScreen_GetWorkAreaWidth:Integer;', + @TScreen_GetWorkAreaWidth); + RegisterProperty(G, + 'property WorkAreaWidth:Integer read TScreen_GetWorkAreaWidth;'); + RegisterFakeHeader(G, + 'function TScreen_GetFormCount:Integer;', + @TScreen_GetFormCount); + RegisterProperty(G, + 'property FormCount:Integer read TScreen_GetFormCount;'); + RegisterFakeHeader(G, + 'function TScreen_GetForms(Index: Integer):TForm;', + @TScreen_GetForms); + RegisterProperty(G, + 'property Forms[Index: Integer]:TForm read TScreen_GetForms;'); + RegisterFakeHeader(G, + 'function TScreen_GetDefaultIme:string;', + @TScreen_GetDefaultIme); + RegisterProperty(G, + 'property DefaultIme:string read TScreen_GetDefaultIme;'); + RegisterFakeHeader(G, + 'function TScreen_GetHeight:Integer;', + @TScreen_GetHeight); + RegisterProperty(G, + 'property Height:Integer read TScreen_GetHeight;'); + RegisterFakeHeader(G, + 'function TScreen_GetPixelsPerInch:Integer;', + @TScreen_GetPixelsPerInch); + RegisterProperty(G, + 'property PixelsPerInch:Integer read TScreen_GetPixelsPerInch;'); + RegisterFakeHeader(G, + 'function TScreen_GetWidth:Integer;', + @TScreen_GetWidth); + RegisterProperty(G, + 'property Width:Integer read TScreen_GetWidth;'); + // End of class TScreen + RegisterRTTIType(H, TypeInfo(TTimerMode)); + // Begin of class TApplication + G := RegisterClassType(H, TApplication); + RegisterHeader(G, + 'constructor Create(AOwner: TComponent); override;', + @TApplication.Create); + RegisterHeader(G, + 'destructor Destroy; override;', + @TApplication.Destroy); + RegisterHeader(G, + 'procedure ActivateHint(CursorPos: TPoint);', + @TApplication.ActivateHint); + RegisterHeader(G, + 'procedure BringToFront;', + @TApplication.BringToFront); + RegisterHeader(G, + 'procedure CancelHint;', + @TApplication.CancelHint); + RegisterHeader(G, + 'procedure CreateHandle;', + @TApplication.CreateHandle); + RegisterHeader(G, + 'procedure HandleException(Sender: TObject);', + @TApplication.HandleException); + RegisterHeader(G, + 'procedure HandleMessage;', + @TApplication.HandleMessage); + RegisterHeader(G, + 'function HelpCommand(Command: Integer; Data: Longint): Boolean;', + @TApplication.HelpCommand); + RegisterHeader(G, + 'function HelpJump(const JumpID: string): Boolean;', + @TApplication.HelpJump); + RegisterHeader(G, + 'function HelpKeyword(const Keyword: String): Boolean;', + @TApplication.HelpKeyword); + RegisterHeader(G, + 'procedure HideHint;', + @TApplication.HideHint); + RegisterHeader(G, + 'procedure HookSynchronizeWakeup;', + @TApplication.HookSynchronizeWakeup); + RegisterHeader(G, + 'procedure Initialize;', + @TApplication.Initialize); + RegisterHeader(G, + 'function IsRightToLeft: Boolean;', + @TApplication.IsRightToLeft); + RegisterHeader(G, + 'procedure Minimize;', + @TApplication.Minimize); + RegisterHeader(G, + 'procedure ModalStarted;', + @TApplication.ModalStarted); + RegisterHeader(G, + 'procedure ModalFinished;', + @TApplication.ModalFinished); + RegisterHeader(G, + 'procedure NormalizeAllTopMosts;', + @TApplication.NormalizeAllTopMosts); + RegisterHeader(G, + 'procedure NormalizeTopMosts;', + @TApplication.NormalizeTopMosts); + RegisterHeader(G, + 'procedure ProcessMessages;', + @TApplication.ProcessMessages); + RegisterHeader(G, + 'procedure Restore;', + @TApplication.Restore); + RegisterHeader(G, + 'procedure RestoreTopMosts;', + @TApplication.RestoreTopMosts); + RegisterHeader(G, + 'procedure Run;', + @TApplication.Run); + RegisterHeader(G, + 'procedure Terminate;', + @TApplication.Terminate); + RegisterHeader(G, + 'procedure UnhookSynchronizeWakeup;', + @TApplication.UnhookSynchronizeWakeup); + RegisterHeader(G, + 'function UseRightToLeftAlignment: Boolean;', + @TApplication.UseRightToLeftAlignment); + RegisterHeader(G, + 'function UseRightToLeftReading: Boolean;', + @TApplication.UseRightToLeftReading); + RegisterHeader(G, + 'function UseRightToLeftScrollBar: Boolean;', + @TApplication.UseRightToLeftScrollBar); + RegisterFakeHeader(G, + 'function TApplication_GetActive:Boolean;', + @TApplication_GetActive); + RegisterProperty(G, + 'property Active:Boolean read TApplication_GetActive;'); + RegisterFakeHeader(G, + 'function TApplication_GetAllowTesting:Boolean;', + @TApplication_GetAllowTesting); + RegisterFakeHeader(G, + 'procedure TApplication_PutAllowTesting(const Value: Boolean);', + @TApplication_PutAllowTesting); + RegisterProperty(G, + 'property AllowTesting:Boolean read TApplication_GetAllowTesting write TApplication_PutAllowTesting;'); + RegisterFakeHeader(G, + 'function TApplication_GetAutoDragDocking:Boolean;', + @TApplication_GetAutoDragDocking); + RegisterFakeHeader(G, + 'procedure TApplication_PutAutoDragDocking(const Value: Boolean);', + @TApplication_PutAutoDragDocking); + RegisterProperty(G, + 'property AutoDragDocking:Boolean read TApplication_GetAutoDragDocking write TApplication_PutAutoDragDocking;'); + RegisterFakeHeader(G, + 'function TApplication_GetCurrentHelpFile:string;', + @TApplication_GetCurrentHelpFile); + RegisterProperty(G, + 'property CurrentHelpFile:string read TApplication_GetCurrentHelpFile;'); + RegisterFakeHeader(G, + 'function TApplication_GetExeName:string;', + @TApplication_GetExeName); + RegisterProperty(G, + 'property ExeName:string read TApplication_GetExeName;'); + RegisterFakeHeader(G, + 'function TApplication_GetHelpFile:string;', + @TApplication_GetHelpFile); + RegisterFakeHeader(G, + 'procedure TApplication_PutHelpFile(const Value: string);', + @TApplication_PutHelpFile); + RegisterProperty(G, + 'property HelpFile:string read TApplication_GetHelpFile write TApplication_PutHelpFile;'); + RegisterFakeHeader(G, + 'function TApplication_GetHint:string;', + @TApplication_GetHint); + RegisterFakeHeader(G, + 'procedure TApplication_PutHint(const Value: string);', + @TApplication_PutHint); + RegisterProperty(G, + 'property Hint:string read TApplication_GetHint write TApplication_PutHint;'); + RegisterFakeHeader(G, + 'function TApplication_GetHintHidePause:Integer;', + @TApplication_GetHintHidePause); + RegisterFakeHeader(G, + 'procedure TApplication_PutHintHidePause(const Value: Integer);', + @TApplication_PutHintHidePause); + RegisterProperty(G, + 'property HintHidePause:Integer read TApplication_GetHintHidePause write TApplication_PutHintHidePause;'); + RegisterFakeHeader(G, + 'function TApplication_GetHintPause:Integer;', + @TApplication_GetHintPause); + RegisterFakeHeader(G, + 'procedure TApplication_PutHintPause(const Value: Integer);', + @TApplication_PutHintPause); + RegisterProperty(G, + 'property HintPause:Integer read TApplication_GetHintPause write TApplication_PutHintPause;'); + RegisterFakeHeader(G, + 'function TApplication_GetHintShortCuts:Boolean;', + @TApplication_GetHintShortCuts); + RegisterFakeHeader(G, + 'procedure TApplication_PutHintShortCuts(const Value: Boolean);', + @TApplication_PutHintShortCuts); + RegisterProperty(G, + 'property HintShortCuts:Boolean read TApplication_GetHintShortCuts write TApplication_PutHintShortCuts;'); + RegisterFakeHeader(G, + 'function TApplication_GetHintShortPause:Integer;', + @TApplication_GetHintShortPause); + RegisterFakeHeader(G, + 'procedure TApplication_PutHintShortPause(const Value: Integer);', + @TApplication_PutHintShortPause); + RegisterProperty(G, + 'property HintShortPause:Integer read TApplication_GetHintShortPause write TApplication_PutHintShortPause;'); + RegisterFakeHeader(G, + 'function TApplication_GetMainForm:TForm;', + @TApplication_GetMainForm); + RegisterProperty(G, + 'property MainForm:TForm read TApplication_GetMainForm;'); + RegisterFakeHeader(G, + 'function TApplication_GetBiDiKeyboard:string;', + @TApplication_GetBiDiKeyboard); + RegisterFakeHeader(G, + 'procedure TApplication_PutBiDiKeyboard(const Value: string);', + @TApplication_PutBiDiKeyboard); + RegisterProperty(G, + 'property BiDiKeyboard:string read TApplication_GetBiDiKeyboard write TApplication_PutBiDiKeyboard;'); + RegisterFakeHeader(G, + 'function TApplication_GetNonBiDiKeyboard:string;', + @TApplication_GetNonBiDiKeyboard); + RegisterFakeHeader(G, + 'procedure TApplication_PutNonBiDiKeyboard(const Value: string);', + @TApplication_PutNonBiDiKeyboard); + RegisterProperty(G, + 'property NonBiDiKeyboard:string read TApplication_GetNonBiDiKeyboard write TApplication_PutNonBiDiKeyboard;'); + RegisterFakeHeader(G, + 'function TApplication_GetShowHint:Boolean;', + @TApplication_GetShowHint); + RegisterFakeHeader(G, + 'procedure TApplication_PutShowHint(const Value: Boolean);', + @TApplication_PutShowHint); + RegisterProperty(G, + 'property ShowHint:Boolean read TApplication_GetShowHint write TApplication_PutShowHint;'); + RegisterFakeHeader(G, + 'function TApplication_GetShowMainForm:Boolean;', + @TApplication_GetShowMainForm); + RegisterFakeHeader(G, + 'procedure TApplication_PutShowMainForm(const Value: Boolean);', + @TApplication_PutShowMainForm); + RegisterProperty(G, + 'property ShowMainForm:Boolean read TApplication_GetShowMainForm write TApplication_PutShowMainForm;'); + RegisterFakeHeader(G, + 'function TApplication_GetTerminated:Boolean;', + @TApplication_GetTerminated); + RegisterProperty(G, + 'property Terminated:Boolean read TApplication_GetTerminated;'); + RegisterFakeHeader(G, + 'function TApplication_GetTitle:string;', + @TApplication_GetTitle); + RegisterFakeHeader(G, + 'procedure TApplication_PutTitle(const Value: string);', + @TApplication_PutTitle); + RegisterProperty(G, + 'property Title:string read TApplication_GetTitle write TApplication_PutTitle;'); + RegisterFakeHeader(G, + 'function TApplication_GetUpdateFormatSettings:Boolean;', + @TApplication_GetUpdateFormatSettings); + RegisterFakeHeader(G, + 'procedure TApplication_PutUpdateFormatSettings(const Value: Boolean);', + @TApplication_PutUpdateFormatSettings); + RegisterProperty(G, + 'property UpdateFormatSettings:Boolean read TApplication_GetUpdateFormatSettings write TApplication_PutUpdateFormatSettings;'); + RegisterFakeHeader(G, + 'function TApplication_GetUpdateMetricSettings:Boolean;', + @TApplication_GetUpdateMetricSettings); + RegisterFakeHeader(G, + 'procedure TApplication_PutUpdateMetricSettings(const Value: Boolean);', + @TApplication_PutUpdateMetricSettings); + RegisterProperty(G, + 'property UpdateMetricSettings:Boolean read TApplication_GetUpdateMetricSettings write TApplication_PutUpdateMetricSettings;'); + // End of class TApplication + RegisterVariable(H, 'Application: TApplication;',@Application); + RegisterVariable(H, 'Screen: TScreen;',@Screen); + RegisterHeader(H, 'procedure EnableTaskWindows(WindowList: Pointer);', @EnableTaskWindows); + RegisterHeader(H, 'procedure FreeObjectInstance(ObjectInstance: Pointer); deprecated;', @FreeObjectInstance); + RegisterHeader(H, 'function IsAccel(VK: Word; const Str: string): Boolean;', @IsAccel); + RegisterHeader(H, 'procedure SetAutoSubClass(Enable: Boolean); deprecated;', @SetAutoSubClass); + RegisterHeader(H, 'procedure DoneCtl3D; deprecated;', @DoneCtl3D); + RegisterHeader(H, 'procedure InitCtl3D; deprecated;', @InitCtl3D); + RegisterHeader(H, 'function ForegroundTask: Boolean;', @ForegroundTask); + RegisterTypeAlias(H, 'TFocusState:Pointer'); + RegisterHeader(H, 'function SaveFocusState: TFocusState;', @SaveFocusState); + RegisterHeader(H, 'procedure RestoreFocusState(FocusState: TFocusState);', @RestoreFocusState); +end; +end. diff --git a/Demos/ANOTHER_DEMOS/IMPORT/IMPORT_Menus.pas b/Demos/ANOTHER_DEMOS/IMPORT/IMPORT_Menus.pas new file mode 100644 index 0000000..18af237 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/IMPORT/IMPORT_Menus.pas @@ -0,0 +1,356 @@ +{$I PaxCompiler.def} + +unit IMPORT_Menus; +interface +uses + SysUtils, + Classes, + Contnrs, +{$IFDEF DPULSAR} + Winapi.Windows, + Winapi.Messages, + Vcl.Graphics, + Vcl.ImgList, + Vcl.ActnList, + Vcl.Menus, +{$ELSE} + Windows, + Messages, + Graphics, + ImgList, + ActnList, + Menus, +{$ENDIF} + Variants, + PaxRegister, + PaxCompiler; +procedure Register_Menus; +implementation +procedure TMenuItem_Add1(Self: TMenuItem;Item: TMenuItem); +begin + Self.Add(Item); +end; +procedure TMenuItem_Add2(Self: TMenuItem;const AItems: array of TMenuItem); +begin + Self.Add(AItems); +end; +function TMenuItem_GetCommand(Self:TMenuItem):Word; +begin + result := Self.Command; +end; +function TMenuItem_GetCount(Self:TMenuItem):Integer; +begin + result := Self.Count; +end; +function TMenuItem_GetItems(Self:TMenuItem;Index: Integer):TMenuItem; +begin + result := Self.Items[Index]; +end; +function TMenuItem_GetMenuIndex(Self:TMenuItem):Integer; +begin + result := Self.MenuIndex; +end; +procedure TMenuItem_PutMenuIndex(Self:TMenuItem;const Value: Integer); +begin + Self.MenuIndex := Value; +end; +function TMenuItem_GetParent(Self:TMenuItem):TMenuItem; +begin + result := Self.Parent; +end; +procedure TMenu_ParentBiDiModeChanged3(Self: TMenu); +begin + Self.ParentBiDiModeChanged(); +end; +procedure TMenu_ParentBiDiModeChanged4(Self: TMenu;AControl: TObject); +begin + Self.ParentBiDiModeChanged(AControl); +end; +function TMenu_GetAutoHotkeys(Self:TMenu):TMenuAutoFlag; +begin + result := Self.AutoHotkeys; +end; +procedure TMenu_PutAutoHotkeys(Self:TMenu;const Value: TMenuAutoFlag); +begin + Self.AutoHotkeys := Value; +end; +function TMenu_GetAutoLineReduction(Self:TMenu):TMenuAutoFlag; +begin + result := Self.AutoLineReduction; +end; +procedure TMenu_PutAutoLineReduction(Self:TMenu;const Value: TMenuAutoFlag); +begin + Self.AutoLineReduction := Value; +end; +function TMenu_GetOwnerDraw(Self:TMenu):Boolean; +begin + result := Self.OwnerDraw; +end; +procedure TMenu_PutOwnerDraw(Self:TMenu;const Value: Boolean); +begin + Self.OwnerDraw := Value; +end; +function TMenu_GetParentBiDiMode(Self:TMenu):Boolean; +begin + result := Self.ParentBiDiMode; +end; +procedure TMenu_PutParentBiDiMode(Self:TMenu;const Value: Boolean); +begin + Self.ParentBiDiMode := Value; +end; +function TPopupMenu_GetPopupComponent(Self:TPopupMenu):TComponent; +begin + result := Self.PopupComponent; +end; +procedure TPopupMenu_PutPopupComponent(Self:TPopupMenu;const Value: TComponent); +begin + Self.PopupComponent := Value; +end; +function TPopupMenu_GetPopupPoint(Self:TPopupMenu):TPoint; +begin + result := Self.PopupPoint; +end; +procedure Register_Menus; +var G, H: Integer; +begin + H := RegisterNamespace(0, 'Menus'); + // Begin of class TMenuItem + G := RegisterClassType(H, TMenuItem); + // End of class TMenuItem + // Begin of class EMenuError + G := RegisterClassType(H, EMenuError); + // End of class EMenuError + // Begin of class TMenu + G := RegisterClassType(H, TMenu); + // End of class TMenu + RegisterRTTIType(H, TypeInfo(TMenuBreak)); + RegisterRTTIType(H, TypeInfo(TMenuItemAutoFlag)); + RegisterRTTIType(H, TypeInfo(TMenuAutoFlag)); + // Begin of class TMenuActionLink + G := RegisterClassType(H, TMenuActionLink); + RegisterHeader(G, + 'constructor Create(AOwner: TComponent); virtual;', + @TMenuActionLink.Create); + // End of class TMenuActionLink + RegisterClassReferenceType(H, 'TMenuActionLinkClass'); + // Begin of class TMenuItem + G := RegisterClassType(H, TMenuItem); + RegisterHeader(G, + 'constructor Create(AOwner: TComponent); override;', + @TMenuItem.Create); + RegisterHeader(G, + 'destructor Destroy; override;', + @TMenuItem.Destroy); + RegisterHeader(G, + 'procedure InitiateAction; virtual;', + @TMenuItem.InitiateAction); + RegisterHeader(G, + 'procedure Insert(Index: Integer; Item: TMenuItem);', + @TMenuItem.Insert); + RegisterHeader(G, + 'procedure Delete(Index: Integer);', + @TMenuItem.Delete); + RegisterHeader(G, + 'procedure Clear;', + @TMenuItem.Clear); + RegisterHeader(G, + 'procedure Click; virtual;', + @TMenuItem.Click); + RegisterHeader(G, + 'function Find(ACaption: string): TMenuItem;', + @TMenuItem.Find); + RegisterHeader(G, + 'function IndexOf(Item: TMenuItem): Integer;', + @TMenuItem.IndexOf); + RegisterHeader(G, + 'function IsLine: Boolean;', + @TMenuItem.IsLine); + RegisterHeader(G, + 'function GetParentComponent: TComponent; override;', + @TMenuItem.GetParentComponent); + RegisterHeader(G, + 'function GetParentMenu: TMenu;', + @TMenuItem.GetParentMenu); + RegisterHeader(G, + 'function HasParent: Boolean; override;', + @TMenuItem.HasParent); + RegisterHeader(G, + 'function NewTopLine: Integer;', + @TMenuItem.NewTopLine); + RegisterHeader(G, + 'function NewBottomLine: Integer;', + @TMenuItem.NewBottomLine); + RegisterHeader(G, + 'function InsertNewLineBefore(AItem: TMenuItem): Integer;', + @TMenuItem.InsertNewLineBefore); + RegisterHeader(G, + 'function InsertNewLineAfter(AItem: TMenuItem): Integer;', + @TMenuItem.InsertNewLineAfter); + RegisterHeader(G, 'procedure Add(Item: TMenuItem); overload;', @TMenuItem_Add1); + RegisterHeader(G, 'procedure Add(const AItems: array of TMenuItem); overload;', @TMenuItem_Add2); + RegisterHeader(G, + 'procedure Remove(Item: TMenuItem);', + @TMenuItem.Remove); + RegisterHeader(G, + 'function RethinkHotkeys: Boolean;', + @TMenuItem.RethinkHotkeys); + RegisterHeader(G, + 'function RethinkLines: Boolean;', + @TMenuItem.RethinkLines); + RegisterFakeHeader(G, + 'function TMenuItem_GetCommand:Word;', + @TMenuItem_GetCommand); + RegisterProperty(G, + 'property Command:Word read TMenuItem_GetCommand;'); + RegisterFakeHeader(G, + 'function TMenuItem_GetCount:Integer;', + @TMenuItem_GetCount); + RegisterProperty(G, + 'property Count:Integer read TMenuItem_GetCount;'); + RegisterFakeHeader(G, + 'function TMenuItem_GetItems(Index: Integer):TMenuItem;', + @TMenuItem_GetItems); + RegisterProperty(G, + 'property Items[Index: Integer]:TMenuItem read TMenuItem_GetItems;default;'); + RegisterFakeHeader(G, + 'function TMenuItem_GetMenuIndex:Integer;', + @TMenuItem_GetMenuIndex); + RegisterFakeHeader(G, + 'procedure TMenuItem_PutMenuIndex(const Value: Integer);', + @TMenuItem_PutMenuIndex); + RegisterProperty(G, + 'property MenuIndex:Integer read TMenuItem_GetMenuIndex write TMenuItem_PutMenuIndex;'); + RegisterFakeHeader(G, + 'function TMenuItem_GetParent:TMenuItem;', + @TMenuItem_GetParent); + RegisterProperty(G, + 'property Parent:TMenuItem read TMenuItem_GetParent;'); + // End of class TMenuItem + RegisterRTTIType(H, TypeInfo(TFindItemKind)); + // Begin of class TMenu + G := RegisterClassType(H, TMenu); + RegisterHeader(G, + 'constructor Create(AOwner: TComponent); override;', + @TMenu.Create); + RegisterHeader(G, + 'destructor Destroy; override;', + @TMenu.Destroy); + RegisterHeader(G, + 'function DispatchCommand(ACommand: Word): Boolean;', + @TMenu.DispatchCommand); + RegisterHeader(G, + 'function FindItem(Value: Integer; Kind: TFindItemKind): TMenuItem;', + @TMenu.FindItem); + RegisterHeader(G, + 'function IsRightToLeft: Boolean;', + @TMenu.IsRightToLeft); + RegisterHeader(G, 'procedure ParentBiDiModeChanged; overload;', @TMenu_ParentBiDiModeChanged3); + RegisterHeader(G, 'procedure ParentBiDiModeChanged(AControl: TObject); overload;', @TMenu_ParentBiDiModeChanged4); + RegisterFakeHeader(G, + 'function TMenu_GetAutoHotkeys:TMenuAutoFlag;', + @TMenu_GetAutoHotkeys); + RegisterFakeHeader(G, + 'procedure TMenu_PutAutoHotkeys(const Value: TMenuAutoFlag);', + @TMenu_PutAutoHotkeys); + RegisterProperty(G, + 'property AutoHotkeys:TMenuAutoFlag read TMenu_GetAutoHotkeys write TMenu_PutAutoHotkeys;'); + RegisterFakeHeader(G, + 'function TMenu_GetAutoLineReduction:TMenuAutoFlag;', + @TMenu_GetAutoLineReduction); + RegisterFakeHeader(G, + 'procedure TMenu_PutAutoLineReduction(const Value: TMenuAutoFlag);', + @TMenu_PutAutoLineReduction); + RegisterProperty(G, + 'property AutoLineReduction:TMenuAutoFlag read TMenu_GetAutoLineReduction write TMenu_PutAutoLineReduction;'); + RegisterFakeHeader(G, + 'function TMenu_GetOwnerDraw:Boolean;', + @TMenu_GetOwnerDraw); + RegisterFakeHeader(G, + 'procedure TMenu_PutOwnerDraw(const Value: Boolean);', + @TMenu_PutOwnerDraw); + RegisterProperty(G, + 'property OwnerDraw:Boolean read TMenu_GetOwnerDraw write TMenu_PutOwnerDraw;'); + RegisterFakeHeader(G, + 'function TMenu_GetParentBiDiMode:Boolean;', + @TMenu_GetParentBiDiMode); + RegisterFakeHeader(G, + 'procedure TMenu_PutParentBiDiMode(const Value: Boolean);', + @TMenu_PutParentBiDiMode); + RegisterProperty(G, + 'property ParentBiDiMode:Boolean read TMenu_GetParentBiDiMode write TMenu_PutParentBiDiMode;'); + // End of class TMenu + // Begin of class TMainMenu + G := RegisterClassType(H, TMainMenu); + RegisterHeader(G, + 'procedure Merge(Menu: TMainMenu);', + @TMainMenu.Merge); + RegisterHeader(G, + 'procedure Unmerge(Menu: TMainMenu);', + @TMainMenu.Unmerge); + RegisterHeader(G, + 'constructor Create(Owner: TComponent);', + @TMainMenu.Create); + // End of class TMainMenu + RegisterRTTIType(H, TypeInfo(TPopupAlignment)); + RegisterRTTIType(H, TypeInfo(TTrackButton)); + RegisterRTTIType(H, TypeInfo(TMenuAnimations)); + RegisterRTTIType(H, TypeInfo(TMenuAnimation)); + // Begin of class TPopupMenu + G := RegisterClassType(H, TPopupMenu); + RegisterHeader(G, + 'constructor Create(AOwner: TComponent); override;', + @TPopupMenu.Create); + RegisterHeader(G, + 'destructor Destroy; override;', + @TPopupMenu.Destroy); + RegisterHeader(G, + 'procedure Popup(X, Y: Integer); virtual;', + @TPopupMenu.Popup); + RegisterFakeHeader(G, + 'function TPopupMenu_GetPopupComponent:TComponent;', + @TPopupMenu_GetPopupComponent); + RegisterFakeHeader(G, + 'procedure TPopupMenu_PutPopupComponent(const Value: TComponent);', + @TPopupMenu_PutPopupComponent); + RegisterProperty(G, + 'property PopupComponent:TComponent read TPopupMenu_GetPopupComponent write TPopupMenu_PutPopupComponent;'); + RegisterFakeHeader(G, + 'function TPopupMenu_GetPopupPoint:TPoint;', + @TPopupMenu_GetPopupPoint); + RegisterProperty(G, + 'property PopupPoint:TPoint read TPopupMenu_GetPopupPoint;'); + // End of class TPopupMenu + // Begin of class TPopupList + G := RegisterClassType(H, TPopupList); + RegisterHeader(G, + 'procedure Add(Popup: TPopupMenu);', + @TPopupList.Add); + RegisterHeader(G, + 'procedure Remove(Popup: TPopupMenu);', + @TPopupList.Remove); + RegisterHeader(G, + 'constructor Create(AOwner: TComponent); virtual;', + @TPopupList.Create); + // End of class TPopupList + // Begin of class TMenuItemStack + G := RegisterClassType(H, TMenuItemStack); + RegisterHeader(G, + 'procedure ClearItem(AItem: TMenuItem);', + @TMenuItemStack.ClearItem); + RegisterHeader(G, + 'constructor Create(AOwner: TComponent); virtual;', + @TMenuItemStack.Create); + // End of class TMenuItemStack + RegisterVariable(H, 'PopupList: TPopupList;',@PopupList); + RegisterVariable(H, 'ShortCutItems: TMenuItemStack;',@ShortCutItems); + RegisterHeader(H, 'function NewMenu(Owner: TComponent; const AName: string; const Items: array of TMenuItem): TMainMenu;', @NewMenu); + RegisterHeader(H, 'function NewPopupMenu(Owner: TComponent; const AName: string; Alignment: TPopupAlignment; AutoPopup: Boolean; const Items: array of TMenuItem): TPopupMenu;', @NewPopupMenu); + RegisterHeader(H, 'function NewLine: TMenuItem;', @NewLine); + RegisterConstant(H, 'cHotkeyPrefix', '&'); + RegisterConstant(H, 'cLineCaption', '-'); + RegisterConstant(H, 'cDialogSuffix', '...'); + RegisterHeader(H, 'function StripHotkey(const Text: string): string;', @StripHotkey); + RegisterHeader(H, 'function GetHotkey(const Text: string): string;', @GetHotkey); + RegisterHeader(H, 'function AnsiSameCaption(const Text1, Text2: string): Boolean;', @AnsiSameCaption); +end; +end. diff --git a/Demos/ANOTHER_DEMOS/IMPORT/IMPORT_StdCtrls.pas b/Demos/ANOTHER_DEMOS/IMPORT/IMPORT_StdCtrls.pas new file mode 100644 index 0000000..2e8512e --- /dev/null +++ b/Demos/ANOTHER_DEMOS/IMPORT/IMPORT_StdCtrls.pas @@ -0,0 +1,641 @@ +{$I PaxCompiler.def} + +unit IMPORT_StdCtrls; +interface +uses + SysUtils, + Classes, +{$IFDEF DPULSAR} + Winapi.Messages, + Winapi.Windows, + Vcl.Controls, + Vcl.Forms, + Vcl.Menus, + Vcl.Graphics, + Vcl.StdCtrls, +{$ELSE} + Messages, + Windows, + Controls, + Forms, + Menus, + Graphics, + StdCtrls, +{$ENDIF} + Variants, + PaxRegister, + PaxCompiler; + +procedure Register_StdCtrls; +implementation + +type + TMemoStrings = class(TStrings) + private + Memo: TCustomMemo; + public + // procedure Clear; override; + end; + + // procedure TMemoStrings.Clear; + // begin + // Memo.Clear; + // end; + + procedure TMemoStrings_Clear(Self: TMemoStrings); // fake method + begin + Self.Memo.Clear; + end; + +type + TListBoxStrings = class(TStrings) + private + ListBox: TCustomListBox; + public +// procedure Clear; override; + end; + + // procedure TListBoxStrings.Clear; + // begin + // ListBox.Clear; + // end; + + procedure TListBoxStrings_Clear(Self: TListBoxStrings); // fake method + begin + Self.ListBox.Clear; + end; + + + +function TCustomEdit_GetCanUndo(Self:TCustomEdit):Boolean; +begin + result := Self.CanUndo; +end; +function TCustomEdit_GetModified(Self:TCustomEdit):Boolean; +begin + result := Self.Modified; +end; +procedure TCustomEdit_PutModified(Self:TCustomEdit;const Value: Boolean); +begin + Self.Modified := Value; +end; +function TCustomEdit_GetSelLength(Self:TCustomEdit):Integer; +begin + result := Self.SelLength; +end; +procedure TCustomEdit_PutSelLength(Self:TCustomEdit;const Value: Integer); +begin + Self.SelLength := Value; +end; +function TCustomEdit_GetSelStart(Self:TCustomEdit):Integer; +begin + result := Self.SelStart; +end; +procedure TCustomEdit_PutSelStart(Self:TCustomEdit;const Value: Integer); +begin + Self.SelStart := Value; +end; +function TCustomEdit_GetSelText(Self:TCustomEdit):string; +begin + result := Self.SelText; +end; +procedure TCustomEdit_PutSelText(Self:TCustomEdit;const Value: string); +begin + Self.SelText := Value; +end; +function TCustomMemo_GetCaretPos(Self:TCustomMemo):TPoint; +begin + result := Self.CaretPos; +end; +procedure TCustomMemo_PutCaretPos(Self:TCustomMemo;const Value: TPoint); +begin + Self.CaretPos := Value; +end; +function TCustomCombo_GetDroppedDown(Self:TCustomCombo):Boolean; +begin + result := Self.DroppedDown; +end; +procedure TCustomCombo_PutDroppedDown(Self:TCustomCombo;const Value: Boolean); +begin + Self.DroppedDown := Value; +end; +function TCustomCombo_GetSelLength(Self:TCustomCombo):Integer; +begin + result := Self.SelLength; +end; +procedure TCustomCombo_PutSelLength(Self:TCustomCombo;const Value: Integer); +begin + Self.SelLength := Value; +end; +function TCustomCombo_GetSelStart(Self:TCustomCombo):Integer; +begin + result := Self.SelStart; +end; +procedure TCustomCombo_PutSelStart(Self:TCustomCombo;const Value: Integer); +begin + Self.SelStart := Value; +end; +function TCustomComboBox_GetAutoComplete(Self:TCustomComboBox):Boolean; +begin + result := Self.AutoComplete; +end; +procedure TCustomComboBox_PutAutoComplete(Self:TCustomComboBox;const Value: Boolean); +begin + Self.AutoComplete := Value; +end; +function TCustomComboBox_GetAutoCloseUp(Self:TCustomComboBox):Boolean; +begin + result := Self.AutoCloseUp; +end; +procedure TCustomComboBox_PutAutoCloseUp(Self:TCustomComboBox;const Value: Boolean); +begin + Self.AutoCloseUp := Value; +end; +function TCustomComboBox_GetAutoDropDown(Self:TCustomComboBox):Boolean; +begin + result := Self.AutoDropDown; +end; +procedure TCustomComboBox_PutAutoDropDown(Self:TCustomComboBox;const Value: Boolean); +begin + Self.AutoDropDown := Value; +end; +function TCustomComboBox_GetCharCase(Self:TCustomComboBox):TEditCharCase; +begin + result := Self.CharCase; +end; +procedure TCustomComboBox_PutCharCase(Self:TCustomComboBox;const Value: TEditCharCase); +begin + Self.CharCase := Value; +end; +function TCustomComboBox_GetSelText(Self:TCustomComboBox):string; +begin + result := Self.SelText; +end; +procedure TCustomComboBox_PutSelText(Self:TCustomComboBox;const Value: string); +begin + Self.SelText := Value; +end; +function TCustomListBox_GetAutoComplete(Self:TCustomListBox):Boolean; +begin + result := Self.AutoComplete; +end; +procedure TCustomListBox_PutAutoComplete(Self:TCustomListBox;const Value: Boolean); +begin + Self.AutoComplete := Value; +end; +function TCustomListBox_GetCount(Self:TCustomListBox):Integer; +begin + result := Self.Count; +end; +procedure TCustomListBox_PutCount(Self:TCustomListBox;const Value: Integer); +begin + Self.Count := Value; +end; +function TCustomListBox_GetSelected(Self:TCustomListBox;Index: Integer):Boolean; +begin + result := Self.Selected[Index]; +end; +procedure TCustomListBox_PutSelected(Self:TCustomListBox;Index: Integer;const Value: Boolean); +begin + Self.Selected[Index] := Value; +end; +function TCustomListBox_GetScrollWidth(Self:TCustomListBox):Integer; +begin + result := Self.ScrollWidth; +end; +procedure TCustomListBox_PutScrollWidth(Self:TCustomListBox;const Value: Integer); +begin + Self.ScrollWidth := Value; +end; +function TCustomListBox_GetTopIndex(Self:TCustomListBox):Integer; +begin + result := Self.TopIndex; +end; +procedure TCustomListBox_PutTopIndex(Self:TCustomListBox;const Value: Integer); +begin + Self.TopIndex := Value; +end; +procedure Register_StdCtrls; +var G, H: Integer; +begin + H := RegisterNamespace(0, 'StdCtrls'); + // Begin of class TCustomGroupBox + G := RegisterClassType(H, TCustomGroupBox); + RegisterHeader(G, + 'constructor Create(AOwner: TComponent); override;', + @TCustomGroupBox.Create); + // End of class TCustomGroupBox + // Begin of class TGroupBox + G := RegisterClassType(H, TGroupBox); + RegisterHeader(G, + 'constructor Create(AOwner: TComponent); override;', + @TGroupBox.Create); + // End of class TGroupBox + RegisterRTTIType(H, TypeInfo(TTextLayout)); + // Begin of class TCustomLabel + G := RegisterClassType(H, TCustomLabel); + RegisterHeader(G, + 'constructor Create(AOwner: TComponent); override;', + @TCustomLabel.Create); + // End of class TCustomLabel + // Begin of class TLabel + G := RegisterClassType(H, TLabel); + RegisterHeader(G, + 'constructor Create(AOwner: TComponent); override;', + @TLabel.Create); + // End of class TLabel + RegisterRTTIType(H, TypeInfo(TEditCharCase)); + // Begin of class TCustomEdit + G := RegisterClassType(H, TCustomEdit); + RegisterHeader(G, + 'constructor Create(AOwner: TComponent); override;', + @TCustomEdit.Create); + RegisterHeader(G, + 'procedure Clear; virtual;', + @TCustomEdit.Clear); + RegisterHeader(G, + 'procedure ClearSelection;', + @TCustomEdit.ClearSelection); + RegisterHeader(G, + 'procedure CopyToClipboard;', + @TCustomEdit.CopyToClipboard); + RegisterHeader(G, + 'procedure CutToClipboard;', + @TCustomEdit.CutToClipboard); + RegisterHeader(G, + 'procedure DefaultHandler(var Message); override;', + @TCustomEdit.DefaultHandler); + RegisterHeader(G, + 'procedure PasteFromClipboard;', + @TCustomEdit.PasteFromClipboard); + RegisterHeader(G, + 'procedure Undo;', + @TCustomEdit.Undo); + RegisterHeader(G, + 'procedure ClearUndo;', + @TCustomEdit.ClearUndo); + RegisterHeader(G, + 'function GetSelTextBuf(Buffer: PChar; BufSize: Integer): Integer; virtual;', + @TCustomEdit.GetSelTextBuf); + RegisterHeader(G, + 'procedure SelectAll;', + @TCustomEdit.SelectAll); + RegisterHeader(G, + 'procedure SetSelTextBuf(Buffer: PChar);', + @TCustomEdit.SetSelTextBuf); + RegisterFakeHeader(G, + 'function TCustomEdit_GetCanUndo:Boolean;', + @TCustomEdit_GetCanUndo); + RegisterProperty(G, + 'property CanUndo:Boolean read TCustomEdit_GetCanUndo;'); + RegisterFakeHeader(G, + 'function TCustomEdit_GetModified:Boolean;', + @TCustomEdit_GetModified); + RegisterFakeHeader(G, + 'procedure TCustomEdit_PutModified(const Value: Boolean);', + @TCustomEdit_PutModified); + RegisterProperty(G, + 'property Modified:Boolean read TCustomEdit_GetModified write TCustomEdit_PutModified;'); + RegisterFakeHeader(G, + 'function TCustomEdit_GetSelLength:Integer;', + @TCustomEdit_GetSelLength); + RegisterFakeHeader(G, + 'procedure TCustomEdit_PutSelLength(const Value: Integer);', + @TCustomEdit_PutSelLength); + RegisterProperty(G, + 'property SelLength:Integer read TCustomEdit_GetSelLength write TCustomEdit_PutSelLength;'); + RegisterFakeHeader(G, + 'function TCustomEdit_GetSelStart:Integer;', + @TCustomEdit_GetSelStart); + RegisterFakeHeader(G, + 'procedure TCustomEdit_PutSelStart(const Value: Integer);', + @TCustomEdit_PutSelStart); + RegisterProperty(G, + 'property SelStart:Integer read TCustomEdit_GetSelStart write TCustomEdit_PutSelStart;'); + RegisterFakeHeader(G, + 'function TCustomEdit_GetSelText:string;', + @TCustomEdit_GetSelText); + RegisterFakeHeader(G, + 'procedure TCustomEdit_PutSelText(const Value: string);', + @TCustomEdit_PutSelText); + RegisterProperty(G, + 'property SelText:string read TCustomEdit_GetSelText write TCustomEdit_PutSelText;'); + // End of class TCustomEdit + // Begin of class TEdit + G := RegisterClassType(H, TEdit); + RegisterHeader(G, + 'constructor Create(AOwner: TComponent); override;', + @TEdit.Create); + // End of class TEdit + RegisterRTTIType(H, TypeInfo(TScrollStyle)); + // Begin of class TCustomMemo + G := RegisterClassType(H, TCustomMemo); + RegisterHeader(G, + 'constructor Create(AOwner: TComponent); override;', + @TCustomMemo.Create); + RegisterHeader(G, + 'destructor Destroy; override;', + @TCustomMemo.Destroy); + RegisterFakeHeader(G, + 'function TCustomMemo_GetCaretPos:TPoint;', + @TCustomMemo_GetCaretPos); + RegisterFakeHeader(G, + 'procedure TCustomMemo_PutCaretPos(const Value: TPoint);', + @TCustomMemo_PutCaretPos); + RegisterProperty(G, + 'property CaretPos:TPoint read TCustomMemo_GetCaretPos write TCustomMemo_PutCaretPos;'); + // End of class TCustomMemo + // Begin of class TMemo + G := RegisterClassType(H, TMemo); + RegisterHeader(G, + 'constructor Create(AOwner: TComponent); override;', + @TMemo.Create); + // End of class TMemo + // Begin of class TCustomCombo + G := RegisterClassType(H, TCustomCombo); + // End of class TCustomCombo + // Begin of class TCustomComboBoxStrings + G := RegisterClassType(H, TCustomComboBoxStrings); + RegisterHeader(G, + 'procedure Clear; override;', + @TCustomComboBoxStrings.Clear); + RegisterHeader(G, + 'procedure Delete(Index: Integer); override;', + @TCustomComboBoxStrings.Delete); + RegisterHeader(G, + 'function IndexOf(const S: string): Integer; override;', + @TCustomComboBoxStrings.IndexOf); + RegisterHeader(G, + 'constructor Create(AOwner: TComponent); virtual;', + @TCustomComboBoxStrings.Create); + // End of class TCustomComboBoxStrings + RegisterClassReferenceType(H, 'TCustomComboBoxStringsClass'); + // Begin of class TCustomCombo + G := RegisterClassType(H, TCustomCombo); + RegisterHeader(G, + 'constructor Create(AOwner: TComponent); override;', + @TCustomCombo.Create); + RegisterHeader(G, + 'destructor Destroy; override;', + @TCustomCombo.Destroy); + RegisterHeader(G, + 'procedure AddItem(Item: String; AObject: TObject); override;', + @TCustomCombo.AddItem); + RegisterHeader(G, + 'procedure Clear; override;', + @TCustomCombo.Clear); + RegisterHeader(G, + 'procedure ClearSelection; override;', + @TCustomCombo.ClearSelection); + RegisterHeader(G, + 'procedure CopySelection(Destination: TCustomListControl); override;', + @TCustomCombo.CopySelection); + RegisterHeader(G, + 'procedure DeleteSelected; override;', + @TCustomCombo.DeleteSelected); + RegisterHeader(G, + 'function Focused: Boolean; override;', + @TCustomCombo.Focused); + RegisterHeader(G, + 'procedure SelectAll; override;', + @TCustomCombo.SelectAll); + RegisterFakeHeader(G, + 'function TCustomCombo_GetDroppedDown:Boolean;', + @TCustomCombo_GetDroppedDown); + RegisterFakeHeader(G, + 'procedure TCustomCombo_PutDroppedDown(const Value: Boolean);', + @TCustomCombo_PutDroppedDown); + RegisterProperty(G, + 'property DroppedDown:Boolean read TCustomCombo_GetDroppedDown write TCustomCombo_PutDroppedDown;'); + RegisterFakeHeader(G, + 'function TCustomCombo_GetSelLength:Integer;', + @TCustomCombo_GetSelLength); + RegisterFakeHeader(G, + 'procedure TCustomCombo_PutSelLength(const Value: Integer);', + @TCustomCombo_PutSelLength); + RegisterProperty(G, + 'property SelLength:Integer read TCustomCombo_GetSelLength write TCustomCombo_PutSelLength;'); + RegisterFakeHeader(G, + 'function TCustomCombo_GetSelStart:Integer;', + @TCustomCombo_GetSelStart); + RegisterFakeHeader(G, + 'procedure TCustomCombo_PutSelStart(const Value: Integer);', + @TCustomCombo_PutSelStart); + RegisterProperty(G, + 'property SelStart:Integer read TCustomCombo_GetSelStart write TCustomCombo_PutSelStart;'); + // End of class TCustomCombo + RegisterRTTIType(H, TypeInfo(TComboBoxStyle)); + // Begin of class TCustomComboBox + G := RegisterClassType(H, TCustomComboBox); + RegisterHeader(G, + 'constructor Create(AOwner: TComponent); override;', + @TCustomComboBox.Create); + RegisterHeader(G, + 'destructor Destroy; override;', + @TCustomComboBox.Destroy); + RegisterFakeHeader(G, + 'function TCustomComboBox_GetAutoComplete:Boolean;', + @TCustomComboBox_GetAutoComplete); + RegisterFakeHeader(G, + 'procedure TCustomComboBox_PutAutoComplete(const Value: Boolean);', + @TCustomComboBox_PutAutoComplete); + RegisterProperty(G, + 'property AutoComplete:Boolean read TCustomComboBox_GetAutoComplete write TCustomComboBox_PutAutoComplete;'); + RegisterFakeHeader(G, + 'function TCustomComboBox_GetAutoCloseUp:Boolean;', + @TCustomComboBox_GetAutoCloseUp); + RegisterFakeHeader(G, + 'procedure TCustomComboBox_PutAutoCloseUp(const Value: Boolean);', + @TCustomComboBox_PutAutoCloseUp); + RegisterProperty(G, + 'property AutoCloseUp:Boolean read TCustomComboBox_GetAutoCloseUp write TCustomComboBox_PutAutoCloseUp;'); + RegisterFakeHeader(G, + 'function TCustomComboBox_GetAutoDropDown:Boolean;', + @TCustomComboBox_GetAutoDropDown); + RegisterFakeHeader(G, + 'procedure TCustomComboBox_PutAutoDropDown(const Value: Boolean);', + @TCustomComboBox_PutAutoDropDown); + RegisterProperty(G, + 'property AutoDropDown:Boolean read TCustomComboBox_GetAutoDropDown write TCustomComboBox_PutAutoDropDown;'); + RegisterFakeHeader(G, + 'function TCustomComboBox_GetCharCase:TEditCharCase;', + @TCustomComboBox_GetCharCase); + RegisterFakeHeader(G, + 'procedure TCustomComboBox_PutCharCase(const Value: TEditCharCase);', + @TCustomComboBox_PutCharCase); + RegisterProperty(G, + 'property CharCase:TEditCharCase read TCustomComboBox_GetCharCase write TCustomComboBox_PutCharCase;'); + RegisterFakeHeader(G, + 'function TCustomComboBox_GetSelText:string;', + @TCustomComboBox_GetSelText); + RegisterFakeHeader(G, + 'procedure TCustomComboBox_PutSelText(const Value: string);', + @TCustomComboBox_PutSelText); + RegisterProperty(G, + 'property SelText:string read TCustomComboBox_GetSelText write TCustomComboBox_PutSelText;'); + // End of class TCustomComboBox + // Begin of class TComboBox + G := RegisterClassType(H, TComboBox); + RegisterHeader(G, + 'constructor Create(AOwner: TComponent); override;', + @TComboBox.Create); + // End of class TComboBox + // Begin of class TButtonControl + G := RegisterClassType(H, TButtonControl); + // End of class TButtonControl + // Begin of class TButtonActionLink + G := RegisterClassType(H, TButtonActionLink); + RegisterHeader(G, + 'constructor Create(AOwner: TComponent); virtual;', + @TButtonActionLink.Create); + // End of class TButtonActionLink + RegisterClassReferenceType(H, 'TButtonActionLinkClass'); + // Begin of class TButtonControl + G := RegisterClassType(H, TButtonControl); + RegisterHeader(G, + 'constructor Create(AOwner: TComponent); override;', + @TButtonControl.Create); + // End of class TButtonControl + // Begin of class TButton + G := RegisterClassType(H, TButton); + RegisterHeader(G, + 'constructor Create(AOwner: TComponent); override;', + @TButton.Create); + RegisterHeader(G, + 'procedure Click; override;', + @TButton.Click); + RegisterHeader(G, + 'function UseRightToLeftAlignment: Boolean; override;', + @TButton.UseRightToLeftAlignment); + // End of class TButton + RegisterRTTIType(H, TypeInfo(TCheckBoxState)); + // Begin of class TCustomCheckBox + G := RegisterClassType(H, TCustomCheckBox); + RegisterHeader(G, + 'constructor Create(AOwner: TComponent); override;', + @TCustomCheckBox.Create); + // End of class TCustomCheckBox + // Begin of class TCheckBox + G := RegisterClassType(H, TCheckBox); + RegisterHeader(G, + 'constructor Create(AOwner: TComponent); override;', + @TCheckBox.Create); + // End of class TCheckBox + // Begin of class TRadioButton + G := RegisterClassType(H, TRadioButton); + RegisterHeader(G, + 'constructor Create(AOwner: TComponent); override;', + @TRadioButton.Create); + // End of class TRadioButton + RegisterRTTIType(H, TypeInfo(TListBoxStyle)); + // Begin of class TCustomListBox + G := RegisterClassType(H, TCustomListBox); + RegisterHeader(G, + 'constructor Create(AOwner: TComponent); override;', + @TCustomListBox.Create); + RegisterHeader(G, + 'destructor Destroy; override;', + @TCustomListBox.Destroy); + RegisterHeader(G, + 'procedure AddItem(Item: String; AObject: TObject); override;', + @TCustomListBox.AddItem); + RegisterHeader(G, + 'procedure Clear; override;', + @TCustomListBox.Clear); + RegisterHeader(G, + 'procedure ClearSelection; override;', + @TCustomListBox.ClearSelection); + RegisterHeader(G, + 'procedure CopySelection(Destination: TCustomListControl); override;', + @TCustomListBox.CopySelection); + RegisterHeader(G, + 'procedure DeleteSelected; override;', + @TCustomListBox.DeleteSelected); + RegisterHeader(G, + 'function ItemAtPos(Pos: TPoint; Existing: Boolean): Integer;', + @TCustomListBox.ItemAtPos); + RegisterHeader(G, + 'function ItemRect(Index: Integer): TRect;', + @TCustomListBox.ItemRect); + RegisterHeader(G, + 'procedure SelectAll; override;', + @TCustomListBox.SelectAll); + RegisterFakeHeader(G, + 'function TCustomListBox_GetAutoComplete:Boolean;', + @TCustomListBox_GetAutoComplete); + RegisterFakeHeader(G, + 'procedure TCustomListBox_PutAutoComplete(const Value: Boolean);', + @TCustomListBox_PutAutoComplete); + RegisterProperty(G, + 'property AutoComplete:Boolean read TCustomListBox_GetAutoComplete write TCustomListBox_PutAutoComplete;'); + RegisterFakeHeader(G, + 'function TCustomListBox_GetCount:Integer;', + @TCustomListBox_GetCount); + RegisterFakeHeader(G, + 'procedure TCustomListBox_PutCount(const Value: Integer);', + @TCustomListBox_PutCount); + RegisterProperty(G, + 'property Count:Integer read TCustomListBox_GetCount write TCustomListBox_PutCount;'); + RegisterFakeHeader(G, + 'function TCustomListBox_GetSelected(Index: Integer):Boolean;', + @TCustomListBox_GetSelected); + RegisterFakeHeader(G, + 'procedure TCustomListBox_PutSelected(Index: Integer;const Value: Boolean);', + @TCustomListBox_PutSelected); + RegisterProperty(G, + 'property Selected[Index: Integer]:Boolean read TCustomListBox_GetSelected write TCustomListBox_PutSelected;'); + RegisterFakeHeader(G, + 'function TCustomListBox_GetScrollWidth:Integer;', + @TCustomListBox_GetScrollWidth); + RegisterFakeHeader(G, + 'procedure TCustomListBox_PutScrollWidth(const Value: Integer);', + @TCustomListBox_PutScrollWidth); + RegisterProperty(G, + 'property ScrollWidth:Integer read TCustomListBox_GetScrollWidth write TCustomListBox_PutScrollWidth;'); + RegisterFakeHeader(G, + 'function TCustomListBox_GetTopIndex:Integer;', + @TCustomListBox_GetTopIndex); + RegisterFakeHeader(G, + 'procedure TCustomListBox_PutTopIndex(const Value: Integer);', + @TCustomListBox_PutTopIndex); + RegisterProperty(G, + 'property TopIndex:Integer read TCustomListBox_GetTopIndex write TCustomListBox_PutTopIndex;'); + // End of class TCustomListBox + // Begin of class TListBox + G := RegisterClassType(H, TListBox); + RegisterHeader(G, + 'constructor Create(AOwner: TComponent); override;', + @TListBox.Create); + // End of class TListBox + RegisterRTTIType(H, TypeInfo(TScrollCode)); + // Begin of class TScrollBar + G := RegisterClassType(H, TScrollBar); + RegisterHeader(G, + 'constructor Create(AOwner: TComponent); override;', + @TScrollBar.Create); + RegisterHeader(G, + 'procedure SetParams(APosition, AMin, AMax: Integer);', + @TScrollBar.SetParams); + // End of class TScrollBar + RegisterRTTIType(H, TypeInfo(TStaticBorderStyle)); + // Begin of class TCustomStaticText + G := RegisterClassType(H, TCustomStaticText); + RegisterHeader(G, + 'constructor Create(AOwner: TComponent); override;', + @TCustomStaticText.Create); + // End of class TCustomStaticText + // Begin of class TStaticText + G := RegisterClassType(H, TStaticText); + RegisterHeader(G, + 'constructor Create(AOwner: TComponent); override;', + @TStaticText.Create); + // End of class TStaticText + + G := RegisterClassType(H, TMemoStrings); + RegisterHeader(G, 'procedure Clear; override;', @TMemoStrings_Clear); + + G := RegisterClassType(H, TListBoxStrings); + RegisterHeader(G, 'procedure Clear; override;', @TListBoxStrings_Clear); + +end; +end. diff --git a/Demos/ANOTHER_DEMOS/IMPORT/IMPORT_SysUtils.pas b/Demos/ANOTHER_DEMOS/IMPORT/IMPORT_SysUtils.pas new file mode 100644 index 0000000..ad6501f --- /dev/null +++ b/Demos/ANOTHER_DEMOS/IMPORT/IMPORT_SysUtils.pas @@ -0,0 +1,375 @@ +unit IMPORT_SysUtils; +interface +uses + SysUtils, + PaxRegister, + PaxCompiler; + +procedure Register_SysUtils; + +implementation + +function _Format(const S: string; const Args: array of const): string; +begin + result := Format(S, Args); +end; + +// Exception ------------------------------------------------------------------- + +function Exception_GetMessage(Self: Exception): String; +begin + result := Self.Message; +end; + +procedure Exception_SetMessage(Self: Exception; const Value: String); +begin + Self.Message := Value; +end; + +function Exception_GetHelpContext(Self: Exception): Integer; +begin + result := Self.HelpContext; +end; + +procedure Exception_SetHelpContext(Self: Exception; Value: Integer); +begin + Self.HelpContext := Value; +end; + +procedure Register_SysUtils; +var + H, G: Integer; +begin + H := RegisterNamespace(0, 'SysUtils'); + + RegisterRTTIType(H, TypeInfo(TReplaceFlags)); + + G := RegisterRecordType(H, 'TTimeStamp'); + RegisterRecordTypeField(G, 'Time', _typeINTEGER); + RegisterRecordTypeField(G, 'Date', _typeINTEGER); + + G := RegisterRecordType(H, 'TSystemTime'); + RegisterRecordTypeField(G, 'wYear', _typeWORD); + RegisterRecordTypeField(G, 'wMonth', _typeWORD); + RegisterRecordTypeField(G, 'wDayOfWeek', _typeWORD); + RegisterRecordTypeField(G, 'wDay', _typeWORD); + RegisterRecordTypeField(G, 'wHour', _typeWORD); + RegisterRecordTypeField(G, 'wMinute', _typeWORD); + RegisterRecordTypeField(G, 'wSecond', _typeWORD); + RegisterRecordTypeField(G, 'wMilliSecond', _typeWORD); + +{ File open modes } + + RegisterConstant(H, 'fmOpenRead', fmOpenRead); + RegisterConstant(H, 'fmOpenWrite', fmOpenWrite); + RegisterConstant(H, 'fmOpenReadWrite', fmOpenReadWrite); + RegisterConstant(H, 'fmShareExclusive', fmShareExclusive); + RegisterConstant(H, 'fmShareDenyWrite', fmShareDenyWrite); + RegisterConstant(H, 'fmShareDenyNone', fmShareDenyNone); +{$IFNDEF MACOS} + RegisterConstant(H, 'fmShareCompat', fmShareCompat); + RegisterConstant(H, 'fmShareDenyRead', fmShareDenyRead); +{$ENDIF} + +{ File attribute constants } + + RegisterConstant(H, 'faReadOnly', faReadOnly); + RegisterConstant(H, 'faHidden', faHidden); + RegisterConstant(H, 'faSysFile', faSysFile); + RegisterConstant(H, 'faVolumeID', faVolumeID); + RegisterConstant(H, 'faDirectory', faDirectory); + RegisterConstant(H, 'faArchive', faArchive); + RegisterConstant(H, 'faAnyFile', faAnyFile); + +{ File mode magic numbers } + + RegisterConstant(H, 'fmClosed', fmClosed); + RegisterConstant(H, 'fmInput', fmInput); + RegisterConstant(H, 'fmOutput', fmOutput); + RegisterConstant(H, 'fmInOut', fmInOut); + +{ Seconds and milliseconds per day } + + RegisterConstant(H, 'SecsPerDay', SecsPerDay); + RegisterConstant(H, 'MSecsPerDay', MSecsPerDay); + +{ Days between 1/1/0001 and 12/31/1899 } + + RegisterConstant(H, 'DateDelta', DateDelta); + + RegisterHeader(H, 'function UpperCase(const S: string): string;', @UpperCase); + RegisterHeader(H, 'function LowerCase(const S: string): string;', @LowerCase); + RegisterHeader(H, 'function CompareStr(const S1, S2: string): Integer;', @CompareStr); + RegisterHeader(H, 'function CompareMem(P1, P2: Pointer; Length: Integer): Boolean;', @CompareMem); + RegisterHeader(H, 'function CompareText(const S1, S2: string): Integer;', @CompareText); + RegisterHeader(H, 'function SameText(const S1, S2: string): Boolean;', @SameText); + RegisterHeader(H, 'function AnsiUpperCase(const S: string): string;', @AnsiUpperCase); + RegisterHeader(H, 'function AnsiLowerCase(const S: string): string;', @AnsiLowerCase); + RegisterHeader(H, 'function AnsiCompareStr(const S1, S2: string): Integer;', @AnsiCompareStr); + RegisterHeader(H, 'function AnsiSameStr(const S1, S2: string): Boolean;', @AnsiSameStr); + RegisterHeader(H, 'function AnsiCompareText(const S1, S2: string): Integer;', @AnsiCompareText); + RegisterHeader(H, 'function AnsiSameText(const S1, S2: string): Boolean;', @AnsiSameText); + RegisterHeader(H, 'function AnsiStrComp(S1, S2: PChar): Integer;', @AnsiStrComp); + RegisterHeader(H, 'function AnsiStrIComp(S1, S2: PChar): Integer;', @AnsiStrIComp); + RegisterHeader(H, 'function AnsiStrLComp(S1, S2: PChar; MaxLen: Cardinal): Integer;', @AnsiStrLComp); + RegisterHeader(H, 'function AnsiStrLIComp(S1, S2: PChar; MaxLen: Cardinal): Integer;', @AnsiStrLIComp); + RegisterHeader(H, 'function AnsiStrLower(Str: PChar): PChar;', @AnsiStrLower); + RegisterHeader(H, 'function AnsiStrUpper(Str: PChar): PChar;', @AnsiStrUpper); + RegisterHeader(H, 'function AnsiLastChar(const S: string): PChar;', @AnsiLastChar); + RegisterHeader(H, 'function AnsiStrLastChar(P: PChar): PChar;', @AnsiStrLastChar); + RegisterHeader(H, 'function Trim(const S: string): string;', @Trim); + RegisterHeader(H, 'function TrimLeft(const S: string): string;', @TrimLeft); + RegisterHeader(H, 'function TrimRight(const S: string): string;', @TrimRight); + RegisterHeader(H, 'function QuotedStr(const S: string): string;', @QuotedStr); + RegisterHeader(H, 'function AnsiQuotedStr(const S: string; Quote: Char): string;', @AnsiQuotedStr); + RegisterHeader(H, 'function AnsiExtractQuotedStr(var Src: PChar; Quote: Char): string;', @AnsiExtractQuotedStr); + RegisterHeader(H, 'function AdjustLineBreaks(const S: string): string;', @AdjustLineBreaks); + RegisterHeader(H, 'function IsValidIdent(const Ident: string): Boolean;', @IsValidIdent); + RegisterHeader(H, 'function IntToStr(Value: Integer): string;', @IntToStr); + RegisterHeader(H, 'function IntToHex(Value: Integer; Digits: Integer): string;', @IntToHex); + RegisterHeader(H, 'function StrToInt(const S: string): Integer;', @StrToInt); + RegisterHeader(H, 'function StrToIntDef(const S: string; Default: Integer): Integer;', @StrToIntDef); + RegisterHeader(H, 'function LoadStr(Ident: Integer): string;', @LoadStr); + RegisterHeader(H, 'function FileOpen(const FileName: string; Mode: LongWord): Integer;', @FileOpen); + RegisterHeader(H, 'function FileCreate(const FileName: string): Integer;', @FileCreate); + RegisterHeader(H, 'function FileRead(Handle: Integer; var Buffer; Count: LongWord): Integer;', @FileRead); + RegisterHeader(H, 'function FileWrite(Handle: Integer; const Buffer; Count: LongWord): Integer;', @FileWrite); + RegisterHeader(H, 'function FileSeek(Handle, Offset, Origin: Integer): Integer;', @FileSeek); + RegisterHeader(H, 'procedure FileClose(Handle: Integer);', @FileClose); + RegisterHeader(H, 'function FileAge(const FileName: string): Integer;', @FileAge); + RegisterHeader(H, 'function FileExists(const FileName: string): Boolean;', @FileExists); + RegisterHeader(H, 'function FileGetDate(Handle: Integer): Integer;', @FileGetDate); + RegisterHeader(H, 'function FileSetDate(Handle: Integer; Age: Integer): Integer;', @FileSetDate); + RegisterHeader(H, 'function FileGetAttr(const FileName: string): Integer;', @FileGetAttr); + RegisterHeader(H, 'function DeleteFile(const FileName: string): Boolean;', @DeleteFile); + RegisterHeader(H, 'function RenameFile(const OldName, NewName: string): Boolean;', @RenameFile); + RegisterHeader(H, 'function ChangeFileExt(const FileName, Extension: string): string;', @ChangeFileExt); + RegisterHeader(H, 'function ExtractFilePath(const FileName: string): string;', @ExtractFilePath); + RegisterHeader(H, 'function ExtractFileDir(const FileName: string): string;', @ExtractFileDir); + RegisterHeader(H, 'function ExtractFileDrive(const FileName: string): string;', @ExtractFileDrive); + RegisterHeader(H, 'function ExtractFileName(const FileName: string): string;', @ExtractFileName); + RegisterHeader(H, 'function ExtractFileExt(const FileName: string): string;', @ExtractFileExt); + RegisterHeader(H, 'function ExpandFileName(const FileName: string): string;', @ExpandFileName); + RegisterHeader(H, 'function ExpandUNCFileName(const FileName: string): string;', @ExpandUNCFileName); + RegisterHeader(H, 'function ExtractRelativePath(const BaseName, DestName: string): string;', @ExtractRelativePath); + RegisterHeader(H, 'function FileSearch(const Name, DirList: string): string;', @FileSearch); + RegisterHeader(H, 'function GetCurrentDir: string;', @GetCurrentDir); + RegisterHeader(H, 'function SetCurrentDir(const Dir: string): Boolean;', @SetCurrentDir); + RegisterHeader(H, 'function CreateDir(const Dir: string): Boolean;', @CreateDir); + RegisterHeader(H, 'function RemoveDir(const Dir: string): Boolean;', @RemoveDir); + + RegisterHeader(H, 'function StrLen(const Str: PChar): Cardinal;', @StrLen); + RegisterHeader(H, 'function StrEnd(const Str: PChar): PChar;', @StrEnd); + RegisterHeader(H, 'function StrMove(Dest: PChar; const Source: PChar; Count: Cardinal): PChar;', @StrMove); + RegisterHeader(H, 'function StrCopy(Dest: PChar; const Source: PChar): PChar;', @StrCopy); + RegisterHeader(H, 'function StrECopy(Dest:PChar; const Source: PChar): PChar;', @StrECopy); + RegisterHeader(H, 'function StrLCopy(Dest: PChar; const Source: PChar; MaxLen: Cardinal): PChar;', @StrLCopy); + RegisterHeader(H, 'function StrPCopy(Dest: PChar; const Source: string): PChar;', @StrPCopy); + RegisterHeader(H, 'function StrPLCopy(Dest: PChar; const Source: string; MaxLen: Cardinal): PChar;', @StrPLCopy); + RegisterHeader(H, 'function StrCat(Dest: PChar; const Source: PChar): PChar;', @StrCat); + RegisterHeader(H, 'function StrLCat(Dest: PChar; const Source: PChar; MaxLen: Cardinal): PChar;', @StrLCat); + RegisterHeader(H, 'function StrComp(const Str1, Str2: PChar): Integer;', @StrComp); + RegisterHeader(H, 'function StrIComp(const Str1, Str2: PChar): Integer;', @StrIComp); + RegisterHeader(H, 'function StrLComp(const Str1, Str2: PChar; MaxLen: Cardinal): Integer;', @StrLComp); + RegisterHeader(H, 'function StrLIComp(const Str1, Str2: PChar; MaxLen: Cardinal): Integer;', @StrLIComp); + RegisterHeader(H, 'function StrScan(const Str: PChar; Chr: Char): PChar;', @StrScan); + RegisterHeader(H, 'function StrRScan(const Str: PChar; Chr: Char): PChar;', @StrRScan); + RegisterHeader(H, 'function StrPos(const Str1, Str2: PChar): PChar;', @StrPos); + RegisterHeader(H, 'function StrUpper(Str: PChar): PChar;', @StrUpper); + RegisterHeader(H, 'function StrLower(Str: PChar): PChar;', @StrLower); + RegisterHeader(H, 'function StrPas(const Str: PChar): string;', @StrPas); + RegisterHeader(H, 'function StrAlloc(Size: Cardinal): PChar;', @StrAlloc); + RegisterHeader(H, 'function StrBufSize(const Str: PChar): Cardinal;', @StrBufSize); + RegisterHeader(H, 'function StrNew(const Str: PChar): PChar;', @StrNew); + RegisterHeader(H, 'procedure StrDispose(Str: PChar);', @StrDispose); + + RegisterHeader(H, 'function FloatToStr(Value: Extended): string;', @FloatToStr); + RegisterHeader(H, 'function FormatFloat(const Format: string; Value: Extended): string;', @FormatFloat); + RegisterHeader(H, 'function StrToFloat(const S: string): Extended;', @StrToFloat); + + RegisterHeader(H, 'function DateTimeToTimeStamp(DateTime: TDateTime): TTimeStamp;', @DateTimeToTimeStamp); + RegisterHeader(H, 'function TimeStampToDateTime(const TimeStamp: TTimeStamp): TDateTime;', @TimeStampToDateTime); + RegisterHeader(H, 'function EncodeDate(Year, Month, Day: Word): TDateTime;', @EncodeDate); + RegisterHeader(H, 'function EncodeTime(Hour, Min, Sec, MSec: Word): TDateTime;', @EncodeTime); + RegisterHeader(H, 'procedure DecodeDate(Date: TDateTime; var Year, Month, Day: Word);', @DecodeDate); + RegisterHeader(H, 'procedure DecodeTime(Time: TDateTime; var Hour, Min, Sec, MSec: Word);', @DecodeTime); + RegisterHeader(H, 'function DayOfWeek(Date: TDateTime): Integer;', @DayOfWeek); + RegisterHeader(H, 'function Date: TDateTime;', @Date); + RegisterHeader(H, 'function Time: TDateTime;', @Time); + RegisterHeader(H, 'function Now: TDateTime;', @Now); + RegisterHeader(H, 'function IncMonth(const Date: TDateTime; NumberOfMonths: Integer): TDateTime;', @IncMonth); + RegisterHeader(H, 'procedure ReplaceTime(var DateTime: TDateTime; const NewTime: TDateTime);', @ReplaceTime); + RegisterHeader(H, 'procedure ReplaceDate(var DateTime: TDateTime; const NewDate: TDateTime);', @ReplaceDate); + RegisterHeader(H, 'function IsLeapYear(Year: Word): Boolean;', @IsLeapYear); + RegisterHeader(H, 'function DateToStr(Date: TDateTime): string;', @DateToStr); + RegisterHeader(H, 'function TimeToStr(Time: TDateTime): string;', @TimeToStr); + RegisterHeader(H, 'function DateTimeToStr(DateTime: TDateTime): string;', @DateTimeToStr); + RegisterHeader(H, 'function StrToDate(const S: string): TDateTime;', @StrToDate); + RegisterHeader(H, 'function StrToTime(const S: string): TDateTime;', @StrToTime); + RegisterHeader(H, 'function StrToDateTime(const S: string): TDateTime;', @StrToDateTime); + + RegisterHeader(H, 'function FormatDateTime(const Format: string; DateTime: TDateTime): string;', @FormatDateTime); + RegisterHeader(H, 'procedure GetFormatSettings;', @GetFormatSettings); + + RegisterHeader(H, 'function StringReplace(const S, OldPattern, NewPattern: string; Flags: TReplaceFlags): string;', @StringReplace); + + RegisterHeader(H, 'procedure FreeAndNil(var Obj);', @FreeAndNil); + + RegisterHeader(H, 'function Format(const S: string; const Args: array of const): string;', + @_Format); + +{$IFNDEF MACOS} + RegisterHeader(H, 'function ExtractShortPathName(const FileName: string): string;', @ExtractShortPathName); + RegisterHeader(H, 'function FileSetAttr(const FileName: string; Attr: Integer): Integer;', @FileSetAttr); + RegisterHeader(H, 'procedure DateTimeToSystemTime(DateTime: TDateTime; var SystemTime: TSystemTime);', @DateTimeToSystemTime); + RegisterHeader(H, 'function SystemTimeToDateTime(const SystemTime: TSystemTime): TDateTime;', @SystemTimeToDateTime); +{$ENDIF} + +// Exception ------------------------------------------------------------------- + + G := RegisterClassType(H, Exception); + RegisterClassReferenceType(H, 'ExceptClass', G); + + RegisterHeader(G, 'constructor Create(const Msg: string);', @Exception.Create); + + RegisterHeader(G, 'function _GetMessage: String;', @Exception_GetMessage); + RegisterHeader(G, 'procedure _SetMessage(const Value: String);', @Exception_SetMessage); + RegisterProperty(G, 'property Message: string read _GetMessage write _SetMessage;'); + + RegisterHeader(G, 'function _GetHelpContext: Integer;', @Exception_GetHelpContext); + RegisterHeader(G, 'procedure _SetHelpContext(Value: Integer);', @Exception_SetHelpContext); + RegisterProperty(G, 'property HelpContext: Integer read _GetHelpContext write _SetHelpContext;'); + +// EAbort ---------------------------------------------------------------------- + + G := RegisterClassType(H, EAbort); + RegisterHeader(G, 'constructor Create(const Msg: string);', @EAbort.Create); + +// EOutOfMemory ---------------------------------------------------------------- + + G := RegisterClassType(H, EOutOfMemory); + RegisterHeader(G, 'constructor Create(const Msg: string);', @EOutOfMemory.Create); + +// EInOutError ----------------------------------------------------------------- + + G := RegisterClassType(H, EInOutError); + RegisterHeader(G, 'constructor Create(const Msg: string);', @EInOutError.Create); + RegisterClassTypeField(G, 'ErrorCode', _typeINTEGER, Integer(@EInOutError(nil).ErrorCode)); + +// EExternal ------------------------------------------------------------------- + + G := RegisterClassType(H, EExternal); + RegisterHeader(G, 'constructor Create(const Msg: string);', @EExternal.Create); + +// EExternalException ---------------------------------------------------------- + + G := RegisterClassType(H, EExternalException); + RegisterHeader(G, 'constructor Create(const Msg: string);', @EExternalException.Create); + +// EIntError ------------------------------------------------------------------- + + G := RegisterClassType(H, EIntError); + RegisterHeader(G, 'constructor Create(const Msg: string);', @EIntError.Create); + +// EDivByZero ------------------------------------------------------------------ + + G := RegisterClassType(H, EDivByZero); + RegisterHeader(G, 'constructor Create(const Msg: string);', @EDivByZero.Create); + +// ERangeError ----------------------------------------------------------------- + + G := RegisterClassType(H, ERangeError); + RegisterHeader(G, 'constructor Create(const Msg: string);', @ERangeError.Create); + +// EIntOverflow ---------------------------------------------------------------- + + G := RegisterClassType(H, EIntOverflow); + RegisterHeader(G, 'constructor Create(const Msg: string);', @EIntOverflow.Create); + +// EMathError ------------------------------------------------------------------ + + G := RegisterClassType(H, EMathError); + RegisterHeader(G, 'constructor Create(const Msg: string);', @EMathError.Create); + +// EInvalidOp ------------------------------------------------------------------ + + G := RegisterClassType(H, EInvalidOp); + RegisterHeader(G, 'constructor Create(const Msg: string);', @EInvalidOp.Create); + +// EZeroDivide ----------------------------------------------------------------- + + G := RegisterClassType(H, EZeroDivide); + RegisterHeader(G, 'constructor Create(const Msg: string);', @EZeroDivide.Create); + +// EOverflow ------------------------------------------------------------------- + + G := RegisterClassType(H, EOverflow); + RegisterHeader(G, 'constructor Create(const Msg: string);', @EOverflow.Create); + +// EUnderflow ------------------------------------------------------------------ + + G := RegisterClassType(H, EUnderflow); + RegisterHeader(G, 'constructor Create(const Msg: string);', @EUnderflow.Create); + +// EInvalidPointer ------------------------------------------------------------- + + G := RegisterClassType(H, EInvalidPointer); + RegisterHeader(G, 'constructor Create(const Msg: string);', @EInvalidPointer.Create); + +// EInvalidCast ---------------------------------------------------------------- + + G := RegisterClassType(H, EInvalidCast); + RegisterHeader(G, 'constructor Create(const Msg: string);', @EInvalidCast.Create); + +// EConvertError --------------------------------------------------------------- + + G := RegisterClassType(H, EConvertError); + RegisterHeader(G, 'constructor Create(const Msg: string);', @EConvertError.Create); + +// EAccessViolation --------------------------------------------------------------- + + G := RegisterClassType(H, EAccessViolation); + RegisterHeader(G, 'constructor Create(const Msg: string);', @EAccessViolation.Create); + +// EPrivilege ------------------------------------------------------------------ + + G := RegisterClassType(H, EPrivilege); + RegisterHeader(G, 'constructor Create(const Msg: string);', @EPrivilege.Create); + +// EStackOverflow ------------------------------------------------------------------ + + G := RegisterClassType(H, EStackOverflow); + RegisterHeader(G, 'constructor Create(const Msg: string);', @EStackOverflow.Create); + +// EControlC ------------------------------------------------------------------- + + G := RegisterClassType(H, EControlC); + RegisterHeader(G, 'constructor Create(const Msg: string);', @EControlC.Create); + +// EVariantError --------------------------------------------------------------- + + G := RegisterClassType(H, EVariantError); + RegisterHeader(G, 'constructor Create(const Msg: string);', @EVariantError.Create); + +// EPropReadOnly --------------------------------------------------------------- + + G := RegisterClassType(H, EPropReadOnly); + RegisterHeader(G, 'constructor Create(const Msg: string);', @EPropReadOnly.Create); + +// EPropWriteOnly -------------------------------------------------------------- + + G := RegisterClassType(H, EPropWriteOnly); + RegisterHeader(G, 'constructor Create(const Msg: string);', @EPropWriteOnly.Create); + +// EAssertionFailed ------------------------------------------------------------ + + G := RegisterClassType(H, EAssertionFailed); + RegisterHeader(G, 'constructor Create(const Msg: string);', @EAssertionFailed.Create); + +// EAbstractError -------------------------------------------------------------- + + G := RegisterClassType(H, EAbstractError); + RegisterHeader(G, 'constructor Create(const Msg: string);', @EAbstractError.Create); +end; + +end. diff --git a/Demos/ANOTHER_DEMOS/IMPORT/IMPORT_Variants.pas b/Demos/ANOTHER_DEMOS/IMPORT/IMPORT_Variants.pas new file mode 100644 index 0000000..860e48a --- /dev/null +++ b/Demos/ANOTHER_DEMOS/IMPORT/IMPORT_Variants.pas @@ -0,0 +1,116 @@ +{$I PaxCompiler.def} +unit IMPORT_Variants; +interface +uses +{$IFDEF VARIANTS} + Variants, +{$ENDIF} + SysUtils, + PaxRegister, + PaxCompiler; + +procedure Register_Variants; + +implementation + +procedure _VarArrayRedim(var A: Variant; HighBound: Integer); +begin + VarArrayRedim(A, HighBound); +end; + +procedure _VarCast(var Dest: Variant; const Source: Variant; VarType: Integer); +begin + VarCast(Dest, Source, VarType); +end; + +procedure _VarClear(var V : Variant); +begin + VarClear(V); +end; + +procedure _VarCopy(var Dest: Variant; const Source: Variant); +begin + VarCopy(Dest, Source); +end; + +procedure Register_Variants; +var + H: Integer; +begin + H := RegisterNamespace(0, 'Variants'); + + RegisterConstant(0, 'varEmpty', _typeWORD, varEmpty); + RegisterConstant(0, 'varNull', _typeWORD, varNull); + RegisterConstant(0, 'varSmallint', _typeWORD, varSmallInt); + RegisterConstant(0, 'varInteger', _typeWORD, varInteger); + RegisterConstant(0, 'varSingle', _typeWORD, varSingle); + RegisterConstant(0, 'varDouble', _typeWORD, varDouble); + RegisterConstant(0, 'varCurrency', _typeWORD, varCurrency); + RegisterConstant(0, 'varDate', _typeWORD, varDate); + RegisterConstant(0, 'varOleStr', _typeWORD, varOleStr); + RegisterConstant(0, 'varDispatch', _typeWORD, varDispatch); + RegisterConstant(0, 'varError', _typeWORD, varError); + RegisterConstant(0, 'varBoolean', _typeWORD, varBoolean); + RegisterConstant(0, 'varVariant', _typeWORD, varVariant); + RegisterConstant(0, 'varUnknown', _typeWORD, varUnknown); +{$IFDEF VARIANTS} + RegisterConstant(0, 'varShortInt', _typeWORD, varShortInt); +{$ENDIF} + RegisterConstant(0, 'varByte', _typeWORD, varByte); +{$IFDEF VARIANTS} + RegisterConstant(0, 'varWord', _typeWORD, varWord); + RegisterConstant(0, 'varLongWord', _typeWORD, varLongWord); + RegisterConstant(0, 'varInt64', _typeWORD, varInt64); +{$ENDIF} + RegisterConstant(0, 'varStrArg', _typeWORD, varStrArg); + RegisterConstant(0, 'varString', _typeWORD, varString); + RegisterConstant(0, 'varAny', _typeWORD, varAny); + + RegisterHeader(H, 'function VarArrayCreate(const Bounds: array of Integer; VarType: Integer): Variant;', + @VarArrayCreate); + RegisterHeader(H, 'function VarArrayDimCount(const A: Variant): Integer;', + @VarArrayDimCount); + RegisterHeader(H, 'function VarArrayHighBound(const A: Variant; Dim: Integer): Integer;', + @VarArrayHighBound); + RegisterHeader(H, 'function VarArrayLock(var A: Variant): Pointer;', + @VarArrayLock); + RegisterHeader(H, 'function VarArrayLowBound(const A: Variant; Dim: Integer): Integer;', + @VarArrayLowBound); + RegisterHeader(H, 'function VarArrayOf(const Values: array of Variant): Variant;', + @VarArrayOf); + RegisterHeader(H, 'procedure VarArrayRedim(var A: Variant; HighBound: Integer);', + @_VarArrayRedim); + RegisterHeader(H, 'function VarArrayRef(const A: Variant): Variant;', + @VarArrayRef); + RegisterHeader(H, 'procedure VarArrayUnlock(var A: Variant);', + @VarArrayUnlock); + RegisterHeader(H, 'function VarAsType(const V: Variant; VarType: Integer): Variant;', + @VarAsType); + RegisterHeader(H, 'procedure VarCast(var Dest: Variant; const Source: Variant; VarType: Integer);', + @_VarCast); + RegisterHeader(H, 'procedure VarClear(var V : Variant);', + @_VarClear); + RegisterHeader(H, 'procedure VarCopy(var Dest: Variant; const Source: Variant);', + @_VarCopy); + RegisterHeader(H, 'function VarFromDateTime(DateTime: TDateTime): Variant;', + @VarFromDateTime); + RegisterHeader(H, 'function VarIsArray(const V: Variant): Boolean;', + @VarIsArray); + RegisterHeader(H, 'function VarIsEmpty(const V: Variant): Boolean;', + @VarIsEmpty); + RegisterHeader(H, 'function VarIsNull(const V: Variant): Boolean;', + @VarIsNull); + RegisterHeader(H, 'function VarToDateTime(const V: Variant): TDateTime;', + @VarToDateTime); + RegisterHeader(H, 'function VarToStr(const V: Variant): string;', + @VarToStr); + RegisterHeader(H, 'function VarType(const V: Variant): Integer;', @VarType); + + RegisterVariable(0, 'EmptyParam', _typeOLEVARIANT, @ EmptyParam); +end; + +initialization + +Register_Variants; + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/AccessToScriptVariables/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/AccessToScriptVariables/Project1.dpr new file mode 100644 index 0000000..513a1dd --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/AccessToScriptVariables/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/AccessToScriptVariables/Project1.res b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/AccessToScriptVariables/Project1.res new file mode 100644 index 0000000..3adc036 Binary files /dev/null and b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/AccessToScriptVariables/Project1.res differ diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/AccessToScriptVariables/Unit1.dfm b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/AccessToScriptVariables/Unit1.dfm new file mode 100644 index 0000000..584c0e5 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/AccessToScriptVariables/Unit1.dfm @@ -0,0 +1,43 @@ +object Form1: TForm1 + Left = 277 + Top = 120 + Caption = 'Access to script-defined variables' + ClientHeight = 164 + ClientWidth = 290 + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -14 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + PixelsPerInch = 120 + TextHeight = 16 + object Button1: TButton + Left = 39 + Top = 98 + Width = 93 + Height = 31 + Caption = 'Run' + TabOrder = 0 + OnClick = Button1Click + end + object PaxCompiler1: TPaxCompiler + Alignment = 1 + DebugMode = False + Left = 48 + Top = 24 + end + object PaxBasicLanguage1: TPaxBasicLanguage + ExplicitOff = False + CompleteBooleanEval = False + UseFWArrays = True + Left = 152 + Top = 80 + end + object PaxInterpreter1: TPaxInterpreter + Console = False + Left = 160 + Top = 16 + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/AccessToScriptVariables/Unit1.pas b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/AccessToScriptVariables/Unit1.pas new file mode 100644 index 0000000..d394476 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/AccessToScriptVariables/Unit1.pas @@ -0,0 +1,58 @@ +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, PaxCompiler, PaxInterpreter, PaxBasicLanguage, PaxRunner; +type + TForm1 = class(TForm) + PaxCompiler1: TPaxCompiler; + Button1: TButton; + PaxBasicLanguage1: TPaxBasicLanguage; + PaxInterpreter1: TPaxInterpreter; + procedure Button1Click(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.dfm} + +procedure TForm1.Button1Click(Sender: TObject); +var + P: Pointer; + I: Integer; +begin + {$O-} + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxBasicLanguage1); + + PaxCompiler1.RegisterHeader(0, 'procedure ShowMessage(const Msg: string);', @ShowMessage); + PaxCompiler1.RegisterHeader(0, 'function IntToStr(Value: Integer): string;', @IntToStr); + + PaxCompiler1.AddModule('1', PaxBasicLanguage1.LanguageName); + PaxCompiler1.AddCode('1', 'Dim X As Integer'); + PaxCompiler1.AddCode('1', 'ShowMessage("script:" + IntToStr(x))'); + + if PaxCompiler1.Compile(PaxInterpreter1) then + begin + P := PaxInterpreter1.GetAddress('x'); + Integer(P^) := 5; // change script-defind variable + PaxInterpreter1.Run; // the first run + ShowMessage('host:' + IntToStr(Integer(P^))); // show script-defined var + Integer(P^) := 30; // change script-defind variable + PaxInterpreter1.Run; // the second run + end + else + for I:=0 to PaxCompiler1.ErrorCount do + ShowMessage(PaxCompiler1.ErrorMessage[I]); +end; + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/BindDFM/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/BindDFM/Project1.dpr new file mode 100644 index 0000000..513a1dd --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/BindDFM/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/BindDFM/Project1.res b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/BindDFM/Project1.res new file mode 100644 index 0000000..3adc036 Binary files /dev/null and b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/BindDFM/Project1.res differ diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/BindDFM/Unit1.dfm b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/BindDFM/Unit1.dfm new file mode 100644 index 0000000..1993e05 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/BindDFM/Unit1.dfm @@ -0,0 +1,61 @@ +object Form1: TForm1 + Left = 338 + Top = 183 + Width = 397 + Height = 222 + Caption = 'Bind DFM file' + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'Tahoma' + Font.Style = [] + OldCreateOrder = False + PixelsPerInch = 96 + TextHeight = 13 + object Button1: TButton + Left = 8 + Top = 24 + Width = 75 + Height = 25 + Caption = 'Run Script' + TabOrder = 0 + OnClick = Button1Click + end + object Memo1: TMemo + Left = 120 + Top = 24 + Width = 233 + Height = 137 + Lines.Strings = ( + 'Imports Unit2' + '' + 'Form2 = New TForm2(null)' + 'Try' + ' Form2.ShowModal' + 'Finally' + ' Form2.Free' + 'End Try' + '') + TabOrder = 1 + end + object PaxCompiler1: TPaxCompiler + Alignment = 1 + DebugMode = False + Left = 24 + Top = 72 + end + object PaxBasicLanguage1: TPaxBasicLanguage + ExplicitOff = False + CompleteBooleanEval = False + UseFWArrays = True + Left = 16 + Top = 128 + end + object PaxInterpreter1: TPaxInterpreter + Console = False + OnCreateObject = PaxInterpreter1CreateObject + Left = 64 + Top = 120 + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/BindDFM/Unit1.pas b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/BindDFM/Unit1.pas new file mode 100644 index 0000000..bc5e496 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/BindDFM/Unit1.pas @@ -0,0 +1,65 @@ +{$O-} +unit Unit1; + +interface + +uses + TypInfo, + Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, + Dialogs, PaxInterpreter, PaxCompiler, StdCtrls, PaxBasicLanguage, PaxRunner; + +type + TForm1 = class(TForm) + Button1: TButton; + PaxCompiler1: TPaxCompiler; + PaxBasicLanguage1: TPaxBasicLanguage; + PaxInterpreter1: TPaxInterpreter; + Memo1: TMemo; + procedure Button1Click(Sender: TObject); + procedure PaxInterpreter1CreateObject(Sender: TPaxRunner; + Instance: TObject); + private + { Private declarations } + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.dfm} + +uses + IMPORT_Common; + +procedure TForm1.Button1Click(Sender: TObject); +begin + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxBasicLanguage1); + PaxCompiler1.AddModule('1', 'Basic'); + PaxCompiler1.AddCode('1', Memo1.Lines.Text); + if PaxCompiler1.Compile(PaxInterpreter1) then + begin + PaxInterpreter1.Run; + end + else + ShowMessage(PaxCompiler1.ErrorMessage[0]); +end; + +procedure TForm1.PaxInterpreter1CreateObject(Sender: TPaxRunner; + Instance: TObject); +var + pti: PTypeInfo; + ptd: PTypeData; +begin + if Instance is TForm then + begin + pti := Instance.ClassInfo; + ptd := GetTypeData(pti); + Sender.LoadDFMFile(Instance, ptd^.UnitName + '.dfm'); + end; +end; + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/BindDFM/Unit2.bas b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/BindDFM/Unit2.bas new file mode 100644 index 0000000..e60f598 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/BindDFM/Unit2.bas @@ -0,0 +1,27 @@ +Module Unit2 + + Imports SysUtils, Variants, Classes, Controls, Forms, Dialogs, StdCtrls + + + Class TForm2 + + Inherits TForm + + Published Button1 As TButton + + Published Sub Button1Click(Sender As TObject) + ShowMessage("Hello") + End Sub + + Published Sub FormCreate(Sender As TObject) + ShowMessage("Created") + End Sub + + End Class + + + Dim Form2 As TForm2 + + +End Module + diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/BindDFM/Unit2.dfm b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/BindDFM/Unit2.dfm new file mode 100644 index 0000000..1977d03 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/BindDFM/Unit2.dfm @@ -0,0 +1,26 @@ +object Form2: TForm2 + Left = 30 + Top = 30 + Caption = 'Form2' + ClientHeight = 216 + ClientWidth = 426 + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'Tahoma' + Font.Style = [] + OldCreateOrder = False + OnCreate = FormCreate + PixelsPerInch = 96 + TextHeight = 13 + object Button1: TButton + Left = 50 + Top = 88 + Width = 75 + Height = 25 + Caption = 'Button1' + TabOrder = 0 + OnClick = Button1Click + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/Breakpoints/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/Breakpoints/Project1.dpr new file mode 100644 index 0000000..513a1dd --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/Breakpoints/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/Breakpoints/Project1.res b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/Breakpoints/Project1.res new file mode 100644 index 0000000..3adc036 Binary files /dev/null and b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/Breakpoints/Project1.res differ diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/Breakpoints/Unit1.dfm b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/Breakpoints/Unit1.dfm new file mode 100644 index 0000000..f7bab63 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/Breakpoints/Unit1.dfm @@ -0,0 +1,146 @@ +object Form1: TForm1 + Left = 192 + Top = 114 + Width = 544 + Height = 416 + Caption = 'Form1' + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + PixelsPerInch = 96 + TextHeight = 13 + object Label1: TLabel + Left = 24 + Top = 8 + Width = 52 + Height = 24 + Caption = 'Script:' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -19 + Font.Name = 'MS Sans Serif' + Font.Style = [] + ParentFont = False + end + object Label2: TLabel + Left = 24 + Top = 232 + Width = 61 + Height = 24 + Caption = 'Output:' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -19 + Font.Name = 'MS Sans Serif' + Font.Style = [] + ParentFont = False + end + object Label3: TLabel + Left = 288 + Top = 48 + Width = 182 + Height = 24 + Caption = 'Add breakpoint at line' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -19 + Font.Name = 'MS Sans Serif' + Font.Style = [] + ParentFont = False + end + object Memo1: TMemo + Left = 32 + Top = 64 + Width = 185 + Height = 177 + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -16 + Font.Name = 'MS Sans Serif' + Font.Style = [] + Lines.Strings = ( + ' print("A") // line 0' + ' print("B") // line 1' + ' print("C") // line 2' + ' print("D") // line 3' + ' print("E") // line 4' + '') + ParentFont = False + TabOrder = 0 + end + object Memo2: TMemo + Left = 16 + Top = 262 + Width = 185 + Height = 169 + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -16 + Font.Name = 'MS Sans Serif' + Font.Style = [] + Lines.Strings = ( + '') + ParentFont = False + TabOrder = 1 + end + object Edit1: TEdit + Left = 480 + Top = 48 + Width = 41 + Height = 33 + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -16 + Font.Name = 'MS Sans Serif' + Font.Style = [] + ParentFont = False + TabOrder = 2 + Text = '2' + end + object Button1: TButton + Left = 304 + Top = 192 + Width = 153 + Height = 49 + Caption = 'Run script' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -19 + Font.Name = 'MS Sans Serif' + Font.Style = [] + ParentFont = False + TabOrder = 3 + OnClick = Button1Click + end + object PaxCompiler1: TPaxCompiler + Alignment = 1 + DebugMode = False + Left = 312 + Top = 304 + end + object PaxCompilerDebugger1: TPaxCompilerDebugger + Left = 432 + Top = 304 + end + object PaxCompilerExplorer1: TPaxCompilerExplorer + Left = 472 + Top = 304 + end + object PaxBasicLanguage1: TPaxBasicLanguage + ExplicitOff = False + CompleteBooleanEval = False + UseFWArrays = True + Left = 344 + Top = 368 + end + object PaxInterpreter1: TPaxInterpreter + Console = False + OnPrintEvent = PaxInterpreter1PrintEvent + Left = 312 + Top = 232 + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/Breakpoints/Unit1.pas b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/Breakpoints/Unit1.pas new file mode 100644 index 0000000..7c05e9c --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/Breakpoints/Unit1.pas @@ -0,0 +1,83 @@ +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, PaxInterpreter, PaxCompiler, PaxCompilerDebugger, + PaxRegister, + PaxCompilerExplorer, PaxBasicLanguage, PaxRunner; + +type + TForm1 = class(TForm) + Memo1: TMemo; + Memo2: TMemo; + Label1: TLabel; + Label2: TLabel; + Edit1: TEdit; + Label3: TLabel; + Button1: TButton; + PaxCompiler1: TPaxCompiler; + PaxCompilerDebugger1: TPaxCompilerDebugger; + PaxCompilerExplorer1: TPaxCompilerExplorer; + PaxBasicLanguage1: TPaxBasicLanguage; + PaxInterpreter1: TPaxInterpreter; + procedure Button1Click(Sender: TObject); + procedure PaxInterpreter1PrintEvent(Sender: TPaxRunner; const Text: string); + private + { Private declarations } + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.dfm} + +procedure TForm1.Button1Click(Sender: TObject); +var + I: Integer; + Breakpoint: Integer; +begin + Memo2.Lines.Clear; + Breakpoint := StrToInt(Edit1.Text); + + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxBasicLanguage1); + + PaxCompiler1.AddModule('1', PaxBasicLanguage1.LanguageName); + PaxCompiler1.AddCode('1', Memo1.Lines.Text); + + PaxCompiler1.DebugMode := true; + + if PaxCompiler1.Compile(PaxInterpreter1) then + begin + PaxCompilerExplorer1.RegisterCompiler(PaxCompiler1); + PaxCompilerDebugger1.RegisterCompiler(PaxCompiler1, PaxInterpreter1); + if PaxCompilerExplorer1.IsExecutableLine('1', Breakpoint) then + PaxCompilerDebugger1.AddBreakpoint('1', Breakpoint); + + PaxCompilerDebugger1.Run; + while PaxCompilerDebugger1.IsPaused do + begin + ShowMessage('Program has been paused at breakpoint: ' + + IntToStr(PaxCompilerDebugger1.SourceLineNumber)); + + PaxInterpreter1.Run; + end; + end + else + for I:=0 to PaxCompiler1.ErrorCount - 1 do + ShowMessage(PaxCompiler1.ErrorMessage[I]); +end; + +procedure TForm1.PaxInterpreter1PrintEvent(Sender: TPaxRunner; + const Text: string); +begin + Form1.Memo2.Lines.Add(Text); +end; + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/CallRoutine/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/CallRoutine/Project1.dpr new file mode 100644 index 0000000..513a1dd --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/CallRoutine/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/CallRoutine/Project1.res b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/CallRoutine/Project1.res new file mode 100644 index 0000000..3adc036 Binary files /dev/null and b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/CallRoutine/Project1.res differ diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/CallRoutine/Unit1.dfm b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/CallRoutine/Unit1.dfm new file mode 100644 index 0000000..df38f4f --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/CallRoutine/Unit1.dfm @@ -0,0 +1,48 @@ +object Form1: TForm1 + Left = 192 + Top = 114 + Caption = 'Call routine demo' + ClientHeight = 116 + ClientWidth = 220 + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -14 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + OnCreate = FormCreate + PixelsPerInch = 120 + TextHeight = 16 + object Button1: TButton + Left = 49 + Top = 89 + Width = 149 + Height = 30 + Margins.Left = 4 + Margins.Top = 4 + Margins.Right = 4 + Margins.Bottom = 4 + Caption = 'Call ' + TabOrder = 0 + OnClick = Button1Click + end + object PaxCompiler1: TPaxCompiler + Alignment = 1 + DebugMode = False + Left = 32 + Top = 16 + end + object PaxBasicLanguage1: TPaxBasicLanguage + ExplicitOff = False + CompleteBooleanEval = False + UseFWArrays = True + Left = 160 + Top = 48 + end + object PaxInterpreter1: TPaxInterpreter + Console = False + Left = 88 + Top = 8 + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/CallRoutine/Unit1.pas b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/CallRoutine/Unit1.pas new file mode 100644 index 0000000..7e151ed --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/CallRoutine/Unit1.pas @@ -0,0 +1,67 @@ +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, PaxCompiler, PaxInterpreter, PaxRegister, PaxBasicLanguage, + PaxRunner; +type + TForm1 = class(TForm) + PaxCompiler1: TPaxCompiler; + Button1: TButton; + PaxBasicLanguage1: TPaxBasicLanguage; + PaxInterpreter1: TPaxInterpreter; + procedure Button1Click(Sender: TObject); + procedure FormCreate(Sender: TObject); + private + Y: Integer; + { Private declarations } + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.dfm} + +procedure TForm1.Button1Click(Sender: TObject); +var + H_Y: Integer; + I: Integer; +begin +{$O-} + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxBasicLanguage1); + + H_Y := PaxCompiler1.RegisterVariable(0, 'Y', _typeINTEGER, @Y); + + PaxCompiler1.AddModule('1', PaxBasicLanguage1.LanguageName); + PaxCompiler1.AddCode('1', 'Sub P(X As Integer)'); + PaxCompiler1.AddCode('1', ' Y = Y + X'); + PaxCompiler1.AddCode('1', 'End Sub'); + + if PaxCompiler1.Compile(PaxInterpreter1) then + begin + PaxInterpreter1.RunInitialization; + + PaxInterpreter1.CallRoutine('P', [10]); // call it + ShowMessage(IntToStr(Y)); + + PaxInterpreter1.CallRoutine('P', [20]); // call it + ShowMessage(IntToStr(Y)); + end + else + for I:=0 to PaxCompiler1.ErrorCount do + ShowMessage(PaxCompiler1.ErrorMessage[I]); +end; + +procedure TForm1.FormCreate(Sender: TObject); +begin + Y := 0; +end; + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/CodeComplet/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/CodeComplet/Project1.dpr new file mode 100644 index 0000000..5769e8a --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/CodeComplet/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form3}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm3, Form3); + Application.Run; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/CodeComplet/Project1.res b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/CodeComplet/Project1.res new file mode 100644 index 0000000..3adc036 Binary files /dev/null and b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/CodeComplet/Project1.res differ diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/CodeComplet/Unit1.dfm b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/CodeComplet/Unit1.dfm new file mode 100644 index 0000000..3bea424 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/CodeComplet/Unit1.dfm @@ -0,0 +1,54 @@ +object Form3: TForm3 + Left = 0 + Top = 0 + Width = 701 + Height = 194 + Caption = 'Code completion demo' + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -10 + Font.Name = 'Tahoma' + Font.Style = [] + OldCreateOrder = False + PixelsPerInch = 96 + TextHeight = 12 + object Button1: TButton + Left = 18 + Top = 12 + Width = 56 + Height = 19 + Caption = 'Create' + TabOrder = 0 + OnClick = Button1Click + end + object Memo1: TMemo + Left = 156 + Top = 6 + Width = 463 + Height = 143 + TabOrder = 1 + end + object PaxCompiler1: TPaxCompiler + Alignment = 1 + DebugMode = False + Left = 24 + Top = 56 + end + object PaxCompilerExplorer1: TPaxCompilerExplorer + Left = 64 + Top = 88 + end + object PaxBasicLanguage1: TPaxBasicLanguage + ExplicitOff = False + CompleteBooleanEval = False + UseFWArrays = True + Left = 104 + Top = 64 + end + object PaxInterpreter1: TPaxInterpreter + Console = False + Left = 80 + Top = 152 + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/CodeComplet/Unit1.pas b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/CodeComplet/Unit1.pas new file mode 100644 index 0000000..2863973 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/CodeComplet/Unit1.pas @@ -0,0 +1,57 @@ +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, + Dialogs, PaxCompiler, StdCtrls, PaxCompilerExplorer, PaxInterpreter, + PaxBasicLanguage, PaxRunner; + +type + TForm3 = class(TForm) + Button1: TButton; + PaxCompiler1: TPaxCompiler; + PaxCompilerExplorer1: TPaxCompilerExplorer; + Memo1: TMemo; + PaxBasicLanguage1: TPaxBasicLanguage; + PaxInterpreter1: TPaxInterpreter; + procedure Button1Click(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + end; + +var + Form3: TForm3; + +implementation + +{$R *.dfm} + +procedure TForm3.Button1Click(Sender: TObject); +var + L: TStringList; +begin + L := TStringList.Create; + try + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxBasicLanguage1); + PaxCompiler1.AddModule('1', 'Basic'); + + PaxCompiler1.AddCodeFromFile('1', 'script1.txt'); + if PaxCompiler1.CodeCompletion('1', 3, 5, Memo1.Lines, PaxBasicLanguage1) then + +// PaxCompiler1.AddCodeFromFile('1', 'script2.txt'); +// if PaxCompiler1.CodeCompletion('1', 1, 3, Memo1.Lines, PaxBasicLanguage1) then + begin + //ok + end + else + ShowMessage(PaxCompiler1.ErrorMessage[0]); + finally + L.Free; + end; +end; + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/CodeComplet/script1.txt b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/CodeComplet/script1.txt new file mode 100644 index 0000000..69e3fe3 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/CodeComplet/script1.txt @@ -0,0 +1,6 @@ +' x = 3, y = 5 +Class SomeClass + Public Z As TObject +End Class +Dim X As SomeClass = New SomeClass +X.Z. diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/CodeComplet/script2.txt b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/CodeComplet/script2.txt new file mode 100644 index 0000000..933e691 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/CodeComplet/script2.txt @@ -0,0 +1,4 @@ +' x = 1, y = 3 +Sub P(X As Integer, Y As Integer) +End Sub +P( diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/CodeExplorer/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/CodeExplorer/Project1.dpr new file mode 100644 index 0000000..513a1dd --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/CodeExplorer/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/CodeExplorer/Project1.res b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/CodeExplorer/Project1.res new file mode 100644 index 0000000..3adc036 Binary files /dev/null and b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/CodeExplorer/Project1.res differ diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/CodeExplorer/Unit1.dfm b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/CodeExplorer/Unit1.dfm new file mode 100644 index 0000000..0475bb6 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/CodeExplorer/Unit1.dfm @@ -0,0 +1,97 @@ +object Form1: TForm1 + Left = 192 + Top = 114 + Caption = 'Code explorer demo' + ClientHeight = 446 + ClientWidth = 688 + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + PixelsPerInch = 96 + TextHeight = 13 + object Panel1: TPanel + Left = 0 + Top = 405 + Width = 688 + Height = 41 + Align = alBottom + TabOrder = 0 + object Button1: TButton + Left = 24 + Top = 8 + Width = 105 + Height = 25 + Caption = 'Compile' + TabOrder = 0 + OnClick = Button1Click + end + end + object Memo1: TMemo + Left = 0 + Top = 0 + Width = 345 + Height = 405 + Align = alLeft + Lines.Strings = ( + 'Imports Classes' + '' + 'Structure MyPoint' + ' X As Double' + ' Y As Double' + 'End Structure' + '' + 'Class SomeClass' + ' Public P As Integer' + ' Public Q As Integer' + '' + ' Function MyClassFunc(X As Integer, Y As Integer) As Integer' + ' End Function' + '' + ' Property MyProp As Integer' + ' Get' + ' return P' + ' End Get' + ' End Property' + 'End Class' + '' + 'Dim L As Double' + 'Const W = "abc"' + '' + 'Enum MyEnum' + ' one' + ' two' + ' three' + 'End Enum' + '' + '') + TabOrder = 1 + end + object TreeView1: TTreeView + Left = 345 + Top = 0 + Width = 343 + Height = 405 + Align = alClient + Indent = 19 + TabOrder = 2 + OnDblClick = TreeView1DblClick + end + object PaxCompiler1: TPaxCompiler + Alignment = 1 + DebugMode = False + Left = 224 + Top = 413 + end + object PaxCompilerExplorer1: TPaxCompilerExplorer + Left = 304 + Top = 413 + end + object PaxBasicLanguage1: TPaxBasicLanguage + Left = 384 + Top = 16 + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/CodeExplorer/Unit1.pas b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/CodeExplorer/Unit1.pas new file mode 100644 index 0000000..3f50dc5 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/CodeExplorer/Unit1.pas @@ -0,0 +1,247 @@ +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, + Dialogs, PaxCompilerExplorer, PaxCompiler, StdCtrls, ExtCtrls, ComCtrls, + IMPORT_Classes, PaxBasicLanguage; + +type + TForm1 = class(TForm) + Panel1: TPanel; + Memo1: TMemo; + Button1: TButton; + PaxCompiler1: TPaxCompiler; + PaxCompilerExplorer1: TPaxCompilerExplorer; + TreeView1: TTreeView; + PaxBasicLanguage1: TPaxBasicLanguage; + procedure Button1Click(Sender: TObject); + procedure TreeView1DblClick(Sender: TObject); + private + { Private declarations } + L: TList; + public + { Public declarations } + procedure BuildTree; + procedure EnumProc(Id: Integer; + Host: Boolean; + Kind: TPaxMemberKind; + Data: Pointer); + end; + +var + Form1: TForm1; + +implementation + +{$R *.dfm} + +procedure TForm1.Button1Click(Sender: TObject); +var + I: Integer; +begin + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxBasicLanguage1); + PaxCompiler1.AddModule('1', 'Basic'); + PaxCompiler1.AddCode('1', Memo1.Lines.Text); + if PaxCompiler1.Compile then + begin + PaxCompilerExplorer1.RegisterCompiler(PaxCompiler1); + BuildTree; + end + else + for I:=0 to PaxCompiler1.ErrorCount - 1 do + ShowMessage(PaxCompiler1.ErrorMessage[I]); +end; + +procedure TForm1.BuildTree; +var + N, N2: TTreeNode; + I: Integer; +begin + L := TList.Create; + try + TreeView1.Items.Clear; + + N := TreeView1.Items.Add(nil, 'Used namespaces'); + L.Add(N); + PaxCompilerExplorer1.EnumMembers(0, true, pmkNamespace, EnumProc, N); + PaxCompilerExplorer1.EnumMembers(0, false, pmkNamespace, EnumProc, N); + + N := TreeView1.Items.Add(nil, 'Noname namespace'); + + N2 := TreeView1.Items.AddChild(N, 'Types'); + L.Add(N2); + PaxCompilerExplorer1.EnumMembers(0, false, pmkType, EnumProc, N2); + + N2 := TreeView1.Items.AddChild(N, 'Procedures'); + L.Add(N2); + PaxCompilerExplorer1.EnumMembers(0, false, pmkProcedure, EnumProc, N2); + + N2 := TreeView1.Items.AddChild(N, 'Functions'); + L.Add(N2); + PaxCompilerExplorer1.EnumMembers(0, false, pmkFunction, EnumProc, N2); + + N2 := TreeView1.Items.AddChild(N, 'Constants'); + L.Add(N2); + PaxCompilerExplorer1.EnumMembers(0, false, pmkConst, EnumProc, N2); + + N2 := TreeView1.Items.AddChild(N, 'Variables'); + L.Add(N2); + PaxCompilerExplorer1.EnumMembers(0, false, pmkVar, EnumProc, N2); + + finally + for I := L.Count - 1 downto 0 do + begin + N2 := TTreeNode(L[I]); + if N2.Count = 0 then + N2.Delete; + end; + + L.Free; + end; +end; + +procedure TForm1.EnumProc(Id: Integer; + Host: Boolean; + Kind: TPaxMemberKind; + Data: Pointer); +var + N, N2, N3: TTreeNode; + Name: String; + TypeName: String; +begin + N := TTreeNode(Data); + + Name := PaxCompilerExplorer1.Names[Id]; + TypeName := PaxCompilerExplorer1.TypeNames[Id]; + + with TreeView1.Items do + case Kind of + pmkProcedure, pmkFunction, pmkConstructor, pmkDestructor: + begin + N2 := AddChildObject(N, Name, TObject(Id)); + + N3 := AddChild(N2, 'Parameters'); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, Host, pmkParam, EnumProc, N3); + + N3 := AddChild(N2, 'Local variables'); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, Host, pmkVar, EnumProc, N3); + + N3 := AddChild(N2, 'Local constants'); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, Host, pmkConst, EnumProc, N3); + + N3 := AddChild(N2, 'Local types'); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, Host, pmkType, EnumProc, N3); + + N3 := TreeView1.Items.AddChild(N2, 'Nested procedures'); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, false, pmkProcedure, EnumProc, N3); + + N3 := TreeView1.Items.AddChild(N2, 'Nested functions'); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, false, pmkFunction, EnumProc, N3); + + end; + pmkParam: AddChildObject(N, Name + ' As ' + TypeName, TObject(Id)); + pmkVar: AddChildObject(N, Name + ' As ' + TypeName, TObject(Id)); + pmkConst: AddChildObject(N, Name + ' As ' + TypeName, TObject(Id)); + pmkField: AddChildObject(N, Name + ' As ' + TypeName, TObject(Id)); + pmkProperty: AddChildObject(N, Name + ' As ' + TypeName, TObject(Id)); + pmkType: + begin + N2 := AddChildObject(N, Name, TObject(Id)); + if PaxCompilerExplorer1.IsRecordType(Id) then + begin + N3 := AddChild(N2, 'Fields'); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, Host, pmkField, EnumProc, N3); + end + else if PaxCompilerExplorer1.IsClassType(Id) then + begin + N3 := AddChild(N2, 'Fields'); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, Host, pmkField, EnumProc, N3); + + N3 := AddChild(N2, 'Properties'); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, Host, pmkProperty, EnumProc, N3); + + N3 := TreeView1.Items.AddChild(N2, 'Constructors'); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, false, pmkConstructor, EnumProc, N3); + + N3 := TreeView1.Items.AddChild(N2, 'Destructor'); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, false, pmkDestructor, EnumProc, N3); + + N3 := TreeView1.Items.AddChild(N2, 'Class procedures'); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, false, pmkProcedure, EnumProc, N3); + + N3 := TreeView1.Items.AddChild(N2, 'Class functions'); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, false, pmkFunction, EnumProc, N3); + end; + end; + pmkNamespace: + begin + N2 := AddChildObject(N, Name, TObject(Id)); + + N3 := AddChild(N2, 'Constants'); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, Host, pmkConst, EnumProc, N3); + + N3 := AddChild(N2, 'Variables'); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, Host, pmkVar, EnumProc, N3); + + N3 := AddChild(N2, 'Procedures'); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, Host, pmkProcedure, EnumProc, N3); + + N3 := AddChild(N2, 'Types'); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, Host, pmkType, EnumProc, N3); + end; + end; +end; + +procedure TForm1.TreeView1DblClick(Sender: TObject); +var + N: TTreeNode; + Id, Position: Integer; + S: String; +begin + N := TTreeView(Sender).Selected; + + if N = nil then + Exit; + + Id := Integer(N.Data); + + if Id = 0 then + Exit; + + S := PaxCompilerExplorer1.Names[Id]; + Position := PaxCompilerExplorer1.Positions[Id]; + + if Id <> 0 then + with Memo1 do + begin + SetFocus; + SelStart := Position; + SelLength := Length(S); + end; +end; + +initialization + +Register_Classes; + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/DebugDemo/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/DebugDemo/Project1.dpr new file mode 100644 index 0000000..cebc69a --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/DebugDemo/Project1.dpr @@ -0,0 +1,15 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}, + Unit2 in 'Unit2.pas' {Form2}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.CreateForm(TForm2, Form2); + Application.Run; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/DebugDemo/Project1.res b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/DebugDemo/Project1.res new file mode 100644 index 0000000..3adc036 Binary files /dev/null and b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/DebugDemo/Project1.res differ diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/DebugDemo/Unit1.dfm b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/DebugDemo/Unit1.dfm new file mode 100644 index 0000000..be136e3 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/DebugDemo/Unit1.dfm @@ -0,0 +1,185 @@ +object Form1: TForm1 + Left = 209 + Top = 111 + Width = 618 + Height = 619 + Caption = 'DebugDemo' + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + OnCloseQuery = FormCloseQuery + PixelsPerInch = 96 + TextHeight = 13 + object Label1: TLabel + Left = 24 + Top = 8 + Width = 52 + Height = 24 + Caption = 'Script:' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -19 + Font.Name = 'MS Sans Serif' + Font.Style = [] + ParentFont = False + end + object Label2: TLabel + Left = 24 + Top = 320 + Width = 54 + Height = 24 + Caption = 'Trace:' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -19 + Font.Name = 'MS Sans Serif' + Font.Style = [] + ParentFont = False + end + object Memo1: TMemo + Left = 16 + Top = 40 + Width = 362 + Height = 273 + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -15 + Font.Name = 'MS Sans Serif' + Font.Style = [] + Lines.Strings = ( + 'Function Fact(N As Integer) As Integer' + ' If N = 1 Then' + ' Return 1' + ' Else' + ' Return N * Fact(N - 1)' + ' End If' + 'End Function' + 'Dim SS As Integer' + 'SS = Fact(3)' + 'print SS' + '') + ParentFont = False + TabOrder = 0 + end + object Memo2: TMemo + Left = 16 + Top = 352 + Width = 417 + Height = 217 + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -15 + Font.Name = 'MS Sans Serif' + Font.Style = [] + Lines.Strings = ( + '') + ParentFont = False + TabOrder = 1 + end + object Button1: TButton + Left = 392 + Top = 25 + Width = 193 + Height = 49 + Caption = 'Compile' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -19 + Font.Name = 'MS Sans Serif' + Font.Style = [] + ParentFont = False + TabOrder = 2 + OnClick = Button1Click + end + object Button2: TButton + Left = 392 + Top = 89 + Width = 193 + Height = 49 + Caption = 'Run' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -19 + Font.Name = 'MS Sans Serif' + Font.Style = [] + ParentFont = False + TabOrder = 3 + OnClick = Button2Click + end + object Button3: TButton + Left = 392 + Top = 155 + Width = 193 + Height = 49 + Caption = 'Trace Into' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -19 + Font.Name = 'MS Sans Serif' + Font.Style = [] + ParentFont = False + TabOrder = 4 + OnClick = Button3Click + end + object Button4: TButton + Left = 392 + Top = 220 + Width = 193 + Height = 50 + Caption = 'Step Over' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -19 + Font.Name = 'MS Sans Serif' + Font.Style = [] + ParentFont = False + TabOrder = 5 + OnClick = Button4Click + end + object Button5: TButton + Left = 392 + Top = 275 + Width = 193 + Height = 48 + Caption = 'Run to Cursor' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -19 + Font.Name = 'MS Sans Serif' + Font.Style = [] + ParentFont = False + TabOrder = 6 + OnClick = Button5Click + end + object PaxCompiler1: TPaxCompiler + Alignment = 1 + DebugMode = False + Left = 184 + Top = 320 + end + object PaxCompilerDebugger1: TPaxCompilerDebugger + Left = 312 + Top = 320 + end + object PaxCompilerExplorer1: TPaxCompilerExplorer + Left = 352 + Top = 320 + end + object PaxBasicLanguage1: TPaxBasicLanguage + ExplicitOff = False + CompleteBooleanEval = False + UseFWArrays = True + Left = 224 + Top = 320 + end + object PaxInterpreter1: TPaxInterpreter + Console = False + OnPauseUpdated = PaxInterpreter1PauseUpdated + Left = 304 + Top = 240 + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/DebugDemo/Unit1.pas b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/DebugDemo/Unit1.pas new file mode 100644 index 0000000..9ff680b --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/DebugDemo/Unit1.pas @@ -0,0 +1,350 @@ +{$O-} +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, PaxInterpreter, PaxCompiler, PaxCompilerDebugger, + PaxRegister, + PaxCompilerExplorer, PaxBasicLanguage, PaxRunner; + +type + TForm1 = class(TForm) + Memo1: TMemo; + Memo2: TMemo; + Label1: TLabel; + Label2: TLabel; + Button1: TButton; + PaxCompiler1: TPaxCompiler; + Button2: TButton; + Button3: TButton; + Button4: TButton; + Button5: TButton; + PaxCompilerDebugger1: TPaxCompilerDebugger; + PaxCompilerExplorer1: TPaxCompilerExplorer; + PaxBasicLanguage1: TPaxBasicLanguage; + PaxInterpreter1: TPaxInterpreter; + procedure Button1Click(Sender: TObject); + procedure Button2Click(Sender: TObject); + procedure Button3Click(Sender: TObject); + procedure Button4Click(Sender: TObject); + procedure Button5Click(Sender: TObject); + procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean); + procedure PaxInterpreter1PrintEvent(Sender: TPaxInterpreter; const Text: string); + procedure PaxInterpreter1PauseUpdated(Sender: TPaxRunner; + const ModuleName: string; SourceLineNumber: Integer); + private + { Private declarations } + ResumeRequest: Boolean; + CloseRequest: Boolean; + procedure UpdateDebugInfo; + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +uses Unit2; + +{$R *.dfm} + +procedure TForm1.Button1Click(Sender: TObject); +var + I: Integer; +begin + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxBasicLanguage1); + PaxCompiler1.AddModule('1', PaxBasicLanguage1.LanguageName); + PaxCompiler1.AddCode('1', Memo1.Lines.Text); + PaxCompiler1.DebugMode := true; + if PaxCompiler1.Compile(PaxInterpreter1) then + begin + ShowMessage('Script has been successfully recompiled.'); + PaxCompilerExplorer1.RegisterCompiler(PaxCompiler1); + PaxCompilerDebugger1.RegisterCompiler(PaxCompiler1, PaxInterpreter1); + end + else + for I:=0 to PaxCompiler1.ErrorCount - 1 do + ShowMessage(PaxCompiler1.ErrorMessage[I]); +end; + +procedure TForm1.Button2Click(Sender: TObject); +begin + if not PaxCompilerDebugger1.Valid then + begin + ShowMessage('You have to compile script. Press "Compile" button.'); + Exit; + end; + PaxCompilerDebugger1.RunMode := _rmRUN; + if PaxCompilerDebugger1.IsPaused then + ResumeRequest := true + else + PaxCompilerDebugger1.Run; +end; + +procedure TForm1.Button3Click(Sender: TObject); +begin + if not PaxCompilerDebugger1.Valid then + begin + ShowMessage('You have to compile script. Press "Compile" button.'); + Exit; + end; + PaxCompilerDebugger1.RunMode := _rmTRACE_INTO; + if PaxCompilerDebugger1.IsPaused then + ResumeRequest := true + else + PaxCompilerDebugger1.Run; +end; + +procedure TForm1.Button4Click(Sender: TObject); +begin + if not PaxCompilerDebugger1.Valid then + begin + ShowMessage('You have to compile script. Press "Compile" button.'); + Exit; + end; + PaxCompilerDebugger1.RunMode := _rmSTEP_OVER; + if PaxCompilerDebugger1.IsPaused then + ResumeRequest := true + else + PaxCompilerDebugger1.Run; +end; + +procedure TForm1.Button5Click(Sender: TObject); +begin + if not PaxCompilerDebugger1.Valid then + begin + ShowMessage('You have to compile script. Press "Compile" button.'); + Exit; + end; + + Form2.ShowModal; + + PaxCompilerDebugger1.RunMode := _rmRUN_TO_CURSOR; + if PaxCompilerDebugger1.IsPaused then + ResumeRequest := true + else + PaxCompilerDebugger1.Run; +end; + +procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean); +begin + CanClose := true; + CloseRequest := true; +end; + +procedure TForm1.PaxInterpreter1PauseUpdated(Sender: TPaxRunner; + const ModuleName: string; SourceLineNumber: Integer); +begin + UpdateDebugInfo; + ResumeRequest := false; + repeat + Application.ProcessMessages; + if ResumeRequest then + Break; + if CloseRequest then + Abort; + until false; +end; + +procedure TForm1.PaxInterpreter1PrintEvent(Sender: TPaxInterpreter; const Text: string); +begin + ShowMessage(Text); +end; + +procedure TForm1.UpdateDebugInfo; + + procedure AddFields(StackFrameNumber, Id: Integer); + var + I, K: Integer; + OwnerName, S: String; + begin + K := PaxCompilerExplorer1.GetFieldCount(Id); + if K = 0 then + Exit; + + OwnerName := PaxCompilerExplorer1.Names[Id]; + if PaxCompilerDebugger1.GetValueAsString(Id) = 'nil' then + Exit; + + for I:=0 to K - 1 do + begin + S := OwnerName + '.' + PaxCompilerExplorer1.GetFieldName(Id, I); + S := ' ' + S + '=' + PaxCompilerDebugger1.GetFieldValueAsString( + StackFrameNumber, Id, I); + Memo2.Lines.Add(S); + end; + end; + + procedure AddPublishedProps(StackFrameNumber, Id: Integer); + var + I, K: Integer; + OwnerName, S: String; + begin + K := PaxCompilerExplorer1.GetPublishedPropCount(Id); + if K = 0 then + Exit; + + OwnerName := PaxCompilerExplorer1.Names[Id]; + if PaxCompilerDebugger1.GetValueAsString(Id) = 'nil' then + Exit; + + for I:=0 to K - 1 do + begin + S := OwnerName + '.' + PaxCompilerExplorer1.GetPublishedPropName(Id, I); + S := ' ' + S + '=' + PaxCompilerDebugger1.GetPublishedPropValueAsString( + StackFrameNumber, Id, I); + Memo2.Lines.Add(S); + end; + end; + + procedure AddArrayElements(StackFrameNumber, Id: Integer); + var + I, K1, K2: Integer; + OwnerName, S: String; + begin + if not PaxCompilerExplorer1.HasArrayType(Id) then + Exit; + + K1 := PaxCompilerExplorer1.GetArrayLowBound(Id); + K2 := PaxCompilerExplorer1.GetArrayHighBound(Id); + + OwnerName := PaxCompilerExplorer1.Names[Id]; + + for I:=K1 to K2 do + begin + S := OwnerName + '[' + IntToStr(I) + ']'; + S := ' ' + S + '=' + PaxCompilerDebugger1.GetArrayItemValueAsString( + StackFrameNumber, Id, I); + Memo2.Lines.Add(S); + end; + end; + + procedure AddDynArrayElements(StackFrameNumber, Id: Integer); + var + I, L: Integer; + OwnerName, S: String; + begin + if not PaxCompilerExplorer1.HasDynArrayType(Id) then + Exit; + + L := PaxCompilerDebugger1.GetDynArrayLength(StackFrameNumber, Id); + + OwnerName := PaxCompilerExplorer1.Names[Id]; + + for I:=0 to L - 1 do + begin + S := OwnerName + '[' + IntToStr(I) + ']'; + S := ' ' + S + '=' + PaxCompilerDebugger1.GetDynArrayItemValueAsString( + StackFrameNumber, Id, I); + Memo2.Lines.Add(S); + end; + end; + +var + SourceLineNumber: Integer; + ModuleName: String; + StackFrameNumber, J, K, SubId, Id: Integer; + S, V: String; + CallStackLineNumber: Integer; + CallStackModuleName: String; +begin + Memo2.Lines.Clear; + if PaxCompilerDebugger1.IsPaused then + begin + ModuleName := PaxCompilerDebugger1.ModuleName; + SourceLineNumber := PaxCompilerDebugger1.SourceLineNumber; + + if SourceLineNumber >= PaxCompiler1.Modules[ModuleName].Count then + Exit; + + Memo2.Lines.Add('Paused at line ' + IntTosTr(SourceLineNumber)); + Memo2.Lines.Add(PaxCompiler1.Modules[ModuleName][SourceLineNumber]); + Memo2.Lines.Add('------------------------------------------------------'); + + if PaxCompilerDebugger1.CallStackCount > 0 then + begin + Memo2.Lines.Add('Call stack:'); + for StackFrameNumber:=0 to PaxCompilerDebugger1.CallStackCount - 1 do + begin + SubId := PaxCompilerDebugger1.CallStack[StackFrameNumber]; + S := '('; + K := PaxCompilerExplorer1.GetParamCount(SubId); + for J:=0 to K - 1 do + begin + Id := PaxCompilerExplorer1.GetParamId(SubId, J); + V := PaxCompilerDebugger1.GetValueAsString(StackFrameNumber, Id); + S := S + V; + if J < K - 1 then + S := S + ','; + end; + S := PaxCompilerExplorer1.Names[SubId] + S + ')'; + + CallStackLineNumber := PaxCompilerDebugger1.CallStackLineNumber[StackFrameNumber]; + CallStackModuleName := PaxCompilerDebugger1.CallStackModuleName[StackFrameNumber]; + + S := S + '; // ' + PaxCompiler1.Modules[CallStackModuleName][CallStackLineNumber]; + + Memo2.Lines.Add(S); + end; + Memo2.Lines.Add('------------------------------------------------------'); + + Memo2.Lines.Add('Local scope:'); + StackFrameNumber := PaxCompilerDebugger1.CallStackCount - 1; + SubId := PaxCompilerDebugger1.CallStack[StackFrameNumber]; + K := PaxCompilerExplorer1.GetLocalCount(SubId); + for J:=0 to K - 1 do + begin + Id := PaxCompilerExplorer1.GetLocalId(SubId, J); + V := PaxCompilerDebugger1.GetValueAsString(StackFrameNumber, Id); + S := PaxCompilerExplorer1.Names[Id] + '=' + V; + Memo2.Lines.Add(S); + + if Pos('X', S) > 0 then + begin + PaxCompilerDebugger1.PutValue(StackFrameNumber, Id, 258); + + V := PaxCompilerDebugger1.GetValueAsString(StackFrameNumber, Id); + S := PaxCompilerExplorer1.Names[Id] + '=' + V; + S := S + ' // modified'; + Memo2.Lines.Add(S); + end; + + AddFields(StackFrameNumber, Id); + AddPublishedProps(StackFrameNumber, Id); + AddArrayElements(StackFrameNumber, Id); + AddDynArrayElements(StackFrameNumber, Id); + end; + + Memo2.Lines.Add('------------------------------------------------------'); + end; + + Memo2.Lines.Add('Global scope:'); + K := PaxCompilerExplorer1.GetGlobalCount(0); + for J:=0 to K - 1 do + begin + Id := PaxCompilerExplorer1.GetGlobalId(0, J); + V := PaxCompilerDebugger1.GetValueAsString(Id); + S := PaxCompilerExplorer1.Names[Id] + '=' + V; + Memo2.Lines.Add(S); + + AddFields(0, Id); + AddPublishedProps(0, Id); + AddArrayElements(0, Id); + AddDynArrayElements(0, Id); + end; + Memo2.Lines.Add('------------------------------------------------------'); + + end + else + Memo2.Lines.Add('Finished'); + + Memo2.SelStart := 0; + Memo2.SelLength := 0; +end; + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/DebugDemo/Unit2.dfm b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/DebugDemo/Unit2.dfm new file mode 100644 index 0000000..c01f34c --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/DebugDemo/Unit2.dfm @@ -0,0 +1,43 @@ +object Form2: TForm2 + Left = 551 + Top = 252 + Width = 384 + Height = 345 + Caption = 'Select line' + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + PixelsPerInch = 96 + TextHeight = 13 + object Panel1: TPanel + Left = 0 + Top = 270 + Width = 376 + Height = 41 + Align = alBottom + TabOrder = 0 + object Button1: TButton + Left = 8 + Top = 8 + Width = 75 + Height = 25 + Caption = 'Ok' + ModalResult = 1 + TabOrder = 0 + OnClick = Button1Click + end + end + object ListBox1: TListBox + Left = 0 + Top = 0 + Width = 376 + Height = 270 + Align = alClient + ItemHeight = 13 + TabOrder = 1 + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/DebugDemo/Unit2.pas b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/DebugDemo/Unit2.pas new file mode 100644 index 0000000..e1e87d9 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/DebugDemo/Unit2.pas @@ -0,0 +1,65 @@ +unit Unit2; + +interface + +uses + Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, ExtCtrls; + +type + TForm2 = class(TForm) + Panel1: TPanel; + ListBox1: TListBox; + Button1: TButton; + procedure Button1Click(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + function ShowModal: Integer; override; + end; + +var + Form2: TForm2; + +implementation + +uses Unit1; + +{$R *.dfm} + +function TForm2.ShowModal: Integer; +var + I: Integer; + S: String; + ch: Char; +begin + ListBox1.Items.Clear; + for I:=0 to Form1.Memo1.Lines.Count - 1 do + begin + if Form1.PaxCompilerExplorer1.IsExecutableLine('1', I) then + ch := '*' + else + ch := ' '; + S := Format('%3d ', [I]) + ch + ' ' + Form1.Memo1.Lines[I]; + ListBox1.Items.Add(S); + end; + + result := inherited ShowModal; +end; + +procedure TForm2.Button1Click(Sender: TObject); +var + I: Integer; +begin + I := ListBox1.ItemIndex; + if Form1.PaxCompilerExplorer1.IsExecutableLine('1', I) then + Form1.PaxCompilerDebugger1.AddTempBreakpoint('1', I) + else + begin + ShowMessage(IntToStr(I) + ' is not executable line!'); + ModalResult := mrCancel; + end; +end; + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/EvalExpression/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/EvalExpression/Project1.dpr new file mode 100644 index 0000000..513a1dd --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/EvalExpression/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/EvalExpression/Project1.res b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/EvalExpression/Project1.res new file mode 100644 index 0000000..3adc036 Binary files /dev/null and b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/EvalExpression/Project1.res differ diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/EvalExpression/Unit1.dfm b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/EvalExpression/Unit1.dfm new file mode 100644 index 0000000..cde7bc7 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/EvalExpression/Unit1.dfm @@ -0,0 +1,43 @@ +object Form1: TForm1 + Left = 192 + Top = 115 + Caption = 'Eval Expression' + ClientHeight = 142 + ClientWidth = 326 + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -14 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + OnCreate = FormCreate + PixelsPerInch = 120 + TextHeight = 16 + object Button1: TButton + Left = 30 + Top = 30 + Width = 247 + Height = 30 + Margins.Left = 4 + Margins.Top = 4 + Margins.Right = 4 + Margins.Bottom = 4 + Caption = 'Create compiled expression' + TabOrder = 0 + OnClick = Button1Click + end + object Button2: TButton + Left = 30 + Top = 79 + Width = 247 + Height = 31 + Margins.Left = 4 + Margins.Top = 4 + Margins.Right = 4 + Margins.Bottom = 4 + Caption = 'Evaluate expression' + TabOrder = 1 + OnClick = Button2Click + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/EvalExpression/Unit1.pas b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/EvalExpression/Unit1.pas new file mode 100644 index 0000000..f8ad384 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/EvalExpression/Unit1.pas @@ -0,0 +1,116 @@ +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, PaxCompiler, PaxInterpreter, PaxRegister, PaxBasicLanguage; + +type + TForm1 = class(TForm) + Button1: TButton; + Button2: TButton; + procedure Button1Click(Sender: TObject); + procedure Button2Click(Sender: TObject); + procedure FormCreate(Sender: TObject); + private + { Private declarations } + arr_x, arr_y: array[1..3] of Double; + h_norm, h_x, h_y: Integer; + + buff: array[1..40960] of Byte; + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.dfm} + +function Norm(x, y: Double): Double; +begin + result := Sqrt(x * x + y * y); +end; + +procedure TForm1.Button1Click(Sender: TObject); +var + PaxCompiler1: TPaxCompiler; + PaxBasicLanguage1: TPaxBasicLanguage; + PaxInterpreter1: TPaxInterpreter; + I: Integer; +begin + PaxCompiler1 := TPaxCompiler.Create(nil); + PaxBasicLanguage1 := TPaxBasicLanguage.Create(nil); + PaxInterpreter1 := TPaxInterpreter.Create(nil); + + try + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxBasicLanguage1); + + h_norm := PaxCompiler1.RegisterHeader(0, 'function Norm(x, y: Double): Double;'); + + h_x := PaxCompiler1.RegisterVariable(0, 'x', _typeDOUBLE); + h_y := PaxCompiler1.RegisterVariable(0, 'y', _typeDOUBLE); + + if PaxCompiler1.CompileExpression('Norm(x, y)', PaxInterpreter1, 'Basic') then + begin + PaxInterpreter1.SaveToBuff(buff); + ShowMessage('Compiled expression has been created!'); + end + else + for I:=0 to PaxCompiler1.ErrorCount - 1 do + ShowMessage(PaxCompiler1.ErrorMessage[I]); + + finally + PaxCompiler1.Free; + PaxBasicLanguage1.Free; + PaxInterpreter1.Free; + end; +end; + +procedure TForm1.Button2Click(Sender: TObject); +var + PaxInterpreter1: TPaxInterpreter; + ResValue: Double; + I: Integer; +begin +{$O-} + if h_x <> 0 then + begin + PaxInterpreter1 := TPaxInterpreter.Create(nil); + try + PaxInterpreter1.LoadFromBuff(buff); + + PaxInterpreter1.SetAddress(h_norm, @norm); + + for I:=1 to 3 do + begin + PaxInterpreter1.SetAddress(h_x, @arr_x[I]); + PaxInterpreter1.SetAddress(h_y, @arr_y[I]); + + PaxInterpreter1.Run; + + ResValue := Double(PaxInterpreter1.ResultPtr^); + ShowMessage(FloatToStr(ResValue)); + end; + + finally + PaxInterpreter1.Free; + end; + end + else + ShowMessage('Press the first button to create compiled script.'); +end; + +procedure TForm1.FormCreate(Sender: TObject); +begin + h_x := 0; h_y := 0; h_norm := 0; + arr_x[1] := 4.2; arr_y[1] := -5.2; + arr_x[2] := -0.4; arr_y[2] := 3.2; + arr_x[3] := 2.0; arr_y[3] := 3; +end; + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/EventHandler/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/EventHandler/Project1.dpr new file mode 100644 index 0000000..513a1dd --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/EventHandler/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/EventHandler/Project1.res b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/EventHandler/Project1.res new file mode 100644 index 0000000..3adc036 Binary files /dev/null and b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/EventHandler/Project1.res differ diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/EventHandler/Unit1.dfm b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/EventHandler/Unit1.dfm new file mode 100644 index 0000000..c1ed362 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/EventHandler/Unit1.dfm @@ -0,0 +1,107 @@ +object Form1: TForm1 + Left = 19 + Top = 116 + Width = 918 + Height = 523 + Caption = 'Script-defined event handler demo' + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + PixelsPerInch = 96 + TextHeight = 13 + object Button1: TButton + Left = 16 + Top = 8 + Width = 273 + Height = 25 + Caption = 'Create event handler for Button2.OnClick event' + TabOrder = 0 + OnClick = Button1Click + end + object Button2: TButton + Left = 782 + Top = 432 + Width = 75 + Height = 25 + Caption = 'Button2' + TabOrder = 1 + end + object Memo1: TMemo + Left = 16 + Top = 40 + Width = 601 + Height = 433 + Font.Charset = RUSSIAN_CHARSET + Font.Color = clWindowText + Font.Height = -15 + Font.Name = 'Times New Roman' + Font.Style = [] + Lines.Strings = ( + 'Class MyHandler' + ' Sub Handle(Sender As TObject)' + ' ShowMessage("Sender: " + Sender.ClassName)' + ' End Sub' + ' Sub Dispose(Sender As TObject)' + ' Free' + ' End Sub' + 'End Class' + '' + 'Dim X As MyHandler = New MyHandler' + 'Button2.OnClick = X.Handle' + 'Form1.OnDestroy = X.Dispose' + '') + ParentFont = False + TabOrder = 2 + end + object Button3: TButton + Left = 696 + Top = 24 + Width = 161 + Height = 25 + Caption = 'Remove event handler' + TabOrder = 3 + OnClick = Button3Click + end + object Memo2: TMemo + Left = 696 + Top = 72 + Width = 161 + Height = 73 + Font.Charset = RUSSIAN_CHARSET + Font.Color = clWindowText + Font.Height = -15 + Font.Name = 'Times New Roman' + Font.Style = [] + Lines.Strings = ( + 'Button2.OnClick = null') + ParentFont = False + TabOrder = 4 + end + object PaxCompiler1: TPaxCompiler + Alignment = 1 + DebugMode = False + Left = 760 + Top = 248 + end + object PaxBasicLanguage1: TPaxBasicLanguage + ExplicitOff = False + CompleteBooleanEval = False + UseFWArrays = True + Left = 760 + Top = 312 + end + object PaxInterpreter1: TPaxInterpreter + Console = False + Left = 536 + Top = 304 + end + object PaxInterpreter2: TPaxInterpreter + Console = False + Left = 576 + Top = 304 + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/EventHandler/Unit1.pas b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/EventHandler/Unit1.pas new file mode 100644 index 0000000..91da739 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/EventHandler/Unit1.pas @@ -0,0 +1,92 @@ +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, + Dialogs, PaxInterpreter, PaxCompiler, StdCtrls, PaxRegister, PaxBasicLanguage, + PaxRunner; + +type + TForm1 = class(TForm) + Button1: TButton; + Button2: TButton; + Memo1: TMemo; + PaxCompiler1: TPaxCompiler; + Button3: TButton; + Memo2: TMemo; + PaxBasicLanguage1: TPaxBasicLanguage; + PaxInterpreter1: TPaxInterpreter; + PaxInterpreter2: TPaxInterpreter; + procedure Button1Click(Sender: TObject); + procedure Button3Click(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.dfm} + +var + H_TButton, H_TForm1: Integer; + +procedure TForm1.Button1Click(Sender: TObject); +var + I: Integer; +begin + if Assigned(Button2.OnClick) then + begin + ShowMessage('The event handler has been already created.'); + Exit; + end; + + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxBasicLanguage1); + PaxCompiler1.AddModule('1', 'Basic'); + PaxCompiler1.AddCode('1', Memo1.Lines.Text); + PaxCompiler1.RegisterVariable(0, 'Button2', H_TButton, @Button2); + PaxCompiler1.RegisterVariable(0, 'Form1', H_TForm1, @Form1); + + if PaxCompiler1.Compile(PaxInterpreter1) then + begin + PaxInterpreter1.Run; + ShowMessage('The event handler has been created. Click Button2.'); + end + else + for I:=0 to PaxCompiler1.ErrorCount - 1 do + ShowMessage(PaxCompiler1.ErrorMessage[I]); +end; + +procedure TForm1.Button3Click(Sender: TObject); +var + I: Integer; +begin + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxBasicLanguage1); + PaxCompiler1.AddModule('1', 'Basic'); + PaxCompiler1.AddCode('1', Memo2.Lines.Text); + PaxCompiler1.RegisterVariable(0, 'Button2', H_TButton, @Button2); + + if PaxCompiler1.Compile(PaxInterpreter2) then + begin + PaxInterpreter2.Run; + ShowMessage('The event handler has been removed.'); + end + else + for I:=0 to PaxCompiler1.ErrorCount - 1 do + ShowMessage(PaxCompiler1.ErrorMessage[I]); +end; + +initialization + + H_TButton := RegisterClassType(0, TButton); + H_TForm1 := RegisterClassType(0, TForm1); + RegisterHeader(0, 'procedure ShowMessage(const Msg: string);', @ShowMessage); + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/EventHandler2/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/EventHandler2/Project1.dpr new file mode 100644 index 0000000..513a1dd --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/EventHandler2/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/EventHandler2/Project1.res b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/EventHandler2/Project1.res new file mode 100644 index 0000000..3adc036 Binary files /dev/null and b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/EventHandler2/Project1.res differ diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/EventHandler2/Unit1.dfm b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/EventHandler2/Unit1.dfm new file mode 100644 index 0000000..a3b0e3f --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/EventHandler2/Unit1.dfm @@ -0,0 +1,115 @@ +object Form1: TForm1 + Left = 192 + Top = 114 + Width = 889 + Height = 607 + Caption = 'Event handler demo' + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + PixelsPerInch = 96 + TextHeight = 13 + object Button1: TButton + Left = 16 + Top = 16 + Width = 209 + Height = 25 + Caption = '1. Compile script' + TabOrder = 0 + OnClick = Button1Click + end + object Button2: TButton + Left = 16 + Top = 56 + Width = 209 + Height = 25 + Caption = '2. Set up script-defined event handler' + TabOrder = 1 + OnClick = Button2Click + end + object Button3: TButton + Left = 16 + Top = 96 + Width = 209 + Height = 25 + Caption = '3. Restore host-defined event handler' + TabOrder = 2 + OnClick = Button3Click + end + object Memo1: TMemo + Left = 240 + Top = 8 + Width = 608 + Height = 545 + Font.Charset = RUSSIAN_CHARSET + Font.Color = clWindowText + Font.Height = -15 + Font.Name = 'Times New Roman' + Font.Style = [] + Lines.Strings = ( + 'Class MyHandler' + ' Sub Handle(Sender As TObject)' + + ' ShowMessage("Script-defined handler. Sender: " + Sender.Clas' + + 'sName)' + ' End Sub' + ' Sub Dispose(Sender As TObject)' + ' Free' + ' End Sub' + 'End Class' + '' + 'Dim X As MyHandler' + 'Dim E As TNotifyEvent' + '' + 'Sub SetHandler' + ' E = ClickMe.OnClick' + ' ClickMe.OnClick = X.Handle' + 'End Sub' + '' + 'Sub RestoreHandler' + ' ClickMe.OnClick = E' + 'End Sub' + '' + 'X = New MyHandler' + 'ClickMe.OnClick(X)' + 'Form1.OnDestroy = X.Dispose' + + 'ShowMessage("The script was compiled and initialized successfull' + + 'y.")' + '' + '') + ParentFont = False + TabOrder = 3 + end + object ClickMe: TButton + Left = 24 + Top = 440 + Width = 201 + Height = 105 + Caption = 'ClickMe' + TabOrder = 4 + OnClick = ClickMeClick + end + object PaxCompiler1: TPaxCompiler + Alignment = 1 + DebugMode = False + Left = 632 + Top = 64 + end + object PaxBasicLanguage1: TPaxBasicLanguage + ExplicitOff = False + CompleteBooleanEval = False + UseFWArrays = True + Left = 648 + Top = 304 + end + object PaxInterpreter1: TPaxInterpreter + Console = False + Left = 512 + Top = 248 + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/EventHandler2/Unit1.pas b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/EventHandler2/Unit1.pas new file mode 100644 index 0000000..d69821f --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/EventHandler2/Unit1.pas @@ -0,0 +1,100 @@ +{$O-} + +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, PaxInterpreter, PaxCompiler, PaxRegister, PaxBasicLanguage, + PaxRunner; + +type + TForm1 = class(TForm) + Button1: TButton; + Button2: TButton; + Button3: TButton; + Memo1: TMemo; + ClickMe: TButton; + PaxCompiler1: TPaxCompiler; + PaxBasicLanguage1: TPaxBasicLanguage; + PaxInterpreter1: TPaxInterpreter; + procedure Button1Click(Sender: TObject); + procedure ClickMeClick(Sender: TObject); + procedure Button2Click(Sender: TObject); + procedure Button3Click(Sender: TObject); + private + { Private declarations } + P_SetHandler: Pointer; + P_RestoreHandler: Pointer; + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.dfm} + +var + H_TButton, H_TForm1: Integer; + +type + TProcP = procedure; + +procedure TForm1.Button1Click(Sender: TObject); +var + I: Integer; +begin + if PaxInterpreter1.DataSize > 0 then + begin + ShowMessage('Script is already compiled.'); + Exit; + end; + + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxBasicLanguage1); + PaxCompiler1.AddModule('1', 'Basic'); + PaxCompiler1.AddCode('1', Memo1.Lines.Text); + PaxCompiler1.RegisterVariable(0, 'ClickMe', H_TButton, @ClickMe); + PaxCompiler1.RegisterVariable(0, 'Form1', H_TForm1, @Form1); + + if PaxCompiler1.Compile(PaxInterpreter1) then + begin + P_SetHandler := PaxInterpreter1.GetAddress('SetHandler'); + P_RestoreHandler := PaxInterpreter1.GetAddress('RestoreHandler'); + + PaxInterpreter1.Run; + end + else + for I:=0 to PaxCompiler1.ErrorCount - 1 do + ShowMessage(PaxCompiler1.ErrorMessage[I]); +end; + +procedure TForm1.Button2Click(Sender: TObject); +begin + TProcP(P_SetHandler); + + ShowMessage('ClickMe contains script-defined event handler now.'); +end; + +procedure TForm1.Button3Click(Sender: TObject); +begin + TProcP(P_RestoreHandler); + + ShowMessage('Host-defined handler is restored.'); +end; + +procedure TForm1.ClickMeClick(Sender: TObject); +begin + ShowMessage('Host-defined event handler. Sender: ' + Sender.ClassName); +end; + +initialization + H_TButton := RegisterClassType(0, TButton); + H_TForm1 := RegisterClassType(0, TForm1); + RegisterHeader(0, 'procedure ShowMessage(const Msg: string);', @ShowMessage); + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/HandledException/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/HandledException/Project1.dpr new file mode 100644 index 0000000..513a1dd --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/HandledException/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/HandledException/Project1.res b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/HandledException/Project1.res new file mode 100644 index 0000000..3adc036 Binary files /dev/null and b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/HandledException/Project1.res differ diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/HandledException/Unit1.dfm b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/HandledException/Unit1.dfm new file mode 100644 index 0000000..03442ed --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/HandledException/Unit1.dfm @@ -0,0 +1,84 @@ +object Form1: TForm1 + Left = 192 + Top = 114 + Width = 721 + Height = 602 + Caption = 'Run-time error handling' + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + PixelsPerInch = 96 + TextHeight = 13 + object Button1: TButton + Left = 24 + Top = 16 + Width = 161 + Height = 25 + Caption = 'Compile and Run' + TabOrder = 0 + OnClick = Button1Click + end + object Memo1: TMemo + Left = 200 + Top = 16 + Width = 481 + Height = 441 + Lines.Strings = ( + 'Imports SysUtils' + '' + 'Sub ErrorProc' + 'Dim I As Integer' + ' I = 0' + ' I = I \ I' + 'End Sub' + '' + 'Sub TestFinally' + ' Dim S As String = "abc"' + ' Dim I As Integer' + ' Try' + ' ErrorProc' + ' Finally' + ' println S' + ' End Try' + ' Println "not executed"' + 'End Sub' + '' + 'Try' + ' TestFinally' + 'Catch' + ' println "ok"' + 'End Try') + TabOrder = 1 + end + object Memo2: TMemo + Left = 200 + Top = 464 + Width = 481 + Height = 89 + TabOrder = 2 + end + object PaxCompiler1: TPaxCompiler + Alignment = 1 + DebugMode = False + Left = 64 + Top = 112 + end + object PaxBasicLanguage1: TPaxBasicLanguage + ExplicitOff = False + CompleteBooleanEval = False + UseFWArrays = True + Left = 112 + Top = 240 + end + object PaxInterpreter1: TPaxInterpreter + Console = False + OnException = PaxInterpreter1Exception + OnPrintEvent = PaxInterpreter1PrintEvent + Left = 136 + Top = 168 + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/HandledException/Unit1.pas b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/HandledException/Unit1.pas new file mode 100644 index 0000000..1d18283 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/HandledException/Unit1.pas @@ -0,0 +1,71 @@ +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, + Dialogs, PaxInterpreter, PaxCompiler, StdCtrls, PAXCOMP_STDLIB, PaxBasicLanguage, + PaxRunner; + +type + TForm1 = class(TForm) + Button1: TButton; + Memo1: TMemo; + PaxCompiler1: TPaxCompiler; + Memo2: TMemo; + PaxBasicLanguage1: TPaxBasicLanguage; + PaxInterpreter1: TPaxInterpreter; + procedure Button1Click(Sender: TObject); + procedure PaxInterpreter1PrintEvent(Sender: TPaxRunner; const Text: string); + procedure PaxInterpreter1Exception(Sender: TPaxRunner; E: Exception; + const ModuleName: string; SourceLineNumber: Integer); + private + { Private declarations } + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.dfm} + +uses + IMPORT_SysUtils; + +procedure TForm1.Button1Click(Sender: TObject); +begin + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxBasicLanguage1); + PaxCompiler1.AddModule('main', 'Basic'); + PaxCompiler1.AddCode('main', Memo1.Lines.Text); + if PaxCompiler1.Compile(PaxInterpreter1) then + begin + PaxInterpreter1.Run; + end + else + ShowMessage(PaxCompiler1.ErrorMessage[0]); +end; + +procedure TForm1.PaxInterpreter1Exception(Sender: TPaxRunner; E: Exception; + const ModuleName: string; SourceLineNumber: Integer); +begin + Form1.Memo2.Text := Form1.Memo2.Text + #13#10 + + 'Exception (' + E.Message + + ') raised at line ' + IntToStr(SourceLineNumber) + ':' + + PaxCompiler1.Modules[ModuleName][SourceLineNumber] + #13#10; +end; + +procedure TForm1.PaxInterpreter1PrintEvent(Sender: TPaxRunner; + const Text: string); +begin + Form1.Memo2.Text := Form1.Memo2.Text + Text; +end; + +initialization + +Register_SysUtils; + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/Hello/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/Hello/Project1.dpr new file mode 100644 index 0000000..513a1dd --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/Hello/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/Hello/Project1.res b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/Hello/Project1.res new file mode 100644 index 0000000..3adc036 Binary files /dev/null and b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/Hello/Project1.res differ diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/Hello/Unit1.dfm b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/Hello/Unit1.dfm new file mode 100644 index 0000000..e9bf245 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/Hello/Unit1.dfm @@ -0,0 +1,47 @@ +object Form1: TForm1 + Left = 192 + Top = 114 + Caption = 'HelloApp' + ClientHeight = 164 + ClientWidth = 290 + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -14 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + PixelsPerInch = 120 + TextHeight = 16 + object Button1: TButton + Left = 39 + Top = 98 + Width = 93 + Height = 31 + Margins.Left = 4 + Margins.Top = 4 + Margins.Right = 4 + Margins.Bottom = 4 + Caption = 'Say "Hello"' + TabOrder = 0 + OnClick = Button1Click + end + object PaxCompiler1: TPaxCompiler + Alignment = 1 + DebugMode = False + Left = 48 + Top = 24 + end + object PaxBasicLanguage1: TPaxBasicLanguage + ExplicitOff = False + CompleteBooleanEval = False + UseFWArrays = True + Left = 152 + Top = 72 + end + object PaxInterpreter1: TPaxInterpreter + Console = False + Left = 184 + Top = 24 + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/Hello/Unit1.pas b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/Hello/Unit1.pas new file mode 100644 index 0000000..c5ea51c --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/Hello/Unit1.pas @@ -0,0 +1,48 @@ +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, PaxCompiler, PaxInterpreter, PaxBasicLanguage, PaxRunner; +type + TForm1 = class(TForm) + PaxCompiler1: TPaxCompiler; + Button1: TButton; + PaxBasicLanguage1: TPaxBasicLanguage; + PaxInterpreter1: TPaxInterpreter; + procedure Button1Click(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.dfm} + +procedure TForm1.Button1Click(Sender: TObject); +var + I, H_TButton: Integer; +begin + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxBasicLanguage1); + + H_TButton := PaxCompiler1.RegisterClassType(0, TButton); + PaxCompiler1.RegisterVariable(0, 'Button1', H_TButton, @Button1); + + PaxCompiler1.AddModule('1', PaxBasicLanguage1.LanguageName); + PaxCompiler1.AddCode('1', 'Button1.Caption = "Hello"'); + + if PaxCompiler1.Compile(PaxInterpreter1) then + PaxInterpreter1.Run + else + for I:=0 to PaxCompiler1.ErrorCount - 1 do + ShowMessage(PaxCompiler1.ErrorMessage[I]); +end; + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/Inheritance/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/Inheritance/Project1.dpr new file mode 100644 index 0000000..513a1dd --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/Inheritance/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/Inheritance/Project1.res b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/Inheritance/Project1.res new file mode 100644 index 0000000..3adc036 Binary files /dev/null and b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/Inheritance/Project1.res differ diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/Inheritance/Unit1.dfm b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/Inheritance/Unit1.dfm new file mode 100644 index 0000000..f92524c --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/Inheritance/Unit1.dfm @@ -0,0 +1,84 @@ +object Form1: TForm1 + Left = 233 + Top = 111 + Width = 646 + Height = 628 + Caption = 'Inerit host class' + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + PixelsPerInch = 96 + TextHeight = 13 + object Button1: TButton + Left = 40 + Top = 32 + Width = 113 + Height = 25 + Caption = 'Run script' + TabOrder = 0 + OnClick = Button1Click + end + object Memo1: TMemo + Left = 192 + Top = 8 + Width = 401 + Height = 569 + Font.Charset = RUSSIAN_CHARSET + Font.Color = clWindowText + Font.Height = -12 + Font.Name = 'Times New Roman' + Font.Style = [] + Lines.Strings = ( + 'Imports Classes' + 'Class MyForm' + ' Inherits TForm' + ' Private Button1 As TButton' + ' Sub New(AOwner As TComponent)' + ' MyBase.CreateNew(AOwner)' + ' Top = 100' + ' Left = 200' + ' Caption = "Script-defined form MyForm"' + ' Button1 = New TButton(Me)' + ' Button1.Parent = Me' + ' Button1.Top = 50' + ' Button1.Left = 50' + ' Button1.Caption = "Click me"' + ' Button1.OnClick = Button1Click' + ' End Sub' + '' + ' Sub Button1Click(Sender As TObject)' + ' ShowMessage("Hello!")' + ' ShowMessage("Sender: " + Sender.ClassName)' + ' End Sub' + 'End Class' + '' + 'Dim F As MyForm = New MyForm(null)' + 'F.ShowModal' + 'F.Free' + '') + ParentFont = False + TabOrder = 1 + end + object PaxCompiler1: TPaxCompiler + Alignment = 1 + DebugMode = False + Left = 40 + Top = 80 + end + object PaxBasicLanguage1: TPaxBasicLanguage + ExplicitOff = False + CompleteBooleanEval = False + UseFWArrays = True + Left = 80 + Top = 232 + end + object PaxInterpreter1: TPaxInterpreter + Console = False + Left = 184 + Top = 320 + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/Inheritance/Unit1.pas b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/Inheritance/Unit1.pas new file mode 100644 index 0000000..f40a0c1 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/Inheritance/Unit1.pas @@ -0,0 +1,101 @@ +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, + Dialogs, PaxInterpreter, PaxCompiler, StdCtrls, PaxRegister, PaxBasicLanguage, + PaxRunner; + +type + TForm1 = class(TForm) + Button1: TButton; + PaxCompiler1: TPaxCompiler; + Memo1: TMemo; + PaxBasicLanguage1: TPaxBasicLanguage; + PaxInterpreter1: TPaxInterpreter; + procedure Button1Click(Sender: TObject); + procedure PaxInterpreter1UnhandledException(Sender: TPaxInterpreter; + E: Exception; const ModuleName: String; SourceLineNumber: Integer); + private + { Private declarations } + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.dfm} + +uses + IMPORT_Classes; + +var + H_TForm: Integer; + +procedure TForm1.Button1Click(Sender: TObject); +var + I: Integer; +begin + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxBasicLanguage1); + PaxCompiler1.AddModule('1', 'Basic'); + PaxCompiler1.AddCode('1', Memo1.Lines.Text); + + if PaxCompiler1.Compile(PaxInterpreter1) then + begin + PaxInterpreter1.Run; + end + else + for I:=0 to PaxCompiler1.ErrorCount - 1 do + ShowMessage(PaxCompiler1.ErrorMessage[I]); +end; + +procedure TForm1.PaxInterpreter1UnhandledException(Sender: TPaxInterpreter; + E: Exception; const ModuleName: String; SourceLineNumber: Integer); +begin + ShowMessage( + 'Exception (' + E.Message + + ') raised at line ' + IntToStr(SourceLineNumber) + ':' + + PaxCompiler1.Modules[ModuleName][SourceLineNumber] + ); +end; + +function TControl_GetParent(Self: TControl): TWinControl; +begin + result := Self.Parent; +end; + +procedure TControl_SetParent(Self: TControl; Value: TWinControl); +begin + Self.Parent := Value; +end; + +var + H: Integer; + +initialization + Register_Classes; + + H := RegisterClassType(0, TControl); + RegisterClassType(0, TWinControl); + RegisterHeader(H, 'function _GetParent: TWinControl;', @TControl_GetParent); + RegisterHeader(H, 'procedure _SetParent(Value: TWinControl);', @TControl_SetParent); + RegisterProperty(H, 'property Parent: TWinControl read _GetParent write _SetParent;'); + + H_TForm := RegisterClassType(0, TForm); + RegisterHeader(H_TForm, 'constructor CreateNew(AOwner: TComponent; Dummy: Integer = 0); override;', + @ TForm.CreateNew); + RegisterHeader(H_TForm, 'function ShowModal: Integer;', @TForm.ShowModal); + + H := RegisterClassType(0, TButton); + RegisterHeader(H, 'constructor Create(AOwner: TComponent); override;', + @TButton.Create); + + RegisterHeader(0, 'procedure ShowMessage(const Msg: string);', @ShowMessage); + + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/LoadCompiledScript/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/LoadCompiledScript/Project1.dpr new file mode 100644 index 0000000..513a1dd --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/LoadCompiledScript/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/LoadCompiledScript/Project1.res b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/LoadCompiledScript/Project1.res new file mode 100644 index 0000000..3adc036 Binary files /dev/null and b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/LoadCompiledScript/Project1.res differ diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/LoadCompiledScript/Unit1.dfm b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/LoadCompiledScript/Unit1.dfm new file mode 100644 index 0000000..85bb875 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/LoadCompiledScript/Unit1.dfm @@ -0,0 +1,43 @@ +object Form1: TForm1 + Left = 192 + Top = 114 + Caption = 'Load compiled script demo' + ClientHeight = 207 + ClientWidth = 341 + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -14 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + OnCreate = FormCreate + PixelsPerInch = 120 + TextHeight = 16 + object Button1: TButton + Left = 49 + Top = 49 + Width = 238 + Height = 31 + Margins.Left = 4 + Margins.Top = 4 + Margins.Right = 4 + Margins.Bottom = 4 + Caption = 'Compile script. Save compile script.' + TabOrder = 0 + OnClick = Button1Click + end + object Button2: TButton + Left = 49 + Top = 118 + Width = 238 + Height = 31 + Margins.Left = 4 + Margins.Top = 4 + Margins.Right = 4 + Margins.Bottom = 4 + Caption = 'Load compiled script. Run script.' + TabOrder = 1 + OnClick = Button2Click + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/LoadCompiledScript/Unit1.pas b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/LoadCompiledScript/Unit1.pas new file mode 100644 index 0000000..16597b5 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/LoadCompiledScript/Unit1.pas @@ -0,0 +1,96 @@ +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, PaxCompiler, PaxInterpreter, PaxRegister, PaxBasicLanguage; +type + TForm1 = class(TForm) + Button1: TButton; + Button2: TButton; + procedure Button1Click(Sender: TObject); + procedure Button2Click(Sender: TObject); + procedure FormCreate(Sender: TObject); + private + H_ShowMessage: Integer; + H_S: Integer; + S: AnsiString; + { Private declarations } + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.dfm} + +procedure TForm1.Button1Click(Sender: TObject); +var + I: Integer; + PaxCompiler1: TPaxCompiler; + PaxBasicLanguage1: TPaxBasicLanguage; + PaxInterpreter1: TPaxInterpreter; +begin + PaxCompiler1 := TPaxCompiler.Create(nil); + PaxBasicLanguage1 := TPaxBasicLanguage.Create(nil); + PaxInterpreter1 := TPaxInterpreter.Create(nil); + + try + PaxCompiler1.RegisterLanguage(PaxBasicLanguage1); + + // register routine 'ShowMessage' + H_ShowMessage := PaxCompiler1.RegisterHeader(0, 'procedure ShowMessage(const Msg: string);'); + + // register variable 'S' + H_S := PaxCompiler1.RegisterVariable(0, 'S', _typeSTRING); + + PaxCompiler1.AddModule('1', PaxBasicLanguage1.LanguageName); + PaxCompiler1.AddCode('1', 'ShowMessage(S)'); + + if PaxCompiler1.Compile(PaxInterpreter1) then + begin + PaxInterpreter1.SaveToFile('1.bin'); + ShowMessage('Compiled script has been created!'); + end + else + for I:=0 to PaxCompiler1.ErrorCount - 1 do + ShowMessage(PaxCompiler1.ErrorMessage[I]); + finally + PaxCompiler1.Free; + PaxBasicLanguage1.Free; + PaxInterpreter1.Free; + end; +end; + +procedure TForm1.Button2Click(Sender: TObject); +var + PaxInterpreter1: TPaxInterpreter; +begin + if FileExists('1.bin') and (H_ShowMessage <> 0) and (H_S <> 0) then + begin + PaxInterpreter1 := TPaxInterpreter.Create(nil); + try + PaxInterpreter1.LoadFromFile('1.bin'); + PaxInterpreter1.SetAddress(H_ShowMessage, @ShowMessage); + PaxInterpreter1.SetAddress(H_S, @S); + PaxInterpreter1.Run; + finally + PaxInterpreter1.Free; + end; + end + else + ShowMessage('Press the first button to create compiled script.'); +end; + +procedure TForm1.FormCreate(Sender: TObject); +begin + H_ShowMessage := 0; + H_S := 0; + S := 'Hello'; +end; + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/OnUsedUnitEvent/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/OnUsedUnitEvent/Project1.dpr new file mode 100644 index 0000000..513a1dd --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/OnUsedUnitEvent/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/OnUsedUnitEvent/Project1.res b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/OnUsedUnitEvent/Project1.res new file mode 100644 index 0000000..3adc036 Binary files /dev/null and b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/OnUsedUnitEvent/Project1.res differ diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/OnUsedUnitEvent/Unit1.dfm b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/OnUsedUnitEvent/Unit1.dfm new file mode 100644 index 0000000..a7acfc1 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/OnUsedUnitEvent/Unit1.dfm @@ -0,0 +1,48 @@ +object Form1: TForm1 + Left = 192 + Top = 114 + Caption = 'OnUsedUnit event demo' + ClientHeight = 144 + ClientWidth = 385 + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -14 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + PixelsPerInch = 120 + TextHeight = 16 + object Button1: TButton + Left = 30 + Top = 30 + Width = 257 + Height = 30 + Margins.Left = 4 + Margins.Top = 4 + Margins.Right = 4 + Margins.Bottom = 4 + Caption = 'Compile and Run' + TabOrder = 0 + OnClick = Button1Click + end + object PaxCompiler1: TPaxCompiler + Alignment = 1 + OnUsedUnit = PaxCompiler1UsedUnit + DebugMode = False + Left = 24 + Top = 80 + end + object PaxBasicLanguage1: TPaxBasicLanguage + ExplicitOff = False + CompleteBooleanEval = False + UseFWArrays = True + Left = 176 + Top = 80 + end + object PaxInterpreter1: TPaxInterpreter + Console = False + Left = 264 + Top = 80 + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/OnUsedUnitEvent/Unit1.pas b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/OnUsedUnitEvent/Unit1.pas new file mode 100644 index 0000000..15337bc --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/OnUsedUnitEvent/Unit1.pas @@ -0,0 +1,68 @@ +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, + Dialogs, PaxInterpreter, PaxCompiler, PaxRegister, StdCtrls, PaxBasicLanguage, + PaxRunner; + +type + TForm1 = class(TForm) + Button1: TButton; + PaxCompiler1: TPaxCompiler; + PaxBasicLanguage1: TPaxBasicLanguage; + PaxInterpreter1: TPaxInterpreter; + procedure Button1Click(Sender: TObject); + function PaxCompiler1UsedUnit(Sender: TPaxCompiler; + const UnitName: String; var SourceCode: String): Boolean; + private + { Private declarations } + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.dfm} + +procedure TForm1.Button1Click(Sender: TObject); +begin + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxBasicLanguage1); + PaxCompiler1.AddModule('main', 'Basic'); + PaxCompiler1.AddCode('main', 'Imports SomeUnit'); + PaxCompiler1.AddCode('main', 'P()'); + if PaxCompiler1.Compile(PaxInterpreter1) then + begin + PaxInterpreter1.Run; + end + else + ShowMessage(PaxCompiler1.ErrorMessage[0]); +end; + +function TForm1.PaxCompiler1UsedUnit(Sender: TPaxCompiler; + const UnitName: String; var SourceCode: String): Boolean; +begin + if UnitName = 'SomeUnit' then + begin + result := true; + SourceCode := + + 'Module SomeUnit' + #13#10 + + ' Public Sub P' + #13#10 + + ' ShowMessage("Hello")' + #13#10 + + ' End Sub' + #13#10 + + 'End Module' + #13#10; + + end + else + result := false; // default processing +end; + +initialization + RegisterHeader(0, 'procedure ShowMessage(const Msg: string);', @ShowMessage); +end. diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/PCU/MyModule.txt b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/PCU/MyModule.txt new file mode 100644 index 0000000..336ed0a --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/PCU/MyModule.txt @@ -0,0 +1,31 @@ +Module MyModule + + Imports Controls, StdCtrls, Forms, Dialogs + + Class MyForm + Inherits TForm + + Published Button1 As TButton + + Sub Button1Click(Sender As TObject) + ShowMessage("Hello!") + End Sub + + Sub New + MyBase.Create(null) + Caption = "My form created in Basic" + Button1 = New TButton(Me) + With Button1 + .Parent = Me + .Caption = "Click Me" + .Name = "Button1" + .Left = 10 + .Top = 20 + .OnClick = Button1Click + End With + End Sub + + + End Class + +End Module \ No newline at end of file diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/PCU/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/PCU/Project1.dpr new file mode 100644 index 0000000..fae35f7 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/PCU/Project1.dpr @@ -0,0 +1,183 @@ +program Project2; +{$APPTYPE CONSOLE} +uses + sysutils, + Classes, + TypInfo, + PAXCOMP_CONSTANTS, + PaxCompiler, + PaxCompilerExplorer, + PaxCompilerDebugger, + PaxBasicLanguage, + PaxInterpreter, + PaxRegister, + IMPORT_Common; + +type + TMyHandler = class + private + L: TStringList; + public + constructor Create; + destructor Destroy; override; + procedure SaveToDisk; + function UsedUnitHandler(Sender: TPaxCompiler; const UnitName: String; + var SourceCode: String): Boolean; + function SavePCUCompilerHandler(Sender: TPaxCompiler; const UnitName: String): TStream; + function LoadPCUCompilerHandler(Sender: TPaxCompiler; const UnitName: String): TStream; + function LoadPCUProgramHandler(Sender: TPaxInterpreter; const UnitName: String): TStream; + end; + +constructor TMyHandler.Create; +begin + inherited; + L := TStringList.Create; +end; + +destructor TMyHandler.Destroy; +var + I: Integer; +begin + for I := 0 to L.Count - 1 do + L.Objects[I].Free; + + L.Free; + inherited; +end; + +procedure TMyHandler.SaveToDisk; +var + I: Integer; + Stream: TMemoryStream; + S: String; +begin + for I := 0 to L.Count - 1 do + begin + S := L[I]; + Stream := TMemoryStream(L.Objects[I]); + Stream.Position := 0; + Stream.SaveToFile(S + '.PCU'); + end; +end; + +function TMyHandler.UsedUnitHandler(Sender: TPaxCompiler; const UnitName: String; + var SourceCode: String): Boolean; +var + L: TStringList; +begin + if CompareText(UnitName, 'MyModule') = 0 then + begin + L := TStringList.Create; + try + L.LoadFromFile('MyModule.txt'); // just to load it from somewhere + SourceCode := L.Text; + finally + L.Free; + end; + result := true; + end; +end; + +function TMyHandler.SavePCUCompilerHandler(Sender: TPaxCompiler; const UnitName: String): TStream; +begin + result := TMemoryStream.Create; + L.AddObject(UnitName, result); +end; + +function TMyHandler.LoadPCUCompilerHandler(Sender: TPaxCompiler; const UnitName: String): TStream; +var + I: Integer; +begin + result := nil; + for I := 0 to L.Count - 1 do + if CompareText(L[I], UnitName) = 0 then + begin + result := TStream(L.Objects[I]); + result.Position := 0; + Exit; + end; +end; + +function TMyHandler.LoadPCUProgramHandler(Sender: TPaxInterpreter; const UnitName: String): TStream; +var + I: Integer; +begin + result := nil; + for I := 0 to L.Count - 1 do + if CompareText(L[I], UnitName) = 0 then + begin + result := TStream(L.Objects[I]); + result.Position := 0; + Exit; + end; +end; + +var + MyHandler: TMyHandler; + +var + PaxCompiler1: TPaxCompiler; + PaxInterpreter1: TPaxInterpreter; + PaxBasicLanguage1: TPaxBasicLanguage; +begin + // Build all units, save pcu-files and create compiled script + + MyHandler := TMyHandler.Create; + try + + PaxCompiler1 := TPaxCompiler.Create(nil); + PaxCompiler1.OnUsedUnit := MyHandler.UsedUnitHandler; +// PaxCompiler1.OnSavePCU := MyHandler.SavePCUCompilerHandler; +// PaxCompiler1.OnLoadPCU := MyHandler.LoadPCUCompilerHandler; + + PaxInterpreter1 := TPaxInterpreter.Create(nil); + PaxBasicLanguage1 := TPaxBasicLanguage.Create(nil); + try + PaxCompiler1.RegisterLanguage(PaxBasicLanguage1); + PaxCompiler1.AddModule('1', 'Basic'); + PaxCompiler1.AddCodeFromFile('1', 'script.txt'); + + if PaxCompiler1.Compile(PaxInterpreter1, true, true) then + // build with run-time packages + begin + PaxInterpreter1.SaveToFile('script.bin'); +// PaxInterpreter1.Run; +// writeln('Press any key...'); +// Readln; +// Exit; + end + else + begin + writeln(PaxCompiler1.ErrorMessage[0]); + writeln(PaxCompiler1.ErrorLine[0]); + writeln('Press any key...'); + Readln; + Exit; + end; + finally + PaxCompiler1.Free; + PaxInterpreter1.Free; + PaxBasicLanguage1.Free; + end; + +// MyHandler.SaveToDisk; + + // Use compiled units (pcu-files) at run-tme as run-time packages + + PaxInterpreter1 := TPaxInterpreter.Create(nil); + try +// PaxInterpreter1.OnLoadPCU := MyHandler.LoadPCUProgramHandler; + + PaxInterpreter1.LoadFromFile('script.bin'); + PaxInterpreter1.Run; + finally + PaxInterpreter1.Free; + end; + + finally + MyHandler.Free; + end; + + writeln('Press any key...'); + Readln; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/PCU/script.txt b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/PCU/script.txt new file mode 100644 index 0000000..b18e22b --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/PCU/script.txt @@ -0,0 +1,9 @@ +Imports Forms +Imports MyModule + +Dim F As MyForm = New MyForm +Try + F.ShowModal +Finally + F.Free +End Try \ No newline at end of file diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/RTTI/1/IMPORT_TypInfo.pas b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/RTTI/1/IMPORT_TypInfo.pas new file mode 100644 index 0000000..4767808 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/RTTI/1/IMPORT_TypInfo.pas @@ -0,0 +1,703 @@ +unit IMPORT_TypInfo; +interface + +procedure Register_TypInfo; + +implementation + +uses + Variants, + SysUtils, + TypInfo, + PaxRegister; +{ + Result := RegisterEnumType (H, 'TTypeKind'); + RegisterEnumValue (Result, 'tkUnknown', 0); + RegisterEnumValue (Result, 'tkInteger', 1); + RegisterEnumValue (Result, 'tkChar', 2); + RegisterEnumValue (Result, 'tkEnumeration', 3); + RegisterEnumValue (Result, 'tkFloat', 4); + RegisterEnumValue (Result, 'tkString', 5); + RegisterEnumValue (Result, 'tkSet', 6); + RegisterEnumValue (Result, 'tkClass', 7); + RegisterEnumValue (Result, 'tkMethod', 8); + RegisterEnumValue (Result, 'tkWChar', 9); + RegisterEnumValue (Result, 'tkLString', 10); + RegisterEnumValue (Result, 'tkWString', 11); + RegisterEnumValue (Result, 'tkVariant', 12); + RegisterEnumValue (Result, 'tkArray', 13); + RegisterEnumValue (Result, 'tkRecord', 14); + RegisterEnumValue (Result, 'tkInterface', 15); + RegisterEnumValue (Result, 'tkInt64', 16); + RegisterEnumValue (Result, 'tkDynArray', 17); +end; + +//==================================================================== +// TPublishableVariantType +//==================================================================== + + +//-------------------------------------------------------------------- +// RegisterClass_TPublishableVariantType +//-------------------------------------------------------------------- + +function RegisterClass_TPublishableVariantType (H: integer): integer; +begin + Result := RegisterClassType (H, TPublishableVariantType); + + RegisterHeader (Result, + 'function GetProperty (var Dest: TVarData; const V: TVarData; const Name: String): Boolean; override;', + @TPublishableVariantType.GetProperty); + RegisterHeader (Result, + 'function SetProperty (const V: TVarData; const Name: String; const Value: TVarData): Boolean; override;', + @TPublishableVariantType.SetProperty); +end; + +//-------------------------------------------------------------------- +// RegisterSet_TTypeKinds +//-------------------------------------------------------------------- + +function RegisterSet_TTypeKinds (H: integer): integer; +begin +// Result := RegisterSetType (H, 'TTypeKinds', T); +end; + +//-------------------------------------------------------------------- +// RegisterEnumerated_TOrdType +//-------------------------------------------------------------------- + +function RegisterEnumerated_TOrdType (H: integer): integer; +begin + Result := RegisterEnumType (H, 'TOrdType'); + RegisterEnumValue (Result, 'otSByte', 0); + RegisterEnumValue (Result, 'otUByte', 1); + RegisterEnumValue (Result, 'otSWord', 2); + RegisterEnumValue (Result, 'otUWord', 3); + RegisterEnumValue (Result, 'otSLong', 4); + RegisterEnumValue (Result, 'otULong', 5); +end; + +//-------------------------------------------------------------------- +// RegisterEnumerated_TFloatType +//-------------------------------------------------------------------- + +function RegisterEnumerated_TFloatType (H: integer): integer; +begin + Result := RegisterEnumType (H, 'TFloatType'); + RegisterEnumValue (Result, 'ftSingle', 0); + RegisterEnumValue (Result, 'ftDouble', 1); + RegisterEnumValue (Result, 'ftExtended', 2); + RegisterEnumValue (Result, 'ftComp', 3); + RegisterEnumValue (Result, 'ftCurr', 4); +end; + +//-------------------------------------------------------------------- +// RegisterEnumerated_TMethodKind +//-------------------------------------------------------------------- + +function RegisterEnumerated_TMethodKind (H: integer): integer; +begin + Result := RegisterEnumType (H, 'TMethodKind'); + RegisterEnumValue (Result, 'mkProcedure', 0); + RegisterEnumValue (Result, 'mkFunction', 1); + RegisterEnumValue (Result, 'mkConstructor', 2); + RegisterEnumValue (Result, 'mkDestructor', 3); + RegisterEnumValue (Result, 'mkClassProcedure', 4); + RegisterEnumValue (Result, 'mkClassFunction', 5); + RegisterEnumValue (Result, 'mkSafeProcedure', 6); + RegisterEnumValue (Result, 'mkSafeFunction', 7); +end; + +//-------------------------------------------------------------------- +// RegisterEnumerated_TParamFlag +//-------------------------------------------------------------------- + +function RegisterEnumerated_TParamFlag (H: integer): integer; +begin + Result := RegisterEnumType (H, 'TParamFlag'); + RegisterEnumValue (Result, 'pfVar', 0); + RegisterEnumValue (Result, 'pfConst', 1); + RegisterEnumValue (Result, 'pfArray', 2); + RegisterEnumValue (Result, 'pfAddress', 3); + RegisterEnumValue (Result, 'pfReference', 4); + RegisterEnumValue (Result, 'pfOut', 5); + Result := RegisterSetType (H, 'TParamFlags', T); +end; + +function RegisterSet_TParamFlagsBase (H: integer): integer; +var + T: integer; +begin + T := LookupTypeID ('TParamFlag'); + if T = 0 then + Raise ENNPaxFormater.Create ('Invalid type name: TParamFlag'); + Result := RegisterSetType (H, 'TParamFlagsBase', T); +end; + +//-------------------------------------------------------------------- +// RegisterEnumerated_TIntfFlag +//-------------------------------------------------------------------- + +function RegisterEnumerated_TIntfFlag (H: integer): integer; +begin + Result := RegisterEnumType (H, 'TIntfFlag'); + RegisterEnumValue (Result, 'ifHasGuid', 0); + RegisterEnumValue (Result, 'ifDispInterface', 1); + RegisterEnumValue (Result, 'ifDispatch', 2); +end; + +//-------------------------------------------------------------------- +// RegisterSet_TIntfFlags +//-------------------------------------------------------------------- + +function RegisterSet_TIntfFlags (H: integer): integer; +var + T: integer; +begin + T := LookupTypeID ('TIntfFlag'); + if T = 0 then + Raise ENNPaxFormater.Create ('Invalid type name: TIntfFlag'); + Result := RegisterSetType (H, 'TIntfFlags', T); +end; + +//-------------------------------------------------------------------- +// RegisterSet_TIntfFlagsBase +//-------------------------------------------------------------------- + +function RegisterSet_TIntfFlagsBase (H: integer): integer; +var + T: integer; +begin + T := LookupTypeID ('TIntfFlag'); + if T = 0 then + Raise ENNPaxFormater.Create ('Invalid type name: TIntfFlag'); + Result := RegisterSetType (H, 'TIntfFlagsBase', T); +end; + +//-------------------------------------------------------------------- +// RegisterPointer_PPTypeInfo +//-------------------------------------------------------------------- + +function RegisterPointer_PPTypeInfo (H: integer): integer; +var + T: Integer; +begin + T := LookupTypeID ('PTypeInfo'); + if T = 0 then + T := RegisterSomeType (H, 'PTypeInfo'); + Result := RegisterPointerType (H, 'PPTypeInfo', T); +end; + +//-------------------------------------------------------------------- +// RegisterPointer_PTypeInfo +//-------------------------------------------------------------------- + +function RegisterPointer_PTypeInfo (H: integer): integer; +var + T: Integer; +begin + T := LookupTypeID ('TTypeInfo'); + if T = 0 then + T := RegisterSomeType (H, 'TTypeInfo'); + Result := RegisterPointerType (H, 'PTypeInfo', T); +end; + +//-------------------------------------------------------------------- +// RegisterRecord_TTypeInfo +//-------------------------------------------------------------------- + +function RegisterRecord_TTypeInfo (H: integer): integer; +var + T: integer; +begin + Result := RegisterRecordType (H, 'TTypeInfo', False); + T := LookupTypeID ('TTypeKind'); + if T = 0 then + Raise ENNPaxFormater.Create ('Invalid type name: TTypeKind'); + RegisterRecordTypeField (Result, 'Kind', T, 0); + T := _typeSHORTSTRING; + RegisterRecordTypeField (Result, 'Name', T, 0); +end; + +//-------------------------------------------------------------------- +// RegisterPointer_PTypeData +//-------------------------------------------------------------------- + +function RegisterPointer_PTypeData (H: integer): integer; +var + T: Integer; +begin + T := LookupTypeID ('TTypeData'); + if T = 0 then + T := RegisterSomeType (H, 'TTypeData'); + Result := RegisterPointerType (H, 'PTypeData', T); +end; + +//-------------------------------------------------------------------- +// RegisterArray_fake_ParamList_18 +//-------------------------------------------------------------------- + +function RegisterArray_fake_ParamList_18 (H: integer): integer; +var + R,T: integer; +begin + R := RegisterTypeDeclaration (H, 'fake_ParamList_18_19 = 0..1023;'); + T := _typeCHAR; + Result := RegisterArrayType (H, 'fake_ParamList_18', R, T, False); +end; + +//-------------------------------------------------------------------- +// RegisterRecord_TTypeData +//-------------------------------------------------------------------- + +function RegisterRecord_TTypeData (H: integer): integer; +var + T: integer; +begin + Result := RegisterRecordType (H, 'TTypeData', False); + T := LookupTypeID ('TOrdType'); + if T = 0 then + Raise ENNPaxFormater.Create ('Invalid type name: TOrdType'); + RegisterVariantRecordTypeField (Result, 'OrdType', T, 02); + T := _typeINTEGER; + RegisterVariantRecordTypeField (Result, 'MinValue', T, 0102); + T := _typeINTEGER; + RegisterVariantRecordTypeField (Result, 'MaxValue', T, 0102); + T := LookupTypeID ('PPTypeInfo'); + if T = 0 then + Raise ENNPaxFormater.Create ('Invalid type name: PPTypeInfo'); + RegisterVariantRecordTypeField (Result, 'BaseType', T, 020102); + T := LookupTypeID ('ShortStringBase'); + if T = 0 then + Raise ENNPaxFormater.Create ('Invalid type name: ShortStringBase'); + RegisterVariantRecordTypeField (Result, 'NameList', T, 020102); + T := LookupTypeID ('ShortStringBase'); + if T = 0 then + Raise ENNPaxFormater.Create ('Invalid type name: ShortStringBase'); + RegisterVariantRecordTypeField (Result, 'EnumUnitName', T, 020102); + T := LookupTypeID ('PPTypeInfo'); + if T = 0 then + Raise ENNPaxFormater.Create ('Invalid type name: PPTypeInfo'); + RegisterVariantRecordTypeField (Result, 'CompType', T, 0202); + T := LookupTypeID ('TFloatType'); + if T = 0 then + Raise ENNPaxFormater.Create ('Invalid type name: TFloatType'); + RegisterVariantRecordTypeField (Result, 'FloatType', T, 03); + T := _typeBYTE; + RegisterVariantRecordTypeField (Result, 'MaxLength', T, 04); + T := LookupTypeID ('TClass'); + if T = 0 then + Raise ENNPaxFormater.Create ('Invalid type name: TClass'); + RegisterVariantRecordTypeField (Result, 'ClassType', T, 05); + T := LookupTypeID ('PPTypeInfo'); + if T = 0 then + Raise ENNPaxFormater.Create ('Invalid type name: PPTypeInfo'); + RegisterVariantRecordTypeField (Result, 'ParentInfo', T, 05); + T := _typeSMALLINT; + RegisterVariantRecordTypeField (Result, 'PropCount', T, 05); + T := LookupTypeID ('ShortStringBase'); + if T = 0 then + Raise ENNPaxFormater.Create ('Invalid type name: ShortStringBase'); + RegisterVariantRecordTypeField (Result, 'UnitName', T, 05); + T := LookupTypeID ('TMethodKind'); + if T = 0 then + Raise ENNPaxFormater.Create ('Invalid type name: TMethodKind'); + RegisterVariantRecordTypeField (Result, 'MethodKind', T, 06); + T := _typeBYTE; + RegisterVariantRecordTypeField (Result, 'ParamCount', T, 06); + T := RegisterArray_fake_ParamList_18 (H); + RegisterVariantRecordTypeField (Result, 'ParamList', T, 06); + T := LookupTypeID ('PPTypeInfo'); + if T = 0 then + Raise ENNPaxFormater.Create ('Invalid type name: PPTypeInfo'); + RegisterVariantRecordTypeField (Result, 'IntfParent', T, 07); + T := LookupTypeID ('TIntfFlagsBase'); + if T = 0 then + Raise ENNPaxFormater.Create ('Invalid type name: TIntfFlagsBase'); + RegisterVariantRecordTypeField (Result, 'IntfFlags', T, 07); + T := LookupTypeID ('TGUID'); + if T = 0 then + Raise ENNPaxFormater.Create ('Invalid type name: TGUID'); + RegisterVariantRecordTypeField (Result, 'Guid', T, 07); + T := LookupTypeID ('ShortStringBase'); + if T = 0 then + Raise ENNPaxFormater.Create ('Invalid type name: ShortStringBase'); + RegisterVariantRecordTypeField (Result, 'IntfUnit', T, 07); + T := _typeINT64; + RegisterVariantRecordTypeField (Result, 'MinInt64Value', T, 08); + RegisterVariantRecordTypeField (Result, 'MaxInt64Value', T, 08); + T := _typeINTEGER; + RegisterVariantRecordTypeField (Result, 'elSize', T, 09); + T := LookupTypeID ('PPTypeInfo'); + if T = 0 then + Raise ENNPaxFormater.Create ('Invalid type name: PPTypeInfo'); + RegisterVariantRecordTypeField (Result, 'elType', T, 09); + T := _typeINTEGER; + RegisterVariantRecordTypeField (Result, 'varType', T, 09); + T := LookupTypeID ('PPTypeInfo'); + if T = 0 then + Raise ENNPaxFormater.Create ('Invalid type name: PPTypeInfo'); + RegisterVariantRecordTypeField (Result, 'elType2', T, 09); + T := LookupTypeID ('ShortStringBase'); + if T = 0 then + Raise ENNPaxFormater.Create ('Invalid type name: ShortStringBase'); + RegisterVariantRecordTypeField (Result, 'DynUnitName', T, 09); +end; + +//-------------------------------------------------------------------- +// RegisterRecord_fake_PropList_31 +//-------------------------------------------------------------------- + +function RegisterRecord_fake_PropList_31 (H: integer): integer; +var + T: integer; +begin + Result := RegisterRecordType (H, 'fake_PropList_31', False); +end; + +//-------------------------------------------------------------------- +// RegisterRecord_TPropData +//-------------------------------------------------------------------- + +function RegisterRecord_TPropData (H: integer): integer; +var + T: integer; +begin + Result := RegisterRecordType (H, 'TPropData', False); + T := _typeWORD; + RegisterRecordTypeField (Result, 'PropCount', T, 0); + T := RegisterRecord_fake_PropList_31 (H); + RegisterRecordTypeField (Result, 'PropList', T, 0); +end; + +//-------------------------------------------------------------------- +// RegisterPointer_PPropInfo +//-------------------------------------------------------------------- + +function RegisterPointer_PPropInfo (H: integer): integer; +var + T: Integer; +begin + T := LookupTypeID ('TPropInfo'); + if T = 0 then + T := RegisterSomeType (H, 'TPropInfo'); + Result := RegisterPointerType (H, 'PPropInfo', T); +end; + +//-------------------------------------------------------------------- +// RegisterRecord_TPropInfo +//-------------------------------------------------------------------- + +function RegisterRecord_TPropInfo (H: integer): integer; +var + T: integer; +begin + Result := RegisterRecordType (H, 'TPropInfo', False); + T := LookupTypeID ('PPTypeInfo'); + if T = 0 then + Raise ENNPaxFormater.Create ('Invalid type name: PPTypeInfo'); + RegisterRecordTypeField (Result, 'PropType', T, 0); + T := _typePOINTER; + RegisterRecordTypeField (Result, 'GetProc', T, 0); + T := _typePOINTER; + RegisterRecordTypeField (Result, 'SetProc', T, 0); + T := _typePOINTER; + RegisterRecordTypeField (Result, 'StoredProc', T, 0); + T := _typeINTEGER; + RegisterRecordTypeField (Result, 'Index', T, 0); + T := _typeINTEGER; + RegisterRecordTypeField (Result, 'Default', T, 0); + T := _typeSMALLINT; + RegisterRecordTypeField (Result, 'NameIndex', T, 0); + T := _typeSHORTSTRING; + RegisterRecordTypeField (Result, 'Name', T, 0); +end; + +//-------------------------------------------------------------------- +// RegisterProcedural_TPropInfoProc +//-------------------------------------------------------------------- + +function RegisterProcedural_TPropInfoProc (H: integer): integer; +begin + Result := RegisterHeader (H, 'procedure fake_TPropInfoProc_40 (PropInfo: PPropInfo);', Nil); + Result := RegisterEventType (H, 'TPropInfoProc', Result); +end; + +//-------------------------------------------------------------------- +// RegisterPointer_PPropList +//-------------------------------------------------------------------- + +function RegisterPointer_PPropList (H: integer): integer; +var + T: Integer; +begin + T := LookupTypeID ('TPropList'); + if T = 0 then + T := RegisterSomeType (H, 'TPropList'); + Result := RegisterPointerType (H, 'PPropList', T); +end; + +//-------------------------------------------------------------------- +// RegisterArray_TPropList +//-------------------------------------------------------------------- + +function RegisterArray_TPropList (H: integer): integer; +var + R,T: integer; +begin + R := RegisterTypeDeclaration (H, 'fake_TPropList_41 = 0..16379;'); + T := LookupTypeID ('PPropInfo'); + if T = 0 then + Raise ENNPaxFormater.Create ('Invalid type name: PPropInfo'); + Result := RegisterArrayType (H, 'TPropList', R, T, False); +end; + +//==================================================================== +// EPropertyError +//==================================================================== + + +//-------------------------------------------------------------------- +// RegisterClass_EPropertyError +//-------------------------------------------------------------------- + +function RegisterClass_EPropertyError (H: integer): integer; +begin + Result := RegisterClassType (H, EPropertyError); + +end; + +//==================================================================== +// EPropertyConvertError +//==================================================================== + + +//-------------------------------------------------------------------- +// RegisterClass_EPropertyConvertError +//-------------------------------------------------------------------- + +function RegisterClass_EPropertyConvertError (H: integer): integer; +begin + Result := RegisterClassType (H, EPropertyConvertError); + +end; + +//-------------------------------------------------------------------- +// RegisterArray_fake_BooleanIdents_42 +//-------------------------------------------------------------------- + +function RegisterArray_fake_BooleanIdents_42 (H: integer): integer; +var + R,T: integer; +begin + R := _typeBOOLEAN; + T := RegisterTypeAlias (H, 'BooleanIdents', _typeSTRING); + Result := RegisterArrayType (H, 'fake_BooleanIdents_42', R, T, False); +end; + +//-------------------------------------------------------------------- +// DoRegisterVariable_BooleanIdents +//-------------------------------------------------------------------- + +function DoRegisterVariable_BooleanIdents (H: Integer): integer; +var + T: integer; +begin + T := RegisterArray_fake_BooleanIdents_42 (H); + result := RegisterVariable (H, 'BooleanIdents', T, @BooleanIdents); +end; + + +//-------------------------------------------------------------------- +// RegisterNameSpace_TypInfo +//-------------------------------------------------------------------- + +procedure RegisterNameSpace_TypInfo; +begin + RegisterNameSpace (0, 'TypInfo'); +end; + + +//-------------------------------------------------------------------- +// Register_TypInfo +//-------------------------------------------------------------------- +} +procedure Register_TypInfo; +var + H, G, A: integer; +begin + H := RegisterNamespace(0, 'TypInfo'); + RegisterRTTIType(H, TypeInfo(TTypeKind)); + RegisterRTTIType(H, TypeInfo(TTypeKinds)); + RegisterRTTIType(H, TypeInfo(TOrdType)); + RegisterRTTIType(H, TypeInfo(TFloatType)); + RegisterRTTIType(H, TypeInfo(TMethodKind)); + RegisterRTTIType(H, TypeInfo(TParamFlag)); + RegisterRTTIType(H, TypeInfo(TParamFlags)); + RegisterRTTIType(H, TypeInfo(TParamFlagsBase)); + RegisterRTTIType(H, TypeInfo(TIntfFlag)); + RegisterRTTIType(H, TypeInfo(TIntfFlags)); + RegisterRTTIType(H, TypeInfo(TIntfFlagsBase)); + + G := RegisterRecordType(H, 'TTypeInfo'); + RegisterRecordTypeField(G, 'Kind', RegisterRTTIType(H, TypeInfo(TTypeKind))); + RegisterRecordTypeField(G, 'Name', _typeSHORTSTRING); + G := RegisterPointerType(H, 'PTypeInfo', G); + G := RegisterPointerType(H, 'PPTypeInfo', G); + + G := RegisterRecordType(H, 'TPropInfo'); + RegisterRecordTypeField(G, 'PropType: PPtypeInfo', 0); + RegisterRecordTypeField(G, 'GetProc', _typePOINTER); + RegisterRecordTypeField(G, 'SetProc', _typePOINTER); + RegisterRecordTypeField(G, 'StoredProc', _typePOINTER); + RegisterRecordTypeField(G, 'Index', _typeINTEGER); + RegisterRecordTypeField(G, 'Default', _typeINTEGER); + RegisterRecordTypeField(G, 'NameIndex', _typeSMALLINT); + RegisterRecordTypeField(G, 'Name', _typeSHORTSTRING); + RegisterPointerType(H, 'PPropInfo', G); + + G := RegisterRecordType(H, 'TPropData'); + RegisterRecordTypeField(G, 'PropCount: Word;', 0); + + A := RegisterArrayType(0, '', RegisterSubrangeType(0, '', _typeINTEGER, 0, 1023), _typeANSICHAR); + + G := RegisterRecordType (H, 'TTypeData', False); + RegisterVariantRecordTypeField(G, 'OrdType: TOrdType', 02); + RegisterVariantRecordTypeField(G, 'MinValue', _typeINTEGER, 0102); + RegisterVariantRecordTypeField(G, 'MaxValue', _typeINTEGER, 0102); + RegisterVariantRecordTypeField(G, 'BaseType: PPTypeInfo', 020102); + RegisterVariantRecordTypeField(G, 'NameList: ShortString', 020102); + RegisterVariantRecordTypeField(G, 'EnumUnitName: ShortString', 020102); + RegisterVariantRecordTypeField(G, 'CompType: PPTypeInfo', 0202); + RegisterVariantRecordTypeField(G, 'FloatType: TFloatType', 03); + RegisterVariantRecordTypeField(G, 'MaxLength', _typeBYTE, 04); + RegisterVariantRecordTypeField(G, 'ClassType: TClass', 05); + RegisterVariantRecordTypeField(G, 'ParentInfo: PPTypeInfo', 05); + RegisterVariantRecordTypeField(G, 'PropCount', _typeSMALLINT, 05); + RegisterVariantRecordTypeField(G, 'UnitName', _typeSHORTSTRING, 05); + RegisterVariantRecordTypeField(G, 'MethodKind: TMethodKind', 06); + RegisterVariantRecordTypeField(G, 'ParamCount', _typeBYTE, 06); + + + RegisterVariantRecordTypeField(G, 'ParamList', A, 06); + RegisterVariantRecordTypeField(G, 'IntfParent: PPTypeInfo', 07); + RegisterVariantRecordTypeField(G, 'IntfFlags: TIntfFlagsBase', 07); + RegisterVariantRecordTypeField(G, 'Guid: TGUID', 07); + RegisterVariantRecordTypeField(G, 'IntfUnit', _typeSHORTSTRING, 07); + RegisterVariantRecordTypeField(G, 'MinInt64Value', _typeINT64, 08); + RegisterVariantRecordTypeField(G, 'MaxInt64Value', _typeINT64, 08); + RegisterVariantRecordTypeField(G, 'elSize', _typeINTEGER, 09); + RegisterVariantRecordTypeField(G, 'elType: PPTypeInfo', 09); + RegisterVariantRecordTypeField(G, 'varType', _typeINTEGER, 09); + RegisterVariantRecordTypeField(G, 'elType2: PPTypeInfo', 09); + RegisterVariantRecordTypeField(G, 'DynUnitName', _typeSHORTSTRING, 09); + + RegisterHeader (H, 'function PropType (Instance: TObject; const PropName: String): TTypeKind; overload;', Nil); + RegisterHeader (H, 'function PropType (AClass: TClass; const PropName: String): TTypeKind; overload;', Nil); + RegisterHeader (H, 'function PropIsType (Instance: TObject; const PropName: String; TypeKind: TTypeKind): Boolean; overload;' + , Nil); + RegisterHeader (H, 'function PropIsType (AClass: TClass; const PropName: String; TypeKind: TTypeKind): Boolean; overload;', + Nil); + RegisterHeader (H, 'function IsStoredProp (Instance: TObject; const PropName: String): Boolean; overload;', Nil); + RegisterHeader (H, 'function IsPublishedProp (Instance: TObject; const PropName: String): Boolean; overload;', Nil); + RegisterHeader (H, 'function IsPublishedProp (AClass: TClass; const PropName: String): Boolean; overload;', Nil); + RegisterHeader (H, 'function GetOrdProp (Instance: TObject; const PropName: String): Longint; overload;', Nil); + RegisterHeader (H, 'procedure SetOrdProp (Instance: TObject; const PropName: String; Value: Longint); overload;', Nil); + RegisterHeader (H, 'function GetEnumProp (Instance: TObject; const PropName: String): String; overload;', Nil); + RegisterHeader (H, 'procedure SetEnumProp (Instance: TObject; const PropName: String; const Value: String); overload;', Nil); + RegisterHeader (H, 'function GetSetProp (Instance: TObject; const PropName: String; Brackets: Boolean = False): String; ' + + 'overload;', Nil); + RegisterHeader (H, 'procedure SetSetProp (Instance: TObject; const PropName: String; const Value: String); overload;', Nil); + RegisterHeader (H, 'function GetObjectProp (Instance: TObject; const PropName: String; MinClass: TClass = nil): TObject; ' + + 'overload;', Nil); + RegisterHeader (H, 'procedure SetObjectProp (Instance: TObject; const PropName: String; Value: TObject); overload;', Nil); + RegisterHeader (H, 'function GetObjectPropClass (Instance: TObject; const PropName: String): TClass; overload;', Nil); + RegisterHeader (H, 'function GetStrProp (Instance: TObject; const PropName: String): String; overload;', Nil); + RegisterHeader (H, 'procedure SetStrProp (Instance: TObject; const PropName: String; const Value: String); overload;', Nil); + RegisterHeader (H, 'function GetWideStrProp (Instance: TObject; const PropName: String): WideString; overload;', Nil); + RegisterHeader (H, 'procedure SetWideStrProp (Instance: TObject; const PropName: String; const Value: WideString); overload;' + , Nil); + RegisterHeader (H, 'function GetFloatProp (Instance: TObject; const PropName: String): Extended; overload;', Nil); + RegisterHeader (H, 'procedure SetFloatProp (Instance: TObject; const PropName: String; const Value: Extended); overload;', + Nil); + RegisterHeader (H, 'function GetVariantProp (Instance: TObject; const PropName: String): Variant; overload;', Nil); + RegisterHeader (H, 'procedure SetVariantProp (Instance: TObject; const PropName: String; const Value: Variant); overload;', + Nil); + RegisterHeader (H, 'function GetMethodProp (Instance: TObject; const PropName: String): TMethod; overload;', Nil); + RegisterHeader (H, 'procedure SetMethodProp (Instance: TObject; const PropName: String; const Value: TMethod); overload;', + Nil); + RegisterHeader (H, 'function GetInt64Prop (Instance: TObject; const PropName: String): Int64; overload;', Nil); + RegisterHeader (H, 'procedure SetInt64Prop (Instance: TObject; const PropName: String; const Value: Int64); overload;', Nil); + RegisterHeader (H, 'function GetInterfaceProp (Instance: TObject; const PropName: String): IInterface; overload;', Nil); + RegisterHeader (H, 'procedure SetInterfaceProp (Instance: TObject; const PropName: String; const Value: IInterface); overload;' + + '', Nil); + RegisterHeader (H, 'function GetPropValue (Instance: TObject; const PropName: String; PreferStrings: Boolean = True): Variant;' + + '', Nil); + RegisterHeader (H, 'procedure SetPropValue (Instance: TObject; const PropName: String; const Value: Variant);', Nil); + RegisterHeader (H, 'procedure FreeAndNilProperties (AObject: TObject);', Nil); + + G := RegisterClassType(H, TPublishableVariantType); + RegisterHeader(G, + 'function GetProperty (var Dest: TVarData; const V: TVarData; const Name: String): Boolean; override;', + @TPublishableVariantType.GetProperty); + RegisterHeader (G, + 'function SetProperty (const V: TVarData; const Name: String; const Value: TVarData): Boolean; override;', + @TPublishableVariantType.SetProperty); + + RegisterConstant (H, 'tkAny = [Low(TTypeKind)..High(TTypeKind)];'); + RegisterConstant (H, 'tkMethods = [tkMethod];'); + RegisterConstant (H, 'tkProperties = tkAny - tkMethods - [tkUnknown];'); + RegisterTypeDeclaration (H, 'ShortStringBase = String [255];'); + RegisterHeader (H, 'function GetTypeData (TypeInfo: PTypeInfo): PTypeData;', Nil); + RegisterHeader (H, 'function GetEnumName (TypeInfo: PTypeInfo; Value: Integer): String;', Nil); + RegisterHeader (H, 'function GetEnumValue (TypeInfo: PTypeInfo; const Name: String): Integer;', Nil); + RegisterHeader (H, 'function GetPropInfo (Instance: TObject; const PropName: String; AKinds: TTypeKinds = []): PPropInfo; ' + + 'overload;', Nil); + RegisterHeader (H, 'function GetPropInfo (AClass: TClass; const PropName: String; AKinds: TTypeKinds = []): PPropInfo; ' + + 'overload;', Nil); + RegisterHeader (H, 'function GetPropInfo (TypeInfo: PTypeInfo; const PropName: String): PPropInfo; overload;', Nil); + RegisterHeader (H, 'function GetPropInfo (TypeInfo: PTypeInfo; const PropName: String; AKinds: TTypeKinds): PPropInfo; ' + + 'overload;', Nil); + RegisterHeader (H, 'procedure GetPropInfos (TypeInfo: PTypeInfo; PropList: PPropList);', Nil); + RegisterHeader (H, 'function GetPropList (TypeInfo: PTypeInfo; TypeKinds: TTypeKinds; PropList: PPropList; SortList: Boolean ' + + '= True): Integer; overload;', Nil); + RegisterHeader (H, 'function GetPropList (TypeInfo: PTypeInfo; out PropList: PPropList): Integer; overload;', Nil); + RegisterHeader (H, 'function GetPropList (AObject: TObject; out PropList: PPropList): Integer; overload;', Nil); + RegisterHeader (H, 'procedure SortPropList (PropList: PPropList; PropCount: Integer);', Nil); + RegisterHeader (H, 'function IsStoredProp (Instance: TObject; PropInfo: PPropInfo): Boolean; overload;', Nil); + RegisterHeader (H, 'function GetOrdProp (Instance: TObject; PropInfo: PPropInfo): Longint; overload;', Nil); + RegisterHeader (H, 'procedure SetOrdProp (Instance: TObject; PropInfo: PPropInfo; Value: Longint); overload;', Nil); + RegisterHeader (H, 'function GetEnumProp (Instance: TObject; PropInfo: PPropInfo): String; overload;', Nil); + RegisterHeader (H, 'procedure SetEnumProp (Instance: TObject; PropInfo: PPropInfo; const Value: String); overload;', Nil); + RegisterHeader (H, 'function GetSetProp (Instance: TObject; PropInfo: PPropInfo; Brackets: Boolean = False): String; overload;' + + '', Nil); + RegisterHeader (H, 'procedure SetSetProp (Instance: TObject; PropInfo: PPropInfo; const Value: String); overload;', Nil); + RegisterHeader (H, 'function GetObjectProp (Instance: TObject; PropInfo: PPropInfo; MinClass: TClass = nil): TObject; ' + + 'overload;', Nil); + RegisterHeader (H, 'procedure SetObjectProp (Instance: TObject; PropInfo: PPropInfo; Value: TObject; ValidateClass: Boolean = ' + + 'True); overload;', Nil); + RegisterHeader (H, 'function GetObjectPropClass (Instance: TObject; PropInfo: PPropInfo): TClass; overload;', Nil); + RegisterHeader (H, 'function GetObjectPropClass (PropInfo: PPropInfo): TClass; overload;', Nil); + RegisterHeader (H, 'function GetStrProp (Instance: TObject; PropInfo: PPropInfo): String; overload;', Nil); + RegisterHeader (H, 'procedure SetStrProp (Instance: TObject; PropInfo: PPropInfo; const Value: String); overload;', Nil); + RegisterHeader (H, 'function GetWideStrProp (Instance: TObject; PropInfo: PPropInfo): WideString; overload;', Nil); + RegisterHeader (H, 'procedure SetWideStrProp (Instance: TObject; PropInfo: PPropInfo; const Value: WideString); overload;', + Nil); + RegisterHeader (H, 'function GetFloatProp (Instance: TObject; PropInfo: PPropInfo): Extended; overload;', Nil); + RegisterHeader (H, 'procedure SetFloatProp (Instance: TObject; PropInfo: PPropInfo; const Value: Extended); overload;', Nil); + RegisterHeader (H, 'function GetVariantProp (Instance: TObject; PropInfo: PPropInfo): Variant; overload;', Nil); + RegisterHeader (H, 'procedure SetVariantProp (Instance: TObject; PropInfo: PPropInfo; const Value: Variant); overload;', Nil); + + RegisterHeader (H, 'function GetMethodProp (Instance: TObject; PropInfo: PPropInfo): TMethod; overload;', Nil); + RegisterHeader (H, 'procedure SetMethodProp (Instance: TObject; PropInfo: PPropInfo; const Value: TMethod); overload;', Nil); + RegisterHeader (H, 'function GetInt64Prop (Instance: TObject; PropInfo: PPropInfo): Int64; overload;', Nil); + RegisterHeader (H, 'procedure SetInt64Prop (Instance: TObject; PropInfo: PPropInfo; const Value: Int64); overload;', Nil); + RegisterHeader (H, 'function GetInterfaceProp (Instance: TObject; PropInfo: PPropInfo): IInterface; overload;', Nil); + RegisterHeader (H, 'procedure SetInterfaceProp (Instance: TObject; PropInfo: PPropInfo; const Value: IInterface); overload;', + Nil); + RegisterVariable (H, 'DotSep:String;', @DotSep); + RegisterHeader (H, 'function SetToString (PropInfo: PPropInfo; Value: Integer; Brackets: Boolean = False): String;', Nil); + RegisterHeader (H, 'function StringToSet (PropInfo: PPropInfo; const Value: String): Integer;', Nil); +end; + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/RTTI/1/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/RTTI/1/Project1.dpr new file mode 100644 index 0000000..824ff4f --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/RTTI/1/Project1.dpr @@ -0,0 +1,187 @@ +{$APPTYPE CONSOLE} +{$O-} +program Project1; +uses + PAXCOMP_CONSTANTS, + PAXCOMP_SYS, + TypInfo, + Classes, + SysUtils, + IMPORT_Classes, + PaxCompiler, + PaxInterpreter, + PaxRegister, + PaxBasicLanguage, + IMPORT_TypInfo in 'IMPORT_TypInfo.pas'; + +type + TTestClass = class + procedure DoTest; + procedure OnClickHandler(Sender: TObject); + procedure OnClickHandler2(Sender: TObject); + end; + +var + PaxInterpreter1: TPaxInterpreter; + +procedure TTestClass.OnClickHandler(Sender: TObject); +begin + writeln('Click'); +end; + +procedure TTestClass.OnClickHandler2(Sender: TObject); +begin + writeln('Click 2'); +end; + + +procedure TTestClass.DoTest; +var + C: TClass; + P: Pointer; + pti: PTypeInfo; + ptd: PTypeData; + ppi: PPropInfo; + I: Integer; + Z, X: TObject; + S: String; + AMethod: TMethod; +begin + AMethod.Code := @ TTestClass.OnClickHandler; + AMethod.Data := Self; + + P := PaxInterpreter1.GetAddress('AMyClass'); + C := TClass(P^); + writeln(C.ClassName); + pti := C.ClassInfo; + writeln(pti^.Name); + + ptd := GetTypeData(pti); + writeln(ptd^.ClassType.ClassName); + pti := ptd^.ParentInfo^; + writeln(pti^.Name); + writeln(ptd^.PropCount); + writeln(ptd^.UnitName); + + ppi := GetPropInfo(C, 'X'); + writeln(ppi^.Name); + + pti := PaxInterpreter1.GetTypeInfo('IUnknown'); + writeln(pti^.Name); + ptd := GetTypeData(pti); + writeln(ptd^.IntfUnit); + + pti := PaxInterpreter1.GetTypeInfo('MyEnum'); + writeln(pti^.Name); + ptd := GetTypeData(pti); + writeln(ptd^.BaseType^.Name); +// writeln(ptd^.EnumUnitName); + writeln(GetEnumName(pti, 2)); + writeln(GetEnumValue(pti, 'three')); + + pti := PaxInterpreter1.GetTypeInfo('Integer'); + writeln(pti^.Name); + + // work with instance + + P := PaxInterpreter1.GetAddress('Z'); + Z := TObject(P^); + writeln(Z.ClassName); + SetOrdProp(Z, 'X', 5); + I := GetOrdProp(Z, 'X'); + writeln(I); + + SetStrProp(Z, 'Y', 'abc'); + S := GetStrProp(Z, 'Y'); + writeln(S); + + ppi := GetPropInfo(Z, 'Inter'); + writeln(ppi^.Name); + + P := Z.MethodAddress('MyProc'); + asm + mov eax, z + mov edx, 10 + mov ecx, 20 + call P; + end; + + P := Z.FieldAddress('Field2'); + X := TObject(P^); + writeln(X.ClassName); + + SetMethodProp(Z, 'OnClick', AMethod); + AMethod := GetMethodProp(Z, 'OnClick'); + + asm + call AMethod.Code; + end; + + // RTTI of inherited class: + + P := PaxInterpreter1.GetAddress('AMyClass2'); + C := TClass(P^); + writeln(C.ClassName); + pti := C.ClassInfo; + writeln(pti^.Name); + + ppi := GetPropInfo(C, 'X'); + writeln(ppi^.Name); + + // work with instance + P := PaxInterpreter1.GetAddress('W'); + Z := TObject(P^); + writeln(Z.ClassName); + SetOrdProp(Z, 'X', 7); + I := GetOrdProp(Z, 'X'); + writeln(I); + + P := Z.MethodAddress('MyProc'); + asm + mov eax, Z + mov edx, 2 + mov edx, 3 + call P + end; + + P := Z.FieldAddress('Field2'); + X := TObject(P^); + writeln(X.ClassName); +end; + +var + PaxCompiler1: TPaxCompiler; + PaxBasicLanguage1: TPaxBasicLanguage; + H: Integer; +begin + Register_Classes; + Register_TypInfo; + RegisterRTTIType(0, TypeInfo(TNotifyEvent)); + + H := RegisterClassType(0, TTestClass); + RegisterHeader(H, 'procedure DoTest;', + @TTestClass.DoTest); + RegisterHeader(H, 'procedure OnClickHandler2(Sender: TObject);', + @TTestClass.OnClickHandler2); + + PaxCompiler1 := TPaxCompiler.Create(nil); + PaxInterpreter1 := TPaxInterpreter.Create(nil); + PaxBasicLanguage1 := TPaxBasicLanguage.Create(nil); + try + PaxCompiler1.RegisterLanguage(PaxBasicLanguage1); + PaxCompiler1.AddModule('1', 'Basic'); + PaxCompiler1.AddCodeFromFile('1', 'script.txt'); + if PaxCompiler1.Compile(PaxInterpreter1) then + begin + PaxInterpreter1.Run; + end + else + writeln(PaxCompiler1.ErrorMessage[0]); + finally + PaxCompiler1.Free; + PaxInterpreter1.Free; + PaxBasicLanguage1.Free; + end; + writeln('Press any key...'); + Readln; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/RTTI/1/script.txt b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/RTTI/1/script.txt new file mode 100644 index 0000000..3cbb690 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/RTTI/1/script.txt @@ -0,0 +1,135 @@ +Imports TypInfo, Classes, PascalNamespace + +Enum MyEnum + one + two + three +End Enum + +Class AMyClass + Inherits TComponent + Private FX As Integer + Private FY AS String + Private fStrings As TStringList + Private fOnClick As TNotifyEvent + Private fInter As IUnknown + + Published Field As TObject + Published Field2 As TStringList + + Function GetY As String + Return FY + End Function + + Sub SetY(value AS String) + println "value=", value + FY = value + println "FY=", FY + End Sub + + Sub New(AOwner As TComponent) + MyBase.Create(null) + Field = New TObject + Field2 = New TStringList + End Sub + + Sub Finalize + Field.Free + Field2.Free + MyBase.Destroy + End Sub + + Sub ScriptHandler(Sender As TObject) + println "***************", Sender.ClassName + ExitCode = 5 + println ExitCode + End Sub + + Published Property X As Integer + Get + Return FX + End Get + Set + println "value=", value + FX = value + println "FX=", FX + End Set + End Property + + Published Property Y As String + Get + Return FY + End Get + Set + FY = value + End Set + End Property + + Published Property Strings As TStringList + Get + Return fStrings + End Get + Set + fStrings = value + End Set + End Property + + Published Property OnClick As TNotifyEvent + Get + Return fOnClick + End Get + Set + fOnClick = value + End Set + End Property + + Published Property Inter As IUnknown + Get + Return fInter + End Get + Set + fInter = value + End Set + End Property + + Published Sub MyProc(U As Integer, V As Integer) + println "MyProc:", X, Y + End Sub + +End Class + +Class AMyClass2 + Inherits AMyClass + Sub New(AOwner As TComponent) + MyBase.New(null) + End Sub +End Class + +Dim Z As AMyClass, W As AMyClass +Dim TestClass As TTestClass = New TTestClass() + +Z = New AMyClass(null) +W = New AMyClass2(null) + +W.X = 5 +println W.X + +W.Name = "yyyy" +println W.Name + +TestClass.DoTest ' Z.OnClick was assigned at host side + +If Assigned(Z.OnClick) Then + Z.OnClick(Z) +End If + +Z.OnClick = TestClass.OnClickHandler2 ' direct assignment of host handler +Z.OnClick(null) + +Z.OnClick = Z.ScriptHandler +Z.OnClick(W) + +Z.Free +W.Free +TestClass.Free + diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/RTTI/2/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/RTTI/2/Project1.dpr new file mode 100644 index 0000000..388aef2 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/RTTI/2/Project1.dpr @@ -0,0 +1,93 @@ +{$APPTYPE CONSOLE} +{$O-} +program Project1; +uses + PAXCOMP_CONSTANTS, + PAXCOMP_SYS, + TypInfo, + Classes, + SysUtils, + PaxCompiler, + PaxInterpreter, + PaxBasicLanguage, + PaxRegister; + +type + TTest = class(TComponent) + public + procedure Save; + end; + +{ TTest } + +procedure MyGetPropertyNames(aObject: TObject; aStringList: TStringList); +var + count : integer; + size : integer; + list : PPropList; + i : integer; + ppi: PPropInfo; +begin + aStringList.Clear; + count := GetPropList(PTypeInfo(aObject.ClassInfo), tkProperties, nil, false); + size := count * SizeOf(Pointer); + GetMem(list, size); + try + GetPropList(PTypeInfo(aObject.ClassInfo), tkProperties, list, false); + for i := 0 to count - 1 do + aStringList.Add(list^[i]^.Name); + finally + FreeMem(list, size); + end; +end; + +type + TMyStringList = class(TStringList) + published + property Text; + end; + +procedure TTest.Save; +var + list: TMyStringList; +begin + list := TMyStringList.Create; + try + MyGetPropertyNames(self, list); + writeln('Property Count = ', list.Count); + writeln('Properties are: ' + list.Text); + finally + list.free; + end; +end; + +var + PaxInterpreter1: TPaxInterpreter; + PaxCompiler1: TPaxCompiler; + PaxBasicLanguage1: TPaxBasicLanguage; + H: Integer; +begin + H := RegisterClassType(0, TTest); + RegisterHeader(H, 'procedure Save;', @TTest.Save); + + PaxCompiler1 := TPaxCompiler.Create(nil); + PaxInterpreter1 := TPaxInterpreter.Create(nil); + PaxBasicLanguage1 := TPaxBasicLanguage.Create(nil); + try + PaxCompiler1.RegisterLanguage(PaxBasicLanguage1); + PaxCompiler1.AddModule('1', 'Basic'); + PaxCompiler1.AddCodeFromFile('1', 'script.txt'); + if PaxCompiler1.Compile(PaxInterpreter1) then + begin + PaxInterpreter1.Run; + end + else + writeln(PaxCompiler1.ErrorMessage[0]); + finally + PaxCompiler1.Free; + PaxInterpreter1.Free; + PaxBasicLanguage1.Free; + end; + writeln('Press any key...'); + Readln; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/RTTI/2/script.txt b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/RTTI/2/script.txt new file mode 100644 index 0000000..22098dc --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/RTTI/2/script.txt @@ -0,0 +1,37 @@ +Class MyTestBase + Inherits TTest +End Class + + +Class MyTest + + Inherits MyTestBase + + Private FX As Integer + Private FY As String + + Published Property X As Integer + Get + Return FX + End Get + Set + FX = value + End Set + End Property + + Published Property Y As String + Get + Return FY + End Get + Set + FY = value + End Set + End Property + +End Class + +Dim t As MyTest = New MyTest +t.x = 10 +t.y = "20" +t.Save +t.Free diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/RegisterVariable/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/RegisterVariable/Project1.dpr new file mode 100644 index 0000000..513a1dd --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/RegisterVariable/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/RegisterVariable/Project1.res b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/RegisterVariable/Project1.res new file mode 100644 index 0000000..3adc036 Binary files /dev/null and b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/RegisterVariable/Project1.res differ diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/RegisterVariable/Unit1.dfm b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/RegisterVariable/Unit1.dfm new file mode 100644 index 0000000..7765bb5 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/RegisterVariable/Unit1.dfm @@ -0,0 +1,47 @@ +object Form1: TForm1 + Left = 192 + Top = 114 + Caption = 'Register variable demo' + ClientHeight = 171 + ClientWidth = 327 + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -14 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + PixelsPerInch = 120 + TextHeight = 16 + object Button1: TButton + Left = 49 + Top = 98 + Width = 93 + Height = 31 + Margins.Left = 4 + Margins.Top = 4 + Margins.Right = 4 + Margins.Bottom = 4 + Caption = 'Run' + TabOrder = 0 + OnClick = Button1Click + end + object PaxCompiler1: TPaxCompiler + Alignment = 1 + DebugMode = False + Left = 32 + Top = 16 + end + object PaxBasicLanguage1: TPaxBasicLanguage + ExplicitOff = False + CompleteBooleanEval = False + UseFWArrays = True + Left = 80 + Top = 16 + end + object PaxInterpreter1: TPaxInterpreter + Console = False + Left = 160 + Top = 96 + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/RegisterVariable/Unit1.pas b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/RegisterVariable/Unit1.pas new file mode 100644 index 0000000..e6c89b3 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Basic/RegisterVariable/Unit1.pas @@ -0,0 +1,68 @@ +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, PaxCompiler, PaxInterpreter, PaxRegister, PaxBasicLanguage, + PaxRunner; + +type + TForm1 = class(TForm) + PaxCompiler1: TPaxCompiler; + Button1: TButton; + PaxBasicLanguage1: TPaxBasicLanguage; + PaxInterpreter1: TPaxInterpreter; + procedure Button1Click(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.dfm} + +type + TMyPoint = packed record + x, y: Integer; + end; + +procedure TForm1.Button1Click(Sender: TObject); +var + H_TMyPoint, H_MyPoint: Integer; + MyPoint: TMyPoint; + I: Integer; +begin + MyPoint.X := 60; + MyPoint.Y := 23; + + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxBasicLanguage1); + + // register host-defined type + H_TMyPoint := PaxCompiler1.RegisterRecordType(0, 'TMyPoint'); + PaxCompiler1.RegisterRecordTypeField(H_TMyPoint, 'X', _typeINTEGER); + PaxCompiler1.RegisterRecordTypeField(H_TMyPoint, 'Y', _typeINTEGER); + + // register host-defined variable + H_MyPoint := PaxCompiler1.RegisterVariable(0, 'MyPoint', H_TMyPoint, @MyPoint); + + PaxCompiler1.AddModule('1', PaxBasicLanguage1.LanguageName); + PaxCompiler1.AddCode('1', 'MyPoint.Y = 8'); + + if PaxCompiler1.Compile(PaxInterpreter1) then + begin + PaxInterpreter1.Run; + ShowMessage(IntToStr(MyPoint.Y)); + end + else + for I:=0 to PaxCompiler1.ErrorCount do + ShowMessage(PaxCompiler1.ErrorMessage[I]); +end; + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/AccessToScriptVariables/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/AccessToScriptVariables/Project1.dpr new file mode 100644 index 0000000..513a1dd --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/AccessToScriptVariables/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/AccessToScriptVariables/Project1.res b/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/AccessToScriptVariables/Project1.res new file mode 100644 index 0000000..3adc036 Binary files /dev/null and b/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/AccessToScriptVariables/Project1.res differ diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/AccessToScriptVariables/Unit1.dfm b/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/AccessToScriptVariables/Unit1.dfm new file mode 100644 index 0000000..5e17894 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/AccessToScriptVariables/Unit1.dfm @@ -0,0 +1,44 @@ +object Form1: TForm1 + Left = 277 + Top = 120 + Caption = 'Access to script-defined variables' + ClientHeight = 164 + ClientWidth = 290 + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -14 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + PixelsPerInch = 120 + TextHeight = 16 + object Button1: TButton + Left = 39 + Top = 98 + Width = 93 + Height = 31 + Margins.Left = 4 + Margins.Top = 4 + Margins.Right = 4 + Margins.Bottom = 4 + Caption = 'Run' + TabOrder = 0 + OnClick = Button1Click + end + object PaxCompiler1: TPaxCompiler + Alignment = 1 + DebugMode = False + Left = 48 + Top = 24 + end + object PaxJavaScriptLanguage1: TPaxJavaScriptLanguage + Left = 152 + Top = 80 + end + object PaxInterpreter1: TPaxInterpreter + Console = False + Left = 168 + Top = 40 + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/AccessToScriptVariables/Unit1.pas b/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/AccessToScriptVariables/Unit1.pas new file mode 100644 index 0000000..8261563 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/AccessToScriptVariables/Unit1.pas @@ -0,0 +1,58 @@ +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, PaxCompiler, PaxInterpreter, PaxJavaScriptLanguage, + PaxRunner; +type + TForm1 = class(TForm) + PaxCompiler1: TPaxCompiler; + Button1: TButton; + PaxJavaScriptLanguage1: TPaxJavaScriptLanguage; + PaxInterpreter1: TPaxInterpreter; + procedure Button1Click(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.dfm} + +procedure TForm1.Button1Click(Sender: TObject); +var + P: Pointer; + I: Integer; +begin + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxJavaScriptLanguage1); + + PaxCompiler1.RegisterHeader(0, 'procedure ShowMessage(const Msg: string);', @ShowMessage); + PaxCompiler1.RegisterHeader(0, 'function IntToStr(Value: Integer): string;', @IntToStr); + + PaxCompiler1.AddModule('1', PaxJavaScriptLanguage1.LanguageName); + PaxCompiler1.AddCode('1', 'var x;'); + PaxCompiler1.AddCode('1', 'ShowMessage("script:" + IntToStr(x));'); + + if PaxCompiler1.Compile(PaxInterpreter1) then + begin + P := PaxInterpreter1.GetAddress('x'); + Variant(P^) := 5; // change script-defind variable + PaxInterpreter1.Run; // the first run + ShowMessage('host:' + IntToStr(Variant(P^))); // show script-defined var + Variant(P^) := 30; // change script-defind variable + PaxInterpreter1.Run; // the second run + end + else + for I:=0 to PaxCompiler1.ErrorCount do + ShowMessage(PaxCompiler1.ErrorMessage[I]); +end; + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/Breakpoints/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/Breakpoints/Project1.dpr new file mode 100644 index 0000000..513a1dd --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/Breakpoints/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/Breakpoints/Project1.res b/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/Breakpoints/Project1.res new file mode 100644 index 0000000..3adc036 Binary files /dev/null and b/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/Breakpoints/Project1.res differ diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/Breakpoints/Unit1.dfm b/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/Breakpoints/Unit1.dfm new file mode 100644 index 0000000..314d7bd --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/Breakpoints/Unit1.dfm @@ -0,0 +1,135 @@ +object Form1: TForm1 + Left = 192 + Top = 114 + Caption = 'Form1' + ClientHeight = 329 + ClientWidth = 761 + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -14 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + PixelsPerInch = 120 + TextHeight = 16 + object Label1: TLabel + Left = 30 + Top = 10 + Width = 60 + Height = 26 + Margins.Left = 4 + Margins.Top = 4 + Margins.Right = 4 + Margins.Bottom = 4 + Caption = 'Script:' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -23 + Font.Name = 'MS Sans Serif' + Font.Style = [] + ParentFont = False + end + object Label3: TLabel + Left = 354 + Top = 59 + Width = 206 + Height = 26 + Margins.Left = 4 + Margins.Top = 4 + Margins.Right = 4 + Margins.Bottom = 4 + Caption = 'Add breakpoint at line' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -23 + Font.Name = 'MS Sans Serif' + Font.Style = [] + ParentFont = False + end + object Memo1: TMemo + Left = 20 + Top = 49 + Width = 227 + Height = 218 + Margins.Left = 4 + Margins.Top = 4 + Margins.Right = 4 + Margins.Bottom = 4 + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -20 + Font.Name = 'MS Sans Serif' + Font.Style = [] + Lines.Strings = ( + ' print("A"); // line 0' + ' print("B"); // line 1' + ' print("C"); // line 2' + ' print("D"); // line 3' + ' print("E"); // line 4' + '') + ParentFont = False + TabOrder = 0 + end + object Edit1: TEdit + Left = 591 + Top = 59 + Width = 50 + Height = 32 + Margins.Left = 4 + Margins.Top = 4 + Margins.Right = 4 + Margins.Bottom = 4 + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -20 + Font.Name = 'MS Sans Serif' + Font.Style = [] + ParentFont = False + TabOrder = 1 + Text = '2' + end + object Button1: TButton + Left = 390 + Top = 158 + Width = 188 + Height = 60 + Margins.Left = 4 + Margins.Top = 4 + Margins.Right = 4 + Margins.Bottom = 4 + Caption = 'Run script' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -23 + Font.Name = 'MS Sans Serif' + Font.Style = [] + ParentFont = False + TabOrder = 2 + OnClick = Button1Click + end + object PaxCompiler1: TPaxCompiler + Alignment = 1 + DebugMode = False + Left = 296 + Top = 192 + end + object PaxCompilerDebugger1: TPaxCompilerDebugger + Left = 456 + Top = 192 + end + object PaxCompilerExplorer1: TPaxCompilerExplorer + Left = 520 + Top = 200 + end + object PaxJavaScriptLanguage1: TPaxJavaScriptLanguage + Left = 344 + Top = 192 + end + object PaxInterpreter1: TPaxInterpreter + Console = False + OnPrintEvent = PaxInterpreter1PrintEvent + Left = 320 + Top = 112 + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/Breakpoints/Unit1.pas b/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/Breakpoints/Unit1.pas new file mode 100644 index 0000000..6d19233 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/Breakpoints/Unit1.pas @@ -0,0 +1,80 @@ +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, PaxInterpreter, PaxCompiler, PaxCompilerDebugger, + PaxRegister, + PaxCompilerExplorer, PaxJavaScriptLanguage, PaxRunner; + +type + TForm1 = class(TForm) + Memo1: TMemo; + Label1: TLabel; + Edit1: TEdit; + Label3: TLabel; + Button1: TButton; + PaxCompiler1: TPaxCompiler; + PaxCompilerDebugger1: TPaxCompilerDebugger; + PaxCompilerExplorer1: TPaxCompilerExplorer; + PaxJavaScriptLanguage1: TPaxJavaScriptLanguage; + PaxInterpreter1: TPaxInterpreter; + procedure Button1Click(Sender: TObject); + procedure PaxInterpreter1PrintEvent(Sender: TPaxRunner; const Text: string); + private + { Private declarations } + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.dfm} + +procedure TForm1.Button1Click(Sender: TObject); +var + I: Integer; + Breakpoint: Integer; +begin + Breakpoint := StrToInt(Edit1.Text); + + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxJavaScriptLanguage1); + + PaxCompiler1.AddModule('1', PaxJavaScriptLanguage1.LanguageName); + PaxCompiler1.AddCode('1', Memo1.Lines.Text); + + PaxCompiler1.DebugMode := true; + + if PaxCompiler1.Compile(PaxInterpreter1) then + begin + PaxCompilerExplorer1.RegisterCompiler(PaxCompiler1); + PaxCompilerDebugger1.RegisterCompiler(PaxCompiler1, PaxInterpreter1); + if PaxCompilerExplorer1.IsExecutableLine('1', Breakpoint) then + PaxCompilerDebugger1.AddBreakpoint('1', Breakpoint); + + PaxCompilerDebugger1.Run; + while PaxCompilerDebugger1.IsPaused do + begin + ShowMessage('Program has been paused at breakpoint: ' + + IntToStr(PaxCompilerDebugger1.SourceLineNumber)); + + PaxInterpreter1.Run; + end; + end + else + for I:=0 to PaxCompiler1.ErrorCount - 1 do + ShowMessage(PaxCompiler1.ErrorMessage[I]); +end; + +procedure TForm1.PaxInterpreter1PrintEvent(Sender: TPaxRunner; + const Text: string); +begin + ShowMessage(Text); +end; + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/CallRoutine/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/CallRoutine/Project1.dpr new file mode 100644 index 0000000..513a1dd --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/CallRoutine/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/CallRoutine/Project1.res b/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/CallRoutine/Project1.res new file mode 100644 index 0000000..3adc036 Binary files /dev/null and b/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/CallRoutine/Project1.res differ diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/CallRoutine/Unit1.dfm b/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/CallRoutine/Unit1.dfm new file mode 100644 index 0000000..3e28065 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/CallRoutine/Unit1.dfm @@ -0,0 +1,45 @@ +object Form1: TForm1 + Left = 192 + Top = 114 + Caption = 'Call routine demo' + ClientHeight = 146 + ClientWidth = 283 + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -14 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + OnCreate = FormCreate + PixelsPerInch = 120 + TextHeight = 16 + object Button1: TButton + Left = 49 + Top = 89 + Width = 149 + Height = 30 + Margins.Left = 4 + Margins.Top = 4 + Margins.Right = 4 + Margins.Bottom = 4 + Caption = 'Call ' + TabOrder = 0 + OnClick = Button1Click + end + object PaxCompiler1: TPaxCompiler + Alignment = 1 + DebugMode = False + Left = 32 + Top = 16 + end + object PaxJavaScriptLanguage1: TPaxJavaScriptLanguage + Left = 192 + Top = 64 + end + object PaxInterpreter1: TPaxInterpreter + Console = False + Left = 136 + Top = 40 + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/CallRoutine/Unit1.pas b/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/CallRoutine/Unit1.pas new file mode 100644 index 0000000..0821fc6 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/CallRoutine/Unit1.pas @@ -0,0 +1,70 @@ +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, PaxCompiler, PaxInterpreter, PaxRegister, PaxJavaScriptLanguage, + PaxRunner; +type + TForm1 = class(TForm) + PaxCompiler1: TPaxCompiler; + Button1: TButton; + PaxJavaScriptLanguage1: TPaxJavaScriptLanguage; + PaxInterpreter1: TPaxInterpreter; + procedure Button1Click(Sender: TObject); + procedure FormCreate(Sender: TObject); + private + Y: Integer; + { Private declarations } + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.dfm} + +uses + PAXCOMP_JavaScript; + +procedure TForm1.Button1Click(Sender: TObject); +var + I: Integer; + P: Pointer; + V: Variant; +begin +{$O-} + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxJavaScriptLanguage1); + + PaxCompiler1.RegisterVariable(0, 'Y', _typeINTEGER, @Y); + + PaxCompiler1.AddModule('1', PaxJavaScriptLanguage1.LanguageName); + PaxCompiler1.AddCode('1', 'function P(U, V)'); + PaxCompiler1.AddCode('1', '{'); + PaxCompiler1.AddCode('1', ' Y = Y + U + V;'); + PaxCompiler1.AddCode('1', ' return Y;'); + PaxCompiler1.AddCode('1', '}'); + + if PaxCompiler1.Compile(PaxInterpreter1) then + begin + PaxInterpreter1.RunInitialization; // to create Function objects + + V := PaxInterpreter1.CallRoutine('#P', [10, 20]); + ShowMessage(IntToStr(Y)); + end + else + for I:=0 to PaxCompiler1.ErrorCount do + ShowMessage(PaxCompiler1.ErrorMessage[I]); +end; + +procedure TForm1.FormCreate(Sender: TObject); +begin + Y := 5; +end; + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/CodeComplet/MyUnit.pas b/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/CodeComplet/MyUnit.pas new file mode 100644 index 0000000..69332a4 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/CodeComplet/MyUnit.pas @@ -0,0 +1,14 @@ +unit MyUnit; +interface +type + TMyClass = class + X, Y: Integer; + end; +var + I: Integer; +const + S = 'abc'; + +implementation + J: Integer; +end. \ No newline at end of file diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/CodeComplet/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/CodeComplet/Project1.dpr new file mode 100644 index 0000000..5769e8a --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/CodeComplet/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form3}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm3, Form3); + Application.Run; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/CodeComplet/Project1.res b/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/CodeComplet/Project1.res new file mode 100644 index 0000000..3adc036 Binary files /dev/null and b/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/CodeComplet/Project1.res differ diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/CodeComplet/Unit1.dfm b/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/CodeComplet/Unit1.dfm new file mode 100644 index 0000000..bf8df40 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/CodeComplet/Unit1.dfm @@ -0,0 +1,46 @@ +object Form3: TForm3 + Left = 0 + Top = 0 + Width = 701 + Height = 194 + Caption = 'Code completion demo' + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -10 + Font.Name = 'Tahoma' + Font.Style = [] + OldCreateOrder = False + PixelsPerInch = 96 + TextHeight = 12 + object Button1: TButton + Left = 18 + Top = 12 + Width = 56 + Height = 19 + Caption = 'Create' + TabOrder = 0 + OnClick = Button1Click + end + object Memo1: TMemo + Left = 156 + Top = 6 + Width = 463 + Height = 143 + TabOrder = 1 + end + object PaxCompiler1: TPaxCompiler + Alignment = 1 + DebugMode = False + Left = 24 + Top = 48 + end + object PaxCompilerExplorer1: TPaxCompilerExplorer + Left = 80 + Top = 88 + end + object PaxJavaScriptLanguage1: TPaxJavaScriptLanguage + Left = 112 + Top = 48 + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/CodeComplet/Unit1.pas b/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/CodeComplet/Unit1.pas new file mode 100644 index 0000000..371ce40 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/CodeComplet/Unit1.pas @@ -0,0 +1,52 @@ +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, + Dialogs, PaxCompiler, StdCtrls, PaxCompilerExplorer, + PaxJavaScriptLanguage, PaxRunner, PaxInterpreter; + +type + TForm3 = class(TForm) + Button1: TButton; + PaxCompiler1: TPaxCompiler; + PaxCompilerExplorer1: TPaxCompilerExplorer; + Memo1: TMemo; + PaxJavaScriptLanguage1: TPaxJavaScriptLanguage; + procedure Button1Click(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + end; + +var + Form3: TForm3; + +implementation + +{$R *.dfm} + +procedure TForm3.Button1Click(Sender: TObject); +var + L: TStringList; +begin + L := TStringList.Create; + try + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxJavaScriptLanguage1); + PaxCompiler1.AddModule('1', 'JavaScript'); + PaxCompiler1.AddCodeFromFile('1', 'script.txt'); + if PaxCompiler1.CodeCompletion('1', 19, 6, Memo1.Lines) then + begin + //ok + end + else + ShowMessage(PaxCompiler1.ErrorMessage[0]); + finally + L.Free; + end; +end; + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/CodeComplet/script.txt b/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/CodeComplet/script.txt new file mode 100644 index 0000000..0cfa935 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/CodeComplet/script.txt @@ -0,0 +1,7 @@ +// x=19, y=6 +function fact(n) +{ + if (n == 1) + return 1; + else + return n * fact( diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/DebugDemo/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/DebugDemo/Project1.dpr new file mode 100644 index 0000000..cebc69a --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/DebugDemo/Project1.dpr @@ -0,0 +1,15 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}, + Unit2 in 'Unit2.pas' {Form2}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.CreateForm(TForm2, Form2); + Application.Run; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/DebugDemo/Project1.res b/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/DebugDemo/Project1.res new file mode 100644 index 0000000..3adc036 Binary files /dev/null and b/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/DebugDemo/Project1.res differ diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/DebugDemo/Unit1.dfm b/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/DebugDemo/Unit1.dfm new file mode 100644 index 0000000..bc62520 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/DebugDemo/Unit1.dfm @@ -0,0 +1,219 @@ +object Form1: TForm1 + Left = 209 + Top = 111 + Caption = 'DebugDemo' + ClientHeight = 743 + ClientWidth = 789 + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -14 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + OnCloseQuery = FormCloseQuery + PixelsPerInch = 120 + TextHeight = 16 + object Label1: TLabel + Left = 30 + Top = 10 + Width = 60 + Height = 26 + Margins.Left = 2 + Margins.Top = 2 + Margins.Right = 2 + Margins.Bottom = 2 + Caption = 'Script:' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -23 + Font.Name = 'MS Sans Serif' + Font.Style = [] + ParentFont = False + end + object Label2: TLabel + Left = 9 + Top = 303 + Width = 62 + Height = 26 + Margins.Left = 2 + Margins.Top = 2 + Margins.Right = 2 + Margins.Bottom = 2 + Caption = 'Trace:' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -23 + Font.Name = 'MS Sans Serif' + Font.Style = [] + ParentFont = False + end + object Memo1: TMemo + Left = 20 + Top = 49 + Width = 445 + Height = 238 + Margins.Left = 2 + Margins.Top = 2 + Margins.Right = 2 + Margins.Bottom = 2 + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -18 + Font.Name = 'MS Sans Serif' + Font.Style = [] + Lines.Strings = ( + 'function fact(n)' + '{' + ' if (n == 1)' + ' return 1;' + ' else' + ' return n * fact(n - 1);' + '}' + 'var ss;' + 'ss = fact(3);' + 'print(ss);' + '') + ParentFont = False + TabOrder = 0 + end + object Memo2: TMemo + Left = 20 + Top = 337 + Width = 445 + Height = 398 + Margins.Left = 2 + Margins.Top = 2 + Margins.Right = 2 + Margins.Bottom = 2 + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -18 + Font.Name = 'MS Sans Serif' + Font.Style = [] + Lines.Strings = ( + '') + ParentFont = False + TabOrder = 1 + end + object Button1: TButton + Left = 482 + Top = 31 + Width = 238 + Height = 60 + Margins.Left = 2 + Margins.Top = 2 + Margins.Right = 2 + Margins.Bottom = 2 + Caption = 'Compile' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -23 + Font.Name = 'MS Sans Serif' + Font.Style = [] + ParentFont = False + TabOrder = 2 + OnClick = Button1Click + end + object Button2: TButton + Left = 482 + Top = 110 + Width = 238 + Height = 60 + Margins.Left = 2 + Margins.Top = 2 + Margins.Right = 2 + Margins.Bottom = 2 + Caption = 'Run' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -23 + Font.Name = 'MS Sans Serif' + Font.Style = [] + ParentFont = False + TabOrder = 3 + OnClick = Button2Click + end + object Button3: TButton + Left = 482 + Top = 191 + Width = 238 + Height = 60 + Margins.Left = 2 + Margins.Top = 2 + Margins.Right = 2 + Margins.Bottom = 2 + Caption = 'Trace Into' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -23 + Font.Name = 'MS Sans Serif' + Font.Style = [] + ParentFont = False + TabOrder = 4 + OnClick = Button3Click + end + object Button4: TButton + Left = 482 + Top = 271 + Width = 238 + Height = 61 + Margins.Left = 2 + Margins.Top = 2 + Margins.Right = 2 + Margins.Bottom = 2 + Caption = 'Step Over' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -23 + Font.Name = 'MS Sans Serif' + Font.Style = [] + ParentFont = False + TabOrder = 5 + OnClick = Button4Click + end + object Button5: TButton + Left = 482 + Top = 338 + Width = 238 + Height = 60 + Margins.Left = 2 + Margins.Top = 2 + Margins.Right = 2 + Margins.Bottom = 2 + Caption = 'Run to Cursor' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -23 + Font.Name = 'MS Sans Serif' + Font.Style = [] + ParentFont = False + TabOrder = 6 + OnClick = Button5Click + end + object PaxCompiler1: TPaxCompiler + Alignment = 1 + DebugMode = False + Left = 544 + Top = 440 + end + object PaxCompilerDebugger1: TPaxCompilerDebugger + Left = 472 + Top = 352 + end + object PaxCompilerExplorer1: TPaxCompilerExplorer + Left = 544 + Top = 360 + end + object PaxJavaScriptLanguage1: TPaxJavaScriptLanguage + Left = 472 + Top = 496 + end + object PaxInterpreter1: TPaxInterpreter + Console = False + OnPauseUpdated = PaxInterpreter1PauseUpdated + OnPrintEvent = PaxInterpreter1PrintEvent + Left = 560 + Top = 544 + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/DebugDemo/Unit1.pas b/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/DebugDemo/Unit1.pas new file mode 100644 index 0000000..60b683d --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/DebugDemo/Unit1.pas @@ -0,0 +1,351 @@ +{$O-} +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, PaxInterpreter, PaxCompiler, PaxCompilerDebugger, + PaxRegister, + PaxCompilerExplorer, PaxJavaScriptLanguage, PaxRunner; + +type + TForm1 = class(TForm) + Memo1: TMemo; + Memo2: TMemo; + Label1: TLabel; + Label2: TLabel; + Button1: TButton; + PaxCompiler1: TPaxCompiler; + Button2: TButton; + Button3: TButton; + Button4: TButton; + Button5: TButton; + PaxCompilerDebugger1: TPaxCompilerDebugger; + PaxCompilerExplorer1: TPaxCompilerExplorer; + PaxJavaScriptLanguage1: TPaxJavaScriptLanguage; + PaxInterpreter1: TPaxInterpreter; + procedure Button1Click(Sender: TObject); + procedure Button2Click(Sender: TObject); + procedure Button3Click(Sender: TObject); + procedure Button4Click(Sender: TObject); + procedure Button5Click(Sender: TObject); + procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean); + procedure PaxInterpreter1PauseUpdated(Sender: TPaxRunner; + const ModuleName: string; SourceLineNumber: Integer); + procedure PaxInterpreter1PrintEvent(Sender: TPaxRunner; const Text: string); + private + { Private declarations } + ResumeRequest: Boolean; + CloseRequest: Boolean; + procedure UpdateDebugInfo; + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +uses Unit2; + +{$R *.dfm} + +procedure TForm1.Button1Click(Sender: TObject); +var + I: Integer; +begin + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxJavaScriptLanguage1); + PaxCompiler1.AddModule('1', PaxJavaScriptLanguage1.LanguageName); + PaxCompiler1.AddCode('1', Memo1.Lines.Text); + PaxCompiler1.DebugMode := true; + if PaxCompiler1.Compile(PaxInterpreter1) then + begin + ShowMessage('Script has been successfully recompiled.'); + PaxCompilerExplorer1.RegisterCompiler(PaxCompiler1); + PaxCompilerDebugger1.RegisterCompiler(PaxCompiler1, PaxInterpreter1); + end + else + for I:=0 to PaxCompiler1.ErrorCount - 1 do + ShowMessage(PaxCompiler1.ErrorMessage[I]); +end; + +procedure TForm1.Button2Click(Sender: TObject); +begin + if not PaxCompilerDebugger1.Valid then + begin + ShowMessage('You have to compile script. Press "Compile" button.'); + Exit; + end; + PaxCompilerDebugger1.RunMode := _rmRUN; + if PaxCompilerDebugger1.IsPaused then + ResumeRequest := true + else + PaxCompilerDebugger1.Run; +end; + +procedure TForm1.Button3Click(Sender: TObject); +begin + if not PaxCompilerDebugger1.Valid then + begin + ShowMessage('You have to compile script. Press "Compile" button.'); + Exit; + end; + PaxCompilerDebugger1.RunMode := _rmTRACE_INTO; + if PaxCompilerDebugger1.IsPaused then + ResumeRequest := true + else + PaxCompilerDebugger1.Run; +end; + +procedure TForm1.Button4Click(Sender: TObject); +begin + if not PaxCompilerDebugger1.Valid then + begin + ShowMessage('You have to compile script. Press "Compile" button.'); + Exit; + end; + PaxCompilerDebugger1.RunMode := _rmSTEP_OVER; + if PaxCompilerDebugger1.IsPaused then + ResumeRequest := true + else + PaxCompilerDebugger1.Run; +end; + +procedure TForm1.Button5Click(Sender: TObject); +begin + if not PaxCompilerDebugger1.Valid then + begin + ShowMessage('You have to compile script. Press "Compile" button.'); + Exit; + end; + + Form2.ShowModal; + + PaxCompilerDebugger1.RunMode := _rmRUN_TO_CURSOR; + if PaxCompilerDebugger1.IsPaused then + ResumeRequest := true + else + PaxCompilerDebugger1.Run; +end; + +procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean); +begin + CanClose := true; + CloseRequest := true; +end; + +procedure TForm1.PaxInterpreter1PauseUpdated(Sender: TPaxRunner; + const ModuleName: string; SourceLineNumber: Integer); +begin + UpdateDebugInfo; + ResumeRequest := false; + repeat + Application.ProcessMessages; + if ResumeRequest then + Break; + if CloseRequest then + Abort; + until false; +end; + +procedure TForm1.PaxInterpreter1PrintEvent(Sender: TPaxRunner; + const Text: string); +begin + ShowMessage(Text); +end; + +procedure TForm1.UpdateDebugInfo; + + procedure AddFields(StackFrameNumber, Id: Integer); + var + I, K: Integer; + OwnerName, S: String; + begin + K := PaxCompilerExplorer1.GetFieldCount(Id); + if K = 0 then + Exit; + + OwnerName := PaxCompilerExplorer1.Names[Id]; + if PaxCompilerDebugger1.GetValueAsString(Id) = 'nil' then + Exit; + + for I:=0 to K - 1 do + begin + S := OwnerName + '.' + PaxCompilerExplorer1.GetFieldName(Id, I); + S := ' ' + S + '=' + PaxCompilerDebugger1.GetFieldValueAsString( + StackFrameNumber, Id, I); + Memo2.Lines.Add(S); + end; + end; + + procedure AddPublishedProps(StackFrameNumber, Id: Integer); + var + I, K: Integer; + OwnerName, S: String; + begin + K := PaxCompilerExplorer1.GetPublishedPropCount(Id); + if K = 0 then + Exit; + + OwnerName := PaxCompilerExplorer1.Names[Id]; + if PaxCompilerDebugger1.GetValueAsString(Id) = 'nil' then + Exit; + + for I:=0 to K - 1 do + begin + S := OwnerName + '.' + PaxCompilerExplorer1.GetPublishedPropName(Id, I); + S := ' ' + S + '=' + PaxCompilerDebugger1.GetPublishedPropValueAsString( + StackFrameNumber, Id, I); + Memo2.Lines.Add(S); + end; + end; + + procedure AddArrayElements(StackFrameNumber, Id: Integer); + var + I, K1, K2: Integer; + OwnerName, S: String; + begin + if not PaxCompilerExplorer1.HasArrayType(Id) then + Exit; + + K1 := PaxCompilerExplorer1.GetArrayLowBound(Id); + K2 := PaxCompilerExplorer1.GetArrayHighBound(Id); + + OwnerName := PaxCompilerExplorer1.Names[Id]; + + for I:=K1 to K2 do + begin + S := OwnerName + '[' + IntToStr(I) + ']'; + S := ' ' + S + '=' + PaxCompilerDebugger1.GetArrayItemValueAsString( + StackFrameNumber, Id, I); + Memo2.Lines.Add(S); + end; + end; + + procedure AddDynArrayElements(StackFrameNumber, Id: Integer); + var + I, L: Integer; + OwnerName, S: String; + begin + if not PaxCompilerExplorer1.HasDynArrayType(Id) then + Exit; + + L := PaxCompilerDebugger1.GetDynArrayLength(StackFrameNumber, Id); + + OwnerName := PaxCompilerExplorer1.Names[Id]; + + for I:=0 to L - 1 do + begin + S := OwnerName + '[' + IntToStr(I) + ']'; + S := ' ' + S + '=' + PaxCompilerDebugger1.GetDynArrayItemValueAsString( + StackFrameNumber, Id, I); + Memo2.Lines.Add(S); + end; + end; + +var + SourceLineNumber: Integer; + ModuleName: String; + StackFrameNumber, J, K, SubId, Id: Integer; + S, V: String; + CallStackLineNumber: Integer; + CallStackModuleName: String; +begin + Memo2.Lines.Clear; + if PaxCompilerDebugger1.IsPaused then + begin + ModuleName := PaxCompilerDebugger1.ModuleName; + SourceLineNumber := PaxCompilerDebugger1.SourceLineNumber; + + if SourceLineNumber >= PaxCompiler1.Modules[ModuleName].Count then + Exit; + + Memo2.Lines.Add('Paused at line ' + IntTosTr(SourceLineNumber)); + Memo2.Lines.Add(PaxCompiler1.Modules[ModuleName][SourceLineNumber]); + Memo2.Lines.Add('------------------------------------------------------'); + + if PaxCompilerDebugger1.CallStackCount > 0 then + begin + Memo2.Lines.Add('Call stack:'); + for StackFrameNumber:=0 to PaxCompilerDebugger1.CallStackCount - 1 do + begin + SubId := PaxCompilerDebugger1.CallStack[StackFrameNumber]; + S := '('; + K := PaxCompilerExplorer1.GetParamCount(SubId); + for J:=0 to K - 1 do + begin + Id := PaxCompilerExplorer1.GetParamId(SubId, J); + V := PaxCompilerDebugger1.GetValueAsString(StackFrameNumber, Id); + S := S + V; + if J < K - 1 then + S := S + ','; + end; + S := PaxCompilerExplorer1.Names[SubId] + S + ')'; + + CallStackLineNumber := PaxCompilerDebugger1.CallStackLineNumber[StackFrameNumber]; + CallStackModuleName := PaxCompilerDebugger1.CallStackModuleName[StackFrameNumber]; + + S := S + '; // ' + PaxCompiler1.Modules[CallStackModuleName][CallStackLineNumber]; + + Memo2.Lines.Add(S); + end; + Memo2.Lines.Add('------------------------------------------------------'); + + Memo2.Lines.Add('Local scope:'); + StackFrameNumber := PaxCompilerDebugger1.CallStackCount - 1; + SubId := PaxCompilerDebugger1.CallStack[StackFrameNumber]; + K := PaxCompilerExplorer1.GetLocalCount(SubId); + for J:=0 to K - 1 do + begin + Id := PaxCompilerExplorer1.GetLocalId(SubId, J); + V := PaxCompilerDebugger1.GetValueAsString(StackFrameNumber, Id); + S := PaxCompilerExplorer1.Names[Id] + '=' + V; + Memo2.Lines.Add(S); + + if Pos('X', S) > 0 then + begin + PaxCompilerDebugger1.PutValue(StackFrameNumber, Id, 258); + + V := PaxCompilerDebugger1.GetValueAsString(StackFrameNumber, Id); + S := PaxCompilerExplorer1.Names[Id] + '=' + V; + S := S + ' // modified'; + Memo2.Lines.Add(S); + end; + + AddFields(StackFrameNumber, Id); + AddPublishedProps(StackFrameNumber, Id); + AddArrayElements(StackFrameNumber, Id); + AddDynArrayElements(StackFrameNumber, Id); + end; + + Memo2.Lines.Add('------------------------------------------------------'); + end; + + Memo2.Lines.Add('Global scope:'); + K := PaxCompilerExplorer1.GetGlobalCount(0); + for J:=0 to K - 1 do + begin + Id := PaxCompilerExplorer1.GetGlobalId(0, J); + V := PaxCompilerDebugger1.GetValueAsString(Id); + S := PaxCompilerExplorer1.Names[Id] + '=' + V; + Memo2.Lines.Add(S); + + AddFields(0, Id); + AddPublishedProps(0, Id); + AddArrayElements(0, Id); + AddDynArrayElements(0, Id); + end; + Memo2.Lines.Add('------------------------------------------------------'); + + end + else + Memo2.Lines.Add('Finished'); + + Memo2.SelStart := 0; + Memo2.SelLength := 0; +end; + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/DebugDemo/Unit2.dfm b/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/DebugDemo/Unit2.dfm new file mode 100644 index 0000000..c01f34c --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/DebugDemo/Unit2.dfm @@ -0,0 +1,43 @@ +object Form2: TForm2 + Left = 551 + Top = 252 + Width = 384 + Height = 345 + Caption = 'Select line' + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + PixelsPerInch = 96 + TextHeight = 13 + object Panel1: TPanel + Left = 0 + Top = 270 + Width = 376 + Height = 41 + Align = alBottom + TabOrder = 0 + object Button1: TButton + Left = 8 + Top = 8 + Width = 75 + Height = 25 + Caption = 'Ok' + ModalResult = 1 + TabOrder = 0 + OnClick = Button1Click + end + end + object ListBox1: TListBox + Left = 0 + Top = 0 + Width = 376 + Height = 270 + Align = alClient + ItemHeight = 13 + TabOrder = 1 + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/DebugDemo/Unit2.pas b/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/DebugDemo/Unit2.pas new file mode 100644 index 0000000..e1e87d9 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/DebugDemo/Unit2.pas @@ -0,0 +1,65 @@ +unit Unit2; + +interface + +uses + Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, ExtCtrls; + +type + TForm2 = class(TForm) + Panel1: TPanel; + ListBox1: TListBox; + Button1: TButton; + procedure Button1Click(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + function ShowModal: Integer; override; + end; + +var + Form2: TForm2; + +implementation + +uses Unit1; + +{$R *.dfm} + +function TForm2.ShowModal: Integer; +var + I: Integer; + S: String; + ch: Char; +begin + ListBox1.Items.Clear; + for I:=0 to Form1.Memo1.Lines.Count - 1 do + begin + if Form1.PaxCompilerExplorer1.IsExecutableLine('1', I) then + ch := '*' + else + ch := ' '; + S := Format('%3d ', [I]) + ch + ' ' + Form1.Memo1.Lines[I]; + ListBox1.Items.Add(S); + end; + + result := inherited ShowModal; +end; + +procedure TForm2.Button1Click(Sender: TObject); +var + I: Integer; +begin + I := ListBox1.ItemIndex; + if Form1.PaxCompilerExplorer1.IsExecutableLine('1', I) then + Form1.PaxCompilerDebugger1.AddTempBreakpoint('1', I) + else + begin + ShowMessage(IntToStr(I) + ' is not executable line!'); + ModalResult := mrCancel; + end; +end; + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/EvalExpression/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/EvalExpression/Project1.dpr new file mode 100644 index 0000000..513a1dd --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/EvalExpression/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/EvalExpression/Project1.res b/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/EvalExpression/Project1.res new file mode 100644 index 0000000..3adc036 Binary files /dev/null and b/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/EvalExpression/Project1.res differ diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/EvalExpression/Unit1.dfm b/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/EvalExpression/Unit1.dfm new file mode 100644 index 0000000..cde7bc7 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/EvalExpression/Unit1.dfm @@ -0,0 +1,43 @@ +object Form1: TForm1 + Left = 192 + Top = 115 + Caption = 'Eval Expression' + ClientHeight = 142 + ClientWidth = 326 + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -14 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + OnCreate = FormCreate + PixelsPerInch = 120 + TextHeight = 16 + object Button1: TButton + Left = 30 + Top = 30 + Width = 247 + Height = 30 + Margins.Left = 4 + Margins.Top = 4 + Margins.Right = 4 + Margins.Bottom = 4 + Caption = 'Create compiled expression' + TabOrder = 0 + OnClick = Button1Click + end + object Button2: TButton + Left = 30 + Top = 79 + Width = 247 + Height = 31 + Margins.Left = 4 + Margins.Top = 4 + Margins.Right = 4 + Margins.Bottom = 4 + Caption = 'Evaluate expression' + TabOrder = 1 + OnClick = Button2Click + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/EvalExpression/Unit1.pas b/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/EvalExpression/Unit1.pas new file mode 100644 index 0000000..25e4cfb --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/EvalExpression/Unit1.pas @@ -0,0 +1,116 @@ +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, PaxCompiler, PaxInterpreter, PaxRegister, + PaxJavaScriptLanguage; + +type + TForm1 = class(TForm) + Button1: TButton; + Button2: TButton; + procedure Button1Click(Sender: TObject); + procedure Button2Click(Sender: TObject); + procedure FormCreate(Sender: TObject); + private + { Private declarations } + arr_x, arr_y: array[1..3] of Double; + h_norm, h_x, h_y: Integer; + + buff: array[1..40960] of Byte; + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.dfm} + +function Norm(x, y: Double): Double; +begin + result := Sqrt(x * x + y * y); +end; + +procedure TForm1.Button1Click(Sender: TObject); +var + PaxCompiler1: TPaxCompiler; + PaxJavaScriptLanguage1: TPaxJavaScriptLanguage; + PaxInterpreter1: TPaxInterpreter; + I: Integer; +begin + PaxCompiler1 := TPaxCompiler.Create(nil); + PaxJavaScriptLanguage1 := TPaxJavaScriptLanguage.Create(nil); + PaxInterpreter1 := TPaxInterpreter.Create(nil); + + try + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxJavaScriptLanguage1); + + h_norm := PaxCompiler1.RegisterHeader(0, 'function Norm(x, y: Double): Double;'); + + h_x := PaxCompiler1.RegisterVariable(0, 'x', _typeDOUBLE); + h_y := PaxCompiler1.RegisterVariable(0, 'y', _typeDOUBLE); + + if PaxCompiler1.CompileExpression('Norm(x, y)', PaxInterpreter1) then + begin + PaxInterpreter1.SaveToBuff(buff); + ShowMessage('Compiled expression has been created!'); + end + else + for I:=0 to PaxCompiler1.ErrorCount - 1 do + ShowMessage(PaxCompiler1.ErrorMessage[I]); + finally + PaxCompiler1.Free; + PaxJavaScriptLanguage1.Free; + PaxInterpreter1.Free; + end; +end; + +procedure TForm1.Button2Click(Sender: TObject); +var + PaxInterpreter1: TPaxInterpreter; + ResValue: Double; + I: Integer; +begin +{$O-} + if h_x <> 0 then + begin + PaxInterpreter1 := TPaxInterpreter.Create(nil); + try + PaxInterpreter1.LoadFromBuff(buff); + + PaxInterpreter1.SetAddress(h_norm, @norm); + + for I:=1 to 3 do + begin + PaxInterpreter1.SetAddress(h_x, @arr_x[I]); + PaxInterpreter1.SetAddress(h_y, @arr_y[I]); + + PaxInterpreter1.Run; + + ResValue := Double(PaxInterpreter1.ResultPtr^); + ShowMessage(FloatToStr(ResValue)); + end; + + finally + PaxInterpreter1.Free; + end; + end + else + ShowMessage('Press the first button to create compiled script.'); +end; + +procedure TForm1.FormCreate(Sender: TObject); +begin + h_x := 0; h_y := 0; h_norm := 0; + arr_x[1] := 4.2; arr_y[1] := -5.2; + arr_x[2] := -0.4; arr_y[2] := 3.2; + arr_x[3] := 2.0; arr_y[3] := 3; +end; + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/Hello/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/Hello/Project1.dpr new file mode 100644 index 0000000..513a1dd --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/Hello/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/Hello/Project1.res b/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/Hello/Project1.res new file mode 100644 index 0000000..3adc036 Binary files /dev/null and b/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/Hello/Project1.res differ diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/Hello/Unit1.dfm b/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/Hello/Unit1.dfm new file mode 100644 index 0000000..8452e52 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/Hello/Unit1.dfm @@ -0,0 +1,44 @@ +object Form1: TForm1 + Left = 192 + Top = 114 + Caption = 'HelloApp' + ClientHeight = 164 + ClientWidth = 290 + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -14 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + PixelsPerInch = 120 + TextHeight = 16 + object Button1: TButton + Left = 39 + Top = 98 + Width = 93 + Height = 31 + Margins.Left = 4 + Margins.Top = 4 + Margins.Right = 4 + Margins.Bottom = 4 + Caption = 'Say "Hello"' + TabOrder = 0 + OnClick = Button1Click + end + object PaxCompiler1: TPaxCompiler + Alignment = 1 + DebugMode = False + Left = 48 + Top = 24 + end + object PaxJavaScriptLanguage1: TPaxJavaScriptLanguage + Left = 152 + Top = 72 + end + object PaxInterpreter1: TPaxInterpreter + Console = False + Left = 208 + Top = 32 + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/Hello/Unit1.pas b/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/Hello/Unit1.pas new file mode 100644 index 0000000..19fb707 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/Hello/Unit1.pas @@ -0,0 +1,49 @@ +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, PaxCompiler, PaxInterpreter, + PaxJavaScriptLanguage, PaxRunner; +type + TForm1 = class(TForm) + PaxCompiler1: TPaxCompiler; + Button1: TButton; + PaxJavaScriptLanguage1: TPaxJavaScriptLanguage; + PaxInterpreter1: TPaxInterpreter; + procedure Button1Click(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.dfm} + +procedure TForm1.Button1Click(Sender: TObject); +var + I, H_TButton: Integer; +begin + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxJavaScriptLanguage1); + + H_TButton := PaxCompiler1.RegisterClassType(0, TButton); + PaxCompiler1.RegisterVariable(0, 'Button1', H_TButton, @Button1); + + PaxCompiler1.AddModule('1', PaxJavaScriptLanguage1.LanguageName); + PaxCompiler1.AddCode('1', 'Button1.Caption = "Hello";'); + + if PaxCompiler1.Compile(PaxInterpreter1) then + PaxInterpreter1.Run + else + for I:=0 to PaxCompiler1.ErrorCount - 1 do + ShowMessage(PaxCompiler1.ErrorMessage[I]); +end; + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/LoadCompiledScript/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/LoadCompiledScript/Project1.dpr new file mode 100644 index 0000000..513a1dd --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/LoadCompiledScript/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/LoadCompiledScript/Project1.res b/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/LoadCompiledScript/Project1.res new file mode 100644 index 0000000..3adc036 Binary files /dev/null and b/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/LoadCompiledScript/Project1.res differ diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/LoadCompiledScript/Unit1.dfm b/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/LoadCompiledScript/Unit1.dfm new file mode 100644 index 0000000..85bb875 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/LoadCompiledScript/Unit1.dfm @@ -0,0 +1,43 @@ +object Form1: TForm1 + Left = 192 + Top = 114 + Caption = 'Load compiled script demo' + ClientHeight = 207 + ClientWidth = 341 + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -14 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + OnCreate = FormCreate + PixelsPerInch = 120 + TextHeight = 16 + object Button1: TButton + Left = 49 + Top = 49 + Width = 238 + Height = 31 + Margins.Left = 4 + Margins.Top = 4 + Margins.Right = 4 + Margins.Bottom = 4 + Caption = 'Compile script. Save compile script.' + TabOrder = 0 + OnClick = Button1Click + end + object Button2: TButton + Left = 49 + Top = 118 + Width = 238 + Height = 31 + Margins.Left = 4 + Margins.Top = 4 + Margins.Right = 4 + Margins.Bottom = 4 + Caption = 'Load compiled script. Run script.' + TabOrder = 1 + OnClick = Button2Click + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/LoadCompiledScript/Unit1.pas b/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/LoadCompiledScript/Unit1.pas new file mode 100644 index 0000000..210a4ea --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/LoadCompiledScript/Unit1.pas @@ -0,0 +1,118 @@ +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, PaxCompiler, PaxInterpreter, PaxRegister, PaxRunner, + PaxJavaScriptLanguage; +type + TForm1 = class(TForm) + Button1: TButton; + Button2: TButton; + procedure Button1Click(Sender: TObject); + procedure Button2Click(Sender: TObject); + procedure FormCreate(Sender: TObject); + private + H_ShowMessage: Integer; + H_S: Integer; + S: AnsiString; + { Private declarations } + procedure SaveToStreamHandler(Sender: TPaxRunner; Stream: TStream); + procedure LoadFromStreamHandler(Sender: TPaxRunner; Stream: TStream); + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.dfm} + +procedure TForm1.SaveToStreamHandler(Sender: TPaxRunner; Stream: TStream); +var + I: Byte; +begin + I := 5; + Stream.Write(I, 1); + ShowMessage('Saved custom data : ' + IntToStr(I)); +end; + +procedure TForm1.LoadFromStreamHandler(Sender: TPaxRunner; Stream: TStream); +var + I: Byte; +begin + Stream.Read(I, 1); + ShowMessage('Loaded custom data : ' + IntToStr(I)); +end; + +procedure TForm1.Button1Click(Sender: TObject); +var + I: Integer; + PaxCompiler1: TPaxCompiler; + PaxJavaScriptLanguage1: TPaxJavaScriptLanguage; + PaxInterpreter1: TPaxInterpreter; +begin + PaxCompiler1 := TPaxCompiler.Create(nil); + PaxJavaScriptLanguage1 := TPaxJavaScriptLanguage.Create(nil); + PaxInterpreter1 := TPaxInterpreter.Create(nil); + + try + PaxCompiler1.RegisterLanguage(PaxJavaScriptLanguage1); + + // register routine 'ShowMessage' + H_ShowMessage := PaxCompiler1.RegisterHeader(0, 'procedure ShowMessage(const Msg: string);'); + + // register variable 'S' + H_S := PaxCompiler1.RegisterVariable(0, 'S', _typeSTRING); + + PaxCompiler1.AddModule('1', PaxJavaScriptLanguage1.LanguageName); + PaxCompiler1.AddCode('1', 'ShowMessage(S);'); + + if PaxCompiler1.Compile(PaxInterpreter1) then + begin + PaxInterpreter1.OnSaveToStream := SaveToStreamHandler; + PaxInterpreter1.SaveToFile('1.bin'); + ShowMessage('Compiled script has been created!'); + end + else + for I:=0 to PaxCompiler1.ErrorCount - 1 do + ShowMessage(PaxCompiler1.ErrorMessage[I]); + finally + PaxCompiler1.Free; + PaxJavaScriptLanguage1.Free; + PaxInterpreter1.Free; + end; +end; + +procedure TForm1.Button2Click(Sender: TObject); +var + PaxInterpreter1: TPaxInterpreter; +begin + if FileExists('1.bin') and (H_ShowMessage <> 0) and (H_S <> 0) then + begin + PaxInterpreter1 := TPaxInterpreter.Create(nil); + try + PaxInterpreter1.OnLoadFromStream := LoadFromStreamHandler; + PaxInterpreter1.LoadFromFile('1.bin'); + PaxInterpreter1.SetAddress(H_ShowMessage, @ShowMessage); + PaxInterpreter1.SetAddress(H_S, @S); + PaxInterpreter1.Run; + finally + PaxInterpreter1.Free; + end; + end + else + ShowMessage('Press the first button to create compiled script.'); +end; + +procedure TForm1.FormCreate(Sender: TObject); +begin + H_ShowMessage := 0; + H_S := 0; + S := 'Hello'; +end; + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/RegisterVariable/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/RegisterVariable/Project1.dpr new file mode 100644 index 0000000..513a1dd --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/RegisterVariable/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/RegisterVariable/Project1.res b/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/RegisterVariable/Project1.res new file mode 100644 index 0000000..3adc036 Binary files /dev/null and b/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/RegisterVariable/Project1.res differ diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/RegisterVariable/Unit1.dfm b/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/RegisterVariable/Unit1.dfm new file mode 100644 index 0000000..3fb5b7a --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/RegisterVariable/Unit1.dfm @@ -0,0 +1,44 @@ +object Form1: TForm1 + Left = 192 + Top = 114 + Caption = 'Register variable demo' + ClientHeight = 171 + ClientWidth = 327 + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -14 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + PixelsPerInch = 120 + TextHeight = 16 + object Button1: TButton + Left = 49 + Top = 98 + Width = 93 + Height = 31 + Margins.Left = 4 + Margins.Top = 4 + Margins.Right = 4 + Margins.Bottom = 4 + Caption = 'Run' + TabOrder = 0 + OnClick = Button1Click + end + object PaxCompiler1: TPaxCompiler + Alignment = 1 + DebugMode = False + Left = 32 + Top = 16 + end + object PaxJavaScriptLanguage1: TPaxJavaScriptLanguage + Left = 80 + Top = 16 + end + object PaxInterpreter1: TPaxInterpreter + Console = False + Left = 160 + Top = 96 + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/RegisterVariable/Unit1.pas b/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/RegisterVariable/Unit1.pas new file mode 100644 index 0000000..b08ca0d --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/JavaScript/RegisterVariable/Unit1.pas @@ -0,0 +1,68 @@ +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, PaxCompiler, PaxInterpreter, PaxRegister, PaxJavaScriptLanguage, + PaxRunner; + +type + TForm1 = class(TForm) + PaxCompiler1: TPaxCompiler; + Button1: TButton; + PaxJavaScriptLanguage1: TPaxJavaScriptLanguage; + PaxInterpreter1: TPaxInterpreter; + procedure Button1Click(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.dfm} + +type + TMyPoint = packed record + x, y: Integer; + end; + +procedure TForm1.Button1Click(Sender: TObject); +var + H_TMyPoint, H_MyPoint: Integer; + MyPoint: TMyPoint; + I: Integer; +begin + MyPoint.X := 60; + MyPoint.Y := 23; + + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxJavaScriptLanguage1); + + // register host-defined type + H_TMyPoint := PaxCompiler1.RegisterRecordType(0, 'TMyPoint'); + PaxCompiler1.RegisterRecordTypeField(H_TMyPoint, 'X', _typeINTEGER); + PaxCompiler1.RegisterRecordTypeField(H_TMyPoint, 'Y', _typeINTEGER); + + // register host-defined variable + H_MyPoint := PaxCompiler1.RegisterVariable(0, 'MyPoint', H_TMyPoint, @MyPoint); + + PaxCompiler1.AddModule('1', PaxJavaScriptLanguage1.LanguageName); + PaxCompiler1.AddCode('1', 'MyPoint.Y = 8;'); + + if PaxCompiler1.Compile(PaxInterpreter1) then + begin + PaxInterpreter1.Run; + ShowMessage(IntToStr(MyPoint.Y)); + end + else + for I:=0 to PaxCompiler1.ErrorCount do + ShowMessage(PaxCompiler1.ErrorMessage[I]); +end; + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/AccessToScriptVariables/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/AccessToScriptVariables/Project1.dpr new file mode 100644 index 0000000..513a1dd --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/AccessToScriptVariables/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/AccessToScriptVariables/Project1.res b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/AccessToScriptVariables/Project1.res new file mode 100644 index 0000000..3adc036 Binary files /dev/null and b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/AccessToScriptVariables/Project1.res differ diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/AccessToScriptVariables/Unit1.dfm b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/AccessToScriptVariables/Unit1.dfm new file mode 100644 index 0000000..d486543 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/AccessToScriptVariables/Unit1.dfm @@ -0,0 +1,49 @@ +object Form1: TForm1 + Left = 277 + Top = 120 + Caption = 'Access to script-defined variables' + ClientHeight = 164 + ClientWidth = 290 + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -14 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + PixelsPerInch = 120 + TextHeight = 16 + object Button1: TButton + Left = 39 + Top = 98 + Width = 93 + Height = 31 + Margins.Left = 4 + Margins.Top = 4 + Margins.Right = 4 + Margins.Bottom = 4 + Caption = 'Run' + TabOrder = 0 + OnClick = Button1Click + end + object PaxCompiler1: TPaxCompiler + Alignment = 1 + DebugMode = False + Left = 40 + Top = 24 + end + object PaxPascalLanguage1: TPaxPascalLanguage + ExplicitOff = False + CompleteBooleanEval = False + UnitLookup = True + PrintKeyword = 'print' + PrintlnKeyword = 'println' + Left = 88 + Top = 24 + end + object PaxInterpreter1: TPaxInterpreter + Console = False + Left = 144 + Top = 88 + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/AccessToScriptVariables/Unit1.pas b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/AccessToScriptVariables/Unit1.pas new file mode 100644 index 0000000..3bf9a03 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/AccessToScriptVariables/Unit1.pas @@ -0,0 +1,60 @@ +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, PaxCompiler, PaxInterpreter, PaxRunner; +type + TForm1 = class(TForm) + Button1: TButton; + PaxCompiler1: TPaxCompiler; + PaxPascalLanguage1: TPaxPascalLanguage; + PaxInterpreter1: TPaxInterpreter; + procedure Button1Click(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.dfm} + +procedure TForm1.Button1Click(Sender: TObject); +var + P: Pointer; + I: Integer; +begin + {$O-} + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + + PaxCompiler1.RegisterHeader(0, 'procedure ShowMessage(const Msg: string);', @ShowMessage); + PaxCompiler1.RegisterHeader(0, 'function IntToStr(Value: Integer): string;', @IntToStr); + + PaxCompiler1.AddModule('1', PaxPascalLanguage1.LanguageName); + PaxCompiler1.AddCode('1', 'var x: Integer;'); + PaxCompiler1.AddCode('1', 'begin'); + PaxCompiler1.AddCode('1', ' ShowMessage(''script:'' + IntToStr(x));'); + PaxCompiler1.AddCode('1', 'end.'); + + if PaxCompiler1.Compile(PaxInterpreter1) then + begin + P := PaxInterpreter1.GetAddress('x'); + Integer(P^) := 5; // change script-defind variable + PaxInterpreter1.Run; // the first run + ShowMessage('host:' + IntToStr(Integer(P^))); // show script-defined var + Integer(P^) := 30; // change script-defind variable + PaxInterpreter1.Run; // the second run + end + else + for I:=0 to PaxCompiler1.ErrorCount do + ShowMessage(PaxCompiler1.ErrorMessage[I]); +end; + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/BindDFM/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/BindDFM/Project1.dpr new file mode 100644 index 0000000..513a1dd --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/BindDFM/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/BindDFM/Project1.res b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/BindDFM/Project1.res new file mode 100644 index 0000000..3adc036 Binary files /dev/null and b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/BindDFM/Project1.res differ diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/BindDFM/Unit1.dfm b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/BindDFM/Unit1.dfm new file mode 100644 index 0000000..171bb92 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/BindDFM/Unit1.dfm @@ -0,0 +1,65 @@ +object Form1: TForm1 + Left = 469 + Top = 227 + Width = 442 + Height = 255 + Caption = 'Form1' + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'Tahoma' + Font.Style = [] + OldCreateOrder = False + PixelsPerInch = 96 + TextHeight = 13 + object Button1: TButton + Left = 16 + Top = 24 + Width = 75 + Height = 25 + Caption = 'Run' + TabOrder = 0 + OnClick = Button1Click + end + object Memo1: TMemo + Left = 112 + Top = 16 + Width = 297 + Height = 185 + Lines.Strings = ( + 'uses' + ' Unit2;' + 'begin' + ' Form2 := TForm2.Create(nil);' + ' try' + ' Form2.ShowModal;' + ' finally' + ' Form2.Free; ' + ' end;' + 'end.') + TabOrder = 1 + end + object PaxCompiler1: TPaxCompiler + Alignment = 1 + OnUnknownDirective = PaxCompiler1UnknownDirective + DebugMode = False + Left = 24 + Top = 64 + end + object PaxPascalLanguage1: TPaxPascalLanguage + ExplicitOff = False + CompleteBooleanEval = False + UnitLookup = True + PrintKeyword = 'print' + PrintlnKeyword = 'println' + Left = 24 + Top = 104 + end + object PaxInterpreter1: TPaxInterpreter + Console = False + OnCreateObject = PaxInterpreter1CreateObject + Left = 24 + Top = 144 + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/BindDFM/Unit1.pas b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/BindDFM/Unit1.pas new file mode 100644 index 0000000..2f8372d --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/BindDFM/Unit1.pas @@ -0,0 +1,72 @@ +{$O-} +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, + Dialogs, PaxInterpreter, PaxCompiler, StdCtrls, PaxRunner; + +type + TForm1 = class(TForm) + Button1: TButton; + PaxCompiler1: TPaxCompiler; + PaxPascalLanguage1: TPaxPascalLanguage; + PaxInterpreter1: TPaxInterpreter; + Memo1: TMemo; + procedure Button1Click(Sender: TObject); + procedure PaxCompiler1UnknownDirective(Sender: TPaxCompiler; + const Directive: string; var ok: Boolean); + procedure PaxInterpreter1CreateObject(Sender: TPaxRunner; + Instance: TObject); + private + CurrModule: String; + { Private declarations } + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.dfm} + +uses + PAXCOMP_SYS, + IMPORT_Common; + +procedure TForm1.Button1Click(Sender: TObject); +begin + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + PaxCompiler1.AddModule('1', 'Pascal'); + PaxCompiler1.AddCode('1', Memo1.Lines.Text); + if PaxCompiler1.Compile(PaxInterpreter1) then + begin + PaxInterpreter1.Run; + end + else + ShowMessage(PaxCompiler1.ErrorMessage[0]); +end; + +procedure TForm1.PaxCompiler1UnknownDirective(Sender: TPaxCompiler; + const Directive: string; var ok: Boolean); +begin + ok := true; + CurrModule := Sender.CurrModuleName; +end; + +{$O-} +procedure TForm1.PaxInterpreter1CreateObject(Sender: TPaxRunner; + Instance: TObject); +var + P: PVmtMethodTable; +begin + P := GetMethodTable(Instance.ClassType); + if Instance is TForm then + Sender.LoadDFMFile(Instance, CurrModule + '.dfm'); +end; + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/BindDFM/Unit2.dfm b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/BindDFM/Unit2.dfm new file mode 100644 index 0000000..157880d --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/BindDFM/Unit2.dfm @@ -0,0 +1,27 @@ +object Form2: TForm2 + Left = 0 + Top = 0 + Caption = 'Form2' + ClientHeight = 282 + ClientWidth = 557 + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -14 + Font.Name = 'Tahoma' + Font.Style = [] + OldCreateOrder = False + OnCreate = FormCreate + OnMouseDown = FormMouseDown + PixelsPerInch = 120 + TextHeight = 17 + object Button1: TButton + Left = 52 + Top = 115 + Width = 98 + Height = 33 + Caption = 'Click me' + TabOrder = 0 + OnClick = Button1Click + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/BindDFM/Unit2.pas b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/BindDFM/Unit2.pas new file mode 100644 index 0000000..453b4b7 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/BindDFM/Unit2.pas @@ -0,0 +1,47 @@ +unit Unit2; + +interface + +uses + SysUtils, Variants, Classes, Controls, Forms, + Dialogs, StdCtrls; + +type + TForm2 = class(TForm) + Button1: TButton; + procedure FormCreate(Sender: TObject); + procedure Button1Click(Sender: TObject); + procedure FormMouseDown(Sender: TObject; Button: TMouseButton; + Shift: TShiftState; X, Y: Integer); + private + { Private declarations } + public + { Public declarations } + end; + +var + Form2: TForm2; + +implementation + +{$R *.dfm} + +procedure TForm2.Button1Click(Sender: TObject); +begin + ShowMessage(ClassName + ', ' + Sender.ClassName + ': Hello'); +end; + +procedure TForm2.FormCreate(Sender: TObject); +begin + ShowMessage(ClassName + ', ' + Sender.ClassName + ': Created'); +end; + +procedure TForm2.FormMouseDown(Sender: TObject; Button: TMouseButton; + Shift: TShiftState; X, Y: Integer); +begin + ShowMessage(Sender.ClassName); + ShowMessage(IntToStr(X)); + ShowMessage(IntToStr(Y)); +end; + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/Breakpoints/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/Breakpoints/Project1.dpr new file mode 100644 index 0000000..513a1dd --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/Breakpoints/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/Breakpoints/Project1.res b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/Breakpoints/Project1.res new file mode 100644 index 0000000..3adc036 Binary files /dev/null and b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/Breakpoints/Project1.res differ diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/Breakpoints/Unit1.dfm b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/Breakpoints/Unit1.dfm new file mode 100644 index 0000000..629ab7a --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/Breakpoints/Unit1.dfm @@ -0,0 +1,177 @@ +object Form1: TForm1 + Left = 192 + Top = 114 + Caption = 'Form1' + ClientHeight = 549 + ClientWidth = 761 + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -14 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + PixelsPerInch = 120 + TextHeight = 16 + object Label1: TLabel + Left = 30 + Top = 10 + Width = 60 + Height = 26 + Margins.Left = 4 + Margins.Top = 4 + Margins.Right = 4 + Margins.Bottom = 4 + Caption = 'Script:' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -23 + Font.Name = 'MS Sans Serif' + Font.Style = [] + ParentFont = False + end + object Label2: TLabel + Left = 30 + Top = 286 + Width = 70 + Height = 26 + Margins.Left = 4 + Margins.Top = 4 + Margins.Right = 4 + Margins.Bottom = 4 + Caption = 'Output:' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -23 + Font.Name = 'MS Sans Serif' + Font.Style = [] + ParentFont = False + end + object Label3: TLabel + Left = 354 + Top = 59 + Width = 206 + Height = 26 + Margins.Left = 4 + Margins.Top = 4 + Margins.Right = 4 + Margins.Bottom = 4 + Caption = 'Add breakpoint at line' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -23 + Font.Name = 'MS Sans Serif' + Font.Style = [] + ParentFont = False + end + object Memo1: TMemo + Left = 20 + Top = 49 + Width = 227 + Height = 218 + Margins.Left = 4 + Margins.Top = 4 + Margins.Right = 4 + Margins.Bottom = 4 + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -20 + Font.Name = 'MS Sans Serif' + Font.Style = [] + Lines.Strings = ( + 'begin // line 0' + ' print('#39'A'#39'); // line 1' + ' print('#39'B'#39'); // line 2' + ' print('#39'C'#39'); // line 3' + ' print('#39'D'#39'); // line 4' + ' print('#39'E'#39'); // line 5' + 'end. // line 6' + '') + ParentFont = False + TabOrder = 0 + end + object Memo2: TMemo + Left = 20 + Top = 315 + Width = 227 + Height = 208 + Margins.Left = 4 + Margins.Top = 4 + Margins.Right = 4 + Margins.Bottom = 4 + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -20 + Font.Name = 'MS Sans Serif' + Font.Style = [] + Lines.Strings = ( + '') + ParentFont = False + TabOrder = 1 + end + object Edit1: TEdit + Left = 591 + Top = 59 + Width = 50 + Height = 32 + Margins.Left = 4 + Margins.Top = 4 + Margins.Right = 4 + Margins.Bottom = 4 + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -20 + Font.Name = 'MS Sans Serif' + Font.Style = [] + ParentFont = False + TabOrder = 2 + Text = '2' + end + object Button1: TButton + Left = 374 + Top = 236 + Width = 188 + Height = 61 + Margins.Left = 4 + Margins.Top = 4 + Margins.Right = 4 + Margins.Bottom = 4 + Caption = 'Run script' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -23 + Font.Name = 'MS Sans Serif' + Font.Style = [] + ParentFont = False + TabOrder = 3 + OnClick = Button1Click + end + object PaxCompiler1: TPaxCompiler + Alignment = 1 + DebugMode = False + Left = 312 + Top = 304 + end + object PaxPascalLanguage1: TPaxPascalLanguage + ExplicitOff = False + CompleteBooleanEval = False + UnitLookup = True + PrintKeyword = 'print' + PrintlnKeyword = 'println' + Left = 360 + Top = 304 + end + object PaxCompilerDebugger1: TPaxCompilerDebugger + Left = 432 + Top = 304 + end + object PaxCompilerExplorer1: TPaxCompilerExplorer + Left = 472 + Top = 304 + end + object PaxInterpreter1: TPaxInterpreter + Console = False + Left = 560 + Top = 296 + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/Breakpoints/Unit1.pas b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/Breakpoints/Unit1.pas new file mode 100644 index 0000000..4c33532 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/Breakpoints/Unit1.pas @@ -0,0 +1,84 @@ +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, PaxInterpreter, PaxCompiler, PaxCompilerDebugger, + PaxRegister, + PaxCompilerExplorer, PaxRunner; + +type + TForm1 = class(TForm) + Memo1: TMemo; + Memo2: TMemo; + Label1: TLabel; + Label2: TLabel; + Edit1: TEdit; + Label3: TLabel; + Button1: TButton; + PaxCompiler1: TPaxCompiler; + PaxPascalLanguage1: TPaxPascalLanguage; + PaxCompilerDebugger1: TPaxCompilerDebugger; + PaxCompilerExplorer1: TPaxCompilerExplorer; + PaxInterpreter1: TPaxInterpreter; + procedure Button1Click(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.dfm} + +procedure TForm1.Button1Click(Sender: TObject); +var + I: Integer; + Breakpoint: Integer; +begin + Memo2.Lines.Clear; + Breakpoint := StrToInt(Edit1.Text); + + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + + PaxCompiler1.AddModule('1', PaxPascalLanguage1.LanguageName); + PaxCompiler1.AddCode('1', Memo1.Lines.Text); + + PaxCompiler1.DebugMode := true; + + if PaxCompiler1.Compile(PaxInterpreter1) then + begin + PaxCompilerExplorer1.RegisterCompiler(PaxCompiler1); + PaxCompilerDebugger1.RegisterCompiler(PaxCompiler1, PaxInterpreter1); + if PaxCompilerExplorer1.IsExecutableLine('1', Breakpoint) then + PaxCompilerDebugger1.AddBreakpoint('1', Breakpoint); + + PaxCompilerDebugger1.Run; + while PaxCompilerDebugger1.IsPaused do + begin + ShowMessage('Program has been paused at breakpoint: ' + + IntToStr(PaxCompilerDebugger1.SourceLineNumber)); + + PaxInterpreter1.Run; + end; + end + else + for I:=0 to PaxCompiler1.ErrorCount - 1 do + ShowMessage(PaxCompiler1.ErrorMessage[I]); +end; + +procedure Print(C: Char); +begin + Form1.Memo2.Lines.Add(C); +end; + +initialization + +RegisterHeader(0, 'procedure Print(C: Char);', @Print); +end. diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/CallInterfaceMethod/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/CallInterfaceMethod/Project1.dpr new file mode 100644 index 0000000..2c5a02d --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/CallInterfaceMethod/Project1.dpr @@ -0,0 +1,65 @@ +{$APPTYPE CONSOLE} +{$O-} +program Project1; +uses + Classes, + PaxCompiler, PaxInterpreter, PaxRegister; + +type + IMyInterface = interface + ['{D13115CA-4D57-4242-A54B-3684870CC7B3}'] + function Add(X, Y: Integer): Integer; + end; + +procedure PassToHost(X: IMyInterface; P1, P2: Integer); +begin + writeln(X.Add(P1, P2)); +end; + +var + PaxCompiler1: TPaxCompiler; + PaxInterpreter1: TPaxInterpreter; + PaxPascalLanguage1: TPaxPascalLanguage; + I: Integer; +begin + I := RegisterInterfaceType(0, 'IMyInterface', IMyInterface); + RegisterHeader(I, + 'function Add(X, Y: Integer): Integer;', nil, -1); + + RegisterHeader(0, + 'procedure PassToHost(X: IMyInterface; P1, P2: Integer);', + @ PassToHost); + + PaxCompiler1 := TPaxCompiler.Create(nil); + PaxInterpreter1 := TPaxInterpreter.Create(nil); + PaxPascalLanguage1 := TPaxPascalLanguage.Create(nil); + try + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + PaxCompiler1.AddModule('1', 'Pascal'); + PaxCompiler1.AddCodeFromFile('1', 'script.txt'); + if PaxCompiler1.Compile(PaxInterpreter1) then + begin + PaxInterpreter1.Run; + end + else + begin + writeln(PaxCompiler1.ErrorMessage[0]); + writeln(PaxCompiler1.ErrorLineNumber[0]); + writeln(PaxCompiler1.ErrorLine[0]); + end; + + for I:=0 to PaxCompiler1.WarningCount - 1 do + begin + writeln(PaxCompiler1.WarningMessage[I]); + writeln(PaxCompiler1.WarningLineNumber[I]); + writeln(PaxCompiler1.WarningLine[I]); + end; + + finally + PaxCompiler1.Free; + PaxInterpreter1.Free; + PaxPascalLanguage1.Free; + end; + writeln('Press any key...'); + Readln; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/CallInterfaceMethod/script.txt b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/CallInterfaceMethod/script.txt new file mode 100644 index 0000000..6d24250 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/CallInterfaceMethod/script.txt @@ -0,0 +1,26 @@ +type + TMyScriptClass = class(TInterfacedObject, IMyInterface) + public + function Add(X, Y: Integer): Integer; + destructor Destroy; override; + end; + +function TMyScriptClass.Add(X, Y: Integer): Integer; +begin + writeln('Hello from script!'); + writeln(X, ' ', Y); + result := X + Y; +end; + +destructor TMyScriptClass.Destroy; +begin + writeln('Script object has been destroyed.'); + inherited; +end; + +var + X: TMyScriptClass; +begin + X := TMyScriptClass.Create; + PassToHost(X, 3, 4); +end. \ No newline at end of file diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/CallRoutine/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/CallRoutine/Project1.dpr new file mode 100644 index 0000000..513a1dd --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/CallRoutine/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/CallRoutine/Project1.dproj b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/CallRoutine/Project1.dproj new file mode 100644 index 0000000..7a8388a --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/CallRoutine/Project1.dproj @@ -0,0 +1,135 @@ + + + {91CB4EC8-833A-41EA-8C60-153FFE297B37} + Project1.dpr + True + Debug + 1153 + Application + VCL + 18.2 + Win32 + + + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Cfg_1 + true + true + + + true + Base + true + + + true + Cfg_2 + true + true + + + false + false + false + false + false + 00400000 + Project1 + Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;System;Xml;Data;Datasnap;Web;Soap;Winapi;$(DCC_Namespace) + 1040 + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=;CFBundleName= + + + Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) + Debug + true + CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(MSBuildProjectName) + 1033 + $(BDS)\bin\default_app.manifest + Project1_Icon.ico + true + $(BDS)\bin\Artwork\Windows\UWP\delphi_UwpDefault_44.png + $(BDS)\bin\Artwork\Windows\UWP\delphi_UwpDefault_150.png + + + Project1_Icon.ico + $(BDS)\bin\Artwork\Windows\UWP\delphi_UwpDefault_44.png + $(BDS)\bin\Artwork\Windows\UWP\delphi_UwpDefault_150.png + + + RELEASE;$(DCC_Define) + 0 + false + 0 + + + true + true + + + DEBUG;$(DCC_Define) + false + true + + + true + true + + + + MainSource + + +
Form1
+ + + Cfg_2 + Base + + + Base + + + Cfg_1 + Base + + + + Delphi.Personality.12 + + + + + Project1.dpr + + + + True + True + True + False + + + 12 + + + + diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/CallRoutine/Project1.res b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/CallRoutine/Project1.res new file mode 100644 index 0000000..dc7ed87 Binary files /dev/null and b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/CallRoutine/Project1.res differ diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/CallRoutine/Project1_Icon.ico b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/CallRoutine/Project1_Icon.ico new file mode 100644 index 0000000..cfd8992 Binary files /dev/null and b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/CallRoutine/Project1_Icon.ico differ diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/CallRoutine/Unit1.dfm b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/CallRoutine/Unit1.dfm new file mode 100644 index 0000000..72eb449 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/CallRoutine/Unit1.dfm @@ -0,0 +1,50 @@ +object Form1: TForm1 + Left = 192 + Top = 114 + Caption = 'Call routine demo' + ClientHeight = 146 + ClientWidth = 283 + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -14 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + OnCreate = FormCreate + PixelsPerInch = 120 + TextHeight = 16 + object Button1: TButton + Left = 49 + Top = 89 + Width = 149 + Height = 30 + Margins.Left = 4 + Margins.Top = 4 + Margins.Right = 4 + Margins.Bottom = 4 + Caption = 'Call ' + TabOrder = 0 + OnClick = Button1Click + end + object PaxCompiler1: TPaxCompiler + Alignment = 1 + DebugMode = False + Left = 32 + Top = 16 + end + object PaxPascalLanguage1: TPaxPascalLanguage + ExplicitOff = False + CompleteBooleanEval = False + UnitLookup = True + PrintKeyword = 'print' + PrintlnKeyword = 'println' + Left = 72 + Top = 16 + end + object PaxInterpreter1: TPaxInterpreter + Console = False + Left = 120 + Top = 16 + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/CallRoutine/Unit1.pas b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/CallRoutine/Unit1.pas new file mode 100644 index 0000000..d386742 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/CallRoutine/Unit1.pas @@ -0,0 +1,69 @@ +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, PaxCompiler, PaxInterpreter, PaxRegister, PaxRunner; +type + TForm1 = class(TForm) + PaxCompiler1: TPaxCompiler; + PaxPascalLanguage1: TPaxPascalLanguage; + Button1: TButton; + PaxInterpreter1: TPaxInterpreter; + procedure Button1Click(Sender: TObject); + procedure FormCreate(Sender: TObject); + private + Y: Integer; + { Private declarations } + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.dfm} + +procedure TForm1.Button1Click(Sender: TObject); +var + I: Integer; + P: Pointer; +begin +{$O-} + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + + PaxCompiler1.RegisterVariable(0, 'Y', _typeINTEGER, @Y); + + PaxCompiler1.AddModule('1', PaxPascalLanguage1.LanguageName); + PaxCompiler1.AddCode('1', 'procedure P(X: Integer);'); + PaxCompiler1.AddCode('1', 'begin'); + PaxCompiler1.AddCode('1', ' Y := Y + X;'); + PaxCompiler1.AddCode('1', 'end;'); + PaxCompiler1.AddCode('1', 'begin'); + PaxCompiler1.AddCode('1', 'end.'); + + if PaxCompiler1.Compile(PaxInterpreter1) then + begin + PaxInterpreter1.RunInitialization; + + PaxInterpreter1.CallRoutine('P', [10]); // call it + ShowMessage(IntToStr(Y)); + + PaxInterpreter1.CallRoutine('P', [20]); // call it + ShowMessage(IntToStr(Y)); + end + else + for I:=0 to PaxCompiler1.ErrorCount do + ShowMessage(PaxCompiler1.ErrorMessage[I]); +end; + +procedure TForm1.FormCreate(Sender: TObject); +begin + Y := 0; +end; + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/DebugDemo/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/DebugDemo/Project1.dpr new file mode 100644 index 0000000..cebc69a --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/DebugDemo/Project1.dpr @@ -0,0 +1,15 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}, + Unit2 in 'Unit2.pas' {Form2}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.CreateForm(TForm2, Form2); + Application.Run; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/DebugDemo/Project1.res b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/DebugDemo/Project1.res new file mode 100644 index 0000000..3adc036 Binary files /dev/null and b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/DebugDemo/Project1.res differ diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/DebugDemo/Unit1.dfm b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/DebugDemo/Unit1.dfm new file mode 100644 index 0000000..b9b0f8e --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/DebugDemo/Unit1.dfm @@ -0,0 +1,225 @@ +object Form1: TForm1 + Left = 209 + Top = 111 + Caption = 'DebugDemo' + ClientHeight = 567 + ClientWidth = 745 + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -14 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + OnCloseQuery = FormCloseQuery + PixelsPerInch = 120 + TextHeight = 16 + object Label1: TLabel + Left = 30 + Top = 10 + Width = 60 + Height = 26 + Margins.Left = 2 + Margins.Top = 2 + Margins.Right = 2 + Margins.Bottom = 2 + Caption = 'Script:' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -23 + Font.Name = 'MS Sans Serif' + Font.Style = [] + ParentFont = False + end + object Label2: TLabel + Left = 30 + Top = 394 + Width = 62 + Height = 26 + Margins.Left = 2 + Margins.Top = 2 + Margins.Right = 2 + Margins.Bottom = 2 + Caption = 'Trace:' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -23 + Font.Name = 'MS Sans Serif' + Font.Style = [] + ParentFont = False + end + object Memo1: TMemo + Left = 20 + Top = 49 + Width = 445 + Height = 336 + Margins.Left = 2 + Margins.Top = 2 + Margins.Right = 2 + Margins.Bottom = 2 + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -18 + Font.Name = 'MS Sans Serif' + Font.Style = [] + Lines.Strings = ( + 'function Fact(N: Integer): Integer;' + 'begin' + ' if N = 1 then' + ' result := 1' + ' else' + ' result := N * Fact(N - 1);' + 'end;' + 'var' + ' SS: Integer;' + 'begin' + ' SS := Fact(3);' + ' print(SS);' + 'end.') + ParentFont = False + TabOrder = 0 + end + object Memo2: TMemo + Left = 20 + Top = 433 + Width = 513 + Height = 267 + Margins.Left = 2 + Margins.Top = 2 + Margins.Right = 2 + Margins.Bottom = 2 + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -18 + Font.Name = 'MS Sans Serif' + Font.Style = [] + Lines.Strings = ( + '') + ParentFont = False + TabOrder = 1 + end + object Button1: TButton + Left = 482 + Top = 31 + Width = 238 + Height = 60 + Margins.Left = 2 + Margins.Top = 2 + Margins.Right = 2 + Margins.Bottom = 2 + Caption = 'Compile' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -23 + Font.Name = 'MS Sans Serif' + Font.Style = [] + ParentFont = False + TabOrder = 2 + OnClick = Button1Click + end + object Button2: TButton + Left = 482 + Top = 110 + Width = 238 + Height = 60 + Margins.Left = 2 + Margins.Top = 2 + Margins.Right = 2 + Margins.Bottom = 2 + Caption = 'Run' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -23 + Font.Name = 'MS Sans Serif' + Font.Style = [] + ParentFont = False + TabOrder = 3 + OnClick = Button2Click + end + object Button3: TButton + Left = 482 + Top = 191 + Width = 238 + Height = 60 + Margins.Left = 2 + Margins.Top = 2 + Margins.Right = 2 + Margins.Bottom = 2 + Caption = 'Trace Into' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -23 + Font.Name = 'MS Sans Serif' + Font.Style = [] + ParentFont = False + TabOrder = 4 + OnClick = Button3Click + end + object Button4: TButton + Left = 482 + Top = 271 + Width = 238 + Height = 61 + Margins.Left = 2 + Margins.Top = 2 + Margins.Right = 2 + Margins.Bottom = 2 + Caption = 'Step Over' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -23 + Font.Name = 'MS Sans Serif' + Font.Style = [] + ParentFont = False + TabOrder = 5 + OnClick = Button4Click + end + object Button5: TButton + Left = 482 + Top = 338 + Width = 238 + Height = 60 + Margins.Left = 2 + Margins.Top = 2 + Margins.Right = 2 + Margins.Bottom = 2 + Caption = 'Run to Cursor' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -23 + Font.Name = 'MS Sans Serif' + Font.Style = [] + ParentFont = False + TabOrder = 6 + OnClick = Button5Click + end + object PaxCompiler1: TPaxCompiler + Alignment = 1 + DebugMode = False + Left = 184 + Top = 320 + end + object PaxPascalLanguage1: TPaxPascalLanguage + ExplicitOff = False + CompleteBooleanEval = False + UnitLookup = True + PrintKeyword = 'print' + PrintlnKeyword = 'println' + Left = 224 + Top = 320 + end + object PaxCompilerDebugger1: TPaxCompilerDebugger + Left = 312 + Top = 320 + end + object PaxCompilerExplorer1: TPaxCompilerExplorer + Left = 352 + Top = 320 + end + object PaxInterpreter1: TPaxInterpreter + Console = False + OnPauseUpdated = PaxInterpreter1PauseUpdated + Left = 256 + Top = 312 + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/DebugDemo/Unit1.pas b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/DebugDemo/Unit1.pas new file mode 100644 index 0000000..483cee9 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/DebugDemo/Unit1.pas @@ -0,0 +1,345 @@ +{$O-} +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, PaxInterpreter, PaxCompiler, PaxCompilerDebugger, + PaxRegister, + PaxCompilerExplorer, PaxRunner; + +type + TForm1 = class(TForm) + Memo1: TMemo; + Memo2: TMemo; + Label1: TLabel; + Label2: TLabel; + Button1: TButton; + PaxCompiler1: TPaxCompiler; + PaxPascalLanguage1: TPaxPascalLanguage; + Button2: TButton; + Button3: TButton; + Button4: TButton; + Button5: TButton; + PaxCompilerDebugger1: TPaxCompilerDebugger; + PaxCompilerExplorer1: TPaxCompilerExplorer; + PaxInterpreter1: TPaxInterpreter; + procedure Button1Click(Sender: TObject); + procedure Button2Click(Sender: TObject); + procedure Button3Click(Sender: TObject); + procedure Button4Click(Sender: TObject); + procedure Button5Click(Sender: TObject); + procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean); + procedure PaxInterpreter1PauseUpdated(Sender: TPaxRunner; + const ModuleName: string; SourceLineNumber: Integer); + private + { Private declarations } + ResumeRequest: Boolean; + CloseRequest: Boolean; + function TestValid: Boolean; + procedure UpdateDebugInfo; + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +uses Unit2; + +{$R *.dfm} + +procedure TForm1.Button1Click(Sender: TObject); +var + I: Integer; +begin + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + PaxPascalLanguage1.SetCallConv(_ccREGISTER); + PaxCompiler1.AddModule('1', PaxPascalLanguage1.LanguageName); + PaxCompiler1.AddCode('1', Memo1.Lines.Text); + PaxCompiler1.DebugMode := true; + if PaxCompiler1.Compile(PaxInterpreter1) then + begin + ShowMessage('Script has been successfully recompiled.'); + PaxCompilerExplorer1.RegisterCompiler(PaxCompiler1); + PaxCompilerDebugger1.RegisterCompiler(PaxCompiler1, PaxInterpreter1); + end + else + for I:=0 to PaxCompiler1.ErrorCount - 1 do + ShowMessage(PaxCompiler1.ErrorMessage[I]); +end; + +function TForm1.TestValid: Boolean; +begin + result := PaxCompilerDebugger1.Valid; + if not result then + ShowMessage('You have to compile script. Press "Compile" button.'); +end; + +procedure TForm1.Button2Click(Sender: TObject); +begin + if not TestValid then Exit; + + PaxCompilerDebugger1.RunMode := _rmRUN; + if PaxCompilerDebugger1.IsPaused then + ResumeRequest := true + else + PaxCompilerDebugger1.Run; +end; + +procedure TForm1.Button3Click(Sender: TObject); +begin + if not TestValid then Exit; + + PaxCompilerDebugger1.RunMode := _rmTRACE_INTO; + if PaxCompilerDebugger1.IsPaused then + ResumeRequest := true + else + PaxCompilerDebugger1.Run; +end; + +procedure TForm1.Button4Click(Sender: TObject); +begin + if not TestValid then Exit; + + PaxCompilerDebugger1.RunMode := _rmSTEP_OVER; + if PaxCompilerDebugger1.IsPaused then + ResumeRequest := true + else + PaxCompilerDebugger1.Run; +end; + +procedure TForm1.Button5Click(Sender: TObject); +begin + if not TestValid then Exit; + + Form2.ShowModal; + + PaxCompilerDebugger1.RunMode := _rmRUN_TO_CURSOR; + if PaxCompilerDebugger1.IsPaused then + ResumeRequest := true + else + PaxCompilerDebugger1.Run; +end; + +procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean); +begin + CanClose := true; + CloseRequest := true; +end; + +procedure TForm1.PaxInterpreter1PauseUpdated(Sender: TPaxRunner; + const ModuleName: string; SourceLineNumber: Integer); +begin + UpdateDebugInfo; + ResumeRequest := false; + repeat + Application.ProcessMessages; + if ResumeRequest then + Break; + if CloseRequest then + Abort; + until false; +end; + +procedure TForm1.UpdateDebugInfo; + + procedure AddFields(StackFrameNumber, Id: Integer); + var + I, K: Integer; + OwnerName, S: String; + begin + K := PaxCompilerExplorer1.GetFieldCount(Id); + if K = 0 then + Exit; + + OwnerName := PaxCompilerExplorer1.Names[Id]; + if PaxCompilerDebugger1.GetValueAsString(Id) = 'nil' then + Exit; + + for I:=0 to K - 1 do + begin + S := OwnerName + '.' + PaxCompilerExplorer1.GetFieldName(Id, I); + S := ' ' + S + '=' + PaxCompilerDebugger1.GetFieldValueAsString( + StackFrameNumber, Id, I); + Memo2.Lines.Add(S); + end; + end; + + procedure AddPublishedProps(StackFrameNumber, Id: Integer); + var + I, K: Integer; + OwnerName, S: String; + begin + K := PaxCompilerExplorer1.GetPublishedPropCount(Id); + if K = 0 then + Exit; + + OwnerName := PaxCompilerExplorer1.Names[Id]; + if PaxCompilerDebugger1.GetValueAsString(Id) = 'nil' then + Exit; + + for I:=0 to K - 1 do + begin + S := OwnerName + '.' + PaxCompilerExplorer1.GetPublishedPropName(Id, I); + S := ' ' + S + '=' + PaxCompilerDebugger1.GetPublishedPropValueAsString( + StackFrameNumber, Id, I); + Memo2.Lines.Add(S); + end; + end; + + procedure AddArrayElements(StackFrameNumber, Id: Integer); + var + I, K1, K2: Integer; + OwnerName, S: String; + begin + if not PaxCompilerExplorer1.HasArrayType(Id) then + Exit; + + K1 := PaxCompilerExplorer1.GetArrayLowBound(Id); + K2 := PaxCompilerExplorer1.GetArrayHighBound(Id); + + OwnerName := PaxCompilerExplorer1.Names[Id]; + + for I:=K1 to K2 do + begin + S := OwnerName + '[' + IntToStr(I) + ']'; + S := ' ' + S + '=' + PaxCompilerDebugger1.GetArrayItemValueAsString( + StackFrameNumber, Id, I); + Memo2.Lines.Add(S); + end; + end; + + procedure AddDynArrayElements(StackFrameNumber, Id: Integer); + var + I, L: Integer; + OwnerName, S: String; + begin + if not PaxCompilerExplorer1.HasDynArrayType(Id) then + Exit; + + L := PaxCompilerDebugger1.GetDynArrayLength(StackFrameNumber, Id); + + OwnerName := PaxCompilerExplorer1.Names[Id]; + + for I:=0 to L - 1 do + begin + S := OwnerName + '[' + IntToStr(I) + ']'; + S := ' ' + S + '=' + PaxCompilerDebugger1.GetDynArrayItemValueAsString( + StackFrameNumber, Id, I); + Memo2.Lines.Add(S); + end; + end; + +var + SourceLineNumber: Integer; + ModuleName: String; + StackFrameNumber, J, K, SubId, Id: Integer; + S, V: String; + CallStackLineNumber: Integer; + CallStackModuleName: String; +begin + Memo2.Lines.Clear; + if PaxCompilerDebugger1.IsPaused then + begin + ModuleName := PaxCompilerDebugger1.ModuleName; + SourceLineNumber := PaxCompilerDebugger1.SourceLineNumber; + + Memo2.Lines.Add('Paused at line ' + IntTosTr(SourceLineNumber)); + Memo2.Lines.Add(PaxCompiler1.Modules[ModuleName][SourceLineNumber]); + Memo2.Lines.Add('------------------------------------------------------'); + + if PaxCompilerDebugger1.CallStackCount > 0 then + begin + Memo2.Lines.Add('Call stack:'); + for StackFrameNumber:=0 to PaxCompilerDebugger1.CallStackCount - 1 do + begin + SubId := PaxCompilerDebugger1.CallStack[StackFrameNumber]; + S := '('; + K := PaxCompilerExplorer1.GetParamCount(SubId); + for J:=0 to K - 1 do + begin + Id := PaxCompilerExplorer1.GetParamId(SubId, J); + V := PaxCompilerDebugger1.GetValueAsString(StackFrameNumber, Id); + S := S + V; + if J < K - 1 then + S := S + ','; + end; + S := PaxCompilerExplorer1.Names[SubId] + S + ')'; + + CallStackLineNumber := PaxCompilerDebugger1.CallStackLineNumber[StackFrameNumber]; + CallStackModuleName := PaxCompilerDebugger1.CallStackModuleName[StackFrameNumber]; + + S := S + '; // ' + PaxCompiler1.Modules[CallStackModuleName][CallStackLineNumber]; + + Memo2.Lines.Add(S); + end; + Memo2.Lines.Add('------------------------------------------------------'); + + Memo2.Lines.Add('Local scope:'); + StackFrameNumber := PaxCompilerDebugger1.CallStackCount - 1; + SubId := PaxCompilerDebugger1.CallStack[StackFrameNumber]; + K := PaxCompilerExplorer1.GetLocalCount(SubId); + for J:=0 to K - 1 do + begin + Id := PaxCompilerExplorer1.GetLocalId(SubId, J); + V := PaxCompilerDebugger1.GetValueAsString(StackFrameNumber, Id); + S := PaxCompilerExplorer1.Names[Id] + '=' + V; + Memo2.Lines.Add(S); + + if Pos('X', S) > 0 then + begin + PaxCompilerDebugger1.PutValue(StackFrameNumber, Id, 258); + + V := PaxCompilerDebugger1.GetValueAsString(StackFrameNumber, Id); + S := PaxCompilerExplorer1.Names[Id] + '=' + V; + S := S + ' // modified'; + Memo2.Lines.Add(S); + end; + + AddFields(StackFrameNumber, Id); + AddPublishedProps(StackFrameNumber, Id); + AddArrayElements(StackFrameNumber, Id); + AddDynArrayElements(StackFrameNumber, Id); + end; + + Memo2.Lines.Add('------------------------------------------------------'); + end; + + Memo2.Lines.Add('Global scope:'); + K := PaxCompilerExplorer1.GetGlobalCount(0); + for J:=0 to K - 1 do + begin + Id := PaxCompilerExplorer1.GetGlobalId(0, J); + V := PaxCompilerDebugger1.GetValueAsString(Id); + S := PaxCompilerExplorer1.Names[Id] + '=' + V; + Memo2.Lines.Add(S); + + AddFields(0, Id); + AddPublishedProps(0, Id); + AddArrayElements(0, Id); + AddDynArrayElements(0, Id); + end; + Memo2.Lines.Add('------------------------------------------------------'); + + end + else + Memo2.Lines.Add('Finished'); + + Memo2.SelStart := 0; + Memo2.SelLength := 0; +end; + +procedure Print(I: Integer); +begin + ShowMessage(IntToStr(I)); +end; + +initialization + RegisterHeader(0, 'procedure Print(I: Integer);', @Print); + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/DebugDemo/Unit2.dfm b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/DebugDemo/Unit2.dfm new file mode 100644 index 0000000..c01f34c --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/DebugDemo/Unit2.dfm @@ -0,0 +1,43 @@ +object Form2: TForm2 + Left = 551 + Top = 252 + Width = 384 + Height = 345 + Caption = 'Select line' + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + PixelsPerInch = 96 + TextHeight = 13 + object Panel1: TPanel + Left = 0 + Top = 270 + Width = 376 + Height = 41 + Align = alBottom + TabOrder = 0 + object Button1: TButton + Left = 8 + Top = 8 + Width = 75 + Height = 25 + Caption = 'Ok' + ModalResult = 1 + TabOrder = 0 + OnClick = Button1Click + end + end + object ListBox1: TListBox + Left = 0 + Top = 0 + Width = 376 + Height = 270 + Align = alClient + ItemHeight = 13 + TabOrder = 1 + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/DebugDemo/Unit2.pas b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/DebugDemo/Unit2.pas new file mode 100644 index 0000000..e1e87d9 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/DebugDemo/Unit2.pas @@ -0,0 +1,65 @@ +unit Unit2; + +interface + +uses + Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, ExtCtrls; + +type + TForm2 = class(TForm) + Panel1: TPanel; + ListBox1: TListBox; + Button1: TButton; + procedure Button1Click(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + function ShowModal: Integer; override; + end; + +var + Form2: TForm2; + +implementation + +uses Unit1; + +{$R *.dfm} + +function TForm2.ShowModal: Integer; +var + I: Integer; + S: String; + ch: Char; +begin + ListBox1.Items.Clear; + for I:=0 to Form1.Memo1.Lines.Count - 1 do + begin + if Form1.PaxCompilerExplorer1.IsExecutableLine('1', I) then + ch := '*' + else + ch := ' '; + S := Format('%3d ', [I]) + ch + ' ' + Form1.Memo1.Lines[I]; + ListBox1.Items.Add(S); + end; + + result := inherited ShowModal; +end; + +procedure TForm2.Button1Click(Sender: TObject); +var + I: Integer; +begin + I := ListBox1.ItemIndex; + if Form1.PaxCompilerExplorer1.IsExecutableLine('1', I) then + Form1.PaxCompilerDebugger1.AddTempBreakpoint('1', I) + else + begin + ShowMessage(IntToStr(I) + ' is not executable line!'); + ModalResult := mrCancel; + end; +end; + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/Demo_Find_Declaration/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/Demo_Find_Declaration/Project1.dpr new file mode 100644 index 0000000..98689c4 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/Demo_Find_Declaration/Project1.dpr @@ -0,0 +1,77 @@ +{$APPTYPE CONSOLE} +program Project1; +uses + Classes, + PAXCOMP_CONSTANTS, + PAXCOMP_KERNEL, + PaxCompiler, PaxInterpreter, PaxRegister, IMPORT_Common; + +var + K: Integer = 0; +procedure Test(Module: String; X, Y: Integer); +var + PaxCompiler1: TPaxCompiler; + PaxInterpreter1: TPaxInterpreter; + PaxPascalLanguage1: TPaxPascalLanguage; + I: Integer; + L: TStringList; + S: String; +begin + Inc(K); + writeln('Test ', K); + writeln('-----------------------------------'); + + L := TStringList.Create; + PaxCompiler1 := TPaxCompiler.Create(nil); + PaxInterpreter1 := TPaxInterpreter.Create(nil); + PaxPascalLanguage1 := TPaxPascalLanguage.Create(nil); + try + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + + PaxCompiler1.AddModule(Module, 'Pascal'); + PaxCompiler1.AddCodeFromFile(Module, Module + '.pas'); + I := PaxCompiler1.FindDeclaration(Module, X, Y); + if I > 0 then + begin + S := PaxCompiler1.GetModuleName(I); + writeln(S); + + I := PaxCompiler1.GetPosition(I); + + L.LoadFromFile(S + '.pas'); + S := L.Text; + S := Copy(S, I + 1, 1); + writeln(S); + writeln(I); + end + else + begin + writeln(PaxCompiler1.ErrorMessage[0]); + writeln(PaxCompiler1.ErrorLineNumber[0]); + writeln(PaxCompiler1.ErrorLine[0]); + end; + finally + PaxCompiler1.Free; + PaxInterpreter1.Free; + PaxPascalLanguage1.Free; + L.Free; + end; +end; +begin +{ + Test('script1', 8, 3); + Test('script2', 4, 5); + Test('script3', 4, 5); + Test('script4', 8, 3); +} +// Test('script5', 8, 3); +// Test('script6', 4, 5); +// Test('script7', 5, 3); +// Test('script8', 8, 5); +// Test('script9', 8, 3); +// Test('script10', 19, 8); + Test('script11', 8, 10); + + writeln('Press any key...'); + Readln; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/Demo_Find_Declaration/script1.pas b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/Demo_Find_Declaration/script1.pas new file mode 100644 index 0000000..40e1622 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/Demo_Find_Declaration/script1.pas @@ -0,0 +1,5 @@ +// x = 8, y = 3 +uses u1; +begin + print I; +end. \ No newline at end of file diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/Demo_Find_Declaration/script10.pas b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/Demo_Find_Declaration/script10.pas new file mode 100644 index 0000000..501b278 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/Demo_Find_Declaration/script10.pas @@ -0,0 +1,12 @@ +// x = 19, y = 8 +unit MyUnit; +interface +type + TMyClass = class + procedure P; + end; +implementation +procedure TMyClass.P; +begin +end; +end. \ No newline at end of file diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/Demo_Find_Declaration/script11.pas b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/Demo_Find_Declaration/script11.pas new file mode 100644 index 0000000..2fd5b67 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/Demo_Find_Declaration/script11.pas @@ -0,0 +1,13 @@ +// x = 8, y = 10 +unit MyUnit; +interface +type + TMyClass = class + procedure P(X: Integer); + end; +implementation +procedure TMyClass.P(X: Integer); +begin + print X; +end; +end. \ No newline at end of file diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/Demo_Find_Declaration/script2.pas b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/Demo_Find_Declaration/script2.pas new file mode 100644 index 0000000..cade6e5 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/Demo_Find_Declaration/script2.pas @@ -0,0 +1,7 @@ +// x = 3, y = 5 +uses u1; +var + X: TMyClass; +begin + X.P; +end. \ No newline at end of file diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/Demo_Find_Declaration/script3.pas b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/Demo_Find_Declaration/script3.pas new file mode 100644 index 0000000..14f1e21 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/Demo_Find_Declaration/script3.pas @@ -0,0 +1,7 @@ +// x = 4, y = 5 +uses u1; +var + X: TMyClass; +begin + X.F; +end. \ No newline at end of file diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/Demo_Find_Declaration/script4.pas b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/Demo_Find_Declaration/script4.pas new file mode 100644 index 0000000..4733ef6 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/Demo_Find_Declaration/script4.pas @@ -0,0 +1,5 @@ +// x = 8, y = 3 +uses u1; +begin + print S; +end. \ No newline at end of file diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/Demo_Find_Declaration/script5.pas b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/Demo_Find_Declaration/script5.pas new file mode 100644 index 0000000..bb3476e --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/Demo_Find_Declaration/script5.pas @@ -0,0 +1,7 @@ +// x = 8, y = 3 +procedure P(S: Integer); +begin + print S; +end; +begin +end. \ No newline at end of file diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/Demo_Find_Declaration/script6.pas b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/Demo_Find_Declaration/script6.pas new file mode 100644 index 0000000..e69de29 diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/Demo_Find_Declaration/script7.pas b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/Demo_Find_Declaration/script7.pas new file mode 100644 index 0000000..6b7a115 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/Demo_Find_Declaration/script7.pas @@ -0,0 +1,7 @@ +// x = 5, y = 3 +function P(S: Integer): Integer; +begin + result := S + S; +end; +begin +end. \ No newline at end of file diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/Demo_Find_Declaration/script8.pas b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/Demo_Find_Declaration/script8.pas new file mode 100644 index 0000000..79d996d --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/Demo_Find_Declaration/script8.pas @@ -0,0 +1,9 @@ +// x = 10, y = 5 +unit MyUnit; +interface +procedure P; +implementation +procedure P; +begin +end; +end. \ No newline at end of file diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/Demo_Find_Declaration/script9.pas b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/Demo_Find_Declaration/script9.pas new file mode 100644 index 0000000..249a1d7 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/Demo_Find_Declaration/script9.pas @@ -0,0 +1,9 @@ +// x = 10, y = 3 +unit MyUnit; +interface +procedure P; +implementation +procedure P; +begin +end; +end. \ No newline at end of file diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/Demo_Find_Declaration/u1.pas b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/Demo_Find_Declaration/u1.pas new file mode 100644 index 0000000..96d61e2 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/Demo_Find_Declaration/u1.pas @@ -0,0 +1,22 @@ +unit u1; +interface +const + S = 'abc'; +var + I: Integer; +type + TMyClass = class + private + fx: Integer; + public + F: Integer; + procedure P; + property X: Integer read fx write fx; + end; +implementation + +procedure TMyClass.P; +begin +end; + +end. \ No newline at end of file diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/Demo_OnComment/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/Demo_OnComment/Project1.dpr new file mode 100644 index 0000000..b4c5bbc --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/Demo_OnComment/Project1.dpr @@ -0,0 +1,209 @@ +{$APPTYPE CONSOLE} +{$O-} +program Project1; +uses + Classes, + typinfo, + PAXCOMP_CONSTANTS, + PAXCOMP_SYS, + PAXCOMP_TYPES, + PaxCompiler, PaxInterpreter, PaxRegister, IMPORT_Common; + +type + TCommentRec = class + public + Id: Integer; + Comment: String; + FullName: String; + end; + + TCommentList = class(TTypedList) + private + function GetRecord(I: Integer): TCommentRec; + public + function Add: TCommentRec; + property Records[I: Integer]: TCommentRec read GetRecord; default; + end; + + THandler = class + CommentList: TCommentList; + constructor Create; + destructor Destroy; override; + procedure DoComment(Sender: TPaxCompiler; + const AComment: String; + const AContext: String; + CommentedTokens: TStrings); + procedure Dump; + end; + +function TCommentList.GetRecord(I: Integer): TCommentRec; +begin + result := TCommentRec(L[I]); +end; + +function TCommentList.Add: TCommentRec; +begin + result := TCommentRec.Create; + L.Add(result); +end; + +constructor THandler.Create; +begin + inherited; + CommentList := TCommentList.Create; +end; + +destructor THandler.Destroy; +begin + CommentList.Free; + inherited; +end; + +function GetFullName(TokenList: TStrings; const AContext: String; var Id: Integer): String; + var + I: Integer; + function NextToken: String; + begin + result := ''; + Inc(I); + if I < TokenList.Count then + result := TokenList[I]; + end; +var + S: String; +begin + result := ''; + I := -1; + result := NextToken; + Id := 0; + + if StrEql(result, 'class') then + begin + result := NextToken; + end + else if StrEql(result, 'unit') then + begin + result := NextToken; + Exit; + end; + + if StrEql(result, 'function') then + begin + result := NextToken; + S := NextToken; + if S = '.' then + result := result + '.' + NextToken; + end + else if StrEql(result, 'procedure') then + begin + result := NextToken; + S := NextToken; + if S = '.' then + result := result + '.' + NextToken; + end + else if StrEql(result, 'constructor') then + begin + result := NextToken; + S := NextToken; + if S = '.' then + result := result + '.' + NextToken; + end + else if StrEql(result, 'destructor') then + begin + result := NextToken; + S := NextToken; + if S = '.' then + result := result + '.' + NextToken; + end + else if StrEql(result, 'property') then + begin + result := NextToken; + end; + + if result = '' then + Exit; + if AContext <> '' then + result := AContext + '.' + result; + + Id := Integer(TokenList.Objects[I]); +end; + +procedure THandler.DoComment(Sender: TPaxCompiler; + const AComment: String; + const AContext: String; + CommentedTokens: TStrings); +var + AFullName: String; + AnId: Integer; +begin + AFullName := GetFullName(CommentedTokens, AContext, AnId); + + with CommentList.Add do + begin + Comment := AComment; + FullName := AFullName; + if AnId = 0 then + Id := Sender.LookupId(AFullName) + else + Id := AnId; + end; +end; + +procedure THandler.Dump; +var + I: Integer; +begin + for I := 0 to CommentList.Count - 1 do + with CommentList[I] do + begin + writeln(Comment); + writeln(FullName); + writeln(Id); + end; +end; + +var + PaxCompiler1: TPaxCompiler; + PaxInterpreter1: TPaxInterpreter; + PaxPascalLanguage1: TPaxPascalLanguage; + I: Integer; + Handler: THandler; +begin + Handler := THandler.Create; + PaxCompiler1 := TPaxCompiler.Create(nil); + PaxInterpreter1 := TPaxInterpreter.Create(nil); + PaxPascalLanguage1 := TPaxPascalLanguage.Create(nil); + + PaxCompiler1.OnComment := Handler.DoComment; + try + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + PaxCompiler1.AddModule('1', 'Pascal'); + PaxCompiler1.AddCodeFromFile('1', 'script2.txt'); + if PaxCompiler1.Compile(PaxInterpreter1) then + begin + Handler.Dump; + end + else + begin + writeln(PaxCompiler1.ErrorMessage[0]); + writeln(PaxCompiler1.ErrorLineNumber[0]); + writeln(PaxCompiler1.ErrorLine[0]); + end; + + for I:=0 to PaxCompiler1.WarningCount - 1 do + begin + writeln(PaxCompiler1.WarningMessage[0]); + writeln(PaxCompiler1.WarningLineNumber[0]); + writeln(PaxCompiler1.WarningLine[0]); + end; + + finally + PaxCompiler1.Free; + PaxInterpreter1.Free; + PaxPascalLanguage1.Free; + Handler.Free; + end; + + writeln('Press any key...'); + Readln; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/Demo_OnComment/script.txt b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/Demo_OnComment/script.txt new file mode 100644 index 0000000..3a50aa1 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/Demo_OnComment/script.txt @@ -0,0 +1,40 @@ +{Declaration of MyUnit} +unit MyUnit; +interface +type + (* TMyClass declaration *) + TMyClass = class + private + (* field fx of TMyClass *) + fx: Integer; + public + (* declaration of TMyClass.P (1) *) + procedure P; overload; + (* declaration of TMyClass.P (2) *) + procedure P(I: Integer); overload; + (* declaration of TMyClass.x *) + property x: Integer read fx; + end; + +implementation + +(* implementation of TMyClass.P (1) *) + +procedure TMyClass.P; +begin +end; + +(* implementation of TMyClass.P (2) *) + +procedure TMyClass.P(I : Integer); +begin +end; + +// myproc + +procedure myproc(x: Integer; y: String); +begin +end; + +begin +end. \ No newline at end of file diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/Demo_OnComment/script2.txt b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/Demo_OnComment/script2.txt new file mode 100644 index 0000000..0f4777b --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/Demo_OnComment/script2.txt @@ -0,0 +1,30 @@ +program MyProg; + +type + (* TMyClass declaration *) + TMyClass = class + private + (* field fx of TMyClass *) + fx: Integer; + public + (* declaration of TMyClass.P *) + class procedure P; + (* declaration of TMyClass.x *) + property x: Integer read fx; + end; + + +(* implementation of TMyClass.P *) + +class procedure TMyClass.P; +begin +end; + +// myproc + +procedure myproc(x: Integer; y: String); +begin +end; + +begin +end. \ No newline at end of file diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/Demo_OnComment/script3.txt b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/Demo_OnComment/script3.txt new file mode 100644 index 0000000..48bfbdd --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/Demo_OnComment/script3.txt @@ -0,0 +1,11 @@ +//--------------------------- +//-- mymethod +//--------------------------- + +{ my proc } + +procedure P; +begin +end; +begin +end. \ No newline at end of file diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/Demo_OnComment/script4.txt b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/Demo_OnComment/script4.txt new file mode 100644 index 0000000..a09efb5 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/Demo_OnComment/script4.txt @@ -0,0 +1,66 @@ +{ ------------------------------------------------------------------------------------ + Declaration of MyUnit +-------------------------------------------------------------------------------------- } +unit MyUnit; +interface +type + {* ------------------------------------------------------------------------------------ + TMyClass declaration + -------------------------------------------------------------------------------------- *} + TMyClass = class + private + {* ------------------------------------------------------------------------------------ + field fx of TMyClass + -------------------------------------------------------------------------------------- *} + fx: Integer; + public + + {* ------------------------------------------------------------------------------------ + declaration of TMyClass.P (1) + -------------------------------------------------------------------------------------- *} + procedure P; overload; + + {* ------------------------------------------------------------------------------------ + declaration of TMyClass.P (2) + -------------------------------------------------------------------------------------- *} + procedure P(I: Integer); overload; + + {* ------------------------------------------------------------------------------------ + declaration of TMyClass.x + -------------------------------------------------------------------------------------- *} + property x: Integer read fx; + end; + +implementation + +//*************************************************************************************** +// +// TMyClass +// +//*************************************************************************************** + +{* ------------------------------------------------------------------------------------ + implementation of TMyClass.P (1) +-------------------------------------------------------------------------------------- *} +procedure TMyClass.P; +begin + // +end; + +{* ------------------------------------------------------------------------------------ + implementation of TMyClass.P (2) +-------------------------------------------------------------------------------------- *} + +procedure TMyClass.P(I : Integer); +begin + // +end; + +// myproc + +procedure myproc(x: Integer; y: String); +begin +end; + +begin +end. \ No newline at end of file diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/Demo_OnComment/script5.txt b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/Demo_OnComment/script5.txt new file mode 100644 index 0000000..6804be5 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/Demo_OnComment/script5.txt @@ -0,0 +1,9 @@ +//desc program + +{* desc P *} +procedure P; +begin +end; + +begin +end. \ No newline at end of file diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/EvalExpression/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/EvalExpression/Project1.dpr new file mode 100644 index 0000000..513a1dd --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/EvalExpression/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/EvalExpression/Project1.res b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/EvalExpression/Project1.res new file mode 100644 index 0000000..3adc036 Binary files /dev/null and b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/EvalExpression/Project1.res differ diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/EvalExpression/Unit1.dfm b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/EvalExpression/Unit1.dfm new file mode 100644 index 0000000..7959775 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/EvalExpression/Unit1.dfm @@ -0,0 +1,44 @@ +object Form1: TForm1 + Left = 192 + Top = 115 + Caption = 'Eval Expression' + ClientHeight = 142 + ClientWidth = 326 + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -14 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + OnCreate = FormCreate + OnDestroy = FormDestroy + PixelsPerInch = 120 + TextHeight = 16 + object Button1: TButton + Left = 30 + Top = 30 + Width = 247 + Height = 30 + Margins.Left = 4 + Margins.Top = 4 + Margins.Right = 4 + Margins.Bottom = 4 + Caption = 'Create compiled expression' + TabOrder = 0 + OnClick = Button1Click + end + object Button2: TButton + Left = 30 + Top = 79 + Width = 247 + Height = 31 + Margins.Left = 4 + Margins.Top = 4 + Margins.Right = 4 + Margins.Bottom = 4 + Caption = 'Evaluate expression' + TabOrder = 1 + OnClick = Button2Click + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/EvalExpression/Unit1.pas b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/EvalExpression/Unit1.pas new file mode 100644 index 0000000..5bf7e43 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/EvalExpression/Unit1.pas @@ -0,0 +1,125 @@ +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, PaxCompiler, PaxInterpreter, PaxRegister; + +type + TForm1 = class(TForm) + Button1: TButton; + Button2: TButton; + procedure Button1Click(Sender: TObject); + procedure Button2Click(Sender: TObject); + procedure FormCreate(Sender: TObject); + procedure FormDestroy(Sender: TObject); + private + { Private declarations } + arr_x, arr_y: array[1..3] of Double; + h_norm, h_x, h_y: Integer; + + buff: Pointer; + buff_size: Integer; + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.dfm} + +function Norm(x, y: Double): Double; +begin + result := Sqrt(x * x + y * y); +end; + +procedure TForm1.Button1Click(Sender: TObject); +var + PaxCompiler1: TPaxCompiler; + PaxPascalLanguage1: TPaxPascalLanguage; + PaxInterpreter1: TPaxInterpreter; + I: Integer; +begin + PaxCompiler1 := TPaxCompiler.Create(nil); + PaxPascalLanguage1 := TPaxPascalLanguage.Create(nil); + PaxInterpreter1 := TPaxInterpreter.Create(nil); + + try + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + + h_norm := PaxCompiler1.RegisterHeader(0, 'function Norm(x, y: Double): Double;'); + + h_x := PaxCompiler1.RegisterVariable(0, 'x', _typeDOUBLE); + h_y := PaxCompiler1.RegisterVariable(0, 'y', _typeDOUBLE); + + if PaxCompiler1.CompileExpression('Norm(x, y)', PaxInterpreter1) then + begin + buff_size := PaxInterpreter1.ImageSize; + buff := AllocMem(buff_size); + PaxInterpreter1.SaveToBuff(buff^); + ShowMessage('Compiled expression has been created!'); + end + else + for I:=0 to PaxCompiler1.ErrorCount - 1 do + ShowMessage(PaxCompiler1.ErrorMessage[I]); + finally + PaxCompiler1.Free; + PaxPascalLanguage1.Free; + PaxInterpreter1.Free; + end; +end; + +procedure TForm1.Button2Click(Sender: TObject); +var + PaxInterpreter1: TPaxInterpreter; + ResValue: Double; + I: Integer; +begin +{$O-} + if h_x <> 0 then + begin + PaxInterpreter1 := TPaxInterpreter.Create(nil); + try + PaxInterpreter1.LoadFromBuff(buff^); + + PaxInterpreter1.SetAddress(h_norm, @norm); + + for I:=1 to 3 do + begin + PaxInterpreter1.SetAddress(h_x, @arr_x[I]); + PaxInterpreter1.SetAddress(h_y, @arr_y[I]); + + PaxInterpreter1.Run; + + ResValue := Double(PaxInterpreter1.ResultPtr^); + ShowMessage(FloatToStr(ResValue)); + end; + + finally + PaxInterpreter1.Free; + end; + end + else + ShowMessage('Press the first button to create compiled script.'); +end; + +procedure TForm1.FormCreate(Sender: TObject); +begin + h_x := 0; h_y := 0; h_norm := 0; + arr_x[1] := 4.2; arr_y[1] := -5.2; + arr_x[2] := -0.4; arr_y[2] := 3.2; + arr_x[3] := 2.0; arr_y[3] := 3; +end; + +procedure TForm1.FormDestroy(Sender: TObject); +begin + if Assigned(buff) then + FreeMem(buff, buff_size); +end; + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/HandledException/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/HandledException/Project1.dpr new file mode 100644 index 0000000..513a1dd --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/HandledException/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/HandledException/Project1.res b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/HandledException/Project1.res new file mode 100644 index 0000000..3adc036 Binary files /dev/null and b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/HandledException/Project1.res differ diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/HandledException/Unit1.dfm b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/HandledException/Unit1.dfm new file mode 100644 index 0000000..e68300b --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/HandledException/Unit1.dfm @@ -0,0 +1,105 @@ +object Form1: TForm1 + Left = 192 + Top = 114 + Caption = 'Run-time error handling' + ClientHeight = 693 + ClientWidth = 847 + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -14 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + PixelsPerInch = 120 + TextHeight = 16 + object Button1: TButton + Left = 30 + Top = 20 + Width = 198 + Height = 30 + Margins.Left = 4 + Margins.Top = 4 + Margins.Right = 4 + Margins.Bottom = 4 + Caption = 'Compile and Run' + TabOrder = 0 + OnClick = Button1Click + end + object Memo1: TMemo + Left = 246 + Top = 20 + Width = 592 + Height = 542 + Margins.Left = 4 + Margins.Top = 4 + Margins.Right = 4 + Margins.Bottom = 4 + Lines.Strings = ( + 'uses' + ' SysUtils;' + '' + 'procedure ErrorProc;' + 'var' + ' I: Integer;' + 'begin' + ' I := 0;' + ' I := I div I;' + 'end;' + '' + 'procedure TestFinally;' + 'var' + ' S: String;' + ' I: Integer;' + 'begin' + ' S := '#39'abc'#39';' + ' try' + ' ErrorProc;' + ' finally' + ' writeln(S);' + ' end;' + ' writeln('#39'not executed'#39');' + 'end;' + '' + 'begin' + ' try' + ' TestFinally;' + ' except' + ' writeln('#39'ok'#39');' + ' end;' + 'end.') + TabOrder = 1 + end + object Memo2: TMemo + Left = 246 + Top = 571 + Width = 592 + Height = 110 + Margins.Left = 4 + Margins.Top = 4 + Margins.Right = 4 + Margins.Bottom = 4 + TabOrder = 2 + end + object PaxCompiler1: TPaxCompiler + Alignment = 1 + DebugMode = False + Left = 64 + Top = 112 + end + object PaxPascalLanguage1: TPaxPascalLanguage + ExplicitOff = False + CompleteBooleanEval = False + UnitLookup = True + PrintKeyword = 'print' + PrintlnKeyword = 'println' + Left = 104 + Top = 112 + end + object PaxInterpreter1: TPaxInterpreter + Console = False + OnException = PaxInterpreter1Exception + Left = 96 + Top = 184 + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/HandledException/Unit1.pas b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/HandledException/Unit1.pas new file mode 100644 index 0000000..ce776c0 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/HandledException/Unit1.pas @@ -0,0 +1,105 @@ +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, + Dialogs, PaxInterpreter, PaxCompiler, StdCtrls, + PAXCOMP_STDLIB, + PaxRunner; + +type + TForm1 = class(TForm) + Button1: TButton; + Memo1: TMemo; + PaxCompiler1: TPaxCompiler; + PaxPascalLanguage1: TPaxPascalLanguage; + Memo2: TMemo; + PaxInterpreter1: TPaxInterpreter; + procedure Button1Click(Sender: TObject); + procedure PaxInterpreter1Exception(Sender: TPaxRunner; E: Exception; + const ModuleName: string; SourceLineNumber: Integer); + private + { Private declarations } + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.dfm} + +uses + IMPORT_SysUtils; + +procedure _Writeln; +begin + Form1.Memo2.Text := Form1.Memo2.Text + #13#10; +end; + +procedure _WriteUnicString(const value: String; L: Integer); +var + S: String; +begin + if L = 0 then + Form1.Memo2.Text := Form1.Memo2.Text + value + else + begin + S := value; + while Length(S) < L do + S := ' ' + S; + Form1.Memo2.Text := Form1.Memo2.Text + S; + end; +end; + +procedure _WriteWideString(const value: WideString; L: Integer); +var + S: String; +begin + if L = 0 then + Form1.Memo2.Text := Form1.Memo2.Text + value + else + begin + S := value; + while Length(S) < L do + S := ' ' + S; + Form1.Memo2.Text := Form1.Memo2.Text + S; + end; +end; + +procedure TForm1.Button1Click(Sender: TObject); +begin + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + PaxCompiler1.AddModule('main', 'Pascal'); + PaxCompiler1.AddCode('main', Memo1.Lines.Text); + if PaxCompiler1.Compile(PaxInterpreter1) then + begin + PaxInterpreter1.SetAddress(H_Writeln, @_Writeln); + PaxInterpreter1.SetAddress(H_WriteAnsiString, @_WriteUnicString); + PaxInterpreter1.SetAddress(H_WriteUnicString, @_WriteUnicString); + PaxInterpreter1.SetAddress(H_WriteWideString, @_WriteWideString); + + PaxInterpreter1.Run; + end + else + ShowMessage(PaxCompiler1.ErrorMessage[0]); +end; + +procedure TForm1.PaxInterpreter1Exception(Sender: TPaxRunner; E: Exception; + const ModuleName: string; SourceLineNumber: Integer); +begin + Form1.Memo2.Text := Form1.Memo2.Text + #13#10 + + 'Exception (' + E.Message + + ') raised at line ' + IntToStr(SourceLineNumber) + ':' + + PaxCompiler1.Modules[ModuleName][SourceLineNumber] + #13#10; +end; + +initialization + +Register_SysUtils; + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/Hello/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/Hello/Project1.dpr new file mode 100644 index 0000000..513a1dd --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/Hello/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/Hello/Project1.res b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/Hello/Project1.res new file mode 100644 index 0000000..3adc036 Binary files /dev/null and b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/Hello/Project1.res differ diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/Hello/Unit1.dfm b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/Hello/Unit1.dfm new file mode 100644 index 0000000..6ac53ae --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/Hello/Unit1.dfm @@ -0,0 +1,49 @@ +object Form1: TForm1 + Left = 192 + Top = 114 + Caption = 'HelloApp' + ClientHeight = 164 + ClientWidth = 290 + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -14 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + PixelsPerInch = 120 + TextHeight = 16 + object Button1: TButton + Left = 39 + Top = 98 + Width = 93 + Height = 31 + Margins.Left = 4 + Margins.Top = 4 + Margins.Right = 4 + Margins.Bottom = 4 + Caption = 'Say "Hello"' + TabOrder = 0 + OnClick = Button1Click + end + object PaxCompiler1: TPaxCompiler + Alignment = 1 + DebugMode = False + Left = 48 + Top = 24 + end + object PaxPascalLanguage1: TPaxPascalLanguage + ExplicitOff = False + CompleteBooleanEval = False + UnitLookup = True + PrintKeyword = 'print' + PrintlnKeyword = 'println' + Left = 96 + Top = 24 + end + object PaxInterpreter1: TPaxInterpreter + Console = False + Left = 144 + Top = 24 + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/Hello/Unit1.pas b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/Hello/Unit1.pas new file mode 100644 index 0000000..0fa3e97 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/Hello/Unit1.pas @@ -0,0 +1,50 @@ +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, PaxCompiler, PaxInterpreter, PaxRunner; +type + TForm1 = class(TForm) + PaxCompiler1: TPaxCompiler; + PaxPascalLanguage1: TPaxPascalLanguage; + Button1: TButton; + PaxInterpreter1: TPaxInterpreter; + procedure Button1Click(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.dfm} + +procedure TForm1.Button1Click(Sender: TObject); +var + I, H_TButton: Integer; +begin + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + + H_TButton := PaxCompiler1.RegisterClassType(0, TButton); + PaxCompiler1.RegisterVariable(0, 'Button1', H_TButton, @Button1); + + PaxCompiler1.AddModule('1', PaxPascalLanguage1.LanguageName); + PaxCompiler1.AddCode('1', 'begin'); + PaxCompiler1.AddCode('1', ' Button1.Caption := ''Hello'';'); + PaxCompiler1.AddCode('1', 'end.'); + + if PaxCompiler1.Compile(PaxInterpreter1) then + PaxInterpreter1.Run + else + for I:=0 to PaxCompiler1.ErrorCount - 1 do + ShowMessage(PaxCompiler1.ErrorMessage[I]); +end; + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/ImportAbstractClasses/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/ImportAbstractClasses/Project1.dpr new file mode 100644 index 0000000..bce4231 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/ImportAbstractClasses/Project1.dpr @@ -0,0 +1,67 @@ +{$APPTYPE CONSOLE} +program Project1; +uses + PaxCompiler, PaxInterpreter, PaxRegister; +type + TMyHostClass = class + public + constructor Create; virtual; abstract; + procedure P; virtual; abstract; + end; + TMyHostClassClass = class of TMyHostClass; + +var + PaxCompiler1: TPaxCompiler; + PaxInterpreter1: TPaxInterpreter; + PaxPascalLanguage1: TPaxPascalLanguage; + I: Integer; + + C: TMyHostClassClass; + X: TMyHostClass; +begin + I := RegisterClassType(0, TMyHostClass); + RegisterHeader(I, + 'constructor Create; virtual; abstract;', + nil); + RegisterHeader(I, + 'procedure P; virtual; abstract;', + nil); + + PaxCompiler1 := TPaxCompiler.Create(nil); + PaxInterpreter1 := TPaxInterpreter.Create(nil); + PaxPascalLanguage1 := TPaxPascalLanguage.Create(nil); + try + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + PaxCompiler1.AddModule('1', 'Pascal'); + PaxCompiler1.AddCodeFromFile('1', 'script.txt'); + if PaxCompiler1.Compile(PaxInterpreter1) then + begin + PaxInterpreter1.RunInitialization; + + C := TMyHostClassClass(PaxInterpreter1.GetAddress('TMyScriptClass')^); + X := C.Create; + X.P; + X.Free; + end + else + begin + writeln(PaxCompiler1.ErrorMessage[0]); + writeln(PaxCompiler1.ErrorLineNumber[0]); + writeln(PaxCompiler1.ErrorLine[0]); + end; + + for I:=0 to PaxCompiler1.WarningCount - 1 do + begin + writeln(PaxCompiler1.WarningMessage[I]); + writeln(PaxCompiler1.WarningLineNumber[I]); + writeln(PaxCompiler1.WarningLine[I]); + end; + + finally + PaxCompiler1.Free; + PaxInterpreter1.Free; + PaxPascalLanguage1.Free; + end; + writeln('Press any key...'); + Readln; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/ImportAbstractClasses/script.txt b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/ImportAbstractClasses/script.txt new file mode 100644 index 0000000..fa74f15 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/ImportAbstractClasses/script.txt @@ -0,0 +1,18 @@ +type + TMyScriptClass = class(TMyHostClass) + constructor Create; override; + procedure P; override; + end; + +constructor TMyScriptClass.Create; +begin + print 'Script object of ' + ClassName + ' is created.'; +end; + +procedure TMyScriptClass.P; +begin + print 'Hello from script!'; +end; + +begin +end. \ No newline at end of file diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/Inheritance/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/Inheritance/Project1.dpr new file mode 100644 index 0000000..da6f35a --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/Inheritance/Project1.dpr @@ -0,0 +1,64 @@ +{$APPTYPE CONSOLE} +program Project1; +uses + PaxCompiler, PaxInterpreter, PaxRegister; +type + TMyHostClass = class + public + procedure P; virtual; abstract; + end; + +procedure PassToHost(X: TMyHostClass); +begin + writeln(X.ClassName); + X.P; +end; + +var + PaxCompiler1: TPaxCompiler; + PaxInterpreter1: TPaxInterpreter; + PaxPascalLanguage1: TPaxPascalLanguage; + I: Integer; +begin + I := RegisterClassType(0, TMyHostClass); + RegisterHeader(I, + 'procedure P; virtual; abstract;', + nil); + + RegisterHeader(0, + 'procedure PassToHost(X: TMyHostClass);', + @ PassToHost); + + PaxCompiler1 := TPaxCompiler.Create(nil); + PaxInterpreter1 := TPaxInterpreter.Create(nil); + PaxPascalLanguage1 := TPaxPascalLanguage.Create(nil); + try + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + PaxCompiler1.AddModule('1', 'Pascal'); + PaxCompiler1.AddCodeFromFile('1', 'script.txt'); + if PaxCompiler1.Compile(PaxInterpreter1) then + begin + PaxInterpreter1.Run; + end + else + begin + writeln(PaxCompiler1.ErrorMessage[0]); + writeln(PaxCompiler1.ErrorLineNumber[0]); + writeln(PaxCompiler1.ErrorLine[0]); + end; + + for I:=0 to PaxCompiler1.WarningCount - 1 do + begin + writeln(PaxCompiler1.WarningMessage[I]); + writeln(PaxCompiler1.WarningLineNumber[I]); + writeln(PaxCompiler1.WarningLine[I]); + end; + + finally + PaxCompiler1.Free; + PaxInterpreter1.Free; + PaxPascalLanguage1.Free; + end; + writeln('Press any key...'); + Readln; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/Inheritance/script.txt b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/Inheritance/script.txt new file mode 100644 index 0000000..90e1139 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/Inheritance/script.txt @@ -0,0 +1,20 @@ +type + TMyScriptClass = class(TMyHostClass) + procedure P; override; + end; + +procedure TMyScriptClass.P; +begin + writeln('Hello from script!'); +end; + +var + X: TMyScriptClass; +begin + X := TMyScriptClass.Create; + try + PassToHost(X); + finally + X.Free; + end; +end. \ No newline at end of file diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/LoadCompiledScript/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/LoadCompiledScript/Project1.dpr new file mode 100644 index 0000000..513a1dd --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/LoadCompiledScript/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/LoadCompiledScript/Project1.res b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/LoadCompiledScript/Project1.res new file mode 100644 index 0000000..3adc036 Binary files /dev/null and b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/LoadCompiledScript/Project1.res differ diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/LoadCompiledScript/Unit1.dfm b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/LoadCompiledScript/Unit1.dfm new file mode 100644 index 0000000..85bb875 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/LoadCompiledScript/Unit1.dfm @@ -0,0 +1,43 @@ +object Form1: TForm1 + Left = 192 + Top = 114 + Caption = 'Load compiled script demo' + ClientHeight = 207 + ClientWidth = 341 + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -14 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + OnCreate = FormCreate + PixelsPerInch = 120 + TextHeight = 16 + object Button1: TButton + Left = 49 + Top = 49 + Width = 238 + Height = 31 + Margins.Left = 4 + Margins.Top = 4 + Margins.Right = 4 + Margins.Bottom = 4 + Caption = 'Compile script. Save compile script.' + TabOrder = 0 + OnClick = Button1Click + end + object Button2: TButton + Left = 49 + Top = 118 + Width = 238 + Height = 31 + Margins.Left = 4 + Margins.Top = 4 + Margins.Right = 4 + Margins.Bottom = 4 + Caption = 'Load compiled script. Run script.' + TabOrder = 1 + OnClick = Button2Click + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/LoadCompiledScript/Unit1.pas b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/LoadCompiledScript/Unit1.pas new file mode 100644 index 0000000..828aa19 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/LoadCompiledScript/Unit1.pas @@ -0,0 +1,98 @@ +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, PaxCompiler, PaxInterpreter, PaxRegister; +type + TForm1 = class(TForm) + Button1: TButton; + Button2: TButton; + procedure Button1Click(Sender: TObject); + procedure Button2Click(Sender: TObject); + procedure FormCreate(Sender: TObject); + private + H_ShowMessage: Integer; + H_S: Integer; + S: AnsiString; + { Private declarations } + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.dfm} + +procedure TForm1.Button1Click(Sender: TObject); +var + I: Integer; + PaxCompiler1: TPaxCompiler; + PaxPascalLanguage1: TPaxPascalLanguage; + PaxInterpreter1: TPaxInterpreter; +begin + PaxCompiler1 := TPaxCompiler.Create(nil); + PaxPascalLanguage1 := TPaxPascalLanguage.Create(nil); + PaxInterpreter1 := TPaxInterpreter.Create(nil); + + try + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + + // register routine 'ShowMessage' + H_ShowMessage := PaxCompiler1.RegisterHeader(0, 'procedure ShowMessage(const Msg: string);'); + + // register variable 'S' + H_S := PaxCompiler1.RegisterVariable(0, 'S', _typeSTRING); + + PaxCompiler1.AddModule('1', PaxPascalLanguage1.LanguageName); + PaxCompiler1.AddCode('1', 'begin'); + PaxCompiler1.AddCode('1', ' ShowMessage(S);'); + PaxCompiler1.AddCode('1', 'end.'); + + if PaxCompiler1.Compile(PaxInterpreter1) then + begin + PaxInterpreter1.SaveToFile('1.bin'); + ShowMessage('Compiled script has been created!'); + end + else + for I:=0 to PaxCompiler1.ErrorCount - 1 do + ShowMessage(PaxCompiler1.ErrorMessage[I]); + finally + PaxCompiler1.Free; + PaxPascalLanguage1.Free; + PaxInterpreter1.Free; + end; +end; + +procedure TForm1.Button2Click(Sender: TObject); +var + PaxInterpreter1: TPaxInterpreter; +begin + if FileExists('1.bin') and (H_ShowMessage <> 0) and (H_S <> 0) then + begin + PaxInterpreter1 := TPaxInterpreter.Create(nil); + try + PaxInterpreter1.LoadFromFile('1.bin'); + PaxInterpreter1.SetAddress(H_ShowMessage, @ShowMessage); + PaxInterpreter1.SetAddress(H_S, @S); + PaxInterpreter1.Run; + finally + PaxInterpreter1.Free; + end; + end + else + ShowMessage('Press the first button to create compiled script.'); +end; + +procedure TForm1.FormCreate(Sender: TObject); +begin + H_ShowMessage := 0; + H_S := 0; + S := 'Hello'; +end; + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/OnUndeclaredIdentifier/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/OnUndeclaredIdentifier/Project1.dpr new file mode 100644 index 0000000..3ac1d96 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/OnUndeclaredIdentifier/Project1.dpr @@ -0,0 +1,64 @@ +{$APPTYPE CONSOLE} +{$O-} +program Project1; +uses + SysUtils, + PaxCompiler, PaxInterpreter, PaxRegister; +type + TMyHandler = class + public + function UndeclaredIdentifierHandler(Sender: TPaxCompiler; + const IdentName: String; + var Scope: String; + var FullTypeName: String): boolean; + end; + +function TMyHandler.UndeclaredIdentifierHandler(Sender: TPaxCompiler; + const IdentName: String; + var Scope: String; + var FullTypeName: String): boolean; +begin + result := false; + if CompareText(IdentName, 'x') = 0 then + begin + result := true; + FullTypeName := 'Integer'; + Scope := 'MyProg'; + end; +end; + +var + PaxCompiler1: TPaxCompiler; + PaxInterpreter1: TPaxInterpreter; + PaxPascalLanguage1: TPaxPascalLanguage; + MyHandler: TMyHandler; +begin + PaxCompiler1 := TPaxCompiler.Create(nil); + PaxInterpreter1 := TPaxInterpreter.Create(nil); + PaxPascalLanguage1 := TPaxPascalLanguage.Create(nil); + MyHandler := TMyHandler.Create; + try + PaxCompiler1.OnUndeclaredIdentifier := MyHandler.UndeclaredIdentifierHandler; + + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + PaxCompiler1.AddModule('1', 'Pascal'); + PaxCompiler1.AddCodeFromFile('1', 'script.txt'); + if PaxCompiler1.Compile(PaxInterpreter1) then + begin + PaxInterpreter1.Run; + end + else + begin + writeln(PaxCompiler1.ErrorMessage[0]); + writeln(PaxCompiler1.ErrorLineNumber[0]); + writeln(PaxCompiler1.ErrorLine[0]); + end; + finally + MyHandler.Free; + PaxCompiler1.Free; + PaxInterpreter1.Free; + PaxPascalLanguage1.Free; + end; + writeln('Press any key...'); + Readln; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/OnUndeclaredIdentifier/script.txt b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/OnUndeclaredIdentifier/script.txt new file mode 100644 index 0000000..cbf67c7 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/OnUndeclaredIdentifier/script.txt @@ -0,0 +1,10 @@ +program MyProg; +procedure P; +begin + writeln(x); + x := 10; + writeln(x); +end; +begin + P; +end. \ No newline at end of file diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/OnUsedUnitEvent/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/OnUsedUnitEvent/Project1.dpr new file mode 100644 index 0000000..513a1dd --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/OnUsedUnitEvent/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/OnUsedUnitEvent/Project1.res b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/OnUsedUnitEvent/Project1.res new file mode 100644 index 0000000..7b5cd7a Binary files /dev/null and b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/OnUsedUnitEvent/Project1.res differ diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/OnUsedUnitEvent/Unit1.dfm b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/OnUsedUnitEvent/Unit1.dfm new file mode 100644 index 0000000..e737e4d --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/OnUsedUnitEvent/Unit1.dfm @@ -0,0 +1,50 @@ +object Form1: TForm1 + Left = 192 + Top = 114 + Caption = 'OnUsedUnit event demo' + ClientHeight = 144 + ClientWidth = 385 + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -14 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + PixelsPerInch = 120 + TextHeight = 16 + object Button1: TButton + Left = 30 + Top = 30 + Width = 257 + Height = 30 + Margins.Left = 4 + Margins.Top = 4 + Margins.Right = 4 + Margins.Bottom = 4 + Caption = 'Compile and Run' + TabOrder = 0 + OnClick = Button1Click + end + object PaxCompiler1: TPaxCompiler + Alignment = 1 + OnUsedUnit = PaxCompiler1UsedUnit + DebugMode = False + Left = 24 + Top = 80 + end + object PaxPascalLanguage1: TPaxPascalLanguage + ExplicitOff = False + CompleteBooleanEval = False + UnitLookup = True + PrintKeyword = 'print' + PrintlnKeyword = 'println' + Left = 72 + Top = 80 + end + object PaxInterpreter1: TPaxInterpreter + Console = False + Left = 120 + Top = 80 + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/OnUsedUnitEvent/Unit1.pas b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/OnUsedUnitEvent/Unit1.pas new file mode 100644 index 0000000..bf7f4e7 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/OnUsedUnitEvent/Unit1.pas @@ -0,0 +1,73 @@ +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, + Dialogs, PaxInterpreter, PaxCompiler, PaxRegister, StdCtrls, PaxRunner; + +type + TForm1 = class(TForm) + Button1: TButton; + PaxCompiler1: TPaxCompiler; + PaxPascalLanguage1: TPaxPascalLanguage; + PaxInterpreter1: TPaxInterpreter; + procedure Button1Click(Sender: TObject); + function PaxCompiler1UsedUnit(Sender: TPaxCompiler; + const UnitName: String; var SourceCode: String): Boolean; + private + { Private declarations } + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.dfm} + +procedure TForm1.Button1Click(Sender: TObject); +begin + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + PaxCompiler1.AddModule('main', 'Pascal'); + PaxCompiler1.AddCode('main', 'uses SomeUnit;'); + PaxCompiler1.AddCode('main', 'begin'); + PaxCompiler1.AddCode('main', ' P;'); + PaxCompiler1.AddCode('main', 'end.'); + if PaxCompiler1.Compile(PaxInterpreter1) then + begin + PaxInterpreter1.Run; + end + else + ShowMessage(PaxCompiler1.ErrorMessage[0]); +end; + +function TForm1.PaxCompiler1UsedUnit(Sender: TPaxCompiler; + const UnitName: String; var SourceCode: String): Boolean; +begin + if UnitName = 'SomeUnit' then + begin + result := true; + SourceCode := + + 'unit SomeUnit;' + #13#10 + + 'interface' + #13#10 + + 'procedure P;' + #13#10 + + 'implementation' + #13#10 + + 'procedure P;' + #13#10 + + 'begin' + #13#10 + + ' ShowMessage(''Hello'');' + #13#10 + + 'end;' + #13#10 + + 'end.' + #13#10; + + end + else + result := false; // default processing +end; + +initialization + RegisterHeader(0, 'procedure ShowMessage(const Msg: string);', @ShowMessage); +end. diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/PCU/MyPascalUnit.pas b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/PCU/MyPascalUnit.pas new file mode 100644 index 0000000..70f03ae --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/PCU/MyPascalUnit.pas @@ -0,0 +1,37 @@ +unit MyPascalUnit; +interface +uses + Controls, StdCtrls, Forms, Dialogs; +type + TMyForm = class(TForm) + Button1: TButton; + private + procedure Button1Click(Sender: TObject); + public + constructor Create; + end; + +implementation + +constructor TMyForm.Create; +begin + inherited Create(nil); + Caption := 'My form created in Pascal'; + Button1 := TButton.Create(Self); + with Button1 do + begin + Parent := Self; + Caption := 'Click Me'; + Name := 'Button1'; + Left := 10; + Top := 20; + OnClick := Button1Click; + end; +end; + +procedure TMyForm.Button1Click(Sender: TObject); +begin + ShowMessage('Hello!'); +end; + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/PCU/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/PCU/Project1.dpr new file mode 100644 index 0000000..de94e5f --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/PCU/Project1.dpr @@ -0,0 +1,230 @@ +program Project2; +{$APPTYPE CONSOLE} +uses + sysutils, + Classes, + TypInfo, + Forms, + PAXCOMP_CONSTANTS, + PaxCompiler, + PaxCompilerExplorer, + PaxCompilerDebugger, + PaxBasicLanguage, + PaxInterpreter, + PaxRegister, + PaxRunner, + IMPORT_Common; + +type + TMyHandler = class + private + L: TStringList; + public + constructor Create; + destructor Destroy; override; + procedure SaveToDisk; + function SavePCUCompilerHandler(Sender: TPaxCompiler; const UnitName: String): TStream; + function LoadPCUCompilerHandler(Sender: TPaxCompiler; const UnitName: String): TStream; + procedure UnknownDirectiveHandler(Sender: TPaxCompiler; + const Directive: string; var ok: Boolean); + + procedure LoadPCUProgramHandler(Sender: TPaxRunner; const UnitName: String; + var result: TStream); + + procedure CreateObjectHandler(Sender: TPaxRunner; + Instance: TObject); + procedure AfterObjectCreationHandler(Sender: TPaxRunner; + Instance: TObject); + procedure DestroyObjectHandler(Sender: TPaxRunner; + Instance: TObject); + procedure AfterObjectDestructionHandler(Sender: TPaxRunner; + Instance: TObject); + end; + +constructor TMyHandler.Create; +begin + inherited; + L := TStringList.Create; +end; + +destructor TMyHandler.Destroy; +var + I: Integer; +begin + for I := 0 to L.Count - 1 do + L.Objects[I].Free; + + L.Free; + inherited; +end; + +procedure TMyHandler.SaveToDisk; +var + I: Integer; + Stream: TMemoryStream; + S: String; +begin + for I := 0 to L.Count - 1 do + begin + S := L[I]; + Stream := TMemoryStream(L.Objects[I]); + Stream.Position := 0; + Stream.SaveToFile(S + '.PCU'); + end; +end; + +function TMyHandler.SavePCUCompilerHandler(Sender: TPaxCompiler; const UnitName: String): TStream; +begin + result := TMemoryStream.Create; + L.AddObject(UnitName, result); +end; + +function TMyHandler.LoadPCUCompilerHandler(Sender: TPaxCompiler; const UnitName: String): TStream; +var + I: Integer; +begin + result := nil; + for I := 0 to L.Count - 1 do + if CompareText(L[I], UnitName) = 0 then + begin + result := TStream(L.Objects[I]); + result.Position := 0; + Exit; + end; +end; + +procedure TMyHandler.LoadPCUProgramHandler(Sender: TPaxRunner; const UnitName: String; + var result: TStream); +var + I: Integer; +begin + result := nil; + for I := 0 to L.Count - 1 do + if CompareText(L[I], UnitName) = 0 then + begin + result := TStream(L.Objects[I]); + result.Position := 0; + Exit; + end; +end; + +procedure TMyHandler.CreateObjectHandler(Sender: TPaxRunner; + Instance: TObject); +var + pti: PTypeInfo; + ptd: PTypeData; + S: String; +begin + writeln('OnCreateObject:'); + + if Instance is TForm then + begin + pti := Instance.ClassInfo; + ptd := GetTypeData(pti); + if FileExists(ptd^.UnitName + '.dfm') then + Sender.LoadDFMFile(Instance, ptd^.UnitName + '.dfm'); + end; +end; + +procedure TMyHandler.AfterObjectCreationHandler(Sender: TPaxRunner; + Instance: TObject); +begin + writeln('OnAfterObjectCreation:'); +end; + +procedure TMyHandler.DestroyObjectHandler(Sender: TPaxRunner; + Instance: TObject); +begin + writeln('OnDestroyObject:'); +end; + +procedure TMyHandler.AfterObjectDestructionHandler(Sender: TPaxRunner; + Instance: TObject); +begin + writeln('OnAfterObjectDestruction:'); +end; + +procedure TMyHandler.UnknownDirectiveHandler(Sender: TPaxCompiler; + const Directive: string; var ok: Boolean); +begin + ok := true; +end; + +var + MyHandler: TMyHandler; + +var + PaxCompiler1: TPaxCompiler; + PaxInterpreter1: TPaxInterpreter; + PaxPascalLanguage1: TPaxPascalLanguage; +begin + // Build all units, save pcu-files and create compiled script + + MyHandler := TMyHandler.Create; + try + + PaxCompiler1 := TPaxCompiler.Create(nil); + PaxCompiler1.OnUnknownDirective := MyHandler.UnknownDirectiveHandler; +// PaxCompiler1.OnSavePCU := MyHandler.SavePCUCompilerHandler; +// PaxCompiler1.OnLoadPCU := MyHandler.LoadPCUCompilerHandler; + + PaxInterpreter1 := TPaxInterpreter.Create(nil); + PaxInterpreter1.OnCreateObject := MyHandler.CreateObjectHandler; + PaxInterpreter1.OnAfterObjectCreation := MyHandler.AfterObjectCreationHandler; + PaxInterpreter1.OnDestroyObject := MyHandler.DestroyObjectHandler; + + PaxPascalLanguage1 := TPaxPascalLanguage.Create(nil); + try + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + PaxCompiler1.AddModule('1', 'Pascal'); +// PaxCompiler1.AddCodeFromFile('1', 'script.txt'); + PaxCompiler1.AddCodeFromFile('1', 'script6.txt'); + + if PaxCompiler1.Compile(PaxInterpreter1, true, false) then + // build with run-time packages + begin + PaxInterpreter1.Run; + writeln('Press any key...'); + Readln; + PaxInterpreter1.SaveToFile('script.bin'); +// Exit; + end + else + begin + writeln(PaxCompiler1.ErrorMessage[0]); + writeln(PaxCompiler1.ErrorLine[0]); + writeln('Press any key...'); + Readln; + Exit; + end; + finally + PaxCompiler1.Free; + PaxInterpreter1.Free; + PaxPascalLanguage1.Free; + end; + +// MyHandler.SaveToDisk; + + // Use compiled units (pcu-files) at run-tme as run-time packages + + PaxInterpreter1 := TPaxInterpreter.Create(nil); + PaxInterpreter1.OnCreateObject := MyHandler.CreateObjectHandler; + PaxInterpreter1.OnAfterObjectCreation := MyHandler.AfterObjectCreationHandler; + PaxInterpreter1.OnDestroyObject := MyHandler.DestroyObjectHandler; + try +// PaxInterpreter1.OnLoadPCU := MyHandler.LoadPCUProgramHandler; + + PaxInterpreter1.LoadFromFile('script.bin'); + PaxInterpreter1.Run; + finally + PaxInterpreter1.Free; + end; + + finally + MyHandler.Free; + end; + + writeln('Press any key...'); + Readln; +end. + diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/PCU/Project2.dpr b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/PCU/Project2.dpr new file mode 100644 index 0000000..d54be0d --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/PCU/Project2.dpr @@ -0,0 +1,105 @@ +program Project2; +{$APPTYPE CONSOLE} +uses + sysutils, + Classes, + TypInfo, + StdCtrls, + Forms, + Dialogs, + PaxRunner, + PaxInterpreter, + PaxRegister; + +type + TMyHandler = class + public + procedure CreateObjectHandler(Sender: TPaxRunner; + Instance: TObject); + procedure MapTableClassRefHandler(Sender: TPaxRunner; + const FullName: String; + Global: Boolean; var ClassRef: TClass); + procedure MapTableProcAddressHandler(Sender: TPaxRunner; + const FullName: String; OverCount: Byte; + Global: Boolean; var Address: Pointer); + end; + +procedure TMyHandler.CreateObjectHandler(Sender: TPaxRunner; + Instance: TObject); +var + pti: PTypeInfo; + ptd: PTypeData; + S: String; +begin + writeln('OnCreateObject:'); + + if Instance is TForm then + begin + pti := Instance.ClassInfo; + ptd := GetTypeData(pti); + if FileExists(ptd^.UnitName + '.dfm') then + Sender.LoadDFMFile(Instance, ptd^.UnitName + '.dfm'); + end; +end; + +procedure TMyHandler.MapTableClassRefHandler(Sender: TPaxRunner; + const FullName: String; + Global: Boolean; var ClassRef: TClass); +begin + if CompareText(FullName, 'Classes.TComponent') = 0 then + ClassRef := Classes.TComponent + else if CompareText(FullName, 'Forms.TCustomForm') = 0 then + ClassRef := Forms.TCustomForm + else if CompareText(FullName, 'Forms.TForm') = 0 then + ClassRef := Forms.TForm + else if CompareText(FullName, 'StdCtrls.TButton') = 0 then + ClassRef := StdCtrls.TButton; +end; + +procedure TMyHandler.MapTableProcAddressHandler(Sender: TPaxRunner; + const FullName: String; OverCount: Byte; + Global: Boolean; var Address: Pointer); +begin + if CompareText(FullName, 'SysUtils.IntToStr') = 0 then + Address := @ SysUtils.IntToStr + else if CompareText(FullName, 'Forms.TCustomForm.ShowModal') = 0 then + Address := @ Forms.TCustomForm.ShowModal + else if CompareText(FullName, 'Forms.TCustomForm.Destroy') = 0 then + Address := @ Forms.TCustomForm.Destroy + else if CompareText(FullName, 'Forms.TForm.Create') = 0 then + Address := @ Forms.TForm.Create + else if CompareText(FullName, 'Dialogs.ShowMessage') = 0 then + Address := @ Dialogs.ShowMessage; +end; + +var + MyHandler: TMyHandler; + +var + PaxInterpreter1: TPaxInterpreter; +begin + try + + // Use compiled units (pcu-files) at run-tme as run-time packages + + PaxInterpreter1 := TPaxInterpreter.Create(nil); + PaxInterpreter1.OnCreateObject := MyHandler.CreateObjectHandler; + try + PaxInterpreter1.OnMapTableClassRef := MyHandler.MapTableClassRefHandler; + PaxInterpreter1.OnMapTableProcAddress := MyHandler.MapTableProcAddressHandler; + + PaxInterpreter1.LoadFromFile('script.bin'); + PaxInterpreter1.MapGlobal; + PaxInterpreter1.Run; + finally + PaxInterpreter1.Free; + end; + + finally + MyHandler.Free; + end; + + writeln('Press any key...'); + Readln; +end. + diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/PCU/Unit2.dfm b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/PCU/Unit2.dfm new file mode 100644 index 0000000..da6204b --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/PCU/Unit2.dfm @@ -0,0 +1,26 @@ +object Form2: TForm2 + Left = 0 + Top = 0 + Caption = 'Form2' + ClientHeight = 216 + ClientWidth = 426 + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'Tahoma' + Font.Style = [] + OldCreateOrder = False + OnCreate = FormCreate + PixelsPerInch = 96 + TextHeight = 13 + object Button1: TButton + Left = 40 + Top = 88 + Width = 75 + Height = 25 + Caption = 'Button1' + TabOrder = 0 + OnClick = Button1Click + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/PCU/Unit2.pas b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/PCU/Unit2.pas new file mode 100644 index 0000000..211caa6 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/PCU/Unit2.pas @@ -0,0 +1,37 @@ +unit Unit2; + +interface + +uses + SysUtils, Variants, Classes, Controls, Forms, + Dialogs, StdCtrls; + +type + TForm2 = class(TForm) + Button1: TButton; + procedure FormCreate(Sender: TObject); + procedure Button1Click(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + end; + +var + Form2: TForm2; + +implementation + +{$R *.dfm} + +procedure TForm2.Button1Click(Sender: TObject); +begin + ShowMessage('Hello'); +end; + +procedure TForm2.FormCreate(Sender: TObject); +begin + ShowMessage('Created'); +end; + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/PCU/UnitB.pas b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/PCU/UnitB.pas new file mode 100644 index 0000000..7dbf663 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/PCU/UnitB.pas @@ -0,0 +1,70 @@ +Unit UnitB; +interface + +procedure PB(X, Y, Z: Integer); + +type + PMyRecord = ^TMyRecord; + + TMyRecord = record + X: Integer; + Y: Integer; + end; + + TProcPB = procedure (X, Y, Z: Integer); + TFuncB = function: Integer of object; stdcall; + + IMyInterface = interface(IUnknown) + ['{E7AA427A-0F4D-4A96-A914-FAB1CA336337}'] + procedure P(X, Y: Integer); cdecl; + function GetX: Integer; + property X: Integer read GetX; + end; + + TMyClassBClass = class of TMyClassB; + + TMyClassB = class(TInterfacedObject, IMyInterface) + constructor Create; + procedure P(X, Y: Integer); cdecl; + function GetX: Integer; + destructor Destroy; override; + end; + + TDynArrB = array of Integer; + +implementation + +uses + UnitA; + +constructor TMyClassB.Create; +begin + inherited; + writeln('Created TMyClassB instance'); +end; + +procedure TMyClassB.P(X, Y: Integer); +begin + writeln(Self.ClassName); + writeln(X, ' ', Y); +end; + +function TMyClassB.GetX: Integer; +begin + result := 123; +end; + + +destructor TMyClassB.Destroy; +begin + writeln('Done'); + inherited; +end; + +procedure PB(X, Y, Z: Integer); +begin + writeln('ProcB'); + ProcA; +end; + +end. \ No newline at end of file diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/PCU/UnitC.pas b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/PCU/UnitC.pas new file mode 100644 index 0000000..33f21fb --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/PCU/UnitC.pas @@ -0,0 +1,46 @@ +Unit UnitC; +interface +uses SysUtils; + +type + TSS = String[5]; + TArrC = array[1..2, 1..3] of Integer; + + CheckFailed = CLASS(Exception) + end; + OtherFailed = CLASS(Exception) + end; + +procedure ProcC(const A: array of Integer); +procedure DoScriptExc; + +implementation + +procedure ProcC(const A: array of Integer); +var + I: Integer; +begin + I := 0; + try + I := I div I; + except + writeln(123); + end; +end; + +procedure DoScriptExc; +begin + try + RAISE checkFailed.create('Select check failed'); +// RAISE OtherFailed.create('Select check failed'); + // RAISE exception.create('Select check failed'); + except + on CheckFailed do + writeln('checkfailed raised'); + else + writeln('other raised'); + end; +end; + + +end. \ No newline at end of file diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/PCU/UnitD.pas b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/PCU/UnitD.pas new file mode 100644 index 0000000..fcfa4d6 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/PCU/UnitD.pas @@ -0,0 +1,50 @@ +Unit UnitD; +interface + +const + ConstIntD = 45; + ConstInitStrD: String = 'abc'; + ConstStrD = 'abc'; + ConstSetD = ['a'..'z']; + +type + TMyClassD = class + constructor Create; + procedure P; virtual; + procedure Q; virtual; + end; + +procedure MyProcD; overload; +procedure MyProcD(X: Integer); overload; + +implementation + +constructor TMyClassD.Create; +begin + inherited; + writeln('MyClassD.Create'); +end; + + +procedure TMyClassD.P; +begin + writeln('MyClassD.P'); +end; + +procedure TMyClassD.Q; +begin + writeln('MyClassD.Q'); +end; + +procedure MyProcD; +begin + writeln(1); +end; + +procedure MyProcD(X: Integer); +begin + writeln(2); +end; + + +end. \ No newline at end of file diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/PCU/UnitE.pas b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/PCU/UnitE.pas new file mode 100644 index 0000000..e84f0dc --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/PCU/UnitE.pas @@ -0,0 +1,27 @@ +Unit UnitE; +interface +uses SysUtils; + +procedure ProcE; overload; +procedure ProcE(X: Integer); overload; +procedure TestHostProc; + +implementation + +procedure ProcE; +begin + writeln(1); +end; + +procedure ProcE(X: Integer); +begin + writeln(2); +end; + +procedure TestHostProc; +begin + writeln(IntToStr(123)); +end; + + +end. \ No newline at end of file diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/PCU/script.txt b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/PCU/script.txt new file mode 100644 index 0000000..aaf79f7 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/PCU/script.txt @@ -0,0 +1,60 @@ +uses + UnitA, UnitB; +var + ProcPB: TProcPB; + I: Integer; + EnumA: TEnumA; + ArrA: TArrA; + SetA: TSetA; + IntAliasA: TIntAliasA; + X: TMyScriptClass; + MyRecord: TMyRecord; + MyInterface: IMyInterface; + Y: TMyClassB; + C: TMyClassBClass; + A: TDynArrB; +begin + Y := TMyClassB.Create; + + MyInterface := TMyClassB.Create as IMyInterface; + MyInterface.P(3, 4); + writeln(MyInterface.X); + + SetLength(A, 3); + A[2] := 77; + writeln(A[2]); + + C := TMyClassB; + writeln(C.ClassName); + + ProcPB := PB; + ProcPB(1, 2, 3); + + + MyRecord.Y := 888; + writeln(MyRecord.Y); + + X := TMyScriptClass.Create; + X.X := TObject.Create; + writeln(X.X.ClassName); + X.MethodP(2, 3); + X.MethodF; + TMyScriptClass.MethodCP; + X.Y := 999; + writeln(X.Y); + + writeln(X is TMyScriptClass); + writeln(X.ClassName); + writeln(TMyScriptClass.ClassName); + X.Free; + + EnumA := TwoA; + writeln(Ord(EnumA)); + ArrA['p'] := EnumA; + writeln(Ord(ArrA['p'])); + I := FuncA(2, 3); + writeln(I); + writeln(XA); + writeln(SA); + SA := 5; +end. \ No newline at end of file diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/PCU/script2.txt b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/PCU/script2.txt new file mode 100644 index 0000000..eae12fa --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/PCU/script2.txt @@ -0,0 +1,7 @@ +uses + UnitC; +begin + ProcC([1, 2, 3]); + writeln(456); + DoScriptExc; +end. \ No newline at end of file diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/PCU/script3.txt b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/PCU/script3.txt new file mode 100644 index 0000000..773d49e --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/PCU/script3.txt @@ -0,0 +1,8 @@ +uses Forms, MyPascalUnit; +var + F: TMyForm; +begin + F := TMyForm.Create; + F.ShowModal; + F.Free; +end. \ No newline at end of file diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/PCU/script4.txt b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/PCU/script4.txt new file mode 100644 index 0000000..4916e82 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/PCU/script4.txt @@ -0,0 +1,38 @@ +uses + UnitD; +type + TMyClass = class(TMyClassD) + constructor Create; + procedure P; override; + end; + +constructor TMyClass.Create; +begin + inherited; + writeln('TMyClass.Create'); +end; + + +procedure TMyClass.P; +begin + inherited; + writeln('TMyClass.P'); +end; + +var + X: TMyClassD; +begin + X := TMyClassD.Create; + X.Q; + X.Free; + + X := TMyClass.Create; + X.P; + X.Q; + X.Free; + + writeln(ConstIntD); + writeln(ConstStrD); + writeln('b' in ConstSetD); + writeln('B' in ConstSetD); +end. \ No newline at end of file diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/PCU/script5.txt b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/PCU/script5.txt new file mode 100644 index 0000000..473d18c --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/PCU/script5.txt @@ -0,0 +1,4 @@ +uses UnitY; +begin + ProcY; +end. \ No newline at end of file diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/PCU/script6.txt b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/PCU/script6.txt new file mode 100644 index 0000000..792ce4b --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/PCU/script6.txt @@ -0,0 +1,8 @@ +uses Forms, Unit2; +var + F: TForm2; +begin + F := TForm2.Create(nil); + F.ShowModal; + F.Free; +end. \ No newline at end of file diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/PCU/script7.txt b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/PCU/script7.txt new file mode 100644 index 0000000..1c0a370 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/PCU/script7.txt @@ -0,0 +1,6 @@ +uses UnitE; +begin + ProcE(1); + ProcE; + TestHostProc; +end. \ No newline at end of file diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/PCU/unitA.pas b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/PCU/unitA.pas new file mode 100644 index 0000000..398a619 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/PCU/unitA.pas @@ -0,0 +1,83 @@ +unit UnitA; +interface +uses + UnitB; + +type + TIntAliasA = Integer; + + TEnumA = (OneA, TwoA); + + TArrA = array['a'..'z'] of TEnumA; + + TSetA = set of TEnumA; + + TMyScriptClass = class + FX: TObject; + public + FY: Integer; + constructor Create; + destructor Destroy; override; + procedure MethodP(X, Y: Integer); + function MethodF: Integer; // virtual; + class procedure MethodCP; + property Y: Integer read FY write FY; + published + property X: TObject read FX write FX; + end; + + +function FuncA(X, Y: Integer): Integer; +procedure ProcA; + +var XA: Integer = 55; + +const + SA: Integer = 11; + +implementation + +constructor TMyScriptClass.Create; +begin + inherited; + writeln('Create'); +end; + +destructor TMyScriptClass.Destroy; +begin + writeln('Destroy'); + inherited; +end; + +procedure TMyScriptClass.MethodP(X, Y: Integer); +begin + writeln('MethodP', X, Y); +end; + +function TMyScriptClass.MethodF: Integer; +begin + writeln('MethodF'); +end; + +class procedure TMyScriptClass.MethodCP; +begin + writeln('MethodCP'); +end; + + +function FuncA(X, Y: Integer): Integer; +begin + PB(1, 2, 3); + try + result := X + Y; + finally + writeln('123'); + end; +end; + +procedure ProcA; +begin + writeln('ProcA'); +end; + +end. \ No newline at end of file diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/PCU/unitX.pas b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/PCU/unitX.pas new file mode 100644 index 0000000..1e80879 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/PCU/unitX.pas @@ -0,0 +1,30 @@ +unit UnitX; +interface + +type + TClassX = class + constructor Create; + procedure ProcX; virtual; + destructor Destroy; override; + end; + +implementation + +constructor TClassX.Create; +begin + inherited; + writeln('ClassX object created'); +end; + +procedure TClassX.ProcX; +begin + writeln('ProcX'); +end; + +destructor TClassX.Destroy; +begin + writeln('ClassX object destroyed'); + inherited; +end; + +end. \ No newline at end of file diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/PCU/unitY.pas b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/PCU/unitY.pas new file mode 100644 index 0000000..f325cca --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/PCU/unitY.pas @@ -0,0 +1,19 @@ +unit UnitY; +interface +uses + UnitX; + +procedure ProcY; + +implementation + +procedure ProcY; +var + X: TClassX; +begin + X := TClassX.Create; + X.ProcX; + X.Free; +end; + +end. \ No newline at end of file diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/RTTI/1/IMPORT_TypInfo.pas b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/RTTI/1/IMPORT_TypInfo.pas new file mode 100644 index 0000000..4767808 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/RTTI/1/IMPORT_TypInfo.pas @@ -0,0 +1,703 @@ +unit IMPORT_TypInfo; +interface + +procedure Register_TypInfo; + +implementation + +uses + Variants, + SysUtils, + TypInfo, + PaxRegister; +{ + Result := RegisterEnumType (H, 'TTypeKind'); + RegisterEnumValue (Result, 'tkUnknown', 0); + RegisterEnumValue (Result, 'tkInteger', 1); + RegisterEnumValue (Result, 'tkChar', 2); + RegisterEnumValue (Result, 'tkEnumeration', 3); + RegisterEnumValue (Result, 'tkFloat', 4); + RegisterEnumValue (Result, 'tkString', 5); + RegisterEnumValue (Result, 'tkSet', 6); + RegisterEnumValue (Result, 'tkClass', 7); + RegisterEnumValue (Result, 'tkMethod', 8); + RegisterEnumValue (Result, 'tkWChar', 9); + RegisterEnumValue (Result, 'tkLString', 10); + RegisterEnumValue (Result, 'tkWString', 11); + RegisterEnumValue (Result, 'tkVariant', 12); + RegisterEnumValue (Result, 'tkArray', 13); + RegisterEnumValue (Result, 'tkRecord', 14); + RegisterEnumValue (Result, 'tkInterface', 15); + RegisterEnumValue (Result, 'tkInt64', 16); + RegisterEnumValue (Result, 'tkDynArray', 17); +end; + +//==================================================================== +// TPublishableVariantType +//==================================================================== + + +//-------------------------------------------------------------------- +// RegisterClass_TPublishableVariantType +//-------------------------------------------------------------------- + +function RegisterClass_TPublishableVariantType (H: integer): integer; +begin + Result := RegisterClassType (H, TPublishableVariantType); + + RegisterHeader (Result, + 'function GetProperty (var Dest: TVarData; const V: TVarData; const Name: String): Boolean; override;', + @TPublishableVariantType.GetProperty); + RegisterHeader (Result, + 'function SetProperty (const V: TVarData; const Name: String; const Value: TVarData): Boolean; override;', + @TPublishableVariantType.SetProperty); +end; + +//-------------------------------------------------------------------- +// RegisterSet_TTypeKinds +//-------------------------------------------------------------------- + +function RegisterSet_TTypeKinds (H: integer): integer; +begin +// Result := RegisterSetType (H, 'TTypeKinds', T); +end; + +//-------------------------------------------------------------------- +// RegisterEnumerated_TOrdType +//-------------------------------------------------------------------- + +function RegisterEnumerated_TOrdType (H: integer): integer; +begin + Result := RegisterEnumType (H, 'TOrdType'); + RegisterEnumValue (Result, 'otSByte', 0); + RegisterEnumValue (Result, 'otUByte', 1); + RegisterEnumValue (Result, 'otSWord', 2); + RegisterEnumValue (Result, 'otUWord', 3); + RegisterEnumValue (Result, 'otSLong', 4); + RegisterEnumValue (Result, 'otULong', 5); +end; + +//-------------------------------------------------------------------- +// RegisterEnumerated_TFloatType +//-------------------------------------------------------------------- + +function RegisterEnumerated_TFloatType (H: integer): integer; +begin + Result := RegisterEnumType (H, 'TFloatType'); + RegisterEnumValue (Result, 'ftSingle', 0); + RegisterEnumValue (Result, 'ftDouble', 1); + RegisterEnumValue (Result, 'ftExtended', 2); + RegisterEnumValue (Result, 'ftComp', 3); + RegisterEnumValue (Result, 'ftCurr', 4); +end; + +//-------------------------------------------------------------------- +// RegisterEnumerated_TMethodKind +//-------------------------------------------------------------------- + +function RegisterEnumerated_TMethodKind (H: integer): integer; +begin + Result := RegisterEnumType (H, 'TMethodKind'); + RegisterEnumValue (Result, 'mkProcedure', 0); + RegisterEnumValue (Result, 'mkFunction', 1); + RegisterEnumValue (Result, 'mkConstructor', 2); + RegisterEnumValue (Result, 'mkDestructor', 3); + RegisterEnumValue (Result, 'mkClassProcedure', 4); + RegisterEnumValue (Result, 'mkClassFunction', 5); + RegisterEnumValue (Result, 'mkSafeProcedure', 6); + RegisterEnumValue (Result, 'mkSafeFunction', 7); +end; + +//-------------------------------------------------------------------- +// RegisterEnumerated_TParamFlag +//-------------------------------------------------------------------- + +function RegisterEnumerated_TParamFlag (H: integer): integer; +begin + Result := RegisterEnumType (H, 'TParamFlag'); + RegisterEnumValue (Result, 'pfVar', 0); + RegisterEnumValue (Result, 'pfConst', 1); + RegisterEnumValue (Result, 'pfArray', 2); + RegisterEnumValue (Result, 'pfAddress', 3); + RegisterEnumValue (Result, 'pfReference', 4); + RegisterEnumValue (Result, 'pfOut', 5); + Result := RegisterSetType (H, 'TParamFlags', T); +end; + +function RegisterSet_TParamFlagsBase (H: integer): integer; +var + T: integer; +begin + T := LookupTypeID ('TParamFlag'); + if T = 0 then + Raise ENNPaxFormater.Create ('Invalid type name: TParamFlag'); + Result := RegisterSetType (H, 'TParamFlagsBase', T); +end; + +//-------------------------------------------------------------------- +// RegisterEnumerated_TIntfFlag +//-------------------------------------------------------------------- + +function RegisterEnumerated_TIntfFlag (H: integer): integer; +begin + Result := RegisterEnumType (H, 'TIntfFlag'); + RegisterEnumValue (Result, 'ifHasGuid', 0); + RegisterEnumValue (Result, 'ifDispInterface', 1); + RegisterEnumValue (Result, 'ifDispatch', 2); +end; + +//-------------------------------------------------------------------- +// RegisterSet_TIntfFlags +//-------------------------------------------------------------------- + +function RegisterSet_TIntfFlags (H: integer): integer; +var + T: integer; +begin + T := LookupTypeID ('TIntfFlag'); + if T = 0 then + Raise ENNPaxFormater.Create ('Invalid type name: TIntfFlag'); + Result := RegisterSetType (H, 'TIntfFlags', T); +end; + +//-------------------------------------------------------------------- +// RegisterSet_TIntfFlagsBase +//-------------------------------------------------------------------- + +function RegisterSet_TIntfFlagsBase (H: integer): integer; +var + T: integer; +begin + T := LookupTypeID ('TIntfFlag'); + if T = 0 then + Raise ENNPaxFormater.Create ('Invalid type name: TIntfFlag'); + Result := RegisterSetType (H, 'TIntfFlagsBase', T); +end; + +//-------------------------------------------------------------------- +// RegisterPointer_PPTypeInfo +//-------------------------------------------------------------------- + +function RegisterPointer_PPTypeInfo (H: integer): integer; +var + T: Integer; +begin + T := LookupTypeID ('PTypeInfo'); + if T = 0 then + T := RegisterSomeType (H, 'PTypeInfo'); + Result := RegisterPointerType (H, 'PPTypeInfo', T); +end; + +//-------------------------------------------------------------------- +// RegisterPointer_PTypeInfo +//-------------------------------------------------------------------- + +function RegisterPointer_PTypeInfo (H: integer): integer; +var + T: Integer; +begin + T := LookupTypeID ('TTypeInfo'); + if T = 0 then + T := RegisterSomeType (H, 'TTypeInfo'); + Result := RegisterPointerType (H, 'PTypeInfo', T); +end; + +//-------------------------------------------------------------------- +// RegisterRecord_TTypeInfo +//-------------------------------------------------------------------- + +function RegisterRecord_TTypeInfo (H: integer): integer; +var + T: integer; +begin + Result := RegisterRecordType (H, 'TTypeInfo', False); + T := LookupTypeID ('TTypeKind'); + if T = 0 then + Raise ENNPaxFormater.Create ('Invalid type name: TTypeKind'); + RegisterRecordTypeField (Result, 'Kind', T, 0); + T := _typeSHORTSTRING; + RegisterRecordTypeField (Result, 'Name', T, 0); +end; + +//-------------------------------------------------------------------- +// RegisterPointer_PTypeData +//-------------------------------------------------------------------- + +function RegisterPointer_PTypeData (H: integer): integer; +var + T: Integer; +begin + T := LookupTypeID ('TTypeData'); + if T = 0 then + T := RegisterSomeType (H, 'TTypeData'); + Result := RegisterPointerType (H, 'PTypeData', T); +end; + +//-------------------------------------------------------------------- +// RegisterArray_fake_ParamList_18 +//-------------------------------------------------------------------- + +function RegisterArray_fake_ParamList_18 (H: integer): integer; +var + R,T: integer; +begin + R := RegisterTypeDeclaration (H, 'fake_ParamList_18_19 = 0..1023;'); + T := _typeCHAR; + Result := RegisterArrayType (H, 'fake_ParamList_18', R, T, False); +end; + +//-------------------------------------------------------------------- +// RegisterRecord_TTypeData +//-------------------------------------------------------------------- + +function RegisterRecord_TTypeData (H: integer): integer; +var + T: integer; +begin + Result := RegisterRecordType (H, 'TTypeData', False); + T := LookupTypeID ('TOrdType'); + if T = 0 then + Raise ENNPaxFormater.Create ('Invalid type name: TOrdType'); + RegisterVariantRecordTypeField (Result, 'OrdType', T, 02); + T := _typeINTEGER; + RegisterVariantRecordTypeField (Result, 'MinValue', T, 0102); + T := _typeINTEGER; + RegisterVariantRecordTypeField (Result, 'MaxValue', T, 0102); + T := LookupTypeID ('PPTypeInfo'); + if T = 0 then + Raise ENNPaxFormater.Create ('Invalid type name: PPTypeInfo'); + RegisterVariantRecordTypeField (Result, 'BaseType', T, 020102); + T := LookupTypeID ('ShortStringBase'); + if T = 0 then + Raise ENNPaxFormater.Create ('Invalid type name: ShortStringBase'); + RegisterVariantRecordTypeField (Result, 'NameList', T, 020102); + T := LookupTypeID ('ShortStringBase'); + if T = 0 then + Raise ENNPaxFormater.Create ('Invalid type name: ShortStringBase'); + RegisterVariantRecordTypeField (Result, 'EnumUnitName', T, 020102); + T := LookupTypeID ('PPTypeInfo'); + if T = 0 then + Raise ENNPaxFormater.Create ('Invalid type name: PPTypeInfo'); + RegisterVariantRecordTypeField (Result, 'CompType', T, 0202); + T := LookupTypeID ('TFloatType'); + if T = 0 then + Raise ENNPaxFormater.Create ('Invalid type name: TFloatType'); + RegisterVariantRecordTypeField (Result, 'FloatType', T, 03); + T := _typeBYTE; + RegisterVariantRecordTypeField (Result, 'MaxLength', T, 04); + T := LookupTypeID ('TClass'); + if T = 0 then + Raise ENNPaxFormater.Create ('Invalid type name: TClass'); + RegisterVariantRecordTypeField (Result, 'ClassType', T, 05); + T := LookupTypeID ('PPTypeInfo'); + if T = 0 then + Raise ENNPaxFormater.Create ('Invalid type name: PPTypeInfo'); + RegisterVariantRecordTypeField (Result, 'ParentInfo', T, 05); + T := _typeSMALLINT; + RegisterVariantRecordTypeField (Result, 'PropCount', T, 05); + T := LookupTypeID ('ShortStringBase'); + if T = 0 then + Raise ENNPaxFormater.Create ('Invalid type name: ShortStringBase'); + RegisterVariantRecordTypeField (Result, 'UnitName', T, 05); + T := LookupTypeID ('TMethodKind'); + if T = 0 then + Raise ENNPaxFormater.Create ('Invalid type name: TMethodKind'); + RegisterVariantRecordTypeField (Result, 'MethodKind', T, 06); + T := _typeBYTE; + RegisterVariantRecordTypeField (Result, 'ParamCount', T, 06); + T := RegisterArray_fake_ParamList_18 (H); + RegisterVariantRecordTypeField (Result, 'ParamList', T, 06); + T := LookupTypeID ('PPTypeInfo'); + if T = 0 then + Raise ENNPaxFormater.Create ('Invalid type name: PPTypeInfo'); + RegisterVariantRecordTypeField (Result, 'IntfParent', T, 07); + T := LookupTypeID ('TIntfFlagsBase'); + if T = 0 then + Raise ENNPaxFormater.Create ('Invalid type name: TIntfFlagsBase'); + RegisterVariantRecordTypeField (Result, 'IntfFlags', T, 07); + T := LookupTypeID ('TGUID'); + if T = 0 then + Raise ENNPaxFormater.Create ('Invalid type name: TGUID'); + RegisterVariantRecordTypeField (Result, 'Guid', T, 07); + T := LookupTypeID ('ShortStringBase'); + if T = 0 then + Raise ENNPaxFormater.Create ('Invalid type name: ShortStringBase'); + RegisterVariantRecordTypeField (Result, 'IntfUnit', T, 07); + T := _typeINT64; + RegisterVariantRecordTypeField (Result, 'MinInt64Value', T, 08); + RegisterVariantRecordTypeField (Result, 'MaxInt64Value', T, 08); + T := _typeINTEGER; + RegisterVariantRecordTypeField (Result, 'elSize', T, 09); + T := LookupTypeID ('PPTypeInfo'); + if T = 0 then + Raise ENNPaxFormater.Create ('Invalid type name: PPTypeInfo'); + RegisterVariantRecordTypeField (Result, 'elType', T, 09); + T := _typeINTEGER; + RegisterVariantRecordTypeField (Result, 'varType', T, 09); + T := LookupTypeID ('PPTypeInfo'); + if T = 0 then + Raise ENNPaxFormater.Create ('Invalid type name: PPTypeInfo'); + RegisterVariantRecordTypeField (Result, 'elType2', T, 09); + T := LookupTypeID ('ShortStringBase'); + if T = 0 then + Raise ENNPaxFormater.Create ('Invalid type name: ShortStringBase'); + RegisterVariantRecordTypeField (Result, 'DynUnitName', T, 09); +end; + +//-------------------------------------------------------------------- +// RegisterRecord_fake_PropList_31 +//-------------------------------------------------------------------- + +function RegisterRecord_fake_PropList_31 (H: integer): integer; +var + T: integer; +begin + Result := RegisterRecordType (H, 'fake_PropList_31', False); +end; + +//-------------------------------------------------------------------- +// RegisterRecord_TPropData +//-------------------------------------------------------------------- + +function RegisterRecord_TPropData (H: integer): integer; +var + T: integer; +begin + Result := RegisterRecordType (H, 'TPropData', False); + T := _typeWORD; + RegisterRecordTypeField (Result, 'PropCount', T, 0); + T := RegisterRecord_fake_PropList_31 (H); + RegisterRecordTypeField (Result, 'PropList', T, 0); +end; + +//-------------------------------------------------------------------- +// RegisterPointer_PPropInfo +//-------------------------------------------------------------------- + +function RegisterPointer_PPropInfo (H: integer): integer; +var + T: Integer; +begin + T := LookupTypeID ('TPropInfo'); + if T = 0 then + T := RegisterSomeType (H, 'TPropInfo'); + Result := RegisterPointerType (H, 'PPropInfo', T); +end; + +//-------------------------------------------------------------------- +// RegisterRecord_TPropInfo +//-------------------------------------------------------------------- + +function RegisterRecord_TPropInfo (H: integer): integer; +var + T: integer; +begin + Result := RegisterRecordType (H, 'TPropInfo', False); + T := LookupTypeID ('PPTypeInfo'); + if T = 0 then + Raise ENNPaxFormater.Create ('Invalid type name: PPTypeInfo'); + RegisterRecordTypeField (Result, 'PropType', T, 0); + T := _typePOINTER; + RegisterRecordTypeField (Result, 'GetProc', T, 0); + T := _typePOINTER; + RegisterRecordTypeField (Result, 'SetProc', T, 0); + T := _typePOINTER; + RegisterRecordTypeField (Result, 'StoredProc', T, 0); + T := _typeINTEGER; + RegisterRecordTypeField (Result, 'Index', T, 0); + T := _typeINTEGER; + RegisterRecordTypeField (Result, 'Default', T, 0); + T := _typeSMALLINT; + RegisterRecordTypeField (Result, 'NameIndex', T, 0); + T := _typeSHORTSTRING; + RegisterRecordTypeField (Result, 'Name', T, 0); +end; + +//-------------------------------------------------------------------- +// RegisterProcedural_TPropInfoProc +//-------------------------------------------------------------------- + +function RegisterProcedural_TPropInfoProc (H: integer): integer; +begin + Result := RegisterHeader (H, 'procedure fake_TPropInfoProc_40 (PropInfo: PPropInfo);', Nil); + Result := RegisterEventType (H, 'TPropInfoProc', Result); +end; + +//-------------------------------------------------------------------- +// RegisterPointer_PPropList +//-------------------------------------------------------------------- + +function RegisterPointer_PPropList (H: integer): integer; +var + T: Integer; +begin + T := LookupTypeID ('TPropList'); + if T = 0 then + T := RegisterSomeType (H, 'TPropList'); + Result := RegisterPointerType (H, 'PPropList', T); +end; + +//-------------------------------------------------------------------- +// RegisterArray_TPropList +//-------------------------------------------------------------------- + +function RegisterArray_TPropList (H: integer): integer; +var + R,T: integer; +begin + R := RegisterTypeDeclaration (H, 'fake_TPropList_41 = 0..16379;'); + T := LookupTypeID ('PPropInfo'); + if T = 0 then + Raise ENNPaxFormater.Create ('Invalid type name: PPropInfo'); + Result := RegisterArrayType (H, 'TPropList', R, T, False); +end; + +//==================================================================== +// EPropertyError +//==================================================================== + + +//-------------------------------------------------------------------- +// RegisterClass_EPropertyError +//-------------------------------------------------------------------- + +function RegisterClass_EPropertyError (H: integer): integer; +begin + Result := RegisterClassType (H, EPropertyError); + +end; + +//==================================================================== +// EPropertyConvertError +//==================================================================== + + +//-------------------------------------------------------------------- +// RegisterClass_EPropertyConvertError +//-------------------------------------------------------------------- + +function RegisterClass_EPropertyConvertError (H: integer): integer; +begin + Result := RegisterClassType (H, EPropertyConvertError); + +end; + +//-------------------------------------------------------------------- +// RegisterArray_fake_BooleanIdents_42 +//-------------------------------------------------------------------- + +function RegisterArray_fake_BooleanIdents_42 (H: integer): integer; +var + R,T: integer; +begin + R := _typeBOOLEAN; + T := RegisterTypeAlias (H, 'BooleanIdents', _typeSTRING); + Result := RegisterArrayType (H, 'fake_BooleanIdents_42', R, T, False); +end; + +//-------------------------------------------------------------------- +// DoRegisterVariable_BooleanIdents +//-------------------------------------------------------------------- + +function DoRegisterVariable_BooleanIdents (H: Integer): integer; +var + T: integer; +begin + T := RegisterArray_fake_BooleanIdents_42 (H); + result := RegisterVariable (H, 'BooleanIdents', T, @BooleanIdents); +end; + + +//-------------------------------------------------------------------- +// RegisterNameSpace_TypInfo +//-------------------------------------------------------------------- + +procedure RegisterNameSpace_TypInfo; +begin + RegisterNameSpace (0, 'TypInfo'); +end; + + +//-------------------------------------------------------------------- +// Register_TypInfo +//-------------------------------------------------------------------- +} +procedure Register_TypInfo; +var + H, G, A: integer; +begin + H := RegisterNamespace(0, 'TypInfo'); + RegisterRTTIType(H, TypeInfo(TTypeKind)); + RegisterRTTIType(H, TypeInfo(TTypeKinds)); + RegisterRTTIType(H, TypeInfo(TOrdType)); + RegisterRTTIType(H, TypeInfo(TFloatType)); + RegisterRTTIType(H, TypeInfo(TMethodKind)); + RegisterRTTIType(H, TypeInfo(TParamFlag)); + RegisterRTTIType(H, TypeInfo(TParamFlags)); + RegisterRTTIType(H, TypeInfo(TParamFlagsBase)); + RegisterRTTIType(H, TypeInfo(TIntfFlag)); + RegisterRTTIType(H, TypeInfo(TIntfFlags)); + RegisterRTTIType(H, TypeInfo(TIntfFlagsBase)); + + G := RegisterRecordType(H, 'TTypeInfo'); + RegisterRecordTypeField(G, 'Kind', RegisterRTTIType(H, TypeInfo(TTypeKind))); + RegisterRecordTypeField(G, 'Name', _typeSHORTSTRING); + G := RegisterPointerType(H, 'PTypeInfo', G); + G := RegisterPointerType(H, 'PPTypeInfo', G); + + G := RegisterRecordType(H, 'TPropInfo'); + RegisterRecordTypeField(G, 'PropType: PPtypeInfo', 0); + RegisterRecordTypeField(G, 'GetProc', _typePOINTER); + RegisterRecordTypeField(G, 'SetProc', _typePOINTER); + RegisterRecordTypeField(G, 'StoredProc', _typePOINTER); + RegisterRecordTypeField(G, 'Index', _typeINTEGER); + RegisterRecordTypeField(G, 'Default', _typeINTEGER); + RegisterRecordTypeField(G, 'NameIndex', _typeSMALLINT); + RegisterRecordTypeField(G, 'Name', _typeSHORTSTRING); + RegisterPointerType(H, 'PPropInfo', G); + + G := RegisterRecordType(H, 'TPropData'); + RegisterRecordTypeField(G, 'PropCount: Word;', 0); + + A := RegisterArrayType(0, '', RegisterSubrangeType(0, '', _typeINTEGER, 0, 1023), _typeANSICHAR); + + G := RegisterRecordType (H, 'TTypeData', False); + RegisterVariantRecordTypeField(G, 'OrdType: TOrdType', 02); + RegisterVariantRecordTypeField(G, 'MinValue', _typeINTEGER, 0102); + RegisterVariantRecordTypeField(G, 'MaxValue', _typeINTEGER, 0102); + RegisterVariantRecordTypeField(G, 'BaseType: PPTypeInfo', 020102); + RegisterVariantRecordTypeField(G, 'NameList: ShortString', 020102); + RegisterVariantRecordTypeField(G, 'EnumUnitName: ShortString', 020102); + RegisterVariantRecordTypeField(G, 'CompType: PPTypeInfo', 0202); + RegisterVariantRecordTypeField(G, 'FloatType: TFloatType', 03); + RegisterVariantRecordTypeField(G, 'MaxLength', _typeBYTE, 04); + RegisterVariantRecordTypeField(G, 'ClassType: TClass', 05); + RegisterVariantRecordTypeField(G, 'ParentInfo: PPTypeInfo', 05); + RegisterVariantRecordTypeField(G, 'PropCount', _typeSMALLINT, 05); + RegisterVariantRecordTypeField(G, 'UnitName', _typeSHORTSTRING, 05); + RegisterVariantRecordTypeField(G, 'MethodKind: TMethodKind', 06); + RegisterVariantRecordTypeField(G, 'ParamCount', _typeBYTE, 06); + + + RegisterVariantRecordTypeField(G, 'ParamList', A, 06); + RegisterVariantRecordTypeField(G, 'IntfParent: PPTypeInfo', 07); + RegisterVariantRecordTypeField(G, 'IntfFlags: TIntfFlagsBase', 07); + RegisterVariantRecordTypeField(G, 'Guid: TGUID', 07); + RegisterVariantRecordTypeField(G, 'IntfUnit', _typeSHORTSTRING, 07); + RegisterVariantRecordTypeField(G, 'MinInt64Value', _typeINT64, 08); + RegisterVariantRecordTypeField(G, 'MaxInt64Value', _typeINT64, 08); + RegisterVariantRecordTypeField(G, 'elSize', _typeINTEGER, 09); + RegisterVariantRecordTypeField(G, 'elType: PPTypeInfo', 09); + RegisterVariantRecordTypeField(G, 'varType', _typeINTEGER, 09); + RegisterVariantRecordTypeField(G, 'elType2: PPTypeInfo', 09); + RegisterVariantRecordTypeField(G, 'DynUnitName', _typeSHORTSTRING, 09); + + RegisterHeader (H, 'function PropType (Instance: TObject; const PropName: String): TTypeKind; overload;', Nil); + RegisterHeader (H, 'function PropType (AClass: TClass; const PropName: String): TTypeKind; overload;', Nil); + RegisterHeader (H, 'function PropIsType (Instance: TObject; const PropName: String; TypeKind: TTypeKind): Boolean; overload;' + , Nil); + RegisterHeader (H, 'function PropIsType (AClass: TClass; const PropName: String; TypeKind: TTypeKind): Boolean; overload;', + Nil); + RegisterHeader (H, 'function IsStoredProp (Instance: TObject; const PropName: String): Boolean; overload;', Nil); + RegisterHeader (H, 'function IsPublishedProp (Instance: TObject; const PropName: String): Boolean; overload;', Nil); + RegisterHeader (H, 'function IsPublishedProp (AClass: TClass; const PropName: String): Boolean; overload;', Nil); + RegisterHeader (H, 'function GetOrdProp (Instance: TObject; const PropName: String): Longint; overload;', Nil); + RegisterHeader (H, 'procedure SetOrdProp (Instance: TObject; const PropName: String; Value: Longint); overload;', Nil); + RegisterHeader (H, 'function GetEnumProp (Instance: TObject; const PropName: String): String; overload;', Nil); + RegisterHeader (H, 'procedure SetEnumProp (Instance: TObject; const PropName: String; const Value: String); overload;', Nil); + RegisterHeader (H, 'function GetSetProp (Instance: TObject; const PropName: String; Brackets: Boolean = False): String; ' + + 'overload;', Nil); + RegisterHeader (H, 'procedure SetSetProp (Instance: TObject; const PropName: String; const Value: String); overload;', Nil); + RegisterHeader (H, 'function GetObjectProp (Instance: TObject; const PropName: String; MinClass: TClass = nil): TObject; ' + + 'overload;', Nil); + RegisterHeader (H, 'procedure SetObjectProp (Instance: TObject; const PropName: String; Value: TObject); overload;', Nil); + RegisterHeader (H, 'function GetObjectPropClass (Instance: TObject; const PropName: String): TClass; overload;', Nil); + RegisterHeader (H, 'function GetStrProp (Instance: TObject; const PropName: String): String; overload;', Nil); + RegisterHeader (H, 'procedure SetStrProp (Instance: TObject; const PropName: String; const Value: String); overload;', Nil); + RegisterHeader (H, 'function GetWideStrProp (Instance: TObject; const PropName: String): WideString; overload;', Nil); + RegisterHeader (H, 'procedure SetWideStrProp (Instance: TObject; const PropName: String; const Value: WideString); overload;' + , Nil); + RegisterHeader (H, 'function GetFloatProp (Instance: TObject; const PropName: String): Extended; overload;', Nil); + RegisterHeader (H, 'procedure SetFloatProp (Instance: TObject; const PropName: String; const Value: Extended); overload;', + Nil); + RegisterHeader (H, 'function GetVariantProp (Instance: TObject; const PropName: String): Variant; overload;', Nil); + RegisterHeader (H, 'procedure SetVariantProp (Instance: TObject; const PropName: String; const Value: Variant); overload;', + Nil); + RegisterHeader (H, 'function GetMethodProp (Instance: TObject; const PropName: String): TMethod; overload;', Nil); + RegisterHeader (H, 'procedure SetMethodProp (Instance: TObject; const PropName: String; const Value: TMethod); overload;', + Nil); + RegisterHeader (H, 'function GetInt64Prop (Instance: TObject; const PropName: String): Int64; overload;', Nil); + RegisterHeader (H, 'procedure SetInt64Prop (Instance: TObject; const PropName: String; const Value: Int64); overload;', Nil); + RegisterHeader (H, 'function GetInterfaceProp (Instance: TObject; const PropName: String): IInterface; overload;', Nil); + RegisterHeader (H, 'procedure SetInterfaceProp (Instance: TObject; const PropName: String; const Value: IInterface); overload;' + + '', Nil); + RegisterHeader (H, 'function GetPropValue (Instance: TObject; const PropName: String; PreferStrings: Boolean = True): Variant;' + + '', Nil); + RegisterHeader (H, 'procedure SetPropValue (Instance: TObject; const PropName: String; const Value: Variant);', Nil); + RegisterHeader (H, 'procedure FreeAndNilProperties (AObject: TObject);', Nil); + + G := RegisterClassType(H, TPublishableVariantType); + RegisterHeader(G, + 'function GetProperty (var Dest: TVarData; const V: TVarData; const Name: String): Boolean; override;', + @TPublishableVariantType.GetProperty); + RegisterHeader (G, + 'function SetProperty (const V: TVarData; const Name: String; const Value: TVarData): Boolean; override;', + @TPublishableVariantType.SetProperty); + + RegisterConstant (H, 'tkAny = [Low(TTypeKind)..High(TTypeKind)];'); + RegisterConstant (H, 'tkMethods = [tkMethod];'); + RegisterConstant (H, 'tkProperties = tkAny - tkMethods - [tkUnknown];'); + RegisterTypeDeclaration (H, 'ShortStringBase = String [255];'); + RegisterHeader (H, 'function GetTypeData (TypeInfo: PTypeInfo): PTypeData;', Nil); + RegisterHeader (H, 'function GetEnumName (TypeInfo: PTypeInfo; Value: Integer): String;', Nil); + RegisterHeader (H, 'function GetEnumValue (TypeInfo: PTypeInfo; const Name: String): Integer;', Nil); + RegisterHeader (H, 'function GetPropInfo (Instance: TObject; const PropName: String; AKinds: TTypeKinds = []): PPropInfo; ' + + 'overload;', Nil); + RegisterHeader (H, 'function GetPropInfo (AClass: TClass; const PropName: String; AKinds: TTypeKinds = []): PPropInfo; ' + + 'overload;', Nil); + RegisterHeader (H, 'function GetPropInfo (TypeInfo: PTypeInfo; const PropName: String): PPropInfo; overload;', Nil); + RegisterHeader (H, 'function GetPropInfo (TypeInfo: PTypeInfo; const PropName: String; AKinds: TTypeKinds): PPropInfo; ' + + 'overload;', Nil); + RegisterHeader (H, 'procedure GetPropInfos (TypeInfo: PTypeInfo; PropList: PPropList);', Nil); + RegisterHeader (H, 'function GetPropList (TypeInfo: PTypeInfo; TypeKinds: TTypeKinds; PropList: PPropList; SortList: Boolean ' + + '= True): Integer; overload;', Nil); + RegisterHeader (H, 'function GetPropList (TypeInfo: PTypeInfo; out PropList: PPropList): Integer; overload;', Nil); + RegisterHeader (H, 'function GetPropList (AObject: TObject; out PropList: PPropList): Integer; overload;', Nil); + RegisterHeader (H, 'procedure SortPropList (PropList: PPropList; PropCount: Integer);', Nil); + RegisterHeader (H, 'function IsStoredProp (Instance: TObject; PropInfo: PPropInfo): Boolean; overload;', Nil); + RegisterHeader (H, 'function GetOrdProp (Instance: TObject; PropInfo: PPropInfo): Longint; overload;', Nil); + RegisterHeader (H, 'procedure SetOrdProp (Instance: TObject; PropInfo: PPropInfo; Value: Longint); overload;', Nil); + RegisterHeader (H, 'function GetEnumProp (Instance: TObject; PropInfo: PPropInfo): String; overload;', Nil); + RegisterHeader (H, 'procedure SetEnumProp (Instance: TObject; PropInfo: PPropInfo; const Value: String); overload;', Nil); + RegisterHeader (H, 'function GetSetProp (Instance: TObject; PropInfo: PPropInfo; Brackets: Boolean = False): String; overload;' + + '', Nil); + RegisterHeader (H, 'procedure SetSetProp (Instance: TObject; PropInfo: PPropInfo; const Value: String); overload;', Nil); + RegisterHeader (H, 'function GetObjectProp (Instance: TObject; PropInfo: PPropInfo; MinClass: TClass = nil): TObject; ' + + 'overload;', Nil); + RegisterHeader (H, 'procedure SetObjectProp (Instance: TObject; PropInfo: PPropInfo; Value: TObject; ValidateClass: Boolean = ' + + 'True); overload;', Nil); + RegisterHeader (H, 'function GetObjectPropClass (Instance: TObject; PropInfo: PPropInfo): TClass; overload;', Nil); + RegisterHeader (H, 'function GetObjectPropClass (PropInfo: PPropInfo): TClass; overload;', Nil); + RegisterHeader (H, 'function GetStrProp (Instance: TObject; PropInfo: PPropInfo): String; overload;', Nil); + RegisterHeader (H, 'procedure SetStrProp (Instance: TObject; PropInfo: PPropInfo; const Value: String); overload;', Nil); + RegisterHeader (H, 'function GetWideStrProp (Instance: TObject; PropInfo: PPropInfo): WideString; overload;', Nil); + RegisterHeader (H, 'procedure SetWideStrProp (Instance: TObject; PropInfo: PPropInfo; const Value: WideString); overload;', + Nil); + RegisterHeader (H, 'function GetFloatProp (Instance: TObject; PropInfo: PPropInfo): Extended; overload;', Nil); + RegisterHeader (H, 'procedure SetFloatProp (Instance: TObject; PropInfo: PPropInfo; const Value: Extended); overload;', Nil); + RegisterHeader (H, 'function GetVariantProp (Instance: TObject; PropInfo: PPropInfo): Variant; overload;', Nil); + RegisterHeader (H, 'procedure SetVariantProp (Instance: TObject; PropInfo: PPropInfo; const Value: Variant); overload;', Nil); + + RegisterHeader (H, 'function GetMethodProp (Instance: TObject; PropInfo: PPropInfo): TMethod; overload;', Nil); + RegisterHeader (H, 'procedure SetMethodProp (Instance: TObject; PropInfo: PPropInfo; const Value: TMethod); overload;', Nil); + RegisterHeader (H, 'function GetInt64Prop (Instance: TObject; PropInfo: PPropInfo): Int64; overload;', Nil); + RegisterHeader (H, 'procedure SetInt64Prop (Instance: TObject; PropInfo: PPropInfo; const Value: Int64); overload;', Nil); + RegisterHeader (H, 'function GetInterfaceProp (Instance: TObject; PropInfo: PPropInfo): IInterface; overload;', Nil); + RegisterHeader (H, 'procedure SetInterfaceProp (Instance: TObject; PropInfo: PPropInfo; const Value: IInterface); overload;', + Nil); + RegisterVariable (H, 'DotSep:String;', @DotSep); + RegisterHeader (H, 'function SetToString (PropInfo: PPropInfo; Value: Integer; Brackets: Boolean = False): String;', Nil); + RegisterHeader (H, 'function StringToSet (PropInfo: PPropInfo; const Value: String): Integer;', Nil); +end; + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/RTTI/1/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/RTTI/1/Project1.dpr new file mode 100644 index 0000000..3cd2a1d --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/RTTI/1/Project1.dpr @@ -0,0 +1,197 @@ +{$APPTYPE CONSOLE} +{$O-} +program Project1; +uses + PAXCOMP_CONSTANTS, + PAXCOMP_SYS, + PAXCOMP_DUMP, + TypInfo, + Classes, + SysUtils, + IMPORT_Classes, + PaxCompiler, + PaxInterpreter, + PaxRegister, + IMPORT_TypInfo in 'IMPORT_TypInfo.pas'; + +type + TTestClass = class + procedure DoTest; + procedure OnClickHandler(Sender: TObject); + procedure OnClickHandler2(Sender: TObject); + end; + +var + PaxInterpreter1: TPaxInterpreter; + +procedure TTestClass.OnClickHandler(Sender: TObject); +begin + writeln('Click'); +end; + +procedure TTestClass.OnClickHandler2(Sender: TObject); +begin + writeln('Click 2'); +end; + +procedure TTestClass.DoTest; +var + C: TClass; + P: Pointer; + pti: PTypeInfo; + ptd: PTypeData; + ppi: PPropInfo; + I: Integer; + Z, X: TObject; + S: String; + AMethod: TMethod; +begin + AMethod.Code := @ TTestClass.OnClickHandler; + AMethod.Data := Self; + + P := PaxInterpreter1.GetAddress('MyProg.TMyClass'); + C := TClass(P^); + writeln(C.ClassName); + pti := C.ClassInfo; + writeln(pti^.Name); + + ptd := GetTypeData(pti); + writeln(ptd^.ClassType.ClassName); + pti := ptd^.ParentInfo^; + writeln(pti^.Name); + writeln(ptd^.PropCount); + writeln(ptd^.UnitName); + + ppi := GetPropInfo(C, 'X'); + writeln(ppi^.Name); + + pti := PaxInterpreter1.GetTypeInfo('IUnknown'); + writeln(pti^.Name); + ptd := GetTypeData(pti); + writeln(ptd^.IntfUnit); + + pti := PaxInterpreter1.GetTypeInfo('MyProg.TCharSet'); + writeln(pti^.Name); + ptd := GetTypeData(pti); + if ptd <> nil then + writeln(ptd^.CompType^.Name); + + pti := PaxInterpreter1.GetTypeInfo('MyProg.TMyEnum'); + writeln(pti^.Name); + ptd := GetTypeData(pti); + writeln(ptd^.BaseType^.Name); +// writeln(ptd^.EnumUnitName); + writeln(GetEnumName(pti, 2)); + writeln(GetEnumValue(pti, 'three')); + + pti := PaxInterpreter1.GetTypeInfo('Integer'); + writeln(pti^.Name); + + // work with instance + + P := PaxInterpreter1.GetAddress('MyProg.Z'); + Z := TObject(P^); + writeln(Z.ClassName); + SetOrdProp(Z, 'X', 5); + I := GetOrdProp(Z, 'X'); + writeln(I); + + SetStrProp(Z, 'Y', 'abc'); + S := GetStrProp(Z, 'Y'); + writeln(S); + + ppi := GetPropInfo(Z, 'Inter'); + writeln(ppi^.Name); + + P := Z.MethodAddress('MyProc'); + asm + mov eax, z + call P; + end; + + P := Z.FieldAddress('Field2'); + X := TObject(P^); + writeln(X.ClassName); + + SetMethodProp(Z, 'OnClick', AMethod); + AMethod := GetMethodProp(Z, 'OnClick'); + + asm + mov eax, z + call AMethod.Code; + end; + + // RTTI of inherited class: + + P := PaxInterpreter1.GetAddress('MyProg.TMyClass2'); + C := TClass(P^); + writeln(C.ClassName); + pti := C.ClassInfo; + writeln(pti^.Name); + + ppi := GetPropInfo(C, 'X'); + writeln(ppi^.Name); + + // work with instance + P := PaxInterpreter1.GetAddress('MyProg.W'); + Z := TObject(P^); + writeln(Z.ClassName); + SetOrdProp(Z, 'X', 7); + I := GetOrdProp(Z, 'X'); + writeln(I); + + P := Z.MethodAddress('MyProc'); + asm + mov eax, z + call P; + end; + + P := Z.FieldAddress('Field2'); + X := TObject(P^); + writeln(X.ClassName); +end; + +var + PaxCompiler1: TPaxCompiler; + PaxPascalLanguage1: TPaxPascalLanguage; + H: Integer; +begin + setdump; + + Register_Classes; + Register_TypInfo; + RegisterRTTIType(0, TypeInfo(TNotifyEvent)); + + H := RegisterClassType(0, TTestClass); + RegisterHeader(H, 'procedure DoTest;', + @TTestClass.DoTest); + RegisterHeader(H, 'procedure OnClickHandler2(Sender: TObject);', + @TTestClass.OnClickHandler2); + + PaxCompiler1 := TPaxCompiler.Create(nil); + PaxInterpreter1 := TPaxInterpreter.Create(nil); + PaxPascalLanguage1 := TPaxPascalLanguage.Create(nil); + try + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + PaxCompiler1.AddModule('1', 'Pascal'); + PaxCompiler1.AddCodeFromFile('1', 'script.txt'); + if PaxCompiler1.Compile(PaxInterpreter1) then + begin +{ + PaxInterpreter1.SaveToFile('1.bin'); + PaxInterpreter1.Free; + PaxInterpreter1 := TPaxInterpreter.Create(nil); + PaxInterpreter1.LoadFromFile('1.bin'); +} + PaxInterpreter1.Run; + end + else + writeln(PaxCompiler1.ErrorMessage[0]); + finally + PaxCompiler1.Free; + PaxInterpreter1.Free; + PaxPascalLanguage1.Free; + end; + writeln('Press any key...'); + Readln; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/RTTI/1/script.txt b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/RTTI/1/script.txt new file mode 100644 index 0000000..fdc1bf2 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/RTTI/1/script.txt @@ -0,0 +1,127 @@ +program MyProg; +uses TypInfo, Classes; +type + TCharSet = set of char; + + TMyEnum = (one, two, three); + + TMyClass = class(TComponent) + private + FX: Integer; + FY: String; + fStrings: TStringList; + FOnClick: TNotifyEvent; + fInter: IUnknown; + function GetX: Integer; + procedure SetX(value: Integer); + function GetY: String; + procedure SetY(const value: String); + public + constructor Create(AOwner: TComponent); + destructor Destroy; override; + procedure ScriptHandler(Sender: TObject); + published + Field: TObject; + Field2: TStringList; + property X: Integer read GetX write SetX; + property Y: String read FY write FY; + property Strings: TStringList read fStrings write fStrings; + property OnClick: TNotifyEvent read fOnClick write fOnClick; + property Inter: IUnknown read fInter write fInter; + procedure MyProc(U, V: Integer); + end; + + TMyClass2 = class(TMyClass) + end; + +constructor TMyClass.Create; +begin + inherited Create(nil); + Field := TObject.Create; + Field2 := TStringList.Create; +end; + +destructor TMyClass.Destroy; +begin + Field.Free; + Field2.Free; + inherited; +end; + +procedure TMyClass.ScriptHandler(Sender: TObject); +begin + writeln('***************', Sender.ClassName); + ExitCode := 5; + writeln(ExitCode); +end; + + +function TMyClass.GetX: Integer; +begin + result := FX; + writeln('result=', result); +end; + +procedure TMyClass.SetX(value: Integer); +begin + writeln('value=', value); + FX := value; + writeln('FX=', FX); +end; + +function TMyClass.GetY: String; +begin + result := FY; + writeln('result=', result); +end; + +procedure TMyClass.SetY(const value: String); +begin + writeln('value=', value); + FY := value; + writeln('FY=', FY); +end; + +procedure TMyClass.MyProc(U, V: Integer); +begin + writeln('MyProc'); +end; + +var + Z, W: TMyClass; + TestClass: TTestClass; + pti: PTypeInfo; +begin + TestClass := TTestClass.Create; + + Z := TMyClass.Create(nil); + W := TMyClass2.Create(nil); + + W.X := 5; + writeln(W.X); + + W.Name := 'yyyy'; + writeln(W.Name); + + TestClass.DoTest; // Z.OnClick was assigned at host side + + if Assigned(Z.OnClick) then + Z.OnClick(Z); + + + Z.OnClick := TestClass.OnClickHandler2; // direct assignment of host handler + Z.OnClick(nil); + + Z.OnClick := Z.ScriptHandler; + Z.OnClick(W); + + pti := TypeInfo(TMyClass); + writeln(pti^.Name); + + + Z.Free; + W.Free; + + TestClass.Free; +end. + diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/RTTI/2/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/RTTI/2/Project1.dpr new file mode 100644 index 0000000..0149da0 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/RTTI/2/Project1.dpr @@ -0,0 +1,90 @@ +{$APPTYPE CONSOLE} +{$O-} +program Project1; +uses + TypInfo, + Classes, + SysUtils, + PaxCompiler, + PaxInterpreter, + PaxRegister; + +type + TTest = class(TComponent) + public + procedure Save; + end; + +{ TTest } + +procedure MyGetPropertyNames(aObject: TObject; aStringList: TStringList); +var + count : integer; + size : integer; + list : PPropList; + i : integer; + ppi: PPropInfo; +begin + aStringList.Clear; + count := GetPropList(PTypeInfo(aObject.ClassInfo), tkProperties, nil, false); + size := count * SizeOf(Pointer); + GetMem(list, size); + try + GetPropList(PTypeInfo(aObject.ClassInfo), tkProperties, list, false); + for i := 0 to count - 1 do + aStringList.Add(list^[i]^.Name); + finally + FreeMem(list, size); + end; +end; + +type + TMyStringList = class(TStringList) + published + property Text; + end; + +procedure TTest.Save; +var + list: TMyStringList; +begin + list := TMyStringList.Create; + try + MyGetPropertyNames(self, list); + writeln('Property Count = ', list.Count); + writeln('Properties are: ' + list.Text); + finally + list.free; + end; +end; + +var + PaxInterpreter1: TPaxInterpreter; + PaxCompiler1: TPaxCompiler; + PaxPascalLanguage1: TPaxPascalLanguage; + H: Integer; +begin + H := RegisterClassType(0, TTest); + RegisterHeader(H, 'procedure Save;', @TTest.Save); + + PaxCompiler1 := TPaxCompiler.Create(nil); + PaxInterpreter1 := TPaxInterpreter.Create(nil); + PaxPascalLanguage1 := TPaxPascalLanguage.Create(nil); + try + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + PaxCompiler1.AddModule('1', 'Pascal'); + PaxCompiler1.AddCodeFromFile('1', 'script.txt'); + if PaxCompiler1.Compile(PaxInterpreter1) then + begin + PaxInterpreter1.Run; + end + else + writeln(PaxCompiler1.ErrorMessage[0]); + finally + PaxCompiler1.Free; + PaxInterpreter1.Free; + PaxPascalLanguage1.Free; + end; + writeln('Press any key...'); + Readln; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/RTTI/2/script.txt b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/RTTI/2/script.txt new file mode 100644 index 0000000..4d0e53b --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/RTTI/2/script.txt @@ -0,0 +1,43 @@ +program MyTestProg; + +type + TMyTestBase = class(TTest) + end; + + + TMyTest = class(TMyTestBase) + private + FX: Integer; + FY: String; + function GetX: Integer; + procedure SetX(value: Integer); + published + property X: Integer read GetX write SetX; + property Y: String read FY write FY; + end; + +function TMyTest.GetX: Integer; +begin + result := FX; + writeln('result=', result); +end; + +procedure TMyTest.SetX(value: Integer); +begin + writeln('value=', value); + FX := value; + writeln('FX=', FX); +end; + +var + t: TMyTest; +begin + t := TMyTest.Create; + try + t.x := 10; + t.y := '20'; + t.Save; + finally + t.Free; + end; +end. \ No newline at end of file diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/RegisterVariable/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/RegisterVariable/Project1.dpr new file mode 100644 index 0000000..513a1dd --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/RegisterVariable/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/RegisterVariable/Project1.res b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/RegisterVariable/Project1.res new file mode 100644 index 0000000..3adc036 Binary files /dev/null and b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/RegisterVariable/Project1.res differ diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/RegisterVariable/Unit1.dfm b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/RegisterVariable/Unit1.dfm new file mode 100644 index 0000000..15df33f --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/RegisterVariable/Unit1.dfm @@ -0,0 +1,49 @@ +object Form1: TForm1 + Left = 192 + Top = 114 + Caption = 'Register variable demo' + ClientHeight = 171 + ClientWidth = 327 + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -14 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + PixelsPerInch = 120 + TextHeight = 16 + object Button1: TButton + Left = 49 + Top = 98 + Width = 93 + Height = 31 + Margins.Left = 4 + Margins.Top = 4 + Margins.Right = 4 + Margins.Bottom = 4 + Caption = 'Run' + TabOrder = 0 + OnClick = Button1Click + end + object PaxCompiler1: TPaxCompiler + Alignment = 1 + DebugMode = False + Left = 32 + Top = 16 + end + object PaxPascalLanguage1: TPaxPascalLanguage + ExplicitOff = False + CompleteBooleanEval = False + UnitLookup = True + PrintKeyword = 'print' + PrintlnKeyword = 'println' + Left = 80 + Top = 16 + end + object PaxInterpreter1: TPaxInterpreter + Console = False + Left = 120 + Top = 16 + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/RegisterVariable/Unit1.pas b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/RegisterVariable/Unit1.pas new file mode 100644 index 0000000..64c35b6 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/RegisterVariable/Unit1.pas @@ -0,0 +1,69 @@ +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, PaxCompiler, PaxInterpreter, PaxRegister, PaxRunner; + +type + TForm1 = class(TForm) + PaxCompiler1: TPaxCompiler; + PaxPascalLanguage1: TPaxPascalLanguage; + Button1: TButton; + PaxInterpreter1: TPaxInterpreter; + procedure Button1Click(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.dfm} + +type + TMyPoint = packed record + x, y: Integer; + end; + +procedure TForm1.Button1Click(Sender: TObject); +var + H_TMyPoint, H_MyPoint: Integer; + MyPoint: TMyPoint; + I: Integer; +begin + MyPoint.X := 60; + MyPoint.Y := 23; + + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + + // register host-defined type + H_TMyPoint := PaxCompiler1.RegisterRecordType(0, 'TMyPoint'); + PaxCompiler1.RegisterRecordTypeField(H_TMyPoint, 'X', _typeINTEGER); + PaxCompiler1.RegisterRecordTypeField(H_TMyPoint, 'Y', _typeINTEGER); + + // register host-defined variable + H_MyPoint := PaxCompiler1.RegisterVariable(0, 'MyPoint', H_TMyPoint, @MyPoint); + + PaxCompiler1.AddModule('1', PaxPascalLanguage1.LanguageName); + PaxCompiler1.AddCode('1', 'begin'); + PaxCompiler1.AddCode('1', ' MyPoint.Y := 8;'); + PaxCompiler1.AddCode('1', 'end.'); + + if PaxCompiler1.Compile(PaxInterpreter1) then + begin + PaxInterpreter1.Run; + ShowMessage(IntToStr(MyPoint.Y)); + end + else + for I:=0 to PaxCompiler1.ErrorCount do + ShowMessage(PaxCompiler1.ErrorMessage[I]); +end; + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/UnhandledException/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/UnhandledException/Project1.dpr new file mode 100644 index 0000000..513a1dd --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/UnhandledException/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/UnhandledException/Project1.res b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/UnhandledException/Project1.res new file mode 100644 index 0000000..3adc036 Binary files /dev/null and b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/UnhandledException/Project1.res differ diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/UnhandledException/Unit1.dfm b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/UnhandledException/Unit1.dfm new file mode 100644 index 0000000..f8288f1 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/UnhandledException/Unit1.dfm @@ -0,0 +1,50 @@ +object Form1: TForm1 + Left = 192 + Top = 114 + Caption = 'Unhandled exception demo' + ClientHeight = 171 + ClientWidth = 604 + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -14 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + PixelsPerInch = 120 + TextHeight = 16 + object Button1: TButton + Left = 59 + Top = 39 + Width = 139 + Height = 31 + Margins.Left = 4 + Margins.Top = 4 + Margins.Right = 4 + Margins.Bottom = 4 + Caption = 'Compile and Run' + TabOrder = 0 + OnClick = Button1Click + end + object PaxCompiler1: TPaxCompiler + Alignment = 1 + DebugMode = False + Left = 200 + Top = 40 + end + object PaxPascalLanguage1: TPaxPascalLanguage + ExplicitOff = False + CompleteBooleanEval = False + UnitLookup = True + PrintKeyword = 'print' + PrintlnKeyword = 'println' + Left = 240 + Top = 40 + end + object PaxInterpreter1: TPaxInterpreter + Console = False + OnUnhandledException = PaxInterpreter1UnhandledException + Left = 288 + Top = 40 + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/UnhandledException/Unit1.pas b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/UnhandledException/Unit1.pas new file mode 100644 index 0000000..840f51b --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/UnhandledException/Unit1.pas @@ -0,0 +1,62 @@ +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, PaxInterpreter, PaxCompiler, PaxRunner; + +type + TForm1 = class(TForm) + Button1: TButton; + PaxCompiler1: TPaxCompiler; + PaxPascalLanguage1: TPaxPascalLanguage; + PaxInterpreter1: TPaxInterpreter; + procedure Button1Click(Sender: TObject); + procedure PaxInterpreter1UnhandledException(Sender: TPaxRunner; + E: Exception; const ModuleName: string; SourceLineNumber: Integer); + private + { Private declarations } + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +uses IMPORT_SysUtils; + +{$R *.dfm} + +procedure TForm1.Button1Click(Sender: TObject); +begin + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + PaxCompiler1.AddModule('main', 'Pascal'); + PaxCompiler1.AddCode('main', 'uses SysUtils;'); + PaxCompiler1.AddCode('main', 'begin'); + PaxCompiler1.AddCode('main', ' raise Exception.Create(''Error'');'); + PaxCompiler1.AddCode('main', 'end.'); + if PaxCompiler1.Compile(PaxInterpreter1) then + begin + PaxInterpreter1.Run; + end + else + ShowMessage('Compile error: ' + PaxCompiler1.ErrorMessage[0] + ' at line ' + #13#10 + + PaxCompiler1.ErrorLine[0]); +end; + +procedure TForm1.PaxInterpreter1UnhandledException(Sender: TPaxRunner; + E: Exception; const ModuleName: string; SourceLineNumber: Integer); +begin + ShowMessage('Run-time error (' + E.Message + ') raised at line ' + IntToStr(SourceLineNumber) + ':' + + PaxCompiler1.Modules[ModuleName][SourceLineNumber]); +end; + +initialization + +Register_SysUtils; + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/code_explorer_ex/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/code_explorer_ex/Project1.dpr new file mode 100644 index 0000000..513a1dd --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/code_explorer_ex/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/code_explorer_ex/Project1.res b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/code_explorer_ex/Project1.res new file mode 100644 index 0000000..3adc036 Binary files /dev/null and b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/code_explorer_ex/Project1.res differ diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/code_explorer_ex/Unit1.dfm b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/code_explorer_ex/Unit1.dfm new file mode 100644 index 0000000..2402583 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/code_explorer_ex/Unit1.dfm @@ -0,0 +1,133 @@ +object Form1: TForm1 + Left = 192 + Top = 114 + Caption = 'Code explorer demo' + ClientHeight = 549 + ClientWidth = 847 + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -14 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + PixelsPerInch = 120 + TextHeight = 16 + object Panel1: TPanel + Left = 0 + Top = 498 + Width = 847 + Height = 51 + Margins.Left = 4 + Margins.Top = 4 + Margins.Right = 4 + Margins.Bottom = 4 + Align = alBottom + TabOrder = 0 + object Button1: TButton + Left = 30 + Top = 10 + Width = 129 + Height = 31 + Margins.Left = 4 + Margins.Top = 4 + Margins.Right = 4 + Margins.Bottom = 4 + Caption = 'Compile' + TabOrder = 0 + OnClick = Button1Click + end + end + object Memo1: TMemo + Left = 0 + Top = 0 + Width = 425 + Height = 498 + Margins.Left = 4 + Margins.Top = 4 + Margins.Right = 4 + Margins.Bottom = 4 + Align = alLeft + Lines.Strings = ( + 'uses' + ' Classes;' + 'type' + ' TMyNotifyEvent = procedure (Sender:TObject) of object;' + '' + ' TMyArray = array[1..10] of Single;' + '' + ' TMyPoint = record' + ' X, Y: Double;' + ' end;' + '' + ' TMyClass = class' + ' private' + ' P, Q: Integer;' + ' public' + ' function MyClassFunc: Integer;' + ' published' + ' property MyProp: Integer read P;' + ' end;' + '' + 'function TMyClass.MyClassFunc: Integer;' + 'begin' + 'end;' + '' + 'procedure MyProc(var X: Integer; const Y: Integer; Z: Integer);' + 'procedure NestedProc;' + 'begin' + 'end;' + 'var' + ' L: Double;' + 'const' + ' W = '#39'abc'#39';' + 'begin' + 'end;' + 'function MyFunc: String;' + 'type' + ' TMyEnum = (one, two, three);' + 'begin' + ' result := '#39'pqr'#39';' + 'end;' + 'const' + ' Z = 80;' + 'var' + ' G: Byte;' + 'begin' + 'end.') + TabOrder = 1 + end + object TreeView1: TTreeView + Left = 425 + Top = 0 + Width = 422 + Height = 498 + Margins.Left = 4 + Margins.Top = 4 + Margins.Right = 4 + Margins.Bottom = 4 + Align = alClient + Indent = 19 + TabOrder = 2 + OnDblClick = TreeView1DblClick + end + object PaxCompiler1: TPaxCompiler + Alignment = 1 + DebugMode = False + Left = 224 + Top = 413 + end + object PaxPascalLanguage1: TPaxPascalLanguage + ExplicitOff = False + CompleteBooleanEval = False + UnitLookup = True + PrintKeyword = 'print' + PrintlnKeyword = 'println' + Left = 264 + Top = 413 + end + object PaxCompilerExplorer1: TPaxCompilerExplorer + Left = 304 + Top = 413 + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/code_explorer_ex/Unit1.pas b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/code_explorer_ex/Unit1.pas new file mode 100644 index 0000000..9a26380 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxInterpreter/Pascal/code_explorer_ex/Unit1.pas @@ -0,0 +1,267 @@ +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, + Dialogs, PaxCompilerExplorer, PaxCompiler, StdCtrls, ExtCtrls, ComCtrls, + PAXCOMP_SYS, + IMPORT_Classes; + +type + TForm1 = class(TForm) + Panel1: TPanel; + Memo1: TMemo; + Button1: TButton; + PaxCompiler1: TPaxCompiler; + PaxPascalLanguage1: TPaxPascalLanguage; + PaxCompilerExplorer1: TPaxCompilerExplorer; + TreeView1: TTreeView; + procedure Button1Click(Sender: TObject); + procedure TreeView1DblClick(Sender: TObject); + private + { Private declarations } + L: TList; + public + { Public declarations } + procedure BuildTree; + procedure EnumProc(Id: Integer; + Host: Boolean; + Kind: TPaxMemberKind; + Data: Pointer); + end; + +var + Form1: TForm1; + +implementation + +{$R *.dfm} + +procedure TForm1.Button1Click(Sender: TObject); +var + I: Integer; +begin + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + PaxCompiler1.AddModule('1', 'Pascal'); + PaxCompiler1.AddCode('1', Memo1.Lines.Text); + if PaxCompiler1.Compile then + begin + PaxCompilerExplorer1.RegisterCompiler(PaxCompiler1); + BuildTree; + end + else + for I:=0 to PaxCompiler1.ErrorCount - 1 do + ShowMessage(PaxCompiler1.ErrorMessage[I]); +end; + +procedure TForm1.BuildTree; +var + N, N2: TTreeNode; + I: Integer; +begin + L := TList.Create; + try + TreeView1.Items.Clear; + + N := TreeView1.Items.Add(nil, 'Used namespaces'); + L.Add(N); + PaxCompilerExplorer1.EnumMembers(0, true, pmkNamespace, EnumProc, N); + PaxCompilerExplorer1.EnumMembers(0, false, pmkNamespace, EnumProc, N); + + N := TreeView1.Items.Add(nil, 'Noname namespace'); + + N2 := TreeView1.Items.AddChild(N, 'Types'); + L.Add(N2); + PaxCompilerExplorer1.EnumMembers(0, false, pmkType, EnumProc, N2); + + N2 := TreeView1.Items.AddChild(N, 'Procedures'); + L.Add(N2); + PaxCompilerExplorer1.EnumMembers(0, false, pmkProcedure, EnumProc, N2); + + N2 := TreeView1.Items.AddChild(N, 'Functions'); + L.Add(N2); + PaxCompilerExplorer1.EnumMembers(0, false, pmkFunction, EnumProc, N2); + + N2 := TreeView1.Items.AddChild(N, 'Constants'); + L.Add(N2); + PaxCompilerExplorer1.EnumMembers(0, false, pmkConst, EnumProc, N2); + + N2 := TreeView1.Items.AddChild(N, 'Variables'); + L.Add(N2); + PaxCompilerExplorer1.EnumMembers(0, false, pmkVar, EnumProc, N2); + + finally + for I := L.Count - 1 downto 0 do + begin + N2 := TTreeNode(L[I]); + if N2.Count = 0 then + N2.Delete; + end; + + L.Free; + end; +end; + +procedure TForm1.EnumProc(Id: Integer; + Host: Boolean; + Kind: TPaxMemberKind; + Data: Pointer); +var + N, N2, N3: TTreeNode; + Name: String; + TypeName: String; + vis: TClassVisibility; + S: String; +begin + N := TTreeNode(Data); + + Name := PaxCompilerExplorer1.Names[Id]; + TypeName := PaxCompilerExplorer1.TypeNames[Id]; + + S := ''; + vis := PaxCompilerExplorer1.GetVisibility(Id); + case vis of + cvPrivate : S := ' (private) '; + cvProtected : S := ' (protected) '; + cvPublic : S := ' (public)'; + cvPublished : S := ' (published) '; + end; + + with TreeView1.Items do + case Kind of + pmkProcedure, pmkFunction, pmkConstructor, pmkDestructor: + begin + N2 := AddChildObject(N, S + Name, TObject(Id)); + + N3 := AddChild(N2, 'Parameters'); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, Host, pmkParam, EnumProc, N3); + + N3 := AddChild(N2, 'Local variables'); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, Host, pmkVar, EnumProc, N3); + + N3 := AddChild(N2, 'Local constants'); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, Host, pmkConst, EnumProc, N3); + + N3 := AddChild(N2, 'Local types'); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, Host, pmkType, EnumProc, N3); + + N3 := TreeView1.Items.AddChild(N2, 'Nested procedures'); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, false, pmkProcedure, EnumProc, N3); + + N3 := TreeView1.Items.AddChild(N2, 'Nested functions'); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, false, pmkFunction, EnumProc, N3); + + end; + pmkParam: + begin + if PaxCompilerExplorer1.IsByRefParam(Id) then + AddChildObject(N, 'var ' + Name + ': ' + TypeName, TObject(Id)) + else if PaxCompilerExplorer1.IsConstParam(Id) then + AddChildObject(N, 'const ' + Name + ': ' + TypeName, TObject(Id)) + else + AddChildObject(N, Name + ': ' + TypeName, TObject(Id)); + end; + pmkVar: AddChildObject(N, Name + ': ' + TypeName, TObject(Id)); + pmkConst: AddChildObject(N, Name + ': ' + TypeName, TObject(Id)); + pmkField: AddChildObject(N, S + Name + ': ' + TypeName, TObject(Id)); + pmkProperty: AddChildObject(N, S + Name + ': ' + TypeName, TObject(Id)); + pmkType: + begin + N2 := AddChildObject(N, Name, TObject(Id)); + if PaxCompilerExplorer1.IsRecordType(Id) then + begin + N3 := AddChild(N2, 'Fields'); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, Host, pmkField, EnumProc, N3); + end + else if PaxCompilerExplorer1.IsClassType(Id) then + begin + N3 := AddChild(N2, 'Fields'); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, Host, pmkField, EnumProc, N3); + + N3 := AddChild(N2, 'Properties'); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, Host, pmkProperty, EnumProc, N3); + + N3 := TreeView1.Items.AddChild(N2, 'Constructors'); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, false, pmkConstructor, EnumProc, N3); + + N3 := TreeView1.Items.AddChild(N2, 'Destructor'); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, false, pmkDestructor, EnumProc, N3); + + N3 := TreeView1.Items.AddChild(N2, 'Class procedures'); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, false, pmkProcedure, EnumProc, N3); + + N3 := TreeView1.Items.AddChild(N2, 'Class functions'); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, false, pmkFunction, EnumProc, N3); + end; + end; + pmkNamespace: + begin + N2 := AddChildObject(N, Name, TObject(Id)); + + N3 := AddChild(N2, 'Constants'); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, Host, pmkConst, EnumProc, N3); + + N3 := AddChild(N2, 'Variables'); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, Host, pmkVar, EnumProc, N3); + + N3 := AddChild(N2, 'Procedures'); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, Host, pmkProcedure, EnumProc, N3); + + N3 := AddChild(N2, 'Types'); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, Host, pmkType, EnumProc, N3); + end; + end; +end; + +procedure TForm1.TreeView1DblClick(Sender: TObject); +var + N: TTreeNode; + Id, Position: Integer; + S: String; +begin + N := TTreeView(Sender).Selected; + + if N = nil then + Exit; + + Id := Integer(N.Data); + + if Id = 0 then + Exit; + + S := PaxCompilerExplorer1.Names[Id]; + Position := PaxCompilerExplorer1.Positions[Id]; + + if Id <> 0 then + with Memo1 do + begin + SetFocus; + SelStart := Position; + SelLength := Length(S); + end; +end; + +initialization + +Register_Classes; + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/AccessToScriptVariables/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/AccessToScriptVariables/Project1.dpr new file mode 100644 index 0000000..513a1dd --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/AccessToScriptVariables/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/AccessToScriptVariables/Project1.res b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/AccessToScriptVariables/Project1.res new file mode 100644 index 0000000..3adc036 Binary files /dev/null and b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/AccessToScriptVariables/Project1.res differ diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/AccessToScriptVariables/Unit1.dfm b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/AccessToScriptVariables/Unit1.dfm new file mode 100644 index 0000000..a5a61c8 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/AccessToScriptVariables/Unit1.dfm @@ -0,0 +1,43 @@ +object Form1: TForm1 + Left = 277 + Top = 120 + Width = 252 + Height = 172 + Caption = 'Access to script-defined variables' + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + PixelsPerInch = 96 + TextHeight = 13 + object Button1: TButton + Left = 32 + Top = 80 + Width = 75 + Height = 25 + Caption = 'Run' + TabOrder = 0 + OnClick = Button1Click + end + object PaxCompiler1: TPaxCompiler + Alignment = 1 + DebugMode = False + Left = 48 + Top = 24 + end + object PaxBasicLanguage1: TPaxBasicLanguage + ExplicitOff = False + CompleteBooleanEval = False + UseFWArrays = True + Left = 152 + Top = 80 + end + object PaxProgram1: TPaxProgram + Console = False + Left = 160 + Top = 16 + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/AccessToScriptVariables/Unit1.pas b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/AccessToScriptVariables/Unit1.pas new file mode 100644 index 0000000..c4799f1 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/AccessToScriptVariables/Unit1.pas @@ -0,0 +1,58 @@ +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, PaxCompiler, PaxProgram, PaxBasicLanguage, PaxRunner; +type + TForm1 = class(TForm) + PaxCompiler1: TPaxCompiler; + PaxProgram1: TPaxProgram; + Button1: TButton; + PaxBasicLanguage1: TPaxBasicLanguage; + procedure Button1Click(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.dfm} + +procedure TForm1.Button1Click(Sender: TObject); +var + P: Pointer; + I: Integer; +begin + {$O-} + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxBasicLanguage1); + + PaxCompiler1.RegisterHeader(0, 'procedure ShowMessage(const Msg: string);', @ShowMessage); + PaxCompiler1.RegisterHeader(0, 'function IntToStr(Value: Integer): string;', @IntToStr); + + PaxCompiler1.AddModule('1', PaxBasicLanguage1.LanguageName); + PaxCompiler1.AddCode('1', 'Dim X As Integer'); + PaxCompiler1.AddCode('1', 'ShowMessage("script:" + IntToStr(x))'); + + if PaxCompiler1.Compile(PaxProgram1) then + begin + P := PaxProgram1.GetAddress('x'); + Integer(P^) := 5; // change script-defind variable + PaxProgram1.Run; // the first run + ShowMessage('host:' + IntToStr(Integer(P^))); // show script-defined var + Integer(P^) := 30; // change script-defind variable + PaxProgram1.Run; // the second run + end + else + for I:=0 to PaxCompiler1.ErrorCount do + ShowMessage(PaxCompiler1.ErrorMessage[I]); +end; + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/Benchmark1/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/Benchmark1/Project1.dpr new file mode 100644 index 0000000..513a1dd --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/Benchmark1/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/Benchmark1/Project1.res b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/Benchmark1/Project1.res new file mode 100644 index 0000000..3adc036 Binary files /dev/null and b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/Benchmark1/Project1.res differ diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/Benchmark1/Unit1.dfm b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/Benchmark1/Unit1.dfm new file mode 100644 index 0000000..68a55ea --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/Benchmark1/Unit1.dfm @@ -0,0 +1,49 @@ +object Form1: TForm1 + Left = 192 + Top = 114 + Caption = 'Benchmark 1' + ClientHeight = 159 + ClientWidth = 277 + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + PixelsPerInch = 96 + TextHeight = 13 + object Button1: TButton + Left = 32 + Top = 80 + Width = 121 + Height = 25 + Caption = 'paxCompiler' + TabOrder = 0 + OnClick = Button1Click + end + object Button2: TButton + Left = 32 + Top = 128 + Width = 121 + Height = 25 + Caption = 'Delphi' + TabOrder = 1 + OnClick = Button2Click + end + object PaxCompiler1: TPaxCompiler + Alignment = 1 + DebugMode = False + Left = 32 + Top = 24 + end + object PaxProgram1: TPaxProgram + Console = False + Left = 112 + Top = 24 + end + object PaxBasicLanguage1: TPaxBasicLanguage + Left = 224 + Top = 96 + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/Benchmark1/Unit1.pas b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/Benchmark1/Unit1.pas new file mode 100644 index 0000000..e559c32 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/Benchmark1/Unit1.pas @@ -0,0 +1,88 @@ +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, PaxCompiler, PaxProgram, PaxBasicLanguage; + +type + TForm1 = class(TForm) + PaxCompiler1: TPaxCompiler; + PaxProgram1: TPaxProgram; + Button1: TButton; + Button2: TButton; + PaxBasicLanguage1: TPaxBasicLanguage; + procedure Button1Click(Sender: TObject); + procedure Button2Click(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.dfm} + +procedure TForm1.Button1Click(Sender: TObject); +var + I: Integer; + t: Integer; +begin + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxBasicLanguage1); + + PaxCompiler1.AddModule('1', PaxBasicLanguage1.LanguageName); + + PaxCompiler1.AddCode('1', 'Sub P'); + PaxCompiler1.AddCode('1', ' Dim d1 As Double, d2 As Double'); + PaxCompiler1.AddCode('1', ' Dim I As Integer'); + PaxCompiler1.AddCode('1', ' d1 = 5.4'); + PaxCompiler1.AddCode('1', ' d2 = 9009960.3'); + PaxCompiler1.AddCode('1', ' I = 0'); + PaxCompiler1.AddCode('1', ' While d1 < d2'); + PaxCompiler1.AddCode('1', ' I += 1'); + PaxCompiler1.AddCode('1', ' d1 += 0.5'); + PaxCompiler1.AddCode('1', ' End While'); + PaxCompiler1.AddCode('1', 'End Sub'); + PaxCompiler1.AddCode('1', 'P()'); + if PaxCompiler1.Compile(PaxProgram1) then + begin + t := GetTickCount; + PaxProgram1.Run; + ShowMessage(IntToStr(GetTickCount - t)); + end + else + for I:=0 to PaxCompiler1.ErrorCount - 1 do + ShowMessage(PaxCompiler1.ErrorMessage[I]); +end; + +procedure P(); +var + d1, d2: Double; + I: Integer; +begin + d1 := 5.4; + d2 := 9009960.3; + I := 0; + while d1 < d2 do + begin + Inc(I); + d1 := d1 + 0.5; + end; +end; + +procedure TForm1.Button2Click(Sender: TObject); +var + t: Integer; +begin + t := GetTickCount; + P; + ShowMessage(IntToStr(GetTickCount - t)); +end; + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/Benchmark2/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/Benchmark2/Project1.dpr new file mode 100644 index 0000000..513a1dd --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/Benchmark2/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/Benchmark2/Project1.res b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/Benchmark2/Project1.res new file mode 100644 index 0000000..3adc036 Binary files /dev/null and b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/Benchmark2/Project1.res differ diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/Benchmark2/Unit1.dfm b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/Benchmark2/Unit1.dfm new file mode 100644 index 0000000..2c64079 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/Benchmark2/Unit1.dfm @@ -0,0 +1,49 @@ +object Form1: TForm1 + Left = 192 + Top = 114 + Caption = 'Benchmark 2' + ClientHeight = 153 + ClientWidth = 217 + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + PixelsPerInch = 96 + TextHeight = 13 + object Button1: TButton + Left = 24 + Top = 72 + Width = 75 + Height = 25 + Caption = 'PaxCompiler' + TabOrder = 0 + OnClick = Button1Click + end + object Button2: TButton + Left = 24 + Top = 120 + Width = 75 + Height = 25 + Caption = 'Delphi' + TabOrder = 1 + OnClick = Button2Click + end + object PaxCompiler1: TPaxCompiler + Alignment = 1 + DebugMode = False + Left = 24 + Top = 24 + end + object PaxProgram1: TPaxProgram + Console = False + Left = 104 + Top = 24 + end + object PaxBasicLanguage1: TPaxBasicLanguage + Left = 136 + Top = 96 + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/Benchmark2/Unit1.pas b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/Benchmark2/Unit1.pas new file mode 100644 index 0000000..b4847d4 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/Benchmark2/Unit1.pas @@ -0,0 +1,70 @@ +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, + Dialogs, PaxCompiler, StdCtrls, PaxProgram, PaxBasicLanguage; + +type + TForm1 = class(TForm) + Button1: TButton; + Button2: TButton; + PaxCompiler1: TPaxCompiler; + PaxProgram1: TPaxProgram; + PaxBasicLanguage1: TPaxBasicLanguage; + procedure Button1Click(Sender: TObject); + procedure Button2Click(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.dfm} + +procedure TForm1.Button1Click(Sender: TObject); +var + I: Integer; + t: Integer; +begin + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxBasicLanguage1); + + PaxCompiler1.RegisterHeader(0, 'function IntToStr(Value: Integer): string;', @IntToStr); + PaxCompiler1.RegisterHeader(0, 'function StrToInt(const S: string): Integer;', @StrToInt); + + PaxCompiler1.AddModule('1', PaxBasicLanguage1.LanguageName); + + PaxCompiler1.AddCode('1', 'Dim I As Integer, K As Integer'); + PaxCompiler1.AddCode('1', 'For I=1 to 200000'); + PaxCompiler1.AddCode('1', ' K = StrToInt(IntToStr(I))'); + PaxCompiler1.AddCode('1', 'Next'); + + if PaxCompiler1.Compile(PaxProgram1) then + begin + t := GetTickCount; + PaxProgram1.Run; + ShowMessage(IntToStr(GetTickCount - t)); + end + else + for I:=0 to PaxCompiler1.ErrorCount - 1 do + ShowMessage(PaxCompiler1.ErrorMessage[I]); +end; + +procedure TForm1.Button2Click(Sender: TObject); +var + I, K, t: Integer; +begin + t := GetTickCount; + for I:=1 to 200000 do + K := StrToInt(IntToStr(I)); + ShowMessage(IntToStr(GetTickCount - t)); +end; + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/Benchmark3/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/Benchmark3/Project1.dpr new file mode 100644 index 0000000..513a1dd --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/Benchmark3/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/Benchmark3/Project1.res b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/Benchmark3/Project1.res new file mode 100644 index 0000000..3adc036 Binary files /dev/null and b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/Benchmark3/Project1.res differ diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/Benchmark3/Unit1.dfm b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/Benchmark3/Unit1.dfm new file mode 100644 index 0000000..3513981 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/Benchmark3/Unit1.dfm @@ -0,0 +1,49 @@ +object Form1: TForm1 + Left = 192 + Top = 114 + Caption = 'Benchmark 2' + ClientHeight = 153 + ClientWidth = 217 + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + PixelsPerInch = 96 + TextHeight = 13 + object Button1: TButton + Left = 24 + Top = 72 + Width = 75 + Height = 25 + Caption = 'PaxCompiler' + TabOrder = 0 + OnClick = Button1Click + end + object Button2: TButton + Left = 24 + Top = 120 + Width = 75 + Height = 25 + Caption = 'Delphi' + TabOrder = 1 + OnClick = Button2Click + end + object PaxCompiler1: TPaxCompiler + Alignment = 1 + DebugMode = False + Left = 24 + Top = 24 + end + object PaxProgram1: TPaxProgram + Console = False + Left = 104 + Top = 24 + end + object PaxBasicLanguage1: TPaxBasicLanguage + Left = 128 + Top = 96 + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/Benchmark3/Unit1.pas b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/Benchmark3/Unit1.pas new file mode 100644 index 0000000..671f50f --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/Benchmark3/Unit1.pas @@ -0,0 +1,82 @@ +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, + Dialogs, PaxCompiler, StdCtrls, PaxProgram, PaxBasicLanguage; + +type + TForm1 = class(TForm) + Button1: TButton; + Button2: TButton; + PaxCompiler1: TPaxCompiler; + PaxProgram1: TPaxProgram; + PaxBasicLanguage1: TPaxBasicLanguage; + procedure Button1Click(Sender: TObject); + procedure Button2Click(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.dfm} + +procedure TForm1.Button1Click(Sender: TObject); +var + I: Integer; + t: Integer; +begin + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxBasicLanguage1); + + PaxCompiler1.AddModule('1', PaxBasicLanguage1.LanguageName); + + PaxCompiler1.AddCode('1', 'Function Fact(N As Integer) As Integer'); + PaxCompiler1.AddCode('1', ' If N = 1 then'); + PaxCompiler1.AddCode('1', ' Return 1'); + PaxCompiler1.AddCode('1', ' Else'); + PaxCompiler1.AddCode('1', ' Return N * Fact(N - 1)'); + PaxCompiler1.AddCode('1', ' End If'); + PaxCompiler1.AddCode('1', 'End Function'); + PaxCompiler1.AddCode('1', 'Dim I As Integer'); + PaxCompiler1.AddCode('1', 'For I=1 to 1000000'); + PaxCompiler1.AddCode('1', ' Fact(10)'); + PaxCompiler1.AddCode('1', 'Next'); + + if PaxCompiler1.Compile(PaxProgram1) then + begin + t := GetTickCount; + PaxProgram1.Run; + ShowMessage(IntToStr(GetTickCount - t)); + end + else + for I:=0 to PaxCompiler1.ErrorCount - 1 do + ShowMessage(PaxCompiler1.ErrorMessage[I]); +end; + +function Fact(N: Integer): Integer; +begin + if N = 1 then + result := 1 + else + result := N * Fact(N - 1); +end; + +procedure TForm1.Button2Click(Sender: TObject); +var + I, t: Integer; +begin + t := GetTickCount; + for I:=1 to 1000000 do + Fact(10); + ShowMessage(IntToStr(GetTickCount - t)); +end; + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/Benchmark4/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/Benchmark4/Project1.dpr new file mode 100644 index 0000000..513a1dd --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/Benchmark4/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/Benchmark4/Project1.res b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/Benchmark4/Project1.res new file mode 100644 index 0000000..3adc036 Binary files /dev/null and b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/Benchmark4/Project1.res differ diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/Benchmark4/Unit1.dfm b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/Benchmark4/Unit1.dfm new file mode 100644 index 0000000..7ad7b8c --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/Benchmark4/Unit1.dfm @@ -0,0 +1,67 @@ +object Form1: TForm1 + Left = 192 + Top = 114 + Caption = 'Benchmark 4' + ClientHeight = 408 + ClientWidth = 543 + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + PixelsPerInch = 96 + TextHeight = 13 + object Memo1: TMemo + Left = 16 + Top = 176 + Width = 513 + Height = 217 + Lines.Strings = ( + 'Dim I As Integer' + 'Dim C As TComponent = New TComponent(null)' + 'For I = 0 to 500000' + ' If C.Tag = 0' + ' C.Tag = 0' + ' C.Name = "a"' + ' End If' + 'Next' + 'C.Free' + '') + TabOrder = 0 + end + object Button1: TButton + Left = 224 + Top = 136 + Width = 75 + Height = 25 + Caption = 'PaxCompiler' + TabOrder = 1 + OnClick = Button1Click + end + object Button2: TButton + Left = 32 + Top = 136 + Width = 75 + Height = 25 + Caption = 'Delphi' + TabOrder = 2 + OnClick = Button2Click + end + object PaxCompiler1: TPaxCompiler + Alignment = 1 + DebugMode = False + Left = 72 + Top = 24 + end + object PaxProgram1: TPaxProgram + Console = False + Left = 176 + Top = 24 + end + object PaxBasicLanguage1: TPaxBasicLanguage + Left = 336 + Top = 56 + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/Benchmark4/Unit1.pas b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/Benchmark4/Unit1.pas new file mode 100644 index 0000000..e066003 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/Benchmark4/Unit1.pas @@ -0,0 +1,76 @@ +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, PaxCompiler, PaxProgram, PaxRegister, PaxBasicLanguage; + +type + TForm1 = class(TForm) + PaxCompiler1: TPaxCompiler; + PaxProgram1: TPaxProgram; + Memo1: TMemo; + Button1: TButton; + Button2: TButton; + PaxBasicLanguage1: TPaxBasicLanguage; + procedure Button1Click(Sender: TObject); + procedure Button2Click(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.dfm} + +procedure TForm1.Button1Click(Sender: TObject); +var + I, t: Integer; +begin + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxBasicLanguage1); + + PaxCompiler1.AddModule('1', 'Basic'); + PaxCompiler1.AddCode('1', Memo1.Lines.Text); + if PaxCompiler1.Compile(PaxProgram1) then + begin + t := GetTickCount(); + PaxProgram1.Run; + t := GetTickCount() - t; + ShowMessage(IntToStr(t)); + end + else + for I:=0 to PaxCompiler1.ErrorCount - 1 do + ShowMessage(PaxCompiler1.ErrorMessage[I]); +end; + +procedure TForm1.Button2Click(Sender: TObject); +var + t, i, j: Integer; + c: TComponent; +begin + t := GetTickCount(); + c := TComponent.Create(nil); + for i := 0 to 500000 do + if c.Tag = 0 then + begin + c.Tag := 0; + c.Name := 'a'; + end; + c.Free; + t := GetTickCount() - t; + ShowMessage(IntToStr(t)); +end; + +var + H: Integer; +initialization + H := RegisterClassType(0, TComponent); + RegisterHeader(H, 'constructor Create(AOwner: TComponent); virtual;', @TComponent.Create); +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/BindDFM/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/BindDFM/Project1.dpr new file mode 100644 index 0000000..513a1dd --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/BindDFM/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/BindDFM/Project1.res b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/BindDFM/Project1.res new file mode 100644 index 0000000..3adc036 Binary files /dev/null and b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/BindDFM/Project1.res differ diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/BindDFM/Unit1.dfm b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/BindDFM/Unit1.dfm new file mode 100644 index 0000000..3a9216d --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/BindDFM/Unit1.dfm @@ -0,0 +1,61 @@ +object Form1: TForm1 + Left = 338 + Top = 183 + Width = 397 + Height = 222 + Caption = 'Bind DFM file' + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'Tahoma' + Font.Style = [] + OldCreateOrder = False + PixelsPerInch = 96 + TextHeight = 13 + object Button1: TButton + Left = 8 + Top = 24 + Width = 75 + Height = 25 + Caption = 'Run Script' + TabOrder = 0 + OnClick = Button1Click + end + object Memo1: TMemo + Left = 120 + Top = 24 + Width = 233 + Height = 137 + Lines.Strings = ( + 'Imports Unit2' + '' + 'Form2 = New TForm2(null)' + 'Try' + ' Form2.ShowModal' + 'Finally' + ' Form2.Free' + 'End Try' + '') + TabOrder = 1 + end + object PaxCompiler1: TPaxCompiler + Alignment = 1 + DebugMode = False + Left = 24 + Top = 72 + end + object PaxBasicLanguage1: TPaxBasicLanguage + ExplicitOff = False + CompleteBooleanEval = False + UseFWArrays = True + Left = 16 + Top = 128 + end + object PaxProgram1: TPaxProgram + Console = False + OnCreateObject = PaxProgram1CreateObject + Left = 64 + Top = 120 + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/BindDFM/Unit1.pas b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/BindDFM/Unit1.pas new file mode 100644 index 0000000..8ba7ca7 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/BindDFM/Unit1.pas @@ -0,0 +1,64 @@ +{$O-} +unit Unit1; + +interface + +uses + TypInfo, + Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, + Dialogs, PaxProgram, PaxCompiler, StdCtrls, PaxBasicLanguage, PaxRunner; + +type + TForm1 = class(TForm) + Button1: TButton; + Memo1: TMemo; + PaxCompiler1: TPaxCompiler; + PaxProgram1: TPaxProgram; + PaxBasicLanguage1: TPaxBasicLanguage; + procedure Button1Click(Sender: TObject); + procedure PaxProgram1CreateObject(Sender: TPaxRunner; Instance: TObject); + private + { Private declarations } + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.dfm} + +uses + IMPORT_Common; + +procedure TForm1.Button1Click(Sender: TObject); +begin + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxBasicLanguage1); + PaxCompiler1.AddModule('1', 'Basic'); + PaxCompiler1.AddCode('1', Memo1.Lines.Text); + if PaxCompiler1.Compile(PaxProgram1) then + begin + PaxProgram1.Run; + end + else + ShowMessage(PaxCompiler1.ErrorMessage[0]); +end; + +procedure TForm1.PaxProgram1CreateObject(Sender: TPaxRunner; + Instance: TObject); +var + pti: PTypeInfo; + ptd: PTypeData; +begin + if Instance is TForm then + begin + pti := Instance.ClassInfo; + ptd := GetTypeData(pti); + Sender.LoadDFMFile(Instance, ptd^.UnitName + '.dfm'); + end; +end; + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/BindDFM/Unit2.bas b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/BindDFM/Unit2.bas new file mode 100644 index 0000000..e60f598 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/BindDFM/Unit2.bas @@ -0,0 +1,27 @@ +Module Unit2 + + Imports SysUtils, Variants, Classes, Controls, Forms, Dialogs, StdCtrls + + + Class TForm2 + + Inherits TForm + + Published Button1 As TButton + + Published Sub Button1Click(Sender As TObject) + ShowMessage("Hello") + End Sub + + Published Sub FormCreate(Sender As TObject) + ShowMessage("Created") + End Sub + + End Class + + + Dim Form2 As TForm2 + + +End Module + diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/BindDFM/Unit2.dfm b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/BindDFM/Unit2.dfm new file mode 100644 index 0000000..1977d03 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/BindDFM/Unit2.dfm @@ -0,0 +1,26 @@ +object Form2: TForm2 + Left = 30 + Top = 30 + Caption = 'Form2' + ClientHeight = 216 + ClientWidth = 426 + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'Tahoma' + Font.Style = [] + OldCreateOrder = False + OnCreate = FormCreate + PixelsPerInch = 96 + TextHeight = 13 + object Button1: TButton + Left = 50 + Top = 88 + Width = 75 + Height = 25 + Caption = 'Button1' + TabOrder = 0 + OnClick = Button1Click + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/Breakpoints/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/Breakpoints/Project1.dpr new file mode 100644 index 0000000..513a1dd --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/Breakpoints/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/Breakpoints/Project1.res b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/Breakpoints/Project1.res new file mode 100644 index 0000000..3adc036 Binary files /dev/null and b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/Breakpoints/Project1.res differ diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/Breakpoints/Unit1.dfm b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/Breakpoints/Unit1.dfm new file mode 100644 index 0000000..f3783b4 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/Breakpoints/Unit1.dfm @@ -0,0 +1,146 @@ +object Form1: TForm1 + Left = 192 + Top = 114 + Width = 647 + Height = 490 + Caption = 'Form1' + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + PixelsPerInch = 96 + TextHeight = 13 + object Label1: TLabel + Left = 24 + Top = 8 + Width = 52 + Height = 24 + Caption = 'Script:' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -19 + Font.Name = 'MS Sans Serif' + Font.Style = [] + ParentFont = False + end + object Label2: TLabel + Left = 24 + Top = 232 + Width = 61 + Height = 24 + Caption = 'Output:' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -19 + Font.Name = 'MS Sans Serif' + Font.Style = [] + ParentFont = False + end + object Label3: TLabel + Left = 288 + Top = 48 + Width = 182 + Height = 24 + Caption = 'Add breakpoint at line' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -19 + Font.Name = 'MS Sans Serif' + Font.Style = [] + ParentFont = False + end + object Memo1: TMemo + Left = 16 + Top = 40 + Width = 185 + Height = 177 + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -16 + Font.Name = 'MS Sans Serif' + Font.Style = [] + Lines.Strings = ( + ' print("A") // line 0' + ' print("B") // line 1' + ' print("C") // line 2' + ' print("D") // line 3' + ' print("E") // line 4' + '') + ParentFont = False + TabOrder = 0 + end + object Memo2: TMemo + Left = 16 + Top = 262 + Width = 185 + Height = 169 + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -16 + Font.Name = 'MS Sans Serif' + Font.Style = [] + Lines.Strings = ( + '') + ParentFont = False + TabOrder = 1 + end + object Edit1: TEdit + Left = 480 + Top = 48 + Width = 41 + Height = 28 + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -16 + Font.Name = 'MS Sans Serif' + Font.Style = [] + ParentFont = False + TabOrder = 2 + Text = '2' + end + object Button1: TButton + Left = 304 + Top = 192 + Width = 153 + Height = 49 + Caption = 'Run script' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -19 + Font.Name = 'MS Sans Serif' + Font.Style = [] + ParentFont = False + TabOrder = 3 + OnClick = Button1Click + end + object PaxCompiler1: TPaxCompiler + Alignment = 1 + DebugMode = False + Left = 312 + Top = 304 + end + object PaxProgram1: TPaxProgram + Console = False + OnPrintEvent = PaxProgram1PrintEvent + Left = 400 + Top = 304 + end + object PaxCompilerDebugger1: TPaxCompilerDebugger + Left = 432 + Top = 304 + end + object PaxCompilerExplorer1: TPaxCompilerExplorer + Left = 472 + Top = 304 + end + object PaxBasicLanguage1: TPaxBasicLanguage + ExplicitOff = False + CompleteBooleanEval = False + UseFWArrays = True + Left = 344 + Top = 368 + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/Breakpoints/Unit1.pas b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/Breakpoints/Unit1.pas new file mode 100644 index 0000000..0fdc7bd --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/Breakpoints/Unit1.pas @@ -0,0 +1,82 @@ +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, PaxProgram, PaxCompiler, PaxCompilerDebugger, + PaxRegister, + PaxCompilerExplorer, PaxBasicLanguage, PaxRunner; + +type + TForm1 = class(TForm) + Memo1: TMemo; + Memo2: TMemo; + Label1: TLabel; + Label2: TLabel; + Edit1: TEdit; + Label3: TLabel; + Button1: TButton; + PaxCompiler1: TPaxCompiler; + PaxProgram1: TPaxProgram; + PaxCompilerDebugger1: TPaxCompilerDebugger; + PaxCompilerExplorer1: TPaxCompilerExplorer; + PaxBasicLanguage1: TPaxBasicLanguage; + procedure Button1Click(Sender: TObject); + procedure PaxProgram1PrintEvent(Sender: TPaxRunner; const Text: string); + private + { Private declarations } + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.dfm} + +procedure TForm1.Button1Click(Sender: TObject); +var + I: Integer; + Breakpoint: Integer; +begin + Memo2.Lines.Clear; + Breakpoint := StrToInt(Edit1.Text); + + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxBasicLanguage1); + + PaxCompiler1.AddModule('1', PaxBasicLanguage1.LanguageName); + PaxCompiler1.AddCode('1', Memo1.Lines.Text); + + PaxCompiler1.DebugMode := true; + + if PaxCompiler1.Compile(PaxProgram1) then + begin + PaxCompilerExplorer1.RegisterCompiler(PaxCompiler1); + PaxCompilerDebugger1.RegisterCompiler(PaxCompiler1, PaxProgram1); + if PaxCompilerExplorer1.IsExecutableLine('1', Breakpoint) then + PaxCompilerDebugger1.AddBreakpoint('1', Breakpoint); + + PaxCompilerDebugger1.Run; + while PaxCompilerDebugger1.IsPaused do + begin + ShowMessage('Program has been paused at breakpoint: ' + + IntToStr(PaxCompilerDebugger1.SourceLineNumber)); + + PaxProgram1.Run; + end; + end + else + for I:=0 to PaxCompiler1.ErrorCount - 1 do + ShowMessage(PaxCompiler1.ErrorMessage[I]); +end; + +procedure TForm1.PaxProgram1PrintEvent(Sender: TPaxRunner; const Text: string); +begin + Form1.Memo2.Lines.Add(Text); +end; + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/CallRoutine/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/CallRoutine/Project1.dpr new file mode 100644 index 0000000..513a1dd --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/CallRoutine/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/CallRoutine/Project1.res b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/CallRoutine/Project1.res new file mode 100644 index 0000000..3adc036 Binary files /dev/null and b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/CallRoutine/Project1.res differ diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/CallRoutine/Unit1.dfm b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/CallRoutine/Unit1.dfm new file mode 100644 index 0000000..17ffff3 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/CallRoutine/Unit1.dfm @@ -0,0 +1,44 @@ +object Form1: TForm1 + Left = 192 + Top = 114 + Width = 238 + Height = 163 + Caption = 'Call routine demo' + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + OnCreate = FormCreate + PixelsPerInch = 96 + TextHeight = 13 + object Button1: TButton + Left = 40 + Top = 72 + Width = 121 + Height = 25 + Caption = 'Call ' + TabOrder = 0 + OnClick = Button1Click + end + object PaxCompiler1: TPaxCompiler + Alignment = 1 + DebugMode = False + Left = 32 + Top = 16 + end + object PaxProgram1: TPaxProgram + Console = False + Left = 112 + Top = 16 + end + object PaxBasicLanguage1: TPaxBasicLanguage + ExplicitOff = False + CompleteBooleanEval = False + UseFWArrays = True + Left = 160 + Top = 48 + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/CallRoutine/Unit1.pas b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/CallRoutine/Unit1.pas new file mode 100644 index 0000000..0b61723 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/CallRoutine/Unit1.pas @@ -0,0 +1,73 @@ +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, PaxCompiler, PaxProgram, PaxRegister, PaxBasicLanguage, + PaxRunner; +type + TForm1 = class(TForm) + PaxCompiler1: TPaxCompiler; + PaxProgram1: TPaxProgram; + Button1: TButton; + PaxBasicLanguage1: TPaxBasicLanguage; + procedure Button1Click(Sender: TObject); + procedure FormCreate(Sender: TObject); + private + Y: Integer; + { Private declarations } + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.dfm} + +// declare procedural type that conforms to a script-defined procedure +type + TProcP = procedure (X: Integer); + +procedure TForm1.Button1Click(Sender: TObject); +var + H_Y, H_P: Integer; + I: Integer; + P: Pointer; +begin +{$O-} + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxBasicLanguage1); + + H_Y := PaxCompiler1.RegisterVariable(0, 'Y', _typeINTEGER, @Y); + + PaxCompiler1.AddModule('1', PaxBasicLanguage1.LanguageName); + PaxCompiler1.AddCode('1', 'Sub P(X As Integer)'); + PaxCompiler1.AddCode('1', ' Y = Y + X'); + PaxCompiler1.AddCode('1', 'End Sub'); + + if PaxCompiler1.Compile(PaxProgram1) then + begin + H_P := PaxCompiler1.GetHandle(0, 'P', true); + P := PaxProgram1.GetAddress(H_P); // get address of script-defind procedure + + TProcP(P)(10); // call it + ShowMessage(IntToStr(Y)); + + TProcP(P)(20); // call it + ShowMessage(IntToStr(Y)); + end + else + for I:=0 to PaxCompiler1.ErrorCount do + ShowMessage(PaxCompiler1.ErrorMessage[I]); +end; + +procedure TForm1.FormCreate(Sender: TObject); +begin + Y := 0; +end; + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/CodeComplet/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/CodeComplet/Project1.dpr new file mode 100644 index 0000000..5769e8a --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/CodeComplet/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form3}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm3, Form3); + Application.Run; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/CodeComplet/Project1.res b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/CodeComplet/Project1.res new file mode 100644 index 0000000..3adc036 Binary files /dev/null and b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/CodeComplet/Project1.res differ diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/CodeComplet/Unit1.dfm b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/CodeComplet/Unit1.dfm new file mode 100644 index 0000000..df2a1bb --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/CodeComplet/Unit1.dfm @@ -0,0 +1,54 @@ +object Form3: TForm3 + Left = 0 + Top = 0 + Width = 684 + Height = 194 + Caption = 'Code completion demo' + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -10 + Font.Name = 'Tahoma' + Font.Style = [] + OldCreateOrder = False + PixelsPerInch = 96 + TextHeight = 12 + object Button1: TButton + Left = 18 + Top = 12 + Width = 56 + Height = 19 + Caption = 'Create' + TabOrder = 0 + OnClick = Button1Click + end + object Memo1: TMemo + Left = 156 + Top = 6 + Width = 463 + Height = 143 + TabOrder = 1 + end + object PaxCompiler1: TPaxCompiler + Alignment = 1 + DebugMode = False + Left = 24 + Top = 56 + end + object PaxCompilerExplorer1: TPaxCompilerExplorer + Left = 64 + Top = 88 + end + object PaxProgram1: TPaxProgram + Console = False + Left = 24 + Top = 80 + end + object PaxBasicLanguage1: TPaxBasicLanguage + ExplicitOff = False + CompleteBooleanEval = False + UseFWArrays = True + Left = 104 + Top = 64 + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/CodeComplet/Unit1.pas b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/CodeComplet/Unit1.pas new file mode 100644 index 0000000..59d6881 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/CodeComplet/Unit1.pas @@ -0,0 +1,57 @@ +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, + Dialogs, PaxCompiler, StdCtrls, PaxCompilerExplorer, PaxProgram, + PaxBasicLanguage, PaxRunner; + +type + TForm3 = class(TForm) + Button1: TButton; + PaxCompiler1: TPaxCompiler; + PaxCompilerExplorer1: TPaxCompilerExplorer; + PaxProgram1: TPaxProgram; + Memo1: TMemo; + PaxBasicLanguage1: TPaxBasicLanguage; + procedure Button1Click(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + end; + +var + Form3: TForm3; + +implementation + +{$R *.dfm} + +procedure TForm3.Button1Click(Sender: TObject); +var + L: TStringList; +begin + L := TStringList.Create; + try + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxBasicLanguage1); + PaxCompiler1.AddModule('1', 'Basic'); + + PaxCompiler1.AddCodeFromFile('1', 'script1.txt'); + if PaxCompiler1.CodeCompletion('1', 3, 5, Memo1.Lines, PaxBasicLanguage1) then + +// PaxCompiler1.AddCodeFromFile('1', 'script2.txt'); +// if PaxCompiler1.CodeCompletion('1', 1, 3, Memo1.Lines, PaxBasicLanguage1) then + begin + //ok + end + else + ShowMessage(PaxCompiler1.ErrorMessage[0]); + finally + L.Free; + end; +end; + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/CodeComplet/script1.txt b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/CodeComplet/script1.txt new file mode 100644 index 0000000..69e3fe3 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/CodeComplet/script1.txt @@ -0,0 +1,6 @@ +' x = 3, y = 5 +Class SomeClass + Public Z As TObject +End Class +Dim X As SomeClass = New SomeClass +X.Z. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/CodeComplet/script2.txt b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/CodeComplet/script2.txt new file mode 100644 index 0000000..933e691 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/CodeComplet/script2.txt @@ -0,0 +1,4 @@ +' x = 1, y = 3 +Sub P(X As Integer, Y As Integer) +End Sub +P( diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/CodeExplorer/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/CodeExplorer/Project1.dpr new file mode 100644 index 0000000..513a1dd --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/CodeExplorer/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/CodeExplorer/Project1.res b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/CodeExplorer/Project1.res new file mode 100644 index 0000000..3adc036 Binary files /dev/null and b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/CodeExplorer/Project1.res differ diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/CodeExplorer/Unit1.dfm b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/CodeExplorer/Unit1.dfm new file mode 100644 index 0000000..0475bb6 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/CodeExplorer/Unit1.dfm @@ -0,0 +1,97 @@ +object Form1: TForm1 + Left = 192 + Top = 114 + Caption = 'Code explorer demo' + ClientHeight = 446 + ClientWidth = 688 + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + PixelsPerInch = 96 + TextHeight = 13 + object Panel1: TPanel + Left = 0 + Top = 405 + Width = 688 + Height = 41 + Align = alBottom + TabOrder = 0 + object Button1: TButton + Left = 24 + Top = 8 + Width = 105 + Height = 25 + Caption = 'Compile' + TabOrder = 0 + OnClick = Button1Click + end + end + object Memo1: TMemo + Left = 0 + Top = 0 + Width = 345 + Height = 405 + Align = alLeft + Lines.Strings = ( + 'Imports Classes' + '' + 'Structure MyPoint' + ' X As Double' + ' Y As Double' + 'End Structure' + '' + 'Class SomeClass' + ' Public P As Integer' + ' Public Q As Integer' + '' + ' Function MyClassFunc(X As Integer, Y As Integer) As Integer' + ' End Function' + '' + ' Property MyProp As Integer' + ' Get' + ' return P' + ' End Get' + ' End Property' + 'End Class' + '' + 'Dim L As Double' + 'Const W = "abc"' + '' + 'Enum MyEnum' + ' one' + ' two' + ' three' + 'End Enum' + '' + '') + TabOrder = 1 + end + object TreeView1: TTreeView + Left = 345 + Top = 0 + Width = 343 + Height = 405 + Align = alClient + Indent = 19 + TabOrder = 2 + OnDblClick = TreeView1DblClick + end + object PaxCompiler1: TPaxCompiler + Alignment = 1 + DebugMode = False + Left = 224 + Top = 413 + end + object PaxCompilerExplorer1: TPaxCompilerExplorer + Left = 304 + Top = 413 + end + object PaxBasicLanguage1: TPaxBasicLanguage + Left = 384 + Top = 16 + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/CodeExplorer/Unit1.pas b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/CodeExplorer/Unit1.pas new file mode 100644 index 0000000..3f50dc5 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/CodeExplorer/Unit1.pas @@ -0,0 +1,247 @@ +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, + Dialogs, PaxCompilerExplorer, PaxCompiler, StdCtrls, ExtCtrls, ComCtrls, + IMPORT_Classes, PaxBasicLanguage; + +type + TForm1 = class(TForm) + Panel1: TPanel; + Memo1: TMemo; + Button1: TButton; + PaxCompiler1: TPaxCompiler; + PaxCompilerExplorer1: TPaxCompilerExplorer; + TreeView1: TTreeView; + PaxBasicLanguage1: TPaxBasicLanguage; + procedure Button1Click(Sender: TObject); + procedure TreeView1DblClick(Sender: TObject); + private + { Private declarations } + L: TList; + public + { Public declarations } + procedure BuildTree; + procedure EnumProc(Id: Integer; + Host: Boolean; + Kind: TPaxMemberKind; + Data: Pointer); + end; + +var + Form1: TForm1; + +implementation + +{$R *.dfm} + +procedure TForm1.Button1Click(Sender: TObject); +var + I: Integer; +begin + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxBasicLanguage1); + PaxCompiler1.AddModule('1', 'Basic'); + PaxCompiler1.AddCode('1', Memo1.Lines.Text); + if PaxCompiler1.Compile then + begin + PaxCompilerExplorer1.RegisterCompiler(PaxCompiler1); + BuildTree; + end + else + for I:=0 to PaxCompiler1.ErrorCount - 1 do + ShowMessage(PaxCompiler1.ErrorMessage[I]); +end; + +procedure TForm1.BuildTree; +var + N, N2: TTreeNode; + I: Integer; +begin + L := TList.Create; + try + TreeView1.Items.Clear; + + N := TreeView1.Items.Add(nil, 'Used namespaces'); + L.Add(N); + PaxCompilerExplorer1.EnumMembers(0, true, pmkNamespace, EnumProc, N); + PaxCompilerExplorer1.EnumMembers(0, false, pmkNamespace, EnumProc, N); + + N := TreeView1.Items.Add(nil, 'Noname namespace'); + + N2 := TreeView1.Items.AddChild(N, 'Types'); + L.Add(N2); + PaxCompilerExplorer1.EnumMembers(0, false, pmkType, EnumProc, N2); + + N2 := TreeView1.Items.AddChild(N, 'Procedures'); + L.Add(N2); + PaxCompilerExplorer1.EnumMembers(0, false, pmkProcedure, EnumProc, N2); + + N2 := TreeView1.Items.AddChild(N, 'Functions'); + L.Add(N2); + PaxCompilerExplorer1.EnumMembers(0, false, pmkFunction, EnumProc, N2); + + N2 := TreeView1.Items.AddChild(N, 'Constants'); + L.Add(N2); + PaxCompilerExplorer1.EnumMembers(0, false, pmkConst, EnumProc, N2); + + N2 := TreeView1.Items.AddChild(N, 'Variables'); + L.Add(N2); + PaxCompilerExplorer1.EnumMembers(0, false, pmkVar, EnumProc, N2); + + finally + for I := L.Count - 1 downto 0 do + begin + N2 := TTreeNode(L[I]); + if N2.Count = 0 then + N2.Delete; + end; + + L.Free; + end; +end; + +procedure TForm1.EnumProc(Id: Integer; + Host: Boolean; + Kind: TPaxMemberKind; + Data: Pointer); +var + N, N2, N3: TTreeNode; + Name: String; + TypeName: String; +begin + N := TTreeNode(Data); + + Name := PaxCompilerExplorer1.Names[Id]; + TypeName := PaxCompilerExplorer1.TypeNames[Id]; + + with TreeView1.Items do + case Kind of + pmkProcedure, pmkFunction, pmkConstructor, pmkDestructor: + begin + N2 := AddChildObject(N, Name, TObject(Id)); + + N3 := AddChild(N2, 'Parameters'); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, Host, pmkParam, EnumProc, N3); + + N3 := AddChild(N2, 'Local variables'); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, Host, pmkVar, EnumProc, N3); + + N3 := AddChild(N2, 'Local constants'); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, Host, pmkConst, EnumProc, N3); + + N3 := AddChild(N2, 'Local types'); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, Host, pmkType, EnumProc, N3); + + N3 := TreeView1.Items.AddChild(N2, 'Nested procedures'); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, false, pmkProcedure, EnumProc, N3); + + N3 := TreeView1.Items.AddChild(N2, 'Nested functions'); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, false, pmkFunction, EnumProc, N3); + + end; + pmkParam: AddChildObject(N, Name + ' As ' + TypeName, TObject(Id)); + pmkVar: AddChildObject(N, Name + ' As ' + TypeName, TObject(Id)); + pmkConst: AddChildObject(N, Name + ' As ' + TypeName, TObject(Id)); + pmkField: AddChildObject(N, Name + ' As ' + TypeName, TObject(Id)); + pmkProperty: AddChildObject(N, Name + ' As ' + TypeName, TObject(Id)); + pmkType: + begin + N2 := AddChildObject(N, Name, TObject(Id)); + if PaxCompilerExplorer1.IsRecordType(Id) then + begin + N3 := AddChild(N2, 'Fields'); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, Host, pmkField, EnumProc, N3); + end + else if PaxCompilerExplorer1.IsClassType(Id) then + begin + N3 := AddChild(N2, 'Fields'); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, Host, pmkField, EnumProc, N3); + + N3 := AddChild(N2, 'Properties'); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, Host, pmkProperty, EnumProc, N3); + + N3 := TreeView1.Items.AddChild(N2, 'Constructors'); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, false, pmkConstructor, EnumProc, N3); + + N3 := TreeView1.Items.AddChild(N2, 'Destructor'); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, false, pmkDestructor, EnumProc, N3); + + N3 := TreeView1.Items.AddChild(N2, 'Class procedures'); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, false, pmkProcedure, EnumProc, N3); + + N3 := TreeView1.Items.AddChild(N2, 'Class functions'); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, false, pmkFunction, EnumProc, N3); + end; + end; + pmkNamespace: + begin + N2 := AddChildObject(N, Name, TObject(Id)); + + N3 := AddChild(N2, 'Constants'); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, Host, pmkConst, EnumProc, N3); + + N3 := AddChild(N2, 'Variables'); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, Host, pmkVar, EnumProc, N3); + + N3 := AddChild(N2, 'Procedures'); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, Host, pmkProcedure, EnumProc, N3); + + N3 := AddChild(N2, 'Types'); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, Host, pmkType, EnumProc, N3); + end; + end; +end; + +procedure TForm1.TreeView1DblClick(Sender: TObject); +var + N: TTreeNode; + Id, Position: Integer; + S: String; +begin + N := TTreeView(Sender).Selected; + + if N = nil then + Exit; + + Id := Integer(N.Data); + + if Id = 0 then + Exit; + + S := PaxCompilerExplorer1.Names[Id]; + Position := PaxCompilerExplorer1.Positions[Id]; + + if Id <> 0 then + with Memo1 do + begin + SetFocus; + SelStart := Position; + SelLength := Length(S); + end; +end; + +initialization + +Register_Classes; + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/DebugDemo/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/DebugDemo/Project1.dpr new file mode 100644 index 0000000..cebc69a --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/DebugDemo/Project1.dpr @@ -0,0 +1,15 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}, + Unit2 in 'Unit2.pas' {Form2}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.CreateForm(TForm2, Form2); + Application.Run; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/DebugDemo/Project1.res b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/DebugDemo/Project1.res new file mode 100644 index 0000000..3adc036 Binary files /dev/null and b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/DebugDemo/Project1.res differ diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/DebugDemo/Unit1.dfm b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/DebugDemo/Unit1.dfm new file mode 100644 index 0000000..8cc295e --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/DebugDemo/Unit1.dfm @@ -0,0 +1,186 @@ +object Form1: TForm1 + Left = 209 + Top = 111 + Width = 634 + Height = 505 + Caption = 'DebugDemo' + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + OnCloseQuery = FormCloseQuery + PixelsPerInch = 96 + TextHeight = 13 + object Label1: TLabel + Left = 24 + Top = 8 + Width = 52 + Height = 24 + Caption = 'Script:' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -19 + Font.Name = 'MS Sans Serif' + Font.Style = [] + ParentFont = False + end + object Label2: TLabel + Left = 24 + Top = 320 + Width = 54 + Height = 24 + Caption = 'Trace:' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -19 + Font.Name = 'MS Sans Serif' + Font.Style = [] + ParentFont = False + end + object Memo1: TMemo + Left = 16 + Top = 40 + Width = 362 + Height = 273 + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -15 + Font.Name = 'MS Sans Serif' + Font.Style = [] + Lines.Strings = ( + 'Function Fact(N As Integer) As Integer' + ' If N = 1 Then' + ' Return 1' + ' Else' + ' Return N * Fact(N - 1)' + ' End If' + 'End Function' + 'Dim SS As Integer' + 'SS = Fact(3)' + 'print SS' + '') + ParentFont = False + TabOrder = 0 + end + object Memo2: TMemo + Left = 16 + Top = 352 + Width = 417 + Height = 217 + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -15 + Font.Name = 'MS Sans Serif' + Font.Style = [] + Lines.Strings = ( + '') + ParentFont = False + TabOrder = 1 + end + object Button1: TButton + Left = 392 + Top = 25 + Width = 193 + Height = 49 + Caption = 'Compile' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -19 + Font.Name = 'MS Sans Serif' + Font.Style = [] + ParentFont = False + TabOrder = 2 + OnClick = Button1Click + end + object Button2: TButton + Left = 392 + Top = 89 + Width = 193 + Height = 49 + Caption = 'Run' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -19 + Font.Name = 'MS Sans Serif' + Font.Style = [] + ParentFont = False + TabOrder = 3 + OnClick = Button2Click + end + object Button3: TButton + Left = 392 + Top = 155 + Width = 193 + Height = 49 + Caption = 'Trace Into' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -19 + Font.Name = 'MS Sans Serif' + Font.Style = [] + ParentFont = False + TabOrder = 4 + OnClick = Button3Click + end + object Button4: TButton + Left = 392 + Top = 220 + Width = 193 + Height = 50 + Caption = 'Step Over' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -19 + Font.Name = 'MS Sans Serif' + Font.Style = [] + ParentFont = False + TabOrder = 5 + OnClick = Button4Click + end + object Button5: TButton + Left = 392 + Top = 275 + Width = 193 + Height = 48 + Caption = 'Run to Cursor' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -19 + Font.Name = 'MS Sans Serif' + Font.Style = [] + ParentFont = False + TabOrder = 6 + OnClick = Button5Click + end + object PaxCompiler1: TPaxCompiler + Alignment = 1 + DebugMode = False + Left = 184 + Top = 320 + end + object PaxProgram1: TPaxProgram + Console = False + OnPauseUpdated = PaxProgram1PauseUpdated + OnPrintEvent = PaxProgram1PrintEvent + Left = 272 + Top = 320 + end + object PaxCompilerDebugger1: TPaxCompilerDebugger + Left = 312 + Top = 320 + end + object PaxCompilerExplorer1: TPaxCompilerExplorer + Left = 352 + Top = 320 + end + object PaxBasicLanguage1: TPaxBasicLanguage + ExplicitOff = False + CompleteBooleanEval = False + UseFWArrays = True + Left = 224 + Top = 320 + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/DebugDemo/Unit1.pas b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/DebugDemo/Unit1.pas new file mode 100644 index 0000000..76d262b --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/DebugDemo/Unit1.pas @@ -0,0 +1,350 @@ +{$O-} +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, PaxProgram, PaxCompiler, PaxCompilerDebugger, + PaxRegister, + PaxCompilerExplorer, PaxBasicLanguage, PaxRunner; + +type + TForm1 = class(TForm) + Memo1: TMemo; + Memo2: TMemo; + Label1: TLabel; + Label2: TLabel; + Button1: TButton; + PaxCompiler1: TPaxCompiler; + PaxProgram1: TPaxProgram; + Button2: TButton; + Button3: TButton; + Button4: TButton; + Button5: TButton; + PaxCompilerDebugger1: TPaxCompilerDebugger; + PaxCompilerExplorer1: TPaxCompilerExplorer; + PaxBasicLanguage1: TPaxBasicLanguage; + procedure Button1Click(Sender: TObject); + procedure Button2Click(Sender: TObject); + procedure Button3Click(Sender: TObject); + procedure Button4Click(Sender: TObject); + procedure Button5Click(Sender: TObject); + procedure PaxProgram1PauseUpdated(Sender: TPaxRunner; + const ModuleName: string; SourceLineNumber: Integer); + procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean); + procedure PaxProgram1PrintEvent(Sender: TPaxRunner; const Text: string); + private + { Private declarations } + ResumeRequest: Boolean; + CloseRequest: Boolean; + procedure UpdateDebugInfo; + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +uses Unit2; + +{$R *.dfm} + +procedure TForm1.Button1Click(Sender: TObject); +var + I: Integer; +begin + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxBasicLanguage1); + PaxCompiler1.AddModule('1', PaxBasicLanguage1.LanguageName); + PaxCompiler1.AddCode('1', Memo1.Lines.Text); + PaxCompiler1.DebugMode := true; + if PaxCompiler1.Compile(PaxProgram1) then + begin + ShowMessage('Script has been successfully recompiled.'); + PaxCompilerExplorer1.RegisterCompiler(PaxCompiler1); + PaxCompilerDebugger1.RegisterCompiler(PaxCompiler1, PaxProgram1); + end + else + for I:=0 to PaxCompiler1.ErrorCount - 1 do + ShowMessage(PaxCompiler1.ErrorMessage[I]); +end; + +procedure TForm1.Button2Click(Sender: TObject); +begin + if not PaxCompilerDebugger1.Valid then + begin + ShowMessage('You have to compile script. Press "Compile" button.'); + Exit; + end; + PaxCompilerDebugger1.RunMode := _rmRUN; + if PaxCompilerDebugger1.IsPaused then + ResumeRequest := true + else + PaxCompilerDebugger1.Run; +end; + +procedure TForm1.Button3Click(Sender: TObject); +begin + if not PaxCompilerDebugger1.Valid then + begin + ShowMessage('You have to compile script. Press "Compile" button.'); + Exit; + end; + PaxCompilerDebugger1.RunMode := _rmTRACE_INTO; + if PaxCompilerDebugger1.IsPaused then + ResumeRequest := true + else + PaxCompilerDebugger1.Run; +end; + +procedure TForm1.Button4Click(Sender: TObject); +begin + if not PaxCompilerDebugger1.Valid then + begin + ShowMessage('You have to compile script. Press "Compile" button.'); + Exit; + end; + PaxCompilerDebugger1.RunMode := _rmSTEP_OVER; + if PaxCompilerDebugger1.IsPaused then + ResumeRequest := true + else + PaxCompilerDebugger1.Run; +end; + +procedure TForm1.Button5Click(Sender: TObject); +begin + if not PaxCompilerDebugger1.Valid then + begin + ShowMessage('You have to compile script. Press "Compile" button.'); + Exit; + end; + + Form2.ShowModal; + + PaxCompilerDebugger1.RunMode := _rmRUN_TO_CURSOR; + if PaxCompilerDebugger1.IsPaused then + ResumeRequest := true + else + PaxCompilerDebugger1.Run; +end; + +procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean); +begin + CanClose := true; + CloseRequest := true; +end; + +procedure TForm1.PaxProgram1PauseUpdated(Sender: TPaxRunner; + const ModuleName: string; SourceLineNumber: Integer); +begin + UpdateDebugInfo; + ResumeRequest := false; + repeat + Application.ProcessMessages; + if ResumeRequest then + Break; + if CloseRequest then + Abort; + until false; +end; + +procedure TForm1.PaxProgram1PrintEvent(Sender: TPaxRunner; const Text: string); +begin + ShowMessage(Text); +end; + +procedure TForm1.UpdateDebugInfo; + + procedure AddFields(StackFrameNumber, Id: Integer); + var + I, K: Integer; + OwnerName, S: String; + begin + K := PaxCompilerExplorer1.GetFieldCount(Id); + if K = 0 then + Exit; + + OwnerName := PaxCompilerExplorer1.Names[Id]; + if PaxCompilerDebugger1.GetValueAsString(Id) = 'nil' then + Exit; + + for I:=0 to K - 1 do + begin + S := OwnerName + '.' + PaxCompilerExplorer1.GetFieldName(Id, I); + S := ' ' + S + '=' + PaxCompilerDebugger1.GetFieldValueAsString( + StackFrameNumber, Id, I); + Memo2.Lines.Add(S); + end; + end; + + procedure AddPublishedProps(StackFrameNumber, Id: Integer); + var + I, K: Integer; + OwnerName, S: String; + begin + K := PaxCompilerExplorer1.GetPublishedPropCount(Id); + if K = 0 then + Exit; + + OwnerName := PaxCompilerExplorer1.Names[Id]; + if PaxCompilerDebugger1.GetValueAsString(Id) = 'nil' then + Exit; + + for I:=0 to K - 1 do + begin + S := OwnerName + '.' + PaxCompilerExplorer1.GetPublishedPropName(Id, I); + S := ' ' + S + '=' + PaxCompilerDebugger1.GetPublishedPropValueAsString( + StackFrameNumber, Id, I); + Memo2.Lines.Add(S); + end; + end; + + procedure AddArrayElements(StackFrameNumber, Id: Integer); + var + I, K1, K2: Integer; + OwnerName, S: String; + begin + if not PaxCompilerExplorer1.HasArrayType(Id) then + Exit; + + K1 := PaxCompilerExplorer1.GetArrayLowBound(Id); + K2 := PaxCompilerExplorer1.GetArrayHighBound(Id); + + OwnerName := PaxCompilerExplorer1.Names[Id]; + + for I:=K1 to K2 do + begin + S := OwnerName + '[' + IntToStr(I) + ']'; + S := ' ' + S + '=' + PaxCompilerDebugger1.GetArrayItemValueAsString( + StackFrameNumber, Id, I); + Memo2.Lines.Add(S); + end; + end; + + procedure AddDynArrayElements(StackFrameNumber, Id: Integer); + var + I, L: Integer; + OwnerName, S: String; + begin + if not PaxCompilerExplorer1.HasDynArrayType(Id) then + Exit; + + L := PaxCompilerDebugger1.GetDynArrayLength(StackFrameNumber, Id); + + OwnerName := PaxCompilerExplorer1.Names[Id]; + + for I:=0 to L - 1 do + begin + S := OwnerName + '[' + IntToStr(I) + ']'; + S := ' ' + S + '=' + PaxCompilerDebugger1.GetDynArrayItemValueAsString( + StackFrameNumber, Id, I); + Memo2.Lines.Add(S); + end; + end; + +var + SourceLineNumber: Integer; + ModuleName: String; + StackFrameNumber, J, K, SubId, Id: Integer; + S, V: String; + CallStackLineNumber: Integer; + CallStackModuleName: String; +begin + Memo2.Lines.Clear; + if PaxCompilerDebugger1.IsPaused then + begin + ModuleName := PaxCompilerDebugger1.ModuleName; + SourceLineNumber := PaxCompilerDebugger1.SourceLineNumber; + + if SourceLineNumber >= PaxCompiler1.Modules[ModuleName].Count then + Exit; + + Memo2.Lines.Add('Paused at line ' + IntTosTr(SourceLineNumber)); + Memo2.Lines.Add(PaxCompiler1.Modules[ModuleName][SourceLineNumber]); + Memo2.Lines.Add('------------------------------------------------------'); + + if PaxCompilerDebugger1.CallStackCount > 0 then + begin + Memo2.Lines.Add('Call stack:'); + for StackFrameNumber:=0 to PaxCompilerDebugger1.CallStackCount - 1 do + begin + SubId := PaxCompilerDebugger1.CallStack[StackFrameNumber]; + S := '('; + K := PaxCompilerExplorer1.GetParamCount(SubId); + for J:=0 to K - 1 do + begin + Id := PaxCompilerExplorer1.GetParamId(SubId, J); + V := PaxCompilerDebugger1.GetValueAsString(StackFrameNumber, Id); + S := S + V; + if J < K - 1 then + S := S + ','; + end; + S := PaxCompilerExplorer1.Names[SubId] + S + ')'; + + CallStackLineNumber := PaxCompilerDebugger1.CallStackLineNumber[StackFrameNumber]; + CallStackModuleName := PaxCompilerDebugger1.CallStackModuleName[StackFrameNumber]; + + S := S + '; // ' + PaxCompiler1.Modules[CallStackModuleName][CallStackLineNumber]; + + Memo2.Lines.Add(S); + end; + Memo2.Lines.Add('------------------------------------------------------'); + + Memo2.Lines.Add('Local scope:'); + StackFrameNumber := PaxCompilerDebugger1.CallStackCount - 1; + SubId := PaxCompilerDebugger1.CallStack[StackFrameNumber]; + K := PaxCompilerExplorer1.GetLocalCount(SubId); + for J:=0 to K - 1 do + begin + Id := PaxCompilerExplorer1.GetLocalId(SubId, J); + V := PaxCompilerDebugger1.GetValueAsString(StackFrameNumber, Id); + S := PaxCompilerExplorer1.Names[Id] + '=' + V; + Memo2.Lines.Add(S); + + if Pos('X', S) > 0 then + begin + PaxCompilerDebugger1.PutValue(StackFrameNumber, Id, 258); + + V := PaxCompilerDebugger1.GetValueAsString(StackFrameNumber, Id); + S := PaxCompilerExplorer1.Names[Id] + '=' + V; + S := S + ' // modified'; + Memo2.Lines.Add(S); + end; + + AddFields(StackFrameNumber, Id); + AddPublishedProps(StackFrameNumber, Id); + AddArrayElements(StackFrameNumber, Id); + AddDynArrayElements(StackFrameNumber, Id); + end; + + Memo2.Lines.Add('------------------------------------------------------'); + end; + + Memo2.Lines.Add('Global scope:'); + K := PaxCompilerExplorer1.GetGlobalCount(0); + for J:=0 to K - 1 do + begin + Id := PaxCompilerExplorer1.GetGlobalId(0, J); + V := PaxCompilerDebugger1.GetValueAsString(Id); + S := PaxCompilerExplorer1.Names[Id] + '=' + V; + Memo2.Lines.Add(S); + + AddFields(0, Id); + AddPublishedProps(0, Id); + AddArrayElements(0, Id); + AddDynArrayElements(0, Id); + end; + Memo2.Lines.Add('------------------------------------------------------'); + + end + else + Memo2.Lines.Add('Finished'); + + Memo2.SelStart := 0; + Memo2.SelLength := 0; +end; + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/DebugDemo/Unit2.dfm b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/DebugDemo/Unit2.dfm new file mode 100644 index 0000000..c01f34c --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/DebugDemo/Unit2.dfm @@ -0,0 +1,43 @@ +object Form2: TForm2 + Left = 551 + Top = 252 + Width = 384 + Height = 345 + Caption = 'Select line' + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + PixelsPerInch = 96 + TextHeight = 13 + object Panel1: TPanel + Left = 0 + Top = 270 + Width = 376 + Height = 41 + Align = alBottom + TabOrder = 0 + object Button1: TButton + Left = 8 + Top = 8 + Width = 75 + Height = 25 + Caption = 'Ok' + ModalResult = 1 + TabOrder = 0 + OnClick = Button1Click + end + end + object ListBox1: TListBox + Left = 0 + Top = 0 + Width = 376 + Height = 270 + Align = alClient + ItemHeight = 13 + TabOrder = 1 + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/DebugDemo/Unit2.pas b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/DebugDemo/Unit2.pas new file mode 100644 index 0000000..e1e87d9 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/DebugDemo/Unit2.pas @@ -0,0 +1,65 @@ +unit Unit2; + +interface + +uses + Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, ExtCtrls; + +type + TForm2 = class(TForm) + Panel1: TPanel; + ListBox1: TListBox; + Button1: TButton; + procedure Button1Click(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + function ShowModal: Integer; override; + end; + +var + Form2: TForm2; + +implementation + +uses Unit1; + +{$R *.dfm} + +function TForm2.ShowModal: Integer; +var + I: Integer; + S: String; + ch: Char; +begin + ListBox1.Items.Clear; + for I:=0 to Form1.Memo1.Lines.Count - 1 do + begin + if Form1.PaxCompilerExplorer1.IsExecutableLine('1', I) then + ch := '*' + else + ch := ' '; + S := Format('%3d ', [I]) + ch + ' ' + Form1.Memo1.Lines[I]; + ListBox1.Items.Add(S); + end; + + result := inherited ShowModal; +end; + +procedure TForm2.Button1Click(Sender: TObject); +var + I: Integer; +begin + I := ListBox1.ItemIndex; + if Form1.PaxCompilerExplorer1.IsExecutableLine('1', I) then + Form1.PaxCompilerDebugger1.AddTempBreakpoint('1', I) + else + begin + ShowMessage(IntToStr(I) + ' is not executable line!'); + ModalResult := mrCancel; + end; +end; + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/EvalExpression/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/EvalExpression/Project1.dpr new file mode 100644 index 0000000..513a1dd --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/EvalExpression/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/EvalExpression/Project1.res b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/EvalExpression/Project1.res new file mode 100644 index 0000000..3adc036 Binary files /dev/null and b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/EvalExpression/Project1.res differ diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/EvalExpression/Unit1.dfm b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/EvalExpression/Unit1.dfm new file mode 100644 index 0000000..86c22b4 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/EvalExpression/Unit1.dfm @@ -0,0 +1,35 @@ +object Form1: TForm1 + Left = 192 + Top = 115 + Caption = 'Eval Expression' + ClientHeight = 115 + ClientWidth = 265 + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + OnCreate = FormCreate + PixelsPerInch = 96 + TextHeight = 13 + object Button1: TButton + Left = 24 + Top = 24 + Width = 201 + Height = 25 + Caption = 'Create compiled expression' + TabOrder = 0 + OnClick = Button1Click + end + object Button2: TButton + Left = 24 + Top = 64 + Width = 201 + Height = 25 + Caption = 'Evaluate expression' + TabOrder = 1 + OnClick = Button2Click + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/EvalExpression/Unit1.pas b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/EvalExpression/Unit1.pas new file mode 100644 index 0000000..1e8ebf2 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/EvalExpression/Unit1.pas @@ -0,0 +1,116 @@ +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, PaxCompiler, PaxProgram, PaxRegister, PaxBasicLanguage; + +type + TForm1 = class(TForm) + Button1: TButton; + Button2: TButton; + procedure Button1Click(Sender: TObject); + procedure Button2Click(Sender: TObject); + procedure FormCreate(Sender: TObject); + private + { Private declarations } + arr_x, arr_y: array[1..3] of Double; + h_norm, h_x, h_y: Integer; + + buff: array[1..40960] of Byte; + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.dfm} + +function Norm(x, y: Double): Double; +begin + result := Sqrt(x * x + y * y); +end; + +procedure TForm1.Button1Click(Sender: TObject); +var + PaxCompiler1: TPaxCompiler; + PaxBasicLanguage1: TPaxBasicLanguage; + PaxProgram1: TPaxProgram; + I: Integer; +begin + PaxCompiler1 := TPaxCompiler.Create(nil); + PaxBasicLanguage1 := TPaxBasicLanguage.Create(nil); + PaxProgram1 := TPaxProgram.Create(nil); + + try + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxBasicLanguage1); + + h_norm := PaxCompiler1.RegisterHeader(0, 'function Norm(x, y: Double): Double;'); + + h_x := PaxCompiler1.RegisterVariable(0, 'x', _typeDOUBLE); + h_y := PaxCompiler1.RegisterVariable(0, 'y', _typeDOUBLE); + + if PaxCompiler1.CompileExpression('Norm(x, y)', PaxProgram1, 'Basic') then + begin + PaxProgram1.SaveToBuff(buff); + ShowMessage('Compiled expression has been created!'); + end + else + for I:=0 to PaxCompiler1.ErrorCount - 1 do + ShowMessage(PaxCompiler1.ErrorMessage[I]); + + finally + PaxCompiler1.Free; + PaxBasicLanguage1.Free; + PaxProgram1.Free; + end; +end; + +procedure TForm1.Button2Click(Sender: TObject); +var + PaxProgram1: TPaxProgram; + ResValue: Double; + I: Integer; +begin +{$O-} + if h_x <> 0 then + begin + PaxProgram1 := TPaxProgram.Create(nil); + try + PaxProgram1.LoadFromBuff(buff); + + PaxProgram1.SetAddress(h_norm, @norm); + + for I:=1 to 3 do + begin + PaxProgram1.SetAddress(h_x, @arr_x[I]); + PaxProgram1.SetAddress(h_y, @arr_y[I]); + + PaxProgram1.Run; + + ResValue := Double(PaxProgram1.ResultPtr^); + ShowMessage(FloatToStr(ResValue)); + end; + + finally + PaxProgram1.Free; + end; + end + else + ShowMessage('Press the first button to create compiled script.'); +end; + +procedure TForm1.FormCreate(Sender: TObject); +begin + h_x := 0; h_y := 0; h_norm := 0; + arr_x[1] := 4.2; arr_y[1] := -5.2; + arr_x[2] := -0.4; arr_y[2] := 3.2; + arr_x[3] := 2.0; arr_y[3] := 3; +end; + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/EventHandler/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/EventHandler/Project1.dpr new file mode 100644 index 0000000..513a1dd --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/EventHandler/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/EventHandler/Project1.res b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/EventHandler/Project1.res new file mode 100644 index 0000000..3adc036 Binary files /dev/null and b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/EventHandler/Project1.res differ diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/EventHandler/Unit1.dfm b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/EventHandler/Unit1.dfm new file mode 100644 index 0000000..605d51e --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/EventHandler/Unit1.dfm @@ -0,0 +1,107 @@ +object Form1: TForm1 + Left = 19 + Top = 116 + Width = 918 + Height = 523 + Caption = 'Script-defined event handler demo' + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + PixelsPerInch = 96 + TextHeight = 13 + object Button1: TButton + Left = 16 + Top = 8 + Width = 273 + Height = 25 + Caption = 'Create event handler for Button2.OnClick event' + TabOrder = 0 + OnClick = Button1Click + end + object Button2: TButton + Left = 782 + Top = 432 + Width = 75 + Height = 25 + Caption = 'Button2' + TabOrder = 1 + end + object Memo1: TMemo + Left = 16 + Top = 40 + Width = 601 + Height = 433 + Font.Charset = RUSSIAN_CHARSET + Font.Color = clWindowText + Font.Height = -15 + Font.Name = 'Times New Roman' + Font.Style = [] + Lines.Strings = ( + 'Class MyHandler' + ' Sub Handle(Sender As TObject)' + ' ShowMessage("Sender: " + Sender.ClassName)' + ' End Sub' + ' Sub Dispose(Sender As TObject)' + ' Free' + ' End Sub' + 'End Class' + '' + 'Dim X As MyHandler = New MyHandler' + 'Button2.OnClick = X.Handle' + 'Form1.OnDestroy = X.Dispose' + '') + ParentFont = False + TabOrder = 2 + end + object Button3: TButton + Left = 696 + Top = 24 + Width = 161 + Height = 25 + Caption = 'Remove event handler' + TabOrder = 3 + OnClick = Button3Click + end + object Memo2: TMemo + Left = 696 + Top = 72 + Width = 161 + Height = 73 + Font.Charset = RUSSIAN_CHARSET + Font.Color = clWindowText + Font.Height = -15 + Font.Name = 'Times New Roman' + Font.Style = [] + Lines.Strings = ( + 'Button2.OnClick = null') + ParentFont = False + TabOrder = 4 + end + object PaxCompiler1: TPaxCompiler + Alignment = 1 + DebugMode = False + Left = 760 + Top = 248 + end + object PaxProgram1: TPaxProgram + Console = False + Left = 200 + Top = 192 + end + object PaxProgram2: TPaxProgram + Console = False + Left = 760 + Top = 176 + end + object PaxBasicLanguage1: TPaxBasicLanguage + ExplicitOff = False + CompleteBooleanEval = False + UseFWArrays = True + Left = 760 + Top = 312 + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/EventHandler/Unit1.pas b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/EventHandler/Unit1.pas new file mode 100644 index 0000000..8e58c8a --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/EventHandler/Unit1.pas @@ -0,0 +1,92 @@ +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, + Dialogs, PaxProgram, PaxCompiler, StdCtrls, PaxRegister, PaxBasicLanguage, + PaxRunner; + +type + TForm1 = class(TForm) + Button1: TButton; + Button2: TButton; + Memo1: TMemo; + PaxCompiler1: TPaxCompiler; + PaxProgram1: TPaxProgram; + Button3: TButton; + Memo2: TMemo; + PaxProgram2: TPaxProgram; + PaxBasicLanguage1: TPaxBasicLanguage; + procedure Button1Click(Sender: TObject); + procedure Button3Click(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.dfm} + +var + H_TButton, H_TForm1: Integer; + +procedure TForm1.Button1Click(Sender: TObject); +var + I: Integer; +begin + if Assigned(Button2.OnClick) then + begin + ShowMessage('The event handler has been already created.'); + Exit; + end; + + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxBasicLanguage1); + PaxCompiler1.AddModule('1', 'Basic'); + PaxCompiler1.AddCode('1', Memo1.Lines.Text); + PaxCompiler1.RegisterVariable(0, 'Button2', H_TButton, @Button2); + PaxCompiler1.RegisterVariable(0, 'Form1', H_TForm1, @Form1); + + if PaxCompiler1.Compile(PaxProgram1) then + begin + PaxProgram1.Run; + ShowMessage('The event handler has been created. Click Button2.'); + end + else + for I:=0 to PaxCompiler1.ErrorCount - 1 do + ShowMessage(PaxCompiler1.ErrorMessage[I]); +end; + +procedure TForm1.Button3Click(Sender: TObject); +var + I: Integer; +begin + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxBasicLanguage1); + PaxCompiler1.AddModule('1', 'Basic'); + PaxCompiler1.AddCode('1', Memo2.Lines.Text); + PaxCompiler1.RegisterVariable(0, 'Button2', H_TButton, @Button2); + + if PaxCompiler1.Compile(PaxProgram2) then + begin + PaxProgram2.Run; + ShowMessage('The event handler has been removed.'); + end + else + for I:=0 to PaxCompiler1.ErrorCount - 1 do + ShowMessage(PaxCompiler1.ErrorMessage[I]); +end; + +initialization + + H_TButton := RegisterClassType(0, TButton); + H_TForm1 := RegisterClassType(0, TForm1); + RegisterHeader(0, 'procedure ShowMessage(const Msg: string);', @ShowMessage); + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/EventHandler2/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/EventHandler2/Project1.dpr new file mode 100644 index 0000000..513a1dd --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/EventHandler2/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/EventHandler2/Project1.res b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/EventHandler2/Project1.res new file mode 100644 index 0000000..e916e21 Binary files /dev/null and b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/EventHandler2/Project1.res differ diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/EventHandler2/Unit1.dfm b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/EventHandler2/Unit1.dfm new file mode 100644 index 0000000..b8944f3 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/EventHandler2/Unit1.dfm @@ -0,0 +1,115 @@ +object Form1: TForm1 + Left = 192 + Top = 114 + Width = 889 + Height = 607 + Caption = 'Event handler demo' + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + PixelsPerInch = 96 + TextHeight = 13 + object Button1: TButton + Left = 16 + Top = 16 + Width = 209 + Height = 25 + Caption = '1. Compile script' + TabOrder = 0 + OnClick = Button1Click + end + object Button2: TButton + Left = 16 + Top = 56 + Width = 209 + Height = 25 + Caption = '2. Set up script-defined event handler' + TabOrder = 1 + OnClick = Button2Click + end + object Button3: TButton + Left = 16 + Top = 96 + Width = 209 + Height = 25 + Caption = '3. Restore host-defined event handler' + TabOrder = 2 + OnClick = Button3Click + end + object Memo1: TMemo + Left = 240 + Top = 8 + Width = 608 + Height = 545 + Font.Charset = RUSSIAN_CHARSET + Font.Color = clWindowText + Font.Height = -13 + Font.Name = 'Times New Roman' + Font.Style = [] + Lines.Strings = ( + 'Class MyHandler' + ' Sub Handle(Sender As TObject)' + + ' ShowMessage("Script-defined handler. Sender: " + Sender.Clas' + + 'sName)' + ' End Sub' + ' Sub Dispose(Sender As TObject)' + ' Free' + ' End Sub' + 'End Class' + '' + 'Dim X As MyHandler' + 'Dim E As TNotifyEvent' + '' + 'Sub SetHandler' + ' E = ClickMe.OnClick' + ' ClickMe.OnClick = X.Handle' + 'End Sub' + '' + 'Sub RestoreHandler' + ' ClickMe.OnClick = E' + 'End Sub' + '' + 'X = New MyHandler' + 'ClickMe.OnClick(X)' + 'Form1.OnDestroy = X.Dispose' + + 'ShowMessage("The script was compiled and initialized successfull' + + 'y.")' + '' + '') + ParentFont = False + TabOrder = 3 + end + object ClickMe: TButton + Left = 24 + Top = 440 + Width = 201 + Height = 105 + Caption = 'ClickMe' + TabOrder = 4 + OnClick = ClickMeClick + end + object PaxCompiler1: TPaxCompiler + Alignment = 1 + DebugMode = False + Left = 632 + Top = 64 + end + object PaxProgram1: TPaxProgram + Console = False + Left = 632 + Top = 152 + end + object PaxBasicLanguage1: TPaxBasicLanguage + ExplicitOff = False + CompleteBooleanEval = False + UseFWArrays = True + Left = 648 + Top = 304 + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/EventHandler2/Unit1.pas b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/EventHandler2/Unit1.pas new file mode 100644 index 0000000..7646808 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/EventHandler2/Unit1.pas @@ -0,0 +1,105 @@ +{$O-} + +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, PaxProgram, PaxCompiler, PaxRegister, PaxBasicLanguage, + PaxRunner; + +type + TForm1 = class(TForm) + Button1: TButton; + Button2: TButton; + Button3: TButton; + Memo1: TMemo; + ClickMe: TButton; + PaxCompiler1: TPaxCompiler; + PaxProgram1: TPaxProgram; + PaxBasicLanguage1: TPaxBasicLanguage; + procedure Button1Click(Sender: TObject); + procedure ClickMeClick(Sender: TObject); + procedure Button2Click(Sender: TObject); + procedure Button3Click(Sender: TObject); + private + { Private declarations } + P_SetHandler: Pointer; + P_RestoreHandler: Pointer; + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.dfm} + +var + H_TButton, H_TForm1: Integer; + +type + TProcP = procedure; + +procedure TForm1.Button1Click(Sender: TObject); +var + I: Integer; + H: Integer; +begin + if PaxProgram1.DataSize > 0 then + begin + ShowMessage('Script is already compiled.'); + Exit; + end; + + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxBasicLanguage1); + PaxCompiler1.AddModule('1', 'Basic'); + PaxCompiler1.AddCode('1', Memo1.Lines.Text); + PaxCompiler1.RegisterVariable(0, 'ClickMe', H_TButton, @ClickMe); + PaxCompiler1.RegisterVariable(0, 'Form1', H_TForm1, @Form1); + + if PaxCompiler1.Compile(PaxProgram1) then + begin + H := PaxCompiler1.GetHandle(0, 'SetHandler', true); + P_SetHandler := PaxProgram1.GetAddress(H); + + H := PaxCompiler1.GetHandle(0, 'RestoreHandler', true); + P_RestoreHandler := PaxProgram1.GetAddress(H); + + PaxProgram1.Run; + end + else + for I:=0 to PaxCompiler1.ErrorCount - 1 do + ShowMessage(PaxCompiler1.ErrorMessage[I]); +end; + +procedure TForm1.Button2Click(Sender: TObject); +begin + TProcP(P_SetHandler); + + ShowMessage('ClickMe contains script-defined event handler now.'); +end; + +procedure TForm1.Button3Click(Sender: TObject); +begin + TProcP(P_RestoreHandler); + + ShowMessage('Host-defined handler is restored.'); +end; + +procedure TForm1.ClickMeClick(Sender: TObject); +begin + ShowMessage('Host-defined event handler. Sender: ' + Sender.ClassName); +end; + +initialization + + H_TButton := RegisterClassType(0, TButton); + H_TForm1 := RegisterClassType(0, TForm1); + RegisterHeader(0, 'procedure ShowMessage(const Msg: string);', @ShowMessage); + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/HandledException/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/HandledException/Project1.dpr new file mode 100644 index 0000000..513a1dd --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/HandledException/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/HandledException/Project1.res b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/HandledException/Project1.res new file mode 100644 index 0000000..3adc036 Binary files /dev/null and b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/HandledException/Project1.res differ diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/HandledException/Unit1.dfm b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/HandledException/Unit1.dfm new file mode 100644 index 0000000..29486cc --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/HandledException/Unit1.dfm @@ -0,0 +1,84 @@ +object Form1: TForm1 + Left = 192 + Top = 114 + Width = 721 + Height = 602 + Caption = 'Run-time error handling' + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + PixelsPerInch = 96 + TextHeight = 13 + object Button1: TButton + Left = 24 + Top = 16 + Width = 161 + Height = 25 + Caption = 'Compile and Run' + TabOrder = 0 + OnClick = Button1Click + end + object Memo1: TMemo + Left = 200 + Top = 16 + Width = 481 + Height = 441 + Lines.Strings = ( + 'Imports SysUtils' + '' + 'Sub ErrorProc' + 'Dim I As Integer' + ' I = 0' + ' I = I \ I' + 'End Sub' + '' + 'Sub TestFinally' + ' Dim S As String = "abc"' + ' Dim I As Integer' + ' Try' + ' ErrorProc' + ' Finally' + ' println S' + ' End Try' + ' Println "not executed"' + 'End Sub' + '' + 'Try' + ' TestFinally' + 'Catch' + ' println "ok"' + 'End Try') + TabOrder = 1 + end + object Memo2: TMemo + Left = 200 + Top = 464 + Width = 481 + Height = 89 + TabOrder = 2 + end + object PaxCompiler1: TPaxCompiler + Alignment = 1 + DebugMode = False + Left = 64 + Top = 112 + end + object PaxProgram1: TPaxProgram + Console = False + OnException = PaxProgram1Exception + OnPrintEvent = PaxProgram1PrintEvent + Left = 112 + Top = 168 + end + object PaxBasicLanguage1: TPaxBasicLanguage + ExplicitOff = False + CompleteBooleanEval = False + UseFWArrays = True + Left = 112 + Top = 240 + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/HandledException/Unit1.pas b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/HandledException/Unit1.pas new file mode 100644 index 0000000..1a2e87a --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/HandledException/Unit1.pas @@ -0,0 +1,70 @@ +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, + Dialogs, PaxProgram, PaxCompiler, StdCtrls, PAXCOMP_STDLIB, PaxBasicLanguage, + PaxRunner; + +type + TForm1 = class(TForm) + Button1: TButton; + Memo1: TMemo; + PaxCompiler1: TPaxCompiler; + PaxProgram1: TPaxProgram; + Memo2: TMemo; + PaxBasicLanguage1: TPaxBasicLanguage; + procedure Button1Click(Sender: TObject); + procedure PaxProgram1Exception(Sender: TPaxRunner; E: Exception; + const ModuleName: String; SourceLineNumber: Integer); + procedure PaxProgram1PrintEvent(Sender: TPaxRunner; const Text: string); + private + { Private declarations } + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.dfm} + +uses + IMPORT_SysUtils; + +procedure TForm1.Button1Click(Sender: TObject); +begin + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxBasicLanguage1); + PaxCompiler1.AddModule('main', 'Basic'); + PaxCompiler1.AddCode('main', Memo1.Lines.Text); + if PaxCompiler1.Compile(PaxProgram1) then + begin + PaxProgram1.Run; + end + else + ShowMessage(PaxCompiler1.ErrorMessage[0]); +end; + +procedure TForm1.PaxProgram1Exception(Sender: TPaxRunner; E: Exception; + const ModuleName: String; SourceLineNumber: Integer); +begin + Form1.Memo2.Text := Form1.Memo2.Text + #13#10 + + 'Exception (' + E.Message + + ') raised at line ' + IntToStr(SourceLineNumber) + ':' + + PaxCompiler1.Modules[ModuleName][SourceLineNumber] + #13#10; +end; + +procedure TForm1.PaxProgram1PrintEvent(Sender: TPaxRunner; const Text: string); +begin + Form1.Memo2.Text := Form1.Memo2.Text + Text; +end; + +initialization + +Register_SysUtils; + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/Hello/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/Hello/Project1.dpr new file mode 100644 index 0000000..513a1dd --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/Hello/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/Hello/Unit1.dfm b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/Hello/Unit1.dfm new file mode 100644 index 0000000..5f0d31d --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/Hello/Unit1.dfm @@ -0,0 +1,43 @@ +object Form1: TForm1 + Left = 192 + Top = 114 + Width = 252 + Height = 172 + Caption = 'HelloApp' + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + PixelsPerInch = 96 + TextHeight = 13 + object Button1: TButton + Left = 32 + Top = 80 + Width = 75 + Height = 25 + Caption = 'Say "Hello"' + TabOrder = 0 + OnClick = Button1Click + end + object PaxCompiler1: TPaxCompiler + Alignment = 1 + DebugMode = False + Left = 48 + Top = 24 + end + object PaxProgram1: TPaxProgram + Console = False + Left = 144 + Top = 24 + end + object PaxBasicLanguage1: TPaxBasicLanguage + ExplicitOff = False + CompleteBooleanEval = False + UseFWArrays = True + Left = 152 + Top = 72 + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/Hello/Unit1.pas b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/Hello/Unit1.pas new file mode 100644 index 0000000..7acfe68 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/Hello/Unit1.pas @@ -0,0 +1,48 @@ +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, PaxCompiler, PaxProgram, PaxBasicLanguage, PaxRunner; +type + TForm1 = class(TForm) + PaxCompiler1: TPaxCompiler; + PaxProgram1: TPaxProgram; + Button1: TButton; + PaxBasicLanguage1: TPaxBasicLanguage; + procedure Button1Click(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.dfm} + +procedure TForm1.Button1Click(Sender: TObject); +var + I, H_TButton: Integer; +begin + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxBasicLanguage1); + + H_TButton := PaxCompiler1.RegisterClassType(0, TButton); + PaxCompiler1.RegisterVariable(0, 'Button1', H_TButton, @Button1); + + PaxCompiler1.AddModule('1', PaxBasicLanguage1.LanguageName); + PaxCompiler1.AddCode('1', 'Button1.Caption = "Hello"'); + + if PaxCompiler1.Compile(PaxProgram1) then + PaxProgram1.Run + else + for I:=0 to PaxCompiler1.ErrorCount - 1 do + ShowMessage(PaxCompiler1.ErrorMessage[I]); +end; + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/LoadCompiledScript/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/LoadCompiledScript/Project1.dpr new file mode 100644 index 0000000..513a1dd --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/LoadCompiledScript/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/LoadCompiledScript/Project1.res b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/LoadCompiledScript/Project1.res new file mode 100644 index 0000000..3adc036 Binary files /dev/null and b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/LoadCompiledScript/Project1.res differ diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/LoadCompiledScript/Unit1.dfm b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/LoadCompiledScript/Unit1.dfm new file mode 100644 index 0000000..43fd831 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/LoadCompiledScript/Unit1.dfm @@ -0,0 +1,35 @@ +object Form1: TForm1 + Left = 192 + Top = 114 + Caption = 'Load compiled script demo' + ClientHeight = 168 + ClientWidth = 277 + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + OnCreate = FormCreate + PixelsPerInch = 96 + TextHeight = 13 + object Button1: TButton + Left = 40 + Top = 40 + Width = 193 + Height = 25 + Caption = 'Compile script. Save compile script.' + TabOrder = 0 + OnClick = Button1Click + end + object Button2: TButton + Left = 40 + Top = 96 + Width = 193 + Height = 25 + Caption = 'Load compiled script. Run script.' + TabOrder = 1 + OnClick = Button2Click + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/LoadCompiledScript/Unit1.pas b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/LoadCompiledScript/Unit1.pas new file mode 100644 index 0000000..b32bfed --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/LoadCompiledScript/Unit1.pas @@ -0,0 +1,96 @@ +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, PaxCompiler, PaxProgram, PaxRegister, PaxBasicLanguage; +type + TForm1 = class(TForm) + Button1: TButton; + Button2: TButton; + procedure Button1Click(Sender: TObject); + procedure Button2Click(Sender: TObject); + procedure FormCreate(Sender: TObject); + private + H_ShowMessage: Integer; + H_S: Integer; + S: AnsiString; + { Private declarations } + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.dfm} + +procedure TForm1.Button1Click(Sender: TObject); +var + I: Integer; + PaxCompiler1: TPaxCompiler; + PaxBasicLanguage1: TPaxBasicLanguage; + PaxProgram1: TPaxProgram; +begin + PaxCompiler1 := TPaxCompiler.Create(nil); + PaxBasicLanguage1 := TPaxBasicLanguage.Create(nil); + PaxProgram1 := TPaxProgram.Create(nil); + + try + PaxCompiler1.RegisterLanguage(PaxBasicLanguage1); + + // register routine 'ShowMessage' + H_ShowMessage := PaxCompiler1.RegisterHeader(0, 'procedure ShowMessage(const Msg: string);'); + + // register variable 'S' + H_S := PaxCompiler1.RegisterVariable(0, 'S', _typeSTRING); + + PaxCompiler1.AddModule('1', PaxBasicLanguage1.LanguageName); + PaxCompiler1.AddCode('1', 'ShowMessage(S)'); + + if PaxCompiler1.Compile(PaxProgram1) then + begin + PaxProgram1.SaveToFile('1.bin'); + ShowMessage('Compiled script has been created!'); + end + else + for I:=0 to PaxCompiler1.ErrorCount - 1 do + ShowMessage(PaxCompiler1.ErrorMessage[I]); + finally + PaxCompiler1.Free; + PaxBasicLanguage1.Free; + PaxProgram1.Free; + end; +end; + +procedure TForm1.Button2Click(Sender: TObject); +var + PaxProgram1: TPaxProgram; +begin + if FileExists('1.bin') and (H_ShowMessage <> 0) and (H_S <> 0) then + begin + PaxProgram1 := TPaxProgram.Create(nil); + try + PaxProgram1.LoadFromFile('1.bin'); + PaxProgram1.SetAddress(H_ShowMessage, @ShowMessage); + PaxProgram1.SetAddress(H_S, @S); + PaxProgram1.Run; + finally + PaxProgram1.Free; + end; + end + else + ShowMessage('Press the first button to create compiled script.'); +end; + +procedure TForm1.FormCreate(Sender: TObject); +begin + H_ShowMessage := 0; + H_S := 0; + S := 'Hello'; +end; + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/OnUsedUnitEvent/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/OnUsedUnitEvent/Project1.dpr new file mode 100644 index 0000000..513a1dd --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/OnUsedUnitEvent/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/OnUsedUnitEvent/Project1.res b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/OnUsedUnitEvent/Project1.res new file mode 100644 index 0000000..3adc036 Binary files /dev/null and b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/OnUsedUnitEvent/Project1.res differ diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/OnUsedUnitEvent/Unit1.dfm b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/OnUsedUnitEvent/Unit1.dfm new file mode 100644 index 0000000..012dc4c --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/OnUsedUnitEvent/Unit1.dfm @@ -0,0 +1,44 @@ +object Form1: TForm1 + Left = 192 + Top = 114 + Width = 329 + Height = 156 + Caption = 'OnUsedUnit event demo' + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + PixelsPerInch = 96 + TextHeight = 13 + object Button1: TButton + Left = 24 + Top = 24 + Width = 209 + Height = 25 + Caption = 'Compile and Run' + TabOrder = 0 + OnClick = Button1Click + end + object PaxCompiler1: TPaxCompiler + Alignment = 1 + OnUsedUnit = PaxCompiler1UsedUnit + DebugMode = False + Left = 24 + Top = 80 + end + object PaxProgram1: TPaxProgram + Console = False + Left = 120 + Top = 80 + end + object PaxBasicLanguage1: TPaxBasicLanguage + ExplicitOff = False + CompleteBooleanEval = False + UseFWArrays = True + Left = 176 + Top = 80 + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/OnUsedUnitEvent/Unit1.pas b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/OnUsedUnitEvent/Unit1.pas new file mode 100644 index 0000000..fa5e4b8 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/OnUsedUnitEvent/Unit1.pas @@ -0,0 +1,68 @@ +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, + Dialogs, PaxProgram, PaxCompiler, PaxRegister, StdCtrls, PaxBasicLanguage, + PaxRunner; + +type + TForm1 = class(TForm) + Button1: TButton; + PaxCompiler1: TPaxCompiler; + PaxProgram1: TPaxProgram; + PaxBasicLanguage1: TPaxBasicLanguage; + procedure Button1Click(Sender: TObject); + function PaxCompiler1UsedUnit(Sender: TPaxCompiler; + const UnitName: String; var SourceCode: String): Boolean; + private + { Private declarations } + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.dfm} + +procedure TForm1.Button1Click(Sender: TObject); +begin + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxBasicLanguage1); + PaxCompiler1.AddModule('main', 'Basic'); + PaxCompiler1.AddCode('main', 'Imports SomeUnit'); + PaxCompiler1.AddCode('main', 'P()'); + if PaxCompiler1.Compile(PaxProgram1) then + begin + PaxProgram1.Run; + end + else + ShowMessage(PaxCompiler1.ErrorMessage[0]); +end; + +function TForm1.PaxCompiler1UsedUnit(Sender: TPaxCompiler; + const UnitName: String; var SourceCode: String): Boolean; +begin + if UnitName = 'SomeUnit' then + begin + result := true; + SourceCode := + + 'Module SomeUnit' + #13#10 + + ' Public Sub P' + #13#10 + + ' ShowMessage("Hello")' + #13#10 + + ' End Sub' + #13#10 + + 'End Module' + #13#10; + + end + else + result := false; // default processing +end; + +initialization + RegisterHeader(0, 'procedure ShowMessage(const Msg: string);', @ShowMessage); +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/PCU/MyModule.txt b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/PCU/MyModule.txt new file mode 100644 index 0000000..336ed0a --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/PCU/MyModule.txt @@ -0,0 +1,31 @@ +Module MyModule + + Imports Controls, StdCtrls, Forms, Dialogs + + Class MyForm + Inherits TForm + + Published Button1 As TButton + + Sub Button1Click(Sender As TObject) + ShowMessage("Hello!") + End Sub + + Sub New + MyBase.Create(null) + Caption = "My form created in Basic" + Button1 = New TButton(Me) + With Button1 + .Parent = Me + .Caption = "Click Me" + .Name = "Button1" + .Left = 10 + .Top = 20 + .OnClick = Button1Click + End With + End Sub + + + End Class + +End Module \ No newline at end of file diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/PCU/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/PCU/Project1.dpr new file mode 100644 index 0000000..2a9a95e --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/PCU/Project1.dpr @@ -0,0 +1,183 @@ +program Project2; +{$APPTYPE CONSOLE} +uses + sysutils, + Classes, + TypInfo, + PAXCOMP_CONSTANTS, + PaxCompiler, + PaxCompilerExplorer, + PaxCompilerDebugger, + PaxBasicLanguage, + PaxProgram, + PaxRegister, + IMPORT_Common; + +type + TMyHandler = class + private + L: TStringList; + public + constructor Create; + destructor Destroy; override; + procedure SaveToDisk; + function UsedUnitHandler(Sender: TPaxCompiler; const UnitName: String; + var SourceCode: String): Boolean; + function SavePCUCompilerHandler(Sender: TPaxCompiler; const UnitName: String): TStream; + function LoadPCUCompilerHandler(Sender: TPaxCompiler; const UnitName: String): TStream; + function LoadPCUProgramHandler(Sender: TPaxProgram; const UnitName: String): TStream; + end; + +constructor TMyHandler.Create; +begin + inherited; + L := TStringList.Create; +end; + +destructor TMyHandler.Destroy; +var + I: Integer; +begin + for I := 0 to L.Count - 1 do + L.Objects[I].Free; + + L.Free; + inherited; +end; + +procedure TMyHandler.SaveToDisk; +var + I: Integer; + Stream: TMemoryStream; + S: String; +begin + for I := 0 to L.Count - 1 do + begin + S := L[I]; + Stream := TMemoryStream(L.Objects[I]); + Stream.Position := 0; + Stream.SaveToFile(S + '.PCU'); + end; +end; + +function TMyHandler.UsedUnitHandler(Sender: TPaxCompiler; const UnitName: String; + var SourceCode: String): Boolean; +var + L: TStringList; +begin + if CompareText(UnitName, 'MyModule') = 0 then + begin + L := TStringList.Create; + try + L.LoadFromFile('MyModule.txt'); // just to load it from somewhere + SourceCode := L.Text; + finally + L.Free; + end; + result := true; + end; +end; + +function TMyHandler.SavePCUCompilerHandler(Sender: TPaxCompiler; const UnitName: String): TStream; +begin + result := TMemoryStream.Create; + L.AddObject(UnitName, result); +end; + +function TMyHandler.LoadPCUCompilerHandler(Sender: TPaxCompiler; const UnitName: String): TStream; +var + I: Integer; +begin + result := nil; + for I := 0 to L.Count - 1 do + if CompareText(L[I], UnitName) = 0 then + begin + result := TStream(L.Objects[I]); + result.Position := 0; + Exit; + end; +end; + +function TMyHandler.LoadPCUProgramHandler(Sender: TPaxProgram; const UnitName: String): TStream; +var + I: Integer; +begin + result := nil; + for I := 0 to L.Count - 1 do + if CompareText(L[I], UnitName) = 0 then + begin + result := TStream(L.Objects[I]); + result.Position := 0; + Exit; + end; +end; + +var + MyHandler: TMyHandler; + +var + PaxCompiler1: TPaxCompiler; + PaxProgram1: TPaxProgram; + PaxBasicLanguage1: TPaxBasicLanguage; +begin + // Build all units, save pcu-files and create compiled script + + MyHandler := TMyHandler.Create; + try + + PaxCompiler1 := TPaxCompiler.Create(nil); + PaxCompiler1.OnUsedUnit := MyHandler.UsedUnitHandler; +// PaxCompiler1.OnSavePCU := MyHandler.SavePCUCompilerHandler; +// PaxCompiler1.OnLoadPCU := MyHandler.LoadPCUCompilerHandler; + + PaxProgram1 := TPaxProgram.Create(nil); + PaxBasicLanguage1 := TPaxBasicLanguage.Create(nil); + try + PaxCompiler1.RegisterLanguage(PaxBasicLanguage1); + PaxCompiler1.AddModule('1', 'Basic'); + PaxCompiler1.AddCodeFromFile('1', 'script.txt'); + + if PaxCompiler1.Compile(PaxProgram1, true, true) then + // build with run-time packages + begin + PaxProgram1.SaveToFile('script.bin'); +// PaxProgram1.Run; +// writeln('Press any key...'); +// Readln; +// Exit; + end + else + begin + writeln(PaxCompiler1.ErrorMessage[0]); + writeln(PaxCompiler1.ErrorLine[0]); + writeln('Press any key...'); + Readln; + Exit; + end; + finally + PaxCompiler1.Free; + PaxProgram1.Free; + PaxBasicLanguage1.Free; + end; + +// MyHandler.SaveToDisk; + + // Use compiled units (pcu-files) at run-tme as run-time packages + + PaxProgram1 := TPaxProgram.Create(nil); + try +// PaxProgram1.OnLoadPCU := MyHandler.LoadPCUProgramHandler; + + PaxProgram1.LoadFromFile('script.bin'); + PaxProgram1.Run; + finally + PaxProgram1.Free; + end; + + finally + MyHandler.Free; + end; + + writeln('Press any key...'); + Readln; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/PCU/script.txt b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/PCU/script.txt new file mode 100644 index 0000000..b18e22b --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/PCU/script.txt @@ -0,0 +1,9 @@ +Imports Forms +Imports MyModule + +Dim F As MyForm = New MyForm +Try + F.ShowModal +Finally + F.Free +End Try \ No newline at end of file diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/PaxInvoke/CppDll/CppDll/CppDll.dsp b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/PaxInvoke/CppDll/CppDll/CppDll.dsp new file mode 100644 index 0000000..1aa0398 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/PaxInvoke/CppDll/CppDll/CppDll.dsp @@ -0,0 +1,113 @@ +# Microsoft Developer Studio Project File - Name="CppDll" - Package Owner=<4> +# Microsoft Developer Studio Generated Build File, Format Version 6.00 +# ** DO NOT EDIT ** + +# TARGTYPE "Win32 (x86) Dynamic-Link Library" 0x0102 + +CFG=CppDll - Win32 Debug +!MESSAGE This is not a valid makefile. To build this project using NMAKE, +!MESSAGE use the Export Makefile command and run +!MESSAGE +!MESSAGE NMAKE /f "CppDll.mak". +!MESSAGE +!MESSAGE You can specify a configuration when running NMAKE +!MESSAGE by defining the macro CFG on the command line. For example: +!MESSAGE +!MESSAGE NMAKE /f "CppDll.mak" CFG="CppDll - Win32 Debug" +!MESSAGE +!MESSAGE Possible choices for configuration are: +!MESSAGE +!MESSAGE "CppDll - Win32 Release" (based on "Win32 (x86) Dynamic-Link Library") +!MESSAGE "CppDll - Win32 Debug" (based on "Win32 (x86) Dynamic-Link Library") +!MESSAGE + +# Begin Project +# PROP AllowPerConfigDependencies 0 +# PROP Scc_ProjName "" +# PROP Scc_LocalPath "" +CPP=cl.exe +MTL=midl.exe +RSC=rc.exe + +!IF "$(CFG)" == "CppDll - Win32 Release" + +# PROP BASE Use_MFC 0 +# PROP BASE Use_Debug_Libraries 0 +# PROP BASE Output_Dir "Release" +# PROP BASE Intermediate_Dir "Release" +# PROP BASE Target_Dir "" +# PROP Use_MFC 0 +# PROP Use_Debug_Libraries 0 +# PROP Output_Dir "Release" +# PROP Intermediate_Dir "Release" +# PROP Target_Dir "" +# ADD BASE CPP /nologo /MT /W3 /GX /O2 /D "WIN32" /D "NDEBUG" /D "_WINDOWS" /D "_MBCS" /D "_USRDLL" /D "CPPDLL_EXPORTS" /YX /FD /c +# ADD CPP /nologo /MT /W3 /GX /O2 /D "WIN32" /D "NDEBUG" /D "_WINDOWS" /D "_MBCS" /D "_USRDLL" /D "CPPDLL_EXPORTS" /YX /FD /c +# ADD BASE MTL /nologo /D "NDEBUG" /mktyplib203 /win32 +# ADD MTL /nologo /D "NDEBUG" /mktyplib203 /win32 +# ADD BASE RSC /l 0x419 /d "NDEBUG" +# ADD RSC /l 0x419 /d "NDEBUG" +BSC32=bscmake.exe +# ADD BASE BSC32 /nologo +# ADD BSC32 /nologo +LINK32=link.exe +# ADD BASE LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /dll /machine:I386 +# ADD LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /dll /machine:I386 + +!ELSEIF "$(CFG)" == "CppDll - Win32 Debug" + +# PROP BASE Use_MFC 0 +# PROP BASE Use_Debug_Libraries 1 +# PROP BASE Output_Dir "Debug" +# PROP BASE Intermediate_Dir "Debug" +# PROP BASE Target_Dir "" +# PROP Use_MFC 0 +# PROP Use_Debug_Libraries 1 +# PROP Output_Dir "Debug" +# PROP Intermediate_Dir "Debug" +# PROP Target_Dir "" +# ADD BASE CPP /nologo /MTd /W3 /Gm /GX /ZI /Od /D "WIN32" /D "_DEBUG" /D "_WINDOWS" /D "_MBCS" /D "_USRDLL" /D "CPPDLL_EXPORTS" /YX /FD /GZ /c +# ADD CPP /nologo /MTd /W3 /Gm /GX /ZI /Od /D "WIN32" /D "_DEBUG" /D "_WINDOWS" /D "_MBCS" /D "_USRDLL" /D "CPPDLL_EXPORTS" /YX /FD /GZ /c +# ADD BASE MTL /nologo /D "_DEBUG" /mktyplib203 /win32 +# ADD MTL /nologo /D "_DEBUG" /mktyplib203 /win32 +# ADD BASE RSC /l 0x419 /d "_DEBUG" +# ADD RSC /l 0x419 /d "_DEBUG" +BSC32=bscmake.exe +# ADD BASE BSC32 /nologo +# ADD BSC32 /nologo +LINK32=link.exe +# ADD BASE LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /dll /debug /machine:I386 /pdbtype:sept +# ADD LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /dll /debug /machine:I386 /pdbtype:sept + +!ENDIF + +# Begin Target + +# Name "CppDll - Win32 Release" +# Name "CppDll - Win32 Debug" +# Begin Group "Source Files" + +# PROP Default_Filter "cpp;c;cxx;rc;def;r;odl;idl;hpj;bat" +# Begin Source File + +SOURCE=.\cppdll.cpp +# End Source File +# Begin Source File + +SOURCE=.\cppdll.def +# End Source File +# End Group +# Begin Group "Header Files" + +# PROP Default_Filter "h;hpp;hxx;hm;inl" +# Begin Source File + +SOURCE=.\cppdll.h +# End Source File +# End Group +# Begin Group "Resource Files" + +# PROP Default_Filter "ico;cur;bmp;dlg;rc2;rct;bin;rgs;gif;jpg;jpeg;jpe" +# End Group +# End Target +# End Project diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/PaxInvoke/CppDll/CppDll/CppDll.dsw b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/PaxInvoke/CppDll/CppDll/CppDll.dsw new file mode 100644 index 0000000..f0c62b4 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/PaxInvoke/CppDll/CppDll/CppDll.dsw @@ -0,0 +1,29 @@ +Microsoft Developer Studio Workspace File, Format Version 6.00 +# WARNING: DO NOT EDIT OR DELETE THIS WORKSPACE FILE! + +############################################################################### + +Project: "CppDll"=.\CppDll.dsp - Package Owner=<4> + +Package=<5> +{{{ +}}} + +Package=<4> +{{{ +}}} + +############################################################################### + +Global: + +Package=<5> +{{{ +}}} + +Package=<3> +{{{ +}}} + +############################################################################### + diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/PaxInvoke/CppDll/CppDll/CppDll.ncb b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/PaxInvoke/CppDll/CppDll/CppDll.ncb new file mode 100644 index 0000000..bab469d Binary files /dev/null and b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/PaxInvoke/CppDll/CppDll/CppDll.ncb differ diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/PaxInvoke/CppDll/CppDll/CppDll.opt b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/PaxInvoke/CppDll/CppDll/CppDll.opt new file mode 100644 index 0000000..2493e4c Binary files /dev/null and b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/PaxInvoke/CppDll/CppDll/CppDll.opt differ diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/PaxInvoke/CppDll/CppDll/CppDll.plg b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/PaxInvoke/CppDll/CppDll/CppDll.plg new file mode 100644 index 0000000..b79ed00 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/PaxInvoke/CppDll/CppDll/CppDll.plg @@ -0,0 +1,34 @@ + + +
+
Build Log

+

+--------------------Configuration: CppDll - Win32 Debug--------------------
+

+
Command Lines

+Creating temporary file "C:\DOCUME~1\ALEXAN~1\LOCALS~1\Temp\RSP88.tmp" with contents
+[
+/nologo /MTd /W3 /Gm /GX /ZI /Od /D "WIN32" /D "_DEBUG" /D "_WINDOWS" /D "_MBCS" /D "_USRDLL" /D "CPPDLL_EXPORTS" /Fp"Debug/CppDll.pch" /YX /Fo"Debug/" /Fd"Debug/" /FD /GZ /c 
+"C:\hot\Assem\demos\CallRoutineEx\CppDll\CppDll\cppdll.cpp"
+]
+Creating command line "cl.exe @C:\DOCUME~1\ALEXAN~1\LOCALS~1\Temp\RSP88.tmp" 
+Creating temporary file "C:\DOCUME~1\ALEXAN~1\LOCALS~1\Temp\RSP89.tmp" with contents
+[
+kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /dll /incremental:yes /pdb:"Debug/CppDll.pdb" /debug /machine:I386 /def:".\cppdll.def" /out:"Debug/CppDll.dll" /implib:"Debug/CppDll.lib" /pdbtype:sept 
+.\Debug\cppdll.obj
+]
+Creating command line "link.exe @C:\DOCUME~1\ALEXAN~1\LOCALS~1\Temp\RSP89.tmp"
+
Output Window

+Compiling...
+cppdll.cpp
+Linking...
+LINK : LNK6004: Debug/CppDll.dll not found or not built by the last incremental link; performing full link
+   Creating library Debug/CppDll.lib and object Debug/CppDll.exp
+
+
+
+
Results

+CppDll.dll - 0 error(s), 0 warning(s)
+
+ + diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/PaxInvoke/CppDll/CppDll/cppdll.cpp b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/PaxInvoke/CppDll/CppDll/cppdll.cpp new file mode 100644 index 0000000..2c48f59 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/PaxInvoke/CppDll/CppDll/cppdll.cpp @@ -0,0 +1,66 @@ +#include "cppdll.h" + +//prevent function name from being mangled +extern "C" + +int __fastcall cube(int num) +{ + return num * num * num; +} + +double __fastcall arr(double a[], int i, int j, float f) +{ + return a[0] + a[1] + i + j + f; +} + +char __fastcall ret_char(char * s) +{ + return s[0]; +} + +MyPoint __fastcall ret_struct(int x, int y, int z) +{ + MyPoint p; + p.x = x; + p.y = y; + p.z = z; + return p; +} + +MyPoint2 __fastcall ret_struct2(int x, int y) +{ + MyPoint2 p; + p.x = x; + p.y = y; + return p; +} + +MyPoint __fastcall pass_struct(const MyPoint & q) +{ + MyPoint p; + p.x = q.x; + p.y = q.y; + p.z = q.z; + return p; +} + +MyPoint __fastcall pass_struct_byval(MyPoint q) +{ + MyPoint p; + p.x = q.x; + p.y = q.y; + p.z = q.z; + return p; +} + +double __fastcall dcube(double num) +{ + return num * num * num; +} + +float __fastcall fcube(float num) +{ + return num * num * num; +} + + diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/PaxInvoke/CppDll/CppDll/cppdll.def b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/PaxInvoke/CppDll/CppDll/cppdll.def new file mode 100644 index 0000000..8cbfb6b --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/PaxInvoke/CppDll/CppDll/cppdll.def @@ -0,0 +1,10 @@ +EXPORTS + cube + arr + ret_char + ret_struct + ret_struct2 + pass_struct + pass_struct_byval + dcube + fcube diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/PaxInvoke/CppDll/CppDll/cppdll.h b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/PaxInvoke/CppDll/CppDll/cppdll.h new file mode 100644 index 0000000..515b5ae --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/PaxInvoke/CppDll/CppDll/cppdll.h @@ -0,0 +1,34 @@ +/* + this header is not required for this dll + to compile; but is required for the app + that will use this dll +*/ + +#ifndef CPPDLL_H +#define CPPDLL_H + +struct MyPoint +{ + int x; + int y; + int z; +}; + +struct MyPoint2 +{ + int x; + int y; +}; + +extern "C" +int __fastcall cube(int num); +double __fastcall arr(double a[], int i, int j, float f); +char __fastcall ret_char(char * s); +MyPoint __fastcall ret_struct(int x, int y, int z); +MyPoint2 __fastcall ret_struct2(int x, int y); +MyPoint __fastcall pass_struct(const MyPoint & q); +MyPoint __fastcall pass_struct_byval(MyPoint q); +double __fastcall dcube(double num); +float __fastcall fcube(float num); + +#endif //CPPDLL_H \ No newline at end of file diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/PaxInvoke/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/PaxInvoke/Project1.dpr new file mode 100644 index 0000000..513a1dd --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/PaxInvoke/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/PaxInvoke/Project1.res b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/PaxInvoke/Project1.res new file mode 100644 index 0000000..3adc036 Binary files /dev/null and b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/PaxInvoke/Project1.res differ diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/PaxInvoke/Unit1.dfm b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/PaxInvoke/Unit1.dfm new file mode 100644 index 0000000..c5a8244 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/PaxInvoke/Unit1.dfm @@ -0,0 +1,111 @@ +object Form1: TForm1 + Left = 192 + Top = 114 + Width = 215 + Height = 323 + Caption = 'Call routine demo' + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + PixelsPerInch = 96 + TextHeight = 13 + object Button1: TButton + Left = 32 + Top = 45 + Width = 121 + Height = 25 + Caption = 'Invokel script function' + TabOrder = 0 + OnClick = Button1Click + end + object Button2: TButton + Left = 32 + Top = 75 + Width = 121 + Height = 25 + Caption = 'Call host function' + TabOrder = 1 + OnClick = Button2Click + end + object Button3: TButton + Left = 32 + Top = 105 + Width = 121 + Height = 25 + Caption = 'Call host method' + TabOrder = 2 + OnClick = Button3Click + end + object Button4: TButton + Left = 32 + Top = 134 + Width = 121 + Height = 25 + Caption = 'Test dynamic array' + TabOrder = 3 + OnClick = Button4Click + end + object Button5: TButton + Left = 32 + Top = 159 + Width = 121 + Height = 25 + Caption = 'Test sets' + TabOrder = 4 + OnClick = Button5Click + end + object Button6: TButton + Left = 32 + Top = 184 + Width = 121 + Height = 25 + Caption = 'Test C++ Dll' + TabOrder = 5 + OnClick = Button6Click + end + object Button7: TButton + Left = 32 + Top = 210 + Width = 121 + Height = 25 + Caption = 'Test SAFECALL' + TabOrder = 6 + OnClick = Button7Click + end + object Button8: TButton + Left = 32 + Top = 239 + Width = 120 + Height = 25 + Caption = 'Test interface' + TabOrder = 7 + OnClick = Button8Click + end + object PaxCompiler1: TPaxCompiler + Alignment = 1 + DebugMode = False + Left = 24 + Top = 8 + end + object PaxProgram1: TPaxProgram + Console = False + OnPrintEvent = PaxProgram1PrintEvent + Left = 88 + Top = 8 + end + object PaxInvoke1: TPaxInvoke + Left = 128 + Top = 16 + end + object PaxBasicLanguage1: TPaxBasicLanguage + ExplicitOff = False + CompleteBooleanEval = False + UseFWArrays = True + Left = 56 + Top = 8 + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/PaxInvoke/Unit1.pas b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/PaxInvoke/Unit1.pas new file mode 100644 index 0000000..615ef6a --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/PaxInvoke/Unit1.pas @@ -0,0 +1,368 @@ +unit Unit1; + +{$O-} +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, PaxCompiler, PaxInvoke, PaxProgram, PaxRegister, + PaxBasicLanguage, PaxRunner; +type + TForm1 = class(TForm) + PaxCompiler1: TPaxCompiler; + PaxProgram1: TPaxProgram; + Button1: TButton; + Button2: TButton; + Button3: TButton; + PaxInvoke1: TPaxInvoke; + Button4: TButton; + Button5: TButton; + Button6: TButton; + Button7: TButton; + Button8: TButton; + PaxBasicLanguage1: TPaxBasicLanguage; + procedure Button1Click(Sender: TObject); + procedure Button2Click(Sender: TObject); + procedure Button3Click(Sender: TObject); + procedure Button4Click(Sender: TObject); + procedure Button5Click(Sender: TObject); + procedure Button6Click(Sender: TObject); + procedure Button7Click(Sender: TObject); + procedure Button8Click(Sender: TObject); + procedure PaxProgram1PrintEvent(Sender: TPaxRunner; const Text: string); + private + { Private declarations } + public + function MyHostMethod(const X, Y: ShortString; Z: Integer): String; + function Safe(X, Y: Integer): HResult; safecall; + { Public declarations } + end; + +type + ITest = interface + ['{E7AA427A-0F4D-4A96-A914-FAB1CA336337}'] + procedure Proc(const S: String); + end; + + TTest = class(TInterfacedObject, ITest) + public + procedure Proc(const S: String); + end; + +var + Form1: TForm1; + +implementation + +{$R *.dfm} + +uses + IMPORT_SysUtils; + +procedure TTest.Proc(const S: String); +begin + ShowMessage(S); +end; + +procedure TForm1.Button1Click(Sender: TObject); +var + H_MyFunc: Integer; + I: Integer; + P: Pointer; +begin +{$O-} + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxBasicLanguage1); + + PaxCompiler1.AddModule('1', PaxBasicLanguage1.LanguageName); + PaxCompiler1.AddCode('1', 'Imports SysUtils'); + PaxCompiler1.AddCode('1', 'Function MyFunc(U As Integer, V As Integer) As Decimal'); + PaxCompiler1.AddCode('1', ' Try'); + PaxCompiler1.AddCode('1', ' Return U / V'); + PaxCompiler1.AddCode('1', ' Catch E As Exception'); + PaxCompiler1.AddCode('1', ' print E.Message'); + PaxCompiler1.AddCode('1', ' Return 7'); + PaxCompiler1.AddCode('1', ' End Try'); + PaxCompiler1.AddCode('1', 'End Function'); + + if PaxCompiler1.Compile(PaxProgram1) then + begin + H_MyFunc := PaxCompiler1.GetHandle(0, 'MyFunc', true); + + P := PaxProgram1.GetAddress(H_MyFunc); // get address of script-defined function + + PaxInvoke1.Address := P; + PaxInvoke1.This := nil; // this is not a method, but global function. + PaxInvoke1.ClearArguments; + PaxInvoke1.AddArgAsInteger(8); + PaxInvoke1.AddArgAsInteger(2); // set it to '0' to try exeption handling + PaxInvoke1.SetResultAsCurrency; + PaxInvoke1.CallConv := _ccREGISTER; + + PaxProgram1.SetEntryPoint(PaxInvoke1); + PaxProgram1.Run; + + ShowMessage(CurrToStr(Currency(PaxInvoke1.GetResultPtr^))); + end + else + for I:=0 to PaxCompiler1.ErrorCount do + ShowMessage(PaxCompiler1.ErrorMessage[I]); +end; + +procedure TForm1.Button2Click(Sender: TObject); + +type + TCharRec = record + X, Y: Char; + end; + +function MyHostFunc(const U, V: TCharRec): String; stdcall; +begin + result := U.X + V.Y; +end; + +var + R: TCharRec; + S: String; +begin + R.X := 'a'; + R.Y := 'b'; + + PaxInvoke1.Address := @ MyHostFunc; + PaxInvoke1.This := nil; // this is not a method + PaxInvoke1.ClearArguments; + PaxInvoke1.AddArgAsRecord(@R, SizeOf(R)); + PaxInvoke1.AddArgAsRecord(@R, SizeOf(R)); + PaxInvoke1.SetResultAsAnsiString; + PaxInvoke1.CallConv := _ccSTDCALL; + PaxInvoke1.CallHost; // call host-defined function + S := String(PaxInvoke1.GetResultPtr^); + ShowMessage(S); + + PaxInvoke1.ClearResult; +end; + +function TForm1.MyHostMethod(const X, Y: ShortString; Z: Integer): String; +begin + result := X + Y + IntToStr(Z); +end; + +procedure TForm1.PaxProgram1PrintEvent(Sender: TPaxRunner; const Text: string); +begin + ShowMessage(Text); +end; + +procedure TForm1.Button3Click(Sender: TObject); +begin + PaxInvoke1.Address := @ TForm1.MyHostMethod; + PaxInvoke1.This := Self; // we call a method + PaxInvoke1.ClearArguments; + PaxInvoke1.AddArgAsShortString('xyz'); + PaxInvoke1.AddArgAsShortString('uv'); + PaxInvoke1.AddArgAsInteger(8); + PaxInvoke1.SetResultAsAnsiString; + PaxInvoke1.CallConv := _ccREGISTER; + PaxInvoke1.CallHost; + ShowMessage(String(PaxInvoke1.GetResultPtr^)); + + PaxInvoke1.ClearResult; +end; + +procedure TForm1.Button4Click(Sender: TObject); + +procedure DynArrayProc(const A: array of String); cdecl; +begin + ShowMessage(A[0] + A[1]); +end; + +var + A: array of string; +begin + SetLength(A, 2); + A[0] := 'abc'; + A[1] := 'pqr'; + + PaxInvoke1.Address := @ DynArrayProc; + PaxInvoke1.This := nil; // this is not a method + PaxInvoke1.ClearArguments; + PaxInvoke1.AddArgAsDynArray(A); + PaxInvoke1.SetResultAsVoid; + PaxInvoke1.CallConv := _ccCDECL; + PaxInvoke1.CallHost; // call host-defined function +end; + +procedure TForm1.Button5Click(Sender: TObject); + +type + TSetType = set of 'a'..'z'; + +procedure SetProc(S: TSetType); +begin + if 'c' in S then + ShowMessage('ok'); +end; + +var + S: TSetType; +begin + S := ['b'..'d']; + + PaxInvoke1.Address := @ SetProc; + PaxInvoke1.This := nil; // this is not a method + PaxInvoke1.ClearArguments; + PaxInvoke1.AddArgAsSet(@S, SizeOf(S)); + PaxInvoke1.SetResultAsVoid; + PaxInvoke1.CallConv := _ccREGISTER; + PaxInvoke1.CallHost; // call host-defined function +end; + +procedure TForm1.Button6Click(Sender: TObject); +type + TMyPoint = record + x, y, z: Integer; + end; + TMyPoint2 = record + x, y: Integer; + end; +var + a: array[0..5] of Double; + r: TMyPoint; + r2: TMyPoint2; +begin + a[0] := 5.3; + a[1] := 10.1; + + PaxInvoke1.This := nil; // this is not a method + PaxInvoke1.CallConv := _ccMSFASTCALL; + + PaxInvoke1.LoadAddress('CppDll.dll', 'cube'); + PaxInvoke1.ClearArguments; + PaxInvoke1.AddArgAsInteger(2); + PaxInvoke1.SetResultAsInteger; + PaxInvoke1.CallHost; // call host-defined function + ShowMessage(IntToStr(Integer(PaxInvoke1.GetResultPtr^))); + + PaxInvoke1.LoadAddress('CppDll.dll', 'arr'); + PaxInvoke1.ClearArguments; + PaxInvoke1.AddArgAsPointer(@a); + PaxInvoke1.AddArgAsInteger(2); + PaxInvoke1.AddArgAsInteger(3); + PaxInvoke1.AddArgAsSingle(6.8); + PaxInvoke1.SetResultAsDouble; + PaxInvoke1.CallHost; // call host-defined function + ShowMessage(FloatToStr(Double(PaxInvoke1.GetResultPtr^))); + + PaxInvoke1.LoadAddress('CppDll.dll', 'ret_char'); + PaxInvoke1.ClearArguments; + PaxInvoke1.AddArgAsPChar('abc'); + PaxInvoke1.SetResultAsChar; + PaxInvoke1.CallHost; // call host-defined function + ShowMessage(Char(PaxInvoke1.GetResultPtr^)); + + PaxInvoke1.LoadAddress('CppDll.dll', 'ret_struct'); + PaxInvoke1.ClearArguments; + PaxInvoke1.AddArgAsInteger(2); + PaxInvoke1.AddArgAsInteger(3); + PaxInvoke1.AddArgAsInteger(5); + PaxInvoke1.SetResultAsRecord(SizeOf(TMyPoint)); + PaxInvoke1.CallHost; // call host-defined function + r := TMyPoint(PaxInvoke1.GetResultPtr^); + ShowMessage(IntToStr(r.x) + ' ' + IntToStr(r.y) + ' ' + IntToStr(r.z)); + + PaxInvoke1.LoadAddress('CppDll.dll', 'ret_struct2'); + PaxInvoke1.ClearArguments; + PaxInvoke1.AddArgAsInteger(2); + PaxInvoke1.AddArgAsInteger(3); + PaxInvoke1.SetResultAsRecord(SizeOf(TMyPoint2)); + PaxInvoke1.CallHost; // call host-defined function + r2 := TMyPoint2(PaxInvoke1.GetResultPtr^); + ShowMessage(IntToStr(r.x) + ' ' + IntToStr(r.y)); + + PaxInvoke1.LoadAddress('CppDll.dll', 'pass_struct'); + PaxInvoke1.ClearArguments; + PaxInvoke1.AddArgAsPointer(@ r); + PaxInvoke1.SetResultAsRecord(SizeOf(TMyPoint)); + PaxInvoke1.CallHost; // call host-defined function + r := TMyPoint(PaxInvoke1.GetResultPtr^); + ShowMessage(IntToStr(r.x) + ' ' + IntToStr(r.y) + ' ' + IntToStr(r.z)); + + PaxInvoke1.LoadAddress('CppDll.dll', 'pass_struct_byval'); + PaxInvoke1.ClearArguments; + PaxInvoke1.AddArgAsRecordByVal(r, SizeOf(r)); + PaxInvoke1.SetResultAsRecord(SizeOf(TMyPoint)); + PaxInvoke1.CallHost; // call host-defined function + r := TMyPoint(PaxInvoke1.GetResultPtr^); + ShowMessage(IntToStr(r.x) + ' ' + IntToStr(r.y) + ' ' + IntToStr(r.z)); + + PaxInvoke1.LoadAddress('CppDll.dll', 'dcube'); + PaxInvoke1.ClearArguments; + PaxInvoke1.AddArgAsDouble(2); + PaxInvoke1.SetResultAsDouble; + PaxInvoke1.CallHost; // call host-defined function + ShowMessage(FloatToStr(Double(PaxInvoke1.GetResultPtr^))); +end; + +function TForm1.Safe(X, Y: Integer): HResult; safecall; +begin + result := X + Y; +end; + +procedure TForm1.Button7Click(Sender: TObject); + +function P(X, Y: Currency): String; safecall; +begin + result := CurrToStr(X + Y); +end; + +begin + PaxInvoke1.This := nil; // this is not a method + PaxInvoke1.CallConv := _ccSAFECALL; + PaxInvoke1.Address := @P; + PaxInvoke1.ClearArguments; + PaxInvoke1.AddArgAsCurrency(2.2); + PaxInvoke1.AddArgAsCurrency(3.4); + PaxInvoke1.SetResultAsAnsiString; + PaxInvoke1.CallHost; // call host-defined function + ShowMessage(String(PaxInvoke1.GetResultPtr^)); + PaxInvoke1.ClearResult; + + PaxInvoke1.This := Self; // this is a method + PaxInvoke1.CallConv := _ccSAFECALL; + PaxInvoke1.Address := @TForm1.Safe; + PaxInvoke1.ClearArguments; + PaxInvoke1.AddArgAsInteger(2); + PaxInvoke1.AddArgAsInteger(3); + PaxInvoke1.SetResultAsInteger; + PaxInvoke1.CallHost; // call host-defined function + ShowMessage(IntToStr(Integer(PaxInvoke1.GetResultPtr^))); +end; + +procedure TForm1.Button8Click(Sender: TObject); + +function GetIntf(I: ITest): ITest; +begin + if Assigned(I) then + result := I + else + result := TTest.Create; +end; + +var + I, J: ITest; +begin + J := TTest.Create; + + PaxInvoke1.This := nil; // this is not a method + PaxInvoke1.CallConv := _ccREGISTER; + PaxInvoke1.Address := @GetIntf; + PaxInvoke1.ClearArguments; + PaxInvoke1.AddArgAsInterface(J); + PaxInvoke1.SetResultAsInterface; + PaxInvoke1.CallHost; // call host-defined function + IUnknown(I) := IUnknown(PaxInvoke1.GetResultPtr^); + I.Proc('hello'); + + PaxInvoke1.ClearResult; +end; + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/RTTI/1/IMPORT_TypInfo.pas b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/RTTI/1/IMPORT_TypInfo.pas new file mode 100644 index 0000000..4767808 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/RTTI/1/IMPORT_TypInfo.pas @@ -0,0 +1,703 @@ +unit IMPORT_TypInfo; +interface + +procedure Register_TypInfo; + +implementation + +uses + Variants, + SysUtils, + TypInfo, + PaxRegister; +{ + Result := RegisterEnumType (H, 'TTypeKind'); + RegisterEnumValue (Result, 'tkUnknown', 0); + RegisterEnumValue (Result, 'tkInteger', 1); + RegisterEnumValue (Result, 'tkChar', 2); + RegisterEnumValue (Result, 'tkEnumeration', 3); + RegisterEnumValue (Result, 'tkFloat', 4); + RegisterEnumValue (Result, 'tkString', 5); + RegisterEnumValue (Result, 'tkSet', 6); + RegisterEnumValue (Result, 'tkClass', 7); + RegisterEnumValue (Result, 'tkMethod', 8); + RegisterEnumValue (Result, 'tkWChar', 9); + RegisterEnumValue (Result, 'tkLString', 10); + RegisterEnumValue (Result, 'tkWString', 11); + RegisterEnumValue (Result, 'tkVariant', 12); + RegisterEnumValue (Result, 'tkArray', 13); + RegisterEnumValue (Result, 'tkRecord', 14); + RegisterEnumValue (Result, 'tkInterface', 15); + RegisterEnumValue (Result, 'tkInt64', 16); + RegisterEnumValue (Result, 'tkDynArray', 17); +end; + +//==================================================================== +// TPublishableVariantType +//==================================================================== + + +//-------------------------------------------------------------------- +// RegisterClass_TPublishableVariantType +//-------------------------------------------------------------------- + +function RegisterClass_TPublishableVariantType (H: integer): integer; +begin + Result := RegisterClassType (H, TPublishableVariantType); + + RegisterHeader (Result, + 'function GetProperty (var Dest: TVarData; const V: TVarData; const Name: String): Boolean; override;', + @TPublishableVariantType.GetProperty); + RegisterHeader (Result, + 'function SetProperty (const V: TVarData; const Name: String; const Value: TVarData): Boolean; override;', + @TPublishableVariantType.SetProperty); +end; + +//-------------------------------------------------------------------- +// RegisterSet_TTypeKinds +//-------------------------------------------------------------------- + +function RegisterSet_TTypeKinds (H: integer): integer; +begin +// Result := RegisterSetType (H, 'TTypeKinds', T); +end; + +//-------------------------------------------------------------------- +// RegisterEnumerated_TOrdType +//-------------------------------------------------------------------- + +function RegisterEnumerated_TOrdType (H: integer): integer; +begin + Result := RegisterEnumType (H, 'TOrdType'); + RegisterEnumValue (Result, 'otSByte', 0); + RegisterEnumValue (Result, 'otUByte', 1); + RegisterEnumValue (Result, 'otSWord', 2); + RegisterEnumValue (Result, 'otUWord', 3); + RegisterEnumValue (Result, 'otSLong', 4); + RegisterEnumValue (Result, 'otULong', 5); +end; + +//-------------------------------------------------------------------- +// RegisterEnumerated_TFloatType +//-------------------------------------------------------------------- + +function RegisterEnumerated_TFloatType (H: integer): integer; +begin + Result := RegisterEnumType (H, 'TFloatType'); + RegisterEnumValue (Result, 'ftSingle', 0); + RegisterEnumValue (Result, 'ftDouble', 1); + RegisterEnumValue (Result, 'ftExtended', 2); + RegisterEnumValue (Result, 'ftComp', 3); + RegisterEnumValue (Result, 'ftCurr', 4); +end; + +//-------------------------------------------------------------------- +// RegisterEnumerated_TMethodKind +//-------------------------------------------------------------------- + +function RegisterEnumerated_TMethodKind (H: integer): integer; +begin + Result := RegisterEnumType (H, 'TMethodKind'); + RegisterEnumValue (Result, 'mkProcedure', 0); + RegisterEnumValue (Result, 'mkFunction', 1); + RegisterEnumValue (Result, 'mkConstructor', 2); + RegisterEnumValue (Result, 'mkDestructor', 3); + RegisterEnumValue (Result, 'mkClassProcedure', 4); + RegisterEnumValue (Result, 'mkClassFunction', 5); + RegisterEnumValue (Result, 'mkSafeProcedure', 6); + RegisterEnumValue (Result, 'mkSafeFunction', 7); +end; + +//-------------------------------------------------------------------- +// RegisterEnumerated_TParamFlag +//-------------------------------------------------------------------- + +function RegisterEnumerated_TParamFlag (H: integer): integer; +begin + Result := RegisterEnumType (H, 'TParamFlag'); + RegisterEnumValue (Result, 'pfVar', 0); + RegisterEnumValue (Result, 'pfConst', 1); + RegisterEnumValue (Result, 'pfArray', 2); + RegisterEnumValue (Result, 'pfAddress', 3); + RegisterEnumValue (Result, 'pfReference', 4); + RegisterEnumValue (Result, 'pfOut', 5); + Result := RegisterSetType (H, 'TParamFlags', T); +end; + +function RegisterSet_TParamFlagsBase (H: integer): integer; +var + T: integer; +begin + T := LookupTypeID ('TParamFlag'); + if T = 0 then + Raise ENNPaxFormater.Create ('Invalid type name: TParamFlag'); + Result := RegisterSetType (H, 'TParamFlagsBase', T); +end; + +//-------------------------------------------------------------------- +// RegisterEnumerated_TIntfFlag +//-------------------------------------------------------------------- + +function RegisterEnumerated_TIntfFlag (H: integer): integer; +begin + Result := RegisterEnumType (H, 'TIntfFlag'); + RegisterEnumValue (Result, 'ifHasGuid', 0); + RegisterEnumValue (Result, 'ifDispInterface', 1); + RegisterEnumValue (Result, 'ifDispatch', 2); +end; + +//-------------------------------------------------------------------- +// RegisterSet_TIntfFlags +//-------------------------------------------------------------------- + +function RegisterSet_TIntfFlags (H: integer): integer; +var + T: integer; +begin + T := LookupTypeID ('TIntfFlag'); + if T = 0 then + Raise ENNPaxFormater.Create ('Invalid type name: TIntfFlag'); + Result := RegisterSetType (H, 'TIntfFlags', T); +end; + +//-------------------------------------------------------------------- +// RegisterSet_TIntfFlagsBase +//-------------------------------------------------------------------- + +function RegisterSet_TIntfFlagsBase (H: integer): integer; +var + T: integer; +begin + T := LookupTypeID ('TIntfFlag'); + if T = 0 then + Raise ENNPaxFormater.Create ('Invalid type name: TIntfFlag'); + Result := RegisterSetType (H, 'TIntfFlagsBase', T); +end; + +//-------------------------------------------------------------------- +// RegisterPointer_PPTypeInfo +//-------------------------------------------------------------------- + +function RegisterPointer_PPTypeInfo (H: integer): integer; +var + T: Integer; +begin + T := LookupTypeID ('PTypeInfo'); + if T = 0 then + T := RegisterSomeType (H, 'PTypeInfo'); + Result := RegisterPointerType (H, 'PPTypeInfo', T); +end; + +//-------------------------------------------------------------------- +// RegisterPointer_PTypeInfo +//-------------------------------------------------------------------- + +function RegisterPointer_PTypeInfo (H: integer): integer; +var + T: Integer; +begin + T := LookupTypeID ('TTypeInfo'); + if T = 0 then + T := RegisterSomeType (H, 'TTypeInfo'); + Result := RegisterPointerType (H, 'PTypeInfo', T); +end; + +//-------------------------------------------------------------------- +// RegisterRecord_TTypeInfo +//-------------------------------------------------------------------- + +function RegisterRecord_TTypeInfo (H: integer): integer; +var + T: integer; +begin + Result := RegisterRecordType (H, 'TTypeInfo', False); + T := LookupTypeID ('TTypeKind'); + if T = 0 then + Raise ENNPaxFormater.Create ('Invalid type name: TTypeKind'); + RegisterRecordTypeField (Result, 'Kind', T, 0); + T := _typeSHORTSTRING; + RegisterRecordTypeField (Result, 'Name', T, 0); +end; + +//-------------------------------------------------------------------- +// RegisterPointer_PTypeData +//-------------------------------------------------------------------- + +function RegisterPointer_PTypeData (H: integer): integer; +var + T: Integer; +begin + T := LookupTypeID ('TTypeData'); + if T = 0 then + T := RegisterSomeType (H, 'TTypeData'); + Result := RegisterPointerType (H, 'PTypeData', T); +end; + +//-------------------------------------------------------------------- +// RegisterArray_fake_ParamList_18 +//-------------------------------------------------------------------- + +function RegisterArray_fake_ParamList_18 (H: integer): integer; +var + R,T: integer; +begin + R := RegisterTypeDeclaration (H, 'fake_ParamList_18_19 = 0..1023;'); + T := _typeCHAR; + Result := RegisterArrayType (H, 'fake_ParamList_18', R, T, False); +end; + +//-------------------------------------------------------------------- +// RegisterRecord_TTypeData +//-------------------------------------------------------------------- + +function RegisterRecord_TTypeData (H: integer): integer; +var + T: integer; +begin + Result := RegisterRecordType (H, 'TTypeData', False); + T := LookupTypeID ('TOrdType'); + if T = 0 then + Raise ENNPaxFormater.Create ('Invalid type name: TOrdType'); + RegisterVariantRecordTypeField (Result, 'OrdType', T, 02); + T := _typeINTEGER; + RegisterVariantRecordTypeField (Result, 'MinValue', T, 0102); + T := _typeINTEGER; + RegisterVariantRecordTypeField (Result, 'MaxValue', T, 0102); + T := LookupTypeID ('PPTypeInfo'); + if T = 0 then + Raise ENNPaxFormater.Create ('Invalid type name: PPTypeInfo'); + RegisterVariantRecordTypeField (Result, 'BaseType', T, 020102); + T := LookupTypeID ('ShortStringBase'); + if T = 0 then + Raise ENNPaxFormater.Create ('Invalid type name: ShortStringBase'); + RegisterVariantRecordTypeField (Result, 'NameList', T, 020102); + T := LookupTypeID ('ShortStringBase'); + if T = 0 then + Raise ENNPaxFormater.Create ('Invalid type name: ShortStringBase'); + RegisterVariantRecordTypeField (Result, 'EnumUnitName', T, 020102); + T := LookupTypeID ('PPTypeInfo'); + if T = 0 then + Raise ENNPaxFormater.Create ('Invalid type name: PPTypeInfo'); + RegisterVariantRecordTypeField (Result, 'CompType', T, 0202); + T := LookupTypeID ('TFloatType'); + if T = 0 then + Raise ENNPaxFormater.Create ('Invalid type name: TFloatType'); + RegisterVariantRecordTypeField (Result, 'FloatType', T, 03); + T := _typeBYTE; + RegisterVariantRecordTypeField (Result, 'MaxLength', T, 04); + T := LookupTypeID ('TClass'); + if T = 0 then + Raise ENNPaxFormater.Create ('Invalid type name: TClass'); + RegisterVariantRecordTypeField (Result, 'ClassType', T, 05); + T := LookupTypeID ('PPTypeInfo'); + if T = 0 then + Raise ENNPaxFormater.Create ('Invalid type name: PPTypeInfo'); + RegisterVariantRecordTypeField (Result, 'ParentInfo', T, 05); + T := _typeSMALLINT; + RegisterVariantRecordTypeField (Result, 'PropCount', T, 05); + T := LookupTypeID ('ShortStringBase'); + if T = 0 then + Raise ENNPaxFormater.Create ('Invalid type name: ShortStringBase'); + RegisterVariantRecordTypeField (Result, 'UnitName', T, 05); + T := LookupTypeID ('TMethodKind'); + if T = 0 then + Raise ENNPaxFormater.Create ('Invalid type name: TMethodKind'); + RegisterVariantRecordTypeField (Result, 'MethodKind', T, 06); + T := _typeBYTE; + RegisterVariantRecordTypeField (Result, 'ParamCount', T, 06); + T := RegisterArray_fake_ParamList_18 (H); + RegisterVariantRecordTypeField (Result, 'ParamList', T, 06); + T := LookupTypeID ('PPTypeInfo'); + if T = 0 then + Raise ENNPaxFormater.Create ('Invalid type name: PPTypeInfo'); + RegisterVariantRecordTypeField (Result, 'IntfParent', T, 07); + T := LookupTypeID ('TIntfFlagsBase'); + if T = 0 then + Raise ENNPaxFormater.Create ('Invalid type name: TIntfFlagsBase'); + RegisterVariantRecordTypeField (Result, 'IntfFlags', T, 07); + T := LookupTypeID ('TGUID'); + if T = 0 then + Raise ENNPaxFormater.Create ('Invalid type name: TGUID'); + RegisterVariantRecordTypeField (Result, 'Guid', T, 07); + T := LookupTypeID ('ShortStringBase'); + if T = 0 then + Raise ENNPaxFormater.Create ('Invalid type name: ShortStringBase'); + RegisterVariantRecordTypeField (Result, 'IntfUnit', T, 07); + T := _typeINT64; + RegisterVariantRecordTypeField (Result, 'MinInt64Value', T, 08); + RegisterVariantRecordTypeField (Result, 'MaxInt64Value', T, 08); + T := _typeINTEGER; + RegisterVariantRecordTypeField (Result, 'elSize', T, 09); + T := LookupTypeID ('PPTypeInfo'); + if T = 0 then + Raise ENNPaxFormater.Create ('Invalid type name: PPTypeInfo'); + RegisterVariantRecordTypeField (Result, 'elType', T, 09); + T := _typeINTEGER; + RegisterVariantRecordTypeField (Result, 'varType', T, 09); + T := LookupTypeID ('PPTypeInfo'); + if T = 0 then + Raise ENNPaxFormater.Create ('Invalid type name: PPTypeInfo'); + RegisterVariantRecordTypeField (Result, 'elType2', T, 09); + T := LookupTypeID ('ShortStringBase'); + if T = 0 then + Raise ENNPaxFormater.Create ('Invalid type name: ShortStringBase'); + RegisterVariantRecordTypeField (Result, 'DynUnitName', T, 09); +end; + +//-------------------------------------------------------------------- +// RegisterRecord_fake_PropList_31 +//-------------------------------------------------------------------- + +function RegisterRecord_fake_PropList_31 (H: integer): integer; +var + T: integer; +begin + Result := RegisterRecordType (H, 'fake_PropList_31', False); +end; + +//-------------------------------------------------------------------- +// RegisterRecord_TPropData +//-------------------------------------------------------------------- + +function RegisterRecord_TPropData (H: integer): integer; +var + T: integer; +begin + Result := RegisterRecordType (H, 'TPropData', False); + T := _typeWORD; + RegisterRecordTypeField (Result, 'PropCount', T, 0); + T := RegisterRecord_fake_PropList_31 (H); + RegisterRecordTypeField (Result, 'PropList', T, 0); +end; + +//-------------------------------------------------------------------- +// RegisterPointer_PPropInfo +//-------------------------------------------------------------------- + +function RegisterPointer_PPropInfo (H: integer): integer; +var + T: Integer; +begin + T := LookupTypeID ('TPropInfo'); + if T = 0 then + T := RegisterSomeType (H, 'TPropInfo'); + Result := RegisterPointerType (H, 'PPropInfo', T); +end; + +//-------------------------------------------------------------------- +// RegisterRecord_TPropInfo +//-------------------------------------------------------------------- + +function RegisterRecord_TPropInfo (H: integer): integer; +var + T: integer; +begin + Result := RegisterRecordType (H, 'TPropInfo', False); + T := LookupTypeID ('PPTypeInfo'); + if T = 0 then + Raise ENNPaxFormater.Create ('Invalid type name: PPTypeInfo'); + RegisterRecordTypeField (Result, 'PropType', T, 0); + T := _typePOINTER; + RegisterRecordTypeField (Result, 'GetProc', T, 0); + T := _typePOINTER; + RegisterRecordTypeField (Result, 'SetProc', T, 0); + T := _typePOINTER; + RegisterRecordTypeField (Result, 'StoredProc', T, 0); + T := _typeINTEGER; + RegisterRecordTypeField (Result, 'Index', T, 0); + T := _typeINTEGER; + RegisterRecordTypeField (Result, 'Default', T, 0); + T := _typeSMALLINT; + RegisterRecordTypeField (Result, 'NameIndex', T, 0); + T := _typeSHORTSTRING; + RegisterRecordTypeField (Result, 'Name', T, 0); +end; + +//-------------------------------------------------------------------- +// RegisterProcedural_TPropInfoProc +//-------------------------------------------------------------------- + +function RegisterProcedural_TPropInfoProc (H: integer): integer; +begin + Result := RegisterHeader (H, 'procedure fake_TPropInfoProc_40 (PropInfo: PPropInfo);', Nil); + Result := RegisterEventType (H, 'TPropInfoProc', Result); +end; + +//-------------------------------------------------------------------- +// RegisterPointer_PPropList +//-------------------------------------------------------------------- + +function RegisterPointer_PPropList (H: integer): integer; +var + T: Integer; +begin + T := LookupTypeID ('TPropList'); + if T = 0 then + T := RegisterSomeType (H, 'TPropList'); + Result := RegisterPointerType (H, 'PPropList', T); +end; + +//-------------------------------------------------------------------- +// RegisterArray_TPropList +//-------------------------------------------------------------------- + +function RegisterArray_TPropList (H: integer): integer; +var + R,T: integer; +begin + R := RegisterTypeDeclaration (H, 'fake_TPropList_41 = 0..16379;'); + T := LookupTypeID ('PPropInfo'); + if T = 0 then + Raise ENNPaxFormater.Create ('Invalid type name: PPropInfo'); + Result := RegisterArrayType (H, 'TPropList', R, T, False); +end; + +//==================================================================== +// EPropertyError +//==================================================================== + + +//-------------------------------------------------------------------- +// RegisterClass_EPropertyError +//-------------------------------------------------------------------- + +function RegisterClass_EPropertyError (H: integer): integer; +begin + Result := RegisterClassType (H, EPropertyError); + +end; + +//==================================================================== +// EPropertyConvertError +//==================================================================== + + +//-------------------------------------------------------------------- +// RegisterClass_EPropertyConvertError +//-------------------------------------------------------------------- + +function RegisterClass_EPropertyConvertError (H: integer): integer; +begin + Result := RegisterClassType (H, EPropertyConvertError); + +end; + +//-------------------------------------------------------------------- +// RegisterArray_fake_BooleanIdents_42 +//-------------------------------------------------------------------- + +function RegisterArray_fake_BooleanIdents_42 (H: integer): integer; +var + R,T: integer; +begin + R := _typeBOOLEAN; + T := RegisterTypeAlias (H, 'BooleanIdents', _typeSTRING); + Result := RegisterArrayType (H, 'fake_BooleanIdents_42', R, T, False); +end; + +//-------------------------------------------------------------------- +// DoRegisterVariable_BooleanIdents +//-------------------------------------------------------------------- + +function DoRegisterVariable_BooleanIdents (H: Integer): integer; +var + T: integer; +begin + T := RegisterArray_fake_BooleanIdents_42 (H); + result := RegisterVariable (H, 'BooleanIdents', T, @BooleanIdents); +end; + + +//-------------------------------------------------------------------- +// RegisterNameSpace_TypInfo +//-------------------------------------------------------------------- + +procedure RegisterNameSpace_TypInfo; +begin + RegisterNameSpace (0, 'TypInfo'); +end; + + +//-------------------------------------------------------------------- +// Register_TypInfo +//-------------------------------------------------------------------- +} +procedure Register_TypInfo; +var + H, G, A: integer; +begin + H := RegisterNamespace(0, 'TypInfo'); + RegisterRTTIType(H, TypeInfo(TTypeKind)); + RegisterRTTIType(H, TypeInfo(TTypeKinds)); + RegisterRTTIType(H, TypeInfo(TOrdType)); + RegisterRTTIType(H, TypeInfo(TFloatType)); + RegisterRTTIType(H, TypeInfo(TMethodKind)); + RegisterRTTIType(H, TypeInfo(TParamFlag)); + RegisterRTTIType(H, TypeInfo(TParamFlags)); + RegisterRTTIType(H, TypeInfo(TParamFlagsBase)); + RegisterRTTIType(H, TypeInfo(TIntfFlag)); + RegisterRTTIType(H, TypeInfo(TIntfFlags)); + RegisterRTTIType(H, TypeInfo(TIntfFlagsBase)); + + G := RegisterRecordType(H, 'TTypeInfo'); + RegisterRecordTypeField(G, 'Kind', RegisterRTTIType(H, TypeInfo(TTypeKind))); + RegisterRecordTypeField(G, 'Name', _typeSHORTSTRING); + G := RegisterPointerType(H, 'PTypeInfo', G); + G := RegisterPointerType(H, 'PPTypeInfo', G); + + G := RegisterRecordType(H, 'TPropInfo'); + RegisterRecordTypeField(G, 'PropType: PPtypeInfo', 0); + RegisterRecordTypeField(G, 'GetProc', _typePOINTER); + RegisterRecordTypeField(G, 'SetProc', _typePOINTER); + RegisterRecordTypeField(G, 'StoredProc', _typePOINTER); + RegisterRecordTypeField(G, 'Index', _typeINTEGER); + RegisterRecordTypeField(G, 'Default', _typeINTEGER); + RegisterRecordTypeField(G, 'NameIndex', _typeSMALLINT); + RegisterRecordTypeField(G, 'Name', _typeSHORTSTRING); + RegisterPointerType(H, 'PPropInfo', G); + + G := RegisterRecordType(H, 'TPropData'); + RegisterRecordTypeField(G, 'PropCount: Word;', 0); + + A := RegisterArrayType(0, '', RegisterSubrangeType(0, '', _typeINTEGER, 0, 1023), _typeANSICHAR); + + G := RegisterRecordType (H, 'TTypeData', False); + RegisterVariantRecordTypeField(G, 'OrdType: TOrdType', 02); + RegisterVariantRecordTypeField(G, 'MinValue', _typeINTEGER, 0102); + RegisterVariantRecordTypeField(G, 'MaxValue', _typeINTEGER, 0102); + RegisterVariantRecordTypeField(G, 'BaseType: PPTypeInfo', 020102); + RegisterVariantRecordTypeField(G, 'NameList: ShortString', 020102); + RegisterVariantRecordTypeField(G, 'EnumUnitName: ShortString', 020102); + RegisterVariantRecordTypeField(G, 'CompType: PPTypeInfo', 0202); + RegisterVariantRecordTypeField(G, 'FloatType: TFloatType', 03); + RegisterVariantRecordTypeField(G, 'MaxLength', _typeBYTE, 04); + RegisterVariantRecordTypeField(G, 'ClassType: TClass', 05); + RegisterVariantRecordTypeField(G, 'ParentInfo: PPTypeInfo', 05); + RegisterVariantRecordTypeField(G, 'PropCount', _typeSMALLINT, 05); + RegisterVariantRecordTypeField(G, 'UnitName', _typeSHORTSTRING, 05); + RegisterVariantRecordTypeField(G, 'MethodKind: TMethodKind', 06); + RegisterVariantRecordTypeField(G, 'ParamCount', _typeBYTE, 06); + + + RegisterVariantRecordTypeField(G, 'ParamList', A, 06); + RegisterVariantRecordTypeField(G, 'IntfParent: PPTypeInfo', 07); + RegisterVariantRecordTypeField(G, 'IntfFlags: TIntfFlagsBase', 07); + RegisterVariantRecordTypeField(G, 'Guid: TGUID', 07); + RegisterVariantRecordTypeField(G, 'IntfUnit', _typeSHORTSTRING, 07); + RegisterVariantRecordTypeField(G, 'MinInt64Value', _typeINT64, 08); + RegisterVariantRecordTypeField(G, 'MaxInt64Value', _typeINT64, 08); + RegisterVariantRecordTypeField(G, 'elSize', _typeINTEGER, 09); + RegisterVariantRecordTypeField(G, 'elType: PPTypeInfo', 09); + RegisterVariantRecordTypeField(G, 'varType', _typeINTEGER, 09); + RegisterVariantRecordTypeField(G, 'elType2: PPTypeInfo', 09); + RegisterVariantRecordTypeField(G, 'DynUnitName', _typeSHORTSTRING, 09); + + RegisterHeader (H, 'function PropType (Instance: TObject; const PropName: String): TTypeKind; overload;', Nil); + RegisterHeader (H, 'function PropType (AClass: TClass; const PropName: String): TTypeKind; overload;', Nil); + RegisterHeader (H, 'function PropIsType (Instance: TObject; const PropName: String; TypeKind: TTypeKind): Boolean; overload;' + , Nil); + RegisterHeader (H, 'function PropIsType (AClass: TClass; const PropName: String; TypeKind: TTypeKind): Boolean; overload;', + Nil); + RegisterHeader (H, 'function IsStoredProp (Instance: TObject; const PropName: String): Boolean; overload;', Nil); + RegisterHeader (H, 'function IsPublishedProp (Instance: TObject; const PropName: String): Boolean; overload;', Nil); + RegisterHeader (H, 'function IsPublishedProp (AClass: TClass; const PropName: String): Boolean; overload;', Nil); + RegisterHeader (H, 'function GetOrdProp (Instance: TObject; const PropName: String): Longint; overload;', Nil); + RegisterHeader (H, 'procedure SetOrdProp (Instance: TObject; const PropName: String; Value: Longint); overload;', Nil); + RegisterHeader (H, 'function GetEnumProp (Instance: TObject; const PropName: String): String; overload;', Nil); + RegisterHeader (H, 'procedure SetEnumProp (Instance: TObject; const PropName: String; const Value: String); overload;', Nil); + RegisterHeader (H, 'function GetSetProp (Instance: TObject; const PropName: String; Brackets: Boolean = False): String; ' + + 'overload;', Nil); + RegisterHeader (H, 'procedure SetSetProp (Instance: TObject; const PropName: String; const Value: String); overload;', Nil); + RegisterHeader (H, 'function GetObjectProp (Instance: TObject; const PropName: String; MinClass: TClass = nil): TObject; ' + + 'overload;', Nil); + RegisterHeader (H, 'procedure SetObjectProp (Instance: TObject; const PropName: String; Value: TObject); overload;', Nil); + RegisterHeader (H, 'function GetObjectPropClass (Instance: TObject; const PropName: String): TClass; overload;', Nil); + RegisterHeader (H, 'function GetStrProp (Instance: TObject; const PropName: String): String; overload;', Nil); + RegisterHeader (H, 'procedure SetStrProp (Instance: TObject; const PropName: String; const Value: String); overload;', Nil); + RegisterHeader (H, 'function GetWideStrProp (Instance: TObject; const PropName: String): WideString; overload;', Nil); + RegisterHeader (H, 'procedure SetWideStrProp (Instance: TObject; const PropName: String; const Value: WideString); overload;' + , Nil); + RegisterHeader (H, 'function GetFloatProp (Instance: TObject; const PropName: String): Extended; overload;', Nil); + RegisterHeader (H, 'procedure SetFloatProp (Instance: TObject; const PropName: String; const Value: Extended); overload;', + Nil); + RegisterHeader (H, 'function GetVariantProp (Instance: TObject; const PropName: String): Variant; overload;', Nil); + RegisterHeader (H, 'procedure SetVariantProp (Instance: TObject; const PropName: String; const Value: Variant); overload;', + Nil); + RegisterHeader (H, 'function GetMethodProp (Instance: TObject; const PropName: String): TMethod; overload;', Nil); + RegisterHeader (H, 'procedure SetMethodProp (Instance: TObject; const PropName: String; const Value: TMethod); overload;', + Nil); + RegisterHeader (H, 'function GetInt64Prop (Instance: TObject; const PropName: String): Int64; overload;', Nil); + RegisterHeader (H, 'procedure SetInt64Prop (Instance: TObject; const PropName: String; const Value: Int64); overload;', Nil); + RegisterHeader (H, 'function GetInterfaceProp (Instance: TObject; const PropName: String): IInterface; overload;', Nil); + RegisterHeader (H, 'procedure SetInterfaceProp (Instance: TObject; const PropName: String; const Value: IInterface); overload;' + + '', Nil); + RegisterHeader (H, 'function GetPropValue (Instance: TObject; const PropName: String; PreferStrings: Boolean = True): Variant;' + + '', Nil); + RegisterHeader (H, 'procedure SetPropValue (Instance: TObject; const PropName: String; const Value: Variant);', Nil); + RegisterHeader (H, 'procedure FreeAndNilProperties (AObject: TObject);', Nil); + + G := RegisterClassType(H, TPublishableVariantType); + RegisterHeader(G, + 'function GetProperty (var Dest: TVarData; const V: TVarData; const Name: String): Boolean; override;', + @TPublishableVariantType.GetProperty); + RegisterHeader (G, + 'function SetProperty (const V: TVarData; const Name: String; const Value: TVarData): Boolean; override;', + @TPublishableVariantType.SetProperty); + + RegisterConstant (H, 'tkAny = [Low(TTypeKind)..High(TTypeKind)];'); + RegisterConstant (H, 'tkMethods = [tkMethod];'); + RegisterConstant (H, 'tkProperties = tkAny - tkMethods - [tkUnknown];'); + RegisterTypeDeclaration (H, 'ShortStringBase = String [255];'); + RegisterHeader (H, 'function GetTypeData (TypeInfo: PTypeInfo): PTypeData;', Nil); + RegisterHeader (H, 'function GetEnumName (TypeInfo: PTypeInfo; Value: Integer): String;', Nil); + RegisterHeader (H, 'function GetEnumValue (TypeInfo: PTypeInfo; const Name: String): Integer;', Nil); + RegisterHeader (H, 'function GetPropInfo (Instance: TObject; const PropName: String; AKinds: TTypeKinds = []): PPropInfo; ' + + 'overload;', Nil); + RegisterHeader (H, 'function GetPropInfo (AClass: TClass; const PropName: String; AKinds: TTypeKinds = []): PPropInfo; ' + + 'overload;', Nil); + RegisterHeader (H, 'function GetPropInfo (TypeInfo: PTypeInfo; const PropName: String): PPropInfo; overload;', Nil); + RegisterHeader (H, 'function GetPropInfo (TypeInfo: PTypeInfo; const PropName: String; AKinds: TTypeKinds): PPropInfo; ' + + 'overload;', Nil); + RegisterHeader (H, 'procedure GetPropInfos (TypeInfo: PTypeInfo; PropList: PPropList);', Nil); + RegisterHeader (H, 'function GetPropList (TypeInfo: PTypeInfo; TypeKinds: TTypeKinds; PropList: PPropList; SortList: Boolean ' + + '= True): Integer; overload;', Nil); + RegisterHeader (H, 'function GetPropList (TypeInfo: PTypeInfo; out PropList: PPropList): Integer; overload;', Nil); + RegisterHeader (H, 'function GetPropList (AObject: TObject; out PropList: PPropList): Integer; overload;', Nil); + RegisterHeader (H, 'procedure SortPropList (PropList: PPropList; PropCount: Integer);', Nil); + RegisterHeader (H, 'function IsStoredProp (Instance: TObject; PropInfo: PPropInfo): Boolean; overload;', Nil); + RegisterHeader (H, 'function GetOrdProp (Instance: TObject; PropInfo: PPropInfo): Longint; overload;', Nil); + RegisterHeader (H, 'procedure SetOrdProp (Instance: TObject; PropInfo: PPropInfo; Value: Longint); overload;', Nil); + RegisterHeader (H, 'function GetEnumProp (Instance: TObject; PropInfo: PPropInfo): String; overload;', Nil); + RegisterHeader (H, 'procedure SetEnumProp (Instance: TObject; PropInfo: PPropInfo; const Value: String); overload;', Nil); + RegisterHeader (H, 'function GetSetProp (Instance: TObject; PropInfo: PPropInfo; Brackets: Boolean = False): String; overload;' + + '', Nil); + RegisterHeader (H, 'procedure SetSetProp (Instance: TObject; PropInfo: PPropInfo; const Value: String); overload;', Nil); + RegisterHeader (H, 'function GetObjectProp (Instance: TObject; PropInfo: PPropInfo; MinClass: TClass = nil): TObject; ' + + 'overload;', Nil); + RegisterHeader (H, 'procedure SetObjectProp (Instance: TObject; PropInfo: PPropInfo; Value: TObject; ValidateClass: Boolean = ' + + 'True); overload;', Nil); + RegisterHeader (H, 'function GetObjectPropClass (Instance: TObject; PropInfo: PPropInfo): TClass; overload;', Nil); + RegisterHeader (H, 'function GetObjectPropClass (PropInfo: PPropInfo): TClass; overload;', Nil); + RegisterHeader (H, 'function GetStrProp (Instance: TObject; PropInfo: PPropInfo): String; overload;', Nil); + RegisterHeader (H, 'procedure SetStrProp (Instance: TObject; PropInfo: PPropInfo; const Value: String); overload;', Nil); + RegisterHeader (H, 'function GetWideStrProp (Instance: TObject; PropInfo: PPropInfo): WideString; overload;', Nil); + RegisterHeader (H, 'procedure SetWideStrProp (Instance: TObject; PropInfo: PPropInfo; const Value: WideString); overload;', + Nil); + RegisterHeader (H, 'function GetFloatProp (Instance: TObject; PropInfo: PPropInfo): Extended; overload;', Nil); + RegisterHeader (H, 'procedure SetFloatProp (Instance: TObject; PropInfo: PPropInfo; const Value: Extended); overload;', Nil); + RegisterHeader (H, 'function GetVariantProp (Instance: TObject; PropInfo: PPropInfo): Variant; overload;', Nil); + RegisterHeader (H, 'procedure SetVariantProp (Instance: TObject; PropInfo: PPropInfo; const Value: Variant); overload;', Nil); + + RegisterHeader (H, 'function GetMethodProp (Instance: TObject; PropInfo: PPropInfo): TMethod; overload;', Nil); + RegisterHeader (H, 'procedure SetMethodProp (Instance: TObject; PropInfo: PPropInfo; const Value: TMethod); overload;', Nil); + RegisterHeader (H, 'function GetInt64Prop (Instance: TObject; PropInfo: PPropInfo): Int64; overload;', Nil); + RegisterHeader (H, 'procedure SetInt64Prop (Instance: TObject; PropInfo: PPropInfo; const Value: Int64); overload;', Nil); + RegisterHeader (H, 'function GetInterfaceProp (Instance: TObject; PropInfo: PPropInfo): IInterface; overload;', Nil); + RegisterHeader (H, 'procedure SetInterfaceProp (Instance: TObject; PropInfo: PPropInfo; const Value: IInterface); overload;', + Nil); + RegisterVariable (H, 'DotSep:String;', @DotSep); + RegisterHeader (H, 'function SetToString (PropInfo: PPropInfo; Value: Integer; Brackets: Boolean = False): String;', Nil); + RegisterHeader (H, 'function StringToSet (PropInfo: PPropInfo; const Value: String): Integer;', Nil); +end; + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/RTTI/1/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/RTTI/1/Project1.dpr new file mode 100644 index 0000000..4ee0daf --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/RTTI/1/Project1.dpr @@ -0,0 +1,193 @@ +{$APPTYPE CONSOLE} +{$O-} +program Project1; +uses + PAXCOMP_CONSTANTS, + PAXCOMP_SYS, + TypInfo, + Classes, + SysUtils, + IMPORT_Classes, + PaxCompiler, + PaxProgram, + PaxRegister, + PaxBasicLanguage, + IMPORT_TypInfo in 'IMPORT_TypInfo.pas'; + +type + TTestClass = class + procedure DoTest; + procedure OnClickHandler(Sender: TObject); + procedure OnClickHandler2(Sender: TObject); + end; + +var + PaxProgram1: TPaxProgram; + +procedure TTestClass.OnClickHandler(Sender: TObject); +begin + writeln('Click'); +end; + +procedure TTestClass.OnClickHandler2(Sender: TObject); +begin + writeln('Click 2'); +end; + + +procedure TTestClass.DoTest; +var + C: TClass; + P: Pointer; + pti: PTypeInfo; + ptd: PTypeData; + ppi: PPropInfo; + I: Integer; + Z, X: TObject; + S: String; + AMethod: TMethod; +begin + AMethod.Code := @ TTestClass.OnClickHandler; + AMethod.Data := Self; + + P := PaxProgram1.GetAddress('AMyClass'); + C := TClass(P^); + writeln(C.ClassName); + pti := C.ClassInfo; + writeln(pti^.Name); + + ptd := GetTypeData(pti); + writeln(ptd^.ClassType.ClassName); + pti := ptd^.ParentInfo^; + writeln(pti^.Name); + writeln(ptd^.PropCount); + writeln(ptd^.UnitName); + + ppi := GetPropInfo(C, 'X'); + writeln(ppi^.Name); + + pti := PaxProgram1.GetTypeInfo('IUnknown'); + writeln(pti^.Name); + ptd := GetTypeData(pti); + writeln(ptd^.IntfUnit); + + pti := PaxProgram1.GetTypeInfo('MyEnum'); + writeln(pti^.Name); + ptd := GetTypeData(pti); + writeln(ptd^.BaseType^.Name); +// writeln(ptd^.EnumUnitName); + writeln(GetEnumName(pti, 2)); + writeln(GetEnumValue(pti, 'three')); + + pti := PaxProgram1.GetTypeInfo('Integer'); + writeln(pti^.Name); + + // work with instance + + P := PaxProgram1.GetAddress('Z'); + Z := TObject(P^); + writeln(Z.ClassName); + SetOrdProp(Z, 'X', 5); + I := GetOrdProp(Z, 'X'); + writeln(I); + + SetStrProp(Z, 'Y', 'abc'); + S := GetStrProp(Z, 'Y'); + writeln(S); + + ppi := GetPropInfo(Z, 'Inter'); + writeln(ppi^.Name); + + P := Z.MethodAddress('MyProc'); + asm + mov eax, z + mov edx, 10 + mov ecx, 20 + call P; + end; + + P := Z.FieldAddress('Field2'); + X := TObject(P^); + writeln(X.ClassName); + + SetMethodProp(Z, 'OnClick', AMethod); + AMethod := GetMethodProp(Z, 'OnClick'); + + asm + call AMethod.Code; + end; + + // RTTI of inherited class: + + P := PaxProgram1.GetAddress('AMyClass2'); + C := TClass(P^); + writeln(C.ClassName); + pti := C.ClassInfo; + writeln(pti^.Name); + + ppi := GetPropInfo(C, 'X'); + writeln(ppi^.Name); + + // work with instance + P := PaxProgram1.GetAddress('W'); + Z := TObject(P^); + writeln(Z.ClassName); + SetOrdProp(Z, 'X', 7); + I := GetOrdProp(Z, 'X'); + writeln(I); + + P := Z.MethodAddress('MyProc'); + asm + mov eax, Z + mov edx, 2 + mov edx, 3 + call P; + end; + + P := Z.FieldAddress('Field2'); + X := TObject(P^); + writeln(X.ClassName); +end; + +var + PaxCompiler1: TPaxCompiler; + PaxBasicLanguage1: TPaxBasicLanguage; + H: Integer; +begin + Register_Classes; + Register_TypInfo; + RegisterRTTIType(0, TypeInfo(TNotifyEvent)); + + H := RegisterClassType(0, TTestClass); + RegisterHeader(H, 'procedure DoTest;', + @TTestClass.DoTest); + RegisterHeader(H, 'procedure OnClickHandler2(Sender: TObject);', + @TTestClass.OnClickHandler2); + + PaxCompiler1 := TPaxCompiler.Create(nil); + PaxProgram1 := TPaxProgram.Create(nil); + PaxBasicLanguage1 := TPaxBasicLanguage.Create(nil); + try + PaxCompiler1.RegisterLanguage(PaxBasicLanguage1); + PaxCompiler1.AddModule('1', 'Basic'); + PaxCompiler1.AddCodeFromFile('1', 'script.txt'); + if PaxCompiler1.Compile(PaxProgram1) then + begin +{ + PaxProgram1.SaveToFile('1.bin'); + PaxProgram1.Free; + PaxProgram1 := TPaxProgram.Create(nil); + PaxProgram1.LoadFromFile('1.bin'); +} + PaxProgram1.Run; + end + else + writeln(PaxCompiler1.ErrorMessage[0]); + finally + PaxCompiler1.Free; + PaxProgram1.Free; + PaxBasicLanguage1.Free; + end; + writeln('Press any key...'); + Readln; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/RTTI/1/script.txt b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/RTTI/1/script.txt new file mode 100644 index 0000000..3cbb690 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/RTTI/1/script.txt @@ -0,0 +1,135 @@ +Imports TypInfo, Classes, PascalNamespace + +Enum MyEnum + one + two + three +End Enum + +Class AMyClass + Inherits TComponent + Private FX As Integer + Private FY AS String + Private fStrings As TStringList + Private fOnClick As TNotifyEvent + Private fInter As IUnknown + + Published Field As TObject + Published Field2 As TStringList + + Function GetY As String + Return FY + End Function + + Sub SetY(value AS String) + println "value=", value + FY = value + println "FY=", FY + End Sub + + Sub New(AOwner As TComponent) + MyBase.Create(null) + Field = New TObject + Field2 = New TStringList + End Sub + + Sub Finalize + Field.Free + Field2.Free + MyBase.Destroy + End Sub + + Sub ScriptHandler(Sender As TObject) + println "***************", Sender.ClassName + ExitCode = 5 + println ExitCode + End Sub + + Published Property X As Integer + Get + Return FX + End Get + Set + println "value=", value + FX = value + println "FX=", FX + End Set + End Property + + Published Property Y As String + Get + Return FY + End Get + Set + FY = value + End Set + End Property + + Published Property Strings As TStringList + Get + Return fStrings + End Get + Set + fStrings = value + End Set + End Property + + Published Property OnClick As TNotifyEvent + Get + Return fOnClick + End Get + Set + fOnClick = value + End Set + End Property + + Published Property Inter As IUnknown + Get + Return fInter + End Get + Set + fInter = value + End Set + End Property + + Published Sub MyProc(U As Integer, V As Integer) + println "MyProc:", X, Y + End Sub + +End Class + +Class AMyClass2 + Inherits AMyClass + Sub New(AOwner As TComponent) + MyBase.New(null) + End Sub +End Class + +Dim Z As AMyClass, W As AMyClass +Dim TestClass As TTestClass = New TTestClass() + +Z = New AMyClass(null) +W = New AMyClass2(null) + +W.X = 5 +println W.X + +W.Name = "yyyy" +println W.Name + +TestClass.DoTest ' Z.OnClick was assigned at host side + +If Assigned(Z.OnClick) Then + Z.OnClick(Z) +End If + +Z.OnClick = TestClass.OnClickHandler2 ' direct assignment of host handler +Z.OnClick(null) + +Z.OnClick = Z.ScriptHandler +Z.OnClick(W) + +Z.Free +W.Free +TestClass.Free + diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/RTTI/2/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/RTTI/2/Project1.dpr new file mode 100644 index 0000000..7e0070e --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/RTTI/2/Project1.dpr @@ -0,0 +1,93 @@ +{$APPTYPE CONSOLE} +{$O-} +program Project1; +uses + PAXCOMP_CONSTANTS, + PAXCOMP_SYS, + TypInfo, + Classes, + SysUtils, + PaxCompiler, + PaxProgram, + PaxBasicLanguage, + PaxRegister; + +type + TTest = class(TComponent) + public + procedure Save; + end; + +{ TTest } + +procedure MyGetPropertyNames(aObject: TObject; aStringList: TStringList); +var + count : integer; + size : integer; + list : PPropList; + i : integer; + ppi: PPropInfo; +begin + aStringList.Clear; + count := GetPropList(PTypeInfo(aObject.ClassInfo), tkProperties, nil, false); + size := count * SizeOf(Pointer); + GetMem(list, size); + try + GetPropList(PTypeInfo(aObject.ClassInfo), tkProperties, list, false); + for i := 0 to count - 1 do + aStringList.Add(list^[i]^.Name); + finally + FreeMem(list, size); + end; +end; + +type + TMyStringList = class(TStringList) + published + property Text; + end; + +procedure TTest.Save; +var + list: TMyStringList; +begin + list := TMyStringList.Create; + try + MyGetPropertyNames(self, list); + writeln('Property Count = ', list.Count); + writeln('Properties are: ' + list.Text); + finally + list.free; + end; +end; + +var + PaxProgram1: TPaxProgram; + PaxCompiler1: TPaxCompiler; + PaxBasicLanguage1: TPaxBasicLanguage; + H: Integer; +begin + H := RegisterClassType(0, TTest); + RegisterHeader(H, 'procedure Save;', @TTest.Save); + + PaxCompiler1 := TPaxCompiler.Create(nil); + PaxProgram1 := TPaxProgram.Create(nil); + PaxBasicLanguage1 := TPaxBasicLanguage.Create(nil); + try + PaxCompiler1.RegisterLanguage(PaxBasicLanguage1); + PaxCompiler1.AddModule('1', 'Basic'); + PaxCompiler1.AddCodeFromFile('1', 'script.txt'); + if PaxCompiler1.Compile(PaxProgram1) then + begin + PaxProgram1.Run; + end + else + writeln(PaxCompiler1.ErrorMessage[0]); + finally + PaxCompiler1.Free; + PaxProgram1.Free; + PaxBasicLanguage1.Free; + end; + writeln('Press any key...'); + Readln; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/RTTI/2/script.txt b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/RTTI/2/script.txt new file mode 100644 index 0000000..22098dc --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/RTTI/2/script.txt @@ -0,0 +1,37 @@ +Class MyTestBase + Inherits TTest +End Class + + +Class MyTest + + Inherits MyTestBase + + Private FX As Integer + Private FY As String + + Published Property X As Integer + Get + Return FX + End Get + Set + FX = value + End Set + End Property + + Published Property Y As String + Get + Return FY + End Get + Set + FY = value + End Set + End Property + +End Class + +Dim t As MyTest = New MyTest +t.x = 10 +t.y = "20" +t.Save +t.Free diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/RegisterVariable/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/RegisterVariable/Project1.dpr new file mode 100644 index 0000000..513a1dd --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/RegisterVariable/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/RegisterVariable/Project1.res b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/RegisterVariable/Project1.res new file mode 100644 index 0000000..3adc036 Binary files /dev/null and b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/RegisterVariable/Project1.res differ diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/RegisterVariable/Unit1.dfm b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/RegisterVariable/Unit1.dfm new file mode 100644 index 0000000..d98d804 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/RegisterVariable/Unit1.dfm @@ -0,0 +1,43 @@ +object Form1: TForm1 + Left = 192 + Top = 114 + Width = 282 + Height = 178 + Caption = 'Register variable demo' + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + PixelsPerInch = 96 + TextHeight = 13 + object Button1: TButton + Left = 40 + Top = 80 + Width = 75 + Height = 25 + Caption = 'Run' + TabOrder = 0 + OnClick = Button1Click + end + object PaxCompiler1: TPaxCompiler + Alignment = 1 + DebugMode = False + Left = 32 + Top = 16 + end + object PaxProgram1: TPaxProgram + Console = False + Left = 128 + Top = 16 + end + object PaxBasicLanguage1: TPaxBasicLanguage + ExplicitOff = False + CompleteBooleanEval = False + UseFWArrays = True + Left = 80 + Top = 16 + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Basic/RegisterVariable/Unit1.pas b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/RegisterVariable/Unit1.pas new file mode 100644 index 0000000..7b91e49 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Basic/RegisterVariable/Unit1.pas @@ -0,0 +1,68 @@ +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, PaxCompiler, PaxProgram, PaxRegister, PaxBasicLanguage, + PaxRunner; + +type + TForm1 = class(TForm) + PaxCompiler1: TPaxCompiler; + PaxProgram1: TPaxProgram; + Button1: TButton; + PaxBasicLanguage1: TPaxBasicLanguage; + procedure Button1Click(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.dfm} + +type + TMyPoint = packed record + x, y: Integer; + end; + +procedure TForm1.Button1Click(Sender: TObject); +var + H_TMyPoint, H_MyPoint: Integer; + MyPoint: TMyPoint; + I: Integer; +begin + MyPoint.X := 60; + MyPoint.Y := 23; + + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxBasicLanguage1); + + // register host-defined type + H_TMyPoint := PaxCompiler1.RegisterRecordType(0, 'TMyPoint'); + PaxCompiler1.RegisterRecordTypeField(H_TMyPoint, 'X', _typeINTEGER); + PaxCompiler1.RegisterRecordTypeField(H_TMyPoint, 'Y', _typeINTEGER); + + // register host-defined variable + H_MyPoint := PaxCompiler1.RegisterVariable(0, 'MyPoint', H_TMyPoint, @MyPoint); + + PaxCompiler1.AddModule('1', PaxBasicLanguage1.LanguageName); + PaxCompiler1.AddCode('1', 'MyPoint.Y = 8'); + + if PaxCompiler1.Compile(PaxProgram1) then + begin + PaxProgram1.Run; + ShowMessage(IntToStr(MyPoint.Y)); + end + else + for I:=0 to PaxCompiler1.ErrorCount do + ShowMessage(PaxCompiler1.ErrorMessage[I]); +end; + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/AccessToScriptVariables/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/AccessToScriptVariables/Project1.dpr new file mode 100644 index 0000000..513a1dd --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/AccessToScriptVariables/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/AccessToScriptVariables/Project1.res b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/AccessToScriptVariables/Project1.res new file mode 100644 index 0000000..3adc036 Binary files /dev/null and b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/AccessToScriptVariables/Project1.res differ diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/AccessToScriptVariables/Unit1.dfm b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/AccessToScriptVariables/Unit1.dfm new file mode 100644 index 0000000..36825ab --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/AccessToScriptVariables/Unit1.dfm @@ -0,0 +1,40 @@ +object Form1: TForm1 + Left = 277 + Top = 120 + Width = 252 + Height = 172 + Caption = 'Access to script-defined variables' + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + PixelsPerInch = 96 + TextHeight = 13 + object Button1: TButton + Left = 32 + Top = 80 + Width = 75 + Height = 25 + Caption = 'Run' + TabOrder = 0 + OnClick = Button1Click + end + object PaxCompiler1: TPaxCompiler + Alignment = 1 + DebugMode = False + Left = 48 + Top = 24 + end + object PaxProgram1: TPaxProgram + Console = False + Left = 144 + Top = 24 + end + object PaxJavaScriptLanguage1: TPaxJavaScriptLanguage + Left = 152 + Top = 80 + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/AccessToScriptVariables/Unit1.pas b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/AccessToScriptVariables/Unit1.pas new file mode 100644 index 0000000..8ed4bb2 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/AccessToScriptVariables/Unit1.pas @@ -0,0 +1,61 @@ +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, PaxCompiler, PaxProgram, PaxJavaScriptLanguage, + PaxRunner; +type + TForm1 = class(TForm) + PaxCompiler1: TPaxCompiler; + PaxProgram1: TPaxProgram; + Button1: TButton; + PaxJavaScriptLanguage1: TPaxJavaScriptLanguage; + procedure Button1Click(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.dfm} + +procedure TForm1.Button1Click(Sender: TObject); +var + P: Pointer; + I: Integer; +begin + {$O-} + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxJavaScriptLanguage1); + + PaxCompiler1.RegisterHeader(0, 'procedure ShowMessage(const Msg: string);', @ShowMessage); + PaxCompiler1.RegisterHeader(0, 'function IntToStr(Value: Integer): string;', @IntToStr); + + PaxCompiler1.AddModule('1', PaxJavaScriptLanguage1.LanguageName); + PaxCompiler1.AddCode('1', 'var x;'); + PaxCompiler1.AddCode('1', 'ShowMessage("script:" + IntToStr(x));'); + + if PaxCompiler1.Compile(PaxProgram1) then + begin + P := PaxProgram1.GetAddress('x'); + Variant(P^) := 5; // change script-defind variable + PaxProgram1.Run; // the first run + ShowMessage('host:' + IntToStr(Variant(P^))); // show script-defined var + Variant(P^) := 30; // change script-defind variable + PaxProgram1.Run; // the second run + end + else + for I:=0 to PaxCompiler1.ErrorCount do + ShowMessage(PaxCompiler1.ErrorMessage[I]); +end; + +initialization SetDump; + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/Benchmark1/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/Benchmark1/Project1.dpr new file mode 100644 index 0000000..513a1dd --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/Benchmark1/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/Benchmark1/Project1.res b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/Benchmark1/Project1.res new file mode 100644 index 0000000..3adc036 Binary files /dev/null and b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/Benchmark1/Project1.res differ diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/Benchmark1/Unit1.dfm b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/Benchmark1/Unit1.dfm new file mode 100644 index 0000000..0e43d3f --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/Benchmark1/Unit1.dfm @@ -0,0 +1,49 @@ +object Form1: TForm1 + Left = 192 + Top = 114 + Width = 612 + Height = 272 + Caption = 'Benchmark 1' + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + PixelsPerInch = 96 + TextHeight = 13 + object Button1: TButton + Left = 32 + Top = 80 + Width = 121 + Height = 25 + Caption = 'paxCompiler' + TabOrder = 0 + OnClick = Button1Click + end + object Button2: TButton + Left = 32 + Top = 128 + Width = 121 + Height = 25 + Caption = 'Delphi' + TabOrder = 1 + OnClick = Button2Click + end + object PaxCompiler1: TPaxCompiler + Alignment = 1 + DebugMode = False + Left = 32 + Top = 24 + end + object PaxProgram1: TPaxProgram + Console = False + Left = 112 + Top = 24 + end + object PaxJavaScriptLanguage1: TPaxJavaScriptLanguage + Left = 72 + Top = 24 + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/Benchmark1/Unit1.pas b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/Benchmark1/Unit1.pas new file mode 100644 index 0000000..1d0eb22 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/Benchmark1/Unit1.pas @@ -0,0 +1,91 @@ +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, PaxCompiler, PaxProgram, PaxJavaScriptLanguage, + PaxRunner; + +type + TForm1 = class(TForm) + PaxCompiler1: TPaxCompiler; + PaxProgram1: TPaxProgram; + Button1: TButton; + Button2: TButton; + PaxJavaScriptLanguage1: TPaxJavaScriptLanguage; + procedure Button1Click(Sender: TObject); + procedure Button2Click(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.dfm} + +procedure TForm1.Button1Click(Sender: TObject); +var + I: Integer; + t: Integer; +begin + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxJavaScriptLanguage1); + + PaxCompiler1.AddModule('1', PaxJavaScriptLanguage1.LanguageName); + + PaxCompiler1.AddCode('1', 'function P()'); + PaxCompiler1.AddCode('1', '{'); + PaxCompiler1.AddCode('1', ' var d1, d2, i;'); + PaxCompiler1.AddCode('1', ' d1 = 5.4;'); + PaxCompiler1.AddCode('1', ' d2 = 9009960.3;'); + PaxCompiler1.AddCode('1', ' i = 0;'); + PaxCompiler1.AddCode('1', ' while (d1 < d2)'); + PaxCompiler1.AddCode('1', ' {'); + PaxCompiler1.AddCode('1', ' i++;'); + PaxCompiler1.AddCode('1', ' d1 += 0.5;'); + PaxCompiler1.AddCode('1', ' }'); + PaxCompiler1.AddCode('1', '}'); + PaxCompiler1.AddCode('1', 'P();'); + if PaxCompiler1.Compile(PaxProgram1) then + begin + t := GetTickCount; + PaxProgram1.Run; + PaxProgram1.GetProgPtr.RootGC.Collect(); + ShowMessage(IntToStr(GetTickCount - t)); + end + else + for I:=0 to PaxCompiler1.ErrorCount - 1 do + ShowMessage(PaxCompiler1.ErrorMessage[I]); +end; + +procedure P(); +var + d1, d2: Double; + I: Integer; +begin + d1 := 5.4; + d2 := 9009960.3; + I := 0; + while d1 < d2 do + begin + Inc(I); + d1 := d1 + 0.5; + end; +end; + +procedure TForm1.Button2Click(Sender: TObject); +var + t: Integer; +begin + t := GetTickCount; + P; + ShowMessage(IntToStr(GetTickCount - t)); +end; + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/Benchmark2/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/Benchmark2/Project1.dpr new file mode 100644 index 0000000..513a1dd --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/Benchmark2/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/Benchmark2/Project1.res b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/Benchmark2/Project1.res new file mode 100644 index 0000000..3adc036 Binary files /dev/null and b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/Benchmark2/Project1.res differ diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/Benchmark2/Unit1.dfm b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/Benchmark2/Unit1.dfm new file mode 100644 index 0000000..9f97e91 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/Benchmark2/Unit1.dfm @@ -0,0 +1,49 @@ +object Form1: TForm1 + Left = 192 + Top = 114 + Width = 233 + Height = 192 + Caption = 'Benchmark 2' + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + PixelsPerInch = 96 + TextHeight = 13 + object Button1: TButton + Left = 24 + Top = 72 + Width = 75 + Height = 25 + Caption = 'PaxCompiler' + TabOrder = 0 + OnClick = Button1Click + end + object Button2: TButton + Left = 24 + Top = 120 + Width = 75 + Height = 25 + Caption = 'Delphi' + TabOrder = 1 + OnClick = Button2Click + end + object PaxCompiler1: TPaxCompiler + Alignment = 1 + DebugMode = False + Left = 24 + Top = 24 + end + object PaxProgram1: TPaxProgram + Console = False + Left = 104 + Top = 24 + end + object PaxJavaScriptLanguage1: TPaxJavaScriptLanguage + Left = 64 + Top = 24 + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/Benchmark2/Unit1.pas b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/Benchmark2/Unit1.pas new file mode 100644 index 0000000..4684032 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/Benchmark2/Unit1.pas @@ -0,0 +1,70 @@ +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, + Dialogs, PaxCompiler, StdCtrls, PaxProgram, PaxJavaScriptLanguage, + PaxRunner; + +type + TForm1 = class(TForm) + Button1: TButton; + Button2: TButton; + PaxCompiler1: TPaxCompiler; + PaxProgram1: TPaxProgram; + PaxJavaScriptLanguage1: TPaxJavaScriptLanguage; + procedure Button1Click(Sender: TObject); + procedure Button2Click(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.dfm} + +procedure TForm1.Button1Click(Sender: TObject); +var + I: Integer; + t: Integer; +begin + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxJavaScriptLanguage1); + + PaxCompiler1.RegisterHeader(0, 'function IntToStr(Value: Integer): string;', @IntToStr); + PaxCompiler1.RegisterHeader(0, 'function StrToInt(const S: string): Integer;', @StrToInt); + + PaxCompiler1.AddModule('1', PaxJavaScriptLanguage1.LanguageName); + + PaxCompiler1.AddCode('1', 'var i, k;'); + PaxCompiler1.AddCode('1', ' for (i=1; i < 200000; i++)'); + PaxCompiler1.AddCode('1', ' k = StrToInt(IntToStr(i));'); + + if PaxCompiler1.Compile(PaxProgram1) then + begin + t := GetTickCount; + PaxProgram1.Run; + ShowMessage(IntToStr(GetTickCount - t)); + end + else + for I:=0 to PaxCompiler1.ErrorCount - 1 do + ShowMessage(PaxCompiler1.ErrorMessage[I]); +end; + +procedure TForm1.Button2Click(Sender: TObject); +var + I, K, t: Integer; +begin + t := GetTickCount; + for I:=1 to 200000 do + K := StrToInt(IntToStr(I)); + ShowMessage(IntToStr(GetTickCount - t)); +end; + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/Benchmark3/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/Benchmark3/Project1.dpr new file mode 100644 index 0000000..513a1dd --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/Benchmark3/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/Benchmark3/Project1.res b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/Benchmark3/Project1.res new file mode 100644 index 0000000..3adc036 Binary files /dev/null and b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/Benchmark3/Project1.res differ diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/Benchmark3/Unit1.dfm b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/Benchmark3/Unit1.dfm new file mode 100644 index 0000000..695196a --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/Benchmark3/Unit1.dfm @@ -0,0 +1,49 @@ +object Form1: TForm1 + Left = 192 + Top = 114 + Width = 233 + Height = 192 + Caption = 'Benchmark 2' + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + PixelsPerInch = 96 + TextHeight = 13 + object Button1: TButton + Left = 24 + Top = 72 + Width = 75 + Height = 25 + Caption = 'PaxCompiler' + TabOrder = 0 + OnClick = Button1Click + end + object Button2: TButton + Left = 24 + Top = 120 + Width = 75 + Height = 25 + Caption = 'Delphi' + TabOrder = 1 + OnClick = Button2Click + end + object PaxCompiler1: TPaxCompiler + Alignment = 1 + DebugMode = False + Left = 24 + Top = 24 + end + object PaxProgram1: TPaxProgram + Console = False + Left = 104 + Top = 24 + end + object PaxJavaScriptLanguage1: TPaxJavaScriptLanguage + Left = 72 + Top = 24 + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/Benchmark3/Unit1.pas b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/Benchmark3/Unit1.pas new file mode 100644 index 0000000..6d87636 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/Benchmark3/Unit1.pas @@ -0,0 +1,82 @@ +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, + Dialogs, PaxCompiler, StdCtrls, PaxProgram, PaxJavaScriptLanguage, + PaxRunner; + +type + TForm1 = class(TForm) + Button1: TButton; + Button2: TButton; + PaxCompiler1: TPaxCompiler; + PaxProgram1: TPaxProgram; + PaxJavaScriptLanguage1: TPaxJavaScriptLanguage; + procedure Button1Click(Sender: TObject); + procedure Button2Click(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.dfm} + +procedure TForm1.Button1Click(Sender: TObject); +var + I: Integer; + t: Integer; +begin + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxJavaScriptLanguage1); + + PaxCompiler1.AddModule('1', PaxJavaScriptLanguage1.LanguageName); + + PaxCompiler1.AddCode('1', 'function fact(n)'); + PaxCompiler1.AddCode('1', '{'); + PaxCompiler1.AddCode('1', ' if (n == 1)'); + PaxCompiler1.AddCode('1', ' return 1;'); + PaxCompiler1.AddCode('1', ' else'); + PaxCompiler1.AddCode('1', ' return n * fact(n - 1);'); + PaxCompiler1.AddCode('1', '}'); + PaxCompiler1.AddCode('1', 'var i;'); + PaxCompiler1.AddCode('1', 'for (i=1; i < 10000; i++)'); + PaxCompiler1.AddCode('1', ' fact(10);'); + + if PaxCompiler1.Compile(PaxProgram1) then + begin + t := GetTickCount; + PaxProgram1.Run; + ShowMessage(IntToStr(GetTickCount - t)); + end + else + for I:=0 to PaxCompiler1.ErrorCount - 1 do + ShowMessage(PaxCompiler1.ErrorMessage[I]); +end; + +function Fact(const N: Variant): Variant; +begin + if N = 1 then + result := 1 + else + result := N * Fact(N - 1); +end; + +procedure TForm1.Button2Click(Sender: TObject); +var + I, t: Integer; +begin + t := GetTickCount; + for I:=1 to 10000 do + Fact(10); + ShowMessage(IntToStr(GetTickCount - t)); +end; + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/Benchmark4/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/Benchmark4/Project1.dpr new file mode 100644 index 0000000..513a1dd --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/Benchmark4/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/Benchmark4/Project1.res b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/Benchmark4/Project1.res new file mode 100644 index 0000000..3adc036 Binary files /dev/null and b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/Benchmark4/Project1.res differ diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/Benchmark4/Unit1.dfm b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/Benchmark4/Unit1.dfm new file mode 100644 index 0000000..74da674 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/Benchmark4/Unit1.dfm @@ -0,0 +1,69 @@ +object Form1: TForm1 + Left = 192 + Top = 114 + Width = 576 + Height = 447 + Caption = 'Benchmark 4' + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + PixelsPerInch = 96 + TextHeight = 13 + object Memo1: TMemo + Left = 16 + Top = 176 + Width = 513 + Height = 217 + Lines.Strings = ( + 'var i, j, c;' + 'c = new TComponent(null);' + 'for (i=0; i<500000; i++)' + '{' + ' if (c.Tag == 0)' + ' {' + ' c.Tag = 0;' + ' c.Name = "a";' + ' }' + '}' + 'c.Free();' + '') + TabOrder = 0 + end + object Button1: TButton + Left = 224 + Top = 136 + Width = 75 + Height = 25 + Caption = 'PaxCompiler' + TabOrder = 1 + OnClick = Button1Click + end + object Button2: TButton + Left = 32 + Top = 136 + Width = 75 + Height = 25 + Caption = 'Delphi' + TabOrder = 2 + OnClick = Button2Click + end + object PaxCompiler1: TPaxCompiler + Alignment = 1 + DebugMode = False + Left = 72 + Top = 24 + end + object PaxProgram1: TPaxProgram + Console = False + Left = 176 + Top = 24 + end + object PaxJavaScriptLanguage1: TPaxJavaScriptLanguage + Left = 120 + Top = 24 + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/Benchmark4/Unit1.pas b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/Benchmark4/Unit1.pas new file mode 100644 index 0000000..9a4b045 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/Benchmark4/Unit1.pas @@ -0,0 +1,77 @@ +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, PaxCompiler, PaxProgram, PaxRegister, PaxJavaScriptLanguage, + PaxRunner; + +type + TForm1 = class(TForm) + PaxCompiler1: TPaxCompiler; + PaxProgram1: TPaxProgram; + Memo1: TMemo; + Button1: TButton; + Button2: TButton; + PaxJavaScriptLanguage1: TPaxJavaScriptLanguage; + procedure Button1Click(Sender: TObject); + procedure Button2Click(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.dfm} + +procedure TForm1.Button1Click(Sender: TObject); +var + I, t: Integer; +begin + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxJavaScriptLanguage1); + + PaxCompiler1.AddModule('1', 'JavaScript'); + PaxCompiler1.AddCode('1', Memo1.Lines.Text); + if PaxCompiler1.Compile(PaxProgram1) then + begin + t := GetTickCount(); + PaxProgram1.Run; + t := GetTickCount() - t; + ShowMessage(IntToStr(t)); + end + else + for I:=0 to PaxCompiler1.ErrorCount - 1 do + ShowMessage(PaxCompiler1.ErrorMessage[I]); +end; + +procedure TForm1.Button2Click(Sender: TObject); +var + t, i, j: Integer; + c: TComponent; +begin + t := GetTickCount(); + c := TComponent.Create(nil); + for i := 0 to 500000 do + if c.Tag = 0 then + begin + c.Tag := 0; + c.Name := 'a'; + end; + c.Free; + t := GetTickCount() - t; + ShowMessage(IntToStr(t)); +end; + +var + H: Integer; +initialization + H := RegisterClassType(0, TComponent); + RegisterHeader(H, 'constructor Create(AOwner: TComponent); virtual;', @TComponent.Create); +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/Breakpoints/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/Breakpoints/Project1.dpr new file mode 100644 index 0000000..513a1dd --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/Breakpoints/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/Breakpoints/Project1.res b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/Breakpoints/Project1.res new file mode 100644 index 0000000..3adc036 Binary files /dev/null and b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/Breakpoints/Project1.res differ diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/Breakpoints/Unit1.dfm b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/Breakpoints/Unit1.dfm new file mode 100644 index 0000000..8ec8742 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/Breakpoints/Unit1.dfm @@ -0,0 +1,114 @@ +object Form1: TForm1 + Left = 192 + Top = 114 + Width = 651 + Height = 306 + Caption = 'Form1' + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + PixelsPerInch = 96 + TextHeight = 13 + object Label1: TLabel + Left = 24 + Top = 8 + Width = 52 + Height = 24 + Caption = 'Script:' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -19 + Font.Name = 'MS Sans Serif' + Font.Style = [] + ParentFont = False + end + object Label3: TLabel + Left = 288 + Top = 48 + Width = 182 + Height = 24 + Caption = 'Add breakpoint at line' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -19 + Font.Name = 'MS Sans Serif' + Font.Style = [] + ParentFont = False + end + object Memo1: TMemo + Left = 16 + Top = 40 + Width = 185 + Height = 177 + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -16 + Font.Name = 'MS Sans Serif' + Font.Style = [] + Lines.Strings = ( + ' print("A"); // line 0' + ' print("B"); // line 1' + ' print("C"); // line 2' + ' print("D"); // line 3' + ' print("E"); // line 4' + '') + ParentFont = False + TabOrder = 0 + end + object Edit1: TEdit + Left = 480 + Top = 48 + Width = 41 + Height = 28 + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -16 + Font.Name = 'MS Sans Serif' + Font.Style = [] + ParentFont = False + TabOrder = 1 + Text = '2' + end + object Button1: TButton + Left = 317 + Top = 128 + Width = 153 + Height = 49 + Caption = 'Run script' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -19 + Font.Name = 'MS Sans Serif' + Font.Style = [] + ParentFont = False + TabOrder = 2 + OnClick = Button1Click + end + object PaxCompiler1: TPaxCompiler + Alignment = 1 + DebugMode = False + Left = 296 + Top = 192 + end + object PaxProgram1: TPaxProgram + Console = False + Left = 400 + Top = 192 + end + object PaxCompilerDebugger1: TPaxCompilerDebugger + Left = 456 + Top = 192 + end + object PaxCompilerExplorer1: TPaxCompilerExplorer + Left = 520 + Top = 200 + end + object PaxJavaScriptLanguage1: TPaxJavaScriptLanguage + Left = 344 + Top = 192 + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/Breakpoints/Unit1.pas b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/Breakpoints/Unit1.pas new file mode 100644 index 0000000..b4068f9 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/Breakpoints/Unit1.pas @@ -0,0 +1,73 @@ +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, PaxProgram, PaxCompiler, PaxCompilerDebugger, + PaxRegister, + PaxCompilerExplorer, PaxJavaScriptLanguage, PaxRunner; + +type + TForm1 = class(TForm) + Memo1: TMemo; + Label1: TLabel; + Edit1: TEdit; + Label3: TLabel; + Button1: TButton; + PaxCompiler1: TPaxCompiler; + PaxProgram1: TPaxProgram; + PaxCompilerDebugger1: TPaxCompilerDebugger; + PaxCompilerExplorer1: TPaxCompilerExplorer; + PaxJavaScriptLanguage1: TPaxJavaScriptLanguage; + procedure Button1Click(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.dfm} + +procedure TForm1.Button1Click(Sender: TObject); +var + I: Integer; + Breakpoint: Integer; +begin + Breakpoint := StrToInt(Edit1.Text); + + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxJavaScriptLanguage1); + + PaxCompiler1.AddModule('1', PaxJavaScriptLanguage1.LanguageName); + PaxCompiler1.AddCode('1', Memo1.Lines.Text); + + PaxCompiler1.DebugMode := true; + + if PaxCompiler1.Compile(PaxProgram1) then + begin + PaxCompilerExplorer1.RegisterCompiler(PaxCompiler1); + PaxCompilerDebugger1.RegisterCompiler(PaxCompiler1, PaxProgram1); + if PaxCompilerExplorer1.IsExecutableLine('1', Breakpoint) then + PaxCompilerDebugger1.AddBreakpoint('1', Breakpoint); + + PaxCompilerDebugger1.Run; + while PaxCompilerDebugger1.IsPaused do + begin + ShowMessage('Program has been paused at breakpoint: ' + + IntToStr(PaxCompilerDebugger1.SourceLineNumber)); + + PaxProgram1.Run; + end; + end + else + for I:=0 to PaxCompiler1.ErrorCount - 1 do + ShowMessage(PaxCompiler1.ErrorMessage[I]); +end; + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/CallRoutine/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/CallRoutine/Project1.dpr new file mode 100644 index 0000000..513a1dd --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/CallRoutine/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/CallRoutine/Project1.res b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/CallRoutine/Project1.res new file mode 100644 index 0000000..3adc036 Binary files /dev/null and b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/CallRoutine/Project1.res differ diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/CallRoutine/Unit1.dfm b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/CallRoutine/Unit1.dfm new file mode 100644 index 0000000..dce0f8e --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/CallRoutine/Unit1.dfm @@ -0,0 +1,41 @@ +object Form1: TForm1 + Left = 192 + Top = 114 + Width = 246 + Height = 158 + Caption = 'Call routine demo' + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + OnCreate = FormCreate + PixelsPerInch = 96 + TextHeight = 13 + object Button1: TButton + Left = 40 + Top = 72 + Width = 121 + Height = 25 + Caption = 'Call ' + TabOrder = 0 + OnClick = Button1Click + end + object PaxCompiler1: TPaxCompiler + Alignment = 1 + DebugMode = False + Left = 32 + Top = 16 + end + object PaxProgram1: TPaxProgram + Console = False + Left = 112 + Top = 16 + end + object PaxJavaScriptLanguage1: TPaxJavaScriptLanguage + Left = 192 + Top = 64 + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/CallRoutine/Unit1.pas b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/CallRoutine/Unit1.pas new file mode 100644 index 0000000..e98934e --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/CallRoutine/Unit1.pas @@ -0,0 +1,73 @@ +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, PaxCompiler, PaxProgram, PaxRegister, PaxJavaScriptLanguage, + PaxRunner; +type + TForm1 = class(TForm) + PaxCompiler1: TPaxCompiler; + PaxProgram1: TPaxProgram; + Button1: TButton; + PaxJavaScriptLanguage1: TPaxJavaScriptLanguage; + procedure Button1Click(Sender: TObject); + procedure FormCreate(Sender: TObject); + private + Y: Integer; + { Private declarations } + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.dfm} + +uses + PAXCOMP_JavaScript; + +procedure TForm1.Button1Click(Sender: TObject); +var + I: Integer; + P: Pointer; + V: Variant; + F: TJS_Function; +begin +{$O-} + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxJavaScriptLanguage1); + + PaxCompiler1.RegisterVariable(0, 'Y', _typeINTEGER, @Y); + + PaxCompiler1.AddModule('1', PaxJavaScriptLanguage1.LanguageName); + PaxCompiler1.AddCode('1', 'function P(U, V)'); + PaxCompiler1.AddCode('1', '{'); + PaxCompiler1.AddCode('1', ' Y = Y + U + V;'); + PaxCompiler1.AddCode('1', ' return Y;'); + PaxCompiler1.AddCode('1', '}'); + + if PaxCompiler1.Compile(PaxProgram1) then + begin + PaxProgram1.Run; // to create Function objects + + P := PaxProgram1.GetAddress('P'); + F := TJS_Function(P^); + V := F.Invoke([10, 20]); + ShowMessage(IntToStr(Y)); + end + else + for I:=0 to PaxCompiler1.ErrorCount do + ShowMessage(PaxCompiler1.ErrorMessage[I]); +end; + +procedure TForm1.FormCreate(Sender: TObject); +begin + Y := 5; +end; + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/CodeComplet/MyUnit.pas b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/CodeComplet/MyUnit.pas new file mode 100644 index 0000000..69332a4 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/CodeComplet/MyUnit.pas @@ -0,0 +1,14 @@ +unit MyUnit; +interface +type + TMyClass = class + X, Y: Integer; + end; +var + I: Integer; +const + S = 'abc'; + +implementation + J: Integer; +end. \ No newline at end of file diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/CodeComplet/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/CodeComplet/Project1.dpr new file mode 100644 index 0000000..5769e8a --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/CodeComplet/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form3}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm3, Form3); + Application.Run; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/CodeComplet/Project1.res b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/CodeComplet/Project1.res new file mode 100644 index 0000000..3adc036 Binary files /dev/null and b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/CodeComplet/Project1.res differ diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/CodeComplet/Unit1.dfm b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/CodeComplet/Unit1.dfm new file mode 100644 index 0000000..ad431c7 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/CodeComplet/Unit1.dfm @@ -0,0 +1,51 @@ +object Form3: TForm3 + Left = 0 + Top = 0 + Width = 684 + Height = 194 + Caption = 'Code completion demo' + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -10 + Font.Name = 'Tahoma' + Font.Style = [] + OldCreateOrder = False + PixelsPerInch = 96 + TextHeight = 12 + object Button1: TButton + Left = 18 + Top = 12 + Width = 56 + Height = 19 + Caption = 'Create' + TabOrder = 0 + OnClick = Button1Click + end + object Memo1: TMemo + Left = 156 + Top = 6 + Width = 463 + Height = 143 + TabOrder = 1 + end + object PaxCompiler1: TPaxCompiler + Alignment = 1 + DebugMode = False + Left = 24 + Top = 48 + end + object PaxCompilerExplorer1: TPaxCompilerExplorer + Left = 80 + Top = 88 + end + object PaxProgram1: TPaxProgram + Console = False + Left = 16 + Top = 96 + end + object PaxJavaScriptLanguage1: TPaxJavaScriptLanguage + Left = 112 + Top = 48 + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/CodeComplet/Unit1.pas b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/CodeComplet/Unit1.pas new file mode 100644 index 0000000..a7a6b02 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/CodeComplet/Unit1.pas @@ -0,0 +1,55 @@ +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, + Dialogs, PaxCompiler, StdCtrls, PaxCompilerExplorer, PaxProgram, + PaxJavaScriptLanguage, PaxRunner; + +type + TForm3 = class(TForm) + Button1: TButton; + PaxCompiler1: TPaxCompiler; + PaxCompilerExplorer1: TPaxCompilerExplorer; + PaxProgram1: TPaxProgram; + Memo1: TMemo; + PaxJavaScriptLanguage1: TPaxJavaScriptLanguage; + procedure Button1Click(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + end; + +var + Form3: TForm3; + +implementation + +{$R *.dfm} + +procedure TForm3.Button1Click(Sender: TObject); +var + L: TStringList; +begin + L := TStringList.Create; + try + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxJavaScriptLanguage1); + PaxCompiler1.AddModule('1', 'JavaScript'); + PaxCompiler1.AddCodeFromFile('1', 'script.txt'); + if PaxCompiler1.CodeCompletion('1', 19, 6, Memo1.Lines) then + begin + //ok + end + else + ShowMessage(PaxCompiler1.ErrorMessage[0]); + finally + L.Free; + end; +end; + +initialization setdump; + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/CodeComplet/script.txt b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/CodeComplet/script.txt new file mode 100644 index 0000000..0cfa935 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/CodeComplet/script.txt @@ -0,0 +1,7 @@ +// x=19, y=6 +function fact(n) +{ + if (n == 1) + return 1; + else + return n * fact( diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/DebugDemo/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/DebugDemo/Project1.dpr new file mode 100644 index 0000000..cebc69a --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/DebugDemo/Project1.dpr @@ -0,0 +1,15 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}, + Unit2 in 'Unit2.pas' {Form2}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.CreateForm(TForm2, Form2); + Application.Run; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/DebugDemo/Project1.res b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/DebugDemo/Project1.res new file mode 100644 index 0000000..3adc036 Binary files /dev/null and b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/DebugDemo/Project1.res differ diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/DebugDemo/Unit1.dfm b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/DebugDemo/Unit1.dfm new file mode 100644 index 0000000..b775156 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/DebugDemo/Unit1.dfm @@ -0,0 +1,182 @@ +object Form1: TForm1 + Left = 209 + Top = 111 + Width = 674 + Height = 643 + Caption = 'DebugDemo' + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + OnCloseQuery = FormCloseQuery + PixelsPerInch = 96 + TextHeight = 13 + object Label1: TLabel + Left = 24 + Top = 8 + Width = 52 + Height = 24 + Caption = 'Script:' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -19 + Font.Name = 'MS Sans Serif' + Font.Style = [] + ParentFont = False + end + object Label2: TLabel + Left = 7 + Top = 246 + Width = 54 + Height = 24 + Caption = 'Trace:' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -19 + Font.Name = 'MS Sans Serif' + Font.Style = [] + ParentFont = False + end + object Memo1: TMemo + Left = 16 + Top = 40 + Width = 362 + Height = 193 + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -15 + Font.Name = 'MS Sans Serif' + Font.Style = [] + Lines.Strings = ( + 'function fact(n)' + '{' + ' if (n == 1)' + ' return 1;' + ' else' + ' return n * fact(n - 1);' + '}' + 'var ss;' + 'ss = fact(3);' + 'print(ss);' + '') + ParentFont = False + TabOrder = 0 + end + object Memo2: TMemo + Left = 16 + Top = 274 + Width = 362 + Height = 323 + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -15 + Font.Name = 'MS Sans Serif' + Font.Style = [] + Lines.Strings = ( + '') + ParentFont = False + TabOrder = 1 + end + object Button1: TButton + Left = 392 + Top = 25 + Width = 193 + Height = 49 + Caption = 'Compile' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -19 + Font.Name = 'MS Sans Serif' + Font.Style = [] + ParentFont = False + TabOrder = 2 + OnClick = Button1Click + end + object Button2: TButton + Left = 392 + Top = 89 + Width = 193 + Height = 49 + Caption = 'Run' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -19 + Font.Name = 'MS Sans Serif' + Font.Style = [] + ParentFont = False + TabOrder = 3 + OnClick = Button2Click + end + object Button3: TButton + Left = 392 + Top = 155 + Width = 193 + Height = 49 + Caption = 'Trace Into' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -19 + Font.Name = 'MS Sans Serif' + Font.Style = [] + ParentFont = False + TabOrder = 4 + OnClick = Button3Click + end + object Button4: TButton + Left = 392 + Top = 220 + Width = 193 + Height = 50 + Caption = 'Step Over' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -19 + Font.Name = 'MS Sans Serif' + Font.Style = [] + ParentFont = False + TabOrder = 5 + OnClick = Button4Click + end + object Button5: TButton + Left = 392 + Top = 275 + Width = 193 + Height = 48 + Caption = 'Run to Cursor' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -19 + Font.Name = 'MS Sans Serif' + Font.Style = [] + ParentFont = False + TabOrder = 6 + OnClick = Button5Click + end + object PaxCompiler1: TPaxCompiler + Alignment = 1 + DebugMode = False + Left = 544 + Top = 440 + end + object PaxProgram1: TPaxProgram + Console = False + OnPauseUpdated = PaxProgram1PauseUpdated + Left = 456 + Top = 408 + end + object PaxCompilerDebugger1: TPaxCompilerDebugger + Left = 472 + Top = 352 + end + object PaxCompilerExplorer1: TPaxCompilerExplorer + Left = 544 + Top = 360 + end + object PaxJavaScriptLanguage1: TPaxJavaScriptLanguage + Left = 472 + Top = 496 + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/DebugDemo/Unit1.pas b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/DebugDemo/Unit1.pas new file mode 100644 index 0000000..f4b538d --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/DebugDemo/Unit1.pas @@ -0,0 +1,334 @@ +{$O-} +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, PaxProgram, PaxCompiler, PaxCompilerDebugger, + PaxRegister, + PaxCompilerExplorer, PaxJavaScriptLanguage, PaxRunner; + +type + TForm1 = class(TForm) + Memo1: TMemo; + Memo2: TMemo; + Label1: TLabel; + Label2: TLabel; + Button1: TButton; + PaxCompiler1: TPaxCompiler; + PaxProgram1: TPaxProgram; + Button2: TButton; + Button3: TButton; + Button4: TButton; + Button5: TButton; + PaxCompilerDebugger1: TPaxCompilerDebugger; + PaxCompilerExplorer1: TPaxCompilerExplorer; + PaxJavaScriptLanguage1: TPaxJavaScriptLanguage; + procedure Button1Click(Sender: TObject); + procedure Button2Click(Sender: TObject); + procedure Button3Click(Sender: TObject); + procedure Button4Click(Sender: TObject); + procedure Button5Click(Sender: TObject); + procedure PaxProgram1PauseUpdated(Sender: TPaxRunner; + const ModuleName: string; SourceLineNumber: Integer); + procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean); + private + { Private declarations } + ResumeRequest: Boolean; + CloseRequest: Boolean; + procedure UpdateDebugInfo; + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +uses Unit2; + +{$R *.dfm} + +procedure TForm1.Button1Click(Sender: TObject); +var + I: Integer; +begin + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxJavaScriptLanguage1); + PaxCompiler1.AddModule('1', PaxJavaScriptLanguage1.LanguageName); + PaxCompiler1.AddCode('1', Memo1.Lines.Text); + PaxCompiler1.DebugMode := true; + if PaxCompiler1.Compile(PaxProgram1) then + begin + ShowMessage('Script has been successfully recompiled.'); + PaxCompilerExplorer1.RegisterCompiler(PaxCompiler1); + PaxCompilerDebugger1.RegisterCompiler(PaxCompiler1, PaxProgram1); + end + else + for I:=0 to PaxCompiler1.ErrorCount - 1 do + ShowMessage(PaxCompiler1.ErrorMessage[I]); +end; + +procedure TForm1.Button2Click(Sender: TObject); +begin + if not PaxCompilerDebugger1.Valid then + begin + ShowMessage('You have to compile script. Press "Compile" button.'); + Exit; + end; + PaxCompilerDebugger1.RunMode := _rmRUN; + if PaxCompilerDebugger1.IsPaused then + ResumeRequest := true + else + PaxCompilerDebugger1.Run; +end; + +procedure TForm1.Button3Click(Sender: TObject); +begin + PaxCompilerDebugger1.RunMode := _rmTRACE_INTO; + if PaxCompilerDebugger1.IsPaused then + ResumeRequest := true + else + PaxCompilerDebugger1.Run; +end; + +procedure TForm1.Button4Click(Sender: TObject); +begin + PaxCompilerDebugger1.RunMode := _rmSTEP_OVER; + if PaxCompilerDebugger1.IsPaused then + ResumeRequest := true + else + PaxCompilerDebugger1.Run; +end; + +procedure TForm1.Button5Click(Sender: TObject); +begin + if not PaxCompilerDebugger1.Valid then + begin + ShowMessage('You have to compile script. Press "Compile" button.'); + Exit; + end; + + Form2.ShowModal; + + PaxCompilerDebugger1.RunMode := _rmRUN_TO_CURSOR; + if PaxCompilerDebugger1.IsPaused then + ResumeRequest := true + else + PaxCompilerDebugger1.Run; +end; + +procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean); +begin + CanClose := true; + CloseRequest := true; +end; + +procedure TForm1.PaxProgram1PauseUpdated(Sender: TPaxRunner; + const ModuleName: string; SourceLineNumber: Integer); +begin + UpdateDebugInfo; + ResumeRequest := false; + repeat + Application.ProcessMessages; + if ResumeRequest then + Break; + if CloseRequest then + Abort; + until false; +end; + +procedure TForm1.UpdateDebugInfo; + + procedure AddFields(StackFrameNumber, Id: Integer); + var + I, K: Integer; + OwnerName, S: String; + begin + K := PaxCompilerExplorer1.GetFieldCount(Id); + if K = 0 then + Exit; + + OwnerName := PaxCompilerExplorer1.Names[Id]; + if PaxCompilerDebugger1.GetValueAsString(Id) = 'nil' then + Exit; + + for I:=0 to K - 1 do + begin + S := OwnerName + '.' + PaxCompilerExplorer1.GetFieldName(Id, I); + S := ' ' + S + '=' + PaxCompilerDebugger1.GetFieldValueAsString( + StackFrameNumber, Id, I); + Memo2.Lines.Add(S); + end; + end; + + procedure AddPublishedProps(StackFrameNumber, Id: Integer); + var + I, K: Integer; + OwnerName, S: String; + begin + K := PaxCompilerExplorer1.GetPublishedPropCount(Id); + if K = 0 then + Exit; + + OwnerName := PaxCompilerExplorer1.Names[Id]; + if PaxCompilerDebugger1.GetValueAsString(Id) = 'nil' then + Exit; + + for I:=0 to K - 1 do + begin + S := OwnerName + '.' + PaxCompilerExplorer1.GetPublishedPropName(Id, I); + S := ' ' + S + '=' + PaxCompilerDebugger1.GetPublishedPropValueAsString( + StackFrameNumber, Id, I); + Memo2.Lines.Add(S); + end; + end; + + procedure AddArrayElements(StackFrameNumber, Id: Integer); + var + I, K1, K2: Integer; + OwnerName, S: String; + begin + if not PaxCompilerExplorer1.HasArrayType(Id) then + Exit; + + K1 := PaxCompilerExplorer1.GetArrayLowBound(Id); + K2 := PaxCompilerExplorer1.GetArrayHighBound(Id); + + OwnerName := PaxCompilerExplorer1.Names[Id]; + + for I:=K1 to K2 do + begin + S := OwnerName + '[' + IntToStr(I) + ']'; + S := ' ' + S + '=' + PaxCompilerDebugger1.GetArrayItemValueAsString( + StackFrameNumber, Id, I); + Memo2.Lines.Add(S); + end; + end; + + procedure AddDynArrayElements(StackFrameNumber, Id: Integer); + var + I, L: Integer; + OwnerName, S: String; + begin + if not PaxCompilerExplorer1.HasDynArrayType(Id) then + Exit; + + L := PaxCompilerDebugger1.GetDynArrayLength(StackFrameNumber, Id); + + OwnerName := PaxCompilerExplorer1.Names[Id]; + + for I:=0 to L - 1 do + begin + S := OwnerName + '[' + IntToStr(I) + ']'; + S := ' ' + S + '=' + PaxCompilerDebugger1.GetDynArrayItemValueAsString( + StackFrameNumber, Id, I); + Memo2.Lines.Add(S); + end; + end; + +var + SourceLineNumber: Integer; + ModuleName: String; + StackFrameNumber, J, K, SubId, Id: Integer; + S, V: String; + CallStackLineNumber: Integer; + CallStackModuleName: String; +begin + Memo2.Lines.Clear; + if PaxCompilerDebugger1.IsPaused then + begin + ModuleName := PaxCompilerDebugger1.ModuleName; + SourceLineNumber := PaxCompilerDebugger1.SourceLineNumber; + + if SourceLineNumber >= PaxCompiler1.Modules[ModuleName].Count then + Exit; + + Memo2.Lines.Add('Paused at line ' + IntTosTr(SourceLineNumber)); + Memo2.Lines.Add(PaxCompiler1.Modules[ModuleName][SourceLineNumber]); + Memo2.Lines.Add('------------------------------------------------------'); + + if PaxCompilerDebugger1.CallStackCount > 0 then + begin + Memo2.Lines.Add('Call stack:'); + for StackFrameNumber:=0 to PaxCompilerDebugger1.CallStackCount - 1 do + begin + SubId := PaxCompilerDebugger1.CallStack[StackFrameNumber]; + S := '('; + K := PaxCompilerExplorer1.GetParamCount(SubId); + for J:=0 to K - 1 do + begin + Id := PaxCompilerExplorer1.GetParamId(SubId, J); + V := PaxCompilerDebugger1.GetValueAsString(StackFrameNumber, Id); + S := S + V; + if J < K - 1 then + S := S + ','; + end; + S := PaxCompilerExplorer1.Names[SubId] + S + ')'; + + CallStackLineNumber := PaxCompilerDebugger1.CallStackLineNumber[StackFrameNumber]; + CallStackModuleName := PaxCompilerDebugger1.CallStackModuleName[StackFrameNumber]; + + S := S + '; // ' + PaxCompiler1.Modules[CallStackModuleName][CallStackLineNumber]; + + Memo2.Lines.Add(S); + end; + Memo2.Lines.Add('------------------------------------------------------'); + + Memo2.Lines.Add('Local scope:'); + StackFrameNumber := PaxCompilerDebugger1.CallStackCount - 1; + SubId := PaxCompilerDebugger1.CallStack[StackFrameNumber]; + K := PaxCompilerExplorer1.GetLocalCount(SubId); + for J:=0 to K - 1 do + begin + Id := PaxCompilerExplorer1.GetLocalId(SubId, J); + V := PaxCompilerDebugger1.GetValueAsString(StackFrameNumber, Id); + S := PaxCompilerExplorer1.Names[Id] + '=' + V; + Memo2.Lines.Add(S); + + if Pos('X', S) > 0 then + begin + PaxCompilerDebugger1.PutValue(StackFrameNumber, Id, 258); + + V := PaxCompilerDebugger1.GetValueAsString(StackFrameNumber, Id); + S := PaxCompilerExplorer1.Names[Id] + '=' + V; + S := S + ' // modified'; + Memo2.Lines.Add(S); + end; + + AddFields(StackFrameNumber, Id); + AddPublishedProps(StackFrameNumber, Id); + AddArrayElements(StackFrameNumber, Id); + AddDynArrayElements(StackFrameNumber, Id); + end; + + Memo2.Lines.Add('------------------------------------------------------'); + end; + + Memo2.Lines.Add('Global scope:'); + K := PaxCompilerExplorer1.GetGlobalCount(0); + for J:=0 to K - 1 do + begin + Id := PaxCompilerExplorer1.GetGlobalId(0, J); + V := PaxCompilerDebugger1.GetValueAsString(Id); + S := PaxCompilerExplorer1.Names[Id] + '=' + V; + Memo2.Lines.Add(S); + + AddFields(0, Id); + AddPublishedProps(0, Id); + AddArrayElements(0, Id); + AddDynArrayElements(0, Id); + end; + Memo2.Lines.Add('------------------------------------------------------'); + + end + else + Memo2.Lines.Add('Finished'); + + Memo2.SelStart := 0; + Memo2.SelLength := 0; +end; + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/DebugDemo/Unit2.dfm b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/DebugDemo/Unit2.dfm new file mode 100644 index 0000000..c01f34c --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/DebugDemo/Unit2.dfm @@ -0,0 +1,43 @@ +object Form2: TForm2 + Left = 551 + Top = 252 + Width = 384 + Height = 345 + Caption = 'Select line' + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + PixelsPerInch = 96 + TextHeight = 13 + object Panel1: TPanel + Left = 0 + Top = 270 + Width = 376 + Height = 41 + Align = alBottom + TabOrder = 0 + object Button1: TButton + Left = 8 + Top = 8 + Width = 75 + Height = 25 + Caption = 'Ok' + ModalResult = 1 + TabOrder = 0 + OnClick = Button1Click + end + end + object ListBox1: TListBox + Left = 0 + Top = 0 + Width = 376 + Height = 270 + Align = alClient + ItemHeight = 13 + TabOrder = 1 + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/DebugDemo/Unit2.pas b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/DebugDemo/Unit2.pas new file mode 100644 index 0000000..e1e87d9 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/DebugDemo/Unit2.pas @@ -0,0 +1,65 @@ +unit Unit2; + +interface + +uses + Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, ExtCtrls; + +type + TForm2 = class(TForm) + Panel1: TPanel; + ListBox1: TListBox; + Button1: TButton; + procedure Button1Click(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + function ShowModal: Integer; override; + end; + +var + Form2: TForm2; + +implementation + +uses Unit1; + +{$R *.dfm} + +function TForm2.ShowModal: Integer; +var + I: Integer; + S: String; + ch: Char; +begin + ListBox1.Items.Clear; + for I:=0 to Form1.Memo1.Lines.Count - 1 do + begin + if Form1.PaxCompilerExplorer1.IsExecutableLine('1', I) then + ch := '*' + else + ch := ' '; + S := Format('%3d ', [I]) + ch + ' ' + Form1.Memo1.Lines[I]; + ListBox1.Items.Add(S); + end; + + result := inherited ShowModal; +end; + +procedure TForm2.Button1Click(Sender: TObject); +var + I: Integer; +begin + I := ListBox1.ItemIndex; + if Form1.PaxCompilerExplorer1.IsExecutableLine('1', I) then + Form1.PaxCompilerDebugger1.AddTempBreakpoint('1', I) + else + begin + ShowMessage(IntToStr(I) + ' is not executable line!'); + ModalResult := mrCancel; + end; +end; + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/EvalExpression/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/EvalExpression/Project1.dpr new file mode 100644 index 0000000..513a1dd --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/EvalExpression/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/EvalExpression/Project1.res b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/EvalExpression/Project1.res new file mode 100644 index 0000000..3adc036 Binary files /dev/null and b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/EvalExpression/Project1.res differ diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/EvalExpression/Unit1.dfm b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/EvalExpression/Unit1.dfm new file mode 100644 index 0000000..86c22b4 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/EvalExpression/Unit1.dfm @@ -0,0 +1,35 @@ +object Form1: TForm1 + Left = 192 + Top = 115 + Caption = 'Eval Expression' + ClientHeight = 115 + ClientWidth = 265 + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + OnCreate = FormCreate + PixelsPerInch = 96 + TextHeight = 13 + object Button1: TButton + Left = 24 + Top = 24 + Width = 201 + Height = 25 + Caption = 'Create compiled expression' + TabOrder = 0 + OnClick = Button1Click + end + object Button2: TButton + Left = 24 + Top = 64 + Width = 201 + Height = 25 + Caption = 'Evaluate expression' + TabOrder = 1 + OnClick = Button2Click + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/EvalExpression/Unit1.pas b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/EvalExpression/Unit1.pas new file mode 100644 index 0000000..cc48100 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/EvalExpression/Unit1.pas @@ -0,0 +1,116 @@ +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, PaxCompiler, PaxProgram, PaxRegister, + PaxJavaScriptLanguage; + +type + TForm1 = class(TForm) + Button1: TButton; + Button2: TButton; + procedure Button1Click(Sender: TObject); + procedure Button2Click(Sender: TObject); + procedure FormCreate(Sender: TObject); + private + { Private declarations } + arr_x, arr_y: array[1..3] of Double; + h_norm, h_x, h_y: Integer; + + buff: array[1..40960] of Byte; + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.dfm} + +function Norm(x, y: Double): Double; +begin + result := Sqrt(x * x + y * y); +end; + +procedure TForm1.Button1Click(Sender: TObject); +var + PaxCompiler1: TPaxCompiler; + PaxJavaScriptLanguage1: TPaxJavaScriptLanguage; + PaxProgram1: TPaxProgram; + I: Integer; +begin + PaxCompiler1 := TPaxCompiler.Create(nil); + PaxJavaScriptLanguage1 := TPaxJavaScriptLanguage.Create(nil); + PaxProgram1 := TPaxProgram.Create(nil); + + try + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxJavaScriptLanguage1); + + h_norm := PaxCompiler1.RegisterHeader(0, 'function Norm(x, y: Double): Double;'); + + h_x := PaxCompiler1.RegisterVariable(0, 'x', _typeDOUBLE); + h_y := PaxCompiler1.RegisterVariable(0, 'y', _typeDOUBLE); + + if PaxCompiler1.CompileExpression('Norm(x, y)', PaxProgram1) then + begin + PaxProgram1.SaveToBuff(buff); + ShowMessage('Compiled expression has been created!'); + end + else + for I:=0 to PaxCompiler1.ErrorCount - 1 do + ShowMessage(PaxCompiler1.ErrorMessage[I]); + finally + PaxCompiler1.Free; + PaxJavaScriptLanguage1.Free; + PaxProgram1.Free; + end; +end; + +procedure TForm1.Button2Click(Sender: TObject); +var + PaxProgram1: TPaxProgram; + ResValue: Double; + I: Integer; +begin +{$O-} + if h_x <> 0 then + begin + PaxProgram1 := TPaxProgram.Create(nil); + try + PaxProgram1.LoadFromBuff(buff); + + PaxProgram1.SetAddress(h_norm, @norm); + + for I:=1 to 3 do + begin + PaxProgram1.SetAddress(h_x, @arr_x[I]); + PaxProgram1.SetAddress(h_y, @arr_y[I]); + + PaxProgram1.Run; + + ResValue := Double(PaxProgram1.ResultPtr^); + ShowMessage(FloatToStr(ResValue)); + end; + + finally + PaxProgram1.Free; + end; + end + else + ShowMessage('Press the first button to create compiled script.'); +end; + +procedure TForm1.FormCreate(Sender: TObject); +begin + h_x := 0; h_y := 0; h_norm := 0; + arr_x[1] := 4.2; arr_y[1] := -5.2; + arr_x[2] := -0.4; arr_y[2] := 3.2; + arr_x[3] := 2.0; arr_y[3] := 3; +end; + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/Hello/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/Hello/Project1.dpr new file mode 100644 index 0000000..513a1dd --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/Hello/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/Hello/Project1.res b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/Hello/Project1.res new file mode 100644 index 0000000..3adc036 Binary files /dev/null and b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/Hello/Project1.res differ diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/Hello/Unit1.dfm b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/Hello/Unit1.dfm new file mode 100644 index 0000000..2efefbc --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/Hello/Unit1.dfm @@ -0,0 +1,40 @@ +object Form1: TForm1 + Left = 192 + Top = 114 + Width = 252 + Height = 172 + Caption = 'HelloApp' + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + PixelsPerInch = 96 + TextHeight = 13 + object Button1: TButton + Left = 32 + Top = 80 + Width = 75 + Height = 25 + Caption = 'Say "Hello"' + TabOrder = 0 + OnClick = Button1Click + end + object PaxCompiler1: TPaxCompiler + Alignment = 1 + DebugMode = False + Left = 48 + Top = 24 + end + object PaxProgram1: TPaxProgram + Console = False + Left = 144 + Top = 24 + end + object PaxJavaScriptLanguage1: TPaxJavaScriptLanguage + Left = 152 + Top = 72 + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/Hello/Unit1.pas b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/Hello/Unit1.pas new file mode 100644 index 0000000..6470bd1 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/Hello/Unit1.pas @@ -0,0 +1,49 @@ +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, PaxCompiler, PaxProgram, + PaxJavaScriptLanguage, PaxRunner; +type + TForm1 = class(TForm) + PaxCompiler1: TPaxCompiler; + PaxProgram1: TPaxProgram; + Button1: TButton; + PaxJavaScriptLanguage1: TPaxJavaScriptLanguage; + procedure Button1Click(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.dfm} + +procedure TForm1.Button1Click(Sender: TObject); +var + I, H_TButton: Integer; +begin + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxJavaScriptLanguage1); + + H_TButton := PaxCompiler1.RegisterClassType(0, TButton); + PaxCompiler1.RegisterVariable(0, 'Button1', H_TButton, @Button1); + + PaxCompiler1.AddModule('1', PaxJavaScriptLanguage1.LanguageName); + PaxCompiler1.AddCode('1', 'Button1.Caption = "Hello";'); + + if PaxCompiler1.Compile(PaxProgram1) then + PaxProgram1.Run + else + for I:=0 to PaxCompiler1.ErrorCount - 1 do + ShowMessage(PaxCompiler1.ErrorMessage[I]); +end; + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/LoadCompiledScript/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/LoadCompiledScript/Project1.dpr new file mode 100644 index 0000000..513a1dd --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/LoadCompiledScript/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/LoadCompiledScript/Project1.res b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/LoadCompiledScript/Project1.res new file mode 100644 index 0000000..3adc036 Binary files /dev/null and b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/LoadCompiledScript/Project1.res differ diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/LoadCompiledScript/Unit1.dfm b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/LoadCompiledScript/Unit1.dfm new file mode 100644 index 0000000..d9baf41 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/LoadCompiledScript/Unit1.dfm @@ -0,0 +1,35 @@ +object Form1: TForm1 + Left = 192 + Top = 114 + Width = 293 + Height = 207 + Caption = 'Load compiled script demo' + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + OnCreate = FormCreate + PixelsPerInch = 96 + TextHeight = 13 + object Button1: TButton + Left = 40 + Top = 40 + Width = 193 + Height = 25 + Caption = 'Compile script. Save compile script.' + TabOrder = 0 + OnClick = Button1Click + end + object Button2: TButton + Left = 40 + Top = 96 + Width = 193 + Height = 25 + Caption = 'Load compiled script. Run script.' + TabOrder = 1 + OnClick = Button2Click + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/LoadCompiledScript/Unit1.pas b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/LoadCompiledScript/Unit1.pas new file mode 100644 index 0000000..f65fe3d --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/LoadCompiledScript/Unit1.pas @@ -0,0 +1,118 @@ +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, PaxCompiler, PaxProgram, PaxRegister, PaxRunner, + PaxJavaScriptLanguage; +type + TForm1 = class(TForm) + Button1: TButton; + Button2: TButton; + procedure Button1Click(Sender: TObject); + procedure Button2Click(Sender: TObject); + procedure FormCreate(Sender: TObject); + private + H_ShowMessage: Integer; + H_S: Integer; + S: AnsiString; + { Private declarations } + procedure SaveToStreamHandler(Sender: TPaxRunner; Stream: TStream); + procedure LoadFromStreamHandler(Sender: TPaxRunner; Stream: TStream); + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.dfm} + +procedure TForm1.SaveToStreamHandler(Sender: TPaxRunner; Stream: TStream); +var + I: Byte; +begin + I := 5; + Stream.Write(I, 1); + ShowMessage('Saved custom data : ' + IntToStr(I)); +end; + +procedure TForm1.LoadFromStreamHandler(Sender: TPaxRunner; Stream: TStream); +var + I: Byte; +begin + Stream.Read(I, 1); + ShowMessage('Loaded custom data : ' + IntToStr(I)); +end; + +procedure TForm1.Button1Click(Sender: TObject); +var + I: Integer; + PaxCompiler1: TPaxCompiler; + PaxJavaScriptLanguage1: TPaxJavaScriptLanguage; + PaxProgram1: TPaxProgram; +begin + PaxCompiler1 := TPaxCompiler.Create(nil); + PaxJavaScriptLanguage1 := TPaxJavaScriptLanguage.Create(nil); + PaxProgram1 := TPaxProgram.Create(nil); + + try + PaxCompiler1.RegisterLanguage(PaxJavaScriptLanguage1); + + // register routine 'ShowMessage' + H_ShowMessage := PaxCompiler1.RegisterHeader(0, 'procedure ShowMessage(const Msg: string);'); + + // register variable 'S' + H_S := PaxCompiler1.RegisterVariable(0, 'S', _typeSTRING); + + PaxCompiler1.AddModule('1', PaxJavaScriptLanguage1.LanguageName); + PaxCompiler1.AddCode('1', 'ShowMessage(S);'); + + if PaxCompiler1.Compile(PaxProgram1) then + begin + PaxProgram1.OnSaveToStream := SaveToStreamHandler; + PaxProgram1.SaveToFile('1.bin'); + ShowMessage('Compiled script has been created!'); + end + else + for I:=0 to PaxCompiler1.ErrorCount - 1 do + ShowMessage(PaxCompiler1.ErrorMessage[I]); + finally + PaxCompiler1.Free; + PaxJavaScriptLanguage1.Free; + PaxProgram1.Free; + end; +end; + +procedure TForm1.Button2Click(Sender: TObject); +var + PaxProgram1: TPaxProgram; +begin + if FileExists('1.bin') and (H_ShowMessage <> 0) and (H_S <> 0) then + begin + PaxProgram1 := TPaxProgram.Create(nil); + try + PaxProgram1.OnLoadFromStream := LoadFromStreamHandler; + PaxProgram1.LoadFromFile('1.bin'); + PaxProgram1.SetAddress(H_ShowMessage, @ShowMessage); + PaxProgram1.SetAddress(H_S, @S); + PaxProgram1.Run; + finally + PaxProgram1.Free; + end; + end + else + ShowMessage('Press the first button to create compiled script.'); +end; + +procedure TForm1.FormCreate(Sender: TObject); +begin + H_ShowMessage := 0; + H_S := 0; + S := 'Hello'; +end; + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/RegisterVariable/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/RegisterVariable/Project1.dpr new file mode 100644 index 0000000..513a1dd --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/RegisterVariable/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/RegisterVariable/Project1.res b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/RegisterVariable/Project1.res new file mode 100644 index 0000000..3adc036 Binary files /dev/null and b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/RegisterVariable/Project1.res differ diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/RegisterVariable/Unit1.dfm b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/RegisterVariable/Unit1.dfm new file mode 100644 index 0000000..1ac3282 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/RegisterVariable/Unit1.dfm @@ -0,0 +1,40 @@ +object Form1: TForm1 + Left = 192 + Top = 114 + Width = 282 + Height = 178 + Caption = 'Register variable demo' + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + PixelsPerInch = 96 + TextHeight = 13 + object Button1: TButton + Left = 40 + Top = 80 + Width = 75 + Height = 25 + Caption = 'Run' + TabOrder = 0 + OnClick = Button1Click + end + object PaxCompiler1: TPaxCompiler + Alignment = 1 + DebugMode = False + Left = 32 + Top = 16 + end + object PaxProgram1: TPaxProgram + Console = False + Left = 128 + Top = 16 + end + object PaxJavaScriptLanguage1: TPaxJavaScriptLanguage + Left = 80 + Top = 16 + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/RegisterVariable/Unit1.pas b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/RegisterVariable/Unit1.pas new file mode 100644 index 0000000..d4b8391 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/JavaScript/RegisterVariable/Unit1.pas @@ -0,0 +1,68 @@ +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, PaxCompiler, PaxProgram, PaxRegister, PaxJavaScriptLanguage, + PaxRunner; + +type + TForm1 = class(TForm) + PaxCompiler1: TPaxCompiler; + PaxProgram1: TPaxProgram; + Button1: TButton; + PaxJavaScriptLanguage1: TPaxJavaScriptLanguage; + procedure Button1Click(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.dfm} + +type + TMyPoint = packed record + x, y: Integer; + end; + +procedure TForm1.Button1Click(Sender: TObject); +var + H_TMyPoint, H_MyPoint: Integer; + MyPoint: TMyPoint; + I: Integer; +begin + MyPoint.X := 60; + MyPoint.Y := 23; + + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxJavaScriptLanguage1); + + // register host-defined type + H_TMyPoint := PaxCompiler1.RegisterRecordType(0, 'TMyPoint'); + PaxCompiler1.RegisterRecordTypeField(H_TMyPoint, 'X', _typeINTEGER); + PaxCompiler1.RegisterRecordTypeField(H_TMyPoint, 'Y', _typeINTEGER); + + // register host-defined variable + H_MyPoint := PaxCompiler1.RegisterVariable(0, 'MyPoint', H_TMyPoint, @MyPoint); + + PaxCompiler1.AddModule('1', PaxJavaScriptLanguage1.LanguageName); + PaxCompiler1.AddCode('1', 'MyPoint.Y = 8;'); + + if PaxCompiler1.Compile(PaxProgram1) then + begin + PaxProgram1.Run; + ShowMessage(IntToStr(MyPoint.Y)); + end + else + for I:=0 to PaxCompiler1.ErrorCount do + ShowMessage(PaxCompiler1.ErrorMessage[I]); +end; + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/AccessToScriptVariables/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/AccessToScriptVariables/Project1.dpr new file mode 100644 index 0000000..513a1dd --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/AccessToScriptVariables/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/AccessToScriptVariables/Project1.res b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/AccessToScriptVariables/Project1.res new file mode 100644 index 0000000..3adc036 Binary files /dev/null and b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/AccessToScriptVariables/Project1.res differ diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/AccessToScriptVariables/Unit1.dfm b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/AccessToScriptVariables/Unit1.dfm new file mode 100644 index 0000000..3609329 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/AccessToScriptVariables/Unit1.dfm @@ -0,0 +1,45 @@ +object Form1: TForm1 + Left = 277 + Top = 120 + Width = 252 + Height = 172 + Caption = 'Access to script-defined variables' + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + PixelsPerInch = 96 + TextHeight = 13 + object Button1: TButton + Left = 32 + Top = 80 + Width = 75 + Height = 25 + Caption = 'Run' + TabOrder = 0 + OnClick = Button1Click + end + object PaxCompiler1: TPaxCompiler + Alignment = 1 + DebugMode = False + Left = 40 + Top = 24 + end + object PaxPascalLanguage1: TPaxPascalLanguage + ExplicitOff = False + CompleteBooleanEval = False + UnitLookup = True + PrintKeyword = 'print' + PrintlnKeyword = 'println' + Left = 88 + Top = 24 + end + object PaxProgram1: TPaxProgram + Console = False + Left = 168 + Top = 48 + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/AccessToScriptVariables/Unit1.pas b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/AccessToScriptVariables/Unit1.pas new file mode 100644 index 0000000..2605701 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/AccessToScriptVariables/Unit1.pas @@ -0,0 +1,60 @@ +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, PaxCompiler, PaxProgram, PaxRunner; +type + TForm1 = class(TForm) + Button1: TButton; + PaxCompiler1: TPaxCompiler; + PaxPascalLanguage1: TPaxPascalLanguage; + PaxProgram1: TPaxProgram; + procedure Button1Click(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.dfm} + +procedure TForm1.Button1Click(Sender: TObject); +var + P: Pointer; + I: Integer; +begin + {$O-} + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + + PaxCompiler1.RegisterHeader(0, 'procedure ShowMessage(const Msg: string);', @ShowMessage); + PaxCompiler1.RegisterHeader(0, 'function IntToStr(Value: Integer): string;', @IntToStr); + + PaxCompiler1.AddModule('1', PaxPascalLanguage1.LanguageName); + PaxCompiler1.AddCode('1', 'var x: Integer;'); + PaxCompiler1.AddCode('1', 'begin'); + PaxCompiler1.AddCode('1', ' ShowMessage(''script:'' + IntToStr(x));'); + PaxCompiler1.AddCode('1', 'end.'); + + if PaxCompiler1.Compile(PaxProgram1) then + begin + P := PaxProgram1.GetAddress('x'); + Integer(P^) := 5; // change script-defind variable + PaxProgram1.Run; // the first run + ShowMessage('host:' + IntToStr(Integer(P^))); // show script-defined var + Integer(P^) := 30; // change script-defind variable + PaxProgram1.Run; // the second run + end + else + for I:=0 to PaxCompiler1.ErrorCount do + ShowMessage(PaxCompiler1.ErrorMessage[I]); +end; + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/Benchmark1/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/Benchmark1/Project1.dpr new file mode 100644 index 0000000..513a1dd --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/Benchmark1/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/Benchmark1/Project1.res b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/Benchmark1/Project1.res new file mode 100644 index 0000000..3adc036 Binary files /dev/null and b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/Benchmark1/Project1.res differ diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/Benchmark1/Unit1.dfm b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/Benchmark1/Unit1.dfm new file mode 100644 index 0000000..7c8e041 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/Benchmark1/Unit1.dfm @@ -0,0 +1,54 @@ +object Form1: TForm1 + Left = 192 + Top = 114 + Width = 285 + Height = 203 + Caption = 'Benchmark 1' + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + PixelsPerInch = 96 + TextHeight = 13 + object Button1: TButton + Left = 32 + Top = 80 + Width = 121 + Height = 25 + Caption = 'paxCompiler' + TabOrder = 0 + OnClick = Button1Click + end + object Button2: TButton + Left = 32 + Top = 128 + Width = 121 + Height = 25 + Caption = 'Delphi' + TabOrder = 1 + OnClick = Button2Click + end + object PaxCompiler1: TPaxCompiler + Alignment = 8 + DebugMode = False + Left = 32 + Top = 24 + end + object PaxPascalLanguage1: TPaxPascalLanguage + ExplicitOff = False + CompleteBooleanEval = False + UnitLookup = True + PrintKeyword = 'print' + PrintlnKeyword = 'println' + Left = 72 + Top = 24 + end + object PaxProgram1: TPaxProgram + Console = False + Left = 112 + Top = 24 + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/Benchmark1/Unit1.pas b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/Benchmark1/Unit1.pas new file mode 100644 index 0000000..a160261 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/Benchmark1/Unit1.pas @@ -0,0 +1,93 @@ +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, PaxCompiler, PaxProgram, PaxRunner; + +type + TForm1 = class(TForm) + PaxCompiler1: TPaxCompiler; + PaxPascalLanguage1: TPaxPascalLanguage; + PaxProgram1: TPaxProgram; + Button1: TButton; + Button2: TButton; + procedure Button1Click(Sender: TObject); + procedure Button2Click(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.dfm} + +procedure TForm1.Button1Click(Sender: TObject); +var + I: Integer; + t: Integer; +begin + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + + PaxCompiler1.AddModule('1', PaxPascalLanguage1.LanguageName); + + PaxCompiler1.AddCode('1', 'procedure P();'); + PaxCompiler1.AddCode('1', 'var'); + PaxCompiler1.AddCode('1', ' d1, d2: Double;'); + PaxCompiler1.AddCode('1', ' I: Integer;'); + PaxCompiler1.AddCode('1', 'begin'); + PaxCompiler1.AddCode('1', ' d1 := 5.4;'); + PaxCompiler1.AddCode('1', ' d2 := 9009960.3;'); + PaxCompiler1.AddCode('1', ' I := 0;'); + PaxCompiler1.AddCode('1', ' while d1 < d2 do'); + PaxCompiler1.AddCode('1', ' begin'); + PaxCompiler1.AddCode('1', ' Inc(I);'); + PaxCompiler1.AddCode('1', ' d1 := d1 + 0.5;'); + PaxCompiler1.AddCode('1', ' end;'); + PaxCompiler1.AddCode('1', 'end;'); + PaxCompiler1.AddCode('1', 'begin'); + PaxCompiler1.AddCode('1', ' P();'); + PaxCompiler1.AddCode('1', 'end.'); + if PaxCompiler1.Compile(PaxProgram1) then + begin + t := GetTickCount; + PaxProgram1.Run; + ShowMessage(IntToStr(GetTickCount - t)); + end + else + for I:=0 to PaxCompiler1.ErrorCount - 1 do + ShowMessage(PaxCompiler1.ErrorMessage[I]); +end; + +procedure P(); +var + d1, d2: Double; + I: Integer; +begin + d1 := 5.4; + d2 := 9009960.3; + I := 0; + while d1 < d2 do + begin + Inc(I); + d1 := d1 + 0.5; + end; +end; + +procedure TForm1.Button2Click(Sender: TObject); +var + t: Integer; +begin + t := GetTickCount; + P; + ShowMessage(IntToStr(GetTickCount - t)); +end; + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/Benchmark2/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/Benchmark2/Project1.dpr new file mode 100644 index 0000000..513a1dd --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/Benchmark2/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/Benchmark2/Project1.res b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/Benchmark2/Project1.res new file mode 100644 index 0000000..3adc036 Binary files /dev/null and b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/Benchmark2/Project1.res differ diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/Benchmark2/Unit1.dfm b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/Benchmark2/Unit1.dfm new file mode 100644 index 0000000..c984675 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/Benchmark2/Unit1.dfm @@ -0,0 +1,54 @@ +object Form1: TForm1 + Left = 192 + Top = 114 + Width = 225 + Height = 197 + Caption = 'Benchmark 2' + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + PixelsPerInch = 96 + TextHeight = 13 + object Button1: TButton + Left = 24 + Top = 72 + Width = 75 + Height = 25 + Caption = 'PaxCompiler' + TabOrder = 0 + OnClick = Button1Click + end + object Button2: TButton + Left = 24 + Top = 120 + Width = 75 + Height = 25 + Caption = 'Delphi' + TabOrder = 1 + OnClick = Button2Click + end + object PaxCompiler1: TPaxCompiler + Alignment = 8 + DebugMode = False + Left = 24 + Top = 24 + end + object PaxPascalLanguage1: TPaxPascalLanguage + ExplicitOff = False + CompleteBooleanEval = False + UnitLookup = True + PrintKeyword = 'print' + PrintlnKeyword = 'println' + Left = 64 + Top = 24 + end + object PaxProgram1: TPaxProgram + Console = False + Left = 104 + Top = 24 + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/Benchmark2/Unit1.pas b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/Benchmark2/Unit1.pas new file mode 100644 index 0000000..c493de4 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/Benchmark2/Unit1.pas @@ -0,0 +1,71 @@ +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, + Dialogs, PaxCompiler, StdCtrls, PaxProgram, PaxRunner; + +type + TForm1 = class(TForm) + Button1: TButton; + Button2: TButton; + PaxCompiler1: TPaxCompiler; + PaxPascalLanguage1: TPaxPascalLanguage; + PaxProgram1: TPaxProgram; + procedure Button1Click(Sender: TObject); + procedure Button2Click(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.dfm} + +procedure TForm1.Button1Click(Sender: TObject); +var + I: Integer; + t: Integer; +begin + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + + PaxCompiler1.RegisterHeader(0, 'function IntToStr(Value: Integer): string;', @IntToStr); + PaxCompiler1.RegisterHeader(0, 'function StrToInt(const S: string): Integer;', @StrToInt); + + PaxCompiler1.AddModule('1', PaxPascalLanguage1.LanguageName); + + PaxCompiler1.AddCode('1', 'var I, K: Integer;'); + PaxCompiler1.AddCode('1', 'begin'); + PaxCompiler1.AddCode('1', ' for I:=1 to 200000 do'); + PaxCompiler1.AddCode('1', ' K := StrToInt(IntToStr(I));'); + PaxCompiler1.AddCode('1', 'end.'); + + if PaxCompiler1.Compile(PaxProgram1) then + begin + t := GetTickCount; + PaxProgram1.Run; + ShowMessage(IntToStr(GetTickCount - t)); + end + else + for I:=0 to PaxCompiler1.ErrorCount - 1 do + ShowMessage(PaxCompiler1.ErrorMessage[I]); +end; + +procedure TForm1.Button2Click(Sender: TObject); +var + I, K, t: Integer; +begin + t := GetTickCount; + for I:=1 to 200000 do + K := StrToInt(IntToStr(I)); + ShowMessage(IntToStr(GetTickCount - t)); +end; + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/Benchmark3/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/Benchmark3/Project1.dpr new file mode 100644 index 0000000..513a1dd --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/Benchmark3/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/Benchmark3/Project1.res b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/Benchmark3/Project1.res new file mode 100644 index 0000000..3adc036 Binary files /dev/null and b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/Benchmark3/Project1.res differ diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/Benchmark3/Unit1.dfm b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/Benchmark3/Unit1.dfm new file mode 100644 index 0000000..c984675 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/Benchmark3/Unit1.dfm @@ -0,0 +1,54 @@ +object Form1: TForm1 + Left = 192 + Top = 114 + Width = 225 + Height = 197 + Caption = 'Benchmark 2' + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + PixelsPerInch = 96 + TextHeight = 13 + object Button1: TButton + Left = 24 + Top = 72 + Width = 75 + Height = 25 + Caption = 'PaxCompiler' + TabOrder = 0 + OnClick = Button1Click + end + object Button2: TButton + Left = 24 + Top = 120 + Width = 75 + Height = 25 + Caption = 'Delphi' + TabOrder = 1 + OnClick = Button2Click + end + object PaxCompiler1: TPaxCompiler + Alignment = 8 + DebugMode = False + Left = 24 + Top = 24 + end + object PaxPascalLanguage1: TPaxPascalLanguage + ExplicitOff = False + CompleteBooleanEval = False + UnitLookup = True + PrintKeyword = 'print' + PrintlnKeyword = 'println' + Left = 64 + Top = 24 + end + object PaxProgram1: TPaxProgram + Console = False + Left = 104 + Top = 24 + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/Benchmark3/Unit1.pas b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/Benchmark3/Unit1.pas new file mode 100644 index 0000000..204c577 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/Benchmark3/Unit1.pas @@ -0,0 +1,84 @@ +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, + Dialogs, PaxCompiler, StdCtrls, PaxProgram, PaxRunner; + +type + TForm1 = class(TForm) + Button1: TButton; + Button2: TButton; + PaxCompiler1: TPaxCompiler; + PaxPascalLanguage1: TPaxPascalLanguage; + PaxProgram1: TPaxProgram; + procedure Button1Click(Sender: TObject); + procedure Button2Click(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.dfm} + +procedure TForm1.Button1Click(Sender: TObject); +var + I: Integer; + t: Integer; +begin + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + + PaxCompiler1.AddModule('1', PaxPascalLanguage1.LanguageName); + + PaxCompiler1.AddCode('1', 'function Fact(N: Integer): Integer;'); + PaxCompiler1.AddCode('1', 'begin'); + PaxCompiler1.AddCode('1', ' if N = 1 then'); + PaxCompiler1.AddCode('1', ' result := 1'); + PaxCompiler1.AddCode('1', ' else'); + PaxCompiler1.AddCode('1', ' result := N * Fact(N - 1);'); + PaxCompiler1.AddCode('1', 'end;'); + PaxCompiler1.AddCode('1', 'var'); + PaxCompiler1.AddCode('1', ' I: Integer;'); + PaxCompiler1.AddCode('1', 'begin'); + PaxCompiler1.AddCode('1', ' for I:=1 to 1000000 do'); + PaxCompiler1.AddCode('1', ' Fact(10);'); + PaxCompiler1.AddCode('1', 'end.'); + + if PaxCompiler1.Compile(PaxProgram1) then + begin + t := GetTickCount; + PaxProgram1.Run; + ShowMessage(IntToStr(GetTickCount - t)); + end + else + for I:=0 to PaxCompiler1.ErrorCount - 1 do + ShowMessage(PaxCompiler1.ErrorMessage[I]); +end; + +function Fact(N: Integer): Integer; +begin + if N = 1 then + result := 1 + else + result := N * Fact(N - 1); +end; + +procedure TForm1.Button2Click(Sender: TObject); +var + I, t: Integer; +begin + t := GetTickCount; + for I:=1 to 1000000 do + Fact(10); + ShowMessage(IntToStr(GetTickCount - t)); +end; + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/Benchmark4/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/Benchmark4/Project1.dpr new file mode 100644 index 0000000..513a1dd --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/Benchmark4/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/Benchmark4/Project1.res b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/Benchmark4/Project1.res new file mode 100644 index 0000000..3adc036 Binary files /dev/null and b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/Benchmark4/Project1.res differ diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/Benchmark4/Unit1.dfm b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/Benchmark4/Unit1.dfm new file mode 100644 index 0000000..5b5081c --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/Benchmark4/Unit1.dfm @@ -0,0 +1,75 @@ +object Form1: TForm1 + Left = 192 + Top = 114 + Width = 576 + Height = 447 + Caption = 'Benchmark 4' + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + PixelsPerInch = 96 + TextHeight = 13 + object Memo1: TMemo + Left = 16 + Top = 176 + Width = 513 + Height = 217 + Lines.Strings = ( + 'var' + ' i, j: Integer;' + ' c: TComponent;' + 'begin' + ' c := TComponent.Create(nil);' + ' for i := 0 to 500000 do' + ' if c.Tag = 0 then' + ' begin' + ' c.Tag := 0;' + ' c.Name := '#39'a'#39';' + ' end;' + ' c.Free;' + 'end.') + TabOrder = 0 + end + object Button1: TButton + Left = 224 + Top = 136 + Width = 75 + Height = 25 + Caption = 'PaxCompiler' + TabOrder = 1 + OnClick = Button1Click + end + object Button2: TButton + Left = 32 + Top = 136 + Width = 75 + Height = 25 + Caption = 'Delphi' + TabOrder = 2 + OnClick = Button2Click + end + object PaxCompiler1: TPaxCompiler + Alignment = 1 + DebugMode = False + Left = 72 + Top = 24 + end + object PaxPascalLanguage1: TPaxPascalLanguage + ExplicitOff = False + CompleteBooleanEval = False + UnitLookup = True + PrintKeyword = 'print' + PrintlnKeyword = 'println' + Left = 128 + Top = 24 + end + object PaxProgram1: TPaxProgram + Console = False + Left = 176 + Top = 24 + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/Benchmark4/Unit1.pas b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/Benchmark4/Unit1.pas new file mode 100644 index 0000000..bfbbf00 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/Benchmark4/Unit1.pas @@ -0,0 +1,76 @@ +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, PaxCompiler, PaxProgram, PaxRegister, PaxRunner; + +type + TForm1 = class(TForm) + PaxCompiler1: TPaxCompiler; + PaxPascalLanguage1: TPaxPascalLanguage; + PaxProgram1: TPaxProgram; + Memo1: TMemo; + Button1: TButton; + Button2: TButton; + procedure Button1Click(Sender: TObject); + procedure Button2Click(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.dfm} + +procedure TForm1.Button1Click(Sender: TObject); +var + I, t: Integer; +begin + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + + PaxCompiler1.AddModule('1', 'Pascal'); + PaxCompiler1.AddCode('1', Memo1.Lines.Text); + if PaxCompiler1.Compile(PaxProgram1) then + begin + t := GetTickCount(); + PaxProgram1.Run; + t := GetTickCount() - t; + ShowMessage(IntToStr(t)); + end + else + for I:=0 to PaxCompiler1.ErrorCount - 1 do + ShowMessage(PaxCompiler1.ErrorMessage[I]); +end; + +procedure TForm1.Button2Click(Sender: TObject); +var + t, i, j: Integer; + c: TComponent; +begin + t := GetTickCount(); + c := TComponent.Create(nil); + for i := 0 to 500000 do + if c.Tag = 0 then + begin + c.Tag := 0; + c.Name := 'a'; + end; + c.Free; + t := GetTickCount() - t; + ShowMessage(IntToStr(t)); +end; + +var + H: Integer; +initialization + H := RegisterClassType(0, TComponent); + RegisterHeader(H, 'constructor Create(AOwner: TComponent); virtual;', @TComponent.Create); +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/BindDFM/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/BindDFM/Project1.dpr new file mode 100644 index 0000000..513a1dd --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/BindDFM/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/BindDFM/Project1.res b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/BindDFM/Project1.res new file mode 100644 index 0000000..3adc036 Binary files /dev/null and b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/BindDFM/Project1.res differ diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/BindDFM/Unit1.dfm b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/BindDFM/Unit1.dfm new file mode 100644 index 0000000..f6c006e --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/BindDFM/Unit1.dfm @@ -0,0 +1,65 @@ +object Form1: TForm1 + Left = 358 + Top = 287 + Width = 442 + Height = 255 + Caption = 'Bind DFM file demo' + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'Tahoma' + Font.Style = [] + OldCreateOrder = False + PixelsPerInch = 96 + TextHeight = 13 + object Button1: TButton + Left = 8 + Top = 24 + Width = 75 + Height = 25 + Caption = 'Run Script' + TabOrder = 0 + OnClick = Button1Click + end + object Memo1: TMemo + Left = 112 + Top = 24 + Width = 281 + Height = 169 + Lines.Strings = ( + 'uses' + ' Unit2;' + 'begin' + ' Form2 := TForm2.Create(nil);' + ' try' + ' Form2.ShowModal;' + ' finally' + ' Form2.Free; ' + ' end;' + 'end.') + TabOrder = 1 + end + object PaxCompiler1: TPaxCompiler + Alignment = 1 + OnUnknownDirective = PaxCompiler1UnknownDirective + DebugMode = False + Left = 16 + Top = 56 + end + object PaxPascalLanguage1: TPaxPascalLanguage + ExplicitOff = False + CompleteBooleanEval = False + UnitLookup = True + PrintKeyword = 'print' + PrintlnKeyword = 'println' + Left = 16 + Top = 88 + end + object PaxProgram1: TPaxProgram + Console = False + OnCreateObject = PaxProgram1CreateObject + Left = 24 + Top = 128 + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/BindDFM/Unit1.pas b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/BindDFM/Unit1.pas new file mode 100644 index 0000000..332be6c --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/BindDFM/Unit1.pas @@ -0,0 +1,66 @@ +{$O-} +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, + Dialogs, PaxProgram, PaxCompiler, StdCtrls, PaxRunner; + +type + TForm1 = class(TForm) + Button1: TButton; + PaxCompiler1: TPaxCompiler; + PaxPascalLanguage1: TPaxPascalLanguage; + PaxProgram1: TPaxProgram; + Memo1: TMemo; + procedure Button1Click(Sender: TObject); + procedure PaxCompiler1UnknownDirective(Sender: TPaxCompiler; + const Directive: string; var ok: Boolean); + procedure PaxProgram1CreateObject(Sender: TPaxRunner; Instance: TObject); + private + CurrModule: String; + { Private declarations } + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.dfm} + +uses + IMPORT_Common; + +procedure TForm1.Button1Click(Sender: TObject); +begin + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + PaxCompiler1.AddModule('1', 'Pascal'); + PaxCompiler1.AddCode('1', Memo1.Lines.Text); + if PaxCompiler1.Compile(PaxProgram1) then + begin + PaxProgram1.Run; + end + else + ShowMessage(PaxCompiler1.ErrorMessage[0]); +end; + +procedure TForm1.PaxCompiler1UnknownDirective(Sender: TPaxCompiler; + const Directive: string; var ok: Boolean); +begin + ok := true; + CurrModule := Sender.CurrModuleName; +end; + +procedure TForm1.PaxProgram1CreateObject(Sender: TPaxRunner; + Instance: TObject); +begin + if Instance is TForm then + Sender.LoadDFMFile(Instance, CurrModule + '.dfm'); +end; + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/BindDFM/Unit2.dfm b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/BindDFM/Unit2.dfm new file mode 100644 index 0000000..da6204b --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/BindDFM/Unit2.dfm @@ -0,0 +1,26 @@ +object Form2: TForm2 + Left = 0 + Top = 0 + Caption = 'Form2' + ClientHeight = 216 + ClientWidth = 426 + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'Tahoma' + Font.Style = [] + OldCreateOrder = False + OnCreate = FormCreate + PixelsPerInch = 96 + TextHeight = 13 + object Button1: TButton + Left = 40 + Top = 88 + Width = 75 + Height = 25 + Caption = 'Button1' + TabOrder = 0 + OnClick = Button1Click + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/BindDFM/Unit2.pas b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/BindDFM/Unit2.pas new file mode 100644 index 0000000..211caa6 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/BindDFM/Unit2.pas @@ -0,0 +1,37 @@ +unit Unit2; + +interface + +uses + SysUtils, Variants, Classes, Controls, Forms, + Dialogs, StdCtrls; + +type + TForm2 = class(TForm) + Button1: TButton; + procedure FormCreate(Sender: TObject); + procedure Button1Click(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + end; + +var + Form2: TForm2; + +implementation + +{$R *.dfm} + +procedure TForm2.Button1Click(Sender: TObject); +begin + ShowMessage('Hello'); +end; + +procedure TForm2.FormCreate(Sender: TObject); +begin + ShowMessage('Created'); +end; + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/Breakpoints/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/Breakpoints/Project1.dpr new file mode 100644 index 0000000..513a1dd --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/Breakpoints/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/Breakpoints/Project1.res b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/Breakpoints/Project1.res new file mode 100644 index 0000000..3adc036 Binary files /dev/null and b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/Breakpoints/Project1.res differ diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/Breakpoints/Unit1.dfm b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/Breakpoints/Unit1.dfm new file mode 100644 index 0000000..623f1de --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/Breakpoints/Unit1.dfm @@ -0,0 +1,149 @@ +object Form1: TForm1 + Left = 192 + Top = 114 + Width = 651 + Height = 485 + Caption = 'Form1' + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + PixelsPerInch = 96 + TextHeight = 13 + object Label1: TLabel + Left = 24 + Top = 8 + Width = 52 + Height = 24 + Caption = 'Script:' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -19 + Font.Name = 'MS Sans Serif' + Font.Style = [] + ParentFont = False + end + object Label2: TLabel + Left = 24 + Top = 232 + Width = 61 + Height = 24 + Caption = 'Output:' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -19 + Font.Name = 'MS Sans Serif' + Font.Style = [] + ParentFont = False + end + object Label3: TLabel + Left = 288 + Top = 48 + Width = 182 + Height = 24 + Caption = 'Add breakpoint at line' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -19 + Font.Name = 'MS Sans Serif' + Font.Style = [] + ParentFont = False + end + object Memo1: TMemo + Left = 16 + Top = 40 + Width = 185 + Height = 177 + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -16 + Font.Name = 'MS Sans Serif' + Font.Style = [] + Lines.Strings = ( + 'begin // line 0' + ' print('#39'A'#39'); // line 1' + ' print('#39'B'#39'); // line 2' + ' print('#39'C'#39'); // line 3' + ' print('#39'D'#39'); // line 4' + ' print('#39'E'#39'); // line 5' + 'end. // line 6' + '') + ParentFont = False + TabOrder = 0 + end + object Memo2: TMemo + Left = 16 + Top = 256 + Width = 185 + Height = 169 + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -16 + Font.Name = 'MS Sans Serif' + Font.Style = [] + Lines.Strings = ( + '') + ParentFont = False + TabOrder = 1 + end + object Edit1: TEdit + Left = 480 + Top = 48 + Width = 41 + Height = 28 + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -16 + Font.Name = 'MS Sans Serif' + Font.Style = [] + ParentFont = False + TabOrder = 2 + Text = '2' + end + object Button1: TButton + Left = 304 + Top = 192 + Width = 153 + Height = 49 + Caption = 'Run script' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -19 + Font.Name = 'MS Sans Serif' + Font.Style = [] + ParentFont = False + TabOrder = 3 + OnClick = Button1Click + end + object PaxCompiler1: TPaxCompiler + Alignment = 1 + DebugMode = False + Left = 312 + Top = 304 + end + object PaxPascalLanguage1: TPaxPascalLanguage + ExplicitOff = False + CompleteBooleanEval = False + UnitLookup = True + PrintKeyword = 'print' + PrintlnKeyword = 'println' + Left = 360 + Top = 304 + end + object PaxProgram1: TPaxProgram + Console = False + Left = 400 + Top = 304 + end + object PaxCompilerDebugger1: TPaxCompilerDebugger + Left = 432 + Top = 304 + end + object PaxCompilerExplorer1: TPaxCompilerExplorer + Left = 472 + Top = 304 + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/Breakpoints/Unit1.pas b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/Breakpoints/Unit1.pas new file mode 100644 index 0000000..bc7d090 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/Breakpoints/Unit1.pas @@ -0,0 +1,85 @@ +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, PaxProgram, PaxCompiler, PaxCompilerDebugger, + PaxRegister, + PaxCompilerExplorer, PaxRunner; + +type + TForm1 = class(TForm) + Memo1: TMemo; + Memo2: TMemo; + Label1: TLabel; + Label2: TLabel; + Edit1: TEdit; + Label3: TLabel; + Button1: TButton; + PaxCompiler1: TPaxCompiler; + PaxPascalLanguage1: TPaxPascalLanguage; + PaxProgram1: TPaxProgram; + PaxCompilerDebugger1: TPaxCompilerDebugger; + PaxCompilerExplorer1: TPaxCompilerExplorer; + procedure Button1Click(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.dfm} + +procedure TForm1.Button1Click(Sender: TObject); +var + I: Integer; + Breakpoint: Integer; +begin + Memo2.Lines.Clear; + Breakpoint := StrToInt(Edit1.Text); + + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + + PaxCompiler1.AddModule('1', PaxPascalLanguage1.LanguageName); + PaxCompiler1.AddCode('1', Memo1.Lines.Text); + + PaxCompiler1.DebugMode := true; + + if PaxCompiler1.Compile(PaxProgram1) then + begin + PaxCompilerExplorer1.RegisterCompiler(PaxCompiler1); + PaxCompilerDebugger1.RegisterCompiler(PaxCompiler1, PaxProgram1); + if PaxCompilerExplorer1.IsExecutableLine('1', Breakpoint) then + PaxCompilerDebugger1.AddBreakpoint('1', Breakpoint); + + PaxCompilerDebugger1.Run; + while PaxCompilerDebugger1.IsPaused do + begin + ShowMessage('Program has been paused at breakpoint: ' + + IntToStr(PaxCompilerDebugger1.SourceLineNumber)); + + PaxProgram1.Run; + end; + end + else + for I:=0 to PaxCompiler1.ErrorCount - 1 do + ShowMessage(PaxCompiler1.ErrorMessage[I]); +end; + +procedure Print(C: Char); +begin + Form1.Memo2.Lines.Add(C); +end; + +initialization + +RegisterHeader(0, 'procedure Print(C: Char);', @Print); + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/CallRoutine/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/CallRoutine/Project1.dpr new file mode 100644 index 0000000..513a1dd --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/CallRoutine/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/CallRoutine/Project1.res b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/CallRoutine/Project1.res new file mode 100644 index 0000000..3adc036 Binary files /dev/null and b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/CallRoutine/Project1.res differ diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/CallRoutine/Unit1.dfm b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/CallRoutine/Unit1.dfm new file mode 100644 index 0000000..651f39f --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/CallRoutine/Unit1.dfm @@ -0,0 +1,46 @@ +object Form1: TForm1 + Left = 192 + Top = 114 + Width = 246 + Height = 158 + Caption = 'Call routine demo' + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + OnCreate = FormCreate + PixelsPerInch = 96 + TextHeight = 13 + object Button1: TButton + Left = 40 + Top = 72 + Width = 121 + Height = 25 + Caption = 'Call ' + TabOrder = 0 + OnClick = Button1Click + end + object PaxCompiler1: TPaxCompiler + Alignment = 1 + DebugMode = False + Left = 32 + Top = 16 + end + object PaxPascalLanguage1: TPaxPascalLanguage + ExplicitOff = False + CompleteBooleanEval = False + UnitLookup = True + PrintKeyword = 'print' + PrintlnKeyword = 'println' + Left = 72 + Top = 16 + end + object PaxProgram1: TPaxProgram + Console = False + Left = 112 + Top = 16 + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/CallRoutine/Unit1.pas b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/CallRoutine/Unit1.pas new file mode 100644 index 0000000..714fa3b --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/CallRoutine/Unit1.pas @@ -0,0 +1,75 @@ +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, PaxCompiler, PaxProgram, PaxRegister, PaxRunner; +type + TForm1 = class(TForm) + PaxCompiler1: TPaxCompiler; + PaxPascalLanguage1: TPaxPascalLanguage; + PaxProgram1: TPaxProgram; + Button1: TButton; + procedure Button1Click(Sender: TObject); + procedure FormCreate(Sender: TObject); + private + Y: Integer; + { Private declarations } + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.dfm} + +// declare procedural type that conforms to a script-defined procedure +type + TProcP = procedure (X: Integer); + +procedure TForm1.Button1Click(Sender: TObject); +var + H_Y, H_P: Integer; + I: Integer; + P: Pointer; +begin +{$O-} + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + + H_Y := PaxCompiler1.RegisterVariable(0, 'Y', _typeINTEGER, @Y); + + PaxCompiler1.AddModule('1', PaxPascalLanguage1.LanguageName); + PaxCompiler1.AddCode('1', 'procedure P(X: Integer);'); + PaxCompiler1.AddCode('1', 'begin'); + PaxCompiler1.AddCode('1', ' Y := Y + X;'); + PaxCompiler1.AddCode('1', 'end;'); + PaxCompiler1.AddCode('1', 'begin'); + PaxCompiler1.AddCode('1', 'end.'); + + if PaxCompiler1.Compile(PaxProgram1) then + begin + H_P := PaxCompiler1.GetHandle(0, 'P', true); + P := PaxProgram1.GetAddress(H_P); // get address of script-defind procedure + + TProcP(P)(10); // call it + ShowMessage(IntToStr(Y)); + + TProcP(P)(20); // call it + ShowMessage(IntToStr(Y)); + end + else + for I:=0 to PaxCompiler1.ErrorCount do + ShowMessage(PaxCompiler1.ErrorMessage[I]); +end; + +procedure TForm1.FormCreate(Sender: TObject); +begin + Y := 0; +end; + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/CodeComplet/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/CodeComplet/Project1.dpr new file mode 100644 index 0000000..5769e8a --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/CodeComplet/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form3}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm3, Form3); + Application.Run; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/CodeComplet/Project1.res b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/CodeComplet/Project1.res new file mode 100644 index 0000000..3adc036 Binary files /dev/null and b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/CodeComplet/Project1.res differ diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/CodeComplet/Unit1.dfm b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/CodeComplet/Unit1.dfm new file mode 100644 index 0000000..462aa64 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/CodeComplet/Unit1.dfm @@ -0,0 +1,56 @@ +object Form3: TForm3 + Left = 188 + Top = 188 + Width = 701 + Height = 194 + Caption = 'Code completion demo' + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -10 + Font.Name = 'Tahoma' + Font.Style = [] + OldCreateOrder = False + PixelsPerInch = 96 + TextHeight = 12 + object Button1: TButton + Left = 18 + Top = 12 + Width = 56 + Height = 19 + Caption = 'Create' + TabOrder = 0 + OnClick = Button1Click + end + object Memo1: TMemo + Left = 156 + Top = 6 + Width = 463 + Height = 143 + TabOrder = 1 + end + object PaxCompiler1: TPaxCompiler + Alignment = 1 + DebugMode = False + Left = 24 + Top = 56 + end + object PaxPascalLanguage1: TPaxPascalLanguage + ExplicitOff = False + CompleteBooleanEval = False + UnitLookup = True + PrintKeyword = 'print' + PrintlnKeyword = 'println' + Left = 56 + Top = 56 + end + object PaxCompilerExplorer1: TPaxCompilerExplorer + Left = 64 + Top = 88 + end + object PaxProgram1: TPaxProgram + Console = False + Left = 24 + Top = 80 + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/CodeComplet/Unit1.pas b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/CodeComplet/Unit1.pas new file mode 100644 index 0000000..d0bc46c --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/CodeComplet/Unit1.pas @@ -0,0 +1,53 @@ +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, + Dialogs, PaxCompiler, StdCtrls, PaxCompilerExplorer, PaxProgram, + PaxRunner; + +type + TForm3 = class(TForm) + Button1: TButton; + PaxCompiler1: TPaxCompiler; + PaxPascalLanguage1: TPaxPascalLanguage; + PaxCompilerExplorer1: TPaxCompilerExplorer; + PaxProgram1: TPaxProgram; + Memo1: TMemo; + procedure Button1Click(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + end; + +var + Form3: TForm3; + +implementation + +{$R *.dfm} + +procedure TForm3.Button1Click(Sender: TObject); +var + L: TStringList; +begin + L := TStringList.Create; + try + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + PaxCompiler1.AddModule('1', 'Pascal'); + PaxCompiler1.AddCodeFromFile('1', 'script3.txt'); + if PaxCompiler1.CodeCompletion('1', 3, 5, Memo1.Lines) then + begin + //ok + end + else + ShowMessage(PaxCompiler1.ErrorMessage[0]); + finally + L.Free; + end; +end; + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/CodeComplet/script.txt b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/CodeComplet/script.txt new file mode 100644 index 0000000..c24e6df --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/CodeComplet/script.txt @@ -0,0 +1,6 @@ +// x=3, y=4 +var + X: TObject; +begin + X. +end. \ No newline at end of file diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/CodeComplet/script2.txt b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/CodeComplet/script2.txt new file mode 100644 index 0000000..0546a47 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/CodeComplet/script2.txt @@ -0,0 +1,11 @@ +// x = 5, y = 9 +type + TMyClass = class + Z: TObject; + end; +var + X: TMyClass; +begin + X := TMyClass.Create; + X.Z. +end. \ No newline at end of file diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/CodeComplet/script3.txt b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/CodeComplet/script3.txt new file mode 100644 index 0000000..df41343 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/CodeComplet/script3.txt @@ -0,0 +1,7 @@ +// x = 3, y = 5 +procedure P(X, Y: Integer); +begin +end; +begin + P( +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/CodeExplorer/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/CodeExplorer/Project1.dpr new file mode 100644 index 0000000..513a1dd --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/CodeExplorer/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/CodeExplorer/Project1.res b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/CodeExplorer/Project1.res new file mode 100644 index 0000000..e916e21 Binary files /dev/null and b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/CodeExplorer/Project1.res differ diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/CodeExplorer/Unit1.dfm b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/CodeExplorer/Unit1.dfm new file mode 100644 index 0000000..139d875 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/CodeExplorer/Unit1.dfm @@ -0,0 +1,107 @@ +object Form1: TForm1 + Left = 192 + Top = 114 + Caption = 'Code explorer demo' + ClientHeight = 446 + ClientWidth = 688 + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + PixelsPerInch = 96 + TextHeight = 13 + object Panel1: TPanel + Left = 0 + Top = 405 + Width = 688 + Height = 41 + Align = alBottom + TabOrder = 0 + object Button1: TButton + Left = 24 + Top = 8 + Width = 105 + Height = 25 + Caption = 'Compile' + TabOrder = 0 + OnClick = Button1Click + end + end + object Memo1: TMemo + Left = 0 + Top = 0 + Width = 345 + Height = 405 + Align = alLeft + Lines.Strings = ( + 'uses' + ' Classes;' + 'type' + ' TMyArray = array[1..10] of Single;' + ' TMyPoint = record' + ' X, Y: Double;' + ' end;' + ' TMyClass = class' + ' P, Q: Integer;' + ' function MyClassFunc: Integer;' + ' property MyProp: Integer read P;' + ' end;' + '' + 'function TMyClass.MyClassFunc: Integer;' + 'begin' + 'end;' + '' + 'procedure MyProc(X, Y: Integer);' + 'procedure NestedProc;' + 'begin' + 'end;' + 'var' + ' L: Double;' + 'const' + ' W = '#39'abc'#39';' + 'begin' + 'end;' + 'function MyFunc: String;' + 'type' + ' TMyEnum = (one, two, three);' + 'begin' + ' result := '#39'pqr'#39';' + 'end;' + 'const' + ' Z = 80;' + 'var ' + ' G: Byte;' + 'begin' + 'end.') + TabOrder = 1 + end + object TreeView1: TTreeView + Left = 345 + Top = 0 + Width = 343 + Height = 405 + Align = alClient + Indent = 19 + TabOrder = 2 + OnDblClick = TreeView1DblClick + end + object PaxCompiler1: TPaxCompiler + Alignment = 1 + DebugMode = False + Left = 224 + Top = 413 + end + object PaxPascalLanguage1: TPaxPascalLanguage + CompleteBooleanEval = False + UnitLookup = True + Left = 264 + Top = 413 + end + object PaxCompilerExplorer1: TPaxCompilerExplorer + Left = 304 + Top = 413 + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/CodeExplorer/Unit1.pas b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/CodeExplorer/Unit1.pas new file mode 100644 index 0000000..de1e4d6 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/CodeExplorer/Unit1.pas @@ -0,0 +1,247 @@ +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, + Dialogs, PaxCompilerExplorer, PaxCompiler, StdCtrls, ExtCtrls, ComCtrls, + IMPORT_Classes; + +type + TForm1 = class(TForm) + Panel1: TPanel; + Memo1: TMemo; + Button1: TButton; + PaxCompiler1: TPaxCompiler; + PaxPascalLanguage1: TPaxPascalLanguage; + PaxCompilerExplorer1: TPaxCompilerExplorer; + TreeView1: TTreeView; + procedure Button1Click(Sender: TObject); + procedure TreeView1DblClick(Sender: TObject); + private + { Private declarations } + L: TList; + public + { Public declarations } + procedure BuildTree; + procedure EnumProc(Id: Integer; + Host: Boolean; + Kind: TPaxMemberKind; + Data: Pointer); + end; + +var + Form1: TForm1; + +implementation + +{$R *.dfm} + +procedure TForm1.Button1Click(Sender: TObject); +var + I: Integer; +begin + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + PaxCompiler1.AddModule('1', 'Pascal'); + PaxCompiler1.AddCode('1', Memo1.Lines.Text); + if PaxCompiler1.Compile then + begin + PaxCompilerExplorer1.RegisterCompiler(PaxCompiler1); + BuildTree; + end + else + for I:=0 to PaxCompiler1.ErrorCount - 1 do + ShowMessage(PaxCompiler1.ErrorMessage[I]); +end; + +procedure TForm1.BuildTree; +var + N, N2: TTreeNode; + I: Integer; +begin + L := TList.Create; + try + TreeView1.Items.Clear; + + N := TreeView1.Items.Add(nil, 'Used namespaces'); + L.Add(N); + PaxCompilerExplorer1.EnumMembers(0, true, pmkNamespace, EnumProc, N); + PaxCompilerExplorer1.EnumMembers(0, false, pmkNamespace, EnumProc, N); + + N := TreeView1.Items.Add(nil, 'Noname namespace'); + + N2 := TreeView1.Items.AddChild(N, 'Types'); + L.Add(N2); + PaxCompilerExplorer1.EnumMembers(0, false, pmkType, EnumProc, N2); + + N2 := TreeView1.Items.AddChild(N, 'Procedures'); + L.Add(N2); + PaxCompilerExplorer1.EnumMembers(0, false, pmkProcedure, EnumProc, N2); + + N2 := TreeView1.Items.AddChild(N, 'Functions'); + L.Add(N2); + PaxCompilerExplorer1.EnumMembers(0, false, pmkFunction, EnumProc, N2); + + N2 := TreeView1.Items.AddChild(N, 'Constants'); + L.Add(N2); + PaxCompilerExplorer1.EnumMembers(0, false, pmkConst, EnumProc, N2); + + N2 := TreeView1.Items.AddChild(N, 'Variables'); + L.Add(N2); + PaxCompilerExplorer1.EnumMembers(0, false, pmkVar, EnumProc, N2); + + finally + for I := L.Count - 1 downto 0 do + begin + N2 := TTreeNode(L[I]); + if N2.Count = 0 then + N2.Delete; + end; + + L.Free; + end; +end; + +procedure TForm1.EnumProc(Id: Integer; + Host: Boolean; + Kind: TPaxMemberKind; + Data: Pointer); +var + N, N2, N3: TTreeNode; + Name: String; + TypeName: String; +begin + N := TTreeNode(Data); + + Name := PaxCompilerExplorer1.Names[Id]; + TypeName := PaxCompilerExplorer1.TypeNames[Id]; + + with TreeView1.Items do + case Kind of + pmkProcedure, pmkFunction, pmkConstructor, pmkDestructor: + begin + N2 := AddChildObject(N, Name, TObject(Id)); + + N3 := AddChild(N2, 'Parameters'); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, Host, pmkParam, EnumProc, N3); + + N3 := AddChild(N2, 'Local variables'); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, Host, pmkVar, EnumProc, N3); + + N3 := AddChild(N2, 'Local constants'); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, Host, pmkConst, EnumProc, N3); + + N3 := AddChild(N2, 'Local types'); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, Host, pmkType, EnumProc, N3); + + N3 := TreeView1.Items.AddChild(N2, 'Nested procedures'); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, false, pmkProcedure, EnumProc, N3); + + N3 := TreeView1.Items.AddChild(N2, 'Nested functions'); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, false, pmkFunction, EnumProc, N3); + + end; + pmkParam: AddChildObject(N, Name + ': ' + TypeName, TObject(Id)); + pmkVar: AddChildObject(N, Name + ': ' + TypeName, TObject(Id)); + pmkConst: AddChildObject(N, Name + ': ' + TypeName, TObject(Id)); + pmkField: AddChildObject(N, Name + ': ' + TypeName, TObject(Id)); + pmkProperty: AddChildObject(N, Name + ': ' + TypeName, TObject(Id)); + pmkType: + begin + N2 := AddChildObject(N, Name, TObject(Id)); + if PaxCompilerExplorer1.IsRecordType(Id) then + begin + N3 := AddChild(N2, 'Fields'); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, Host, pmkField, EnumProc, N3); + end + else if PaxCompilerExplorer1.IsClassType(Id) then + begin + N3 := AddChild(N2, 'Fields'); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, Host, pmkField, EnumProc, N3); + + N3 := AddChild(N2, 'Properties'); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, Host, pmkProperty, EnumProc, N3); + + N3 := TreeView1.Items.AddChild(N2, 'Constructors'); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, false, pmkConstructor, EnumProc, N3); + + N3 := TreeView1.Items.AddChild(N2, 'Destructor'); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, false, pmkDestructor, EnumProc, N3); + + N3 := TreeView1.Items.AddChild(N2, 'Class procedures'); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, false, pmkProcedure, EnumProc, N3); + + N3 := TreeView1.Items.AddChild(N2, 'Class functions'); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, false, pmkFunction, EnumProc, N3); + end; + end; + pmkNamespace: + begin + N2 := AddChildObject(N, Name, TObject(Id)); + + N3 := AddChild(N2, 'Constants'); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, Host, pmkConst, EnumProc, N3); + + N3 := AddChild(N2, 'Variables'); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, Host, pmkVar, EnumProc, N3); + + N3 := AddChild(N2, 'Procedures'); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, Host, pmkProcedure, EnumProc, N3); + + N3 := AddChild(N2, 'Types'); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, Host, pmkType, EnumProc, N3); + end; + end; +end; + +procedure TForm1.TreeView1DblClick(Sender: TObject); +var + N: TTreeNode; + Id, Position: Integer; + S: String; +begin + N := TTreeView(Sender).Selected; + + if N = nil then + Exit; + + Id := Integer(N.Data); + + if Id = 0 then + Exit; + + S := PaxCompilerExplorer1.Names[Id]; + Position := PaxCompilerExplorer1.Positions[Id]; + + if Id <> 0 then + with Memo1 do + begin + SetFocus; + SelStart := Position; + SelLength := Length(S); + end; +end; + +initialization + +Register_Classes; + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/DebugDemo/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/DebugDemo/Project1.dpr new file mode 100644 index 0000000..cebc69a --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/DebugDemo/Project1.dpr @@ -0,0 +1,15 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}, + Unit2 in 'Unit2.pas' {Form2}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.CreateForm(TForm2, Form2); + Application.Run; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/DebugDemo/Project1.res b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/DebugDemo/Project1.res new file mode 100644 index 0000000..3adc036 Binary files /dev/null and b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/DebugDemo/Project1.res differ diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/DebugDemo/Unit1.dfm b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/DebugDemo/Unit1.dfm new file mode 100644 index 0000000..3f9899b --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/DebugDemo/Unit1.dfm @@ -0,0 +1,190 @@ +object Form1: TForm1 + Left = 209 + Top = 111 + Width = 638 + Height = 500 + Caption = 'DebugDemo' + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + OnCloseQuery = FormCloseQuery + PixelsPerInch = 96 + TextHeight = 13 + object Label1: TLabel + Left = 24 + Top = 8 + Width = 52 + Height = 24 + Caption = 'Script:' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -19 + Font.Name = 'MS Sans Serif' + Font.Style = [] + ParentFont = False + end + object Label2: TLabel + Left = 24 + Top = 320 + Width = 54 + Height = 24 + Caption = 'Trace:' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -19 + Font.Name = 'MS Sans Serif' + Font.Style = [] + ParentFont = False + end + object Memo1: TMemo + Left = 16 + Top = 40 + Width = 362 + Height = 273 + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -15 + Font.Name = 'MS Sans Serif' + Font.Style = [] + Lines.Strings = ( + 'function Fact(N: Integer): Integer;' + 'begin' + ' if N = 1 then' + '// ttttt' + ' result := 1' + ' else' + ' result := N * Fact(N - 1);' + 'end;' + 'var' + ' SS: Integer;' + 'begin' + ' SS := Fact(3);' + ' print(SS);' + 'end.') + ParentFont = False + TabOrder = 0 + end + object Memo2: TMemo + Left = 16 + Top = 352 + Width = 417 + Height = 217 + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -15 + Font.Name = 'MS Sans Serif' + Font.Style = [] + Lines.Strings = ( + '') + ParentFont = False + TabOrder = 1 + end + object Button1: TButton + Left = 392 + Top = 25 + Width = 193 + Height = 49 + Caption = 'Compile' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -19 + Font.Name = 'MS Sans Serif' + Font.Style = [] + ParentFont = False + TabOrder = 2 + OnClick = Button1Click + end + object Button2: TButton + Left = 392 + Top = 89 + Width = 193 + Height = 49 + Caption = 'Run' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -19 + Font.Name = 'MS Sans Serif' + Font.Style = [] + ParentFont = False + TabOrder = 3 + OnClick = Button2Click + end + object Button3: TButton + Left = 392 + Top = 155 + Width = 193 + Height = 49 + Caption = 'Trace Into' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -19 + Font.Name = 'MS Sans Serif' + Font.Style = [] + ParentFont = False + TabOrder = 4 + OnClick = Button3Click + end + object Button4: TButton + Left = 392 + Top = 220 + Width = 193 + Height = 50 + Caption = 'Step Over' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -19 + Font.Name = 'MS Sans Serif' + Font.Style = [] + ParentFont = False + TabOrder = 5 + OnClick = Button4Click + end + object Button5: TButton + Left = 392 + Top = 275 + Width = 193 + Height = 48 + Caption = 'Run to Cursor' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -19 + Font.Name = 'MS Sans Serif' + Font.Style = [] + ParentFont = False + TabOrder = 6 + OnClick = Button5Click + end + object PaxCompiler1: TPaxCompiler + Alignment = 1 + DebugMode = False + Left = 184 + Top = 320 + end + object PaxPascalLanguage1: TPaxPascalLanguage + ExplicitOff = False + CompleteBooleanEval = False + UnitLookup = True + PrintKeyword = 'print' + PrintlnKeyword = 'println' + Left = 224 + Top = 320 + end + object PaxProgram1: TPaxProgram + Console = False + OnPauseUpdated = PaxProgram1PauseUpdated + Left = 272 + Top = 320 + end + object PaxCompilerDebugger1: TPaxCompilerDebugger + Left = 312 + Top = 320 + end + object PaxCompilerExplorer1: TPaxCompilerExplorer + Left = 352 + Top = 320 + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/DebugDemo/Unit1.pas b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/DebugDemo/Unit1.pas new file mode 100644 index 0000000..ed25592 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/DebugDemo/Unit1.pas @@ -0,0 +1,341 @@ +{$O-} +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, PaxProgram, PaxCompiler, PaxCompilerDebugger, + PaxRegister, + PaxCompilerExplorer, PaxRunner; + +type + TForm1 = class(TForm) + Memo1: TMemo; + Memo2: TMemo; + Label1: TLabel; + Label2: TLabel; + Button1: TButton; + PaxCompiler1: TPaxCompiler; + PaxPascalLanguage1: TPaxPascalLanguage; + PaxProgram1: TPaxProgram; + Button2: TButton; + Button3: TButton; + Button4: TButton; + Button5: TButton; + PaxCompilerDebugger1: TPaxCompilerDebugger; + PaxCompilerExplorer1: TPaxCompilerExplorer; + procedure Button1Click(Sender: TObject); + procedure Button2Click(Sender: TObject); + procedure Button3Click(Sender: TObject); + procedure Button4Click(Sender: TObject); + procedure Button5Click(Sender: TObject); + procedure PaxProgram1PauseUpdated(Sender: TPaxRunner; + const ModuleName: string; SourceLineNumber: Integer); + procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean); + private + { Private declarations } + ResumeRequest: Boolean; + CloseRequest: Boolean; + procedure UpdateDebugInfo; + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +uses Unit2; + +{$R *.dfm} + +procedure TForm1.Button1Click(Sender: TObject); +var + I: Integer; +begin + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + PaxPascalLanguage1.SetCallConv(_ccREGISTER); + PaxCompiler1.AddModule('1', PaxPascalLanguage1.LanguageName); + PaxCompiler1.AddCode('1', Memo1.Lines.Text); + PaxCompiler1.DebugMode := true; + if PaxCompiler1.Compile(PaxProgram1) then + begin + ShowMessage('Script has been successfully recompiled.'); + PaxCompilerExplorer1.RegisterCompiler(PaxCompiler1); + PaxCompilerDebugger1.RegisterCompiler(PaxCompiler1, PaxProgram1); + end + else + for I:=0 to PaxCompiler1.ErrorCount - 1 do + ShowMessage(PaxCompiler1.ErrorMessage[I]); +end; + +procedure TForm1.Button2Click(Sender: TObject); +begin + if not PaxCompilerDebugger1.Valid then + begin + ShowMessage('You have to compile script. Press "Compile" button.'); + Exit; + end; + PaxCompilerDebugger1.RunMode := _rmRUN; + if PaxCompilerDebugger1.IsPaused then + ResumeRequest := true + else + PaxCompilerDebugger1.Run; +end; + +procedure TForm1.Button3Click(Sender: TObject); +begin + PaxCompilerDebugger1.RunMode := _rmTRACE_INTO; + if PaxCompilerDebugger1.IsPaused then + ResumeRequest := true + else + PaxCompilerDebugger1.Run; +end; + +procedure TForm1.Button4Click(Sender: TObject); +begin + PaxCompilerDebugger1.RunMode := _rmSTEP_OVER; + if PaxCompilerDebugger1.IsPaused then + ResumeRequest := true + else + PaxCompilerDebugger1.Run; +end; + +procedure TForm1.Button5Click(Sender: TObject); +begin + if not PaxCompilerDebugger1.Valid then + begin + ShowMessage('You have to compile script. Press "Compile" button.'); + Exit; + end; + + Form2.ShowModal; + + PaxCompilerDebugger1.RunMode := _rmRUN_TO_CURSOR; + if PaxCompilerDebugger1.IsPaused then + ResumeRequest := true + else + PaxCompilerDebugger1.Run; +end; + +procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean); +begin + CanClose := true; + CloseRequest := true; +end; + +procedure TForm1.PaxProgram1PauseUpdated(Sender: TPaxRunner; + const ModuleName: string; SourceLineNumber: Integer); +begin + UpdateDebugInfo; + ResumeRequest := false; + repeat + Application.ProcessMessages; + if ResumeRequest then + Break; + if CloseRequest then + Abort; + until false; +end; + +procedure TForm1.UpdateDebugInfo; + + procedure AddFields(StackFrameNumber, Id: Integer); + var + I, K: Integer; + OwnerName, S: String; + begin + K := PaxCompilerExplorer1.GetFieldCount(Id); + if K = 0 then + Exit; + + OwnerName := PaxCompilerExplorer1.Names[Id]; + if PaxCompilerDebugger1.GetValueAsString(Id) = 'nil' then + Exit; + + for I:=0 to K - 1 do + begin + S := OwnerName + '.' + PaxCompilerExplorer1.GetFieldName(Id, I); + S := ' ' + S + '=' + PaxCompilerDebugger1.GetFieldValueAsString( + StackFrameNumber, Id, I); + Memo2.Lines.Add(S); + end; + end; + + procedure AddPublishedProps(StackFrameNumber, Id: Integer); + var + I, K: Integer; + OwnerName, S: String; + begin + K := PaxCompilerExplorer1.GetPublishedPropCount(Id); + if K = 0 then + Exit; + + OwnerName := PaxCompilerExplorer1.Names[Id]; + if PaxCompilerDebugger1.GetValueAsString(Id) = 'nil' then + Exit; + + for I:=0 to K - 1 do + begin + S := OwnerName + '.' + PaxCompilerExplorer1.GetPublishedPropName(Id, I); + S := ' ' + S + '=' + PaxCompilerDebugger1.GetPublishedPropValueAsString( + StackFrameNumber, Id, I); + Memo2.Lines.Add(S); + end; + end; + + procedure AddArrayElements(StackFrameNumber, Id: Integer); + var + I, K1, K2: Integer; + OwnerName, S: String; + begin + if not PaxCompilerExplorer1.HasArrayType(Id) then + Exit; + + K1 := PaxCompilerExplorer1.GetArrayLowBound(Id); + K2 := PaxCompilerExplorer1.GetArrayHighBound(Id); + + OwnerName := PaxCompilerExplorer1.Names[Id]; + + for I:=K1 to K2 do + begin + S := OwnerName + '[' + IntToStr(I) + ']'; + S := ' ' + S + '=' + PaxCompilerDebugger1.GetArrayItemValueAsString( + StackFrameNumber, Id, I); + Memo2.Lines.Add(S); + end; + end; + + procedure AddDynArrayElements(StackFrameNumber, Id: Integer); + var + I, L: Integer; + OwnerName, S: String; + begin + if not PaxCompilerExplorer1.HasDynArrayType(Id) then + Exit; + + L := PaxCompilerDebugger1.GetDynArrayLength(StackFrameNumber, Id); + + OwnerName := PaxCompilerExplorer1.Names[Id]; + + for I:=0 to L - 1 do + begin + S := OwnerName + '[' + IntToStr(I) + ']'; + S := ' ' + S + '=' + PaxCompilerDebugger1.GetDynArrayItemValueAsString( + StackFrameNumber, Id, I); + Memo2.Lines.Add(S); + end; + end; + +var + SourceLineNumber: Integer; + ModuleName: String; + StackFrameNumber, J, K, SubId, Id: Integer; + S, V: String; + CallStackLineNumber: Integer; + CallStackModuleName: String; +begin + Memo2.Lines.Clear; + if PaxCompilerDebugger1.IsPaused then + begin + ModuleName := PaxCompilerDebugger1.ModuleName; + SourceLineNumber := PaxCompilerDebugger1.SourceLineNumber; + + Memo2.Lines.Add('Paused at line ' + IntTosTr(SourceLineNumber)); + Memo2.Lines.Add(PaxCompiler1.Modules[ModuleName][SourceLineNumber]); + Memo2.Lines.Add('------------------------------------------------------'); + + if PaxCompilerDebugger1.CallStackCount > 0 then + begin + Memo2.Lines.Add('Call stack:'); + for StackFrameNumber:=0 to PaxCompilerDebugger1.CallStackCount - 1 do + begin + SubId := PaxCompilerDebugger1.CallStack[StackFrameNumber]; + S := '('; + K := PaxCompilerExplorer1.GetParamCount(SubId); + for J:=0 to K - 1 do + begin + Id := PaxCompilerExplorer1.GetParamId(SubId, J); + V := PaxCompilerDebugger1.GetValueAsString(StackFrameNumber, Id); + S := S + V; + if J < K - 1 then + S := S + ','; + end; + S := PaxCompilerExplorer1.Names[SubId] + S + ')'; + + CallStackLineNumber := PaxCompilerDebugger1.CallStackLineNumber[StackFrameNumber]; + CallStackModuleName := PaxCompilerDebugger1.CallStackModuleName[StackFrameNumber]; + + S := S + '; // ' + PaxCompiler1.Modules[CallStackModuleName][CallStackLineNumber]; + + Memo2.Lines.Add(S); + end; + Memo2.Lines.Add('------------------------------------------------------'); + + Memo2.Lines.Add('Local scope:'); + StackFrameNumber := PaxCompilerDebugger1.CallStackCount - 1; + SubId := PaxCompilerDebugger1.CallStack[StackFrameNumber]; + K := PaxCompilerExplorer1.GetLocalCount(SubId); + for J:=0 to K - 1 do + begin + Id := PaxCompilerExplorer1.GetLocalId(SubId, J); + V := PaxCompilerDebugger1.GetValueAsString(StackFrameNumber, Id); + S := PaxCompilerExplorer1.Names[Id] + '=' + V; + Memo2.Lines.Add(S); + + if Pos('X', S) > 0 then + begin + PaxCompilerDebugger1.PutValue(StackFrameNumber, Id, 258); + + V := PaxCompilerDebugger1.GetValueAsString(StackFrameNumber, Id); + S := PaxCompilerExplorer1.Names[Id] + '=' + V; + S := S + ' // modified'; + Memo2.Lines.Add(S); + end; + + AddFields(StackFrameNumber, Id); + AddPublishedProps(StackFrameNumber, Id); + AddArrayElements(StackFrameNumber, Id); + AddDynArrayElements(StackFrameNumber, Id); + end; + + Memo2.Lines.Add('------------------------------------------------------'); + end; + + Memo2.Lines.Add('Global scope:'); + K := PaxCompilerExplorer1.GetGlobalCount(0); + for J:=0 to K - 1 do + begin + Id := PaxCompilerExplorer1.GetGlobalId(0, J); + V := PaxCompilerDebugger1.GetValueAsString(Id); + S := PaxCompilerExplorer1.Names[Id] + '=' + V; + Memo2.Lines.Add(S); + + AddFields(0, Id); + AddPublishedProps(0, Id); + AddArrayElements(0, Id); + AddDynArrayElements(0, Id); + end; + Memo2.Lines.Add('------------------------------------------------------'); + + end + else + Memo2.Lines.Add('Finished'); + + Memo2.SelStart := 0; + Memo2.SelLength := 0; +end; + +procedure Print(I: Integer); +begin + ShowMessage(IntToStr(I)); +end; + +initialization + +RegisterHeader(0, 'procedure Print(I: Integer);', @Print); + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/DebugDemo/Unit2.dfm b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/DebugDemo/Unit2.dfm new file mode 100644 index 0000000..c01f34c --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/DebugDemo/Unit2.dfm @@ -0,0 +1,43 @@ +object Form2: TForm2 + Left = 551 + Top = 252 + Width = 384 + Height = 345 + Caption = 'Select line' + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + PixelsPerInch = 96 + TextHeight = 13 + object Panel1: TPanel + Left = 0 + Top = 270 + Width = 376 + Height = 41 + Align = alBottom + TabOrder = 0 + object Button1: TButton + Left = 8 + Top = 8 + Width = 75 + Height = 25 + Caption = 'Ok' + ModalResult = 1 + TabOrder = 0 + OnClick = Button1Click + end + end + object ListBox1: TListBox + Left = 0 + Top = 0 + Width = 376 + Height = 270 + Align = alClient + ItemHeight = 13 + TabOrder = 1 + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/DebugDemo/Unit2.pas b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/DebugDemo/Unit2.pas new file mode 100644 index 0000000..e1e87d9 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/DebugDemo/Unit2.pas @@ -0,0 +1,65 @@ +unit Unit2; + +interface + +uses + Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, ExtCtrls; + +type + TForm2 = class(TForm) + Panel1: TPanel; + ListBox1: TListBox; + Button1: TButton; + procedure Button1Click(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + function ShowModal: Integer; override; + end; + +var + Form2: TForm2; + +implementation + +uses Unit1; + +{$R *.dfm} + +function TForm2.ShowModal: Integer; +var + I: Integer; + S: String; + ch: Char; +begin + ListBox1.Items.Clear; + for I:=0 to Form1.Memo1.Lines.Count - 1 do + begin + if Form1.PaxCompilerExplorer1.IsExecutableLine('1', I) then + ch := '*' + else + ch := ' '; + S := Format('%3d ', [I]) + ch + ' ' + Form1.Memo1.Lines[I]; + ListBox1.Items.Add(S); + end; + + result := inherited ShowModal; +end; + +procedure TForm2.Button1Click(Sender: TObject); +var + I: Integer; +begin + I := ListBox1.ItemIndex; + if Form1.PaxCompilerExplorer1.IsExecutableLine('1', I) then + Form1.PaxCompilerDebugger1.AddTempBreakpoint('1', I) + else + begin + ShowMessage(IntToStr(I) + ' is not executable line!'); + ModalResult := mrCancel; + end; +end; + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/EvalExpression/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/EvalExpression/Project1.dpr new file mode 100644 index 0000000..513a1dd --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/EvalExpression/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/EvalExpression/Project1.res b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/EvalExpression/Project1.res new file mode 100644 index 0000000..3adc036 Binary files /dev/null and b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/EvalExpression/Project1.res differ diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/EvalExpression/Unit1.dfm b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/EvalExpression/Unit1.dfm new file mode 100644 index 0000000..86c22b4 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/EvalExpression/Unit1.dfm @@ -0,0 +1,35 @@ +object Form1: TForm1 + Left = 192 + Top = 115 + Caption = 'Eval Expression' + ClientHeight = 115 + ClientWidth = 265 + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + OnCreate = FormCreate + PixelsPerInch = 96 + TextHeight = 13 + object Button1: TButton + Left = 24 + Top = 24 + Width = 201 + Height = 25 + Caption = 'Create compiled expression' + TabOrder = 0 + OnClick = Button1Click + end + object Button2: TButton + Left = 24 + Top = 64 + Width = 201 + Height = 25 + Caption = 'Evaluate expression' + TabOrder = 1 + OnClick = Button2Click + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/EvalExpression/Unit1.pas b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/EvalExpression/Unit1.pas new file mode 100644 index 0000000..3261aa1 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/EvalExpression/Unit1.pas @@ -0,0 +1,115 @@ +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, PaxCompiler, PaxProgram, PaxRegister; + +type + TForm1 = class(TForm) + Button1: TButton; + Button2: TButton; + procedure Button1Click(Sender: TObject); + procedure Button2Click(Sender: TObject); + procedure FormCreate(Sender: TObject); + private + { Private declarations } + arr_x, arr_y: array[1..3] of Double; + h_norm, h_x, h_y: Integer; + + buff: array[1..40960] of Byte; + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.dfm} + +function Norm(x, y: Double): Double; +begin + result := Sqrt(x * x + y * y); +end; + +procedure TForm1.Button1Click(Sender: TObject); +var + PaxCompiler1: TPaxCompiler; + PaxPascalLanguage1: TPaxPascalLanguage; + PaxProgram1: TPaxProgram; + I: Integer; +begin + PaxCompiler1 := TPaxCompiler.Create(nil); + PaxPascalLanguage1 := TPaxPascalLanguage.Create(nil); + PaxProgram1 := TPaxProgram.Create(nil); + + try + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + + h_norm := PaxCompiler1.RegisterHeader(0, 'function Norm(x, y: Double): Double;'); + + h_x := PaxCompiler1.RegisterVariable(0, 'x', _typeDOUBLE); + h_y := PaxCompiler1.RegisterVariable(0, 'y', _typeDOUBLE); + + if PaxCompiler1.CompileExpression('Norm(x, y)', PaxProgram1) then + begin + PaxProgram1.SaveToBuff(buff); + ShowMessage('Compiled expression has been created!'); + end + else + for I:=0 to PaxCompiler1.ErrorCount - 1 do + ShowMessage(PaxCompiler1.ErrorMessage[I]); + finally + PaxCompiler1.Free; + PaxPascalLanguage1.Free; + PaxProgram1.Free; + end; +end; + +procedure TForm1.Button2Click(Sender: TObject); +var + PaxProgram1: TPaxProgram; + ResValue: Double; + I: Integer; +begin +{$O-} + if h_x <> 0 then + begin + PaxProgram1 := TPaxProgram.Create(nil); + try + PaxProgram1.LoadFromBuff(buff); + + PaxProgram1.SetAddress(h_norm, @norm); + + for I:=1 to 3 do + begin + PaxProgram1.SetAddress(h_x, @arr_x[I]); + PaxProgram1.SetAddress(h_y, @arr_y[I]); + + PaxProgram1.Run; + + ResValue := Double(PaxProgram1.ResultPtr^); + ShowMessage(FloatToStr(ResValue)); + end; + + finally + PaxProgram1.Free; + end; + end + else + ShowMessage('Press the first button to create compiled script.'); +end; + +procedure TForm1.FormCreate(Sender: TObject); +begin + h_x := 0; h_y := 0; h_norm := 0; + arr_x[1] := 4.2; arr_y[1] := -5.2; + arr_x[2] := -0.4; arr_y[2] := 3.2; + arr_x[3] := 2.0; arr_y[3] := 3; +end; + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/EventHandler/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/EventHandler/Project1.dpr new file mode 100644 index 0000000..513a1dd --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/EventHandler/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/EventHandler/Project1.res b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/EventHandler/Project1.res new file mode 100644 index 0000000..3adc036 Binary files /dev/null and b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/EventHandler/Project1.res differ diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/EventHandler/Unit1.dfm b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/EventHandler/Unit1.dfm new file mode 100644 index 0000000..02569c2 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/EventHandler/Unit1.dfm @@ -0,0 +1,125 @@ +object Form1: TForm1 + Left = 19 + Top = 116 + Width = 519 + Height = 524 + Caption = 'Script-defined event handler demo' + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + PixelsPerInch = 96 + TextHeight = 13 + object Button1: TButton + Left = 16 + Top = 8 + Width = 273 + Height = 25 + Caption = 'Create event handler for Button2.OnClick event' + TabOrder = 0 + OnClick = Button1Click + end + object Button2: TButton + Left = 392 + Top = 432 + Width = 75 + Height = 25 + Caption = 'Button2' + TabOrder = 1 + end + object Memo1: TMemo + Left = 16 + Top = 40 + Width = 273 + Height = 433 + Font.Charset = RUSSIAN_CHARSET + Font.Color = clWindowText + Font.Height = -15 + Font.Name = 'Times New Roman' + Font.Style = [] + Lines.Strings = ( + 'type' + ' TMyHandler = class' + ' procedure Handle(Sender: TObject); ' + ' procedure Dispose(Sender: TObject); ' + ' end;' + '' + 'procedure TMyHandler.Handle(Sender: ' + 'TObject); ' + 'begin' + ' ShowMessage('#39'Sender: '#39' + ' + 'Sender.ClassName);' + 'end;' + '' + 'procedure TMyHandler.Dispose(Sender: ' + 'TObject); ' + 'begin' + ' Free;' + 'end;' + '' + 'var' + ' X: TMyHandler;' + 'begin' + ' X := TMyHandler.Create;' + ' Button2.OnClick := X.Handle;' + ' Form1.OnDestroy := X.Dispose;' + 'end.' + '') + ParentFont = False + TabOrder = 2 + end + object Button3: TButton + Left = 312 + Top = 8 + Width = 161 + Height = 25 + Caption = 'Remove event handler' + TabOrder = 3 + OnClick = Button3Click + end + object Memo2: TMemo + Left = 312 + Top = 40 + Width = 161 + Height = 73 + Font.Charset = RUSSIAN_CHARSET + Font.Color = clWindowText + Font.Height = -15 + Font.Name = 'Times New Roman' + Font.Style = [] + Lines.Strings = ( + 'begin' + ' Button2.OnClick := nil;' + 'end.') + ParentFont = False + TabOrder = 4 + end + object PaxCompiler1: TPaxCompiler + Alignment = 1 + DebugMode = False + Left = 416 + Top = 168 + end + object PaxPascalLanguage1: TPaxPascalLanguage + ExplicitOff = False + CompleteBooleanEval = False + UnitLookup = True + PrintKeyword = 'print' + PrintlnKeyword = 'println' + Left = 416 + Top = 200 + end + object PaxProgram1: TPaxProgram + Console = False + Left = 200 + Top = 192 + end + object PaxProgram2: TPaxProgram + Console = False + Left = 424 + Top = 72 + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/EventHandler/Unit1.pas b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/EventHandler/Unit1.pas new file mode 100644 index 0000000..ef3fd03 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/EventHandler/Unit1.pas @@ -0,0 +1,93 @@ +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, + Dialogs, PaxProgram, PaxCompiler, StdCtrls, PaxRegister, PaxRunner; + +type + TForm1 = class(TForm) + Button1: TButton; + Button2: TButton; + Memo1: TMemo; + PaxCompiler1: TPaxCompiler; + PaxPascalLanguage1: TPaxPascalLanguage; + PaxProgram1: TPaxProgram; + Button3: TButton; + Memo2: TMemo; + PaxProgram2: TPaxProgram; + procedure Button1Click(Sender: TObject); + procedure Button3Click(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.dfm} + +var + H_TButton, H_TForm1: Integer; + +procedure TForm1.Button1Click(Sender: TObject); +var + I: Integer; +begin + if Assigned(Button2.OnClick) then + begin + ShowMessage('The event handler has been already created.'); + Exit; + end; + + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + PaxCompiler1.AddModule('1', 'Pascal'); + PaxCompiler1.AddCode('1', Memo1.Lines.Text); + PaxCompiler1.RegisterVariable(0, 'Button2', H_TButton, @Button2); + PaxCompiler1.RegisterVariable(0, 'Form1', H_TForm1, @Form1); + + PaxPascalLanguage1.SetCallConv(_ccREGISTER); + + if PaxCompiler1.Compile(PaxProgram1) then + begin + PaxProgram1.Run; + ShowMessage('The event handler has been created. Click Button2.'); + end + else + for I:=0 to PaxCompiler1.ErrorCount - 1 do + ShowMessage(PaxCompiler1.ErrorMessage[I]); +end; + +procedure TForm1.Button3Click(Sender: TObject); +var + I: Integer; +begin + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + PaxCompiler1.AddModule('1', 'Pascal'); + PaxCompiler1.AddCode('1', Memo2.Lines.Text); + PaxCompiler1.RegisterVariable(0, 'Button2', H_TButton, @Button2); + + if PaxCompiler1.Compile(PaxProgram2) then + begin + PaxProgram2.Run; + ShowMessage('The event handler has been removed.'); + end + else + for I:=0 to PaxCompiler1.ErrorCount - 1 do + ShowMessage(PaxCompiler1.ErrorMessage[I]); +end; + +initialization + + H_TButton := RegisterClassType(0, TButton); + H_TForm1 := RegisterClassType(0, TForm1); + RegisterHeader(0, 'procedure ShowMessage(const Msg: string);', @ShowMessage); + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/EventHandler2/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/EventHandler2/Project1.dpr new file mode 100644 index 0000000..513a1dd --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/EventHandler2/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/EventHandler2/Project1.res b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/EventHandler2/Project1.res new file mode 100644 index 0000000..3adc036 Binary files /dev/null and b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/EventHandler2/Project1.res differ diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/EventHandler2/Unit1.dfm b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/EventHandler2/Unit1.dfm new file mode 100644 index 0000000..43aa07c --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/EventHandler2/Unit1.dfm @@ -0,0 +1,131 @@ +object Form1: TForm1 + Left = 192 + Top = 114 + Width = 721 + Height = 607 + Caption = 'Event handler demo' + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + PixelsPerInch = 96 + TextHeight = 13 + object Button1: TButton + Left = 16 + Top = 16 + Width = 209 + Height = 25 + Caption = '1. Compile script' + TabOrder = 0 + OnClick = Button1Click + end + object Button2: TButton + Left = 16 + Top = 56 + Width = 209 + Height = 25 + Caption = '2. Set up script-defined event handler' + TabOrder = 1 + OnClick = Button2Click + end + object Button3: TButton + Left = 16 + Top = 96 + Width = 209 + Height = 25 + Caption = '3. Restore host-defined event handler' + TabOrder = 2 + OnClick = Button3Click + end + object Memo1: TMemo + Left = 240 + Top = 8 + Width = 441 + Height = 545 + Font.Charset = RUSSIAN_CHARSET + Font.Color = clWindowText + Font.Height = -13 + Font.Name = 'Times New Roman' + Font.Style = [] + Lines.Strings = ( + 'type' + ' TMyHandler = class' + ' procedure Handle(Sender: TObject); ' + ' procedure Dispose(Sender: TObject); ' + ' end;' + '' + 'procedure TMyHandler.Handle(Sender: TObject); ' + 'begin' + + ' ShowMessage('#39'Script-defined handler. Sender: '#39' + Sender.Clas' + + 'sName);' + 'end;' + '' + 'procedure TMyHandler.Dispose(Sender: TObject); ' + 'begin' + ' Free;' + 'end;' + '' + 'var' + ' X: TMyHandler;' + ' E: TNotifyEvent;' + '' + 'procedure SetHandler; ' + 'begin' + ' E := ClickMe.OnClick;' + ' ClickMe.OnClick := X.Handle;' + 'end;' + '' + 'procedure RestoreHandler; ' + 'begin' + ' ClickMe.OnClick := E;' + 'end;' + '' + 'begin' + ' X := TMyHandler.Create;' + '' + ' ClickMe.OnClick(X);' + '' + ' Form1.OnDestroy := X.Dispose;' + + ' ShowMessage('#39'The script was compiled and initialized successf' + + 'ully.'#39');' + 'end.' + '' + '') + ParentFont = False + TabOrder = 3 + end + object ClickMe: TButton + Left = 24 + Top = 440 + Width = 201 + Height = 105 + Caption = 'ClickMe' + TabOrder = 4 + OnClick = ClickMeClick + end + object PaxCompiler1: TPaxCompiler + Alignment = 1 + DebugMode = False + Left = 632 + Top = 64 + end + object PaxPascalLanguage1: TPaxPascalLanguage + ExplicitOff = False + CompleteBooleanEval = False + UnitLookup = True + PrintKeyword = 'print' + PrintlnKeyword = 'println' + Left = 640 + Top = 112 + end + object PaxProgram1: TPaxProgram + Console = False + Left = 632 + Top = 152 + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/EventHandler2/Unit1.pas b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/EventHandler2/Unit1.pas new file mode 100644 index 0000000..eee9510 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/EventHandler2/Unit1.pas @@ -0,0 +1,106 @@ +{$O-} + +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, PaxProgram, PaxCompiler, PaxRegister, PaxRunner; + +type + TForm1 = class(TForm) + Button1: TButton; + Button2: TButton; + Button3: TButton; + Memo1: TMemo; + ClickMe: TButton; + PaxCompiler1: TPaxCompiler; + PaxPascalLanguage1: TPaxPascalLanguage; + PaxProgram1: TPaxProgram; + procedure Button1Click(Sender: TObject); + procedure ClickMeClick(Sender: TObject); + procedure Button2Click(Sender: TObject); + procedure Button3Click(Sender: TObject); + private + { Private declarations } + P_SetHandler: Pointer; + P_RestoreHandler: Pointer; + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.dfm} + +var + H_TButton, H_TForm1: Integer; + +type + TProcP = procedure; + +procedure TForm1.Button1Click(Sender: TObject); +var + I: Integer; + H: Integer; +begin + if PaxProgram1.DataSize > 0 then + begin + ShowMessage('Script is already compiled.'); + Exit; + end; + + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + PaxCompiler1.AddModule('1', 'Pascal'); + PaxCompiler1.AddCode('1', Memo1.Lines.Text); + PaxCompiler1.RegisterVariable(0, 'ClickMe', H_TButton, @ClickMe); + PaxCompiler1.RegisterVariable(0, 'Form1', H_TForm1, @Form1); + + PaxPascalLanguage1.SetCallConv(_ccREGISTER); + + if PaxCompiler1.Compile(PaxProgram1) then + begin + H := PaxCompiler1.GetHandle(0, 'SetHandler', true); + P_SetHandler := PaxProgram1.GetAddress(H); + + H := PaxCompiler1.GetHandle(0, 'RestoreHandler', true); + P_RestoreHandler := PaxProgram1.GetAddress(H); + + PaxProgram1.Run; + end + else + for I:=0 to PaxCompiler1.ErrorCount - 1 do + ShowMessage(PaxCompiler1.ErrorMessage[I]); +end; + +procedure TForm1.Button2Click(Sender: TObject); +begin + TProcP(P_SetHandler); + + ShowMessage('ClickMe contains script-defined event handler now.'); +end; + +procedure TForm1.Button3Click(Sender: TObject); +begin + TProcP(P_RestoreHandler); + + ShowMessage('Host-defined handler is restored.'); +end; + +procedure TForm1.ClickMeClick(Sender: TObject); +begin + ShowMessage('Host-defined event handler. Sender: ' + Sender.ClassName); +end; + +initialization + + H_TButton := RegisterClassType(0, TButton); + H_TForm1 := RegisterClassType(0, TForm1); + RegisterHeader(0, 'procedure ShowMessage(const Msg: string);', @ShowMessage); + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/HandledException/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/HandledException/Project1.dpr new file mode 100644 index 0000000..513a1dd --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/HandledException/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/HandledException/Project1.res b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/HandledException/Project1.res new file mode 100644 index 0000000..3adc036 Binary files /dev/null and b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/HandledException/Project1.res differ diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/HandledException/Unit1.dfm b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/HandledException/Unit1.dfm new file mode 100644 index 0000000..f1929ef --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/HandledException/Unit1.dfm @@ -0,0 +1,93 @@ +object Form1: TForm1 + Left = 192 + Top = 114 + Width = 721 + Height = 602 + Caption = 'Run-time error handling' + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + PixelsPerInch = 96 + TextHeight = 13 + object Button1: TButton + Left = 24 + Top = 16 + Width = 161 + Height = 25 + Caption = 'Compile and Run' + TabOrder = 0 + OnClick = Button1Click + end + object Memo1: TMemo + Left = 200 + Top = 16 + Width = 481 + Height = 441 + Lines.Strings = ( + 'uses' + ' SysUtils;' + '' + 'procedure ErrorProc;' + 'var' + ' I: Integer;' + 'begin' + ' I := 0;' + ' I := I div I;' + 'end;' + '' + 'procedure TestFinally;' + 'var' + ' S: String;' + ' I: Integer;' + 'begin' + ' S := '#39'abc'#39';' + ' try' + ' ErrorProc;' + ' finally' + ' writeln(S);' + ' end;' + ' writeln('#39'not executed'#39');' + 'end;' + '' + 'begin' + ' try' + ' TestFinally;' + ' except' + ' writeln('#39'ok'#39');' + ' end;' + 'end.') + TabOrder = 1 + end + object Memo2: TMemo + Left = 200 + Top = 464 + Width = 481 + Height = 89 + TabOrder = 2 + end + object PaxCompiler1: TPaxCompiler + Alignment = 1 + DebugMode = False + Left = 64 + Top = 112 + end + object PaxPascalLanguage1: TPaxPascalLanguage + ExplicitOff = False + CompleteBooleanEval = False + UnitLookup = True + PrintKeyword = 'print' + PrintlnKeyword = 'println' + Left = 104 + Top = 112 + end + object PaxProgram1: TPaxProgram + Console = False + OnException = PaxProgram1Exception + Left = 80 + Top = 152 + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/HandledException/Unit1.pas b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/HandledException/Unit1.pas new file mode 100644 index 0000000..2659c8f --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/HandledException/Unit1.pas @@ -0,0 +1,103 @@ +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, + Dialogs, PaxProgram, PaxCompiler, StdCtrls, PAXCOMP_STDLIB, PaxRunner; + +type + TForm1 = class(TForm) + Button1: TButton; + Memo1: TMemo; + PaxCompiler1: TPaxCompiler; + PaxPascalLanguage1: TPaxPascalLanguage; + PaxProgram1: TPaxProgram; + Memo2: TMemo; + procedure Button1Click(Sender: TObject); + procedure PaxProgram1Exception(Sender: TPaxRunner; E: Exception; + const ModuleName: String; SourceLineNumber: Integer); + private + { Private declarations } + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.dfm} + +uses + IMPORT_SysUtils; + +procedure _Writeln; +begin + Form1.Memo2.Text := Form1.Memo2.Text + #13#10; +end; + +procedure _WriteUnicString(const value: String; L: Integer); +var + S: String; +begin + if L = 0 then + Form1.Memo2.Text := Form1.Memo2.Text + value + else + begin + S := value; + while Length(S) < L do + S := ' ' + S; + Form1.Memo2.Text := Form1.Memo2.Text + S; + end; +end; + +procedure _WriteWideString(const value: WideString; L: Integer); +var + S: String; +begin + if L = 0 then + Form1.Memo2.Text := Form1.Memo2.Text + value + else + begin + S := value; + while Length(S) < L do + S := ' ' + S; + Form1.Memo2.Text := Form1.Memo2.Text + S; + end; +end; + +procedure TForm1.Button1Click(Sender: TObject); +begin + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + PaxCompiler1.AddModule('main', 'Pascal'); + PaxCompiler1.AddCode('main', Memo1.Lines.Text); + if PaxCompiler1.Compile(PaxProgram1) then + begin + PaxProgram1.SetAddress(H_Writeln, @_Writeln); + PaxProgram1.SetAddress(H_WriteAnsiString, @_WriteUnicString); + PaxProgram1.SetAddress(H_WriteUnicString, @_WriteUnicString); + PaxProgram1.SetAddress(H_WriteWideString, @_WriteWideString); + + PaxProgram1.Run; + end + else + ShowMessage(PaxCompiler1.ErrorMessage[0]); +end; + +procedure TForm1.PaxProgram1Exception(Sender: TPaxRunner; E: Exception; + const ModuleName: String; SourceLineNumber: Integer); +begin + Form1.Memo2.Text := Form1.Memo2.Text + #13#10 + + 'Exception (' + E.Message + + ') raised at line ' + IntToStr(SourceLineNumber) + ':' + + PaxCompiler1.Modules[ModuleName][SourceLineNumber] + #13#10; +end; + +initialization + +Register_SysUtils; + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/Hello/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/Hello/Project1.dpr new file mode 100644 index 0000000..513a1dd --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/Hello/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/Hello/Project1.res b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/Hello/Project1.res new file mode 100644 index 0000000..3adc036 Binary files /dev/null and b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/Hello/Project1.res differ diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/Hello/Unit1.dfm b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/Hello/Unit1.dfm new file mode 100644 index 0000000..8fd2f96 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/Hello/Unit1.dfm @@ -0,0 +1,45 @@ +object Form1: TForm1 + Left = 192 + Top = 114 + Width = 252 + Height = 172 + Caption = 'HelloApp' + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + PixelsPerInch = 96 + TextHeight = 13 + object Button1: TButton + Left = 32 + Top = 80 + Width = 75 + Height = 25 + Caption = 'Say "Hello"' + TabOrder = 0 + OnClick = Button1Click + end + object PaxCompiler1: TPaxCompiler + Alignment = 1 + DebugMode = False + Left = 48 + Top = 24 + end + object PaxPascalLanguage1: TPaxPascalLanguage + ExplicitOff = False + CompleteBooleanEval = False + UnitLookup = True + PrintKeyword = 'print' + PrintlnKeyword = 'println' + Left = 96 + Top = 24 + end + object PaxProgram1: TPaxProgram + Console = False + Left = 144 + Top = 24 + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/Hello/Unit1.pas b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/Hello/Unit1.pas new file mode 100644 index 0000000..cdb3fed --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/Hello/Unit1.pas @@ -0,0 +1,50 @@ +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, PaxCompiler, PaxProgram, PaxRunner; +type + TForm1 = class(TForm) + PaxCompiler1: TPaxCompiler; + PaxPascalLanguage1: TPaxPascalLanguage; + PaxProgram1: TPaxProgram; + Button1: TButton; + procedure Button1Click(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.dfm} + +procedure TForm1.Button1Click(Sender: TObject); +var + I, H_TButton: Integer; +begin + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + + H_TButton := PaxCompiler1.RegisterClassType(0, TButton); + PaxCompiler1.RegisterVariable(0, 'Button1', H_TButton, @Button1); + + PaxCompiler1.AddModule('1', PaxPascalLanguage1.LanguageName); + PaxCompiler1.AddCode('1', 'begin'); + PaxCompiler1.AddCode('1', ' Button1.Caption := ''Hello'';'); + PaxCompiler1.AddCode('1', 'end.'); + + if PaxCompiler1.Compile(PaxProgram1) then + PaxProgram1.Run + else + for I:=0 to PaxCompiler1.ErrorCount - 1 do + ShowMessage(PaxCompiler1.ErrorMessage[I]); +end; + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/Inheritance/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/Inheritance/Project1.dpr new file mode 100644 index 0000000..ee9ca2f --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/Inheritance/Project1.dpr @@ -0,0 +1,64 @@ +{$APPTYPE CONSOLE} +program Project1; +uses + PaxCompiler, PaxProgram, PaxRegister; +type + TMyHostClass = class + public + procedure P; virtual; abstract; + end; + +procedure PassToHost(X: TMyHostClass); +begin + writeln(X.ClassName); + X.P; +end; + +var + PaxCompiler1: TPaxCompiler; + PaxProgram1: TPaxProgram; + PaxPascalLanguage1: TPaxPascalLanguage; + I: Integer; +begin + I := RegisterClassType(0, TMyHostClass); + RegisterHeader(I, + 'procedure P; virtual; abstract;', + nil); + + RegisterHeader(0, + 'procedure PassToHost(X: TMyHostClass);', + @ PassToHost); + + PaxCompiler1 := TPaxCompiler.Create(nil); + PaxProgram1 := TPaxProgram.Create(nil); + PaxPascalLanguage1 := TPaxPascalLanguage.Create(nil); + try + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + PaxCompiler1.AddModule('1', 'Pascal'); + PaxCompiler1.AddCodeFromFile('1', 'script.txt'); + if PaxCompiler1.Compile(PaxProgram1) then + begin + PaxProgram1.Run; + end + else + begin + writeln(PaxCompiler1.ErrorMessage[0]); + writeln(PaxCompiler1.ErrorLineNumber[0]); + writeln(PaxCompiler1.ErrorLine[0]); + end; + + for I:=0 to PaxCompiler1.WarningCount - 1 do + begin + writeln(PaxCompiler1.WarningMessage[I]); + writeln(PaxCompiler1.WarningLineNumber[I]); + writeln(PaxCompiler1.WarningLine[I]); + end; + + finally + PaxCompiler1.Free; + PaxProgram1.Free; + PaxPascalLanguage1.Free; + end; + writeln('Press any key...'); + Readln; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/Inheritance/script.txt b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/Inheritance/script.txt new file mode 100644 index 0000000..90e1139 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/Inheritance/script.txt @@ -0,0 +1,20 @@ +type + TMyScriptClass = class(TMyHostClass) + procedure P; override; + end; + +procedure TMyScriptClass.P; +begin + writeln('Hello from script!'); +end; + +var + X: TMyScriptClass; +begin + X := TMyScriptClass.Create; + try + PassToHost(X); + finally + X.Free; + end; +end. \ No newline at end of file diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/LoadCompiledScript/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/LoadCompiledScript/Project1.dpr new file mode 100644 index 0000000..513a1dd --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/LoadCompiledScript/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/LoadCompiledScript/Project1.res b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/LoadCompiledScript/Project1.res new file mode 100644 index 0000000..3adc036 Binary files /dev/null and b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/LoadCompiledScript/Project1.res differ diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/LoadCompiledScript/Unit1.dfm b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/LoadCompiledScript/Unit1.dfm new file mode 100644 index 0000000..43fd831 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/LoadCompiledScript/Unit1.dfm @@ -0,0 +1,35 @@ +object Form1: TForm1 + Left = 192 + Top = 114 + Caption = 'Load compiled script demo' + ClientHeight = 168 + ClientWidth = 277 + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + OnCreate = FormCreate + PixelsPerInch = 96 + TextHeight = 13 + object Button1: TButton + Left = 40 + Top = 40 + Width = 193 + Height = 25 + Caption = 'Compile script. Save compile script.' + TabOrder = 0 + OnClick = Button1Click + end + object Button2: TButton + Left = 40 + Top = 96 + Width = 193 + Height = 25 + Caption = 'Load compiled script. Run script.' + TabOrder = 1 + OnClick = Button2Click + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/LoadCompiledScript/Unit1.pas b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/LoadCompiledScript/Unit1.pas new file mode 100644 index 0000000..311d389 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/LoadCompiledScript/Unit1.pas @@ -0,0 +1,98 @@ +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, PaxCompiler, PaxProgram, PaxRegister; +type + TForm1 = class(TForm) + Button1: TButton; + Button2: TButton; + procedure Button1Click(Sender: TObject); + procedure Button2Click(Sender: TObject); + procedure FormCreate(Sender: TObject); + private + H_ShowMessage: Integer; + H_S: Integer; + S: AnsiString; + { Private declarations } + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.dfm} + +procedure TForm1.Button1Click(Sender: TObject); +var + I: Integer; + PaxCompiler1: TPaxCompiler; + PaxPascalLanguage1: TPaxPascalLanguage; + PaxProgram1: TPaxProgram; +begin + PaxCompiler1 := TPaxCompiler.Create(nil); + PaxPascalLanguage1 := TPaxPascalLanguage.Create(nil); + PaxProgram1 := TPaxProgram.Create(nil); + + try + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + + // register routine 'ShowMessage' + H_ShowMessage := PaxCompiler1.RegisterHeader(0, 'procedure ShowMessage(const Msg: string);'); + + // register variable 'S' + H_S := PaxCompiler1.RegisterVariable(0, 'S', _typeSTRING); + + PaxCompiler1.AddModule('1', PaxPascalLanguage1.LanguageName); + PaxCompiler1.AddCode('1', 'begin'); + PaxCompiler1.AddCode('1', ' ShowMessage(S);'); + PaxCompiler1.AddCode('1', 'end.'); + + if PaxCompiler1.Compile(PaxProgram1) then + begin + PaxProgram1.SaveToFile('1.bin'); + ShowMessage('Compiled script has been created!'); + end + else + for I:=0 to PaxCompiler1.ErrorCount - 1 do + ShowMessage(PaxCompiler1.ErrorMessage[I]); + finally + PaxCompiler1.Free; + PaxPascalLanguage1.Free; + PaxProgram1.Free; + end; +end; + +procedure TForm1.Button2Click(Sender: TObject); +var + PaxProgram1: TPaxProgram; +begin + if FileExists('1.bin') and (H_ShowMessage <> 0) and (H_S <> 0) then + begin + PaxProgram1 := TPaxProgram.Create(nil); + try + PaxProgram1.LoadFromFile('1.bin'); + PaxProgram1.SetAddress(H_ShowMessage, @ShowMessage); + PaxProgram1.SetAddress(H_S, @S); + PaxProgram1.Run; + finally + PaxProgram1.Free; + end; + end + else + ShowMessage('Press the first button to create compiled script.'); +end; + +procedure TForm1.FormCreate(Sender: TObject); +begin + H_ShowMessage := 0; + H_S := 0; + S := 'Hello'; +end; + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/OnUndeclaredIdentifier/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/OnUndeclaredIdentifier/Project1.dpr new file mode 100644 index 0000000..bbbee41 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/OnUndeclaredIdentifier/Project1.dpr @@ -0,0 +1,64 @@ +{$APPTYPE CONSOLE} +{$O-} +program Project1; +uses + SysUtils, + PaxCompiler, PaxProgram, PaxRegister; +type + TMyHandler = class + public + function UndeclaredIdentifierHandler(Sender: TPaxCompiler; + const IdentName: String; + var Scope: String; + var FullTypeName: String): boolean; + end; + +function TMyHandler.UndeclaredIdentifierHandler(Sender: TPaxCompiler; + const IdentName: String; + var Scope: String; + var FullTypeName: String): boolean; +begin + result := false; + if CompareText(IdentName, 'x') = 0 then + begin + result := true; + FullTypeName := 'Integer'; + Scope := 'MyProg'; + end; +end; + +var + PaxCompiler1: TPaxCompiler; + PaxProgram1: TPaxProgram; + PaxPascalLanguage1: TPaxPascalLanguage; + MyHandler: TMyHandler; +begin + PaxCompiler1 := TPaxCompiler.Create(nil); + PaxProgram1 := TPaxProgram.Create(nil); + PaxPascalLanguage1 := TPaxPascalLanguage.Create(nil); + MyHandler := TMyHandler.Create; + try + PaxCompiler1.OnUndeclaredIdentifier := MyHandler.UndeclaredIdentifierHandler; + + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + PaxCompiler1.AddModule('1', 'Pascal'); + PaxCompiler1.AddCodeFromFile('1', 'script.txt'); + if PaxCompiler1.Compile(PaxProgram1) then + begin + PaxProgram1.Run; + end + else + begin + writeln(PaxCompiler1.ErrorMessage[0]); + writeln(PaxCompiler1.ErrorLineNumber[0]); + writeln(PaxCompiler1.ErrorLine[0]); + end; + finally + MyHandler.Free; + PaxCompiler1.Free; + PaxProgram1.Free; + PaxPascalLanguage1.Free; + end; + writeln('Press any key...'); + Readln; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/OnUndeclaredIdentifier/script.txt b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/OnUndeclaredIdentifier/script.txt new file mode 100644 index 0000000..cbf67c7 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/OnUndeclaredIdentifier/script.txt @@ -0,0 +1,10 @@ +program MyProg; +procedure P; +begin + writeln(x); + x := 10; + writeln(x); +end; +begin + P; +end. \ No newline at end of file diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/OnUsedUnitEvent/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/OnUsedUnitEvent/Project1.dpr new file mode 100644 index 0000000..513a1dd --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/OnUsedUnitEvent/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/OnUsedUnitEvent/Project1.res b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/OnUsedUnitEvent/Project1.res new file mode 100644 index 0000000..3adc036 Binary files /dev/null and b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/OnUsedUnitEvent/Project1.res differ diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/OnUsedUnitEvent/Unit1.dfm b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/OnUsedUnitEvent/Unit1.dfm new file mode 100644 index 0000000..0c675a1 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/OnUsedUnitEvent/Unit1.dfm @@ -0,0 +1,46 @@ +object Form1: TForm1 + Left = 192 + Top = 114 + Width = 329 + Height = 156 + Caption = 'OnUsedUnit event demo' + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + PixelsPerInch = 96 + TextHeight = 13 + object Button1: TButton + Left = 24 + Top = 24 + Width = 209 + Height = 25 + Caption = 'Compile and Run' + TabOrder = 0 + OnClick = Button1Click + end + object PaxCompiler1: TPaxCompiler + Alignment = 1 + OnUsedUnit = PaxCompiler1UsedUnit + DebugMode = False + Left = 24 + Top = 80 + end + object PaxPascalLanguage1: TPaxPascalLanguage + ExplicitOff = False + CompleteBooleanEval = False + UnitLookup = True + PrintKeyword = 'print' + PrintlnKeyword = 'println' + Left = 72 + Top = 80 + end + object PaxProgram1: TPaxProgram + Console = False + Left = 120 + Top = 80 + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/OnUsedUnitEvent/Unit1.pas b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/OnUsedUnitEvent/Unit1.pas new file mode 100644 index 0000000..1037300 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/OnUsedUnitEvent/Unit1.pas @@ -0,0 +1,73 @@ +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, + Dialogs, PaxProgram, PaxCompiler, PaxRegister, StdCtrls, PaxRunner; + +type + TForm1 = class(TForm) + Button1: TButton; + PaxCompiler1: TPaxCompiler; + PaxPascalLanguage1: TPaxPascalLanguage; + PaxProgram1: TPaxProgram; + procedure Button1Click(Sender: TObject); + function PaxCompiler1UsedUnit(Sender: TPaxCompiler; + const UnitName: String; var SourceCode: String): Boolean; + private + { Private declarations } + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.dfm} + +procedure TForm1.Button1Click(Sender: TObject); +begin + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + PaxCompiler1.AddModule('main', 'Pascal'); + PaxCompiler1.AddCode('main', 'uses SomeUnit;'); + PaxCompiler1.AddCode('main', 'begin'); + PaxCompiler1.AddCode('main', ' P;'); + PaxCompiler1.AddCode('main', 'end.'); + if PaxCompiler1.Compile(PaxProgram1) then + begin + PaxProgram1.Run; + end + else + ShowMessage(PaxCompiler1.ErrorMessage[0]); +end; + +function TForm1.PaxCompiler1UsedUnit(Sender: TPaxCompiler; + const UnitName: String; var SourceCode: String): Boolean; +begin + if UnitName = 'SomeUnit' then + begin + result := true; + SourceCode := + + 'unit SomeUnit;' + #13#10 + + 'interface' + #13#10 + + 'procedure P;' + #13#10 + + 'implementation' + #13#10 + + 'procedure P;' + #13#10 + + 'begin' + #13#10 + + ' ShowMessage(''Hello'');' + #13#10 + + 'end;' + #13#10 + + 'end.' + #13#10; + + end + else + result := false; // default processing +end; + +initialization + RegisterHeader(0, 'procedure ShowMessage(const Msg: string);', @ShowMessage); +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/PCU/MyPascalUnit.pas b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/PCU/MyPascalUnit.pas new file mode 100644 index 0000000..70f03ae --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/PCU/MyPascalUnit.pas @@ -0,0 +1,37 @@ +unit MyPascalUnit; +interface +uses + Controls, StdCtrls, Forms, Dialogs; +type + TMyForm = class(TForm) + Button1: TButton; + private + procedure Button1Click(Sender: TObject); + public + constructor Create; + end; + +implementation + +constructor TMyForm.Create; +begin + inherited Create(nil); + Caption := 'My form created in Pascal'; + Button1 := TButton.Create(Self); + with Button1 do + begin + Parent := Self; + Caption := 'Click Me'; + Name := 'Button1'; + Left := 10; + Top := 20; + OnClick := Button1Click; + end; +end; + +procedure TMyForm.Button1Click(Sender: TObject); +begin + ShowMessage('Hello!'); +end; + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/PCU/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/PCU/Project1.dpr new file mode 100644 index 0000000..a7b2225 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/PCU/Project1.dpr @@ -0,0 +1,228 @@ +program Project2; +{$APPTYPE CONSOLE} +uses + sysutils, + Classes, + TypInfo, + Forms, + PAXCOMP_CONSTANTS, + PaxRunner, + PaxCompiler, + PaxCompilerExplorer, + PaxCompilerDebugger, + PaxBasicLanguage, + PaxProgram, + PaxRegister, + IMPORT_Common; + +type + TMyHandler = class + private + L: TStringList; + public + constructor Create; + destructor Destroy; override; + procedure SaveToDisk; + function SavePCUCompilerHandler(Sender: TPaxCompiler; const UnitName: String): TStream; + function LoadPCUCompilerHandler(Sender: TPaxCompiler; const UnitName: String): TStream; + procedure UnknownDirectiveHandler(Sender: TPaxCompiler; + const Directive: string; var ok: Boolean); + + function LoadPCUProgramHandler(Sender: TPaxRunner; const UnitName: String): TStream; + + procedure CreateObjectHandler(Sender: TPaxRunner; + Instance: TObject); + procedure AfterObjectCreationHandler(Sender: TPaxRunner; + Instance: TObject); + procedure DestroyObjectHandler(Sender: TPaxRunner; + Instance: TObject); + procedure AfterObjectDestructionHandler(Sender: TPaxRunner; + Instance: TObject); + end; + +constructor TMyHandler.Create; +begin + inherited; + L := TStringList.Create; +end; + +destructor TMyHandler.Destroy; +var + I: Integer; +begin + for I := 0 to L.Count - 1 do + L.Objects[I].Free; + + L.Free; + inherited; +end; + +procedure TMyHandler.SaveToDisk; +var + I: Integer; + Stream: TMemoryStream; + S: String; +begin + for I := 0 to L.Count - 1 do + begin + S := L[I]; + Stream := TMemoryStream(L.Objects[I]); + Stream.Position := 0; + Stream.SaveToFile(S + '.PCU'); + end; +end; + +function TMyHandler.SavePCUCompilerHandler(Sender: TPaxCompiler; const UnitName: String): TStream; +begin + result := TMemoryStream.Create; + L.AddObject(UnitName, result); +end; + +function TMyHandler.LoadPCUCompilerHandler(Sender: TPaxCompiler; const UnitName: String): TStream; +var + I: Integer; +begin + result := nil; + for I := 0 to L.Count - 1 do + if CompareText(L[I], UnitName) = 0 then + begin + result := TStream(L.Objects[I]); + result.Position := 0; + Exit; + end; +end; + +function TMyHandler.LoadPCUProgramHandler(Sender: TPaxRunner; const UnitName: String): TStream; +var + I: Integer; +begin + result := nil; + for I := 0 to L.Count - 1 do + if CompareText(L[I], UnitName) = 0 then + begin + result := TStream(L.Objects[I]); + result.Position := 0; + Exit; + end; +end; + +procedure TMyHandler.CreateObjectHandler(Sender: TPaxRunner; + Instance: TObject); +var + pti: PTypeInfo; + ptd: PTypeData; + S: String; +begin + writeln('OnCreateObject:'); + + if Instance is TForm then + begin + pti := Instance.ClassInfo; + ptd := GetTypeData(pti); + if FileExists(ptd^.UnitName + '.dfm') then + Sender.LoadDFMFile(Instance, ptd^.UnitName + '.dfm'); + end; +end; + +procedure TMyHandler.AfterObjectCreationHandler(Sender: TPaxRunner; + Instance: TObject); +begin + writeln('OnAfterObjectCreation:'); +end; + +procedure TMyHandler.DestroyObjectHandler(Sender: TPaxRunner; + Instance: TObject); +begin + writeln('OnDestroyObject:'); +end; + +procedure TMyHandler.AfterObjectDestructionHandler(Sender: TPaxRunner; + Instance: TObject); +begin + writeln('OnAfterObjectDestruction:'); +end; + +procedure TMyHandler.UnknownDirectiveHandler(Sender: TPaxCompiler; + const Directive: string; var ok: Boolean); +begin + ok := true; +end; + +var + MyHandler: TMyHandler; + +var + PaxCompiler1: TPaxCompiler; + PaxProgram1: TPaxProgram; + PaxPascalLanguage1: TPaxPascalLanguage; +begin + // Build all units, save pcu-files and create compiled script + + MyHandler := TMyHandler.Create; + try + + PaxCompiler1 := TPaxCompiler.Create(nil); + PaxCompiler1.OnUnknownDirective := MyHandler.UnknownDirectiveHandler; +// PaxCompiler1.OnSavePCU := MyHandler.SavePCUCompilerHandler; +// PaxCompiler1.OnLoadPCU := MyHandler.LoadPCUCompilerHandler; + + PaxProgram1 := TPaxProgram.Create(nil); + PaxProgram1.OnCreateObject := MyHandler.CreateObjectHandler; + PaxProgram1.OnAfterObjectCreation := MyHandler.AfterObjectCreationHandler; + PaxProgram1.OnDestroyObject := MyHandler.DestroyObjectHandler; + + PaxPascalLanguage1 := TPaxPascalLanguage.Create(nil); + try + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + PaxCompiler1.AddModule('1', 'Pascal'); +// PaxCompiler1.AddCodeFromFile('1', 'script.txt'); + PaxCompiler1.AddCodeFromFile('1', 'script6.txt'); + + if PaxCompiler1.Compile(PaxProgram1, true, false) then + // build with run-time packages + begin + PaxProgram1.SaveToFile('script.bin'); +// PaxProgram1.Run; +// writeln('Press any key...'); +// Readln; +// Exit; + end + else + begin + writeln(PaxCompiler1.ErrorMessage[0]); + writeln(PaxCompiler1.ErrorLine[0]); + writeln('Press any key...'); + Readln; + Exit; + end; + finally + PaxCompiler1.Free; + PaxProgram1.Free; + PaxPascalLanguage1.Free; + end; + +// MyHandler.SaveToDisk; + + // Use compiled units (pcu-files) at run-tme as run-time packages + + PaxProgram1 := TPaxProgram.Create(nil); + PaxProgram1.OnCreateObject := MyHandler.CreateObjectHandler; + PaxProgram1.OnAfterObjectCreation := MyHandler.AfterObjectCreationHandler; + PaxProgram1.OnDestroyObject := MyHandler.DestroyObjectHandler; + try +// PaxProgram1.OnLoadPCU := MyHandler.LoadPCUProgramHandler; + + PaxProgram1.LoadFromFile('script.bin'); + PaxProgram1.Run; + finally + PaxProgram1.Free; + end; + + finally + MyHandler.Free; + end; + + writeln('Press any key...'); + Readln; +end. + diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/PCU/Project2.dpr b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/PCU/Project2.dpr new file mode 100644 index 0000000..38c0f5b --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/PCU/Project2.dpr @@ -0,0 +1,102 @@ +program Project2; +{$APPTYPE CONSOLE} +uses + sysutils, + Classes, + TypInfo, + StdCtrls, + Forms, + Dialogs, + PaxProgram, + PaxRegister; + +type + TMyHandler = class + public + procedure CreateObjectHandler(Sender: TPaxProgram; + Instance: TObject); + procedure MapTableClassRefHandler(Sender: TPaxProgram; + const FullName: String; + Global: Boolean; var ClassRef: TClass); + procedure MapTableProcAddressHandler(Sender: TPaxProgram; + const FullName: String; OverCount: Byte; + Global: Boolean; var Address: Pointer); + end; + +procedure TMyHandler.CreateObjectHandler(Sender: TPaxProgram; + Instance: TObject); +var + pti: PTypeInfo; + ptd: PTypeData; + S: String; +begin + writeln('OnCreateObject:'); + + if Instance is TForm then + begin + pti := Instance.ClassInfo; + ptd := GetTypeData(pti); + if FileExists(ptd^.UnitName + '.dfm') then + Sender.LoadDFMFile(Instance, ptd^.UnitName + '.dfm'); + end; +end; + +procedure TMyHandler.MapTableClassRefHandler(Sender: TPaxProgram; + const FullName: String; + Global: Boolean; var ClassRef: TClass); +begin + if CompareText(FullName, 'Classes.TComponent') = 0 then + ClassRef := Classes.TComponent + else if CompareText(FullName, 'Forms.TCustomForm') = 0 then + ClassRef := Forms.TCustomForm + else if CompareText(FullName, 'Forms.TForm') = 0 then + ClassRef := Forms.TForm + else if CompareText(FullName, 'StdCtrls.TButton') = 0 then + ClassRef := StdCtrls.TButton; +end; + +procedure TMyHandler.MapTableProcAddressHandler(Sender: TPaxProgram; + const FullName: String; OverCount: Byte; + Global: Boolean; var Address: Pointer); +begin + if CompareText(FullName, 'SysUtils.IntToStr') = 0 then + Address := @ SysUtils.IntToStr + else if CompareText(FullName, 'Forms.TCustomForm.ShowModal') = 0 then + Address := @ Forms.TCustomForm.ShowModal + else if CompareText(FullName, 'Forms.TForm.Create') = 0 then + Address := @ Forms.TForm.Create + else if CompareText(FullName, 'Dialogs.ShowMessage') = 0 then + Address := @ Dialogs.ShowMessage; +end; + +var + MyHandler: TMyHandler; + +var + PaxProgram1: TPaxProgram; +begin + try + + // Use compiled units (pcu-files) at run-tme as run-time packages + + PaxProgram1 := TPaxProgram.Create(nil); + PaxProgram1.OnCreateObject := MyHandler.CreateObjectHandler; + try + PaxProgram1.OnMapTableClassRef := MyHandler.MapTableClassRefHandler; + PaxProgram1.OnMapTableProcAddress := MyHandler.MapTableProcAddressHandler; + + PaxProgram1.LoadFromFile('script.bin'); + PaxProgram1.MapGlobal; + PaxProgram1.Run; + finally + PaxProgram1.Free; + end; + + finally + MyHandler.Free; + end; + + writeln('Press any key...'); + Readln; +end. + diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/PCU/Unit2.PCU b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/PCU/Unit2.PCU new file mode 100644 index 0000000..80d26ea Binary files /dev/null and b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/PCU/Unit2.PCU differ diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/PCU/Unit2.dfm b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/PCU/Unit2.dfm new file mode 100644 index 0000000..da6204b --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/PCU/Unit2.dfm @@ -0,0 +1,26 @@ +object Form2: TForm2 + Left = 0 + Top = 0 + Caption = 'Form2' + ClientHeight = 216 + ClientWidth = 426 + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'Tahoma' + Font.Style = [] + OldCreateOrder = False + OnCreate = FormCreate + PixelsPerInch = 96 + TextHeight = 13 + object Button1: TButton + Left = 40 + Top = 88 + Width = 75 + Height = 25 + Caption = 'Button1' + TabOrder = 0 + OnClick = Button1Click + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/PCU/Unit2.pas b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/PCU/Unit2.pas new file mode 100644 index 0000000..211caa6 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/PCU/Unit2.pas @@ -0,0 +1,37 @@ +unit Unit2; + +interface + +uses + SysUtils, Variants, Classes, Controls, Forms, + Dialogs, StdCtrls; + +type + TForm2 = class(TForm) + Button1: TButton; + procedure FormCreate(Sender: TObject); + procedure Button1Click(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + end; + +var + Form2: TForm2; + +implementation + +{$R *.dfm} + +procedure TForm2.Button1Click(Sender: TObject); +begin + ShowMessage('Hello'); +end; + +procedure TForm2.FormCreate(Sender: TObject); +begin + ShowMessage('Created'); +end; + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/PCU/UnitB.pas b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/PCU/UnitB.pas new file mode 100644 index 0000000..7dbf663 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/PCU/UnitB.pas @@ -0,0 +1,70 @@ +Unit UnitB; +interface + +procedure PB(X, Y, Z: Integer); + +type + PMyRecord = ^TMyRecord; + + TMyRecord = record + X: Integer; + Y: Integer; + end; + + TProcPB = procedure (X, Y, Z: Integer); + TFuncB = function: Integer of object; stdcall; + + IMyInterface = interface(IUnknown) + ['{E7AA427A-0F4D-4A96-A914-FAB1CA336337}'] + procedure P(X, Y: Integer); cdecl; + function GetX: Integer; + property X: Integer read GetX; + end; + + TMyClassBClass = class of TMyClassB; + + TMyClassB = class(TInterfacedObject, IMyInterface) + constructor Create; + procedure P(X, Y: Integer); cdecl; + function GetX: Integer; + destructor Destroy; override; + end; + + TDynArrB = array of Integer; + +implementation + +uses + UnitA; + +constructor TMyClassB.Create; +begin + inherited; + writeln('Created TMyClassB instance'); +end; + +procedure TMyClassB.P(X, Y: Integer); +begin + writeln(Self.ClassName); + writeln(X, ' ', Y); +end; + +function TMyClassB.GetX: Integer; +begin + result := 123; +end; + + +destructor TMyClassB.Destroy; +begin + writeln('Done'); + inherited; +end; + +procedure PB(X, Y, Z: Integer); +begin + writeln('ProcB'); + ProcA; +end; + +end. \ No newline at end of file diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/PCU/UnitC.pas b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/PCU/UnitC.pas new file mode 100644 index 0000000..33f21fb --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/PCU/UnitC.pas @@ -0,0 +1,46 @@ +Unit UnitC; +interface +uses SysUtils; + +type + TSS = String[5]; + TArrC = array[1..2, 1..3] of Integer; + + CheckFailed = CLASS(Exception) + end; + OtherFailed = CLASS(Exception) + end; + +procedure ProcC(const A: array of Integer); +procedure DoScriptExc; + +implementation + +procedure ProcC(const A: array of Integer); +var + I: Integer; +begin + I := 0; + try + I := I div I; + except + writeln(123); + end; +end; + +procedure DoScriptExc; +begin + try + RAISE checkFailed.create('Select check failed'); +// RAISE OtherFailed.create('Select check failed'); + // RAISE exception.create('Select check failed'); + except + on CheckFailed do + writeln('checkfailed raised'); + else + writeln('other raised'); + end; +end; + + +end. \ No newline at end of file diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/PCU/UnitD.pas b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/PCU/UnitD.pas new file mode 100644 index 0000000..fcfa4d6 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/PCU/UnitD.pas @@ -0,0 +1,50 @@ +Unit UnitD; +interface + +const + ConstIntD = 45; + ConstInitStrD: String = 'abc'; + ConstStrD = 'abc'; + ConstSetD = ['a'..'z']; + +type + TMyClassD = class + constructor Create; + procedure P; virtual; + procedure Q; virtual; + end; + +procedure MyProcD; overload; +procedure MyProcD(X: Integer); overload; + +implementation + +constructor TMyClassD.Create; +begin + inherited; + writeln('MyClassD.Create'); +end; + + +procedure TMyClassD.P; +begin + writeln('MyClassD.P'); +end; + +procedure TMyClassD.Q; +begin + writeln('MyClassD.Q'); +end; + +procedure MyProcD; +begin + writeln(1); +end; + +procedure MyProcD(X: Integer); +begin + writeln(2); +end; + + +end. \ No newline at end of file diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/PCU/UnitE.pas b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/PCU/UnitE.pas new file mode 100644 index 0000000..e84f0dc --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/PCU/UnitE.pas @@ -0,0 +1,27 @@ +Unit UnitE; +interface +uses SysUtils; + +procedure ProcE; overload; +procedure ProcE(X: Integer); overload; +procedure TestHostProc; + +implementation + +procedure ProcE; +begin + writeln(1); +end; + +procedure ProcE(X: Integer); +begin + writeln(2); +end; + +procedure TestHostProc; +begin + writeln(IntToStr(123)); +end; + + +end. \ No newline at end of file diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/PCU/script.txt b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/PCU/script.txt new file mode 100644 index 0000000..aaf79f7 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/PCU/script.txt @@ -0,0 +1,60 @@ +uses + UnitA, UnitB; +var + ProcPB: TProcPB; + I: Integer; + EnumA: TEnumA; + ArrA: TArrA; + SetA: TSetA; + IntAliasA: TIntAliasA; + X: TMyScriptClass; + MyRecord: TMyRecord; + MyInterface: IMyInterface; + Y: TMyClassB; + C: TMyClassBClass; + A: TDynArrB; +begin + Y := TMyClassB.Create; + + MyInterface := TMyClassB.Create as IMyInterface; + MyInterface.P(3, 4); + writeln(MyInterface.X); + + SetLength(A, 3); + A[2] := 77; + writeln(A[2]); + + C := TMyClassB; + writeln(C.ClassName); + + ProcPB := PB; + ProcPB(1, 2, 3); + + + MyRecord.Y := 888; + writeln(MyRecord.Y); + + X := TMyScriptClass.Create; + X.X := TObject.Create; + writeln(X.X.ClassName); + X.MethodP(2, 3); + X.MethodF; + TMyScriptClass.MethodCP; + X.Y := 999; + writeln(X.Y); + + writeln(X is TMyScriptClass); + writeln(X.ClassName); + writeln(TMyScriptClass.ClassName); + X.Free; + + EnumA := TwoA; + writeln(Ord(EnumA)); + ArrA['p'] := EnumA; + writeln(Ord(ArrA['p'])); + I := FuncA(2, 3); + writeln(I); + writeln(XA); + writeln(SA); + SA := 5; +end. \ No newline at end of file diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/PCU/script2.txt b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/PCU/script2.txt new file mode 100644 index 0000000..eae12fa --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/PCU/script2.txt @@ -0,0 +1,7 @@ +uses + UnitC; +begin + ProcC([1, 2, 3]); + writeln(456); + DoScriptExc; +end. \ No newline at end of file diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/PCU/script3.txt b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/PCU/script3.txt new file mode 100644 index 0000000..773d49e --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/PCU/script3.txt @@ -0,0 +1,8 @@ +uses Forms, MyPascalUnit; +var + F: TMyForm; +begin + F := TMyForm.Create; + F.ShowModal; + F.Free; +end. \ No newline at end of file diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/PCU/script4.txt b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/PCU/script4.txt new file mode 100644 index 0000000..4916e82 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/PCU/script4.txt @@ -0,0 +1,38 @@ +uses + UnitD; +type + TMyClass = class(TMyClassD) + constructor Create; + procedure P; override; + end; + +constructor TMyClass.Create; +begin + inherited; + writeln('TMyClass.Create'); +end; + + +procedure TMyClass.P; +begin + inherited; + writeln('TMyClass.P'); +end; + +var + X: TMyClassD; +begin + X := TMyClassD.Create; + X.Q; + X.Free; + + X := TMyClass.Create; + X.P; + X.Q; + X.Free; + + writeln(ConstIntD); + writeln(ConstStrD); + writeln('b' in ConstSetD); + writeln('B' in ConstSetD); +end. \ No newline at end of file diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/PCU/script5.txt b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/PCU/script5.txt new file mode 100644 index 0000000..473d18c --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/PCU/script5.txt @@ -0,0 +1,4 @@ +uses UnitY; +begin + ProcY; +end. \ No newline at end of file diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/PCU/script6.txt b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/PCU/script6.txt new file mode 100644 index 0000000..792ce4b --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/PCU/script6.txt @@ -0,0 +1,8 @@ +uses Forms, Unit2; +var + F: TForm2; +begin + F := TForm2.Create(nil); + F.ShowModal; + F.Free; +end. \ No newline at end of file diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/PCU/script7.txt b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/PCU/script7.txt new file mode 100644 index 0000000..1c0a370 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/PCU/script7.txt @@ -0,0 +1,6 @@ +uses UnitE; +begin + ProcE(1); + ProcE; + TestHostProc; +end. \ No newline at end of file diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/PCU/unitA.pas b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/PCU/unitA.pas new file mode 100644 index 0000000..398a619 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/PCU/unitA.pas @@ -0,0 +1,83 @@ +unit UnitA; +interface +uses + UnitB; + +type + TIntAliasA = Integer; + + TEnumA = (OneA, TwoA); + + TArrA = array['a'..'z'] of TEnumA; + + TSetA = set of TEnumA; + + TMyScriptClass = class + FX: TObject; + public + FY: Integer; + constructor Create; + destructor Destroy; override; + procedure MethodP(X, Y: Integer); + function MethodF: Integer; // virtual; + class procedure MethodCP; + property Y: Integer read FY write FY; + published + property X: TObject read FX write FX; + end; + + +function FuncA(X, Y: Integer): Integer; +procedure ProcA; + +var XA: Integer = 55; + +const + SA: Integer = 11; + +implementation + +constructor TMyScriptClass.Create; +begin + inherited; + writeln('Create'); +end; + +destructor TMyScriptClass.Destroy; +begin + writeln('Destroy'); + inherited; +end; + +procedure TMyScriptClass.MethodP(X, Y: Integer); +begin + writeln('MethodP', X, Y); +end; + +function TMyScriptClass.MethodF: Integer; +begin + writeln('MethodF'); +end; + +class procedure TMyScriptClass.MethodCP; +begin + writeln('MethodCP'); +end; + + +function FuncA(X, Y: Integer): Integer; +begin + PB(1, 2, 3); + try + result := X + Y; + finally + writeln('123'); + end; +end; + +procedure ProcA; +begin + writeln('ProcA'); +end; + +end. \ No newline at end of file diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/PCU/unitX.pas b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/PCU/unitX.pas new file mode 100644 index 0000000..1e80879 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/PCU/unitX.pas @@ -0,0 +1,30 @@ +unit UnitX; +interface + +type + TClassX = class + constructor Create; + procedure ProcX; virtual; + destructor Destroy; override; + end; + +implementation + +constructor TClassX.Create; +begin + inherited; + writeln('ClassX object created'); +end; + +procedure TClassX.ProcX; +begin + writeln('ProcX'); +end; + +destructor TClassX.Destroy; +begin + writeln('ClassX object destroyed'); + inherited; +end; + +end. \ No newline at end of file diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/PCU/unitY.pas b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/PCU/unitY.pas new file mode 100644 index 0000000..f325cca --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/PCU/unitY.pas @@ -0,0 +1,19 @@ +unit UnitY; +interface +uses + UnitX; + +procedure ProcY; + +implementation + +procedure ProcY; +var + X: TClassX; +begin + X := TClassX.Create; + X.ProcX; + X.Free; +end; + +end. \ No newline at end of file diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/PaxInvoke/CppDll/CppDll/CppDll.dsp b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/PaxInvoke/CppDll/CppDll/CppDll.dsp new file mode 100644 index 0000000..1aa0398 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/PaxInvoke/CppDll/CppDll/CppDll.dsp @@ -0,0 +1,113 @@ +# Microsoft Developer Studio Project File - Name="CppDll" - Package Owner=<4> +# Microsoft Developer Studio Generated Build File, Format Version 6.00 +# ** DO NOT EDIT ** + +# TARGTYPE "Win32 (x86) Dynamic-Link Library" 0x0102 + +CFG=CppDll - Win32 Debug +!MESSAGE This is not a valid makefile. To build this project using NMAKE, +!MESSAGE use the Export Makefile command and run +!MESSAGE +!MESSAGE NMAKE /f "CppDll.mak". +!MESSAGE +!MESSAGE You can specify a configuration when running NMAKE +!MESSAGE by defining the macro CFG on the command line. For example: +!MESSAGE +!MESSAGE NMAKE /f "CppDll.mak" CFG="CppDll - Win32 Debug" +!MESSAGE +!MESSAGE Possible choices for configuration are: +!MESSAGE +!MESSAGE "CppDll - Win32 Release" (based on "Win32 (x86) Dynamic-Link Library") +!MESSAGE "CppDll - Win32 Debug" (based on "Win32 (x86) Dynamic-Link Library") +!MESSAGE + +# Begin Project +# PROP AllowPerConfigDependencies 0 +# PROP Scc_ProjName "" +# PROP Scc_LocalPath "" +CPP=cl.exe +MTL=midl.exe +RSC=rc.exe + +!IF "$(CFG)" == "CppDll - Win32 Release" + +# PROP BASE Use_MFC 0 +# PROP BASE Use_Debug_Libraries 0 +# PROP BASE Output_Dir "Release" +# PROP BASE Intermediate_Dir "Release" +# PROP BASE Target_Dir "" +# PROP Use_MFC 0 +# PROP Use_Debug_Libraries 0 +# PROP Output_Dir "Release" +# PROP Intermediate_Dir "Release" +# PROP Target_Dir "" +# ADD BASE CPP /nologo /MT /W3 /GX /O2 /D "WIN32" /D "NDEBUG" /D "_WINDOWS" /D "_MBCS" /D "_USRDLL" /D "CPPDLL_EXPORTS" /YX /FD /c +# ADD CPP /nologo /MT /W3 /GX /O2 /D "WIN32" /D "NDEBUG" /D "_WINDOWS" /D "_MBCS" /D "_USRDLL" /D "CPPDLL_EXPORTS" /YX /FD /c +# ADD BASE MTL /nologo /D "NDEBUG" /mktyplib203 /win32 +# ADD MTL /nologo /D "NDEBUG" /mktyplib203 /win32 +# ADD BASE RSC /l 0x419 /d "NDEBUG" +# ADD RSC /l 0x419 /d "NDEBUG" +BSC32=bscmake.exe +# ADD BASE BSC32 /nologo +# ADD BSC32 /nologo +LINK32=link.exe +# ADD BASE LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /dll /machine:I386 +# ADD LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /dll /machine:I386 + +!ELSEIF "$(CFG)" == "CppDll - Win32 Debug" + +# PROP BASE Use_MFC 0 +# PROP BASE Use_Debug_Libraries 1 +# PROP BASE Output_Dir "Debug" +# PROP BASE Intermediate_Dir "Debug" +# PROP BASE Target_Dir "" +# PROP Use_MFC 0 +# PROP Use_Debug_Libraries 1 +# PROP Output_Dir "Debug" +# PROP Intermediate_Dir "Debug" +# PROP Target_Dir "" +# ADD BASE CPP /nologo /MTd /W3 /Gm /GX /ZI /Od /D "WIN32" /D "_DEBUG" /D "_WINDOWS" /D "_MBCS" /D "_USRDLL" /D "CPPDLL_EXPORTS" /YX /FD /GZ /c +# ADD CPP /nologo /MTd /W3 /Gm /GX /ZI /Od /D "WIN32" /D "_DEBUG" /D "_WINDOWS" /D "_MBCS" /D "_USRDLL" /D "CPPDLL_EXPORTS" /YX /FD /GZ /c +# ADD BASE MTL /nologo /D "_DEBUG" /mktyplib203 /win32 +# ADD MTL /nologo /D "_DEBUG" /mktyplib203 /win32 +# ADD BASE RSC /l 0x419 /d "_DEBUG" +# ADD RSC /l 0x419 /d "_DEBUG" +BSC32=bscmake.exe +# ADD BASE BSC32 /nologo +# ADD BSC32 /nologo +LINK32=link.exe +# ADD BASE LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /dll /debug /machine:I386 /pdbtype:sept +# ADD LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /dll /debug /machine:I386 /pdbtype:sept + +!ENDIF + +# Begin Target + +# Name "CppDll - Win32 Release" +# Name "CppDll - Win32 Debug" +# Begin Group "Source Files" + +# PROP Default_Filter "cpp;c;cxx;rc;def;r;odl;idl;hpj;bat" +# Begin Source File + +SOURCE=.\cppdll.cpp +# End Source File +# Begin Source File + +SOURCE=.\cppdll.def +# End Source File +# End Group +# Begin Group "Header Files" + +# PROP Default_Filter "h;hpp;hxx;hm;inl" +# Begin Source File + +SOURCE=.\cppdll.h +# End Source File +# End Group +# Begin Group "Resource Files" + +# PROP Default_Filter "ico;cur;bmp;dlg;rc2;rct;bin;rgs;gif;jpg;jpeg;jpe" +# End Group +# End Target +# End Project diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/PaxInvoke/CppDll/CppDll/CppDll.dsw b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/PaxInvoke/CppDll/CppDll/CppDll.dsw new file mode 100644 index 0000000..f0c62b4 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/PaxInvoke/CppDll/CppDll/CppDll.dsw @@ -0,0 +1,29 @@ +Microsoft Developer Studio Workspace File, Format Version 6.00 +# WARNING: DO NOT EDIT OR DELETE THIS WORKSPACE FILE! + +############################################################################### + +Project: "CppDll"=.\CppDll.dsp - Package Owner=<4> + +Package=<5> +{{{ +}}} + +Package=<4> +{{{ +}}} + +############################################################################### + +Global: + +Package=<5> +{{{ +}}} + +Package=<3> +{{{ +}}} + +############################################################################### + diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/PaxInvoke/CppDll/CppDll/CppDll.ncb b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/PaxInvoke/CppDll/CppDll/CppDll.ncb new file mode 100644 index 0000000..bab469d Binary files /dev/null and b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/PaxInvoke/CppDll/CppDll/CppDll.ncb differ diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/PaxInvoke/CppDll/CppDll/CppDll.opt b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/PaxInvoke/CppDll/CppDll/CppDll.opt new file mode 100644 index 0000000..2493e4c Binary files /dev/null and b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/PaxInvoke/CppDll/CppDll/CppDll.opt differ diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/PaxInvoke/CppDll/CppDll/CppDll.plg b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/PaxInvoke/CppDll/CppDll/CppDll.plg new file mode 100644 index 0000000..b79ed00 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/PaxInvoke/CppDll/CppDll/CppDll.plg @@ -0,0 +1,34 @@ + + +
+
Build Log

+

+--------------------Configuration: CppDll - Win32 Debug--------------------
+

+
Command Lines

+Creating temporary file "C:\DOCUME~1\ALEXAN~1\LOCALS~1\Temp\RSP88.tmp" with contents
+[
+/nologo /MTd /W3 /Gm /GX /ZI /Od /D "WIN32" /D "_DEBUG" /D "_WINDOWS" /D "_MBCS" /D "_USRDLL" /D "CPPDLL_EXPORTS" /Fp"Debug/CppDll.pch" /YX /Fo"Debug/" /Fd"Debug/" /FD /GZ /c 
+"C:\hot\Assem\demos\CallRoutineEx\CppDll\CppDll\cppdll.cpp"
+]
+Creating command line "cl.exe @C:\DOCUME~1\ALEXAN~1\LOCALS~1\Temp\RSP88.tmp" 
+Creating temporary file "C:\DOCUME~1\ALEXAN~1\LOCALS~1\Temp\RSP89.tmp" with contents
+[
+kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /dll /incremental:yes /pdb:"Debug/CppDll.pdb" /debug /machine:I386 /def:".\cppdll.def" /out:"Debug/CppDll.dll" /implib:"Debug/CppDll.lib" /pdbtype:sept 
+.\Debug\cppdll.obj
+]
+Creating command line "link.exe @C:\DOCUME~1\ALEXAN~1\LOCALS~1\Temp\RSP89.tmp"
+
Output Window

+Compiling...
+cppdll.cpp
+Linking...
+LINK : LNK6004: Debug/CppDll.dll not found or not built by the last incremental link; performing full link
+   Creating library Debug/CppDll.lib and object Debug/CppDll.exp
+
+
+
+
Results

+CppDll.dll - 0 error(s), 0 warning(s)
+
+ + diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/PaxInvoke/CppDll/CppDll/cppdll.cpp b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/PaxInvoke/CppDll/CppDll/cppdll.cpp new file mode 100644 index 0000000..2c48f59 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/PaxInvoke/CppDll/CppDll/cppdll.cpp @@ -0,0 +1,66 @@ +#include "cppdll.h" + +//prevent function name from being mangled +extern "C" + +int __fastcall cube(int num) +{ + return num * num * num; +} + +double __fastcall arr(double a[], int i, int j, float f) +{ + return a[0] + a[1] + i + j + f; +} + +char __fastcall ret_char(char * s) +{ + return s[0]; +} + +MyPoint __fastcall ret_struct(int x, int y, int z) +{ + MyPoint p; + p.x = x; + p.y = y; + p.z = z; + return p; +} + +MyPoint2 __fastcall ret_struct2(int x, int y) +{ + MyPoint2 p; + p.x = x; + p.y = y; + return p; +} + +MyPoint __fastcall pass_struct(const MyPoint & q) +{ + MyPoint p; + p.x = q.x; + p.y = q.y; + p.z = q.z; + return p; +} + +MyPoint __fastcall pass_struct_byval(MyPoint q) +{ + MyPoint p; + p.x = q.x; + p.y = q.y; + p.z = q.z; + return p; +} + +double __fastcall dcube(double num) +{ + return num * num * num; +} + +float __fastcall fcube(float num) +{ + return num * num * num; +} + + diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/PaxInvoke/CppDll/CppDll/cppdll.def b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/PaxInvoke/CppDll/CppDll/cppdll.def new file mode 100644 index 0000000..8cbfb6b --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/PaxInvoke/CppDll/CppDll/cppdll.def @@ -0,0 +1,10 @@ +EXPORTS + cube + arr + ret_char + ret_struct + ret_struct2 + pass_struct + pass_struct_byval + dcube + fcube diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/PaxInvoke/CppDll/CppDll/cppdll.h b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/PaxInvoke/CppDll/CppDll/cppdll.h new file mode 100644 index 0000000..515b5ae --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/PaxInvoke/CppDll/CppDll/cppdll.h @@ -0,0 +1,34 @@ +/* + this header is not required for this dll + to compile; but is required for the app + that will use this dll +*/ + +#ifndef CPPDLL_H +#define CPPDLL_H + +struct MyPoint +{ + int x; + int y; + int z; +}; + +struct MyPoint2 +{ + int x; + int y; +}; + +extern "C" +int __fastcall cube(int num); +double __fastcall arr(double a[], int i, int j, float f); +char __fastcall ret_char(char * s); +MyPoint __fastcall ret_struct(int x, int y, int z); +MyPoint2 __fastcall ret_struct2(int x, int y); +MyPoint __fastcall pass_struct(const MyPoint & q); +MyPoint __fastcall pass_struct_byval(MyPoint q); +double __fastcall dcube(double num); +float __fastcall fcube(float num); + +#endif //CPPDLL_H \ No newline at end of file diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/PaxInvoke/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/PaxInvoke/Project1.dpr new file mode 100644 index 0000000..513a1dd --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/PaxInvoke/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/PaxInvoke/Project1.res b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/PaxInvoke/Project1.res new file mode 100644 index 0000000..8e8388f Binary files /dev/null and b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/PaxInvoke/Project1.res differ diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/PaxInvoke/Unit1.dfm b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/PaxInvoke/Unit1.dfm new file mode 100644 index 0000000..fae8b8a --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/PaxInvoke/Unit1.dfm @@ -0,0 +1,112 @@ +object Form1: TForm1 + Left = 192 + Top = 114 + Width = 211 + Height = 324 + Caption = 'Call routine demo' + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + PixelsPerInch = 96 + TextHeight = 13 + object Button1: TButton + Left = 32 + Top = 45 + Width = 121 + Height = 25 + Caption = 'Invokel script function' + TabOrder = 0 + OnClick = Button1Click + end + object Button2: TButton + Left = 32 + Top = 75 + Width = 121 + Height = 25 + Caption = 'Call host function' + TabOrder = 1 + OnClick = Button2Click + end + object Button3: TButton + Left = 32 + Top = 105 + Width = 121 + Height = 25 + Caption = 'Call host method' + TabOrder = 2 + OnClick = Button3Click + end + object Button4: TButton + Left = 32 + Top = 134 + Width = 121 + Height = 25 + Caption = 'Test dynamic array' + TabOrder = 3 + OnClick = Button4Click + end + object Button5: TButton + Left = 32 + Top = 159 + Width = 121 + Height = 25 + Caption = 'Test sets' + TabOrder = 4 + OnClick = Button5Click + end + object Button6: TButton + Left = 32 + Top = 184 + Width = 121 + Height = 25 + Caption = 'Test C++ Dll' + TabOrder = 5 + OnClick = Button6Click + end + object Button7: TButton + Left = 32 + Top = 210 + Width = 121 + Height = 25 + Caption = 'Test SAFECALL' + TabOrder = 6 + OnClick = Button7Click + end + object Button8: TButton + Left = 32 + Top = 239 + Width = 120 + Height = 25 + Caption = 'Test interface' + TabOrder = 7 + OnClick = Button8Click + end + object PaxCompiler1: TPaxCompiler + Alignment = 8 + DebugMode = False + Left = 16 + Top = 16 + end + object PaxPascalLanguage1: TPaxPascalLanguage + ExplicitOff = False + CompleteBooleanEval = False + UnitLookup = True + PrintKeyword = 'print' + PrintlnKeyword = 'println' + Left = 48 + Top = 16 + end + object PaxProgram1: TPaxProgram + Console = False + Left = 80 + Top = 16 + end + object PaxInvoke1: TPaxInvoke + Left = 128 + Top = 16 + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/PaxInvoke/Unit1.pas b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/PaxInvoke/Unit1.pas new file mode 100644 index 0000000..7905321 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/PaxInvoke/Unit1.pas @@ -0,0 +1,376 @@ +unit Unit1; + +{$O-} +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, PaxCompiler, PaxInvoke, PaxProgram, PaxRegister, PaxRunner; + +type + TForm1 = class(TForm) + PaxCompiler1: TPaxCompiler; + PaxPascalLanguage1: TPaxPascalLanguage; + PaxProgram1: TPaxProgram; + Button1: TButton; + Button2: TButton; + Button3: TButton; + PaxInvoke1: TPaxInvoke; + Button4: TButton; + Button5: TButton; + Button6: TButton; + Button7: TButton; + Button8: TButton; + procedure Button1Click(Sender: TObject); + procedure Button2Click(Sender: TObject); + procedure Button3Click(Sender: TObject); + procedure Button4Click(Sender: TObject); + procedure Button5Click(Sender: TObject); + procedure Button6Click(Sender: TObject); + procedure Button7Click(Sender: TObject); + procedure Button8Click(Sender: TObject); + private + { Private declarations } + public + function MyHostMethod(const X, Y: ShortString; Z: Integer): String; + function Safe(X, Y: Integer): HResult; safecall; + { Public declarations } + end; + +type + ITest = interface + ['{E7AA427A-0F4D-4A96-A914-FAB1CA336337}'] + procedure Proc(const S: String); + end; + + TTest = class(TInterfacedObject, ITest) + public + procedure Proc(const S: String); + end; + +var + Form1: TForm1; + +implementation + +{$R *.dfm} + +uses + IMPORT_Common; + + +procedure TTest.Proc(const S: String); +begin + ShowMessage(S); +end; + +procedure TForm1.Button1Click(Sender: TObject); + +procedure Print(const S: String); +begin + ShowMessage(S); +end; + +var + H_MyFunc: Integer; + I: Integer; + P: Pointer; +begin +{$O-} + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + PaxCompiler1.RegisterHeader(0, 'procedure Print(const S: String);', @Print); + + PaxCompiler1.AddModule('1', PaxPascalLanguage1.LanguageName); + PaxCompiler1.AddCode('1', 'uses SysUtils;'); + PaxCompiler1.AddCode('1', 'function MyFunc(U, V: Integer): Currency; cdecl;'); + PaxCompiler1.AddCode('1', 'begin'); + PaxCompiler1.AddCode('1', ' try'); + PaxCompiler1.AddCode('1', ' result := U / V;'); + PaxCompiler1.AddCode('1', ' except'); + PaxCompiler1.AddCode('1', ' on E: Exception do'); + PaxCompiler1.AddCode('1', ' begin'); + PaxCompiler1.AddCode('1', ' print(E.Message);'); + PaxCompiler1.AddCode('1', ' result := 7;'); + PaxCompiler1.AddCode('1', ' end;'); + PaxCompiler1.AddCode('1', ' end;'); + PaxCompiler1.AddCode('1', 'end;'); + PaxCompiler1.AddCode('1', 'begin'); + PaxCompiler1.AddCode('1', 'end.'); + + if PaxCompiler1.Compile(PaxProgram1) then + begin + H_MyFunc := PaxCompiler1.GetHandle(0, 'MyFunc', true); + + P := PaxProgram1.GetAddress(H_MyFunc); // get address of script-defined function + + PaxInvoke1.Address := P; + PaxInvoke1.This := nil; // this is not a method, but global function. + PaxInvoke1.ClearArguments; + PaxInvoke1.AddArgAsInteger(8); + PaxInvoke1.AddArgAsInteger(2); // set it to '0' to try exeption handling + PaxInvoke1.SetResultAsCurrency; + PaxInvoke1.CallConv := _ccCDECL; + + PaxProgram1.SetEntryPoint(PaxInvoke1); + PaxProgram1.Run; + + ShowMessage(CurrToStr(Currency(PaxInvoke1.GetResultPtr^))); + end + else + for I:=0 to PaxCompiler1.ErrorCount do + ShowMessage(PaxCompiler1.ErrorMessage[I]); +end; + +procedure TForm1.Button2Click(Sender: TObject); + +type + TCharRec = record + X, Y: Char; + end; + +function MyHostFunc(const U, V: TCharRec): String; stdcall; +begin + result := U.X + V.Y; +end; + +var + R: TCharRec; + S: String; +begin + R.X := 'a'; + R.Y := 'b'; + + PaxInvoke1.Address := @ MyHostFunc; + PaxInvoke1.This := nil; // this is not a method + PaxInvoke1.ClearArguments; + PaxInvoke1.AddArgAsRecord(@R, SizeOf(R)); + PaxInvoke1.AddArgAsRecord(@R, SizeOf(R)); + PaxInvoke1.SetResultAsString; + PaxInvoke1.CallConv := _ccSTDCALL; + PaxInvoke1.CallHost; // call host-defined function + S := String(PaxInvoke1.GetResultPtr^); + ShowMessage(S); + + PaxInvoke1.ClearResult; +end; + +function TForm1.MyHostMethod(const X, Y: ShortString; Z: Integer): String; +begin + result := X + Y + IntToStr(Z); +end; + +procedure TForm1.Button3Click(Sender: TObject); +begin + PaxInvoke1.Address := @ TForm1.MyHostMethod; + PaxInvoke1.This := Self; // we call a method + PaxInvoke1.ClearArguments; + PaxInvoke1.AddArgAsShortString('xyz'); + PaxInvoke1.AddArgAsShortString('uv'); + PaxInvoke1.AddArgAsInteger(8); + PaxInvoke1.SetResultAsString; + PaxInvoke1.CallConv := _ccREGISTER; + PaxInvoke1.CallHost; + ShowMessage(String(PaxInvoke1.GetResultPtr^)); + + PaxInvoke1.ClearResult; +end; + +procedure TForm1.Button4Click(Sender: TObject); + +procedure DynArrayProc(const A: array of String); cdecl; +begin + ShowMessage(A[0] + A[1]); +end; + +var + A: array of string; +begin + SetLength(A, 2); + A[0] := 'abc'; + A[1] := 'pqr'; + + PaxInvoke1.Address := @ DynArrayProc; + PaxInvoke1.This := nil; // this is not a method + PaxInvoke1.ClearArguments; + PaxInvoke1.AddArgAsDynArray(A); + PaxInvoke1.SetResultAsVoid; + PaxInvoke1.CallConv := _ccCDECL; + PaxInvoke1.CallHost; // call host-defined function +end; + +procedure TForm1.Button5Click(Sender: TObject); + +type + TSetType = set of 'a'..'z'; + +procedure SetProc(S: TSetType); +begin + if 'c' in S then + ShowMessage('ok'); +end; + +var + S: TSetType; +begin + S := ['b'..'d']; + + PaxInvoke1.Address := @ SetProc; + PaxInvoke1.This := nil; // this is not a method + PaxInvoke1.ClearArguments; + PaxInvoke1.AddArgAsSet(@S, SizeOf(S)); + PaxInvoke1.SetResultAsVoid; + PaxInvoke1.CallConv := _ccREGISTER; + PaxInvoke1.CallHost; // call host-defined function +end; + +procedure TForm1.Button6Click(Sender: TObject); +type + TMyPoint = record + x, y, z: Integer; + end; + TMyPoint2 = record + x, y: Integer; + end; +var + a: array[0..5] of Double; + r: TMyPoint; + r2: TMyPoint2; +begin + a[0] := 5.3; + a[1] := 10.1; + + PaxInvoke1.This := nil; // this is not a method + PaxInvoke1.CallConv := _ccMSFASTCALL; + + PaxInvoke1.LoadAddress('CppDll.dll', 'cube'); + PaxInvoke1.ClearArguments; + PaxInvoke1.AddArgAsInteger(2); + PaxInvoke1.SetResultAsInteger; + PaxInvoke1.CallHost; // call host-defined function + ShowMessage(IntToStr(Integer(PaxInvoke1.GetResultPtr^))); + + PaxInvoke1.LoadAddress('CppDll.dll', 'arr'); + PaxInvoke1.ClearArguments; + PaxInvoke1.AddArgAsPointer(@a); + PaxInvoke1.AddArgAsInteger(2); + PaxInvoke1.AddArgAsInteger(3); + PaxInvoke1.AddArgAsSingle(6.8); + PaxInvoke1.SetResultAsDouble; + PaxInvoke1.CallHost; // call host-defined function + ShowMessage(FloatToStr(Double(PaxInvoke1.GetResultPtr^))); + + PaxInvoke1.LoadAddress('CppDll.dll', 'ret_char'); + PaxInvoke1.ClearArguments; + PaxInvoke1.AddArgAsPAnsiChar(PansiChar('abc')); + PaxInvoke1.SetResultAsAnsiChar; + PaxInvoke1.CallHost; // call host-defined function + ShowMessage(AnsiChar(PaxInvoke1.GetResultPtr^)); + + PaxInvoke1.LoadAddress('CppDll.dll', 'ret_struct'); + PaxInvoke1.ClearArguments; + PaxInvoke1.AddArgAsInteger(2); + PaxInvoke1.AddArgAsInteger(3); + PaxInvoke1.AddArgAsInteger(5); + PaxInvoke1.SetResultAsRecord(SizeOf(TMyPoint)); + PaxInvoke1.CallHost; // call host-defined function + r := TMyPoint(PaxInvoke1.GetResultPtr^); + ShowMessage(IntToStr(r.x) + ' ' + IntToStr(r.y) + ' ' + IntToStr(r.z)); + + PaxInvoke1.LoadAddress('CppDll.dll', 'ret_struct2'); + PaxInvoke1.ClearArguments; + PaxInvoke1.AddArgAsInteger(2); + PaxInvoke1.AddArgAsInteger(3); + PaxInvoke1.SetResultAsRecord(SizeOf(TMyPoint2)); + PaxInvoke1.CallHost; // call host-defined function + r2 := TMyPoint2(PaxInvoke1.GetResultPtr^); + ShowMessage(IntToStr(r.x) + ' ' + IntToStr(r.y)); + + PaxInvoke1.LoadAddress('CppDll.dll', 'pass_struct'); + PaxInvoke1.ClearArguments; + PaxInvoke1.AddArgAsPointer(@ r); + PaxInvoke1.SetResultAsRecord(SizeOf(TMyPoint)); + PaxInvoke1.CallHost; // call host-defined function + r := TMyPoint(PaxInvoke1.GetResultPtr^); + ShowMessage(IntToStr(r.x) + ' ' + IntToStr(r.y) + ' ' + IntToStr(r.z)); + + PaxInvoke1.LoadAddress('CppDll.dll', 'pass_struct_byval'); + PaxInvoke1.ClearArguments; + PaxInvoke1.AddArgAsRecordByVal(r, SizeOf(r)); + PaxInvoke1.SetResultAsRecord(SizeOf(TMyPoint)); + PaxInvoke1.CallHost; // call host-defined function + r := TMyPoint(PaxInvoke1.GetResultPtr^); + ShowMessage(IntToStr(r.x) + ' ' + IntToStr(r.y) + ' ' + IntToStr(r.z)); + + PaxInvoke1.LoadAddress('CppDll.dll', 'dcube'); + PaxInvoke1.ClearArguments; + PaxInvoke1.AddArgAsDouble(2); + PaxInvoke1.SetResultAsDouble; + PaxInvoke1.CallHost; // call host-defined function + ShowMessage(FloatToStr(Double(PaxInvoke1.GetResultPtr^))); +end; + +function TForm1.Safe(X, Y: Integer): HResult; safecall; +begin + result := X + Y; +end; + +procedure TForm1.Button7Click(Sender: TObject); + +function P(X, Y: Currency): String; safecall; +begin + result := CurrToStr(X + Y); +end; + +begin + PaxInvoke1.This := nil; // this is not a method + PaxInvoke1.CallConv := _ccSAFECALL; + PaxInvoke1.Address := @P; + PaxInvoke1.ClearArguments; + PaxInvoke1.AddArgAsCurrency(2.2); + PaxInvoke1.AddArgAsCurrency(3.4); + PaxInvoke1.SetResultAsString; + PaxInvoke1.CallHost; // call host-defined function + ShowMessage(String(PaxInvoke1.GetResultPtr^)); + PaxInvoke1.ClearResult; + + PaxInvoke1.This := Self; // this is a method + PaxInvoke1.CallConv := _ccSAFECALL; + PaxInvoke1.Address := @TForm1.Safe; + PaxInvoke1.ClearArguments; + PaxInvoke1.AddArgAsInteger(2); + PaxInvoke1.AddArgAsInteger(3); + PaxInvoke1.SetResultAsInteger; + PaxInvoke1.CallHost; // call host-defined function + ShowMessage(IntToStr(Integer(PaxInvoke1.GetResultPtr^))); +end; + +procedure TForm1.Button8Click(Sender: TObject); + +function GetIntf(I: ITest): ITest; +begin + if Assigned(I) then + result := I + else + result := TTest.Create; +end; + +var + I, J: ITest; +begin + J := TTest.Create; + + PaxInvoke1.This := nil; // this is not a method + PaxInvoke1.CallConv := _ccREGISTER; + PaxInvoke1.Address := @GetIntf; + PaxInvoke1.ClearArguments; + PaxInvoke1.AddArgAsInterface(J); + PaxInvoke1.SetResultAsInterface; + PaxInvoke1.CallHost; // call host-defined function + IUnknown(I) := IUnknown(PaxInvoke1.GetResultPtr^); + I.Proc('hello'); + + PaxInvoke1.ClearResult; +end; + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/RTTI/1/IMPORT_TypInfo.pas b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/RTTI/1/IMPORT_TypInfo.pas new file mode 100644 index 0000000..4767808 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/RTTI/1/IMPORT_TypInfo.pas @@ -0,0 +1,703 @@ +unit IMPORT_TypInfo; +interface + +procedure Register_TypInfo; + +implementation + +uses + Variants, + SysUtils, + TypInfo, + PaxRegister; +{ + Result := RegisterEnumType (H, 'TTypeKind'); + RegisterEnumValue (Result, 'tkUnknown', 0); + RegisterEnumValue (Result, 'tkInteger', 1); + RegisterEnumValue (Result, 'tkChar', 2); + RegisterEnumValue (Result, 'tkEnumeration', 3); + RegisterEnumValue (Result, 'tkFloat', 4); + RegisterEnumValue (Result, 'tkString', 5); + RegisterEnumValue (Result, 'tkSet', 6); + RegisterEnumValue (Result, 'tkClass', 7); + RegisterEnumValue (Result, 'tkMethod', 8); + RegisterEnumValue (Result, 'tkWChar', 9); + RegisterEnumValue (Result, 'tkLString', 10); + RegisterEnumValue (Result, 'tkWString', 11); + RegisterEnumValue (Result, 'tkVariant', 12); + RegisterEnumValue (Result, 'tkArray', 13); + RegisterEnumValue (Result, 'tkRecord', 14); + RegisterEnumValue (Result, 'tkInterface', 15); + RegisterEnumValue (Result, 'tkInt64', 16); + RegisterEnumValue (Result, 'tkDynArray', 17); +end; + +//==================================================================== +// TPublishableVariantType +//==================================================================== + + +//-------------------------------------------------------------------- +// RegisterClass_TPublishableVariantType +//-------------------------------------------------------------------- + +function RegisterClass_TPublishableVariantType (H: integer): integer; +begin + Result := RegisterClassType (H, TPublishableVariantType); + + RegisterHeader (Result, + 'function GetProperty (var Dest: TVarData; const V: TVarData; const Name: String): Boolean; override;', + @TPublishableVariantType.GetProperty); + RegisterHeader (Result, + 'function SetProperty (const V: TVarData; const Name: String; const Value: TVarData): Boolean; override;', + @TPublishableVariantType.SetProperty); +end; + +//-------------------------------------------------------------------- +// RegisterSet_TTypeKinds +//-------------------------------------------------------------------- + +function RegisterSet_TTypeKinds (H: integer): integer; +begin +// Result := RegisterSetType (H, 'TTypeKinds', T); +end; + +//-------------------------------------------------------------------- +// RegisterEnumerated_TOrdType +//-------------------------------------------------------------------- + +function RegisterEnumerated_TOrdType (H: integer): integer; +begin + Result := RegisterEnumType (H, 'TOrdType'); + RegisterEnumValue (Result, 'otSByte', 0); + RegisterEnumValue (Result, 'otUByte', 1); + RegisterEnumValue (Result, 'otSWord', 2); + RegisterEnumValue (Result, 'otUWord', 3); + RegisterEnumValue (Result, 'otSLong', 4); + RegisterEnumValue (Result, 'otULong', 5); +end; + +//-------------------------------------------------------------------- +// RegisterEnumerated_TFloatType +//-------------------------------------------------------------------- + +function RegisterEnumerated_TFloatType (H: integer): integer; +begin + Result := RegisterEnumType (H, 'TFloatType'); + RegisterEnumValue (Result, 'ftSingle', 0); + RegisterEnumValue (Result, 'ftDouble', 1); + RegisterEnumValue (Result, 'ftExtended', 2); + RegisterEnumValue (Result, 'ftComp', 3); + RegisterEnumValue (Result, 'ftCurr', 4); +end; + +//-------------------------------------------------------------------- +// RegisterEnumerated_TMethodKind +//-------------------------------------------------------------------- + +function RegisterEnumerated_TMethodKind (H: integer): integer; +begin + Result := RegisterEnumType (H, 'TMethodKind'); + RegisterEnumValue (Result, 'mkProcedure', 0); + RegisterEnumValue (Result, 'mkFunction', 1); + RegisterEnumValue (Result, 'mkConstructor', 2); + RegisterEnumValue (Result, 'mkDestructor', 3); + RegisterEnumValue (Result, 'mkClassProcedure', 4); + RegisterEnumValue (Result, 'mkClassFunction', 5); + RegisterEnumValue (Result, 'mkSafeProcedure', 6); + RegisterEnumValue (Result, 'mkSafeFunction', 7); +end; + +//-------------------------------------------------------------------- +// RegisterEnumerated_TParamFlag +//-------------------------------------------------------------------- + +function RegisterEnumerated_TParamFlag (H: integer): integer; +begin + Result := RegisterEnumType (H, 'TParamFlag'); + RegisterEnumValue (Result, 'pfVar', 0); + RegisterEnumValue (Result, 'pfConst', 1); + RegisterEnumValue (Result, 'pfArray', 2); + RegisterEnumValue (Result, 'pfAddress', 3); + RegisterEnumValue (Result, 'pfReference', 4); + RegisterEnumValue (Result, 'pfOut', 5); + Result := RegisterSetType (H, 'TParamFlags', T); +end; + +function RegisterSet_TParamFlagsBase (H: integer): integer; +var + T: integer; +begin + T := LookupTypeID ('TParamFlag'); + if T = 0 then + Raise ENNPaxFormater.Create ('Invalid type name: TParamFlag'); + Result := RegisterSetType (H, 'TParamFlagsBase', T); +end; + +//-------------------------------------------------------------------- +// RegisterEnumerated_TIntfFlag +//-------------------------------------------------------------------- + +function RegisterEnumerated_TIntfFlag (H: integer): integer; +begin + Result := RegisterEnumType (H, 'TIntfFlag'); + RegisterEnumValue (Result, 'ifHasGuid', 0); + RegisterEnumValue (Result, 'ifDispInterface', 1); + RegisterEnumValue (Result, 'ifDispatch', 2); +end; + +//-------------------------------------------------------------------- +// RegisterSet_TIntfFlags +//-------------------------------------------------------------------- + +function RegisterSet_TIntfFlags (H: integer): integer; +var + T: integer; +begin + T := LookupTypeID ('TIntfFlag'); + if T = 0 then + Raise ENNPaxFormater.Create ('Invalid type name: TIntfFlag'); + Result := RegisterSetType (H, 'TIntfFlags', T); +end; + +//-------------------------------------------------------------------- +// RegisterSet_TIntfFlagsBase +//-------------------------------------------------------------------- + +function RegisterSet_TIntfFlagsBase (H: integer): integer; +var + T: integer; +begin + T := LookupTypeID ('TIntfFlag'); + if T = 0 then + Raise ENNPaxFormater.Create ('Invalid type name: TIntfFlag'); + Result := RegisterSetType (H, 'TIntfFlagsBase', T); +end; + +//-------------------------------------------------------------------- +// RegisterPointer_PPTypeInfo +//-------------------------------------------------------------------- + +function RegisterPointer_PPTypeInfo (H: integer): integer; +var + T: Integer; +begin + T := LookupTypeID ('PTypeInfo'); + if T = 0 then + T := RegisterSomeType (H, 'PTypeInfo'); + Result := RegisterPointerType (H, 'PPTypeInfo', T); +end; + +//-------------------------------------------------------------------- +// RegisterPointer_PTypeInfo +//-------------------------------------------------------------------- + +function RegisterPointer_PTypeInfo (H: integer): integer; +var + T: Integer; +begin + T := LookupTypeID ('TTypeInfo'); + if T = 0 then + T := RegisterSomeType (H, 'TTypeInfo'); + Result := RegisterPointerType (H, 'PTypeInfo', T); +end; + +//-------------------------------------------------------------------- +// RegisterRecord_TTypeInfo +//-------------------------------------------------------------------- + +function RegisterRecord_TTypeInfo (H: integer): integer; +var + T: integer; +begin + Result := RegisterRecordType (H, 'TTypeInfo', False); + T := LookupTypeID ('TTypeKind'); + if T = 0 then + Raise ENNPaxFormater.Create ('Invalid type name: TTypeKind'); + RegisterRecordTypeField (Result, 'Kind', T, 0); + T := _typeSHORTSTRING; + RegisterRecordTypeField (Result, 'Name', T, 0); +end; + +//-------------------------------------------------------------------- +// RegisterPointer_PTypeData +//-------------------------------------------------------------------- + +function RegisterPointer_PTypeData (H: integer): integer; +var + T: Integer; +begin + T := LookupTypeID ('TTypeData'); + if T = 0 then + T := RegisterSomeType (H, 'TTypeData'); + Result := RegisterPointerType (H, 'PTypeData', T); +end; + +//-------------------------------------------------------------------- +// RegisterArray_fake_ParamList_18 +//-------------------------------------------------------------------- + +function RegisterArray_fake_ParamList_18 (H: integer): integer; +var + R,T: integer; +begin + R := RegisterTypeDeclaration (H, 'fake_ParamList_18_19 = 0..1023;'); + T := _typeCHAR; + Result := RegisterArrayType (H, 'fake_ParamList_18', R, T, False); +end; + +//-------------------------------------------------------------------- +// RegisterRecord_TTypeData +//-------------------------------------------------------------------- + +function RegisterRecord_TTypeData (H: integer): integer; +var + T: integer; +begin + Result := RegisterRecordType (H, 'TTypeData', False); + T := LookupTypeID ('TOrdType'); + if T = 0 then + Raise ENNPaxFormater.Create ('Invalid type name: TOrdType'); + RegisterVariantRecordTypeField (Result, 'OrdType', T, 02); + T := _typeINTEGER; + RegisterVariantRecordTypeField (Result, 'MinValue', T, 0102); + T := _typeINTEGER; + RegisterVariantRecordTypeField (Result, 'MaxValue', T, 0102); + T := LookupTypeID ('PPTypeInfo'); + if T = 0 then + Raise ENNPaxFormater.Create ('Invalid type name: PPTypeInfo'); + RegisterVariantRecordTypeField (Result, 'BaseType', T, 020102); + T := LookupTypeID ('ShortStringBase'); + if T = 0 then + Raise ENNPaxFormater.Create ('Invalid type name: ShortStringBase'); + RegisterVariantRecordTypeField (Result, 'NameList', T, 020102); + T := LookupTypeID ('ShortStringBase'); + if T = 0 then + Raise ENNPaxFormater.Create ('Invalid type name: ShortStringBase'); + RegisterVariantRecordTypeField (Result, 'EnumUnitName', T, 020102); + T := LookupTypeID ('PPTypeInfo'); + if T = 0 then + Raise ENNPaxFormater.Create ('Invalid type name: PPTypeInfo'); + RegisterVariantRecordTypeField (Result, 'CompType', T, 0202); + T := LookupTypeID ('TFloatType'); + if T = 0 then + Raise ENNPaxFormater.Create ('Invalid type name: TFloatType'); + RegisterVariantRecordTypeField (Result, 'FloatType', T, 03); + T := _typeBYTE; + RegisterVariantRecordTypeField (Result, 'MaxLength', T, 04); + T := LookupTypeID ('TClass'); + if T = 0 then + Raise ENNPaxFormater.Create ('Invalid type name: TClass'); + RegisterVariantRecordTypeField (Result, 'ClassType', T, 05); + T := LookupTypeID ('PPTypeInfo'); + if T = 0 then + Raise ENNPaxFormater.Create ('Invalid type name: PPTypeInfo'); + RegisterVariantRecordTypeField (Result, 'ParentInfo', T, 05); + T := _typeSMALLINT; + RegisterVariantRecordTypeField (Result, 'PropCount', T, 05); + T := LookupTypeID ('ShortStringBase'); + if T = 0 then + Raise ENNPaxFormater.Create ('Invalid type name: ShortStringBase'); + RegisterVariantRecordTypeField (Result, 'UnitName', T, 05); + T := LookupTypeID ('TMethodKind'); + if T = 0 then + Raise ENNPaxFormater.Create ('Invalid type name: TMethodKind'); + RegisterVariantRecordTypeField (Result, 'MethodKind', T, 06); + T := _typeBYTE; + RegisterVariantRecordTypeField (Result, 'ParamCount', T, 06); + T := RegisterArray_fake_ParamList_18 (H); + RegisterVariantRecordTypeField (Result, 'ParamList', T, 06); + T := LookupTypeID ('PPTypeInfo'); + if T = 0 then + Raise ENNPaxFormater.Create ('Invalid type name: PPTypeInfo'); + RegisterVariantRecordTypeField (Result, 'IntfParent', T, 07); + T := LookupTypeID ('TIntfFlagsBase'); + if T = 0 then + Raise ENNPaxFormater.Create ('Invalid type name: TIntfFlagsBase'); + RegisterVariantRecordTypeField (Result, 'IntfFlags', T, 07); + T := LookupTypeID ('TGUID'); + if T = 0 then + Raise ENNPaxFormater.Create ('Invalid type name: TGUID'); + RegisterVariantRecordTypeField (Result, 'Guid', T, 07); + T := LookupTypeID ('ShortStringBase'); + if T = 0 then + Raise ENNPaxFormater.Create ('Invalid type name: ShortStringBase'); + RegisterVariantRecordTypeField (Result, 'IntfUnit', T, 07); + T := _typeINT64; + RegisterVariantRecordTypeField (Result, 'MinInt64Value', T, 08); + RegisterVariantRecordTypeField (Result, 'MaxInt64Value', T, 08); + T := _typeINTEGER; + RegisterVariantRecordTypeField (Result, 'elSize', T, 09); + T := LookupTypeID ('PPTypeInfo'); + if T = 0 then + Raise ENNPaxFormater.Create ('Invalid type name: PPTypeInfo'); + RegisterVariantRecordTypeField (Result, 'elType', T, 09); + T := _typeINTEGER; + RegisterVariantRecordTypeField (Result, 'varType', T, 09); + T := LookupTypeID ('PPTypeInfo'); + if T = 0 then + Raise ENNPaxFormater.Create ('Invalid type name: PPTypeInfo'); + RegisterVariantRecordTypeField (Result, 'elType2', T, 09); + T := LookupTypeID ('ShortStringBase'); + if T = 0 then + Raise ENNPaxFormater.Create ('Invalid type name: ShortStringBase'); + RegisterVariantRecordTypeField (Result, 'DynUnitName', T, 09); +end; + +//-------------------------------------------------------------------- +// RegisterRecord_fake_PropList_31 +//-------------------------------------------------------------------- + +function RegisterRecord_fake_PropList_31 (H: integer): integer; +var + T: integer; +begin + Result := RegisterRecordType (H, 'fake_PropList_31', False); +end; + +//-------------------------------------------------------------------- +// RegisterRecord_TPropData +//-------------------------------------------------------------------- + +function RegisterRecord_TPropData (H: integer): integer; +var + T: integer; +begin + Result := RegisterRecordType (H, 'TPropData', False); + T := _typeWORD; + RegisterRecordTypeField (Result, 'PropCount', T, 0); + T := RegisterRecord_fake_PropList_31 (H); + RegisterRecordTypeField (Result, 'PropList', T, 0); +end; + +//-------------------------------------------------------------------- +// RegisterPointer_PPropInfo +//-------------------------------------------------------------------- + +function RegisterPointer_PPropInfo (H: integer): integer; +var + T: Integer; +begin + T := LookupTypeID ('TPropInfo'); + if T = 0 then + T := RegisterSomeType (H, 'TPropInfo'); + Result := RegisterPointerType (H, 'PPropInfo', T); +end; + +//-------------------------------------------------------------------- +// RegisterRecord_TPropInfo +//-------------------------------------------------------------------- + +function RegisterRecord_TPropInfo (H: integer): integer; +var + T: integer; +begin + Result := RegisterRecordType (H, 'TPropInfo', False); + T := LookupTypeID ('PPTypeInfo'); + if T = 0 then + Raise ENNPaxFormater.Create ('Invalid type name: PPTypeInfo'); + RegisterRecordTypeField (Result, 'PropType', T, 0); + T := _typePOINTER; + RegisterRecordTypeField (Result, 'GetProc', T, 0); + T := _typePOINTER; + RegisterRecordTypeField (Result, 'SetProc', T, 0); + T := _typePOINTER; + RegisterRecordTypeField (Result, 'StoredProc', T, 0); + T := _typeINTEGER; + RegisterRecordTypeField (Result, 'Index', T, 0); + T := _typeINTEGER; + RegisterRecordTypeField (Result, 'Default', T, 0); + T := _typeSMALLINT; + RegisterRecordTypeField (Result, 'NameIndex', T, 0); + T := _typeSHORTSTRING; + RegisterRecordTypeField (Result, 'Name', T, 0); +end; + +//-------------------------------------------------------------------- +// RegisterProcedural_TPropInfoProc +//-------------------------------------------------------------------- + +function RegisterProcedural_TPropInfoProc (H: integer): integer; +begin + Result := RegisterHeader (H, 'procedure fake_TPropInfoProc_40 (PropInfo: PPropInfo);', Nil); + Result := RegisterEventType (H, 'TPropInfoProc', Result); +end; + +//-------------------------------------------------------------------- +// RegisterPointer_PPropList +//-------------------------------------------------------------------- + +function RegisterPointer_PPropList (H: integer): integer; +var + T: Integer; +begin + T := LookupTypeID ('TPropList'); + if T = 0 then + T := RegisterSomeType (H, 'TPropList'); + Result := RegisterPointerType (H, 'PPropList', T); +end; + +//-------------------------------------------------------------------- +// RegisterArray_TPropList +//-------------------------------------------------------------------- + +function RegisterArray_TPropList (H: integer): integer; +var + R,T: integer; +begin + R := RegisterTypeDeclaration (H, 'fake_TPropList_41 = 0..16379;'); + T := LookupTypeID ('PPropInfo'); + if T = 0 then + Raise ENNPaxFormater.Create ('Invalid type name: PPropInfo'); + Result := RegisterArrayType (H, 'TPropList', R, T, False); +end; + +//==================================================================== +// EPropertyError +//==================================================================== + + +//-------------------------------------------------------------------- +// RegisterClass_EPropertyError +//-------------------------------------------------------------------- + +function RegisterClass_EPropertyError (H: integer): integer; +begin + Result := RegisterClassType (H, EPropertyError); + +end; + +//==================================================================== +// EPropertyConvertError +//==================================================================== + + +//-------------------------------------------------------------------- +// RegisterClass_EPropertyConvertError +//-------------------------------------------------------------------- + +function RegisterClass_EPropertyConvertError (H: integer): integer; +begin + Result := RegisterClassType (H, EPropertyConvertError); + +end; + +//-------------------------------------------------------------------- +// RegisterArray_fake_BooleanIdents_42 +//-------------------------------------------------------------------- + +function RegisterArray_fake_BooleanIdents_42 (H: integer): integer; +var + R,T: integer; +begin + R := _typeBOOLEAN; + T := RegisterTypeAlias (H, 'BooleanIdents', _typeSTRING); + Result := RegisterArrayType (H, 'fake_BooleanIdents_42', R, T, False); +end; + +//-------------------------------------------------------------------- +// DoRegisterVariable_BooleanIdents +//-------------------------------------------------------------------- + +function DoRegisterVariable_BooleanIdents (H: Integer): integer; +var + T: integer; +begin + T := RegisterArray_fake_BooleanIdents_42 (H); + result := RegisterVariable (H, 'BooleanIdents', T, @BooleanIdents); +end; + + +//-------------------------------------------------------------------- +// RegisterNameSpace_TypInfo +//-------------------------------------------------------------------- + +procedure RegisterNameSpace_TypInfo; +begin + RegisterNameSpace (0, 'TypInfo'); +end; + + +//-------------------------------------------------------------------- +// Register_TypInfo +//-------------------------------------------------------------------- +} +procedure Register_TypInfo; +var + H, G, A: integer; +begin + H := RegisterNamespace(0, 'TypInfo'); + RegisterRTTIType(H, TypeInfo(TTypeKind)); + RegisterRTTIType(H, TypeInfo(TTypeKinds)); + RegisterRTTIType(H, TypeInfo(TOrdType)); + RegisterRTTIType(H, TypeInfo(TFloatType)); + RegisterRTTIType(H, TypeInfo(TMethodKind)); + RegisterRTTIType(H, TypeInfo(TParamFlag)); + RegisterRTTIType(H, TypeInfo(TParamFlags)); + RegisterRTTIType(H, TypeInfo(TParamFlagsBase)); + RegisterRTTIType(H, TypeInfo(TIntfFlag)); + RegisterRTTIType(H, TypeInfo(TIntfFlags)); + RegisterRTTIType(H, TypeInfo(TIntfFlagsBase)); + + G := RegisterRecordType(H, 'TTypeInfo'); + RegisterRecordTypeField(G, 'Kind', RegisterRTTIType(H, TypeInfo(TTypeKind))); + RegisterRecordTypeField(G, 'Name', _typeSHORTSTRING); + G := RegisterPointerType(H, 'PTypeInfo', G); + G := RegisterPointerType(H, 'PPTypeInfo', G); + + G := RegisterRecordType(H, 'TPropInfo'); + RegisterRecordTypeField(G, 'PropType: PPtypeInfo', 0); + RegisterRecordTypeField(G, 'GetProc', _typePOINTER); + RegisterRecordTypeField(G, 'SetProc', _typePOINTER); + RegisterRecordTypeField(G, 'StoredProc', _typePOINTER); + RegisterRecordTypeField(G, 'Index', _typeINTEGER); + RegisterRecordTypeField(G, 'Default', _typeINTEGER); + RegisterRecordTypeField(G, 'NameIndex', _typeSMALLINT); + RegisterRecordTypeField(G, 'Name', _typeSHORTSTRING); + RegisterPointerType(H, 'PPropInfo', G); + + G := RegisterRecordType(H, 'TPropData'); + RegisterRecordTypeField(G, 'PropCount: Word;', 0); + + A := RegisterArrayType(0, '', RegisterSubrangeType(0, '', _typeINTEGER, 0, 1023), _typeANSICHAR); + + G := RegisterRecordType (H, 'TTypeData', False); + RegisterVariantRecordTypeField(G, 'OrdType: TOrdType', 02); + RegisterVariantRecordTypeField(G, 'MinValue', _typeINTEGER, 0102); + RegisterVariantRecordTypeField(G, 'MaxValue', _typeINTEGER, 0102); + RegisterVariantRecordTypeField(G, 'BaseType: PPTypeInfo', 020102); + RegisterVariantRecordTypeField(G, 'NameList: ShortString', 020102); + RegisterVariantRecordTypeField(G, 'EnumUnitName: ShortString', 020102); + RegisterVariantRecordTypeField(G, 'CompType: PPTypeInfo', 0202); + RegisterVariantRecordTypeField(G, 'FloatType: TFloatType', 03); + RegisterVariantRecordTypeField(G, 'MaxLength', _typeBYTE, 04); + RegisterVariantRecordTypeField(G, 'ClassType: TClass', 05); + RegisterVariantRecordTypeField(G, 'ParentInfo: PPTypeInfo', 05); + RegisterVariantRecordTypeField(G, 'PropCount', _typeSMALLINT, 05); + RegisterVariantRecordTypeField(G, 'UnitName', _typeSHORTSTRING, 05); + RegisterVariantRecordTypeField(G, 'MethodKind: TMethodKind', 06); + RegisterVariantRecordTypeField(G, 'ParamCount', _typeBYTE, 06); + + + RegisterVariantRecordTypeField(G, 'ParamList', A, 06); + RegisterVariantRecordTypeField(G, 'IntfParent: PPTypeInfo', 07); + RegisterVariantRecordTypeField(G, 'IntfFlags: TIntfFlagsBase', 07); + RegisterVariantRecordTypeField(G, 'Guid: TGUID', 07); + RegisterVariantRecordTypeField(G, 'IntfUnit', _typeSHORTSTRING, 07); + RegisterVariantRecordTypeField(G, 'MinInt64Value', _typeINT64, 08); + RegisterVariantRecordTypeField(G, 'MaxInt64Value', _typeINT64, 08); + RegisterVariantRecordTypeField(G, 'elSize', _typeINTEGER, 09); + RegisterVariantRecordTypeField(G, 'elType: PPTypeInfo', 09); + RegisterVariantRecordTypeField(G, 'varType', _typeINTEGER, 09); + RegisterVariantRecordTypeField(G, 'elType2: PPTypeInfo', 09); + RegisterVariantRecordTypeField(G, 'DynUnitName', _typeSHORTSTRING, 09); + + RegisterHeader (H, 'function PropType (Instance: TObject; const PropName: String): TTypeKind; overload;', Nil); + RegisterHeader (H, 'function PropType (AClass: TClass; const PropName: String): TTypeKind; overload;', Nil); + RegisterHeader (H, 'function PropIsType (Instance: TObject; const PropName: String; TypeKind: TTypeKind): Boolean; overload;' + , Nil); + RegisterHeader (H, 'function PropIsType (AClass: TClass; const PropName: String; TypeKind: TTypeKind): Boolean; overload;', + Nil); + RegisterHeader (H, 'function IsStoredProp (Instance: TObject; const PropName: String): Boolean; overload;', Nil); + RegisterHeader (H, 'function IsPublishedProp (Instance: TObject; const PropName: String): Boolean; overload;', Nil); + RegisterHeader (H, 'function IsPublishedProp (AClass: TClass; const PropName: String): Boolean; overload;', Nil); + RegisterHeader (H, 'function GetOrdProp (Instance: TObject; const PropName: String): Longint; overload;', Nil); + RegisterHeader (H, 'procedure SetOrdProp (Instance: TObject; const PropName: String; Value: Longint); overload;', Nil); + RegisterHeader (H, 'function GetEnumProp (Instance: TObject; const PropName: String): String; overload;', Nil); + RegisterHeader (H, 'procedure SetEnumProp (Instance: TObject; const PropName: String; const Value: String); overload;', Nil); + RegisterHeader (H, 'function GetSetProp (Instance: TObject; const PropName: String; Brackets: Boolean = False): String; ' + + 'overload;', Nil); + RegisterHeader (H, 'procedure SetSetProp (Instance: TObject; const PropName: String; const Value: String); overload;', Nil); + RegisterHeader (H, 'function GetObjectProp (Instance: TObject; const PropName: String; MinClass: TClass = nil): TObject; ' + + 'overload;', Nil); + RegisterHeader (H, 'procedure SetObjectProp (Instance: TObject; const PropName: String; Value: TObject); overload;', Nil); + RegisterHeader (H, 'function GetObjectPropClass (Instance: TObject; const PropName: String): TClass; overload;', Nil); + RegisterHeader (H, 'function GetStrProp (Instance: TObject; const PropName: String): String; overload;', Nil); + RegisterHeader (H, 'procedure SetStrProp (Instance: TObject; const PropName: String; const Value: String); overload;', Nil); + RegisterHeader (H, 'function GetWideStrProp (Instance: TObject; const PropName: String): WideString; overload;', Nil); + RegisterHeader (H, 'procedure SetWideStrProp (Instance: TObject; const PropName: String; const Value: WideString); overload;' + , Nil); + RegisterHeader (H, 'function GetFloatProp (Instance: TObject; const PropName: String): Extended; overload;', Nil); + RegisterHeader (H, 'procedure SetFloatProp (Instance: TObject; const PropName: String; const Value: Extended); overload;', + Nil); + RegisterHeader (H, 'function GetVariantProp (Instance: TObject; const PropName: String): Variant; overload;', Nil); + RegisterHeader (H, 'procedure SetVariantProp (Instance: TObject; const PropName: String; const Value: Variant); overload;', + Nil); + RegisterHeader (H, 'function GetMethodProp (Instance: TObject; const PropName: String): TMethod; overload;', Nil); + RegisterHeader (H, 'procedure SetMethodProp (Instance: TObject; const PropName: String; const Value: TMethod); overload;', + Nil); + RegisterHeader (H, 'function GetInt64Prop (Instance: TObject; const PropName: String): Int64; overload;', Nil); + RegisterHeader (H, 'procedure SetInt64Prop (Instance: TObject; const PropName: String; const Value: Int64); overload;', Nil); + RegisterHeader (H, 'function GetInterfaceProp (Instance: TObject; const PropName: String): IInterface; overload;', Nil); + RegisterHeader (H, 'procedure SetInterfaceProp (Instance: TObject; const PropName: String; const Value: IInterface); overload;' + + '', Nil); + RegisterHeader (H, 'function GetPropValue (Instance: TObject; const PropName: String; PreferStrings: Boolean = True): Variant;' + + '', Nil); + RegisterHeader (H, 'procedure SetPropValue (Instance: TObject; const PropName: String; const Value: Variant);', Nil); + RegisterHeader (H, 'procedure FreeAndNilProperties (AObject: TObject);', Nil); + + G := RegisterClassType(H, TPublishableVariantType); + RegisterHeader(G, + 'function GetProperty (var Dest: TVarData; const V: TVarData; const Name: String): Boolean; override;', + @TPublishableVariantType.GetProperty); + RegisterHeader (G, + 'function SetProperty (const V: TVarData; const Name: String; const Value: TVarData): Boolean; override;', + @TPublishableVariantType.SetProperty); + + RegisterConstant (H, 'tkAny = [Low(TTypeKind)..High(TTypeKind)];'); + RegisterConstant (H, 'tkMethods = [tkMethod];'); + RegisterConstant (H, 'tkProperties = tkAny - tkMethods - [tkUnknown];'); + RegisterTypeDeclaration (H, 'ShortStringBase = String [255];'); + RegisterHeader (H, 'function GetTypeData (TypeInfo: PTypeInfo): PTypeData;', Nil); + RegisterHeader (H, 'function GetEnumName (TypeInfo: PTypeInfo; Value: Integer): String;', Nil); + RegisterHeader (H, 'function GetEnumValue (TypeInfo: PTypeInfo; const Name: String): Integer;', Nil); + RegisterHeader (H, 'function GetPropInfo (Instance: TObject; const PropName: String; AKinds: TTypeKinds = []): PPropInfo; ' + + 'overload;', Nil); + RegisterHeader (H, 'function GetPropInfo (AClass: TClass; const PropName: String; AKinds: TTypeKinds = []): PPropInfo; ' + + 'overload;', Nil); + RegisterHeader (H, 'function GetPropInfo (TypeInfo: PTypeInfo; const PropName: String): PPropInfo; overload;', Nil); + RegisterHeader (H, 'function GetPropInfo (TypeInfo: PTypeInfo; const PropName: String; AKinds: TTypeKinds): PPropInfo; ' + + 'overload;', Nil); + RegisterHeader (H, 'procedure GetPropInfos (TypeInfo: PTypeInfo; PropList: PPropList);', Nil); + RegisterHeader (H, 'function GetPropList (TypeInfo: PTypeInfo; TypeKinds: TTypeKinds; PropList: PPropList; SortList: Boolean ' + + '= True): Integer; overload;', Nil); + RegisterHeader (H, 'function GetPropList (TypeInfo: PTypeInfo; out PropList: PPropList): Integer; overload;', Nil); + RegisterHeader (H, 'function GetPropList (AObject: TObject; out PropList: PPropList): Integer; overload;', Nil); + RegisterHeader (H, 'procedure SortPropList (PropList: PPropList; PropCount: Integer);', Nil); + RegisterHeader (H, 'function IsStoredProp (Instance: TObject; PropInfo: PPropInfo): Boolean; overload;', Nil); + RegisterHeader (H, 'function GetOrdProp (Instance: TObject; PropInfo: PPropInfo): Longint; overload;', Nil); + RegisterHeader (H, 'procedure SetOrdProp (Instance: TObject; PropInfo: PPropInfo; Value: Longint); overload;', Nil); + RegisterHeader (H, 'function GetEnumProp (Instance: TObject; PropInfo: PPropInfo): String; overload;', Nil); + RegisterHeader (H, 'procedure SetEnumProp (Instance: TObject; PropInfo: PPropInfo; const Value: String); overload;', Nil); + RegisterHeader (H, 'function GetSetProp (Instance: TObject; PropInfo: PPropInfo; Brackets: Boolean = False): String; overload;' + + '', Nil); + RegisterHeader (H, 'procedure SetSetProp (Instance: TObject; PropInfo: PPropInfo; const Value: String); overload;', Nil); + RegisterHeader (H, 'function GetObjectProp (Instance: TObject; PropInfo: PPropInfo; MinClass: TClass = nil): TObject; ' + + 'overload;', Nil); + RegisterHeader (H, 'procedure SetObjectProp (Instance: TObject; PropInfo: PPropInfo; Value: TObject; ValidateClass: Boolean = ' + + 'True); overload;', Nil); + RegisterHeader (H, 'function GetObjectPropClass (Instance: TObject; PropInfo: PPropInfo): TClass; overload;', Nil); + RegisterHeader (H, 'function GetObjectPropClass (PropInfo: PPropInfo): TClass; overload;', Nil); + RegisterHeader (H, 'function GetStrProp (Instance: TObject; PropInfo: PPropInfo): String; overload;', Nil); + RegisterHeader (H, 'procedure SetStrProp (Instance: TObject; PropInfo: PPropInfo; const Value: String); overload;', Nil); + RegisterHeader (H, 'function GetWideStrProp (Instance: TObject; PropInfo: PPropInfo): WideString; overload;', Nil); + RegisterHeader (H, 'procedure SetWideStrProp (Instance: TObject; PropInfo: PPropInfo; const Value: WideString); overload;', + Nil); + RegisterHeader (H, 'function GetFloatProp (Instance: TObject; PropInfo: PPropInfo): Extended; overload;', Nil); + RegisterHeader (H, 'procedure SetFloatProp (Instance: TObject; PropInfo: PPropInfo; const Value: Extended); overload;', Nil); + RegisterHeader (H, 'function GetVariantProp (Instance: TObject; PropInfo: PPropInfo): Variant; overload;', Nil); + RegisterHeader (H, 'procedure SetVariantProp (Instance: TObject; PropInfo: PPropInfo; const Value: Variant); overload;', Nil); + + RegisterHeader (H, 'function GetMethodProp (Instance: TObject; PropInfo: PPropInfo): TMethod; overload;', Nil); + RegisterHeader (H, 'procedure SetMethodProp (Instance: TObject; PropInfo: PPropInfo; const Value: TMethod); overload;', Nil); + RegisterHeader (H, 'function GetInt64Prop (Instance: TObject; PropInfo: PPropInfo): Int64; overload;', Nil); + RegisterHeader (H, 'procedure SetInt64Prop (Instance: TObject; PropInfo: PPropInfo; const Value: Int64); overload;', Nil); + RegisterHeader (H, 'function GetInterfaceProp (Instance: TObject; PropInfo: PPropInfo): IInterface; overload;', Nil); + RegisterHeader (H, 'procedure SetInterfaceProp (Instance: TObject; PropInfo: PPropInfo; const Value: IInterface); overload;', + Nil); + RegisterVariable (H, 'DotSep:String;', @DotSep); + RegisterHeader (H, 'function SetToString (PropInfo: PPropInfo; Value: Integer; Brackets: Boolean = False): String;', Nil); + RegisterHeader (H, 'function StringToSet (PropInfo: PPropInfo; const Value: String): Integer;', Nil); +end; + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/RTTI/1/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/RTTI/1/Project1.dpr new file mode 100644 index 0000000..1322472 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/RTTI/1/Project1.dpr @@ -0,0 +1,192 @@ +{$APPTYPE CONSOLE} +{$O-} +program Project1; +uses + PAXCOMP_CONSTANTS, + PAXCOMP_SYS, + TypInfo, + Classes, + SysUtils, + IMPORT_Classes, + PaxCompiler, + PaxProgram, + PaxRegister, + IMPORT_TypInfo in 'IMPORT_TypInfo.pas'; + +type + TTestClass = class + procedure DoTest; + procedure OnClickHandler(Sender: TObject); + procedure OnClickHandler2(Sender: TObject); + end; + +var + PaxProgram1: TPaxProgram; + +procedure TTestClass.OnClickHandler(Sender: TObject); +begin + writeln('Click'); +end; + +procedure TTestClass.OnClickHandler2(Sender: TObject); +begin + writeln('Click 2'); +end; + + +procedure TTestClass.DoTest; +var + C: TClass; + P: Pointer; + pti: PTypeInfo; + ptd: PTypeData; + ppi: PPropInfo; + I: Integer; + Z, X: TObject; + S: String; + AMethod: TMethod; +begin + AMethod.Code := @ TTestClass.OnClickHandler; + AMethod.Data := Self; + + P := PaxProgram1.GetAddress('MyProg.TMyClass'); + C := TClass(P^); + writeln(C.ClassName); + pti := C.ClassInfo; + writeln(pti^.Name); + + ptd := GetTypeData(pti); + writeln(ptd^.ClassType.ClassName); + pti := ptd^.ParentInfo^; + writeln(pti^.Name); + writeln(ptd^.PropCount); + writeln(ptd^.UnitName); + + ppi := GetPropInfo(C, 'X'); + writeln(ppi^.Name); + + pti := PaxProgram1.GetTypeInfo('IUnknown'); + writeln(pti^.Name); + ptd := GetTypeData(pti); + writeln(ptd^.IntfUnit); + + pti := PaxProgram1.GetTypeInfo('MyProg.TCharSet'); + writeln(pti^.Name); + ptd := GetTypeData(pti); + if ptd <> nil then + writeln(ptd^.CompType^.Name); + + pti := PaxProgram1.GetTypeInfo('MyProg.TMyEnum'); + writeln(pti^.Name); + ptd := GetTypeData(pti); + writeln(ptd^.BaseType^.Name); +// writeln(ptd^.EnumUnitName); + writeln(GetEnumName(pti, 2)); + writeln(GetEnumValue(pti, 'three')); + + pti := PaxProgram1.GetTypeInfo('Integer'); + writeln(pti^.Name); + + // work with instance + + P := PaxProgram1.GetAddress('MyProg.Z'); + Z := TObject(P^); + writeln(Z.ClassName); + SetOrdProp(Z, 'X', 5); + I := GetOrdProp(Z, 'X'); + writeln(I); + + SetStrProp(Z, 'Y', 'abc'); + S := GetStrProp(Z, 'Y'); + writeln(S); + + ppi := GetPropInfo(Z, 'Inter'); + writeln(ppi^.Name); + + P := Z.MethodAddress('MyProc'); + asm + call P; + end; + + P := Z.FieldAddress('Field2'); + X := TObject(P^); + writeln(X.ClassName); + + SetMethodProp(Z, 'OnClick', AMethod); + AMethod := GetMethodProp(Z, 'OnClick'); + + asm + call AMethod.Code; + end; + + // RTTI of inherited class: + + P := PaxProgram1.GetAddress('MyProg.TMyClass2'); + C := TClass(P^); + writeln(C.ClassName); + pti := C.ClassInfo; + writeln(pti^.Name); + + ppi := GetPropInfo(C, 'X'); + writeln(ppi^.Name); + + // work with instance + P := PaxProgram1.GetAddress('MyProg.W'); + Z := TObject(P^); + writeln(Z.ClassName); + SetOrdProp(Z, 'X', 7); + I := GetOrdProp(Z, 'X'); + writeln(I); + + P := Z.MethodAddress('MyProc'); + asm + call P; + end; + + P := Z.FieldAddress('Field2'); + X := TObject(P^); + writeln(X.ClassName); +end; + +var + PaxCompiler1: TPaxCompiler; + PaxPascalLanguage1: TPaxPascalLanguage; + H: Integer; +begin + Register_Classes; + Register_TypInfo; + RegisterRTTIType(0, TypeInfo(TNotifyEvent)); + + H := RegisterClassType(0, TTestClass); + RegisterHeader(H, 'procedure DoTest;', + @TTestClass.DoTest); + RegisterHeader(H, 'procedure OnClickHandler2(Sender: TObject);', + @TTestClass.OnClickHandler2); + + PaxCompiler1 := TPaxCompiler.Create(nil); + PaxProgram1 := TPaxProgram.Create(nil); + PaxPascalLanguage1 := TPaxPascalLanguage.Create(nil); + try + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + PaxCompiler1.AddModule('1', 'Pascal'); + PaxCompiler1.AddCodeFromFile('1', 'script.txt'); + if PaxCompiler1.Compile(PaxProgram1) then + begin +{ + PaxProgram1.SaveToFile('1.bin'); + PaxProgram1.Free; + PaxProgram1 := TPaxProgram.Create(nil); + PaxProgram1.LoadFromFile('1.bin'); +} + PaxProgram1.Run; + end + else + writeln(PaxCompiler1.ErrorMessage[0]); + finally + PaxCompiler1.Free; + PaxProgram1.Free; + PaxPascalLanguage1.Free; + end; + writeln('Press any key...'); + Readln; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/RTTI/1/script.txt b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/RTTI/1/script.txt new file mode 100644 index 0000000..2fcac02 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/RTTI/1/script.txt @@ -0,0 +1,127 @@ +program MyProg; +uses TypInfo, Classes; +type + TCharSet = set of char; + + TMyEnum = (one, two, three); + + TMyClass = class(TComponent) + private + FX: Integer; + FY: String; + fStrings: TStringList; + FOnClick: TNotifyEvent; + fInter: IUnknown; + function GetX: Integer; + procedure SetX(value: Integer); + function GetY: String; + procedure SetY(const value: String); + public + constructor Create(AOwner: TComponent); + destructor Destroy; override; + procedure ScriptHandler(Sender: TObject); + published + Field: TObject; + Field2: TStringList; + property X: Integer read GetX write SetX; + property Y: String read FY write FY; + property Strings: TStringList read fStrings write fStrings; + property OnClick: TNotifyEvent read fOnClick write fOnClick; + property Inter: IUnknown read fInter write fInter; + procedure MyProc(U, V: Integer); + end; + + TMyClass2 = class(TMyClass) + end; + +constructor TMyClass.Create; +begin + inherited Create; + Field := TObject.Create; + Field2 := TStringList.Create; +end; + +destructor TMyClass.Destroy; +begin + Field.Free; + Field2.Free; + inherited; +end; + +procedure TMyClass.ScriptHandler(Sender: TObject); +begin + writeln('***************', Sender.ClassName); + ExitCode := 5; + writeln(ExitCode); +end; + + +function TMyClass.GetX: Integer; +begin + result := FX; + writeln('result=', result); +end; + +procedure TMyClass.SetX(value: Integer); +begin + writeln('value=', value); + FX := value; + writeln('FX=', FX); +end; + +function TMyClass.GetY: String; +begin + result := FY; + writeln('result=', result); +end; + +procedure TMyClass.SetY(const value: String); +begin + writeln('value=', value); + FY := value; + writeln('FY=', FY); +end; + +procedure TMyClass.MyProc(U, V: Integer); +begin + writeln('MyProc'); +end; + +var + Z, W: TMyClass; + TestClass: TTestClass; + pti: PTypeInfo; +begin + TestClass := TTestClass.Create; + + Z := TMyClass.Create(nil); + W := TMyClass2.Create(nil); + + W.X := 5; + writeln(W.X); + + W.Name := 'yyyy'; + writeln(W.Name); + + TestClass.DoTest; // Z.OnClick was assigned at host side + + if Assigned(Z.OnClick) then + Z.OnClick(Z); + + + Z.OnClick := TestClass.OnClickHandler2; // direct assignment of host handler + Z.OnClick(nil); + + Z.OnClick := Z.ScriptHandler; + Z.OnClick(W); + + pti := TypeInfo(TMyClass); + writeln(pti^.Name); + + + Z.Free; + W.Free; + + TestClass.Free; +end. + diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/RTTI/2/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/RTTI/2/Project1.dpr new file mode 100644 index 0000000..00ab849 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/RTTI/2/Project1.dpr @@ -0,0 +1,92 @@ +{$APPTYPE CONSOLE} +{$O-} +program Project1; +uses + PAXCOMP_CONSTANTS, + PAXCOMP_SYS, + TypInfo, + Classes, + SysUtils, + PaxCompiler, + PaxProgram, + PaxRegister; + +type + TTest = class(TComponent) + public + procedure Save; + end; + +{ TTest } + +procedure MyGetPropertyNames(aObject: TObject; aStringList: TStringList); +var + count : integer; + size : integer; + list : PPropList; + i : integer; + ppi: PPropInfo; +begin + aStringList.Clear; + count := GetPropList(PTypeInfo(aObject.ClassInfo), tkProperties, nil, false); + size := count * SizeOf(Pointer); + GetMem(list, size); + try + GetPropList(PTypeInfo(aObject.ClassInfo), tkProperties, list, false); + for i := 0 to count - 1 do + aStringList.Add(list^[i]^.Name); + finally + FreeMem(list, size); + end; +end; + +type + TMyStringList = class(TStringList) + published + property Text; + end; + +procedure TTest.Save; +var + list: TMyStringList; +begin + list := TMyStringList.Create; + try + MyGetPropertyNames(self, list); + writeln('Property Count = ', list.Count); + writeln('Properties are: ' + list.Text); + finally + list.free; + end; +end; + +var + PaxProgram1: TPaxProgram; + PaxCompiler1: TPaxCompiler; + PaxPascalLanguage1: TPaxPascalLanguage; + H: Integer; +begin + H := RegisterClassType(0, TTest); + RegisterHeader(H, 'procedure Save;', @TTest.Save); + + PaxCompiler1 := TPaxCompiler.Create(nil); + PaxProgram1 := TPaxProgram.Create(nil); + PaxPascalLanguage1 := TPaxPascalLanguage.Create(nil); + try + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + PaxCompiler1.AddModule('1', 'Pascal'); + PaxCompiler1.AddCodeFromFile('1', 'script.txt'); + if PaxCompiler1.Compile(PaxProgram1) then + begin + PaxProgram1.Run; + end + else + writeln(PaxCompiler1.ErrorMessage[0]); + finally + PaxCompiler1.Free; + PaxProgram1.Free; + PaxPascalLanguage1.Free; + end; + writeln('Press any key...'); + Readln; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/RTTI/2/script.txt b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/RTTI/2/script.txt new file mode 100644 index 0000000..4d0e53b --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/RTTI/2/script.txt @@ -0,0 +1,43 @@ +program MyTestProg; + +type + TMyTestBase = class(TTest) + end; + + + TMyTest = class(TMyTestBase) + private + FX: Integer; + FY: String; + function GetX: Integer; + procedure SetX(value: Integer); + published + property X: Integer read GetX write SetX; + property Y: String read FY write FY; + end; + +function TMyTest.GetX: Integer; +begin + result := FX; + writeln('result=', result); +end; + +procedure TMyTest.SetX(value: Integer); +begin + writeln('value=', value); + FX := value; + writeln('FX=', FX); +end; + +var + t: TMyTest; +begin + t := TMyTest.Create; + try + t.x := 10; + t.y := '20'; + t.Save; + finally + t.Free; + end; +end. \ No newline at end of file diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/RegisterVariable/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/RegisterVariable/Project1.dpr new file mode 100644 index 0000000..513a1dd --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/RegisterVariable/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/RegisterVariable/Project1.res b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/RegisterVariable/Project1.res new file mode 100644 index 0000000..3adc036 Binary files /dev/null and b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/RegisterVariable/Project1.res differ diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/RegisterVariable/Unit1.dfm b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/RegisterVariable/Unit1.dfm new file mode 100644 index 0000000..de996ec --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/RegisterVariable/Unit1.dfm @@ -0,0 +1,45 @@ +object Form1: TForm1 + Left = 192 + Top = 114 + Width = 282 + Height = 178 + Caption = 'Register variable demo' + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + PixelsPerInch = 96 + TextHeight = 13 + object Button1: TButton + Left = 40 + Top = 80 + Width = 75 + Height = 25 + Caption = 'Run' + TabOrder = 0 + OnClick = Button1Click + end + object PaxCompiler1: TPaxCompiler + Alignment = 1 + DebugMode = False + Left = 32 + Top = 16 + end + object PaxPascalLanguage1: TPaxPascalLanguage + ExplicitOff = False + CompleteBooleanEval = False + UnitLookup = True + PrintKeyword = 'print' + PrintlnKeyword = 'println' + Left = 80 + Top = 16 + end + object PaxProgram1: TPaxProgram + Console = False + Left = 128 + Top = 16 + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/RegisterVariable/Unit1.pas b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/RegisterVariable/Unit1.pas new file mode 100644 index 0000000..2ebd838 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/RegisterVariable/Unit1.pas @@ -0,0 +1,69 @@ +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, PaxCompiler, PaxProgram, PaxRegister, PaxRunner; + +type + TForm1 = class(TForm) + PaxCompiler1: TPaxCompiler; + PaxPascalLanguage1: TPaxPascalLanguage; + PaxProgram1: TPaxProgram; + Button1: TButton; + procedure Button1Click(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.dfm} + +type + TMyPoint = packed record + x, y: Integer; + end; + +procedure TForm1.Button1Click(Sender: TObject); +var + H_TMyPoint, H_MyPoint: Integer; + MyPoint: TMyPoint; + I: Integer; +begin + MyPoint.X := 60; + MyPoint.Y := 23; + + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + + // register host-defined type + H_TMyPoint := PaxCompiler1.RegisterRecordType(0, 'TMyPoint'); + PaxCompiler1.RegisterRecordTypeField(H_TMyPoint, 'X', _typeINTEGER); + PaxCompiler1.RegisterRecordTypeField(H_TMyPoint, 'Y', _typeINTEGER); + + // register host-defined variable + H_MyPoint := PaxCompiler1.RegisterVariable(0, 'MyPoint', H_TMyPoint, @MyPoint); + + PaxCompiler1.AddModule('1', PaxPascalLanguage1.LanguageName); + PaxCompiler1.AddCode('1', 'begin'); + PaxCompiler1.AddCode('1', ' MyPoint.Y := 8;'); + PaxCompiler1.AddCode('1', 'end.'); + + if PaxCompiler1.Compile(PaxProgram1) then + begin + PaxProgram1.Run; + ShowMessage(IntToStr(MyPoint.Y)); + end + else + for I:=0 to PaxCompiler1.ErrorCount do + ShowMessage(PaxCompiler1.ErrorMessage[I]); +end; + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/UnhandledException/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/UnhandledException/Project1.dpr new file mode 100644 index 0000000..513a1dd --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/UnhandledException/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/UnhandledException/Unit1.dfm b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/UnhandledException/Unit1.dfm new file mode 100644 index 0000000..4edb12b --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/UnhandledException/Unit1.dfm @@ -0,0 +1,43 @@ +object Form1: TForm1 + Left = 192 + Top = 114 + Caption = 'Unhandled exception demo' + ClientHeight = 139 + ClientWidth = 491 + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + PixelsPerInch = 96 + TextHeight = 13 + object Button1: TButton + Left = 48 + Top = 32 + Width = 113 + Height = 25 + Caption = 'Compile and Run' + TabOrder = 0 + OnClick = Button1Click + end + object PaxCompiler1: TPaxCompiler + Alignment = 1 + DebugMode = False + Left = 200 + Top = 40 + end + object PaxPascalLanguage1: TPaxPascalLanguage + CompleteBooleanEval = False + UnitLookup = True + Left = 240 + Top = 40 + end + object PaxProgram1: TPaxProgram + Console = False + OnUnhandledException = PaxProgram1UnhandledException + Left = 280 + Top = 40 + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/UnhandledException/Unit1.pas b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/UnhandledException/Unit1.pas new file mode 100644 index 0000000..1901a19 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/UnhandledException/Unit1.pas @@ -0,0 +1,62 @@ +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, PaxProgram, PaxCompiler; + +type + TForm1 = class(TForm) + Button1: TButton; + PaxCompiler1: TPaxCompiler; + PaxPascalLanguage1: TPaxPascalLanguage; + PaxProgram1: TPaxProgram; + procedure PaxProgram1UnhandledException(Sender: TPaxProgram; E: Exception; + const ModuleName: String; SourceLineNumber: Integer); + procedure Button1Click(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +uses IMPORT_SysUtils; + +{$R *.dfm} + +procedure TForm1.PaxProgram1UnhandledException(Sender: TPaxProgram; + E: Exception; const ModuleName: String; SourceLineNumber: Integer); +begin + ShowMessage('Run-time error (' + E.Message + ') raised at line ' + IntToStr(SourceLineNumber) + ':' + + PaxCompiler1.Modules[ModuleName][SourceLineNumber]); +end; + +procedure TForm1.Button1Click(Sender: TObject); +begin + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + PaxCompiler1.AddModule('main', 'Pascal'); + PaxCompiler1.AddCode('main', 'uses SysUtils;'); + PaxCompiler1.AddCode('main', 'begin'); + PaxCompiler1.AddCode('main', ' raise Exception.Create(''Error'');'); + PaxCompiler1.AddCode('main', 'end.'); + if PaxCompiler1.Compile(PaxProgram1) then + begin + PaxProgram1.Run; + end + else + ShowMessage('Compile error: ' + PaxCompiler1.ErrorMessage[0] + ' at line ' + #13#10 + + PaxCompiler1.ErrorLine[0]); +end; + +initialization + +Register_SysUtils; + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/code_explorer_ex/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/code_explorer_ex/Project1.dpr new file mode 100644 index 0000000..513a1dd --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/code_explorer_ex/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/code_explorer_ex/Project1.res b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/code_explorer_ex/Project1.res new file mode 100644 index 0000000..3adc036 Binary files /dev/null and b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/code_explorer_ex/Project1.res differ diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/code_explorer_ex/Unit1.dfm b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/code_explorer_ex/Unit1.dfm new file mode 100644 index 0000000..00a24c2 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/code_explorer_ex/Unit1.dfm @@ -0,0 +1,115 @@ +object Form1: TForm1 + Left = 192 + Top = 114 + Caption = 'Code explorer demo' + ClientHeight = 446 + ClientWidth = 688 + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + PixelsPerInch = 96 + TextHeight = 13 + object Panel1: TPanel + Left = 0 + Top = 405 + Width = 688 + Height = 41 + Align = alBottom + TabOrder = 0 + object Button1: TButton + Left = 24 + Top = 8 + Width = 105 + Height = 25 + Caption = 'Compile' + TabOrder = 0 + OnClick = Button1Click + end + end + object Memo1: TMemo + Left = 0 + Top = 0 + Width = 345 + Height = 405 + Align = alLeft + Lines.Strings = ( + 'uses' + ' Classes;' + 'type' + '' + ' TMyNotifyEvent = procedure (Sender:TObject) of object;' + '' + ' TMyArray = array[1..10] of Single;' + ' TMyPoint = record' + ' X, Y: Double;' + ' end;' + ' TMyClass = class' + ' private' + ' P, Q: Integer;' + ' public' + ' function MyClassFunc: Integer;' + ' published' + ' property MyProp: Integer read P;' + ' end;' + '' + 'function TMyClass.MyClassFunc: Integer;' + 'begin' + 'end;' + '' + 'procedure MyProc(var X: Integer; const Y: Integer; Z: Integer);' + 'procedure NestedProc;' + 'begin' + 'end;' + 'var' + ' L: Double;' + 'const' + ' W = '#39'abc'#39';' + 'begin' + 'end;' + 'function MyFunc: String;' + 'type' + ' TMyEnum = (one, two, three);' + 'begin' + ' result := '#39'pqr'#39';' + 'end;' + 'const' + ' Z = 80;' + 'var' + ' G: Byte;' + 'begin' + 'end.') + TabOrder = 1 + end + object TreeView1: TTreeView + Left = 345 + Top = 0 + Width = 343 + Height = 405 + Align = alClient + Indent = 19 + TabOrder = 2 + OnDblClick = TreeView1DblClick + end + object PaxCompiler1: TPaxCompiler + Alignment = 1 + DebugMode = False + Left = 224 + Top = 413 + end + object PaxPascalLanguage1: TPaxPascalLanguage + CompleteBooleanEval = False + UnitLookup = True + PrintKeyword = 'print' + PrintlnKeyword = 'println' + Left = 264 + Top = 413 + end + object PaxCompilerExplorer1: TPaxCompilerExplorer + Left = 304 + Top = 413 + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/code_explorer_ex/Unit1.pas b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/code_explorer_ex/Unit1.pas new file mode 100644 index 0000000..9a26380 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/code_explorer_ex/Unit1.pas @@ -0,0 +1,267 @@ +unit Unit1; + +interface + +uses + Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, + Dialogs, PaxCompilerExplorer, PaxCompiler, StdCtrls, ExtCtrls, ComCtrls, + PAXCOMP_SYS, + IMPORT_Classes; + +type + TForm1 = class(TForm) + Panel1: TPanel; + Memo1: TMemo; + Button1: TButton; + PaxCompiler1: TPaxCompiler; + PaxPascalLanguage1: TPaxPascalLanguage; + PaxCompilerExplorer1: TPaxCompilerExplorer; + TreeView1: TTreeView; + procedure Button1Click(Sender: TObject); + procedure TreeView1DblClick(Sender: TObject); + private + { Private declarations } + L: TList; + public + { Public declarations } + procedure BuildTree; + procedure EnumProc(Id: Integer; + Host: Boolean; + Kind: TPaxMemberKind; + Data: Pointer); + end; + +var + Form1: TForm1; + +implementation + +{$R *.dfm} + +procedure TForm1.Button1Click(Sender: TObject); +var + I: Integer; +begin + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + PaxCompiler1.AddModule('1', 'Pascal'); + PaxCompiler1.AddCode('1', Memo1.Lines.Text); + if PaxCompiler1.Compile then + begin + PaxCompilerExplorer1.RegisterCompiler(PaxCompiler1); + BuildTree; + end + else + for I:=0 to PaxCompiler1.ErrorCount - 1 do + ShowMessage(PaxCompiler1.ErrorMessage[I]); +end; + +procedure TForm1.BuildTree; +var + N, N2: TTreeNode; + I: Integer; +begin + L := TList.Create; + try + TreeView1.Items.Clear; + + N := TreeView1.Items.Add(nil, 'Used namespaces'); + L.Add(N); + PaxCompilerExplorer1.EnumMembers(0, true, pmkNamespace, EnumProc, N); + PaxCompilerExplorer1.EnumMembers(0, false, pmkNamespace, EnumProc, N); + + N := TreeView1.Items.Add(nil, 'Noname namespace'); + + N2 := TreeView1.Items.AddChild(N, 'Types'); + L.Add(N2); + PaxCompilerExplorer1.EnumMembers(0, false, pmkType, EnumProc, N2); + + N2 := TreeView1.Items.AddChild(N, 'Procedures'); + L.Add(N2); + PaxCompilerExplorer1.EnumMembers(0, false, pmkProcedure, EnumProc, N2); + + N2 := TreeView1.Items.AddChild(N, 'Functions'); + L.Add(N2); + PaxCompilerExplorer1.EnumMembers(0, false, pmkFunction, EnumProc, N2); + + N2 := TreeView1.Items.AddChild(N, 'Constants'); + L.Add(N2); + PaxCompilerExplorer1.EnumMembers(0, false, pmkConst, EnumProc, N2); + + N2 := TreeView1.Items.AddChild(N, 'Variables'); + L.Add(N2); + PaxCompilerExplorer1.EnumMembers(0, false, pmkVar, EnumProc, N2); + + finally + for I := L.Count - 1 downto 0 do + begin + N2 := TTreeNode(L[I]); + if N2.Count = 0 then + N2.Delete; + end; + + L.Free; + end; +end; + +procedure TForm1.EnumProc(Id: Integer; + Host: Boolean; + Kind: TPaxMemberKind; + Data: Pointer); +var + N, N2, N3: TTreeNode; + Name: String; + TypeName: String; + vis: TClassVisibility; + S: String; +begin + N := TTreeNode(Data); + + Name := PaxCompilerExplorer1.Names[Id]; + TypeName := PaxCompilerExplorer1.TypeNames[Id]; + + S := ''; + vis := PaxCompilerExplorer1.GetVisibility(Id); + case vis of + cvPrivate : S := ' (private) '; + cvProtected : S := ' (protected) '; + cvPublic : S := ' (public)'; + cvPublished : S := ' (published) '; + end; + + with TreeView1.Items do + case Kind of + pmkProcedure, pmkFunction, pmkConstructor, pmkDestructor: + begin + N2 := AddChildObject(N, S + Name, TObject(Id)); + + N3 := AddChild(N2, 'Parameters'); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, Host, pmkParam, EnumProc, N3); + + N3 := AddChild(N2, 'Local variables'); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, Host, pmkVar, EnumProc, N3); + + N3 := AddChild(N2, 'Local constants'); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, Host, pmkConst, EnumProc, N3); + + N3 := AddChild(N2, 'Local types'); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, Host, pmkType, EnumProc, N3); + + N3 := TreeView1.Items.AddChild(N2, 'Nested procedures'); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, false, pmkProcedure, EnumProc, N3); + + N3 := TreeView1.Items.AddChild(N2, 'Nested functions'); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, false, pmkFunction, EnumProc, N3); + + end; + pmkParam: + begin + if PaxCompilerExplorer1.IsByRefParam(Id) then + AddChildObject(N, 'var ' + Name + ': ' + TypeName, TObject(Id)) + else if PaxCompilerExplorer1.IsConstParam(Id) then + AddChildObject(N, 'const ' + Name + ': ' + TypeName, TObject(Id)) + else + AddChildObject(N, Name + ': ' + TypeName, TObject(Id)); + end; + pmkVar: AddChildObject(N, Name + ': ' + TypeName, TObject(Id)); + pmkConst: AddChildObject(N, Name + ': ' + TypeName, TObject(Id)); + pmkField: AddChildObject(N, S + Name + ': ' + TypeName, TObject(Id)); + pmkProperty: AddChildObject(N, S + Name + ': ' + TypeName, TObject(Id)); + pmkType: + begin + N2 := AddChildObject(N, Name, TObject(Id)); + if PaxCompilerExplorer1.IsRecordType(Id) then + begin + N3 := AddChild(N2, 'Fields'); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, Host, pmkField, EnumProc, N3); + end + else if PaxCompilerExplorer1.IsClassType(Id) then + begin + N3 := AddChild(N2, 'Fields'); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, Host, pmkField, EnumProc, N3); + + N3 := AddChild(N2, 'Properties'); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, Host, pmkProperty, EnumProc, N3); + + N3 := TreeView1.Items.AddChild(N2, 'Constructors'); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, false, pmkConstructor, EnumProc, N3); + + N3 := TreeView1.Items.AddChild(N2, 'Destructor'); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, false, pmkDestructor, EnumProc, N3); + + N3 := TreeView1.Items.AddChild(N2, 'Class procedures'); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, false, pmkProcedure, EnumProc, N3); + + N3 := TreeView1.Items.AddChild(N2, 'Class functions'); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, false, pmkFunction, EnumProc, N3); + end; + end; + pmkNamespace: + begin + N2 := AddChildObject(N, Name, TObject(Id)); + + N3 := AddChild(N2, 'Constants'); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, Host, pmkConst, EnumProc, N3); + + N3 := AddChild(N2, 'Variables'); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, Host, pmkVar, EnumProc, N3); + + N3 := AddChild(N2, 'Procedures'); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, Host, pmkProcedure, EnumProc, N3); + + N3 := AddChild(N2, 'Types'); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, Host, pmkType, EnumProc, N3); + end; + end; +end; + +procedure TForm1.TreeView1DblClick(Sender: TObject); +var + N: TTreeNode; + Id, Position: Integer; + S: String; +begin + N := TTreeView(Sender).Selected; + + if N = nil then + Exit; + + Id := Integer(N.Data); + + if Id = 0 then + Exit; + + S := PaxCompilerExplorer1.Names[Id]; + Position := PaxCompilerExplorer1.Positions[Id]; + + if Id <> 0 then + with Memo1 do + begin + SetFocus; + SelStart := Position; + SelLength := Length(S); + end; +end; + +initialization + +Register_Classes; + +end. diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/pcu2/Project1.dpr b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/pcu2/Project1.dpr new file mode 100644 index 0000000..7ebe30f --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/pcu2/Project1.dpr @@ -0,0 +1,67 @@ +program Project2; +{$APPTYPE CONSOLE} +uses + sysutils, + Classes, + TypInfo, + Forms, + PaxCompiler, + PaxProgram, + PaxRegister, + IMPORT_Common; + +type + TMyHandler = class + public + procedure UnknownDirectiveHandler(Sender: TPaxCompiler; + const Directive: string; var ok: Boolean); + end; + +procedure TMyHandler.UnknownDirectiveHandler(Sender: TPaxCompiler; + const Directive: string; var ok: Boolean); +begin + ok := true; +end; + +var + MyHandler: TMyHandler; + PaxCompiler1: TPaxCompiler; + PaxProgram1: TPaxProgram; + PaxPascalLanguage1: TPaxPascalLanguage; +begin + // Build all units, save pcu-files and create compiled script + + MyHandler := TMyHandler.Create; + PaxCompiler1 := TPaxCompiler.Create(nil); + PaxCompiler1.OnUnknownDirective := MyHandler.UnknownDirectiveHandler; + + PaxProgram1 := TPaxProgram.Create(nil); + PaxPascalLanguage1 := TPaxPascalLanguage.Create(nil); + + try + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + PaxCompiler1.AddModule('unit2', 'Pascal'); + PaxCompiler1.AddCodeFromFile('unit2', 'unit2.pas'); + + if PaxCompiler1.Compile(PaxProgram1, true, false) then + begin + // build with run-time packages + PaxProgram1.SaveToFile('unit2.pcu'); + writeln('ok'); + end + else + begin + writeln(PaxCompiler1.ErrorMessage[0]); + writeln(PaxCompiler1.ErrorLine[0]); + end; + finally + PaxCompiler1.Free; + PaxProgram1.Free; + PaxPascalLanguage1.Free; + MyHandler.Free; + end; + + writeln('Press any key...'); + Readln; +end. + diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/pcu2/Project2.dpr b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/pcu2/Project2.dpr new file mode 100644 index 0000000..f825afe --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/pcu2/Project2.dpr @@ -0,0 +1,83 @@ +program Project2; +{$APPTYPE CONSOLE} +uses + sysutils, + Classes, + TypInfo, + Forms, + PaxCompiler, + PaxRunner, + PaxProgram, + PaxRegister, + IMPORT_Common; + +type + TMyHandler = class + public + procedure CreateObjectHandler(Sender: TPaxRunner; + Instance: TObject); + end; + +procedure TMyHandler.CreateObjectHandler(Sender: TPaxRunner; + Instance: TObject); +var + pti: PTypeInfo; + ptd: PTypeData; + S: String; +begin + writeln('OnCreateObject:'); + + if Instance is TForm then + begin + pti := Instance.ClassInfo; + ptd := GetTypeData(pti); + if FileExists(ptd^.UnitName + '.dfm') then + Sender.LoadDFMFile(Instance, ptd^.UnitName + '.dfm'); + end; +end; + +var + MyHandler: TMyHandler; + PaxCompiler1: TPaxCompiler; + PaxProgram1: TPaxProgram; + PaxPascalLanguage1: TPaxPascalLanguage; +begin + // Build all units, save pcu-files and create compiled script + + MyHandler := TMyHandler.Create; + PaxCompiler1 := TPaxCompiler.Create(nil); + + PaxProgram1 := TPaxProgram.Create(nil); + PaxProgram1.OnCreateObject := MyHandler.CreateObjectHandler; + PaxPascalLanguage1 := TPaxPascalLanguage.Create(nil); + + try + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + PaxCompiler1.AddModule('1', 'Pascal'); + PaxCompiler1.AddCode('1', 'uses Forms, unit2;'); + PaxCompiler1.AddCode('1', 'var F: TForm2;'); + PaxCompiler1.AddCode('1', 'begin'); + PaxCompiler1.AddCode('1', ' F := TForm2.Create(nil);'); + PaxCompiler1.AddCode('1', ' F.ShowModal;'); + PaxCompiler1.AddCode('1', ' F.Free;'); + PaxCompiler1.AddCode('1', 'end.'); + + if PaxCompiler1.Compile(PaxProgram1) then + // build with run-time packages + PaxProgram1.Run + else + begin + writeln(PaxCompiler1.ErrorMessage[0]); + writeln(PaxCompiler1.ErrorLine[0]); + end; + finally + PaxCompiler1.Free; + PaxProgram1.Free; + PaxPascalLanguage1.Free; + MyHandler.Free; + end; + + writeln('Press any key...'); + Readln; +end. + diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/pcu2/Unit2.dfm b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/pcu2/Unit2.dfm new file mode 100644 index 0000000..da6204b --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/pcu2/Unit2.dfm @@ -0,0 +1,26 @@ +object Form2: TForm2 + Left = 0 + Top = 0 + Caption = 'Form2' + ClientHeight = 216 + ClientWidth = 426 + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'Tahoma' + Font.Style = [] + OldCreateOrder = False + OnCreate = FormCreate + PixelsPerInch = 96 + TextHeight = 13 + object Button1: TButton + Left = 40 + Top = 88 + Width = 75 + Height = 25 + Caption = 'Button1' + TabOrder = 0 + OnClick = Button1Click + end +end diff --git a/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/pcu2/Unit2.pas b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/pcu2/Unit2.pas new file mode 100644 index 0000000..211caa6 --- /dev/null +++ b/Demos/ANOTHER_DEMOS/PaxProgram/Pascal/pcu2/Unit2.pas @@ -0,0 +1,37 @@ +unit Unit2; + +interface + +uses + SysUtils, Variants, Classes, Controls, Forms, + Dialogs, StdCtrls; + +type + TForm2 = class(TForm) + Button1: TButton; + procedure FormCreate(Sender: TObject); + procedure Button1Click(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + end; + +var + Form2: TForm2; + +implementation + +{$R *.dfm} + +procedure TForm2.Button1Click(Sender: TObject); +begin + ShowMessage('Hello'); +end; + +procedure TForm2.FormCreate(Sender: TObject); +begin + ShowMessage('Created'); +end; + +end. diff --git a/Demos/AUTO_IMPORT_DEMOS/PaxInterpreter/Hello/Project1.dpr b/Demos/AUTO_IMPORT_DEMOS/PaxInterpreter/Hello/Project1.dpr new file mode 100644 index 0000000..fb91550 --- /dev/null +++ b/Demos/AUTO_IMPORT_DEMOS/PaxInterpreter/Hello/Project1.dpr @@ -0,0 +1,14 @@ +program Project1; + +uses + Vcl.Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.MainFormOnTaskbar := True; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Demos/AUTO_IMPORT_DEMOS/PaxInterpreter/Hello/Project1.dproj b/Demos/AUTO_IMPORT_DEMOS/PaxInterpreter/Hello/Project1.dproj new file mode 100644 index 0000000..7896600 --- /dev/null +++ b/Demos/AUTO_IMPORT_DEMOS/PaxInterpreter/Hello/Project1.dproj @@ -0,0 +1,141 @@ + + + {B5379478-9DE6-48A0-9780-9C51DB4DF7CC} + Project1.dpr + True + Debug + 1025 + Application + VCL + 18.1 + Win32 + + + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Cfg_1 + true + true + + + true + Base + true + + + true + Cfg_2 + true + true + + + true + Cfg_2 + true + true + + + false + Project1 + 2052 + false + false + false + false + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=;CFBundleName= + 00400000 + Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;System;Xml;Data;Datasnap;Web;Soap;$(DCC_Namespace) + + + 1033 + true + true + Project1_Icon.ico + $(BDS)\bin\default_app.manifest + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments= + Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) + + + true + Project1_Icon.ico + $(BDS)\bin\default_app.manifest + + + RELEASE;$(DCC_Define) + false + 0 + 0 + + + true + true + + + true + DEBUG;$(DCC_Define) + false + + + Debug + + + true + true + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments= + + + + MainSource + + +
Form1
+ + + Cfg_2 + Base + + + Base + + + Cfg_1 + Base + + + + Delphi.Personality.12 + + + + + Project1.dpr + + + + True + True + False + + + 12 + + + + diff --git a/Demos/AUTO_IMPORT_DEMOS/PaxInterpreter/Hello/Project1.otares b/Demos/AUTO_IMPORT_DEMOS/PaxInterpreter/Hello/Project1.otares new file mode 100644 index 0000000..5e952b5 Binary files /dev/null and b/Demos/AUTO_IMPORT_DEMOS/PaxInterpreter/Hello/Project1.otares differ diff --git a/Demos/AUTO_IMPORT_DEMOS/PaxInterpreter/Hello/Project1.res b/Demos/AUTO_IMPORT_DEMOS/PaxInterpreter/Hello/Project1.res new file mode 100644 index 0000000..926afb5 Binary files /dev/null and b/Demos/AUTO_IMPORT_DEMOS/PaxInterpreter/Hello/Project1.res differ diff --git a/Demos/AUTO_IMPORT_DEMOS/PaxInterpreter/Hello/Project1_Icon.ico b/Demos/AUTO_IMPORT_DEMOS/PaxInterpreter/Hello/Project1_Icon.ico new file mode 100644 index 0000000..fc7534d Binary files /dev/null and b/Demos/AUTO_IMPORT_DEMOS/PaxInterpreter/Hello/Project1_Icon.ico differ diff --git a/Demos/AUTO_IMPORT_DEMOS/PaxInterpreter/Hello/Unit1.dfm b/Demos/AUTO_IMPORT_DEMOS/PaxInterpreter/Hello/Unit1.dfm new file mode 100644 index 0000000..8236bc4 --- /dev/null +++ b/Demos/AUTO_IMPORT_DEMOS/PaxInterpreter/Hello/Unit1.dfm @@ -0,0 +1,68 @@ +object Form1: TForm1 + Left = 0 + Top = 0 + Caption = 'Hello' + ClientHeight = 203 + ClientWidth = 412 + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -10 + Font.Name = 'Tahoma' + Font.Style = [] + OldCreateOrder = False + PixelsPerInch = 96 + TextHeight = 12 + object Memo1: TMemo + Left = 12 + Top = 12 + Width = 229 + Height = 175 + Margins.Left = 2 + Margins.Top = 2 + Margins.Right = 2 + Margins.Bottom = 2 + Lines.Strings = ( + 'uses' + ' Unit1;' + 'begin' + ' Form1.Button1.Caption := '#39'Hello'#39';' + 'end.') + TabOrder = 0 + end + object Button1: TButton + Left = 266 + Top = 168 + Width = 56 + Height = 19 + Margins.Left = 2 + Margins.Top = 2 + Margins.Right = 2 + Margins.Bottom = 2 + Caption = 'Run script' + TabOrder = 1 + OnClick = Button1Click + end + object PaxCompiler1: TPaxCompiler + Alignment = 8 + OnUsedUnit = PaxCompiler1UsedUnit + OnImportUnit = PaxCompiler1ImportUnit + DebugMode = False + Left = 320 + Top = 40 + end + object PaxPascalLanguage1: TPaxPascalLanguage + ExplicitOff = False + CompleteBooleanEval = False + UnitLookup = True + PrintKeyword = 'print' + PrintlnKeyword = 'println' + Left = 312 + Top = 96 + end + object PaxInterpreter1: TPaxInterpreter + Console = False + Left = 360 + Top = 88 + end +end diff --git a/Demos/AUTO_IMPORT_DEMOS/PaxInterpreter/Hello/Unit1.pas b/Demos/AUTO_IMPORT_DEMOS/PaxInterpreter/Hello/Unit1.pas new file mode 100644 index 0000000..6dd969b --- /dev/null +++ b/Demos/AUTO_IMPORT_DEMOS/PaxInterpreter/Hello/Unit1.pas @@ -0,0 +1,68 @@ +unit Unit1; + +interface + +uses + Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics, + Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, PaxRunner, PaxInterpreter, + PaxCompiler; + +type + TForm1 = class(TForm) + Memo1: TMemo; + Button1: TButton; + PaxCompiler1: TPaxCompiler; + PaxPascalLanguage1: TPaxPascalLanguage; + PaxInterpreter1: TPaxInterpreter; + procedure PaxCompiler1ImportUnit(Sender: TPaxCompiler; Id: Integer; + const AFullName: string); + procedure Button1Click(Sender: TObject); + function PaxCompiler1UsedUnit(Sender: TPaxCompiler; const UnitName: string; + var SourceCode: string): Boolean; + private + { Private declarations } + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.dfm} + +procedure TForm1.Button1Click(Sender: TObject); +begin + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + PaxCompiler1.AddModule('1', 'Pascal'); + PaxCompiler1.AddCode('1', Memo1.Lines.Text); + if PaxCompiler1.Compile(PaxInterpreter1) then + begin + PaxInterpreter1.Run; + end + else + ShowMessage(PaxCompiler1.ErrorMessage[0]); +end; + +procedure TForm1.PaxCompiler1ImportUnit(Sender: TPaxCompiler; Id: Integer; + const AFullName: string); +begin +// Global members must be imported explicitly. + + Sender.RegisterVariable(Id, 'Form1: TForm1', @Form1); +end; + +function TForm1.PaxCompiler1UsedUnit(Sender: TPaxCompiler; + const UnitName: string; var SourceCode: string): Boolean; +begin +// Use OnUsedUnit event to prevent loading Unit1.pas from disk. +// We are going to import types of Unit1.pas, not to compile the unit. + + Sender.RegisterImportUnit(0, UnitName); + result := true; + SourceCode := ''; +end; + +end. diff --git a/Demos/AUTO_IMPORT_DEMOS/PaxInterpreter/ImportAbstractClass/Project1.dpr b/Demos/AUTO_IMPORT_DEMOS/PaxInterpreter/ImportAbstractClass/Project1.dpr new file mode 100644 index 0000000..fb91550 --- /dev/null +++ b/Demos/AUTO_IMPORT_DEMOS/PaxInterpreter/ImportAbstractClass/Project1.dpr @@ -0,0 +1,14 @@ +program Project1; + +uses + Vcl.Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.MainFormOnTaskbar := True; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Demos/AUTO_IMPORT_DEMOS/PaxInterpreter/ImportAbstractClass/Project1.dproj b/Demos/AUTO_IMPORT_DEMOS/PaxInterpreter/ImportAbstractClass/Project1.dproj new file mode 100644 index 0000000..e7dbe59 --- /dev/null +++ b/Demos/AUTO_IMPORT_DEMOS/PaxInterpreter/ImportAbstractClass/Project1.dproj @@ -0,0 +1,141 @@ + + + {0CC03600-F15D-4008-A4CE-DB486B456283} + Project1.dpr + True + Debug + 1025 + Application + VCL + 18.1 + Win32 + + + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Cfg_1 + true + true + + + true + Base + true + + + true + Cfg_2 + true + true + + + true + Cfg_2 + true + true + + + false + Project1 + 2052 + false + false + false + false + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=;CFBundleName= + 00400000 + Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;System;Xml;Data;Datasnap;Web;Soap;$(DCC_Namespace) + + + 1033 + true + true + Project1_Icon.ico + $(BDS)\bin\default_app.manifest + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments= + Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) + + + true + Project1_Icon.ico + $(BDS)\bin\default_app.manifest + + + RELEASE;$(DCC_Define) + false + 0 + 0 + + + true + true + + + true + DEBUG;$(DCC_Define) + false + + + Debug + + + true + true + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments= + + + + MainSource + + +
Form1
+ + + Cfg_2 + Base + + + Base + + + Cfg_1 + Base + + + + Delphi.Personality.12 + + + + + Project1.dpr + + + + True + True + False + + + 12 + + + + diff --git a/Demos/AUTO_IMPORT_DEMOS/PaxInterpreter/ImportAbstractClass/Project1.otares b/Demos/AUTO_IMPORT_DEMOS/PaxInterpreter/ImportAbstractClass/Project1.otares new file mode 100644 index 0000000..5e952b5 Binary files /dev/null and b/Demos/AUTO_IMPORT_DEMOS/PaxInterpreter/ImportAbstractClass/Project1.otares differ diff --git a/Demos/AUTO_IMPORT_DEMOS/PaxInterpreter/ImportAbstractClass/Project1.res b/Demos/AUTO_IMPORT_DEMOS/PaxInterpreter/ImportAbstractClass/Project1.res new file mode 100644 index 0000000..926afb5 Binary files /dev/null and b/Demos/AUTO_IMPORT_DEMOS/PaxInterpreter/ImportAbstractClass/Project1.res differ diff --git a/Demos/AUTO_IMPORT_DEMOS/PaxInterpreter/ImportAbstractClass/Project1_Icon.ico b/Demos/AUTO_IMPORT_DEMOS/PaxInterpreter/ImportAbstractClass/Project1_Icon.ico new file mode 100644 index 0000000..fc7534d Binary files /dev/null and b/Demos/AUTO_IMPORT_DEMOS/PaxInterpreter/ImportAbstractClass/Project1_Icon.ico differ diff --git a/Demos/AUTO_IMPORT_DEMOS/PaxInterpreter/ImportAbstractClass/Unit1.dfm b/Demos/AUTO_IMPORT_DEMOS/PaxInterpreter/ImportAbstractClass/Unit1.dfm new file mode 100644 index 0000000..dda1036 --- /dev/null +++ b/Demos/AUTO_IMPORT_DEMOS/PaxInterpreter/ImportAbstractClass/Unit1.dfm @@ -0,0 +1,83 @@ +object Form1: TForm1 + Left = 0 + Top = 0 + Caption = 'Import of Abstract Class' + ClientHeight = 284 + ClientWidth = 470 + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -10 + Font.Name = 'Tahoma' + Font.Style = [] + OldCreateOrder = False + PixelsPerInch = 96 + TextHeight = 12 + object Memo1: TMemo + Left = 6 + Top = 12 + Width = 295 + Height = 266 + Margins.Left = 2 + Margins.Top = 2 + Margins.Right = 2 + Margins.Bottom = 2 + Lines.Strings = ( + 'uses' + ' Unit1;' + '' + 'type' + ' TMyScriptClass = class(TMyHostClass)' + ' constructor Create; override;' + ' procedure P; override;' + ' end;' + '' + 'constructor TMyScriptClass.Create;' + 'begin' + ' print '#39'Script object of '#39' + ClassName + '#39' is created.'#39';' + 'end;' + '' + 'procedure TMyScriptClass.P;' + 'begin' + ' print '#39'Hello from script!'#39';' + 'end;' + '' + 'begin' + 'end.') + TabOrder = 0 + end + object Button1: TButton + Left = 378 + Top = 216 + Width = 56 + Height = 19 + Margins.Left = 2 + Margins.Top = 2 + Margins.Right = 2 + Margins.Bottom = 2 + Caption = 'Run script' + TabOrder = 1 + OnClick = Button1Click + end + object PaxCompiler1: TPaxCompiler + Alignment = 8 + OnUsedUnit = PaxCompiler1UsedUnit + DebugMode = False + Left = 400 + Top = 96 + end + object PaxPascalLanguage1: TPaxPascalLanguage + ExplicitOff = False + CompleteBooleanEval = False + UnitLookup = True + PrintKeyword = 'print' + PrintlnKeyword = 'println' + Left = 360 + Top = 144 + end + object PaxInterpreter1: TPaxInterpreter + Console = False + Left = 432 + Top = 232 + end +end diff --git a/Demos/AUTO_IMPORT_DEMOS/PaxInterpreter/ImportAbstractClass/Unit1.pas b/Demos/AUTO_IMPORT_DEMOS/PaxInterpreter/ImportAbstractClass/Unit1.pas new file mode 100644 index 0000000..65791a2 --- /dev/null +++ b/Demos/AUTO_IMPORT_DEMOS/PaxInterpreter/ImportAbstractClass/Unit1.pas @@ -0,0 +1,81 @@ +unit Unit1; + +interface + +uses + Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics, + Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, PaxRunner, PaxInterpreter, + PaxCompiler; + +type + TForm1 = class(TForm) + Memo1: TMemo; + PaxCompiler1: TPaxCompiler; + PaxPascalLanguage1: TPaxPascalLanguage; + PaxInterpreter1: TPaxInterpreter; + Button1: TButton; + procedure Button1Click(Sender: TObject); + function PaxCompiler1UsedUnit(Sender: TPaxCompiler; const UnitName: string; + var SourceCode: string): Boolean; + private + { Private declarations } + public + { Public declarations } + end; + + TMyHostClass = class + public + constructor Create; virtual; abstract; + procedure P; virtual; abstract; + end; + TMyHostClassClass = class of TMyHostClass; + +var + Form1: TForm1; + +implementation + +{$R *.dfm} + +procedure Dummy(P: Pointer); begin end; + +procedure TForm1.Button1Click(Sender: TObject); +var + C: TMyHostClassClass; + X: TMyHostClass; +begin + Dummy(TMyHostClass); // just to punish Delphi to create rtti for this class + + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + PaxCompiler1.AddModule('1', 'Pascal'); + PaxCompiler1.AddCode('1', Memo1.Lines.Text); + if PaxCompiler1.Compile(PaxInterpreter1) then + begin + PaxInterpreter1.RunInitialization; + + C := TMyHostClassClass(PaxInterpreter1.GetAddress('TMyScriptClass')^); + X := C.Create; + try + X.P; + finally + X.Free; + end; + + end + else + ShowMessage(PaxCompiler1.ErrorMessage[0]); +end; + +function TForm1.PaxCompiler1UsedUnit(Sender: TPaxCompiler; + const UnitName: string; var SourceCode: string): Boolean; +begin +// Use OnUsedUnit event to prevent loading Unit1.pas from disk. +// We are going to import types of Unit1.pas, not to compile the unit. + + Sender.RegisterImportUnit(0, UnitName); + result := true; + SourceCode := ''; +end; + +end. diff --git a/Demos/AUTO_IMPORT_DEMOS/PaxInterpreter/LoadCompiledScript/Project1.dpr b/Demos/AUTO_IMPORT_DEMOS/PaxInterpreter/LoadCompiledScript/Project1.dpr new file mode 100644 index 0000000..65fafb5 --- /dev/null +++ b/Demos/AUTO_IMPORT_DEMOS/PaxInterpreter/LoadCompiledScript/Project1.dpr @@ -0,0 +1,90 @@ +{$APPTYPE CONSOLE} +program Project1; +uses + System.Classes, System.Rtti, System.TypInfo, + SysUtils, Vcl.StdCtrls, + Vcl.Dialogs, u1, u2, + PaxCompiler, PaxInterpreter, PaxRegister; + +type + THandler = class + function DoOnUsedUnit(Sender: TPaxCompiler; const UnitName: String; + var SourceCode: String): Boolean; + procedure DoOnImportUnit(Sender: TPaxCompiler; + UnitId: Integer; + const AUnitName: String); + end; + +function THandler.DoOnUsedUnit(Sender: TPaxCompiler; const UnitName: String; + var SourceCode: String): Boolean; +begin + Sender.RegisterImportUnit(0, UnitName); + result := true; + SourceCode := ''; +end; + +procedure THandler.DoOnImportUnit(Sender: TPaxCompiler; + UnitId: Integer; + const AUnitName: String); +begin + writeln('Imported unit: ', AUnitName); + writeln; + writeln; + if CompareText('Vcl.Dialogs', AUnitName) = 0 then + begin + Sender.RegisterHeader(UnitId, + 'procedure ShowMessage(const S: String);', + @ Vcl.Dialogs.ShowMessage); + end; +end; + +procedure Dummy(P: Pointer); begin end; + +var + PaxCompiler1: TPaxCompiler; + PaxInterpreter1: TPaxInterpreter; + PaxPascalLanguage1: TPaxPascalLanguage; + Handler: THandler; + I: Integer; +begin + Dummy(TMyClass); + + Handler := THandler.Create; + PaxCompiler1 := TPaxCompiler.Create(nil); + PaxInterpreter1 := TPaxInterpreter.Create(nil); + PaxPascalLanguage1 := TPaxPascalLanguage.Create(nil); + try + PaxCompiler1.OnUsedUnit := Handler.DoOnUsedUnit; + PaxCompiler1.OnImportUnit := Handler.DoOnImportUnit; + + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + PaxCompiler1.AddModule('1', 'Pascal'); + PaxCompiler1.AddCodeFromFile('1', 'script3.txt'); + if PaxCompiler1.Compile(PaxInterpreter1) then + begin + PaxInterpreter1.SaveToFile('1.bin'); + PaxInterpreter1.Run; + end + else + begin + writeln(PaxCompiler1.ErrorMessage[0]); + writeln(PaxCompiler1.ErrorLineNumber[0]); + writeln(PaxCompiler1.ErrorLine[0]); + end; + + for I:=0 to PaxCompiler1.WarningCount - 1 do + begin + writeln(PaxCompiler1.WarningMessage[I]); + writeln(PaxCompiler1.WarningLineNumber[I]); + writeln(PaxCompiler1.WarningLine[I]); + end; + + finally + PaxCompiler1.Free; + PaxInterpreter1.Free; + PaxPascalLanguage1.Free; + Handler.Free; + end; + writeln('Press any key...'); + Readln; +end. diff --git a/Demos/AUTO_IMPORT_DEMOS/PaxInterpreter/LoadCompiledScript/Project1.dproj b/Demos/AUTO_IMPORT_DEMOS/PaxInterpreter/LoadCompiledScript/Project1.dproj new file mode 100644 index 0000000..dbd543e --- /dev/null +++ b/Demos/AUTO_IMPORT_DEMOS/PaxInterpreter/LoadCompiledScript/Project1.dproj @@ -0,0 +1,145 @@ + + + {4A2F7471-B95A-47A4-8326-A446ADA5A20B} + Project1.dpr + True + Debug + 17 + Console + None + 15.1 + Win32 + + + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + 00400000 + System;Xml;Data;Datasnap;Web;Soap;$(DCC_Namespace) + true + false + 1033 + false + false + false + false + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=;CFBundleName=;CFBundleDisplayName=;UIDeviceFamily=;CFBundleIdentifier=;CFBundleVersion=;CFBundlePackageType=;CFBundleSignature=;CFBundleAllowMixedLocalizations=;UISupportedInterfaceOrientations=;CFBundleExecutable=;CFBundleResourceSpecification=;LSRequiresIPhoneOS=;CFBundleInfoDictionaryVersion=;CFBundleDevelopmentRegion=;package=;label=;versionCode=;versionName=;persistent=;restoreAnyVersion=;installLocation=;largeHeap=;theme= + + + 1033 + Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments= + + + 0 + false + 0 + RELEASE;$(DCC_Define) + + + true + DEBUG;$(DCC_Define) + false + + + + MainSource + + + Cfg_2 + Base + + + Base + + + Cfg_1 + Base + + + + Delphi.Personality.12 + + + + + Project1.dpr + + + False + False + 1 + 0 + 0 + 0 + False + False + False + False + False + 1033 + 1252 + + + + + 1.0.0.0 + + + + + + 1.0.0.0 + + + + + + + + + + + + + + + + + + + + + + + + + + + + True + False + True + False + + + 12 + + + + diff --git a/Demos/AUTO_IMPORT_DEMOS/PaxInterpreter/LoadCompiledScript/Project1.res b/Demos/AUTO_IMPORT_DEMOS/PaxInterpreter/LoadCompiledScript/Project1.res new file mode 100644 index 0000000..5e952b5 Binary files /dev/null and b/Demos/AUTO_IMPORT_DEMOS/PaxInterpreter/LoadCompiledScript/Project1.res differ diff --git a/Demos/AUTO_IMPORT_DEMOS/PaxInterpreter/LoadCompiledScript/Project2.dpr b/Demos/AUTO_IMPORT_DEMOS/PaxInterpreter/LoadCompiledScript/Project2.dpr new file mode 100644 index 0000000..873b4f3 --- /dev/null +++ b/Demos/AUTO_IMPORT_DEMOS/PaxInterpreter/LoadCompiledScript/Project2.dpr @@ -0,0 +1,59 @@ +program Project2; +{$APPTYPE CONSOLE} +{$O-} +uses + System.sysutils, + System.Classes, + Vcl.StdCtrls, + Vcl.Forms, + Vcl.Dialogs, + PaxRunner, + u1, + u2, + PaxInterpreter, + PaxRegister; + +type + TMyHandler = class + public + procedure MapTableProcAddressHandler(Sender: TPaxRunner; + const FullName: String; OverCount: Byte; + Global: Boolean; var Address: Pointer); + end; + +procedure TMyHandler.MapTableProcAddressHandler(Sender: TPaxRunner; + const FullName: String; OverCount: Byte; + Global: Boolean; var Address: Pointer); +begin + if CompareText(FullName, 'Vcl.Dialogs.ShowMessage') = 0 then + Address := @ Vcl.Dialogs.ShowMessage; +end; + +var + MyHandler: TMyHandler; + +var + PaxInterpreter1: TPaxInterpreter; +begin + + try + PaxInterpreter1 := TPaxInterpreter.Create(nil); + try + PaxInterpreter1.OnMapTableProcAddress := MyHandler.MapTableProcAddressHandler; + + PaxInterpreter1.LoadFromFile('1.bin'); + PaxInterpreter1.MapGlobal; + PaxInterpreter1.MapLocal; + PaxInterpreter1.Run; + finally + PaxInterpreter1.Free; + end; + + finally + MyHandler.Free; + end; + + writeln('Press any key...'); + Readln; +end. + diff --git a/Demos/AUTO_IMPORT_DEMOS/PaxInterpreter/LoadCompiledScript/Project2.dproj b/Demos/AUTO_IMPORT_DEMOS/PaxInterpreter/LoadCompiledScript/Project2.dproj new file mode 100644 index 0000000..9d7b96f --- /dev/null +++ b/Demos/AUTO_IMPORT_DEMOS/PaxInterpreter/LoadCompiledScript/Project2.dproj @@ -0,0 +1,144 @@ + + + {B09FCA6E-BAFE-4ED6-A719-B493F8081C14} + Project2.dpr + True + Debug + 17 + Console + VCL + 15.1 + Win32 + + + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + 00400000 + Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;System;Xml;Data;Datasnap;Web;Soap;$(DCC_Namespace) + true + false + 1033 + false + false + false + false + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=;CFBundleName=;CFBundleDisplayName=;UIDeviceFamily=;CFBundleIdentifier=;CFBundleVersion=;CFBundlePackageType=;CFBundleSignature=;CFBundleAllowMixedLocalizations=;UISupportedInterfaceOrientations=;CFBundleExecutable=;CFBundleResourceSpecification=;LSRequiresIPhoneOS=;CFBundleInfoDictionaryVersion=;CFBundleDevelopmentRegion=;package=;label=;versionCode=;versionName=;persistent=;restoreAnyVersion=;installLocation=;largeHeap=;theme= + + + 1033 + Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments= + + + 0 + false + 0 + RELEASE;$(DCC_Define) + + + true + DEBUG;$(DCC_Define) + false + + + + MainSource + + + Cfg_2 + Base + + + Base + + + Cfg_1 + Base + + + + Delphi.Personality.12 + + + + + Project2.dpr + + + False + False + 1 + 0 + 0 + 0 + False + False + False + False + False + 1033 + 1252 + + + + + 1.0.0.0 + + + + + + 1.0.0.0 + + + + + + + + + + + + + + + + + + + + + + + + + + + + True + True + False + + + 12 + + + + diff --git a/Demos/AUTO_IMPORT_DEMOS/PaxInterpreter/LoadCompiledScript/Project2.res b/Demos/AUTO_IMPORT_DEMOS/PaxInterpreter/LoadCompiledScript/Project2.res new file mode 100644 index 0000000..5e952b5 Binary files /dev/null and b/Demos/AUTO_IMPORT_DEMOS/PaxInterpreter/LoadCompiledScript/Project2.res differ diff --git a/Demos/AUTO_IMPORT_DEMOS/PaxInterpreter/LoadCompiledScript/script.txt b/Demos/AUTO_IMPORT_DEMOS/PaxInterpreter/LoadCompiledScript/script.txt new file mode 100644 index 0000000..8358876 --- /dev/null +++ b/Demos/AUTO_IMPORT_DEMOS/PaxInterpreter/LoadCompiledScript/script.txt @@ -0,0 +1,10 @@ +uses u1, u2; +var + X: TMyClass; + I: IMyInterface; +begin + X := TMyClass.Create; + I := X; + I.P(3, 4); + I.P; +end. \ No newline at end of file diff --git a/Demos/AUTO_IMPORT_DEMOS/PaxInterpreter/LoadCompiledScript/script2.txt b/Demos/AUTO_IMPORT_DEMOS/PaxInterpreter/LoadCompiledScript/script2.txt new file mode 100644 index 0000000..05c9189 --- /dev/null +++ b/Demos/AUTO_IMPORT_DEMOS/PaxInterpreter/LoadCompiledScript/script2.txt @@ -0,0 +1,21 @@ +uses System.Classes; +var + L: TStringList; + S: String; + P: Pointer; +begin + L := TStringList.Create; + L.Add('abc'); + println L.Count; + s := L[0]; + println s; + L[0] := 'pqr'; + println L[0]; + L.Objects[0] := TObject(1); + P := L.Objects[0]; + println Integer(P); + + + L.Clear; + println L.Count; +end. \ No newline at end of file diff --git a/Demos/AUTO_IMPORT_DEMOS/PaxInterpreter/LoadCompiledScript/script3.txt b/Demos/AUTO_IMPORT_DEMOS/PaxInterpreter/LoadCompiledScript/script3.txt new file mode 100644 index 0000000..ffd9986 --- /dev/null +++ b/Demos/AUTO_IMPORT_DEMOS/PaxInterpreter/LoadCompiledScript/script3.txt @@ -0,0 +1,45 @@ +uses + Vcl.Controls, Vcl.StdCtrls, Vcl.Forms, Vcl.Dialogs; +type + TMyForm = class(TForm) + Button1: TButton; + private + procedure Button1Click(Sender: TObject); + public + constructor Create; + end; + +constructor TMyForm.Create; +begin + inherited Create(nil); + + Caption := 'My second paxCompiler GUI Application'; + + Button1 := TButton.Create(Self); + + with Button1 do + begin + Parent := Self; + Caption := 'Click Me'; + Name := 'Button1'; + Left := 10; + Top := 20; + OnClick := Button1Click; + end; +end; + +procedure TMyForm.Button1Click(Sender: TObject); +begin + ShowMessage('Hello!'); +end; + +var + F: TMyForm; +begin + F := TMyForm.Create; + try + F.ShowModal; + finally + F.Free; + end; +end. diff --git a/Demos/AUTO_IMPORT_DEMOS/PaxInterpreter/LoadCompiledScript/u1.pas b/Demos/AUTO_IMPORT_DEMOS/PaxInterpreter/LoadCompiledScript/u1.pas new file mode 100644 index 0000000..a88d38e --- /dev/null +++ b/Demos/AUTO_IMPORT_DEMOS/PaxInterpreter/LoadCompiledScript/u1.pas @@ -0,0 +1,42 @@ +{$O-} +unit u1; +interface +uses + u2; +type + TMyClass = class(TInterfacedObject, IMyInterface) + public + constructor Create; + destructor Destroy; override; + procedure Q; virtual; abstract; + procedure P; overload; virtual; + procedure P(X, Y: Integer); overload; + end; + +implementation + +constructor TMyClass.Create; +begin + writeln('TMyClass object is created.'); +end; + +destructor TMyClass.Destroy; +begin + writeln('TMyClass object is destroyed.'); +end; + +procedure TMyClass.P; +begin + writeln('P1'); +end; + +procedure TMyClass.P(X, Y: Integer); +begin + writeln('P2'); +end; + +procedure Dummy(P: Pointer); begin end; +initialization + Dummy(TMyClass); + +end. \ No newline at end of file diff --git a/Demos/AUTO_IMPORT_DEMOS/PaxInterpreter/LoadCompiledScript/u2.pas b/Demos/AUTO_IMPORT_DEMOS/PaxInterpreter/LoadCompiledScript/u2.pas new file mode 100644 index 0000000..f9eaa23 --- /dev/null +++ b/Demos/AUTO_IMPORT_DEMOS/PaxInterpreter/LoadCompiledScript/u2.pas @@ -0,0 +1,12 @@ +unit u2; +interface +type + {$M+} + IMyInterface = interface + ['{F9A8D720-A96E-4F2D-BB60-72A9AD2DAAF3}'] + procedure P; overload; + procedure P(X, Y: Integer); overload; + end; + +implementation +end. \ No newline at end of file diff --git a/Demos/AUTO_IMPORT_DEMOS/PaxInterpreter/OperatorOverloading/Project1.dpr b/Demos/AUTO_IMPORT_DEMOS/PaxInterpreter/OperatorOverloading/Project1.dpr new file mode 100644 index 0000000..fb91550 --- /dev/null +++ b/Demos/AUTO_IMPORT_DEMOS/PaxInterpreter/OperatorOverloading/Project1.dpr @@ -0,0 +1,14 @@ +program Project1; + +uses + Vcl.Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.MainFormOnTaskbar := True; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Demos/AUTO_IMPORT_DEMOS/PaxInterpreter/OperatorOverloading/Project1.dproj b/Demos/AUTO_IMPORT_DEMOS/PaxInterpreter/OperatorOverloading/Project1.dproj new file mode 100644 index 0000000..bef4be1 --- /dev/null +++ b/Demos/AUTO_IMPORT_DEMOS/PaxInterpreter/OperatorOverloading/Project1.dproj @@ -0,0 +1,129 @@ + + + {5F8730A9-23EA-46A1-9D26-8F3AA13E1012} + Project1.dpr + True + Debug + 1025 + Application + VCL + 18.1 + Win32 + + + true + + + true + Base + true + + + true + Base + true + + + true + Cfg_1 + true + true + + + true + Base + true + + + true + Cfg_2 + true + true + + + true + Cfg_2 + true + true + + + false + Project1 + 2052 + false + false + false + false + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=;CFBundleName= + 00400000 + Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;System;Xml;Data;Datasnap;Web;Soap;$(DCC_Namespace) + + + 1033 + true + true + $(BDS)\bin\default_app.manifest + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments= + Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) + + + RELEASE;$(DCC_Define) + false + 0 + 0 + + + true + true + + + true + DEBUG;$(DCC_Define) + false + + + Debug + + + true + true + + + + MainSource + + +
Form1
+ + + Cfg_2 + Base + + + Base + + + Cfg_1 + Base + + + + Delphi.Personality.12 + + + + + Project1.dpr + + + + True + True + False + + + 12 + + + + diff --git a/Demos/AUTO_IMPORT_DEMOS/PaxInterpreter/OperatorOverloading/Project1.res b/Demos/AUTO_IMPORT_DEMOS/PaxInterpreter/OperatorOverloading/Project1.res new file mode 100644 index 0000000..f057a95 Binary files /dev/null and b/Demos/AUTO_IMPORT_DEMOS/PaxInterpreter/OperatorOverloading/Project1.res differ diff --git a/Demos/AUTO_IMPORT_DEMOS/PaxInterpreter/OperatorOverloading/Unit1.dfm b/Demos/AUTO_IMPORT_DEMOS/PaxInterpreter/OperatorOverloading/Unit1.dfm new file mode 100644 index 0000000..ce147b5 --- /dev/null +++ b/Demos/AUTO_IMPORT_DEMOS/PaxInterpreter/OperatorOverloading/Unit1.dfm @@ -0,0 +1,87 @@ +object Form1: TForm1 + Left = 0 + Top = 0 + Caption = 'Operator Overloading' + ClientHeight = 303 + ClientWidth = 453 + Color = clBtnFace + Font.Charset = ANSI_CHARSET + Font.Color = clWindowText + Font.Height = -12 + Font.Name = #24494#36719#38597#40657 + Font.Style = [] + OldCreateOrder = False + DesignSize = ( + 453 + 303) + PixelsPerInch = 120 + TextHeight = 17 + object Memo1: TMemo + Left = 0 + Top = 0 + Width = 359 + Height = 303 + Margins.Left = 2 + Margins.Top = 2 + Margins.Right = 2 + Margins.Bottom = 2 + Align = alLeft + Anchors = [akLeft, akTop, akRight, akBottom] + Lines.Strings = ( + 'uses' + ' Unit1;' + 'var' + ' U, V: TMyRecord;' + ' I: Integer;' + 'begin' + ' V := TMyRecord(4); // explicit type cast' + ' U := 3; // implicit type cast' + ' V.x := 1;' + ' V.y := 2;' + ' U := U + V; // operation of addition' + ' print U.X;' + ' print U.Y;' + ' I := V;' + ' print I;' + 'end.') + TabOrder = 0 + ExplicitLeft = 6 + ExplicitTop = 6 + ExplicitHeight = 289 + end + object Button1: TButton + Left = 370 + Top = 275 + Width = 76 + Height = 20 + Margins.Left = 2 + Margins.Top = 2 + Margins.Right = 2 + Margins.Bottom = 2 + Anchors = [akRight, akBottom] + Caption = 'Run script' + TabOrder = 1 + OnClick = Button1Click + end + object PaxCompiler1: TPaxCompiler + Alignment = 8 + OnUsedUnit = PaxCompiler1UsedUnit + DebugMode = False + Left = 616 + Top = 80 + end + object PaxPascalLanguage1: TPaxPascalLanguage + ExplicitOff = False + CompleteBooleanEval = False + UnitLookup = True + PrintKeyword = 'print' + PrintlnKeyword = 'println' + Left = 616 + Top = 152 + end + object PaxInterpreter1: TPaxInterpreter + Console = False + Left = 608 + Top = 240 + end +end diff --git a/Demos/AUTO_IMPORT_DEMOS/PaxInterpreter/OperatorOverloading/Unit1.pas b/Demos/AUTO_IMPORT_DEMOS/PaxInterpreter/OperatorOverloading/Unit1.pas new file mode 100644 index 0000000..43415c5 --- /dev/null +++ b/Demos/AUTO_IMPORT_DEMOS/PaxInterpreter/OperatorOverloading/Unit1.pas @@ -0,0 +1,101 @@ +unit Unit1; + +interface + +uses + Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics, + Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, PaxRunner, PaxInterpreter, + PaxCompiler; + +type + TForm1 = class(TForm) + Memo1: TMemo; + Button1: TButton; + PaxCompiler1: TPaxCompiler; + PaxPascalLanguage1: TPaxPascalLanguage; + PaxInterpreter1: TPaxInterpreter; + procedure Button1Click(Sender: TObject); + function PaxCompiler1UsedUnit(Sender: TPaxCompiler; const UnitName: string; + var SourceCode: string): Boolean; + private + { Private declarations } + public + { Public declarations } + end; + +type + TMyRecord = record + x, y: Integer; + class operator Add(a, b: TMyRecord): TMyRecord; + class operator Subtract(a, b: TMyRecord): TMyRecord; + class operator Implicit(a: Integer): TMyRecord; + class operator Implicit(a: TMyRecord): Integer; + class operator Explicit(a: Integer): TMyRecord; + end; + +var + Form1: TForm1; + +implementation + +{$R *.dfm} + +class operator TMyRecord.Add(a, b: TMyRecord): TMyRecord; +begin + result.x := a.x + b.x; + result.y := a.y + b.y; +end; + +class operator TMyRecord.Subtract(a, b: TMyRecord): TMyRecord; +begin + result.x := a.x - b.x; + result.y := a.y - b.y; +end; + +class operator TMyRecord.Implicit(a: Integer): TMyRecord; +begin + result.x := a; + result.y := 0; +end; + +class operator TMyRecord.Implicit(a: TMyRecord): Integer; +begin + result := a.x; +end; + +class operator TMyRecord.Explicit(a: Integer): TMyRecord; +begin + result.x := a; + result.y := 0; +end; + +procedure Dummy(P: Pointer); begin end; + +procedure TForm1.Button1Click(Sender: TObject); +begin + Dummy(TypeInfo(TMyRecord)); // just to punish Delphi to create RTTI for TMyRecord + + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + PaxCompiler1.AddModule('1', 'Pascal'); + PaxCompiler1.AddCode('1', Memo1.Lines.Text); + if PaxCompiler1.Compile(PaxInterpreter1) then + begin + PaxInterpreter1.Run; + end + else + ShowMessage(PaxCompiler1.ErrorMessage[0]); +end; + +function TForm1.PaxCompiler1UsedUnit(Sender: TPaxCompiler; + const UnitName: string; var SourceCode: string): Boolean; +begin +// Use OnUsedUnit event to prevent loading Unit1.pas from disk. +// We are going to import types of Unit1.pas, not to compile the unit. + + Sender.RegisterImportUnit(0, UnitName); + result := true; + SourceCode := ''; +end; + +end. diff --git a/Demos/AUTO_IMPORT_DEMOS/PaxProgram/Hello/Project1.dpr b/Demos/AUTO_IMPORT_DEMOS/PaxProgram/Hello/Project1.dpr new file mode 100644 index 0000000..fb91550 --- /dev/null +++ b/Demos/AUTO_IMPORT_DEMOS/PaxProgram/Hello/Project1.dpr @@ -0,0 +1,14 @@ +program Project1; + +uses + Vcl.Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.MainFormOnTaskbar := True; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Demos/AUTO_IMPORT_DEMOS/PaxProgram/Hello/Project1.res b/Demos/AUTO_IMPORT_DEMOS/PaxProgram/Hello/Project1.res new file mode 100644 index 0000000..9ae8631 Binary files /dev/null and b/Demos/AUTO_IMPORT_DEMOS/PaxProgram/Hello/Project1.res differ diff --git a/Demos/AUTO_IMPORT_DEMOS/PaxProgram/Hello/Unit1.dfm b/Demos/AUTO_IMPORT_DEMOS/PaxProgram/Hello/Unit1.dfm new file mode 100644 index 0000000..964273e --- /dev/null +++ b/Demos/AUTO_IMPORT_DEMOS/PaxProgram/Hello/Unit1.dfm @@ -0,0 +1,60 @@ +object Form1: TForm1 + Left = 0 + Top = 0 + Caption = 'Hello' + ClientHeight = 272 + ClientWidth = 563 + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -13 + Font.Name = 'Tahoma' + Font.Style = [] + OldCreateOrder = False + PixelsPerInch = 120 + TextHeight = 16 + object Memo1: TMemo + Left = 16 + Top = 16 + Width = 305 + Height = 233 + Lines.Strings = ( + 'uses' + ' Unit1;' + 'begin' + ' Form1.Button1.Caption := '#39'Hello'#39';' + 'end.') + TabOrder = 0 + end + object Button1: TButton + Left = 440 + Top = 216 + Width = 75 + Height = 25 + Caption = 'Run script' + TabOrder = 1 + OnClick = Button1Click + end + object PaxCompiler1: TPaxCompiler + Alignment = 8 + OnUsedUnit = PaxCompiler1UsedUnit + OnImportUnit = PaxCompiler1ImportUnit + DebugMode = False + Left = 424 + Top = 72 + end + object PaxPascalLanguage1: TPaxPascalLanguage + ExplicitOff = False + CompleteBooleanEval = False + UnitLookup = True + PrintKeyword = 'print' + PrintlnKeyword = 'println' + Left = 376 + Top = 128 + end + object PaxProgram1: TPaxProgram + Console = False + Left = 472 + Top = 128 + end +end diff --git a/Demos/AUTO_IMPORT_DEMOS/PaxProgram/Hello/Unit1.pas b/Demos/AUTO_IMPORT_DEMOS/PaxProgram/Hello/Unit1.pas new file mode 100644 index 0000000..14576e5 --- /dev/null +++ b/Demos/AUTO_IMPORT_DEMOS/PaxProgram/Hello/Unit1.pas @@ -0,0 +1,68 @@ +unit Unit1; + +interface + +uses + Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics, + Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, PaxRunner, PaxProgram, + PaxCompiler; + +type + TForm1 = class(TForm) + Memo1: TMemo; + Button1: TButton; + PaxCompiler1: TPaxCompiler; + PaxPascalLanguage1: TPaxPascalLanguage; + PaxProgram1: TPaxProgram; + procedure PaxCompiler1ImportUnit(Sender: TPaxCompiler; Id: Integer; + const AFullName: string); + procedure Button1Click(Sender: TObject); + function PaxCompiler1UsedUnit(Sender: TPaxCompiler; const UnitName: string; + var SourceCode: string): Boolean; + private + { Private declarations } + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.dfm} + +procedure TForm1.Button1Click(Sender: TObject); +begin + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + PaxCompiler1.AddModule('1', 'Pascal'); + PaxCompiler1.AddCode('1', Memo1.Lines.Text); + if PaxCompiler1.Compile(PaxProgram1) then + begin + PaxProgram1.Run; + end + else + ShowMessage(PaxCompiler1.ErrorMessage[0]); +end; + +procedure TForm1.PaxCompiler1ImportUnit(Sender: TPaxCompiler; Id: Integer; + const AFullName: string); +begin +// Global members must be imported explicitly. + + Sender.RegisterVariable(Id, 'Form1: TForm1', @Form1); +end; + +function TForm1.PaxCompiler1UsedUnit(Sender: TPaxCompiler; + const UnitName: string; var SourceCode: string): Boolean; +begin +// Use OnUsedUnit event to prevent loading Unit1.pas from disk. +// We are going to import types of Unit1.pas, not to compile the unit. + + Sender.RegisterImportUnit(0, UnitName); + result := true; + SourceCode := ''; +end; + +end. diff --git a/Demos/AUTO_IMPORT_DEMOS/PaxProgram/ImportAbstractClass/Project1.dpr b/Demos/AUTO_IMPORT_DEMOS/PaxProgram/ImportAbstractClass/Project1.dpr new file mode 100644 index 0000000..fb91550 --- /dev/null +++ b/Demos/AUTO_IMPORT_DEMOS/PaxProgram/ImportAbstractClass/Project1.dpr @@ -0,0 +1,14 @@ +program Project1; + +uses + Vcl.Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.MainFormOnTaskbar := True; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Demos/AUTO_IMPORT_DEMOS/PaxProgram/ImportAbstractClass/Project1.res b/Demos/AUTO_IMPORT_DEMOS/PaxProgram/ImportAbstractClass/Project1.res new file mode 100644 index 0000000..9ae8631 Binary files /dev/null and b/Demos/AUTO_IMPORT_DEMOS/PaxProgram/ImportAbstractClass/Project1.res differ diff --git a/Demos/AUTO_IMPORT_DEMOS/PaxProgram/ImportAbstractClass/Unit1.dfm b/Demos/AUTO_IMPORT_DEMOS/PaxProgram/ImportAbstractClass/Unit1.dfm new file mode 100644 index 0000000..3d8841f --- /dev/null +++ b/Demos/AUTO_IMPORT_DEMOS/PaxProgram/ImportAbstractClass/Unit1.dfm @@ -0,0 +1,75 @@ +object Form1: TForm1 + Left = 0 + Top = 0 + Caption = 'Import of Abstract Class' + ClientHeight = 379 + ClientWidth = 627 + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -13 + Font.Name = 'Tahoma' + Font.Style = [] + OldCreateOrder = False + PixelsPerInch = 120 + TextHeight = 16 + object Memo1: TMemo + Left = 8 + Top = 16 + Width = 393 + Height = 355 + Lines.Strings = ( + 'uses' + ' Unit1;' + '' + 'type' + ' TMyScriptClass = class(TMyHostClass)' + ' constructor Create; override;' + ' procedure P; override;' + ' end;' + '' + 'constructor TMyScriptClass.Create;' + 'begin' + ' print '#39'Script object of '#39' + ClassName + '#39' is created.'#39';' + 'end;' + '' + 'procedure TMyScriptClass.P;' + 'begin' + ' print '#39'Hello from script!'#39';' + 'end;' + '' + 'begin' + 'end.') + TabOrder = 0 + end + object Button1: TButton + Left = 504 + Top = 288 + Width = 75 + Height = 25 + Caption = 'Run script' + TabOrder = 1 + OnClick = Button1Click + end + object PaxCompiler1: TPaxCompiler + Alignment = 8 + OnUsedUnit = PaxCompiler1UsedUnit + DebugMode = False + Left = 448 + Top = 96 + end + object PaxPascalLanguage1: TPaxPascalLanguage + ExplicitOff = False + CompleteBooleanEval = False + UnitLookup = True + PrintKeyword = 'print' + PrintlnKeyword = 'println' + Left = 440 + Top = 168 + end + object PaxProgram1: TPaxProgram + Console = False + Left = 448 + Top = 248 + end +end diff --git a/Demos/AUTO_IMPORT_DEMOS/PaxProgram/ImportAbstractClass/Unit1.pas b/Demos/AUTO_IMPORT_DEMOS/PaxProgram/ImportAbstractClass/Unit1.pas new file mode 100644 index 0000000..3beed55 --- /dev/null +++ b/Demos/AUTO_IMPORT_DEMOS/PaxProgram/ImportAbstractClass/Unit1.pas @@ -0,0 +1,81 @@ +unit Unit1; + +interface + +uses + Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics, + Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, PaxRunner, PaxProgram, + PaxCompiler; + +type + TForm1 = class(TForm) + Memo1: TMemo; + PaxCompiler1: TPaxCompiler; + PaxPascalLanguage1: TPaxPascalLanguage; + Button1: TButton; + PaxProgram1: TPaxProgram; + procedure Button1Click(Sender: TObject); + function PaxCompiler1UsedUnit(Sender: TPaxCompiler; const UnitName: string; + var SourceCode: string): Boolean; + private + { Private declarations } + public + { Public declarations } + end; + + TMyHostClass = class + public + constructor Create; virtual; abstract; + procedure P; virtual; abstract; + end; + TMyHostClassClass = class of TMyHostClass; + +var + Form1: TForm1; + +implementation + +{$R *.dfm} + +procedure Dummy(P: Pointer); begin end; + +procedure TForm1.Button1Click(Sender: TObject); +var + C: TMyHostClassClass; + X: TMyHostClass; +begin + Dummy(TMyHostClass); // just to punish Delphi to create rtti for this class + + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + PaxCompiler1.AddModule('1', 'Pascal'); + PaxCompiler1.AddCode('1', Memo1.Lines.Text); + if PaxCompiler1.Compile(PaxProgram1) then + begin + PaxProgram1.RunInitialization; + + C := TMyHostClassClass(PaxProgram1.GetAddress('TMyScriptClass')^); + X := C.Create; + try + X.P; + finally + X.Free; + end; + + end + else + ShowMessage(PaxCompiler1.ErrorMessage[0]); +end; + +function TForm1.PaxCompiler1UsedUnit(Sender: TPaxCompiler; + const UnitName: string; var SourceCode: string): Boolean; +begin +// Use OnUsedUnit event to prevent loading Unit1.pas from disk. +// We are going to import types of Unit1.pas, not to compile the unit. + + Sender.RegisterImportUnit(0, UnitName); + result := true; + SourceCode := ''; +end; + +end. diff --git a/Demos/AUTO_IMPORT_DEMOS/PaxProgram/LoadCompiledScript/1.bin b/Demos/AUTO_IMPORT_DEMOS/PaxProgram/LoadCompiledScript/1.bin new file mode 100644 index 0000000..d71c4d1 Binary files /dev/null and b/Demos/AUTO_IMPORT_DEMOS/PaxProgram/LoadCompiledScript/1.bin differ diff --git a/Demos/AUTO_IMPORT_DEMOS/PaxProgram/LoadCompiledScript/Project1.dpr b/Demos/AUTO_IMPORT_DEMOS/PaxProgram/LoadCompiledScript/Project1.dpr new file mode 100644 index 0000000..a5b1726 --- /dev/null +++ b/Demos/AUTO_IMPORT_DEMOS/PaxProgram/LoadCompiledScript/Project1.dpr @@ -0,0 +1,90 @@ +{$APPTYPE CONSOLE} +program Project1; +uses + System.Classes, System.Rtti, System.TypInfo, + SysUtils, Vcl.StdCtrls, + Vcl.Dialogs, u1, u2, + PaxCompiler, PaxProgram, PaxRegister; + +type + THandler = class + function DoOnUsedUnit(Sender: TPaxCompiler; const UnitName: String; + var SourceCode: String): Boolean; + procedure DoOnImportUnit(Sender: TPaxCompiler; + UnitId: Integer; + const AUnitName: String); + end; + +function THandler.DoOnUsedUnit(Sender: TPaxCompiler; const UnitName: String; + var SourceCode: String): Boolean; +begin + Sender.RegisterImportUnit(0, UnitName); + result := true; + SourceCode := ''; +end; + +procedure THandler.DoOnImportUnit(Sender: TPaxCompiler; + UnitId: Integer; + const AUnitName: String); +begin + writeln('Imported unit: ', AUnitName); + writeln; + writeln; + if CompareText('Vcl.Dialogs', AUnitName) = 0 then + begin + Sender.RegisterHeader(UnitId, + 'procedure ShowMessage(const S: String);', + @ Vcl.Dialogs.ShowMessage); + end; +end; + +procedure Dummy(P: Pointer); begin end; + +var + PaxCompiler1: TPaxCompiler; + PaxProgram1: TPaxProgram; + PaxPascalLanguage1: TPaxPascalLanguage; + Handler: THandler; + I: Integer; +begin + Dummy(TMyClass); + + Handler := THandler.Create; + PaxCompiler1 := TPaxCompiler.Create(nil); + PaxProgram1 := TPaxProgram.Create(nil); + PaxPascalLanguage1 := TPaxPascalLanguage.Create(nil); + try + PaxCompiler1.OnUsedUnit := Handler.DoOnUsedUnit; + PaxCompiler1.OnImportUnit := Handler.DoOnImportUnit; + + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + PaxCompiler1.AddModule('1', 'Pascal'); + PaxCompiler1.AddCodeFromFile('1', 'script3.txt'); + if PaxCompiler1.Compile(PaxProgram1) then + begin + PaxProgram1.SaveToFile('1.bin'); + PaxProgram1.Run; + end + else + begin + writeln(PaxCompiler1.ErrorMessage[0]); + writeln(PaxCompiler1.ErrorLineNumber[0]); + writeln(PaxCompiler1.ErrorLine[0]); + end; + + for I:=0 to PaxCompiler1.WarningCount - 1 do + begin + writeln(PaxCompiler1.WarningMessage[I]); + writeln(PaxCompiler1.WarningLineNumber[I]); + writeln(PaxCompiler1.WarningLine[I]); + end; + + finally + PaxCompiler1.Free; + PaxProgram1.Free; + PaxPascalLanguage1.Free; + Handler.Free; + end; + writeln('Press any key...'); + Readln; +end. diff --git a/Demos/AUTO_IMPORT_DEMOS/PaxProgram/LoadCompiledScript/Project1.res b/Demos/AUTO_IMPORT_DEMOS/PaxProgram/LoadCompiledScript/Project1.res new file mode 100644 index 0000000..5e952b5 Binary files /dev/null and b/Demos/AUTO_IMPORT_DEMOS/PaxProgram/LoadCompiledScript/Project1.res differ diff --git a/Demos/AUTO_IMPORT_DEMOS/PaxProgram/LoadCompiledScript/Project2.dpr b/Demos/AUTO_IMPORT_DEMOS/PaxProgram/LoadCompiledScript/Project2.dpr new file mode 100644 index 0000000..6183274 --- /dev/null +++ b/Demos/AUTO_IMPORT_DEMOS/PaxProgram/LoadCompiledScript/Project2.dpr @@ -0,0 +1,59 @@ +program Project2; +{$APPTYPE CONSOLE} +{$O-} +uses + System.sysutils, + System.Classes, + Vcl.StdCtrls, + Vcl.Forms, + Vcl.Dialogs, + PaxRunner, + u1, + u2, + PaxProgram, + PaxRegister; + +type + TMyHandler = class + public + procedure MapTableProcAddressHandler(Sender: TPaxRunner; + const FullName: String; OverCount: Byte; + Global: Boolean; var Address: Pointer); + end; + +procedure TMyHandler.MapTableProcAddressHandler(Sender: TPaxRunner; + const FullName: String; OverCount: Byte; + Global: Boolean; var Address: Pointer); +begin + if CompareText(FullName, 'Vcl.Dialogs.ShowMessage') = 0 then + Address := @ Vcl.Dialogs.ShowMessage; +end; + +var + MyHandler: TMyHandler; + +var + PaxProgram1: TPaxProgram; +begin + + try + PaxProgram1 := TPaxProgram.Create(nil); + try + PaxProgram1.OnMapTableProcAddress := MyHandler.MapTableProcAddressHandler; + + PaxProgram1.LoadFromFile('1.bin'); + PaxProgram1.MapGlobal; + PaxProgram1.MapLocal; + PaxProgram1.Run; + finally + PaxProgram1.Free; + end; + + finally + MyHandler.Free; + end; + + writeln('Press any key...'); + Readln; +end. + diff --git a/Demos/AUTO_IMPORT_DEMOS/PaxProgram/LoadCompiledScript/Project2.res b/Demos/AUTO_IMPORT_DEMOS/PaxProgram/LoadCompiledScript/Project2.res new file mode 100644 index 0000000..5e952b5 Binary files /dev/null and b/Demos/AUTO_IMPORT_DEMOS/PaxProgram/LoadCompiledScript/Project2.res differ diff --git a/Demos/AUTO_IMPORT_DEMOS/PaxProgram/LoadCompiledScript/script.txt b/Demos/AUTO_IMPORT_DEMOS/PaxProgram/LoadCompiledScript/script.txt new file mode 100644 index 0000000..8358876 --- /dev/null +++ b/Demos/AUTO_IMPORT_DEMOS/PaxProgram/LoadCompiledScript/script.txt @@ -0,0 +1,10 @@ +uses u1, u2; +var + X: TMyClass; + I: IMyInterface; +begin + X := TMyClass.Create; + I := X; + I.P(3, 4); + I.P; +end. \ No newline at end of file diff --git a/Demos/AUTO_IMPORT_DEMOS/PaxProgram/LoadCompiledScript/script2.txt b/Demos/AUTO_IMPORT_DEMOS/PaxProgram/LoadCompiledScript/script2.txt new file mode 100644 index 0000000..05c9189 --- /dev/null +++ b/Demos/AUTO_IMPORT_DEMOS/PaxProgram/LoadCompiledScript/script2.txt @@ -0,0 +1,21 @@ +uses System.Classes; +var + L: TStringList; + S: String; + P: Pointer; +begin + L := TStringList.Create; + L.Add('abc'); + println L.Count; + s := L[0]; + println s; + L[0] := 'pqr'; + println L[0]; + L.Objects[0] := TObject(1); + P := L.Objects[0]; + println Integer(P); + + + L.Clear; + println L.Count; +end. \ No newline at end of file diff --git a/Demos/AUTO_IMPORT_DEMOS/PaxProgram/LoadCompiledScript/script3.txt b/Demos/AUTO_IMPORT_DEMOS/PaxProgram/LoadCompiledScript/script3.txt new file mode 100644 index 0000000..ffd9986 --- /dev/null +++ b/Demos/AUTO_IMPORT_DEMOS/PaxProgram/LoadCompiledScript/script3.txt @@ -0,0 +1,45 @@ +uses + Vcl.Controls, Vcl.StdCtrls, Vcl.Forms, Vcl.Dialogs; +type + TMyForm = class(TForm) + Button1: TButton; + private + procedure Button1Click(Sender: TObject); + public + constructor Create; + end; + +constructor TMyForm.Create; +begin + inherited Create(nil); + + Caption := 'My second paxCompiler GUI Application'; + + Button1 := TButton.Create(Self); + + with Button1 do + begin + Parent := Self; + Caption := 'Click Me'; + Name := 'Button1'; + Left := 10; + Top := 20; + OnClick := Button1Click; + end; +end; + +procedure TMyForm.Button1Click(Sender: TObject); +begin + ShowMessage('Hello!'); +end; + +var + F: TMyForm; +begin + F := TMyForm.Create; + try + F.ShowModal; + finally + F.Free; + end; +end. diff --git a/Demos/AUTO_IMPORT_DEMOS/PaxProgram/LoadCompiledScript/u1.pas b/Demos/AUTO_IMPORT_DEMOS/PaxProgram/LoadCompiledScript/u1.pas new file mode 100644 index 0000000..a88d38e --- /dev/null +++ b/Demos/AUTO_IMPORT_DEMOS/PaxProgram/LoadCompiledScript/u1.pas @@ -0,0 +1,42 @@ +{$O-} +unit u1; +interface +uses + u2; +type + TMyClass = class(TInterfacedObject, IMyInterface) + public + constructor Create; + destructor Destroy; override; + procedure Q; virtual; abstract; + procedure P; overload; virtual; + procedure P(X, Y: Integer); overload; + end; + +implementation + +constructor TMyClass.Create; +begin + writeln('TMyClass object is created.'); +end; + +destructor TMyClass.Destroy; +begin + writeln('TMyClass object is destroyed.'); +end; + +procedure TMyClass.P; +begin + writeln('P1'); +end; + +procedure TMyClass.P(X, Y: Integer); +begin + writeln('P2'); +end; + +procedure Dummy(P: Pointer); begin end; +initialization + Dummy(TMyClass); + +end. \ No newline at end of file diff --git a/Demos/AUTO_IMPORT_DEMOS/PaxProgram/LoadCompiledScript/u2.pas b/Demos/AUTO_IMPORT_DEMOS/PaxProgram/LoadCompiledScript/u2.pas new file mode 100644 index 0000000..f9eaa23 --- /dev/null +++ b/Demos/AUTO_IMPORT_DEMOS/PaxProgram/LoadCompiledScript/u2.pas @@ -0,0 +1,12 @@ +unit u2; +interface +type + {$M+} + IMyInterface = interface + ['{F9A8D720-A96E-4F2D-BB60-72A9AD2DAAF3}'] + procedure P; overload; + procedure P(X, Y: Integer); overload; + end; + +implementation +end. \ No newline at end of file diff --git a/Demos/AUTO_IMPORT_DEMOS/PaxProgram/OperatorOverloading/Project1.dpr b/Demos/AUTO_IMPORT_DEMOS/PaxProgram/OperatorOverloading/Project1.dpr new file mode 100644 index 0000000..fb91550 --- /dev/null +++ b/Demos/AUTO_IMPORT_DEMOS/PaxProgram/OperatorOverloading/Project1.dpr @@ -0,0 +1,14 @@ +program Project1; + +uses + Vcl.Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.MainFormOnTaskbar := True; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Demos/AUTO_IMPORT_DEMOS/PaxProgram/OperatorOverloading/Project1.res b/Demos/AUTO_IMPORT_DEMOS/PaxProgram/OperatorOverloading/Project1.res new file mode 100644 index 0000000..d41ae7f Binary files /dev/null and b/Demos/AUTO_IMPORT_DEMOS/PaxProgram/OperatorOverloading/Project1.res differ diff --git a/Demos/AUTO_IMPORT_DEMOS/PaxProgram/OperatorOverloading/Unit1.dfm b/Demos/AUTO_IMPORT_DEMOS/PaxProgram/OperatorOverloading/Unit1.dfm new file mode 100644 index 0000000..6308f55 --- /dev/null +++ b/Demos/AUTO_IMPORT_DEMOS/PaxProgram/OperatorOverloading/Unit1.dfm @@ -0,0 +1,70 @@ +object Form1: TForm1 + Left = 0 + Top = 0 + Caption = 'Operator Overloading' + ClientHeight = 397 + ClientWidth = 708 + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -13 + Font.Name = 'Tahoma' + Font.Style = [] + OldCreateOrder = False + PixelsPerInch = 120 + TextHeight = 16 + object Memo1: TMemo + Left = 8 + Top = 8 + Width = 561 + Height = 381 + Lines.Strings = ( + 'uses' + ' Unit1;' + 'var' + ' U, V: TMyRecord;' + ' I: Integer;' + 'begin' + ' V := TMyRecord(4); // explicit type cast' + ' U := 3; // implicit type cast' + ' V.x := 1;' + ' V.y := 2;' + ' U := U + V; // operation of addition' + ' print U.X;' + ' print U.Y;' + ' I := V;' + ' print I;' + 'end.') + TabOrder = 0 + end + object Button1: TButton + Left = 600 + Top = 336 + Width = 75 + Height = 25 + Caption = 'Run script' + TabOrder = 1 + OnClick = Button1Click + end + object PaxCompiler1: TPaxCompiler + Alignment = 8 + OnUsedUnit = PaxCompiler1UsedUnit + DebugMode = False + Left = 616 + Top = 80 + end + object PaxPascalLanguage1: TPaxPascalLanguage + ExplicitOff = False + CompleteBooleanEval = False + UnitLookup = True + PrintKeyword = 'print' + PrintlnKeyword = 'println' + Left = 616 + Top = 152 + end + object PaxProgram1: TPaxProgram + Console = False + Left = 600 + Top = 248 + end +end diff --git a/Demos/AUTO_IMPORT_DEMOS/PaxProgram/OperatorOverloading/Unit1.pas b/Demos/AUTO_IMPORT_DEMOS/PaxProgram/OperatorOverloading/Unit1.pas new file mode 100644 index 0000000..0bd8918 --- /dev/null +++ b/Demos/AUTO_IMPORT_DEMOS/PaxProgram/OperatorOverloading/Unit1.pas @@ -0,0 +1,101 @@ +unit Unit1; + +interface + +uses + Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics, + Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, PaxRunner, + PaxCompiler, PaxProgram; + +type + TForm1 = class(TForm) + Memo1: TMemo; + Button1: TButton; + PaxCompiler1: TPaxCompiler; + PaxPascalLanguage1: TPaxPascalLanguage; + PaxProgram1: TPaxProgram; + procedure Button1Click(Sender: TObject); + function PaxCompiler1UsedUnit(Sender: TPaxCompiler; const UnitName: string; + var SourceCode: string): Boolean; + private + { Private declarations } + public + { Public declarations } + end; + +type + TMyRecord = record + x, y: Integer; + class operator Add(a, b: TMyRecord): TMyRecord; + class operator Subtract(a, b: TMyRecord): TMyRecord; + class operator Implicit(a: Integer): TMyRecord; + class operator Implicit(a: TMyRecord): Integer; + class operator Explicit(a: Integer): TMyRecord; + end; + +var + Form1: TForm1; + +implementation + +{$R *.dfm} + +class operator TMyRecord.Add(a, b: TMyRecord): TMyRecord; +begin + result.x := a.x + b.x; + result.y := a.y + b.y; +end; + +class operator TMyRecord.Subtract(a, b: TMyRecord): TMyRecord; +begin + result.x := a.x - b.x; + result.y := a.y - b.y; +end; + +class operator TMyRecord.Implicit(a: Integer): TMyRecord; +begin + result.x := a; + result.y := 0; +end; + +class operator TMyRecord.Implicit(a: TMyRecord): Integer; +begin + result := a.x; +end; + +class operator TMyRecord.Explicit(a: Integer): TMyRecord; +begin + result.x := a; + result.y := 0; +end; + +procedure Dummy(P: Pointer); begin end; + +procedure TForm1.Button1Click(Sender: TObject); +begin + Dummy(TypeInfo(TMyRecord)); // just to punish Delphi to create RTTI for TMyRecord + + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + PaxCompiler1.AddModule('1', 'Pascal'); + PaxCompiler1.AddCode('1', Memo1.Lines.Text); + if PaxCompiler1.Compile(PaxProgram1) then + begin + PaxProgram1.Run; + end + else + ShowMessage(PaxCompiler1.ErrorMessage[0]); +end; + +function TForm1.PaxCompiler1UsedUnit(Sender: TPaxCompiler; + const UnitName: string; var SourceCode: string): Boolean; +begin +// Use OnUsedUnit event to prevent loading Unit1.pas from disk. +// We are going to import types of Unit1.pas, not to compile the unit. + + Sender.RegisterImportUnit(0, UnitName); + result := true; + SourceCode := ''; +end; + +end. diff --git a/Readme.md b/Readme.md new file mode 100644 index 0000000..5ac7d22 --- /dev/null +++ b/Readme.md @@ -0,0 +1,17 @@ +paxCompiler sources +------------------------------------------------------------------------------ +Version: 4.2 +Status: Registered. +Build: 14 October, 2014. +Copyright (c) 2006-2014 Alexander Baranovsky +Author: Alexander Baranovsky +Web site: www.paxcompiler.com + +Xilinx Tokyio mod: 7 August 2017 +Delphi 12 Athena Decembar 2023 + + + + +================= +www.downloadly.ir \ No newline at end of file diff --git a/Sources/Android/Demos/CallFunction/AndroidManifest.template.xml b/Sources/Android/Demos/CallFunction/AndroidManifest.template.xml new file mode 100644 index 0000000..b593684 --- /dev/null +++ b/Sources/Android/Demos/CallFunction/AndroidManifest.template.xml @@ -0,0 +1,42 @@ + + + + + + +<%uses-permission%> + + + +<%application-meta-data%> + <%services%> + + + + + + + + + + <%activity%> + <%receivers%> + + + diff --git a/Sources/Android/Demos/CallFunction/Project1.dpr b/Sources/Android/Demos/CallFunction/Project1.dpr new file mode 100644 index 0000000..3ac7d4f --- /dev/null +++ b/Sources/Android/Demos/CallFunction/Project1.dpr @@ -0,0 +1,14 @@ +program Project1; + +uses + System.StartUpCopy, + FMX.Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Sources/Android/Demos/CallFunction/Project1.dproj b/Sources/Android/Demos/CallFunction/Project1.dproj new file mode 100644 index 0000000..25a9e9b --- /dev/null +++ b/Sources/Android/Demos/CallFunction/Project1.dproj @@ -0,0 +1,936 @@ + + + {39E0ADEA-F8D6-42DC-9A9E-86B640357759} + 18.2 + FMX + Project1.dpr + True + Debug + Android + 1113 + Application + + + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Cfg_1 + true + true + + + true + Cfg_1 + true + true + + + true + Cfg_1 + true + true + + + true + Base + true + + + true + Cfg_2 + true + true + + + true + true + true + true + System;Xml;Data;Datasnap;Web;Soap;$(DCC_Namespace) + true + true + true + true + true + true + .\$(Platform)\$(Config) + .\$(Platform)\$(Config) + false + false + false + false + false + Project1 + $(BDS)\bin\delphi_PROJECTICON.ico + $(BDS)\bin\delphi_PROJECTICNS.icns + + + $(BDS)\bin\Artwork\Android\FM_LauncherIcon_72x72.png + FireDACSqliteDriver;bindcompfmx;DBXSqliteDriver;fmx;rtl;dbrtl;DbxClientDriver;IndySystem;FireDACCommon;bindcomp;DBXInterBaseDriver;DataSnapClient;DataSnapCommon;paxcomp_xe5;DataSnapProviderClient;xmlrtl;ibxpress;DbxCommonDriver;IndyProtocols;dbxcds;FireDACCommonDriver;bindengine;soaprtl;bindcompdbx;FMXTee;fmxFireDAC;CustomIPTransport;FireDAC;dsnap;IndyCore;FireDACDataSnapDriver;IndyIPCommon;CloudService;FireDACIBDriver;inet;FireDACDBXDriver;FmxTeeUI;RESTComponents;dbexpress;IndyIPClient;$(DCC_UsePackage) + $(BDS)\bin\Artwork\Android\FM_LauncherIcon_36x36.png + $(BDS)\bin\Artwork\Android\FM_LauncherIcon_96x96.png + package=com.embarcadero.$(MSBuildProjectName);label=$(MSBuildProjectName);versionCode=1;versionName=1.0.0;persistent=False;restoreAnyVersion=False;installLocation=preferExternal;largeHeap=False;theme=TitleBar;hardwareAccelerated=true;apiKey= + $(BDS)\bin\Artwork\Android\FM_LauncherIcon_48x48.png + true + Debug + $(BDS)\bin\Artwork\Android\FM_LauncherIcon_144x144.png + $(BDS)\bin\Artwork\Android\FM_SplashImage_426x320.png + $(BDS)\bin\Artwork\Android\FM_SplashImage_470x320.png + $(BDS)\bin\Artwork\Android\FM_SplashImage_640x480.png + $(BDS)\bin\Artwork\Android\FM_SplashImage_960x720.png + android-support-v4.dex.jar;cloud-messaging.dex.jar;fmx.dex.jar;google-analytics-v2.dex.jar;google-play-billing.dex.jar;google-play-licensing.dex.jar;google-play-services.dex.jar + + + $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_60x60.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_120x120.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_40x40.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_80x80.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_40x40.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_80x80.png + $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_76x76.png + $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_152x152.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_768x1024.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_1024x768.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_1536x2048.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_2048x1536.png + CFBundleName=$(MSBuildProjectName);CFBundleDevelopmentRegion=en;CFBundleDisplayName=$(MSBuildProjectName);CFBundleIdentifier=$(MSBuildProjectName);CFBundleInfoDictionaryVersion=6.0;CFBundleVersion=1.0.0.0;CFBundlePackageType=APPL;CFBundleSignature=????;LSRequiresIPhoneOS=true;CFBundleAllowMixedLocalizations=YES;CFBundleExecutable=$(MSBuildProjectName);UIDeviceFamily=iPhone & iPad;CFBundleResourceSpecification=ResourceRules.plist;NSLocationWhenInUseUsageDescription=The reason for accessing the location information of the user;NSLocationAlwaysUsageDescription=The reason for accessing the location information of the user;FMLocalNotificationPermission=false;UIBackgroundModes=;NSContactsUsageDescription=The reason for accessing the contacts;NSPhotoLibraryUsageDescription=The reason for accessing the photo library;NSCameraUsageDescription=The reason for accessing the camera + iPhoneAndiPad + true + Debug + $(MSBuildProjectName) + $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_87x87.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_180x180.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImage_750x1334.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImage_1242x2208.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImage_2208x1242.png + true + Base + true + $(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_29x29.png + FireDACSqliteDriver;bindcompfmx;DBXSqliteDriver;fmx;rtl;dbrtl;DbxClientDriver;IndySystem;FireDACCommon;bindcomp;DBXInterBaseDriver;DataSnapClient;DataSnapCommon;DataSnapProviderClient;xmlrtl;ibxpress;DbxCommonDriver;IndyProtocols;dbxcds;FireDACCommonDriver;bindengine;soaprtl;bindcompdbx;FMXTee;fmxFireDAC;CustomIPTransport;FireDAC;dsnap;fmxase;IndyCore;FireDACDataSnapDriver;IndyIPCommon;CloudService;FireDACIBDriver;inet;FireDACDBXDriver;FmxTeeUI;RESTComponents;dbexpress;IndyIPClient;$(DCC_UsePackage);$(DCC_UsePackage) + $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_72x72.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SettingIcon_29x29.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_768x1004.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImage_640x1136.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_57x57.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_2048x1496.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_1024x748.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImage_320x480.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImage_640x960.png + $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_144x144.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_100x100.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SettingIcon_58x58.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_58x58.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_1536x2008.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_114x114.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_50x50.png + + + $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_87x87.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_180x180.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImage_750x1334.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImage_1242x2208.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImage_2208x1242.png + CFBundleName=$(MSBuildProjectName);CFBundleDevelopmentRegion=en;CFBundleDisplayName=$(MSBuildProjectName);CFBundleIdentifier=$(MSBuildProjectName);CFBundleInfoDictionaryVersion=6.0;CFBundleVersion=1.0.0.0;CFBundlePackageType=APPL;CFBundleSignature=????;LSRequiresIPhoneOS=true;CFBundleAllowMixedLocalizations=YES;CFBundleExecutable=$(MSBuildProjectName);UIDeviceFamily=iPhone & iPad;CFBundleResourceSpecification=ResourceRules.plist;NSLocationWhenInUseUsageDescription=The reason for accessing the location information of the user;NSLocationAlwaysUsageDescription=The reason for accessing the location information of the user;FMLocalNotificationPermission=false;UIBackgroundModes=;NSContactsUsageDescription=The reason for accessing the contacts;NSPhotoLibraryUsageDescription=The reason for accessing the photo library;NSCameraUsageDescription=The reason for accessing the camera + iPhoneAndiPad + true + Debug + $(MSBuildProjectName) + true + Base + true + $(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_29x29.png + FireDACSqliteDriver;bindcompfmx;DBXSqliteDriver;fmx;rtl;dbrtl;DbxClientDriver;IndySystem;FireDACCommon;bindcomp;DBXInterBaseDriver;DataSnapClient;DataSnapCommon;DataSnapProviderClient;xmlrtl;ibxpress;DbxCommonDriver;IndyProtocols;dbxcds;FireDACCommonDriver;bindengine;soaprtl;bindcompdbx;FMXTee;fmxFireDAC;CustomIPTransport;FireDAC;dsnap;fmxase;IndyCore;FireDACDataSnapDriver;IndyIPCommon;CloudService;FireDACIBDriver;inet;FireDACDBXDriver;FmxTeeUI;RESTComponents;dbexpress;IndyIPClient;$(DCC_UsePackage);$(DCC_UsePackage) + $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_72x72.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SettingIcon_29x29.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_768x1004.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImage_640x1136.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_57x57.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_2048x1496.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_1024x748.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImage_320x480.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImage_640x960.png + $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_144x144.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_100x100.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SettingIcon_58x58.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_58x58.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_1536x2008.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_114x114.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_50x50.png + + + $(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_29x29.png + FireDACSqliteDriver;bindcompfmx;DBXSqliteDriver;fmx;rtl;dbrtl;DbxClientDriver;IndySystem;FireDACCommon;bindcomp;DBXInterBaseDriver;DataSnapClient;DataSnapCommon;DataSnapProviderClient;xmlrtl;ibxpress;DbxCommonDriver;IndyProtocols;dbxcds;FireDACCommonDriver;bindengine;soaprtl;bindcompdbx;FMXTee;fmxFireDAC;CustomIPTransport;FireDAC;dsnap;fmxase;IndyCore;FireDACDataSnapDriver;IndyIPCommon;CloudService;FireDACIBDriver;inet;FireDACDBXDriver;FmxTeeUI;RESTComponents;dbexpress;IndyIPClient;$(DCC_UsePackage) + $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_72x72.png + CFBundleName=$(MSBuildProjectName);CFBundleDevelopmentRegion=en;CFBundleDisplayName=$(MSBuildProjectName);CFBundleIdentifier=$(MSBuildProjectName);CFBundleInfoDictionaryVersion=6.0;CFBundleVersion=1.0.0.0;CFBundlePackageType=APPL;CFBundleSignature=????;LSRequiresIPhoneOS=true;CFBundleAllowMixedLocalizations=YES;CFBundleExecutable=$(MSBuildProjectName);UIDeviceFamily=iPhone & iPad;CFBundleResourceSpecification=ResourceRules.plist;NSLocationWhenInUseUsageDescription=The reason for accessing the location information of the user;NSLocationAlwaysUsageDescription=The reason for accessing the location information of the user;FMLocalNotificationPermission=false;UIBackgroundModes=;NSContactsUsageDescription=The reason for accessing the contacts;NSPhotoLibraryUsageDescription=The reason for accessing the photo library;NSCameraUsageDescription=The reason for accessing the camera + $(BDS)\bin\Artwork\iOS\iPad\FM_SettingIcon_29x29.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImage_640x1136.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_57x57.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_1024x748.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_768x1004.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_2048x1496.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_58x58.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImage_320x480.png + true + $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImage_640x960.png + $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_144x144.png + iPhoneAndiPad + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_1536x2008.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SettingIcon_58x58.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_50x50.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_100x100.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_114x114.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_60x60.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_120x120.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_40x40.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_80x80.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_40x40.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_80x80.png + $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_76x76.png + $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_152x152.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_768x1024.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_1024x768.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_1536x2048.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_2048x1536.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_87x87.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_180x180.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImage_750x1334.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImage_1242x2208.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImage_2208x1242.png + + + CFBundleName=$(MSBuildProjectName);CFBundleDisplayName=$(MSBuildProjectName);CFBundleIdentifier=$(MSBuildProjectName);CFBundleVersion=1.0.0;CFBundlePackageType=APPL;CFBundleSignature=????;CFBundleAllowMixedLocalizations=YES;CFBundleExecutable=$(MSBuildProjectName);NSHighResolutionCapable=true;LSApplicationCategoryType=public.app-category.utilities;NSLocationAlwaysUsageDescription=The reason for accessing the location information of the user;NSLocationWhenInUseUsageDescription=The reason for accessing the location information of the user;NSContactsUsageDescription=The reason for accessing the contacts + Debug + true + + + $(BDS)\bin\default_app.manifest + Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) + 1033 + true + CompanyName=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(MSBuildProjectName);FileDescription=$(MSBuildProjectName);ProductName=$(MSBuildProjectName) + DataSnapIndy10ServerTransport;FireDACASADriver;FireDACSqliteDriver;bindcompfmx;DBXSqliteDriver;vcldbx;FireDACPgDriver;FireDACODBCDriver;fmx;rtl;dbrtl;DbxClientDriver;IndySystem;FireDACCommon;bindcomp;inetdb;TeeDB;vclib;inetdbbde;DBXInterBaseDriver;DataSnapClient;DataSnapCommon;DBXOdbcDriver;DataSnapServer;Tee;vclFireDAC;paxcomp_xe5;DataSnapProviderClient;xmlrtl;svnui;ibxpress;DbxCommonDriver;DBXSybaseASEDriver;vclimg;IndyProtocols;dbxcds;DBXMySQLDriver;DatasnapConnectorsFreePascal;FireDACCommonDriver;MetropolisUILiveTile;bindengine;vclactnband;vcldb;soaprtl;bindcompdbx;vcldsnap;bindcompvcl;FMXTee;TeeUI;vclie;fmxFireDAC;FireDACADSDriver;vcltouch;DBXDb2Driver;DBXOracleDriver;CustomIPTransport;vclribbon;VclSmp;FireDACMSSQLDriver;FireDAC;dsnap;Intraweb;fmxase;vcl;IndyCore;FireDACDataSnapDriver;IndyIPServer;IndyIPCommon;VCLRESTComponents;CloudService;dsnapcon;FireDACIBDriver;DBXFirebirdDriver;inet;DBXMSSQLDriver;fmxobj;FireDACDBXDriver;DBXInformixDriver;DataSnapConnectors;FireDACMySQLDriver;FmxTeeUI;vclx;CodeSiteExpressPkg;inetdbxpress;svn;DBXSybaseASADriver;FireDACOracleDriver;fmxdae;FireDACDb2Driver;RESTComponents;bdertl;FireDACMSAccDriver;adortl;dbexpress;IndyIPClient;$(DCC_UsePackage) + true + $(BDS)\bin\Artwork\Windows\UWP\delphi_UwpDefault_44.png + $(BDS)\bin\Artwork\Windows\UWP\delphi_UwpDefault_150.png + + + Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;$(DCC_Namespace) + Debug + true + CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProgramID=com.embarcadero.$(MSBuildProjectName);ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments= + 1033 + $(BDS)\bin\default_app.manifest + true + $(BDS)\bin\Artwork\Windows\UWP\delphi_UwpDefault_44.png + $(BDS)\bin\Artwork\Windows\UWP\delphi_UwpDefault_150.png + + + DEBUG;$(DCC_Define) + true + false + true + true + true + + + F:\Documenti\Documenti\RAD Studio\Componenti\paxcomp\Sources\;$(Debugger_DebugSourcePath) + + + false + Debug + + + true + true + + + false + RELEASE;$(DCC_Define) + 0 + 0 + + + true + true + + + + MainSource + + +
Form1
+ fmx + + + Cfg_2 + Base + + + Base + + + Cfg_1 + Base + + + + Delphi.Personality.12 + + + + + False + False + 1 + 0 + 0 + 0 + False + False + False + False + False + 1033 + 1252 + + + + + 1.0.0.0 + + + + + + 1.0.0.0 + + + + + + + + + + + + + + + + + + + + + + + + + + + Project1.dpr + + + + + + + ic_launcher.png + true + + + + + ic_launcher.png + true + + + + + splash_image.png + true + + + + + splash_image.png + true + + + + + splash_image.png + true + + + + + + + ic_launcher.png + true + + + + + libProject1.so + true + + + + + true + + + + + libProject1.so + true + + + + + true + + + + + classes.dex + true + + + + + + true + + + + + + true + + + + + + + true + + + + + libProject1.so + true + + + + + true + + + + + ic_launcher.png + true + + + + + true + + + + + splash_image.png + true + + + + + true + + + + + ic_launcher.png + true + + + + + + + 1 + + + Contents\MacOS + 1 + + + Contents\MacOS + 0 + + + + + classes + 1 + + + + + library\lib\armeabi-v7a + 1 + + + + + library\lib\armeabi + 1 + + + + + library\lib\mips + 1 + + + + + library\lib\armeabi-v7a + 1 + + + + + res\drawable + 1 + + + + + res\values + 1 + + + + + res\drawable + 1 + + + + + res\drawable-xxhdpi + 1 + + + + + res\drawable-ldpi + 1 + + + + + res\drawable-mdpi + 1 + + + + + res\drawable-hdpi + 1 + + + + + res\drawable-xhdpi + 1 + + + + + res\drawable-small + 1 + + + + + res\drawable-normal + 1 + + + + + res\drawable-large + 1 + + + + + res\drawable-xlarge + 1 + + + + + 1 + + + Contents\MacOS + 1 + + + 0 + + + + + Contents\MacOS + 1 + .framework + + + 0 + + + + + 1 + .dylib + + + 1 + .dylib + + + 1 + .dylib + + + Contents\MacOS + 1 + .dylib + + + 0 + .dll;.bpl + + + + + 1 + .dylib + + + 1 + .dylib + + + 1 + .dylib + + + Contents\MacOS + 1 + .dylib + + + 0 + .bpl + + + + + 0 + + + 0 + + + 0 + + + 0 + + + Contents\Resources\StartUp\ + 0 + + + 0 + + + + + 1 + + + 1 + + + 1 + + + + + 1 + + + 1 + + + 1 + + + + + 1 + + + 1 + + + 1 + + + + + 1 + + + 1 + + + 1 + + + + + 1 + + + 1 + + + 1 + + + + + 1 + + + 1 + + + 1 + + + + + 1 + + + 1 + + + 1 + + + + + 1 + + + + + ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF + 1 + + + ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF + 1 + + + + + 1 + + + 1 + + + + + ..\ + 1 + + + ..\ + 1 + + + + + 1 + + + 1 + + + 1 + + + + + 1 + + + 1 + + + 1 + + + + + ..\ + 1 + + + + + Contents + 1 + + + + + Contents\Resources + 1 + + + + + library\lib\armeabi-v7a + 1 + + + 1 + + + 1 + + + 1 + + + 1 + + + Contents\MacOS + 1 + + + 0 + + + + + 1 + + + 1 + + + + + Assets + 1 + + + Assets + 1 + + + + + Assets + 1 + + + Assets + 1 + + + + + + + + + + + + + True + True + True + True + False + True + False + + + 12 + + + + + diff --git a/Sources/Android/Demos/CallFunction/Project1.res b/Sources/Android/Demos/CallFunction/Project1.res new file mode 100644 index 0000000..36f26e2 Binary files /dev/null and b/Sources/Android/Demos/CallFunction/Project1.res differ diff --git a/Sources/Android/Demos/CallFunction/Unit1.fmx b/Sources/Android/Demos/CallFunction/Unit1.fmx new file mode 100644 index 0000000..2d6c082 --- /dev/null +++ b/Sources/Android/Demos/CallFunction/Unit1.fmx @@ -0,0 +1,266 @@ +object Form1: TForm1 + Left = 0 + Top = 0 + Caption = 'Form2' + ClientHeight = 596 + ClientWidth = 384 + FormFactor.Width = 320 + FormFactor.Height = 480 + FormFactor.Devices = [Desktop] + DesignerMasterStyle = 3 + object Memo1: TMemo + Touch.InteractiveGestures = [Pan, LongTap, DoubleTap] + DataDetectorTypes = [] + Lines.Strings = ( + 'function Anchor(const Address, Text: String): String;' + 'begin' + ' result := '#39''#39' + Text + '#39''#39';' + 'end;' + '' + 'begin' + 'end.' + '') + StyledSettings = [FontColor] + TextSettings.Font.Family = 'Courier New' + TextSettings.Font.Size = 10.000000000000000000 + TextSettings.Font.StyleExt = {00070000000000000004000000} + Anchors = [akLeft, akTop, akRight] + Position.X = 8.000000000000000000 + Position.Y = 24.000000000000000000 + Size.Width = 305.000000000000000000 + Size.Height = 97.000000000000000000 + Size.PlatformDefault = False + TabOrder = 2 + Viewport.Width = 292.000000000000000000 + Viewport.Height = 84.000000000000000000 + end + object Memo2: TMemo + Touch.InteractiveGestures = [Pan, LongTap, DoubleTap] + DataDetectorTypes = [] + StyledSettings = [FontColor] + TextSettings.Font.Family = 'Courier New' + TextSettings.Font.Size = 10.000000000000000000 + TextSettings.Font.StyleExt = {00070000000000000004000000} + Anchors = [akLeft, akRight, akBottom] + Position.X = 8.000000000000000000 + Position.Y = 484.000000000000000000 + Size.Width = 369.000000000000000000 + Size.Height = 61.000000000000000000 + Size.PlatformDefault = False + TabOrder = 3 + Viewport.Width = 361.000000000000000000 + Viewport.Height = 53.000000000000000000 + end + object Button1: TButton + Anchors = [akTop, akRight] + Position.X = 320.000000000000000000 + Position.Y = 24.000000000000000000 + Size.Width = 57.000000000000000000 + Size.Height = 97.000000000000000000 + Size.PlatformDefault = False + TabOrder = 6 + Text = 'Call' + OnClick = Button1Click + end + object Button2: TButton + Anchors = [akRight, akBottom] + Position.X = 304.000000000000000000 + Position.Y = 547.000000000000000000 + Size.Width = 73.000000000000000000 + Size.Height = 44.000000000000000000 + Size.PlatformDefault = False + TabOrder = 7 + Text = 'Exit' + OnClick = Button2Click + end + object Edit1: TEdit + Touch.InteractiveGestures = [LongTap, DoubleTap] + Anchors = [akLeft, akRight, akBottom] + TabOrder = 9 + Text = 'Click here...' + Position.X = 72.000000000000000000 + Position.Y = 424.000000000000000000 + Size.Width = 201.000000000000000000 + Size.Height = 32.000000000000000000 + Size.PlatformDefault = False + StyledSettings = [Family, Style, FontColor] + end + object Edit2: TEdit + Touch.InteractiveGestures = [LongTap, DoubleTap] + Anchors = [akLeft, akRight, akBottom] + StyleLookup = 'editstyle' + TabOrder = 8 + Text = 'http://www.google.com' + Position.X = 72.000000000000000000 + Position.Y = 392.000000000000000000 + Size.Width = 201.000000000000000000 + Size.Height = 32.000000000000000000 + Size.PlatformDefault = False + StyledSettings = [Family, Style, FontColor] + end + object Label1: TLabel + Anchors = [akLeft, akBottom] + StyledSettings = [Family, Style, FontColor] + Position.X = 8.000000000000000000 + Position.Y = 392.000000000000000000 + Size.Width = 57.000000000000000000 + Size.Height = 32.000000000000000000 + Size.PlatformDefault = False + Text = 'Address:' + end + object Label2: TLabel + Anchors = [akLeft, akBottom] + StyledSettings = [Family, Style, FontColor] + Position.X = 8.000000000000000000 + Position.Y = 424.000000000000000000 + Size.Width = 57.000000000000000000 + Size.Height = 32.000000000000000000 + Size.PlatformDefault = False + Text = 'Text:' + end + object Label3: TLabel + StyledSettings = [Family] + Position.X = 10.000000000000000000 + Position.Y = 2.000000000000000000 + Size.Width = 129.000000000000000000 + Size.Height = 23.000000000000000000 + Size.PlatformDefault = False + TextSettings.Font.Size = 11.000000000000000000 + TextSettings.Font.StyleExt = {00070000000000000004000000} + TextSettings.FontColor = claCrimson + Text = 'Object Pascal' + end + object Label4: TLabel + Anchors = [akLeft, akBottom] + StyledSettings = [Family] + Position.X = 8.000000000000000000 + Position.Y = 461.000000000000000000 + Size.Width = 257.000000000000000000 + Size.Height = 23.000000000000000000 + Size.PlatformDefault = False + TextSettings.Font.Size = 11.000000000000000000 + TextSettings.Font.StyleExt = {00070000000000000004000000} + TextSettings.FontColor = claDarkcyan + Text = 'Result:' + end + object Memo3: TMemo + Touch.InteractiveGestures = [Pan, LongTap, DoubleTap] + DataDetectorTypes = [] + Lines.Strings = ( + 'FUNCTION Anchor(Address, Text As STRING) As STRING' + ' DIM Risultato AS STRING' + ' Risultato = ""'#39' + Text + ""' + ' RETURN Risultato' + 'END FUNCTION' + '') + StyledSettings = [FontColor] + TextSettings.Font.Family = 'Courier New' + TextSettings.Font.Size = 10.000000000000000000 + TextSettings.Font.StyleExt = {00070000000000000004000000} + Anchors = [akLeft, akTop, akRight] + Position.X = 7.000000000000000000 + Position.Y = 152.000000000000000000 + Size.Width = 306.000000000000000000 + Size.Height = 97.000000000000000000 + Size.PlatformDefault = False + TabOrder = 1 + Viewport.Width = 298.000000000000000000 + Viewport.Height = 84.000000000000000000 + end + object Memo4: TMemo + Touch.InteractiveGestures = [Pan, LongTap, DoubleTap] + DataDetectorTypes = [] + Lines.Strings = ( + 'function Anchor(Address, Text)' + '{' + ' Address = ""'#39' + Text + "";' + ' RETURN Address;' + '}' + '') + StyledSettings = [FontColor] + TextSettings.Font.Family = 'Courier New' + TextSettings.Font.Size = 10.000000000000000000 + TextSettings.Font.StyleExt = {00070000000000000004000000} + Anchors = [akLeft, akTop, akRight] + Position.X = 7.000000000000000000 + Position.Y = 280.000000000000000000 + Size.Width = 306.000000000000000000 + Size.Height = 97.000000000000000000 + Size.PlatformDefault = False + TabOrder = 0 + Viewport.Width = 298.000000000000000000 + Viewport.Height = 84.000000000000000000 + end + object Label5: TLabel + StyledSettings = [Family] + Position.X = 10.000000000000000000 + Position.Y = 130.000000000000000000 + Size.Width = 129.000000000000000000 + Size.Height = 23.000000000000000000 + Size.PlatformDefault = False + TextSettings.Font.Size = 11.000000000000000000 + TextSettings.Font.StyleExt = {00070000000000000004000000} + TextSettings.FontColor = claCrimson + Text = 'Basic' + end + object Label6: TLabel + StyledSettings = [Family] + Position.X = 10.000000000000000000 + Position.Y = 258.000000000000000000 + Size.Width = 129.000000000000000000 + Size.Height = 23.000000000000000000 + Size.PlatformDefault = False + TextSettings.Font.Size = 11.000000000000000000 + TextSettings.Font.StyleExt = {00070000000000000004000000} + TextSettings.FontColor = claCrimson + Text = 'JavaScript' + end + object Button3: TButton + Anchors = [akTop, akRight] + Position.X = 319.000000000000000000 + Position.Y = 152.000000000000000000 + Size.Width = 57.000000000000000000 + Size.Height = 97.000000000000000000 + Size.PlatformDefault = False + TabOrder = 5 + Text = 'Call' + OnClick = Button3Click + end + object Button4: TButton + Anchors = [akTop, akRight] + Position.X = 319.000000000000000000 + Position.Y = 280.000000000000000000 + Size.Width = 57.000000000000000000 + Size.Height = 97.000000000000000000 + Size.PlatformDefault = False + TabOrder = 4 + Text = 'Call' + OnClick = Button4Click + end + object Label7: TLabel + Anchors = [akLeft, akBottom] + StyledSettings = [Family] + Position.X = 8.000000000000000000 + Position.Y = 377.000000000000000000 + Size.Width = 273.000000000000000000 + Size.Height = 23.000000000000000000 + Size.PlatformDefault = False + TextSettings.Font.Size = 11.000000000000000000 + TextSettings.Font.StyleExt = {00070000000000000004000000} + TextSettings.FontColor = claDodgerblue + Text = 'Parameters' + end + object Label8: TLabel + Anchors = [akLeft, akBottom] + StyledSettings = [Family] + Position.X = 8.000000000000000000 + Position.Y = 565.000000000000000000 + Size.Width = 257.000000000000000000 + Size.Height = 23.000000000000000000 + Size.PlatformDefault = False + TextSettings.Font.Size = 16.000000000000000000 + TextSettings.Font.StyleExt = {00070000000100000004000000} + Text = '10.2 Tokyo by Xilinx' + TabOrder = 11 + end +end diff --git a/Sources/Android/Demos/CallFunction/Unit1.pas b/Sources/Android/Demos/CallFunction/Unit1.pas new file mode 100644 index 0000000..b332cc8 --- /dev/null +++ b/Sources/Android/Demos/CallFunction/Unit1.pas @@ -0,0 +1,116 @@ +unit Unit1; + +interface + +uses + System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants, + FMX.Types, FMX.Controls, FMX.Forms, FMX.Graphics, FMX.Dialogs, FMX.StdCtrls, +{$IFDEF ANDROID} + FMX.Platform.Android, +{$ENDIF} + FMX.Layouts, FMX.Memo, + PaxCompiler, + PaxBasicLanguage, + PAxJavascriptLanguage, + PaxRunner, PaxInterpreter, FMX.Controls.Presentation, + FMX.ScrollBox, FMX.Edit; + +type + TForm1 = class(TForm) + Memo1: TMemo; + Memo2: TMemo; + Button1: TButton; + Button2: TButton; + Edit1: TEdit; + Edit2: TEdit; + Label1: TLabel; + Label2: TLabel; + Label3: TLabel; + Label4: TLabel; + Memo3: TMemo; + Memo4: TMemo; + Label5: TLabel; + Label6: TLabel; + Button3: TButton; + Button4: TButton; + Label7: TLabel; + Label8: TLabel; + procedure Button2Click(Sender: TObject); + procedure Button1Click(Sender: TObject); + procedure Button3Click(Sender: TObject); + procedure Button4Click(Sender: TObject); + private + { Private declarations } + PaxLanguage1: TPaxCompilerLanguage; + procedure CompileAndRun(sLanguage: string); + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.fmx} + +procedure TForm1.CompileAndRun(sLanguage: string); +var + PaxCompiler1: TPaxCompiler; + PaxInterpreter1: TPaxInterpreter; + S: String; +begin + PaxCompiler1 := TPaxCompiler.Create(nil); + PaxInterpreter1 := TPaxInterpreter.Create(nil); + try + PaxCompiler1.RegisterLanguage(PaxLanguage1); + PaxCompiler1.AddModule('1', sLanguage); + PaxCompiler1.AddCode('1', Memo1.Lines.Text); + if PaxCompiler1.Compile(PaxInterpreter1) then + begin + PaxInterpreter1.RunInitialization; + S := PaxInterpreter1.CallRoutine('Anchor', [Edit2.Text, Edit1.Text]); + Memo2.Lines.Add(S); + end + else + begin + ShowMessage(PaxCompiler1.ErrorMessage[0]); + end; + finally + FreeAndNil(PaxCompiler1); + FreeAndNil(PaxInterpreter1); + FreeAndNil(PaxLanguage1); + end; +end; + +procedure TForm1.Button1Click(Sender: TObject); +begin + PaxLanguage1 := TPaxPascalLanguage.Create(nil); + CompileAndRun('Pascal'); +end; + + +procedure TForm1.Button3Click(Sender: TObject); +begin + PaxLanguage1 := TPaxBasicLanguage.Create(nil); + CompileAndRun('Basic'); +end; + + +procedure TForm1.Button4Click(Sender: TObject); +begin + PaxLanguage1 := TPaxJavaScriptLanguage.Create(nil); + CompileAndRun('JavaScript'); +end; + +procedure TForm1.Button2Click(Sender: TObject); +begin +{$IFDEF ANDROID} + MainActivity.finish; +{$ELSE} + Close; +{$ENDIF} +end; + + +end. diff --git a/Sources/Android/Demos/DebugDemo/Project1.dpr b/Sources/Android/Demos/DebugDemo/Project1.dpr new file mode 100644 index 0000000..3ac7d4f --- /dev/null +++ b/Sources/Android/Demos/DebugDemo/Project1.dpr @@ -0,0 +1,14 @@ +program Project1; + +uses + System.StartUpCopy, + FMX.Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Sources/Android/Demos/DebugDemo/Project1.dproj b/Sources/Android/Demos/DebugDemo/Project1.dproj new file mode 100644 index 0000000..579d6c2 --- /dev/null +++ b/Sources/Android/Demos/DebugDemo/Project1.dproj @@ -0,0 +1,578 @@ + + + {A2936444-2C7D-4C37-AC89-85946911B94B} + 15.1 + FMX + Project1.dpr + True + Debug + Android + 89 + Application + + + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Cfg_1 + true + true + + + true + Cfg_1 + true + true + + + true + Base + true + + + true + true + true + true + true + true + true + true + System;Xml;Data;Datasnap;Web;Soap;$(DCC_Namespace) + true + true + .\$(Platform)\$(Config) + .\$(Platform)\$(Config) + false + false + false + false + false + + + $(BDS)\bin\Artwork\Android\FM_LauncherIcon_144x144.png + FireDACSqliteDriver;bindcompfmx;DBXSqliteDriver;fmx;rtl;dbrtl;DbxClientDriver;IndySystem;FireDACCommon;bindcomp;DBXInterBaseDriver;DataSnapClient;DataSnapCommon;paxcomp_xe5;DataSnapProviderClient;xmlrtl;ibxpress;DbxCommonDriver;IndyProtocols;dbxcds;FireDACCommonDriver;bindengine;soaprtl;bindcompdbx;FMXTee;fmxFireDAC;CustomIPTransport;FireDAC;dsnap;IndyCore;FireDACDataSnapDriver;IndyIPCommon;CloudService;FireDACIBDriver;inet;FireDACDBXDriver;FmxTeeUI;RESTComponents;dbexpress;IndyIPClient;$(DCC_UsePackage) + true + $(BDS)\bin\Artwork\Android\FM_LauncherIcon_96x96.png + $(BDS)\bin\Artwork\Android\FM_LauncherIcon_36x36.png + $(BDS)\bin\Artwork\Android\FM_LauncherIcon_72x72.png + package=com.embarcadero.$(MSBuildProjectName);label=$(MSBuildProjectName);versionCode=1;versionName=1.0.0;persistent=False;restoreAnyVersion=False;installLocation=preferExternal;largeHeap=False;theme=TitleBar + $(BDS)\bin\Artwork\Android\FM_LauncherIcon_48x48.png + Debug + + + $(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_100x100.png + FireDACSqliteDriver;bindcompfmx;DBXSqliteDriver;fmx;rtl;dbrtl;DbxClientDriver;IndySystem;FireDACCommon;bindcomp;DBXInterBaseDriver;DataSnapClient;DataSnapCommon;DataSnapProviderClient;xmlrtl;ibxpress;DbxCommonDriver;IndyProtocols;dbxcds;FireDACCommonDriver;bindengine;soaprtl;bindcompdbx;FMXTee;fmxFireDAC;CustomIPTransport;FireDAC;dsnap;fmxase;IndyCore;FireDACDataSnapDriver;IndyIPCommon;CloudService;FireDACIBDriver;inet;FireDACDBXDriver;FmxTeeUI;RESTComponents;dbexpress;IndyIPClient;$(DCC_UsePackage) + $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_72x72.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SettingIcon_58x58.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_50x50.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImage_640x1136.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SettingIcon_29x29.png + true + $(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_58x58.png + $(MSBuildProjectName) + iPhoneAndiPad + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_1024x748.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_29x29.png + Debug + CFBundleName=$(MSBuildProjectName);CFBundleDevelopmentRegion=en;CFBundleDisplayName=$(MSBuildProjectName);CFBundleIdentifier=$(MSBuildProjectName);CFBundleInfoDictionaryVersion=6.0;CFBundleVersion=1.0.0.0;CFBundlePackageType=APPL;CFBundleSignature=????;LSRequiresIPhoneOS=true;CFBundleAllowMixedLocalizations=YES;CFBundleExecutable=$(MSBuildProjectName);UIDeviceFamily=iPhone & iPad;CFBundleResourceSpecification=ResourceRules.plist + $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_114x114.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_2048x1496.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_1536x2008.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImage_320x480.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_768x1004.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImage_640x960.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_57x57.png + $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_144x144.png + + + $(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_100x100.png + FireDACSqliteDriver;bindcompfmx;DBXSqliteDriver;fmx;rtl;dbrtl;DbxClientDriver;IndySystem;FireDACCommon;bindcomp;DBXInterBaseDriver;DataSnapClient;DataSnapCommon;DataSnapProviderClient;xmlrtl;ibxpress;DbxCommonDriver;IndyProtocols;dbxcds;FireDACCommonDriver;bindengine;soaprtl;bindcompdbx;FMXTee;fmxFireDAC;CustomIPTransport;FireDAC;dsnap;fmxase;IndyCore;FireDACDataSnapDriver;IndyIPCommon;CloudService;FireDACIBDriver;inet;FireDACDBXDriver;FmxTeeUI;RESTComponents;dbexpress;IndyIPClient;$(DCC_UsePackage) + $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_72x72.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SettingIcon_58x58.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_50x50.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SettingIcon_29x29.png + true + $(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_58x58.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImage_640x1136.png + iPhoneAndiPad + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_1024x748.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_29x29.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_1536x2008.png + CFBundleName=$(MSBuildProjectName);CFBundleDevelopmentRegion=en;CFBundleDisplayName=$(MSBuildProjectName);CFBundleIdentifier=$(MSBuildProjectName);CFBundleInfoDictionaryVersion=6.0;CFBundleVersion=1.0.0.0;CFBundlePackageType=APPL;CFBundleSignature=????;LSRequiresIPhoneOS=true;CFBundleAllowMixedLocalizations=YES;CFBundleExecutable=$(MSBuildProjectName);UIDeviceFamily=iPhone & iPad;CFBundleResourceSpecification=ResourceRules.plist + $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_114x114.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_2048x1496.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImage_320x480.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_768x1004.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImage_640x960.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_57x57.png + $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_144x144.png + + + 1033 + DataSnapIndy10ServerTransport;FireDACASADriver;FireDACSqliteDriver;bindcompfmx;DBXSqliteDriver;vcldbx;FireDACPgDriver;FireDACODBCDriver;fmx;rtl;dbrtl;DbxClientDriver;IndySystem;FireDACCommon;bindcomp;inetdb;TeeDB;vclib;inetdbbde;DBXInterBaseDriver;DataSnapClient;DataSnapCommon;DBXOdbcDriver;DataSnapServer;Tee;vclFireDAC;paxcomp_xe5;DataSnapProviderClient;xmlrtl;svnui;ibxpress;DbxCommonDriver;DBXSybaseASEDriver;vclimg;IndyProtocols;dbxcds;DBXMySQLDriver;DatasnapConnectorsFreePascal;FireDACCommonDriver;MetropolisUILiveTile;bindengine;vclactnband;vcldb;soaprtl;bindcompdbx;vcldsnap;bindcompvcl;FMXTee;TeeUI;vclie;fmxFireDAC;FireDACADSDriver;vcltouch;DBXDb2Driver;DBXOracleDriver;CustomIPTransport;vclribbon;VclSmp;FireDACMSSQLDriver;FireDAC;dsnap;Intraweb;fmxase;vcl;IndyCore;FireDACDataSnapDriver;IndyIPServer;IndyIPCommon;VCLRESTComponents;CloudService;dsnapcon;FireDACIBDriver;DBXFirebirdDriver;inet;DBXMSSQLDriver;fmxobj;FireDACDBXDriver;DBXInformixDriver;DataSnapConnectors;FireDACMySQLDriver;FmxTeeUI;vclx;CodeSiteExpressPkg;inetdbxpress;svn;DBXSybaseASADriver;FireDACOracleDriver;fmxdae;FireDACDb2Driver;RESTComponents;bdertl;FireDACMSAccDriver;adortl;dbexpress;IndyIPClient;$(DCC_UsePackage) + true + $(BDS)\bin\default_app.manifest + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments= + Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) + + + DEBUG;$(DCC_Define) + true + false + true + true + true + + + C:\HOT\assem2\CURR\;$(Debugger_DebugSourcePath) + + + false + + + false + RELEASE;$(DCC_Define) + 0 + 0 + + + + MainSource + + +
Form1
+ fmx + + + Cfg_2 + Base + + + Base + + + Cfg_1 + Base + + + + Delphi.Personality.12 + + + + + False + False + 1 + 0 + 0 + 0 + False + False + False + False + False + 1033 + 1252 + + + + + 1.0.0.0 + + + + + + 1.0.0.0 + + + + + + + + + + + + + + + + + + + + + + + + + + + Project1.dpr + + + + + + classes.dex + + + + + + + + + + + + ic_launcher.png + + + + + ic_launcher.png + + + + + ic_launcher.png + + + + + ic_launcher.png + + + + + ic_launcher.png + + + + + + + + + + + 1 + .dylib + + + 0 + .bpl + + + Contents\MacOS + 1 + .dylib + + + 1 + .dylib + + + + + 1 + .dylib + + + 0 + .dll;.bpl + + + Contents\MacOS + 1 + .dylib + + + 1 + .dylib + + + + + 1 + + + 1 + + + + + Contents + 1 + + + + + ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF + 1 + + + + + 1 + + + 1 + + + + + Contents + 1 + + + + + library\lib\armeabi + 1 + + + + + 1 + + + 1 + + + + + res\drawable-xhdpi + 1 + + + + + 1 + + + 1 + + + + + res\drawable-xxhdpi + 1 + + + + + Contents\MacOS + 1 + + + 1 + + + 0 + + + + + Contents\MacOS + 1 + .framework + + + 0 + + + + + 1 + + + + + Contents\MacOS + 1 + + + 1 + + + Contents\MacOS + 0 + + + + + classes + 1 + + + + + 1 + + + + + 1 + + + 1 + + + + + 1 + + + + + res\drawable + 1 + + + + + Contents\Resources + 1 + + + + + 1 + + + + + 1 + + + 1 + + + + + 1 + + + library\lib\armeabi + 1 + + + 0 + + + Contents\MacOS + 1 + + + 1 + + + + + 0 + + + 0 + + + 0 + + + Contents\MacOS + 0 + + + 0 + + + + + 1 + + + 1 + + + + + res\drawable-ldpi + 1 + + + + + 1 + + + 1 + + + + + res\drawable-mdpi + 1 + + + + + res\drawable-hdpi + 1 + + + + + 1 + + + + + + + + + + + True + True + True + True + + + 12 + + + + + diff --git a/Sources/Android/Demos/DebugDemo/Project1.res b/Sources/Android/Demos/DebugDemo/Project1.res new file mode 100644 index 0000000..0739f2f Binary files /dev/null and b/Sources/Android/Demos/DebugDemo/Project1.res differ diff --git a/Sources/Android/Demos/DebugDemo/Unit1.fmx b/Sources/Android/Demos/DebugDemo/Unit1.fmx new file mode 100644 index 0000000..68670dd --- /dev/null +++ b/Sources/Android/Demos/DebugDemo/Unit1.fmx @@ -0,0 +1,98 @@ +object Form1: TForm1 + Left = 0 + Top = 0 + Caption = 'Debug demo' + ClientHeight = 567 + ClientWidth = 384 + FormFactor.Width = 320 + FormFactor.Height = 480 + FormFactor.Devices = [dkDesktop] + OnCreate = FormCreate + OnDestroy = FormDestroy + DesignerMobile = True + DesignerWidth = 384 + DesignerHeight = 592 + DesignerDeviceName = 'Google Nexus 4' + DesignerOrientation = 0 + DesignerOSVersion = '' + object Memo1: TMemo + Touch.InteractiveGestures = [igPan, igLongTap, igDoubleTap] + Height = 137.000000000000000000 + Position.X = 16.000000000000000000 + Position.Y = 24.000000000000000000 + TabOrder = 0 + Width = 193.000000000000000000 + Lines.Strings = ( + 'function Fact(N: Integer): Integer;' + 'begin' + ' if N = 1 then' + ' result := 1' + ' else' + ' result := N * Fact(N - 1);' + 'end;' + 'var SS: Integer;' + 'begin' + ' SS := Fact(3);' + ' print(SS);' + 'end.' + '') + end + object Memo2: TMemo + Touch.InteractiveGestures = [igPan, igLongTap, igDoubleTap] + Height = 233.000000000000000000 + Position.X = 16.000000000000000000 + Position.Y = 184.000000000000000000 + TabOrder = 1 + Width = 193.000000000000000000 + end + object Button1: TButton + Height = 44.000000000000000000 + Position.X = 216.000000000000000000 + Position.Y = 24.000000000000000000 + TabOrder = 2 + Text = 'Compile' + Trimming = ttCharacter + Width = 97.000000000000000000 + OnClick = Button1Click + end + object Button2: TButton + Height = 44.000000000000000000 + Position.X = 216.000000000000000000 + Position.Y = 72.000000000000000000 + TabOrder = 3 + Text = 'Run' + Trimming = ttCharacter + Width = 97.000000000000000000 + OnClick = Button2Click + end + object Button3: TButton + Height = 44.000000000000000000 + Position.X = 216.000000000000000000 + Position.Y = 120.000000000000000000 + TabOrder = 4 + Text = 'Trace Into' + Trimming = ttCharacter + Width = 97.000000000000000000 + OnClick = Button3Click + end + object Button4: TButton + Height = 44.000000000000000000 + Position.X = 216.000000000000000000 + Position.Y = 168.000000000000000000 + TabOrder = 5 + Text = 'Step Over' + Trimming = ttCharacter + Width = 97.000000000000000000 + OnClick = Button4Click + end + object Button5: TButton + Height = 44.000000000000000000 + Position.X = 216.000000000000000000 + Position.Y = 216.000000000000000000 + TabOrder = 6 + Text = 'Exit' + Trimming = ttCharacter + Width = 97.000000000000000000 + OnClick = Button5Click + end +end diff --git a/Sources/Android/Demos/DebugDemo/Unit1.pas b/Sources/Android/Demos/DebugDemo/Unit1.pas new file mode 100644 index 0000000..2616f10 --- /dev/null +++ b/Sources/Android/Demos/DebugDemo/Unit1.pas @@ -0,0 +1,364 @@ +unit Unit1; + +interface + +uses + System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants, + FMX.Types, FMX.Controls, FMX.Forms, FMX.Graphics, FMX.Dialogs, FMX.StdCtrls, + FMX.Layouts, FMX.Memo, +{$IFDEF ANDROID} + FMX.Platform.Android, +{$ENDIF} + PaxCompiler, + PaxRunner, + PaxInterpreter, + PaxCompilerExplorer, + PaxCompilerDebugger; + +type + TForm1 = class(TForm) + Memo1: TMemo; + Memo2: TMemo; + Button1: TButton; + Button2: TButton; + Button3: TButton; + Button4: TButton; + Button5: TButton; + procedure Button1Click(Sender: TObject); + procedure FormCreate(Sender: TObject); + procedure FormDestroy(Sender: TObject); + procedure Button2Click(Sender: TObject); + procedure Button3Click(Sender: TObject); + procedure Button5Click(Sender: TObject); + procedure Button4Click(Sender: TObject); + private + { Private declarations } + PaxCompiler1: TPaxCompiler; + PaxInterpreter1: TPaxInterpreter; + PaxPascalLanguage1: TPaxPascalLanguage; + PaxCompilerExplorer1: TPaxCompilerExplorer; + PaxCompilerDebugger1: TPaxCompilerDebugger; + PauseProcessed: Boolean; + function TestValid: Boolean; + procedure DoPause(Sender: TPaxRunner; + const ModuleName: String; SourceLineNumber: Integer); + procedure DoPrint(Sender: TPaxRunner; const S: String); + procedure RunDebugger(RunMode: Integer); + public + { Public declarations } + procedure UpdateDebugInfo; + procedure ClearOutput; + procedure Output(const S: String); + end; + +var + Form1: TForm1; + +implementation + +{$R *.fmx} + +procedure TForm1.RunDebugger(RunMode: Integer); +begin + if not TestValid then Exit; + + PauseProcessed := false; + PaxCompilerDebugger1.RunMode := RunMode; + PaxCompilerDebugger1.Run; + if not PauseProcessed then + Output('FINISHED'); +end; + +procedure TForm1.Button2Click(Sender: TObject); +begin + RunDebugger(_rmRUN); +end; + +procedure TForm1.Button3Click(Sender: TObject); +begin + RunDebugger(_rmTRACE_INTO); +end; + +procedure TForm1.Button4Click(Sender: TObject); +begin + RunDebugger(_rmSTEP_OVER); +end; + +procedure TForm1.Button5Click(Sender: TObject); +begin +{$IFDEF ANDROID} + MainActivity.finish; +{$ELSE} + Close; +{$ENDIF} +end; + +procedure TForm1.FormCreate(Sender: TObject); +begin + PaxCompiler1 := TPaxCompiler.Create(nil); + PaxInterpreter1 := TPaxInterpreter.Create(nil); + PaxPascalLanguage1 := TPaxPascalLanguage.Create(nil); + PaxCompilerExplorer1 := TPaxCompilerExplorer.Create(nil); + PaxCompilerDebugger1 := TPaxCompilerDebugger.Create(nil); + + PaxInterpreter1.OnPause := DoPause; + PaxInterpreter1.OnPrintEvent := DoPrint; + + Button2.Enabled := false; + Button3.Enabled := false; + Button4.Enabled := false; +end; + +procedure TForm1.FormDestroy(Sender: TObject); +begin + FreeAndNil(PaxCompiler1); + FreeAndNil(PaxInterpreter1); + FreeAndNil(PaxPascalLanguage1); + FreeAndNil(PaxCompilerExplorer1); + FreeAndNil(PaxCompilerDebugger1); +end; + +procedure TForm1.ClearOutput; +begin + Memo2.Lines.Clear; +end; + +procedure TForm1.Output(const S: String); +begin + Memo2.Lines.Add(S); +end; + +procedure TForm1.Button1Click(Sender: TObject); +var + I: Integer; +begin + ClearOutput; + + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + PaxCompiler1.AddModule('1', PaxPascalLanguage1.LanguageName); + PaxCompiler1.AddCode('1', Memo1.Lines.Text); + PaxCompiler1.DebugMode := true; + if PaxCompiler1.Compile(PaxInterpreter1) then + begin + Output('Compilation: OK'); + PaxCompilerExplorer1.RegisterCompiler(PaxCompiler1); + PaxCompilerDebugger1.RegisterCompiler(PaxCompiler1, PaxInterpreter1); + + Button2.Enabled := true; + Button3.Enabled := true; + Button4.Enabled := true; + end + else + for I:=0 to PaxCompiler1.ErrorCount - 1 do + Output(PaxCompiler1.ErrorMessage[I]); +end; + +procedure TForm1.DoPause(Sender: TPaxRunner; + const ModuleName: String; SourceLineNumber: Integer); +begin + UpdateDebugInfo; + PauseProcessed := true; +end; + +procedure TForm1.DoPrint(Sender: TPaxRunner; const S: String); +begin + ShowMessage(S); +end; + +function TForm1.TestValid: Boolean; +begin + result := PaxCompilerDebugger1.Valid; + if not result then + Output('Script is not valid.'); +end; + +procedure TForm1.UpdateDebugInfo; + + procedure AddFields(StackFrameNumber, Id: Integer); + var + I, K: Integer; + OwnerName, S: String; + begin + K := PaxCompilerExplorer1.GetFieldCount(Id); + if K = 0 then + Exit; + + OwnerName := PaxCompilerExplorer1.Names[Id]; + if PaxCompilerDebugger1.GetValueAsString(Id) = 'nil' then + Exit; + + for I:=0 to K - 1 do + begin + S := OwnerName + '.' + PaxCompilerExplorer1.GetFieldName(Id, I); + S := ' ' + S + '=' + PaxCompilerDebugger1.GetFieldValueAsString( + StackFrameNumber, Id, I); + Output(S); + end; + end; + + procedure AddPublishedProps(StackFrameNumber, Id: Integer); + var + I, K: Integer; + OwnerName, S: String; + begin + K := PaxCompilerExplorer1.GetPublishedPropCount(Id); + if K = 0 then + Exit; + + OwnerName := PaxCompilerExplorer1.Names[Id]; + if PaxCompilerDebugger1.GetValueAsString(Id) = 'nil' then + Exit; + + for I:=0 to K - 1 do + begin + S := OwnerName + '.' + PaxCompilerExplorer1.GetPublishedPropName(Id, I); + S := ' ' + S + '=' + PaxCompilerDebugger1.GetPublishedPropValueAsString( + StackFrameNumber, Id, I); + Output(S); + end; + end; + + procedure AddArrayElements(StackFrameNumber, Id: Integer); + var + I, K1, K2: Integer; + OwnerName, S: String; + begin + if not PaxCompilerExplorer1.HasArrayType(Id) then + Exit; + + K1 := PaxCompilerExplorer1.GetArrayLowBound(Id); + K2 := PaxCompilerExplorer1.GetArrayHighBound(Id); + + OwnerName := PaxCompilerExplorer1.Names[Id]; + + for I:=K1 to K2 do + begin + S := OwnerName + '[' + IntToStr(I) + ']'; + S := ' ' + S + '=' + PaxCompilerDebugger1.GetArrayItemValueAsString( + StackFrameNumber, Id, I); + Output(S); + end; + end; + + procedure AddDynArrayElements(StackFrameNumber, Id: Integer); + var + I, L: Integer; + OwnerName, S: String; + begin + if not PaxCompilerExplorer1.HasDynArrayType(Id) then + Exit; + + L := PaxCompilerDebugger1.GetDynArrayLength(StackFrameNumber, Id); + + OwnerName := PaxCompilerExplorer1.Names[Id]; + + for I:=0 to L - 1 do + begin + S := OwnerName + '[' + IntToStr(I) + ']'; + S := ' ' + S + '=' + PaxCompilerDebugger1.GetDynArrayItemValueAsString( + StackFrameNumber, Id, I); + Output(S); + end; + end; + +var + SourceLineNumber: Integer; + ModuleName: String; + StackFrameNumber, J, K, SubId, Id: Integer; + S, V: String; + CallStackLineNumber: Integer; + CallStackModuleName: String; +begin + ClearOutput; + if PaxCompilerDebugger1.IsPaused then + begin + ModuleName := PaxCompilerDebugger1.ModuleName; + SourceLineNumber := PaxCompilerDebugger1.SourceLineNumber; + + Output('Paused at line ' + IntTosTr(SourceLineNumber)); + Output(PaxCompiler1.Modules[ModuleName][SourceLineNumber]); + Output('------------------------------------------------------'); + + if PaxCompilerDebugger1.CallStackCount > 0 then + begin + Output('Call stack:'); + for StackFrameNumber:=0 to PaxCompilerDebugger1.CallStackCount - 1 do + begin + SubId := PaxCompilerDebugger1.CallStack[StackFrameNumber]; + S := '('; + K := PaxCompilerExplorer1.GetParamCount(SubId); + for J:=0 to K - 1 do + begin + Id := PaxCompilerExplorer1.GetParamId(SubId, J); + V := PaxCompilerDebugger1.GetValueAsString(StackFrameNumber, Id); + S := S + V; + if J < K - 1 then + S := S + ','; + end; + S := PaxCompilerExplorer1.Names[SubId] + S + ')'; + + CallStackLineNumber := PaxCompilerDebugger1.CallStackLineNumber[StackFrameNumber]; + CallStackModuleName := PaxCompilerDebugger1.CallStackModuleName[StackFrameNumber]; + + S := S + '; // ' + PaxCompiler1.Modules[CallStackModuleName][CallStackLineNumber]; + + Output(S); + end; + Output('------------------------------------------------------'); + + Output('Local scope:'); + StackFrameNumber := PaxCompilerDebugger1.CallStackCount - 1; + SubId := PaxCompilerDebugger1.CallStack[StackFrameNumber]; + K := PaxCompilerExplorer1.GetLocalCount(SubId); + for J:=0 to K - 1 do + begin + Id := PaxCompilerExplorer1.GetLocalId(SubId, J); + V := PaxCompilerDebugger1.GetValueAsString(StackFrameNumber, Id); + S := PaxCompilerExplorer1.Names[Id] + '=' + V; + Output(S); + + if Pos('X', S) > 0 then + begin + PaxCompilerDebugger1.PutValue(StackFrameNumber, Id, 258); + + V := PaxCompilerDebugger1.GetValueAsString(StackFrameNumber, Id); + S := PaxCompilerExplorer1.Names[Id] + '=' + V; + S := S + ' // modified'; + Output(S); + end; + + AddFields(StackFrameNumber, Id); + AddPublishedProps(StackFrameNumber, Id); + AddArrayElements(StackFrameNumber, Id); + AddDynArrayElements(StackFrameNumber, Id); + end; + + Output('------------------------------------------------------'); + end; + + Output('Global scope:'); + K := PaxCompilerExplorer1.GetGlobalCount(0); + for J:=0 to K - 1 do + begin + Id := PaxCompilerExplorer1.GetGlobalId(0, J); + V := PaxCompilerDebugger1.GetValueAsString(Id); + S := PaxCompilerExplorer1.Names[Id] + '=' + V; + Output(S); + + AddFields(0, Id); + AddPublishedProps(0, Id); + AddArrayElements(0, Id); + AddDynArrayElements(0, Id); + end; + Output('------------------------------------------------------'); + + end + else + Output('Finished'); + + Memo2.SelStart := 0; + Memo2.SelLength := 0; +end; + +end. diff --git a/Sources/Android/Demos/Hello/Project1.dpr b/Sources/Android/Demos/Hello/Project1.dpr new file mode 100644 index 0000000..3ac7d4f --- /dev/null +++ b/Sources/Android/Demos/Hello/Project1.dpr @@ -0,0 +1,14 @@ +program Project1; + +uses + System.StartUpCopy, + FMX.Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Sources/Android/Demos/Hello/Project1.dproj b/Sources/Android/Demos/Hello/Project1.dproj new file mode 100644 index 0000000..c9212a2 --- /dev/null +++ b/Sources/Android/Demos/Hello/Project1.dproj @@ -0,0 +1,271 @@ + + + {69F9C8A8-F413-48F1-8B31-6A84FC32AAD6} + 15.2 + FMX + Project1.dpr + True + Debug + Win32 + 89 + Application + + + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Cfg_1 + true + true + + + true + Base + true + + + true + true + true + System;Xml;Data;Datasnap;Web;Soap;$(DCC_Namespace) + true + true + true + true + true + true + true + .\$(Platform)\$(Config) + .\$(Platform)\$(Config) + false + false + false + false + false + + + $(BDS)\bin\Artwork\Android\FM_LauncherIcon_36x36.png + true + FireDACSqliteDriver;DBXSqliteDriver;fmx;IndySystem;DBXInterBaseDriver;DataSnapClient;DataSnapCommon;paxcomp_xe5;DataSnapProviderClient;DbxCommonDriver;dbxcds;fmxFireDAC;CustomIPTransport;dsnap;IndyCore;IndyIPCommon;CloudService;FmxTeeUI;FireDACIBDriver;FireDACDBXDriver;bindcompfmx;rtl;dbrtl;DbxClientDriver;FireDACCommon;bindcomp;xmlrtl;ibxpress;IndyProtocols;FireDACCommonDriver;bindengine;soaprtl;bindcompdbx;FMXTee;FireDAC;FireDACDataSnapDriver;inet;RESTComponents;dbexpress;IndyIPClient;$(DCC_UsePackage) + $(BDS)\bin\Artwork\Android\FM_LauncherIcon_72x72.png + $(BDS)\bin\Artwork\Android\FM_LauncherIcon_96x96.png + Debug + $(BDS)\bin\Artwork\Android\FM_LauncherIcon_144x144.png + package=com.embarcadero.$(MSBuildProjectName);label=$(MSBuildProjectName);versionCode=1;versionName=1.0.0;persistent=False;restoreAnyVersion=False;installLocation=preferExternal;largeHeap=False;theme=TitleBar + $(BDS)\bin\Artwork\Android\FM_LauncherIcon_48x48.png + + + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_768x1004.png + iPhoneAndiPad + $(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_40x40.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImage_640x1136.png + $(MSBuildProjectName) + $(BDS)\bin\Artwork\iOS\iPad\FM_SettingIcon_58x58.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_1024x748.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SettingIcon_29x29.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_60x60.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_50x50.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_80x80.png + FireDACSqliteDriver;DBXSqliteDriver;fmx;IndySystem;DBXInterBaseDriver;DataSnapClient;DataSnapCommon;DataSnapProviderClient;DbxCommonDriver;dbxcds;fmxFireDAC;CustomIPTransport;dsnap;fmxase;IndyCore;IndyIPCommon;CloudService;FmxTeeUI;FireDACIBDriver;FireDACDBXDriver;bindcompfmx;rtl;dbrtl;DbxClientDriver;FireDACCommon;bindcomp;xmlrtl;ibxpress;IndyProtocols;FireDACCommonDriver;bindengine;soaprtl;bindcompdbx;FMXTee;FireDAC;FireDACDataSnapDriver;inet;RESTComponents;dbexpress;IndyIPClient;$(DCC_UsePackage) + $(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_40x40.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImage_640x960.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_57x57.png + $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_72x72.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImage_320x480.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_1024x768.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_80x80.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_58x58.png + $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_152x152.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_1536x2008.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_2048x1496.png + $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_76x76.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_768x1024.png + Debug + $(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_29x29.png + $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_144x144.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_2048x1536.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_100x100.png + true + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_1536x2048.png + CFBundleName=$(MSBuildProjectName);CFBundleDevelopmentRegion=en;CFBundleDisplayName=$(MSBuildProjectName);CFBundleIdentifier=$(MSBuildProjectName);CFBundleInfoDictionaryVersion=6.0;CFBundleVersion=1.0.0.0;CFBundlePackageType=APPL;CFBundleSignature=????;LSRequiresIPhoneOS=true;CFBundleAllowMixedLocalizations=YES;CFBundleExecutable=$(MSBuildProjectName);UIDeviceFamily=iPhone & iPad;CFBundleResourceSpecification=ResourceRules.plist + $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_114x114.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_120x120.png + + + $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImage_640x1136.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_768x1004.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_60x60.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_40x40.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SettingIcon_29x29.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SettingIcon_58x58.png + iPhoneAndiPad + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_1024x748.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_50x50.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_80x80.png + FireDACSqliteDriver;DBXSqliteDriver;fmx;IndySystem;DBXInterBaseDriver;DataSnapClient;DataSnapCommon;DataSnapProviderClient;DbxCommonDriver;dbxcds;fmxFireDAC;CustomIPTransport;dsnap;fmxase;IndyCore;IndyIPCommon;CloudService;FmxTeeUI;FireDACIBDriver;FireDACDBXDriver;bindcompfmx;rtl;dbrtl;DbxClientDriver;FireDACCommon;bindcomp;xmlrtl;ibxpress;IndyProtocols;FireDACCommonDriver;bindengine;soaprtl;bindcompdbx;FMXTee;FireDAC;FireDACDataSnapDriver;inet;RESTComponents;dbexpress;IndyIPClient;$(DCC_UsePackage) + $(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_40x40.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImage_640x960.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_57x57.png + $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_72x72.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImage_320x480.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_1024x768.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_1536x2008.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_80x80.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_29x29.png + $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_152x152.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_2048x1496.png + $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_76x76.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_58x58.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_768x1024.png + $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_144x144.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_2048x1536.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_100x100.png + true + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_1536x2048.png + CFBundleName=$(MSBuildProjectName);CFBundleDevelopmentRegion=en;CFBundleDisplayName=$(MSBuildProjectName);CFBundleIdentifier=$(MSBuildProjectName);CFBundleInfoDictionaryVersion=6.0;CFBundleVersion=1.0.0.0;CFBundlePackageType=APPL;CFBundleSignature=????;LSRequiresIPhoneOS=true;CFBundleAllowMixedLocalizations=YES;CFBundleExecutable=$(MSBuildProjectName);UIDeviceFamily=iPhone & iPad;CFBundleResourceSpecification=ResourceRules.plist + $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_114x114.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_120x120.png + + + true + 1033 + FireDACSqliteDriver;DBXSqliteDriver;FireDACPgDriver;fmx;IndySystem;TeeDB;frx19;vclib;inetdbbde;DBXInterBaseDriver;DataSnapClient;DataSnapCommon;DataSnapServer;paxcomp_xe5;DataSnapProviderClient;DBXSybaseASEDriver;DbxCommonDriver;vclimg;dbxcds;DatasnapConnectorsFreePascal;MetropolisUILiveTile;vcldb;vcldsnap;fmxFireDAC;DBXDb2Driver;DBXOracleDriver;CustomIPTransport;vclribbon;dsnap;IndyIPServer;fmxase;vcl;IndyCore;IndyIPCommon;CloudService;DBXMSSQLDriver;FmxTeeUI;FireDACIBDriver;CodeSiteExpressPkg;FireDACDBXDriver;inetdbxpress;webdsnap;frxe19;FireDACDb2Driver;adortl;frxDB19;FireDACASADriver;bindcompfmx;vcldbx;FireDACODBCDriver;rtl;dbrtl;DbxClientDriver;FireDACCommon;bindcomp;inetdb;Tee;DBXOdbcDriver;vclFireDAC;xmlrtl;svnui;ibxpress;IndyProtocols;DBXMySQLDriver;FireDACCommonDriver;bindengine;vclactnband;soaprtl;bindcompdbx;FMXTee;TeeUI;bindcompvcl;vclie;FireDACADSDriver;vcltouch;VclSmp;FireDACMSSQLDriver;FireDAC;VCLRESTComponents;Intraweb;DBXInformixDriver;DataSnapConnectors;FireDACDataSnapDriver;dsnapcon;DBXFirebirdDriver;inet;fmxobj;FireDACMySQLDriver;vclx;svn;DBXSybaseASADriver;FireDACOracleDriver;fmxdae;RESTComponents;bdertl;FireDACMSAccDriver;DataSnapIndy10ServerTransport;dbexpress;IndyIPClient;$(DCC_UsePackage) + $(BDS)\bin\default_app.manifest + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments= + Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) + + + DEBUG;$(DCC_Define) + true + false + true + true + true + + + false + + + false + RELEASE;$(DCC_Define) + 0 + 0 + + + + MainSource + + +
Form1
+ fmx + + + Cfg_2 + Base + + + Base + + + Cfg_1 + Base + + + + Delphi.Personality.12 + + + + + False + False + 1 + 0 + 0 + 0 + False + False + False + False + False + 1033 + 1252 + + + + + 1.0.0.0 + + + + + + 1.0.0.0 + + + + + + + + + + + + + + + + + + + + + + + + + + + Project1.dpr + + + + + True + True + True + True + + + 12 + + + + diff --git a/Sources/Android/Demos/Hello/Project1.res b/Sources/Android/Demos/Hello/Project1.res new file mode 100644 index 0000000..5e7322a Binary files /dev/null and b/Sources/Android/Demos/Hello/Project1.res differ diff --git a/Sources/Android/Demos/Hello/Unit1.fmx b/Sources/Android/Demos/Hello/Unit1.fmx new file mode 100644 index 0000000..e84e972 --- /dev/null +++ b/Sources/Android/Demos/Hello/Unit1.fmx @@ -0,0 +1,50 @@ +object Form1: TForm1 + Left = 0 + Top = 0 + Caption = 'Form1' + ClientHeight = 567 + ClientWidth = 384 + FormFactor.Width = 320 + FormFactor.Height = 480 + FormFactor.Devices = [dkDesktop] + DesignerMobile = True + DesignerWidth = 384 + DesignerHeight = 592 + DesignerDeviceName = 'Google Nexus 4' + DesignerOrientation = 0 + DesignerOSVersion = '' + object Button1: TButton + Height = 44.000000000000000000 + Position.X = 16.000000000000000000 + Position.Y = 16.000000000000000000 + TabOrder = 0 + Text = 'Say Hello' + Trimming = ttCharacter + Width = 145.000000000000000000 + OnClick = Button1Click + end + object Memo1: TMemo + Touch.InteractiveGestures = [igPan, igLongTap, igDoubleTap] + Height = 129.000000000000000000 + Position.X = 16.000000000000000000 + Position.Y = 160.000000000000000000 + TabOrder = 1 + Width = 265.000000000000000000 + Lines.Strings = ( + 'uses Unit1;' + 'begin' + ' Form1.Button1.Text := '#39'Hello'#39';' + 'end.' + '') + end + object Button2: TButton + Height = 44.000000000000000000 + Position.X = 200.000000000000000000 + Position.Y = 16.000000000000000000 + TabOrder = 2 + Text = 'Exit' + Trimming = ttCharacter + Width = 73.000000000000000000 + OnClick = Button2Click + end +end diff --git a/Sources/Android/Demos/Hello/Unit1.pas b/Sources/Android/Demos/Hello/Unit1.pas new file mode 100644 index 0000000..963804a --- /dev/null +++ b/Sources/Android/Demos/Hello/Unit1.pas @@ -0,0 +1,94 @@ +unit Unit1; + +interface + +uses + System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants, + FMX.StdCtrls, + FMX.Memo, + FMX.Types, FMX.Controls, FMX.Forms, FMX.Graphics, FMX.Dialogs, + FMX.Layouts, +{$IFDEF ANDROID} + FMX.Platform.Android, +{$ENDIF} + PaxCompiler, PaxRunner, PaxInterpreter; + +type + TForm1 = class(TForm) + Button1: TButton; + Memo1: TMemo; + Button2: TButton; + procedure Button1Click(Sender: TObject); + procedure Button2Click(Sender: TObject); + private + { Private declarations } + procedure DoImportGlobalMembers(Sender: TPaxCompiler); + function DoUsedUnit(Sender: TPaxCompiler; + const UnitName: string; var SourceCode: string): Boolean; + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.fmx} + +procedure TForm1.Button2Click(Sender: TObject); +begin +{$IFDEF ANDROID} + MainActivity.finish; +{$ELSE} + Close; +{$ENDIF} +end; + +procedure TForm1.DoImportGlobalMembers(Sender: TPaxCompiler); +begin +// Global members must be imported explicitly. + + Sender.RegisterVariable(0, 'Form1: TForm1', @Form1); +end; + +function TForm1.DoUsedUnit(Sender: TPaxCompiler; + const UnitName: string; var SourceCode: string): Boolean; +begin +// Use OnUsedUnit event to prevent loading Unit1.pas from disk. +// We are going to import types of Unit1.pas, not to compile the unit. + result := false; +end; + +procedure TForm1.Button1Click(Sender: TObject); +var + PaxCompiler1: TPaxCompiler; + PaxInterpreter1: TPaxInterpreter; + PaxPascalLanguage1: TPaxPascalLanguage; +begin + PaxCompiler1 := TPaxCompiler.Create(nil); + PaxInterpreter1 := TPaxInterpreter.Create(nil); + PaxPascalLanguage1 := TPaxPascalLanguage.Create(nil); + try + PaxCompiler1.OnImportGlobalMembers := DoImportGlobalMembers; + PaxCompiler1.OnUsedUnit := DoUsedUnit; + + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + PaxCompiler1.AddModule('1', 'Pascal'); + PaxCompiler1.AddCode('1', Memo1.Lines.Text); + if PaxCompiler1.Compile(PaxInterpreter1) then + begin + PaxInterpreter1.Run; + end + else + begin + ShowMessage(PaxCompiler1.ErrorMessage[0]); + end; + finally + FreeAndNil(PaxCompiler1); + FreeAndNil(PaxInterpreter1); + FreeAndNil(PaxPascalLanguage1); + end; +end; + +end. diff --git a/Sources/Android/Demos/OperatorOverloading/Project1.dpr b/Sources/Android/Demos/OperatorOverloading/Project1.dpr new file mode 100644 index 0000000..3ac7d4f --- /dev/null +++ b/Sources/Android/Demos/OperatorOverloading/Project1.dpr @@ -0,0 +1,14 @@ +program Project1; + +uses + System.StartUpCopy, + FMX.Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Sources/Android/Demos/OperatorOverloading/Project1.dproj b/Sources/Android/Demos/OperatorOverloading/Project1.dproj new file mode 100644 index 0000000..c384e40 --- /dev/null +++ b/Sources/Android/Demos/OperatorOverloading/Project1.dproj @@ -0,0 +1,271 @@ + + + {C55C11A6-3E14-4B9B-9595-24B90ECB6C08} + 15.2 + FMX + Project1.dpr + True + Debug + Win32 + 89 + Application + + + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Cfg_1 + true + true + + + true + Base + true + + + true + true + true + System;Xml;Data;Datasnap;Web;Soap;$(DCC_Namespace) + true + true + true + true + true + true + true + .\$(Platform)\$(Config) + .\$(Platform)\$(Config) + false + false + false + false + false + + + $(BDS)\bin\Artwork\Android\FM_LauncherIcon_36x36.png + true + FireDACSqliteDriver;DBXSqliteDriver;fmx;IndySystem;DBXInterBaseDriver;DataSnapClient;DataSnapCommon;paxcomp_xe5;DataSnapProviderClient;DbxCommonDriver;dbxcds;fmxFireDAC;CustomIPTransport;dsnap;IndyCore;IndyIPCommon;CloudService;FmxTeeUI;FireDACIBDriver;FireDACDBXDriver;bindcompfmx;rtl;dbrtl;DbxClientDriver;FireDACCommon;bindcomp;xmlrtl;ibxpress;IndyProtocols;FireDACCommonDriver;bindengine;soaprtl;bindcompdbx;FMXTee;FireDAC;FireDACDataSnapDriver;inet;RESTComponents;dbexpress;IndyIPClient;$(DCC_UsePackage) + $(BDS)\bin\Artwork\Android\FM_LauncherIcon_72x72.png + $(BDS)\bin\Artwork\Android\FM_LauncherIcon_96x96.png + Debug + $(BDS)\bin\Artwork\Android\FM_LauncherIcon_144x144.png + package=com.embarcadero.$(MSBuildProjectName);label=$(MSBuildProjectName);versionCode=1;versionName=1.0.0;persistent=False;restoreAnyVersion=False;installLocation=preferExternal;largeHeap=False;theme=TitleBar + $(BDS)\bin\Artwork\Android\FM_LauncherIcon_48x48.png + + + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_768x1004.png + iPhoneAndiPad + $(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_40x40.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImage_640x1136.png + $(MSBuildProjectName) + $(BDS)\bin\Artwork\iOS\iPad\FM_SettingIcon_58x58.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_1024x748.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SettingIcon_29x29.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_60x60.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_50x50.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_80x80.png + FireDACSqliteDriver;DBXSqliteDriver;fmx;IndySystem;DBXInterBaseDriver;DataSnapClient;DataSnapCommon;DataSnapProviderClient;DbxCommonDriver;dbxcds;fmxFireDAC;CustomIPTransport;dsnap;fmxase;IndyCore;IndyIPCommon;CloudService;FmxTeeUI;FireDACIBDriver;FireDACDBXDriver;bindcompfmx;rtl;dbrtl;DbxClientDriver;FireDACCommon;bindcomp;xmlrtl;ibxpress;IndyProtocols;FireDACCommonDriver;bindengine;soaprtl;bindcompdbx;FMXTee;FireDAC;FireDACDataSnapDriver;inet;RESTComponents;dbexpress;IndyIPClient;$(DCC_UsePackage) + $(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_40x40.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImage_640x960.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_57x57.png + $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_72x72.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImage_320x480.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_1024x768.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_80x80.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_58x58.png + $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_152x152.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_1536x2008.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_2048x1496.png + $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_76x76.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_768x1024.png + Debug + $(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_29x29.png + $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_144x144.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_2048x1536.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_100x100.png + true + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_1536x2048.png + CFBundleName=$(MSBuildProjectName);CFBundleDevelopmentRegion=en;CFBundleDisplayName=$(MSBuildProjectName);CFBundleIdentifier=$(MSBuildProjectName);CFBundleInfoDictionaryVersion=6.0;CFBundleVersion=1.0.0.0;CFBundlePackageType=APPL;CFBundleSignature=????;LSRequiresIPhoneOS=true;CFBundleAllowMixedLocalizations=YES;CFBundleExecutable=$(MSBuildProjectName);UIDeviceFamily=iPhone & iPad;CFBundleResourceSpecification=ResourceRules.plist + $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_114x114.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_120x120.png + + + $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImage_640x1136.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_768x1004.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_60x60.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_40x40.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SettingIcon_29x29.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SettingIcon_58x58.png + iPhoneAndiPad + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_1024x748.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_50x50.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_80x80.png + FireDACSqliteDriver;DBXSqliteDriver;fmx;IndySystem;DBXInterBaseDriver;DataSnapClient;DataSnapCommon;DataSnapProviderClient;DbxCommonDriver;dbxcds;fmxFireDAC;CustomIPTransport;dsnap;fmxase;IndyCore;IndyIPCommon;CloudService;FmxTeeUI;FireDACIBDriver;FireDACDBXDriver;bindcompfmx;rtl;dbrtl;DbxClientDriver;FireDACCommon;bindcomp;xmlrtl;ibxpress;IndyProtocols;FireDACCommonDriver;bindengine;soaprtl;bindcompdbx;FMXTee;FireDAC;FireDACDataSnapDriver;inet;RESTComponents;dbexpress;IndyIPClient;$(DCC_UsePackage) + $(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_40x40.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImage_640x960.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_57x57.png + $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_72x72.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImage_320x480.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_1024x768.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_1536x2008.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_80x80.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_29x29.png + $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_152x152.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_2048x1496.png + $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_76x76.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_58x58.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_768x1024.png + $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_144x144.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_2048x1536.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_100x100.png + true + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_1536x2048.png + CFBundleName=$(MSBuildProjectName);CFBundleDevelopmentRegion=en;CFBundleDisplayName=$(MSBuildProjectName);CFBundleIdentifier=$(MSBuildProjectName);CFBundleInfoDictionaryVersion=6.0;CFBundleVersion=1.0.0.0;CFBundlePackageType=APPL;CFBundleSignature=????;LSRequiresIPhoneOS=true;CFBundleAllowMixedLocalizations=YES;CFBundleExecutable=$(MSBuildProjectName);UIDeviceFamily=iPhone & iPad;CFBundleResourceSpecification=ResourceRules.plist + $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_114x114.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_120x120.png + + + true + 1033 + FireDACSqliteDriver;DBXSqliteDriver;FireDACPgDriver;fmx;IndySystem;TeeDB;frx19;vclib;inetdbbde;DBXInterBaseDriver;DataSnapClient;DataSnapCommon;DataSnapServer;paxcomp_xe5;DataSnapProviderClient;DBXSybaseASEDriver;DbxCommonDriver;vclimg;dbxcds;DatasnapConnectorsFreePascal;MetropolisUILiveTile;vcldb;vcldsnap;fmxFireDAC;DBXDb2Driver;DBXOracleDriver;CustomIPTransport;vclribbon;dsnap;IndyIPServer;fmxase;vcl;IndyCore;IndyIPCommon;CloudService;DBXMSSQLDriver;FmxTeeUI;FireDACIBDriver;CodeSiteExpressPkg;FireDACDBXDriver;inetdbxpress;webdsnap;frxe19;FireDACDb2Driver;adortl;frxDB19;FireDACASADriver;bindcompfmx;vcldbx;FireDACODBCDriver;rtl;dbrtl;DbxClientDriver;FireDACCommon;bindcomp;inetdb;Tee;DBXOdbcDriver;vclFireDAC;xmlrtl;svnui;ibxpress;IndyProtocols;DBXMySQLDriver;FireDACCommonDriver;bindengine;vclactnband;soaprtl;bindcompdbx;FMXTee;TeeUI;bindcompvcl;vclie;FireDACADSDriver;vcltouch;VclSmp;FireDACMSSQLDriver;FireDAC;VCLRESTComponents;Intraweb;DBXInformixDriver;DataSnapConnectors;FireDACDataSnapDriver;dsnapcon;DBXFirebirdDriver;inet;fmxobj;FireDACMySQLDriver;vclx;svn;DBXSybaseASADriver;FireDACOracleDriver;fmxdae;RESTComponents;bdertl;FireDACMSAccDriver;DataSnapIndy10ServerTransport;dbexpress;IndyIPClient;$(DCC_UsePackage) + $(BDS)\bin\default_app.manifest + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments= + Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) + + + DEBUG;$(DCC_Define) + true + false + true + true + true + + + false + + + false + RELEASE;$(DCC_Define) + 0 + 0 + + + + MainSource + + +
Form1
+ fmx + + + Cfg_2 + Base + + + Base + + + Cfg_1 + Base + + + + Delphi.Personality.12 + + + + + False + False + 1 + 0 + 0 + 0 + False + False + False + False + False + 1033 + 1252 + + + + + 1.0.0.0 + + + + + + 1.0.0.0 + + + + + + + + + + + + + + + + + + + + + + + + + + + Project1.dpr + + + + + True + True + True + True + + + 12 + + + + diff --git a/Sources/Android/Demos/OperatorOverloading/Project1.res b/Sources/Android/Demos/OperatorOverloading/Project1.res new file mode 100644 index 0000000..5e7322a Binary files /dev/null and b/Sources/Android/Demos/OperatorOverloading/Project1.res differ diff --git a/Sources/Android/Demos/OperatorOverloading/Unit1.fmx b/Sources/Android/Demos/OperatorOverloading/Unit1.fmx new file mode 100644 index 0000000..a1363ec --- /dev/null +++ b/Sources/Android/Demos/OperatorOverloading/Unit1.fmx @@ -0,0 +1,69 @@ +object Form1: TForm1 + Left = 0 + Top = 0 + Caption = 'Form1' + ClientHeight = 567 + ClientWidth = 384 + FormFactor.Width = 320 + FormFactor.Height = 480 + FormFactor.Devices = [dkDesktop] + DesignerMobile = True + DesignerWidth = 384 + DesignerHeight = 592 + DesignerDeviceName = 'Google Nexus 4' + DesignerOrientation = 0 + DesignerOSVersion = '' + object Memo1: TMemo + Touch.InteractiveGestures = [igPan, igLongTap, igDoubleTap] + Height = 385.000000000000000000 + Position.X = 24.000000000000000000 + Position.Y = -104.000000000000000000 + TabOrder = 0 + Width = 281.000000000000000000 + Lines.Strings = ( + 'uses Unit1;' + 'var U, V: TMyRecord; I: Integer;' + 'begin' + ' print '#39'Output:'#39';' + ' V := TMyRecord(4); // explicit type cast' + ' I := Integer(V); // explicit type cast' + ' print I;' + ' U := 3; // implicit type cast' + ' V.x := 1;' + ' V.y := 2;' + ' U := U + V; // operation of addition' + ' print U.X, U.Y;' + ' I := V;' + ' print I;' + 'end.' + '') + end + object Button1: TButton + Height = 44.000000000000000000 + Position.X = 16.000000000000000000 + Position.Y = 408.000000000000000000 + TabOrder = 1 + Text = 'Run' + Trimming = ttCharacter + Width = 73.000000000000000000 + OnClick = Button1Click + end + object Memo2: TMemo + Touch.InteractiveGestures = [igPan, igLongTap, igDoubleTap] + Height = 105.000000000000000000 + Position.X = 24.000000000000000000 + Position.Y = 296.000000000000000000 + TabOrder = 2 + Width = 273.000000000000000000 + end + object Button2: TButton + Height = 44.000000000000000000 + Position.X = 104.000000000000000000 + Position.Y = 408.000000000000000000 + TabOrder = 3 + Text = 'Exit' + Trimming = ttCharacter + Width = 73.000000000000000000 + OnClick = Button2Click + end +end diff --git a/Sources/Android/Demos/OperatorOverloading/Unit1.pas b/Sources/Android/Demos/OperatorOverloading/Unit1.pas new file mode 100644 index 0000000..96a2e7a --- /dev/null +++ b/Sources/Android/Demos/OperatorOverloading/Unit1.pas @@ -0,0 +1,145 @@ +unit Unit1; + +interface + +uses + System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants, + FMX.Types, FMX.Controls, FMX.Forms, FMX.Graphics, FMX.Dialogs, FMX.StdCtrls, +{$IFDEF ANDROID} + FMX.Platform.Android, +{$ENDIF} + FMX.Layouts, FMX.Memo, PaxCompiler, PaxRunner, PaxInterpreter; + +type + TForm1 = class(TForm) + Memo1: TMemo; + Button1: TButton; + Memo2: TMemo; + Button2: TButton; + procedure Button1Click(Sender: TObject); + procedure Button2Click(Sender: TObject); + private + { Private declarations } + procedure DoPrint(Sender: TPaxRunner; const S: String); + function DoUsedUnit(Sender: TPaxCompiler; + const UnitName: string; var SourceCode: string): Boolean; + public + { Public declarations } + end; + + TMyRecord = record + x, y: Integer; + class operator Add(a, b: TMyRecord): TMyRecord; + class operator Subtract(a, b: TMyRecord): TMyRecord; + class operator Implicit(a: Integer): TMyRecord; + class operator Implicit(a: TMyRecord): Integer; + class operator Explicit(a: Integer): TMyRecord; + class operator Explicit(a: TMyRecord): Integer; + class operator Explicit(a: TMyRecord): Double; + end; + +var + Form1: TForm1; + +implementation + +{$R *.fmx} + +class operator TMyRecord.Add(a, b: TMyRecord): TMyRecord; +begin + result.x := a.x + b.x; + result.y := a.y + b.y; +end; + +class operator TMyRecord.Subtract(a, b: TMyRecord): TMyRecord; +begin + result.x := a.x - b.x; + result.y := a.y - b.y; +end; + +class operator TMyRecord.Implicit(a: Integer): TMyRecord; +begin + result.x := a; + result.y := 0; +end; + +class operator TMyRecord.Implicit(a: TMyRecord): Integer; +begin + result := a.x; +end; + +class operator TMyRecord.Explicit(a: Integer): TMyRecord; +begin + result.x := a; + result.y := 0; +end; + +class operator TMyRecord.Explicit(a: TMyRecord): Integer; +begin + result := a.x; +end; + +class operator TMyRecord.Explicit(a: TMyRecord): Double; +begin + result := a.x; +end; + +procedure TForm1.Button2Click(Sender: TObject); +begin +{$IFDEF ANDROID} + MainActivity.finish; +{$ELSE} + Close; +{$ENDIF} +end; + +procedure TForm1.DoPrint(Sender: TPaxRunner; const S: String); +begin + Memo2.Lines.Add(S); +end; + +procedure Dummy(P: Pointer); begin end; + +function TForm1.DoUsedUnit(Sender: TPaxCompiler; + const UnitName: string; var SourceCode: string): Boolean; +begin +// Use OnUsedUnit event to prevent loading Unit1.pas from disk. +// We are going to import types of Unit1.pas, not to compile the unit. + result := false; +end; + +procedure TForm1.Button1Click(Sender: TObject); +var + PaxCompiler1: TPaxCompiler; + PaxInterpreter1: TPaxInterpreter; + PaxPascalLanguage1: TPaxPascalLanguage; +begin + Dummy(TypeInfo(TMyRecord)); // just to punish Delphi to create RTTI for TMyRecord + + PaxCompiler1 := TPaxCompiler.Create(nil); + PaxInterpreter1 := TPaxInterpreter.Create(nil); + PaxPascalLanguage1 := TPaxPascalLanguage.Create(nil); + + PaxCompiler1.OnUsedUnit := DoUsedUnit; + + try + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + PaxCompiler1.AddModule('1', 'Pascal'); + PaxCompiler1.AddCode('1', Memo1.Lines.Text); + if PaxCompiler1.Compile(PaxInterpreter1) then + begin + PaxInterpreter1.OnPrintEvent := DoPrint; + PaxInterpreter1.Run; + end + else + begin + ShowMessage(PaxCompiler1.ErrorMessage[0]); + end; + finally + FreeAndNil(PaxCompiler1); + FreeAndNil(PaxInterpreter1); + FreeAndNil(PaxPascalLanguage1); + end; +end; + +end. diff --git a/Sources/Android/Demos/ScriptClass/Project1.dpr b/Sources/Android/Demos/ScriptClass/Project1.dpr new file mode 100644 index 0000000..3ac7d4f --- /dev/null +++ b/Sources/Android/Demos/ScriptClass/Project1.dpr @@ -0,0 +1,14 @@ +program Project1; + +uses + System.StartUpCopy, + FMX.Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Sources/Android/Demos/ScriptClass/Project1.dproj b/Sources/Android/Demos/ScriptClass/Project1.dproj new file mode 100644 index 0000000..549f8ef --- /dev/null +++ b/Sources/Android/Demos/ScriptClass/Project1.dproj @@ -0,0 +1,247 @@ + + + {90EBE9AB-475B-4547-B828-69AF52A85794} + 15.1 + FMX + Project1.dpr + True + Debug + Android + 89 + Application + + + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Cfg_1 + true + true + + + true + Base + true + + + true + true + System;Xml;Data;Datasnap;Web;Soap;$(DCC_Namespace) + true + true + true + true + true + true + true + true + .\$(Platform)\$(Config) + .\$(Platform)\$(Config) + false + false + false + false + false + + + $(BDS)\bin\Artwork\Android\FM_LauncherIcon_72x72.png + $(BDS)\bin\Artwork\Android\FM_LauncherIcon_36x36.png + FireDACSqliteDriver;bindcompfmx;DBXSqliteDriver;fmx;rtl;dbrtl;DbxClientDriver;IndySystem;FireDACCommon;bindcomp;DBXInterBaseDriver;DataSnapClient;DataSnapCommon;paxcomp_xe5;DataSnapProviderClient;xmlrtl;ibxpress;DbxCommonDriver;IndyProtocols;dbxcds;FireDACCommonDriver;bindengine;soaprtl;bindcompdbx;FMXTee;fmxFireDAC;CustomIPTransport;FireDAC;dsnap;IndyCore;FireDACDataSnapDriver;IndyIPCommon;CloudService;FireDACIBDriver;inet;FireDACDBXDriver;FmxTeeUI;RESTComponents;dbexpress;IndyIPClient;$(DCC_UsePackage) + $(BDS)\bin\Artwork\Android\FM_LauncherIcon_48x48.png + $(BDS)\bin\Artwork\Android\FM_LauncherIcon_96x96.png + $(BDS)\bin\Artwork\Android\FM_LauncherIcon_144x144.png + true + package=com.embarcadero.$(MSBuildProjectName);label=$(MSBuildProjectName);versionCode=1;versionName=1.0.0;persistent=False;restoreAnyVersion=False;installLocation=preferExternal;largeHeap=False;theme=TitleBar + Debug + + + FireDACSqliteDriver;bindcompfmx;DBXSqliteDriver;fmx;rtl;dbrtl;DbxClientDriver;IndySystem;FireDACCommon;bindcomp;DBXInterBaseDriver;DataSnapClient;DataSnapCommon;DataSnapProviderClient;xmlrtl;ibxpress;DbxCommonDriver;IndyProtocols;dbxcds;FireDACCommonDriver;bindengine;soaprtl;bindcompdbx;FMXTee;fmxFireDAC;CustomIPTransport;FireDAC;dsnap;fmxase;IndyCore;FireDACDataSnapDriver;IndyIPCommon;CloudService;FireDACIBDriver;inet;FireDACDBXDriver;FmxTeeUI;RESTComponents;dbexpress;IndyIPClient;$(DCC_UsePackage) + $(BDS)\bin\Artwork\iOS\iPad\FM_SettingIcon_58x58.png + iPhoneAndiPad + $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_72x72.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImage_640x1136.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_114x114.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_1024x748.png + $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_144x144.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_58x58.png + $(MSBuildProjectName) + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_2048x1496.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_100x100.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SettingIcon_29x29.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_50x50.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_768x1004.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_1536x2008.png + true + Debug + $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImage_640x960.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImage_320x480.png + CFBundleName=$(MSBuildProjectName);CFBundleDevelopmentRegion=en;CFBundleDisplayName=$(MSBuildProjectName);CFBundleIdentifier=$(MSBuildProjectName);CFBundleInfoDictionaryVersion=6.0;CFBundleVersion=1.0.0.0;CFBundlePackageType=APPL;CFBundleSignature=????;LSRequiresIPhoneOS=true;CFBundleAllowMixedLocalizations=YES;CFBundleExecutable=$(MSBuildProjectName);UIDeviceFamily=iPhone & iPad;CFBundleResourceSpecification=ResourceRules.plist + $(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_29x29.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_57x57.png + + + FireDACSqliteDriver;bindcompfmx;DBXSqliteDriver;fmx;rtl;dbrtl;DbxClientDriver;IndySystem;FireDACCommon;bindcomp;DBXInterBaseDriver;DataSnapClient;DataSnapCommon;DataSnapProviderClient;xmlrtl;ibxpress;DbxCommonDriver;IndyProtocols;dbxcds;FireDACCommonDriver;bindengine;soaprtl;bindcompdbx;FMXTee;fmxFireDAC;CustomIPTransport;FireDAC;dsnap;fmxase;IndyCore;FireDACDataSnapDriver;IndyIPCommon;CloudService;FireDACIBDriver;inet;FireDACDBXDriver;FmxTeeUI;RESTComponents;dbexpress;IndyIPClient;$(DCC_UsePackage) + $(BDS)\bin\Artwork\iOS\iPad\FM_SettingIcon_58x58.png + iPhoneAndiPad + $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_72x72.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImage_640x1136.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_1024x748.png + $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_144x144.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_58x58.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_114x114.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_2048x1496.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_100x100.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SettingIcon_29x29.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_50x50.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_768x1004.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_1536x2008.png + true + $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImage_640x960.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImage_320x480.png + CFBundleName=$(MSBuildProjectName);CFBundleDevelopmentRegion=en;CFBundleDisplayName=$(MSBuildProjectName);CFBundleIdentifier=$(MSBuildProjectName);CFBundleInfoDictionaryVersion=6.0;CFBundleVersion=1.0.0.0;CFBundlePackageType=APPL;CFBundleSignature=????;LSRequiresIPhoneOS=true;CFBundleAllowMixedLocalizations=YES;CFBundleExecutable=$(MSBuildProjectName);UIDeviceFamily=iPhone & iPad;CFBundleResourceSpecification=ResourceRules.plist + $(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_29x29.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_57x57.png + + + $(BDS)\bin\default_app.manifest + Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) + 1033 + true + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments= + DataSnapIndy10ServerTransport;FireDACASADriver;FireDACSqliteDriver;bindcompfmx;DBXSqliteDriver;vcldbx;FireDACPgDriver;FireDACODBCDriver;fmx;rtl;dbrtl;DbxClientDriver;IndySystem;FireDACCommon;bindcomp;inetdb;TeeDB;vclib;inetdbbde;DBXInterBaseDriver;DataSnapClient;DataSnapCommon;DBXOdbcDriver;DataSnapServer;Tee;vclFireDAC;paxcomp_xe5;DataSnapProviderClient;xmlrtl;svnui;ibxpress;DbxCommonDriver;DBXSybaseASEDriver;vclimg;IndyProtocols;dbxcds;DBXMySQLDriver;DatasnapConnectorsFreePascal;FireDACCommonDriver;MetropolisUILiveTile;bindengine;vclactnband;vcldb;soaprtl;bindcompdbx;vcldsnap;bindcompvcl;FMXTee;TeeUI;vclie;fmxFireDAC;FireDACADSDriver;vcltouch;DBXDb2Driver;DBXOracleDriver;CustomIPTransport;vclribbon;VclSmp;FireDACMSSQLDriver;FireDAC;dsnap;Intraweb;fmxase;vcl;IndyCore;FireDACDataSnapDriver;IndyIPServer;IndyIPCommon;VCLRESTComponents;CloudService;dsnapcon;FireDACIBDriver;DBXFirebirdDriver;inet;DBXMSSQLDriver;fmxobj;FireDACDBXDriver;DBXInformixDriver;DataSnapConnectors;FireDACMySQLDriver;FmxTeeUI;vclx;CodeSiteExpressPkg;inetdbxpress;svn;DBXSybaseASADriver;FireDACOracleDriver;fmxdae;FireDACDb2Driver;RESTComponents;bdertl;FireDACMSAccDriver;adortl;dbexpress;IndyIPClient;$(DCC_UsePackage) + + + DEBUG;$(DCC_Define) + true + false + true + true + true + + + false + + + false + RELEASE;$(DCC_Define) + 0 + 0 + + + + MainSource + + +
Form1
+ fmx + + + Cfg_2 + Base + + + Base + + + Cfg_1 + Base + + + + Delphi.Personality.12 + + + + + False + False + 1 + 0 + 0 + 0 + False + False + False + False + False + 1033 + 1252 + + + + + 1.0.0.0 + + + + + + 1.0.0.0 + + + + + + + + + + + + + + + + + + + + + + + + + + + Project1.dpr + + + + + True + True + True + True + + + 12 + + + + diff --git a/Sources/Android/Demos/ScriptClass/Project1.res b/Sources/Android/Demos/ScriptClass/Project1.res new file mode 100644 index 0000000..0739f2f Binary files /dev/null and b/Sources/Android/Demos/ScriptClass/Project1.res differ diff --git a/Sources/Android/Demos/ScriptClass/Unit1.fmx b/Sources/Android/Demos/ScriptClass/Unit1.fmx new file mode 100644 index 0000000..753f655 --- /dev/null +++ b/Sources/Android/Demos/ScriptClass/Unit1.fmx @@ -0,0 +1,76 @@ +object Form1: TForm1 + Left = 0 + Top = 0 + Caption = 'Form2' + ClientHeight = 567 + ClientWidth = 384 + FormFactor.Width = 320 + FormFactor.Height = 480 + FormFactor.Devices = [dkDesktop] + DesignerMobile = True + DesignerWidth = 384 + DesignerHeight = 592 + DesignerDeviceName = 'Google Nexus 4' + DesignerOrientation = 0 + DesignerOSVersion = '' + object Memo1: TMemo + Touch.InteractiveGestures = [igPan, igLongTap, igDoubleTap] + Height = 225.000000000000000000 + Position.X = 8.000000000000000000 + Position.Y = 8.000000000000000000 + TabOrder = 0 + Width = 281.000000000000000000 + Lines.Strings = ( + 'uses' + ' Unit1;' + 'type' + ' TScriptClass = class(TMyClass)' + ' public' + ' procedure P(X, Y: Integer); override;' + ' end;' + 'procedure TScriptClass.P(X, Y: Integer);' + 'begin' + ' print X, Y;' + 'end;' + 'var' + ' I: Integer;' + ' X: TMyClass;' + 'begin' + '// Test global variable' + ' print Form1.ClassName;' + '// Test global procedure' + ' IntegerByRef(I);' + ' print I;' + ' X := TScriptClass.Create;' + ' X.P(3, 4);' + 'end.') + end + object Memo2: TMemo + Touch.InteractiveGestures = [igPan, igLongTap, igDoubleTap] + Height = 106.000000000000000000 + Position.X = 8.000000000000000000 + Position.Y = 240.000000000000000000 + TabOrder = 1 + Width = 281.000000000000000000 + end + object Button1: TButton + Height = 44.000000000000000000 + Position.X = 8.000000000000000000 + Position.Y = 368.000000000000000000 + TabOrder = 2 + Text = 'Run ' + Trimming = ttCharacter + Width = 73.000000000000000000 + OnClick = Button1Click + end + object Button2: TButton + Height = 44.000000000000000000 + Position.X = 104.000000000000000000 + Position.Y = 368.000000000000000000 + TabOrder = 3 + Text = 'Exit' + Trimming = ttCharacter + Width = 73.000000000000000000 + OnClick = Button2Click + end +end diff --git a/Sources/Android/Demos/ScriptClass/Unit1.pas b/Sources/Android/Demos/ScriptClass/Unit1.pas new file mode 100644 index 0000000..d9c697e --- /dev/null +++ b/Sources/Android/Demos/ScriptClass/Unit1.pas @@ -0,0 +1,123 @@ +unit Unit1; + +interface + +uses + System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants, +{$IFDEF ANDROID} + FMX.Platform.Android, +{$ENDIF} + FMX.Types, FMX.Controls, FMX.Forms, FMX.Graphics, FMX.Dialogs, FMX.StdCtrls, + FMX.Layouts, FMX.Memo, + PaxCompiler, PaxRunner, PaxInterpreter; + +type + TForm1 = class(TForm) + Memo1: TMemo; + Memo2: TMemo; + Button1: TButton; + Button2: TButton; + procedure Button2Click(Sender: TObject); + procedure Button1Click(Sender: TObject); + private + { Private declarations } + procedure DoImportGlobalMembers(Sender: TPaxCompiler); + function DoUsedUnit(Sender: TPaxCompiler; + const UnitName: string; var SourceCode: string): Boolean; + procedure DoPrint(Sender: TPaxRunner; const S: String); + public + { Public declarations } + end; + + {$M+} + TMyClass = class + public + procedure P(X, Y: Integer); virtual; abstract; + destructor Destroy; override; + end; + +var + Form1: TForm1; + +implementation + +{$R *.fmx} + +destructor TMyClass.Destroy; +begin + Form1.Memo2.Lines.Add('*** Done ***'); + inherited; +end; + + +procedure IntegerByRef(var I: Integer); +begin + I := 5; +end; + +procedure TForm1.DoImportGlobalMembers(Sender: TPaxCompiler); +begin +// Global members must be imported explicitly. + + Sender.RegisterVariable(0, 'Form1: TForm1', @Form1); + Sender.RegisterHeader(0, + 'procedure IntegerByRef(var I: Integer);', + @ IntegerByRef); +end; + +function TForm1.DoUsedUnit(Sender: TPaxCompiler; + const UnitName: string; var SourceCode: string): Boolean; +begin +// Use OnUsedUnit event to prevent loading Unit1.pas from disk. +// We are going to import types of Unit1.pas, not to compile the unit. + result := false; +end; + +procedure TForm1.DoPrint(Sender: TPaxRunner; const S: String); +begin + Memo2.Lines.Add(S); +end; + +procedure TForm1.Button1Click(Sender: TObject); +var + PaxCompiler1: TPaxCompiler; + PaxInterpreter1: TPaxInterpreter; + PaxLanguage1: TPaxCompilerLanguage; +begin + PaxCompiler1 := TPaxCompiler.Create(nil); + PaxInterpreter1 := TPaxInterpreter.Create(nil); + PaxLanguage1 := TPaxPascalLanguage.Create(nil); + + PaxCompiler1.OnUsedUnit := DoUsedUnit; + PaxCompiler1.OnImportGlobalMembers := DoImportGlobalMembers; + + try + PaxCompiler1.RegisterLanguage(PaxLanguage1); + PaxCompiler1.AddModule('1', 'Pascal'); + PaxCompiler1.AddCode('1', Memo1.Lines.Text); + if PaxCompiler1.Compile(PaxInterpreter1) then + begin + PaxInterpreter1.OnPrintEvent := DoPrint; + PaxInterpreter1.Run; + end + else + begin + ShowMessage(PaxCompiler1.ErrorMessage[0]); + end; + finally + FreeAndNil(PaxCompiler1); + FreeAndNil(PaxInterpreter1); + FreeAndNil(PaxLanguage1); + end; +end; + +procedure TForm1.Button2Click(Sender: TObject); +begin +{$IFDEF ANDROID} + MainActivity.finish; +{$ELSE} + Close; +{$ENDIF} +end; + +end. diff --git a/Sources/Android/packages/D10_1_Berlin/AndroidManifest.template.xml b/Sources/Android/packages/D10_1_Berlin/AndroidManifest.template.xml new file mode 100644 index 0000000..b593684 --- /dev/null +++ b/Sources/Android/packages/D10_1_Berlin/AndroidManifest.template.xml @@ -0,0 +1,42 @@ + + + + + + +<%uses-permission%> + + + +<%application-meta-data%> + <%services%> + + + + + + + + + + <%activity%> + <%receivers%> + + + diff --git a/Sources/Android/packages/D10_1_Berlin/PaxCompilerRegister.pas b/Sources/Android/packages/D10_1_Berlin/PaxCompilerRegister.pas new file mode 100644 index 0000000..21ef041 --- /dev/null +++ b/Sources/Android/packages/D10_1_Berlin/PaxCompilerRegister.pas @@ -0,0 +1,52 @@ +//////////////////////////////////////////////////////////////////////////// +// PaxCompiler +// Site: http://www.paxcompiler.com +// Author: Alexander Baranovsky (paxscript@gmail.com) +// ======================================================================== +// Copyright (c) Alexander Baranovsky, 2006-2014. All rights reserved. +// Code Version: 4.0 +// ======================================================================== +// Unit: PaxCompilerRegister.pas +// ======================================================================== +//////////////////////////////////////////////////////////////////////////// + +{$I PaxCompiler.def} +unit PaxCompilerRegister; + +interface +uses + Classes, + PaxCompiler, +{$IFNDEF INTERPRETER_ONLY} + PaxProgram, + PaxInvoke, +{$ENDIF} + PaxInterpreter, + PaxCompilerDebugger, + PaxCompilerExplorer, + PaxBasicLanguage, + PaxJavaScriptLanguage, + PaxEval; + +procedure Register; + +Implementation + +procedure Register; +begin + RegisterComponents('PaxCompiler', + [TPaxCompiler, + TPaxPascalLanguage, +{$IFNDEF INTERPRETER_ONLY} + TPaxProgram, + TPaxInvoke, +{$ENDIF} + TPaxCompilerDebugger, + TPaxCompilerExplorer, + TPaxBasicLanguage, + TPaxJavaScriptLanguage, + TPaxEval, + TPaxInterpreter]); +end; + +end. diff --git a/Sources/Android/packages/D10_1_Berlin/paxcomp_android_D10_1.dpk b/Sources/Android/packages/D10_1_Berlin/paxcomp_android_D10_1.dpk new file mode 100644 index 0000000..16b20a6 --- /dev/null +++ b/Sources/Android/packages/D10_1_Berlin/paxcomp_android_D10_1.dpk @@ -0,0 +1,39 @@ +package paxcomp_android_D10_1; + +{$R *.res} +{$R 'PaxCompiler.dcr'} +{$IFDEF IMPLICITBUILDING This IFDEF should not be used by users} +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO OFF} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION OFF} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES ON} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$DEFINE DEBUG} +{$ENDIF IMPLICITBUILDING} +{$IMPLICITBUILD ON} + +requires + rtl; + +contains + PaxCompilerRegister in 'PaxCompilerRegister.pas'; + +end. + + diff --git a/Sources/Android/packages/D10_1_Berlin/paxcomp_android_D10_1.dproj b/Sources/Android/packages/D10_1_Berlin/paxcomp_android_D10_1.dproj new file mode 100644 index 0000000..81d9736 --- /dev/null +++ b/Sources/Android/packages/D10_1_Berlin/paxcomp_android_D10_1.dproj @@ -0,0 +1,465 @@ + + + {60FCB09C-C1BF-46AA-A459-F78C271F7B30} + paxcomp_android_D10_1.dpk + True + Release + 17 + Package + None + 18.1 + Android + + + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + false + paxcomp_android_D10_1 + true + false + false + true + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=;CFBundleName= + System;Xml;Data;Datasnap;Web;Soap;$(DCC_Namespace) + false + 1033 + false + 00400000 + + + android-support-v4.dex.jar;apk-expansion.dex.jar;cloud-messaging.dex.jar;fmx.dex.jar;google-analytics-v2.dex.jar;google-play-billing.dex.jar;google-play-licensing.dex.jar;google-play-services.dex.jar + Debug + package=com.embarcadero.$(MSBuildProjectName);label=$(MSBuildProjectName);versionCode=1;versionName=1.0.0;persistent=False;restoreAnyVersion=False;installLocation=preferExternal;largeHeap=False;theme=TitleBar;hardwareAccelerated=true;apiKey= + + + 1033 + true + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments= + Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) + + + 0 + false + RELEASE;$(DCC_Define) + 0 + + + true + DEBUG;$(DCC_Define) + false + + + + MainSource + + + + + + Cfg_2 + Base + + + Base + + + Cfg_1 + Base + + + + Delphi.Personality.12 + Package + + + + paxcomp_android_D10_1.dpk + + + + True + False + False + True + False + + + + + true + + + + + true + + + + + true + + + + + true + + + + + 0 + .dll;.bpl + + + 1 + .dylib + + + + + Contents\Resources + 1 + + + + + classes + 1 + + + + + Contents\MacOS + 0 + + + 1 + + + + + 1 + + + 1 + + + 1 + + + + + res\drawable-xxhdpi + 1 + + + + + library\lib\mips + 1 + + + + + 1 + + + 1 + + + 0 + + + 1 + + + 1 + + + library\lib\armeabi-v7a + 1 + + + 1 + + + + + 0 + + + 1 + .framework + + + + + 1 + + + 1 + + + 1 + + + + + 1 + + + 1 + + + 1 + + + + + ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF + 1 + + + ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF + 1 + + + + + + 1 + + + 1 + + + 1 + + + + + + library\lib\armeabi + 1 + + + + + 0 + + + 1 + + + 1 + + + + + 1 + + + 1 + + + 1 + + + + + res\drawable-normal + 1 + + + + + res\drawable-xhdpi + 1 + + + + + res\drawable-large + 1 + + + + + 1 + + + 1 + + + 1 + + + + + + res\drawable-hdpi + 1 + + + + + library\lib\armeabi-v7a + 1 + + + + + + + 1 + + + 1 + + + 1 + + + + + res\values + 1 + + + + + res\drawable-small + 1 + + + + + res\drawable + 1 + + + + + 1 + + + 1 + + + 1 + + + + + 1 + + + + + res\drawable + 1 + + + + + 0 + + + 0 + + + 0 + + + 0 + + + 0 + + + 0 + + + + + library\lib\armeabi-v7a + 1 + + + + + 0 + .bpl + + + 1 + .dylib + + + 1 + .dylib + + + 1 + .dylib + + + 1 + .dylib + + + + + res\drawable-mdpi + 1 + + + + + res\drawable-xlarge + 1 + + + + + res\drawable-ldpi + 1 + + + + + + + + + + + + + + 12 + + + + + diff --git a/Sources/Android/packages/D10_1_Berlin/paxcomp_android_D10_1.res b/Sources/Android/packages/D10_1_Berlin/paxcomp_android_D10_1.res new file mode 100644 index 0000000..36f26e2 Binary files /dev/null and b/Sources/Android/packages/D10_1_Berlin/paxcomp_android_D10_1.res differ diff --git a/Sources/Android/packages/D10_1_Berlin/paxcompiler.dcr b/Sources/Android/packages/D10_1_Berlin/paxcompiler.dcr new file mode 100644 index 0000000..4bcc339 Binary files /dev/null and b/Sources/Android/packages/D10_1_Berlin/paxcompiler.dcr differ diff --git a/Sources/Android/packages/D10_2_Tokyo/AndroidManifest.template.xml b/Sources/Android/packages/D10_2_Tokyo/AndroidManifest.template.xml new file mode 100644 index 0000000..b593684 --- /dev/null +++ b/Sources/Android/packages/D10_2_Tokyo/AndroidManifest.template.xml @@ -0,0 +1,42 @@ + + + + + + +<%uses-permission%> + + + +<%application-meta-data%> + <%services%> + + + + + + + + + + <%activity%> + <%receivers%> + + + diff --git a/Sources/Android/packages/D10_2_Tokyo/PaxCompilerRegister.pas b/Sources/Android/packages/D10_2_Tokyo/PaxCompilerRegister.pas new file mode 100644 index 0000000..21ef041 --- /dev/null +++ b/Sources/Android/packages/D10_2_Tokyo/PaxCompilerRegister.pas @@ -0,0 +1,52 @@ +//////////////////////////////////////////////////////////////////////////// +// PaxCompiler +// Site: http://www.paxcompiler.com +// Author: Alexander Baranovsky (paxscript@gmail.com) +// ======================================================================== +// Copyright (c) Alexander Baranovsky, 2006-2014. All rights reserved. +// Code Version: 4.0 +// ======================================================================== +// Unit: PaxCompilerRegister.pas +// ======================================================================== +//////////////////////////////////////////////////////////////////////////// + +{$I PaxCompiler.def} +unit PaxCompilerRegister; + +interface +uses + Classes, + PaxCompiler, +{$IFNDEF INTERPRETER_ONLY} + PaxProgram, + PaxInvoke, +{$ENDIF} + PaxInterpreter, + PaxCompilerDebugger, + PaxCompilerExplorer, + PaxBasicLanguage, + PaxJavaScriptLanguage, + PaxEval; + +procedure Register; + +Implementation + +procedure Register; +begin + RegisterComponents('PaxCompiler', + [TPaxCompiler, + TPaxPascalLanguage, +{$IFNDEF INTERPRETER_ONLY} + TPaxProgram, + TPaxInvoke, +{$ENDIF} + TPaxCompilerDebugger, + TPaxCompilerExplorer, + TPaxBasicLanguage, + TPaxJavaScriptLanguage, + TPaxEval, + TPaxInterpreter]); +end; + +end. diff --git a/Sources/Android/packages/D10_2_Tokyo/paxcomp_android_D10_2.dpk b/Sources/Android/packages/D10_2_Tokyo/paxcomp_android_D10_2.dpk new file mode 100644 index 0000000..a557763 --- /dev/null +++ b/Sources/Android/packages/D10_2_Tokyo/paxcomp_android_D10_2.dpk @@ -0,0 +1,39 @@ +package paxcomp_android_D10_2; + +{$R *.res} +{$R 'PaxCompiler.dcr'} +{$IFDEF IMPLICITBUILDING This IFDEF should not be used by users} +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO OFF} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION OFF} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES ON} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$DEFINE DEBUG} +{$ENDIF IMPLICITBUILDING} +{$IMPLICITBUILD ON} + +requires + rtl; + +contains + PaxCompilerRegister in 'PaxCompilerRegister.pas'; + +end. + + diff --git a/Sources/Android/packages/D10_2_Tokyo/paxcomp_android_D10_2.dproj b/Sources/Android/packages/D10_2_Tokyo/paxcomp_android_D10_2.dproj new file mode 100644 index 0000000..9204cb8 --- /dev/null +++ b/Sources/Android/packages/D10_2_Tokyo/paxcomp_android_D10_2.dproj @@ -0,0 +1,494 @@ + + + {60FCB09C-C1BF-46AA-A459-F78C271F7B30} + paxcomp_android_D10_2.dpk + True + Debug + 17 + Package + None + 18.2 + Android + + + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + false + paxcomp_android_D10_2 + true + false + false + true + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=;CFBundleName= + System;Xml;Data;Datasnap;Web;Soap;$(DCC_Namespace) + false + 1033 + false + 00400000 + + + android-support-v4.dex.jar;apk-expansion.dex.jar;cloud-messaging.dex.jar;fmx.dex.jar;google-analytics-v2.dex.jar;google-play-billing.dex.jar;google-play-licensing.dex.jar;google-play-services.dex.jar + Debug + package=com.embarcadero.$(MSBuildProjectName);label=$(MSBuildProjectName);versionCode=1;versionName=1.0.0;persistent=False;restoreAnyVersion=False;installLocation=preferExternal;largeHeap=False;theme=TitleBar;hardwareAccelerated=true;apiKey= + + + 1033 + true + CompanyName=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(MSBuildProjectName);FileDescription=$(MSBuildProjectName);ProductName=$(MSBuildProjectName) + Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) + + + 0 + false + RELEASE;$(DCC_Define) + 0 + + + true + DEBUG;$(DCC_Define) + false + + + + MainSource + + + + + + Cfg_2 + Base + + + Base + + + Cfg_1 + Base + + + + Delphi.Personality.12 + Package + + + + paxcomp_android_D10_2.dpk + + + + True + False + False + False + True + False + + + + + true + + + + + true + + + + + true + + + + + true + + + + + 1 + + + Contents\MacOS + 0 + + + + + classes + 1 + + + + + library\lib\armeabi-v7a + 1 + + + + + library\lib\armeabi + 1 + + + + + library\lib\mips + 1 + + + + + + library\lib\armeabi-v7a + 1 + + + + + res\drawable + 1 + + + + + res\values + 1 + + + + + res\drawable + 1 + + + + + res\drawable-xxhdpi + 1 + + + + + res\drawable-ldpi + 1 + + + + + res\drawable-mdpi + 1 + + + + + res\drawable-hdpi + 1 + + + + + res\drawable-xhdpi + 1 + + + + + res\drawable-small + 1 + + + + + res\drawable-normal + 1 + + + + + res\drawable-large + 1 + + + + + res\drawable-xlarge + 1 + + + + + 1 + + + 1 + + + 0 + + + + + 1 + .framework + + + 0 + + + + + 1 + .dylib + + + 0 + .dll;.bpl + + + + + 1 + .dylib + + + 1 + .dylib + + + 1 + .dylib + + + 1 + .dylib + + + 0 + .bpl + + + + + 0 + + + 0 + + + 0 + + + 0 + + + 0 + + + 0 + + + + + 1 + + + 1 + + + 1 + + + + + 1 + + + 1 + + + 1 + + + + + 1 + + + 1 + + + 1 + + + + + 1 + + + 1 + + + 1 + + + + + 1 + + + 1 + + + 1 + + + + + 1 + + + 1 + + + 1 + + + + + 1 + + + 1 + + + 1 + + + + + 1 + + + + + ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF + 1 + + + ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF + 1 + + + + + + + + 1 + + + 1 + + + 1 + + + + + + + Contents\Resources + 1 + + + + + library\lib\armeabi-v7a + 1 + + + 1 + + + 1 + + + 1 + + + 1 + + + 1 + + + 0 + + + + + 1 + + + 1 + + + + + Assets + 1 + + + Assets + 1 + + + + + Assets + 1 + + + Assets + 1 + + + + + + + + + + + + + 12 + + + + + diff --git a/Sources/Android/packages/D10_2_Tokyo/paxcomp_android_D10_2.res b/Sources/Android/packages/D10_2_Tokyo/paxcomp_android_D10_2.res new file mode 100644 index 0000000..36f26e2 Binary files /dev/null and b/Sources/Android/packages/D10_2_Tokyo/paxcomp_android_D10_2.res differ diff --git a/Sources/Android/packages/D10_2_Tokyo/paxcompiler.dcr b/Sources/Android/packages/D10_2_Tokyo/paxcompiler.dcr new file mode 100644 index 0000000..4bcc339 Binary files /dev/null and b/Sources/Android/packages/D10_2_Tokyo/paxcompiler.dcr differ diff --git a/Sources/Android/packages/D10_Siattle/AndroidManifest.template.xml b/Sources/Android/packages/D10_Siattle/AndroidManifest.template.xml new file mode 100644 index 0000000..b593684 --- /dev/null +++ b/Sources/Android/packages/D10_Siattle/AndroidManifest.template.xml @@ -0,0 +1,42 @@ + + + + + + +<%uses-permission%> + + + +<%application-meta-data%> + <%services%> + + + + + + + + + + <%activity%> + <%receivers%> + + + diff --git a/Sources/Android/packages/D10_Siattle/PaxCompilerRegister.pas b/Sources/Android/packages/D10_Siattle/PaxCompilerRegister.pas new file mode 100644 index 0000000..21ef041 --- /dev/null +++ b/Sources/Android/packages/D10_Siattle/PaxCompilerRegister.pas @@ -0,0 +1,52 @@ +//////////////////////////////////////////////////////////////////////////// +// PaxCompiler +// Site: http://www.paxcompiler.com +// Author: Alexander Baranovsky (paxscript@gmail.com) +// ======================================================================== +// Copyright (c) Alexander Baranovsky, 2006-2014. All rights reserved. +// Code Version: 4.0 +// ======================================================================== +// Unit: PaxCompilerRegister.pas +// ======================================================================== +//////////////////////////////////////////////////////////////////////////// + +{$I PaxCompiler.def} +unit PaxCompilerRegister; + +interface +uses + Classes, + PaxCompiler, +{$IFNDEF INTERPRETER_ONLY} + PaxProgram, + PaxInvoke, +{$ENDIF} + PaxInterpreter, + PaxCompilerDebugger, + PaxCompilerExplorer, + PaxBasicLanguage, + PaxJavaScriptLanguage, + PaxEval; + +procedure Register; + +Implementation + +procedure Register; +begin + RegisterComponents('PaxCompiler', + [TPaxCompiler, + TPaxPascalLanguage, +{$IFNDEF INTERPRETER_ONLY} + TPaxProgram, + TPaxInvoke, +{$ENDIF} + TPaxCompilerDebugger, + TPaxCompilerExplorer, + TPaxBasicLanguage, + TPaxJavaScriptLanguage, + TPaxEval, + TPaxInterpreter]); +end; + +end. diff --git a/Sources/Android/packages/D10_Siattle/paxcomp_android_D10.dpk b/Sources/Android/packages/D10_Siattle/paxcomp_android_D10.dpk new file mode 100644 index 0000000..fe29bd4 --- /dev/null +++ b/Sources/Android/packages/D10_Siattle/paxcomp_android_D10.dpk @@ -0,0 +1,39 @@ +package paxcomp_android_D10; + +{$R *.res} +{$R 'PaxCompiler.dcr'} +{$IFDEF IMPLICITBUILDING This IFDEF should not be used by users} +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO OFF} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION OFF} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES ON} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$DEFINE DEBUG} +{$ENDIF IMPLICITBUILDING} +{$IMPLICITBUILD ON} + +requires + rtl; + +contains + PaxCompilerRegister in 'PaxCompilerRegister.pas'; + +end. + + diff --git a/Sources/Android/packages/D10_Siattle/paxcomp_android_D10.dproj b/Sources/Android/packages/D10_Siattle/paxcomp_android_D10.dproj new file mode 100644 index 0000000..3c99459 --- /dev/null +++ b/Sources/Android/packages/D10_Siattle/paxcomp_android_D10.dproj @@ -0,0 +1,461 @@ + + + {60FCB09C-C1BF-46AA-A459-F78C271F7B30} + paxcomp_android_D10.dpk + True + Release + 17 + Package + None + 18.1 + Android + + + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + false + paxcomp_android_D10 + true + false + false + true + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=;CFBundleName= + System;Xml;Data;Datasnap;Web;Soap;$(DCC_Namespace) + false + 1033 + false + 00400000 + + + android-support-v4.dex.jar;apk-expansion.dex.jar;cloud-messaging.dex.jar;fmx.dex.jar;google-analytics-v2.dex.jar;google-play-billing.dex.jar;google-play-licensing.dex.jar;google-play-services.dex.jar + Debug + package=com.embarcadero.$(MSBuildProjectName);label=$(MSBuildProjectName);versionCode=1;versionName=1.0.0;persistent=False;restoreAnyVersion=False;installLocation=preferExternal;largeHeap=False;theme=TitleBar;hardwareAccelerated=true;apiKey= + + + 1033 + true + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments= + Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) + + + 0 + false + RELEASE;$(DCC_Define) + 0 + + + true + DEBUG;$(DCC_Define) + false + + + + MainSource + + + + + + Cfg_2 + Base + + + Base + + + Cfg_1 + Base + + + + Delphi.Personality.12 + Package + + + + paxcomp_android_D10.dpk + + + + True + False + False + True + False + + + + + true + + + + + true + + + + + true + + + + + + Contents\Resources + 1 + + + + + classes + 1 + + + + + Contents\MacOS + 0 + + + 1 + + + + + 1 + + + 1 + + + 1 + + + + + res\drawable-xxhdpi + 1 + + + + + library\lib\mips + 1 + + + + + 0 + + + 1 + + + 1 + + + 1 + + + library\lib\armeabi-v7a + 1 + + + 1 + + + + + 0 + + + 1 + .framework + + + + + 1 + + + 1 + + + 1 + + + + + 1 + + + 1 + + + 1 + + + + + ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF + 1 + + + ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF + 1 + + + + + library\lib\x86 + 1 + + + + + 1 + + + 1 + + + 1 + + + + + + library\lib\armeabi + 1 + + + + + 0 + + + 1 + + + 1 + + + + + 1 + + + 1 + + + 1 + + + + + res\drawable-normal + 1 + + + + + res\drawable-xhdpi + 1 + + + + + res\drawable-large + 1 + + + + + 1 + + + 1 + + + 1 + + + + + + res\drawable-hdpi + 1 + + + + + library\lib\armeabi-v7a + 1 + + + + + + + 1 + + + 1 + + + 1 + + + + + res\values + 1 + + + + + res\drawable-small + 1 + + + + + res\drawable + 1 + + + + + 1 + + + 1 + + + 1 + + + + + 1 + + + + + res\drawable + 1 + + + + + 0 + + + 0 + + + 0 + + + 0 + + + 0 + + + 0 + + + + + library\lib\armeabi-v7a + 1 + + + + + 0 + .bpl + + + 1 + .dylib + + + 1 + .dylib + + + 1 + .dylib + + + 1 + .dylib + + + + + res\drawable-mdpi + 1 + + + + + res\drawable-xlarge + 1 + + + + + res\drawable-ldpi + 1 + + + + + 0 + .dll;.bpl + + + 1 + .dylib + + + + + + + + + + + + 12 + + + + + diff --git a/Sources/Android/packages/D10_Siattle/paxcomp_android_D10.res b/Sources/Android/packages/D10_Siattle/paxcomp_android_D10.res new file mode 100644 index 0000000..36f26e2 Binary files /dev/null and b/Sources/Android/packages/D10_Siattle/paxcomp_android_D10.res differ diff --git a/Sources/Android/packages/D10_Siattle/paxcompiler.dcr b/Sources/Android/packages/D10_Siattle/paxcompiler.dcr new file mode 100644 index 0000000..4bcc339 Binary files /dev/null and b/Sources/Android/packages/D10_Siattle/paxcompiler.dcr differ diff --git a/Sources/Android/packages/xe5/PaxCompilerRegister.pas b/Sources/Android/packages/xe5/PaxCompilerRegister.pas new file mode 100644 index 0000000..21ef041 --- /dev/null +++ b/Sources/Android/packages/xe5/PaxCompilerRegister.pas @@ -0,0 +1,52 @@ +//////////////////////////////////////////////////////////////////////////// +// PaxCompiler +// Site: http://www.paxcompiler.com +// Author: Alexander Baranovsky (paxscript@gmail.com) +// ======================================================================== +// Copyright (c) Alexander Baranovsky, 2006-2014. All rights reserved. +// Code Version: 4.0 +// ======================================================================== +// Unit: PaxCompilerRegister.pas +// ======================================================================== +//////////////////////////////////////////////////////////////////////////// + +{$I PaxCompiler.def} +unit PaxCompilerRegister; + +interface +uses + Classes, + PaxCompiler, +{$IFNDEF INTERPRETER_ONLY} + PaxProgram, + PaxInvoke, +{$ENDIF} + PaxInterpreter, + PaxCompilerDebugger, + PaxCompilerExplorer, + PaxBasicLanguage, + PaxJavaScriptLanguage, + PaxEval; + +procedure Register; + +Implementation + +procedure Register; +begin + RegisterComponents('PaxCompiler', + [TPaxCompiler, + TPaxPascalLanguage, +{$IFNDEF INTERPRETER_ONLY} + TPaxProgram, + TPaxInvoke, +{$ENDIF} + TPaxCompilerDebugger, + TPaxCompilerExplorer, + TPaxBasicLanguage, + TPaxJavaScriptLanguage, + TPaxEval, + TPaxInterpreter]); +end; + +end. diff --git a/Sources/Android/packages/xe5/paxcomp_android_xe5.dpk b/Sources/Android/packages/xe5/paxcomp_android_xe5.dpk new file mode 100644 index 0000000..dc0a2e6 --- /dev/null +++ b/Sources/Android/packages/xe5/paxcomp_android_xe5.dpk @@ -0,0 +1,37 @@ +package paxcomp_android_xe5; + +{$R *.res} +{$R 'PaxCompiler.dcr'} +{$IFDEF IMPLICITBUILDING This IFDEF should not be used by users} +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION OFF} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES ON} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$DEFINE DEBUG} +{$ENDIF IMPLICITBUILDING} +{$IMPLICITBUILD ON} + +requires + rtl; + +contains + PaxCompilerRegister in 'PaxCompilerRegister.pas'; + +end. diff --git a/Sources/Android/packages/xe5/paxcomp_android_xe5.dproj b/Sources/Android/packages/xe5/paxcomp_android_xe5.dproj new file mode 100644 index 0000000..d813406 --- /dev/null +++ b/Sources/Android/packages/xe5/paxcomp_android_xe5.dproj @@ -0,0 +1,191 @@ + + + {258F6364-5BCD-41F3-B36F-5692B578857D} + paxcomp_android_xe5.dpk + 15.1 + None + True + Debug + Android + 17 + Package + + + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Cfg_1 + true + true + + + true + Base + true + + + System;Xml;Data;Datasnap;Web;Soap;$(DCC_Namespace) + true + true + All + .\$(Platform)\$(Config) + .\$(Platform)\$(Config) + false + false + false + false + false + + + package=com.embarcadero.$(MSBuildProjectName);label=$(MSBuildProjectName);versionCode=1;versionName=1.0.0;persistent=False;restoreAnyVersion=False;installLocation=preferExternal;largeHeap=False;theme=TitleBar + Debug + None + + + None + + + None + + + true + Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments= + 1033 + + + DEBUG;$(DCC_Define) + true + false + true + true + true + + + false + + + false + RELEASE;$(DCC_Define) + 0 + 0 + + + + MainSource + + + + + + Cfg_2 + Base + + + Base + + + Cfg_1 + Base + + + + Delphi.Personality.12 + Package + + + + paxcomp_android_xe5.dpk + + + True + False + 1 + 0 + 0 + 0 + False + False + False + False + False + 1033 + 1252 + + + + + 1.0.0.0 + + + + + + 1.0.0.0 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + True + False + False + False + True + False + + + 12 + + + + diff --git a/Sources/Android/packages/xe5/paxcomp_android_xe5.res b/Sources/Android/packages/xe5/paxcomp_android_xe5.res new file mode 100644 index 0000000..5e952b5 Binary files /dev/null and b/Sources/Android/packages/xe5/paxcomp_android_xe5.res differ diff --git a/Sources/Android/packages/xe5/paxcompiler.dcr b/Sources/Android/packages/xe5/paxcompiler.dcr new file mode 100644 index 0000000..4bcc339 Binary files /dev/null and b/Sources/Android/packages/xe5/paxcompiler.dcr differ diff --git a/Sources/Android/packages/xe6/PaxCompilerRegister.pas b/Sources/Android/packages/xe6/PaxCompilerRegister.pas new file mode 100644 index 0000000..21ef041 --- /dev/null +++ b/Sources/Android/packages/xe6/PaxCompilerRegister.pas @@ -0,0 +1,52 @@ +//////////////////////////////////////////////////////////////////////////// +// PaxCompiler +// Site: http://www.paxcompiler.com +// Author: Alexander Baranovsky (paxscript@gmail.com) +// ======================================================================== +// Copyright (c) Alexander Baranovsky, 2006-2014. All rights reserved. +// Code Version: 4.0 +// ======================================================================== +// Unit: PaxCompilerRegister.pas +// ======================================================================== +//////////////////////////////////////////////////////////////////////////// + +{$I PaxCompiler.def} +unit PaxCompilerRegister; + +interface +uses + Classes, + PaxCompiler, +{$IFNDEF INTERPRETER_ONLY} + PaxProgram, + PaxInvoke, +{$ENDIF} + PaxInterpreter, + PaxCompilerDebugger, + PaxCompilerExplorer, + PaxBasicLanguage, + PaxJavaScriptLanguage, + PaxEval; + +procedure Register; + +Implementation + +procedure Register; +begin + RegisterComponents('PaxCompiler', + [TPaxCompiler, + TPaxPascalLanguage, +{$IFNDEF INTERPRETER_ONLY} + TPaxProgram, + TPaxInvoke, +{$ENDIF} + TPaxCompilerDebugger, + TPaxCompilerExplorer, + TPaxBasicLanguage, + TPaxJavaScriptLanguage, + TPaxEval, + TPaxInterpreter]); +end; + +end. diff --git a/Sources/Android/packages/xe6/paxcomp_android_xe6.dpk b/Sources/Android/packages/xe6/paxcomp_android_xe6.dpk new file mode 100644 index 0000000..ffc9675 --- /dev/null +++ b/Sources/Android/packages/xe6/paxcomp_android_xe6.dpk @@ -0,0 +1,38 @@ +package paxcomp_android_xe6; + +{$R *.res} +{$R 'PaxCompiler.dcr'} +{$IFDEF IMPLICITBUILDING This IFDEF should not be used by users} +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO OFF} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION OFF} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES ON} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$DEFINE DEBUG} +{$ENDIF IMPLICITBUILDING} +{$IMPLICITBUILD ON} + +requires + rtl; + +contains + PaxCompilerRegister in 'PaxCompilerRegister.pas'; + +end. + diff --git a/Sources/Android/packages/xe6/paxcomp_android_xe6.dproj b/Sources/Android/packages/xe6/paxcomp_android_xe6.dproj new file mode 100644 index 0000000..db59692 --- /dev/null +++ b/Sources/Android/packages/xe6/paxcomp_android_xe6.dproj @@ -0,0 +1,112 @@ + + + {9128156D-4F09-455A-8656-6CA5D066F7E4} + paxcomp_android_xe6.dpk + True + Debug + 17 + Package + None + 15.4 + Android + + + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + false + false + paxcomp_android_xe6 + false + 00400000 + System;Xml;Data;Datasnap;Web;Soap;$(DCC_Namespace) + false + 1033 + false + true + true + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=;CFBundleName= + + + Debug + package=com.embarcadero.$(MSBuildProjectName);label=$(MSBuildProjectName);versionCode=1;versionName=1.0.0;persistent=False;restoreAnyVersion=False;installLocation=preferExternal;largeHeap=False;theme=TitleBar;hardwareAccelerated=true + + + true + Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) + 1033 + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments= + + + false + 0 + 0 + RELEASE;$(DCC_Define) + + + DEBUG;$(DCC_Define) + true + false + + + + MainSource + + + + + + Cfg_2 + Base + + + Base + + + Cfg_1 + Base + + + + Delphi.Personality.12 + Package + + + + paxcomp_android_xe6.dpk + + + + True + False + False + False + True + False + + + 12 + + + + diff --git a/Sources/Android/packages/xe6/paxcomp_android_xe6.otares b/Sources/Android/packages/xe6/paxcomp_android_xe6.otares new file mode 100644 index 0000000..5e952b5 Binary files /dev/null and b/Sources/Android/packages/xe6/paxcomp_android_xe6.otares differ diff --git a/Sources/Android/packages/xe7/paxcomp_android_xe7.dpk b/Sources/Android/packages/xe7/paxcomp_android_xe7.dpk new file mode 100644 index 0000000..4f9c9ea --- /dev/null +++ b/Sources/Android/packages/xe7/paxcomp_android_xe7.dpk @@ -0,0 +1,39 @@ +package paxcomp_android_xe7; + +{$R *.res} +{$R 'PaxCompiler.dcr'} +{$IFDEF IMPLICITBUILDING This IFDEF should not be used by users} +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO OFF} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION OFF} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES ON} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$DEFINE DEBUG} +{$ENDIF IMPLICITBUILDING} +{$IMPLICITBUILD ON} + +requires + rtl; + +contains + PaxCompilerRegister in 'PaxCompilerRegister.pas'; + +end. + + diff --git a/Sources/Android/packages/xe7/paxcomp_android_xe7.dproj b/Sources/Android/packages/xe7/paxcomp_android_xe7.dproj new file mode 100644 index 0000000..45027ba --- /dev/null +++ b/Sources/Android/packages/xe7/paxcomp_android_xe7.dproj @@ -0,0 +1,112 @@ + + + {60FCB09C-C1BF-46AA-A459-F78C271F7B30} + paxcomp_android_xe7.dpk + True + Debug + 17 + Package + None + 16.0 + Android + + + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + false + paxcomp_android_xe7 + true + false + false + true + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=;CFBundleName= + System;Xml;Data;Datasnap;Web;Soap;$(DCC_Namespace) + false + 1033 + false + 00400000 + + + Debug + package=com.embarcadero.$(MSBuildProjectName);label=$(MSBuildProjectName);versionCode=1;versionName=1.0.0;persistent=False;restoreAnyVersion=False;installLocation=preferExternal;largeHeap=False;theme=TitleBar;hardwareAccelerated=true + + + 1033 + true + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments= + Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) + + + 0 + false + RELEASE;$(DCC_Define) + 0 + + + true + DEBUG;$(DCC_Define) + false + + + + MainSource + + + + + + Cfg_2 + Base + + + Base + + + Cfg_1 + Base + + + + Delphi.Personality.12 + Package + + + + paxcomp_android_xe7.dpk + + + + True + False + False + False + True + False + + + 12 + + + + diff --git a/Sources/Android/packages/xe7/paxcomp_android_xe7.otares b/Sources/Android/packages/xe7/paxcomp_android_xe7.otares new file mode 100644 index 0000000..5e952b5 Binary files /dev/null and b/Sources/Android/packages/xe7/paxcomp_android_xe7.otares differ diff --git a/Sources/Android/packages/xe7/paxcomp_android_xe7.res b/Sources/Android/packages/xe7/paxcomp_android_xe7.res new file mode 100644 index 0000000..5e952b5 Binary files /dev/null and b/Sources/Android/packages/xe7/paxcomp_android_xe7.res differ diff --git a/Sources/Android/packages/xe7/paxcompiler.dcr b/Sources/Android/packages/xe7/paxcompiler.dcr new file mode 100644 index 0000000..4bcc339 Binary files /dev/null and b/Sources/Android/packages/xe7/paxcompiler.dcr differ diff --git a/Sources/CentOS/Demos/CallInterfaceMethod/project2.ico b/Sources/CentOS/Demos/CallInterfaceMethod/project2.ico new file mode 100644 index 0000000..0341321 Binary files /dev/null and b/Sources/CentOS/Demos/CallInterfaceMethod/project2.ico differ diff --git a/Sources/CentOS/Demos/CallInterfaceMethod/project2.lpi b/Sources/CentOS/Demos/CallInterfaceMethod/project2.lpi new file mode 100644 index 0000000..46b749f --- /dev/null +++ b/Sources/CentOS/Demos/CallInterfaceMethod/project2.lpi @@ -0,0 +1,89 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/Sources/CentOS/Demos/CallInterfaceMethod/project2.lpr b/Sources/CentOS/Demos/CallInterfaceMethod/project2.lpr new file mode 100644 index 0000000..76574b5 --- /dev/null +++ b/Sources/CentOS/Demos/CallInterfaceMethod/project2.lpr @@ -0,0 +1,21 @@ +program project2; + +{$mode objfpc}{$H+} + +uses + {$IFDEF UNIX}{$IFDEF UseCThreads} + cthreads, + {$ENDIF}{$ENDIF} + Interfaces, // this includes the LCL widgetset + Forms, Unit2, LResources + { you can add units after this }; + +{$IFDEF WINDOWS}{$R project2.rc}{$ENDIF} + +begin + {$I project2.lrs} + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. + diff --git a/Sources/CentOS/Demos/CallInterfaceMethod/project2.lrs b/Sources/CentOS/Demos/CallInterfaceMethod/project2.lrs new file mode 100644 index 0000000..2747aa9 --- /dev/null +++ b/Sources/CentOS/Demos/CallInterfaceMethod/project2.lrs @@ -0,0 +1,5237 @@ +LazarusResources.Add('MAINICON','ICO',[ + #0#0#1#0#6#0#0#0#0#0#1#0' '#0#226#145#0#0'f'#0#0#0#128#128#0#0#1#0' '#0'('#8#1 + +#0'H'#146#0#0'@@'#0#0#1#0' '#0'(B'#0#0'p'#154#1#0'00'#0#0#1#0' '#0#168'%'#0#0 + +#152#220#1#0' '#0#0#1#0' '#0#168#16#0#0'@'#2#2#0#16#16#0#0#1#0' '#0'h'#4#0#0 + +#232#18#2#0#137'PNG'#13#10#26#10#0#0#0#13'IHDR'#0#0#1#0#0#0#1#0#8#6#0#0#0'\r' + +#168'f'#0#0#145#169'IDATx'#218#236']'#5#128#28#245#213#127#235'n'#231'w9I.N' + +#136#144#4#139#17#220'['#220#221#138';!'#184'|'#180#148#2#197'Kq'#13'R('#20 + +'(V'#180#197#3#9'!'#144#144#16#187#156#219#202#173#251'~'#239#253'gfo'#246'r' + +'~'#187';{'#242#131#201#236#173#204#204#202#251#253#159'?'#25#140'a'#12'c'#24 + +#181#144'I}'#1'c'#24#195#24#164#195#24#1#140'a'#12#163#24'c'#4'0'#134'1'#140 + +'b'#140#17#192#24#198'0'#138'1F'#0'c'#24#195'('#198#24#1#140'"'#140#155'}2}' + +#223#6#220'L'#184#25'q'#11#227#230#161#173#225#167#21#17#169#175'o'#12#217 + +#199#24#1#12'c'#160'@'#155'q7'#21#183'i'#184'M'#198#173#8'8'#225'N'#217'd2' + +#153'p'#155#132#191#167#239'<'#132#155''''#145'H0B'#224'7'#175#232'v'#7'n' + +#219'p'#219#128#219'F'#220'j'#145'4'#18'R'#127#6'c'#24#26#198#8' '#199#129'B' + +'.'#199#221'x'#224#132'|'#170#176#161'P'#211#223'%='#189'N'#214#195'7+'#235 + +#230'+O@'#207'r'#156#232#249#161#0#146#197'&'#232'$'#132#228#134#196#224#145 + +#250's'#27'C'#255'0F'#0'9'#6#20'x'#18#234#189'q'#219#7#183'=P'#208'ie'#215 + +#136#159'#'#22'nA'#160'e'#194#157#226#199'DO'#20'nwG'#12'b!O'#240#127'$R'#238 + +#236#230'q'#209#157']I'#2#159#211#136#187#181#184'}'#198'o'#171#145#20'bR' + +#127#182'c'#216#17'c'#4' 1P'#224#11'p'#183#20'8'#161#223#27#5'u'#186#240'X' + +#167'L'#239'('#228't'#155#219#0#228#244#12#185#140'{'#158#140'{'#157#140#191 + +'!'#235#250'|'#232'<'#166' '#196#130#252#146'ps'#27'pRM'#255#203#184#191#197 + +#143#209#235#196#247'AbGb'#232'B'#10#29#248#248#255#160#147#16'~'#26'3'#31'r' + +#3'c'#4#144'e'#160#192'[p'#183#23#240#171'<'#10#229'L'#224#191#7#177#192#203 + +'8)'#6#185'\'#158#20'h'#185#156#187'_.'#227#4#158#30#163#219#10'z'#142#188 + +#203#227#252#30'D'#247#201#21#10#220'+AF{P@\'#22#135'D,'#134#194#26#131'8' + +#238#227#241#24'/'#216'qn'#31'O'#0#222#194#251#241#223'8@'#28#255#137#199#185 + +#191#227#137#4#187#157#224#239'#'#2#136''''#186''''#134'nH'#193#129#247#127 + +#14''#193#238#139#11'['#146'(R'#9#161#139#217'A&' + +#195#10#220#158'G2'#248'E'#234#239'k4a'#140#0'2'#4#20'z%'#238#246#7'N'#232 + +#127#143'{'#29#221'/'#172#230#226#21'^,'#240'$'#172'$'#224'J'#165#2#148#180 + +'W)A'#163#214'3'#1#215#144#176'ku'#160#209#242'B'#175'V'#129#10#159#175'T' + +#202#217's'#233'u'#10#185'p'#172'.'#26#129#130'3'#21#184#251#216#149'p'#23 + +#202'Vn'#224'Vo'#129#4#226#156#128#198'x'#1#142#197'8'#161#142'E'#19#16'E!' + +#143'D'#227#16'Eb'#8'!'#9#132#131'~n'#11's'#251#16'#'#135'0>/'#134#207#225'6' + +#129#16#24'A'#136#8#129#206#215'U;'#192#251#215#224#238#5#220'^B2h'#150#250 + +'{'#28#233#24'#'#128'4'#3#5#127'.'#238'N'#197#237'D'#20#190'b'#186'O,'#244 + +#130#170#174#144#209'*.c'#2#175#228#133'^'#173'T'#162'P'#171'Ao'#178#130'^o' + +#3#157#209#10'Z'#29#10#187'J'#129#171'=nL'#208#233#182#156#221'V)'#21#201'=#' + +#11'%G'#0'D$r9g'#247#211#185#146'&'#3#179#8'd)'#206'AnE'#134#20'5'#30'e'#149 + +#187#29#231'6"'#128'h'#156#132'9'#158'$'#128'H'#132#246'1'#238#182'h'#31#198 + +'}8'#24#130#128#175#3#252'^'''#248'}N'#8#5'}'#236'1'#129#16#162#177#174#132 + +#16'g'#218#1#153#24#220'5'#177']'#12#175#225'c'#224#200#224'M$'#3#191#212#223 + +#237'H'#196#24#1#164#1'('#244#21#184';'#25#183'SQ'#184'v'#162#251#186#21'z~' + +#133#231'Vv'#18'^'#20'x'#149#10#244'('#232'z'#163#13#12#6#220#27#204#184#226 + +#227#170#175'Q'#130'V'#173'`'#194'O'#127#171'U'#188#192#171':'#133'^'#197#142 + +#195#173#254't'#31'g&p'#171#127#210#148#160#235#224#29#132#130#250#159#18#9 + +#224#205#0#178#245#133#21#153#217#251#252#223'$'#155'$'#160#209'8'#183#250'w' + +#146#0#10'2'#145#0#222#14'G8'#2#160'=m'#161'H'#20#205#132#24#4#195#220#237'@' + +' '#0'~'#143#139#145#1#145'B'#136#204#8#188#159'#'#131#24'gJ'#224'qbq'#193 + +#223#176#131#153#224'E2'#248'''pd@>'#131#184#212#223#249'H'#193#24#1#12#1'(' + +#248#243'pw='#10#219#17#192'-'#174#12'rN'#210'8'#149'\&O'#170#244'*'#21#9#178 + +#146#9#188#193'd'#195'}'#30'nf'#208'jT'#160#19#132#30'7'#29#19'~%G'#4'<'#9 + +#168#149#220#202'O'#171'<'#169#253#10#165#12#148'ra'#213#167's'#164#10'>]'#2 + +'wA'#188#192#11#209#129'D*'#1'$U'#239#164'g'#159#255#139#183#215#227#188'3P' + +#16#206'(o'#14#16#9#196#4'2Hj'#5#164#1#160#208#147#224#135#163'l'#31#8'E!(' + +#222'P'#240#253'>'#31#4#188'.'#240'!'#25#248'<'#14'4'#27#130#248#218'(#'#5'F' + +#4#140#12'x"'#232#226'3'#192#191')'#25#233'/'#184'='#131'D'#16#146#250'70' + +#220'1F'#0#131#0#10#254'"'#220#221#128#194'v'#16#253#157'\'#237'y'#207''#198#147'BLl'#30#136#136#0#133'>'#16'N%'#1#250 + +';'#16#196'-'#20#129'` '#2#30#183#3'<'#174'f'#240'x'#218'Q;'#8'32 '#13'C'#236 + +'d'#20'L'#4#17#17#144#227#240'^'#220#30'C"'#240'I'#253#155#24#174#24'#'#128#1 + +#0#5#159#156'z7'#162'0-'#161#191#185#24'<-'#181#220'j'#159'j'#203#163'0'#235 + +'t`'#182#20#131#201'V'#2'F'#147#25#244'Z'#21#24'p'#163#189'^G'#130#174'b'#194 + +#175#21'V|'#141#130#9'='#17#6#19#252#164#131#143#183#229#153#195#16'D6=''' + +#224#178#174#241#254'.'#215'-'#147#13#236'k'#22''''#1#137's'#4#128#251#159'#' + +#2#193'THtF'#16#146#132'@'#26'B$'#158'4'#11'B'#145'N'#141' '#200#147'A '#24#1 + +'?'#146#128#31'I'#192#239#167#219#184#5#130#224'v'#181#129#219#217#194'i'#6 + +','#242#16'c'#14#199#164#137#16#139#167'h'#5'x'#187#29'/'#233'~'#220#30'F"' + +#232#144#250'72'#220'0F'#0'}'#128'/'#160#249#29'p+'#254#174't'#31#23'^'#239 + +#12#209'1!Ur'#234#189'V'#171#1#147#165#136#173#244'&K'#30'/'#236'j0'#232'T' + +#201'M'#199#147#128'V'#195#169#248#156#208'+83A'#201#31'O.'#178#231'{'#17'v' + +#254'&'#183#239'A'#208#7'"'#255'='#165#254'v%'#133'D'#167#154#176#3')p^'#255 + +#4#243#27#196'D'#142'C'#210#10#194#188'_'#128#153#7'A'#142#8'|'#129'0n'#17 + +#182#249'i'#143'Z'#128#23#205#4#15#18#1#145#129#223#239#193#215'E'#153'f'#192 + +#162#11#188#19#177#139#175#128#146#141#30#193#253'}H'#4#237'R'#255'n'#134#11 + +#198#8#160#7#240'9'#248#199#1'g'#227'S'#178#206#14#130#175#18#236'z\'#189#13 + +'&+X'#243#199#161#224#23#162#144#235'P'#232'U`'#228#5#158#8#192#168#231#132 + +'^'''#8'>'#9#189'Z'#145't'#230'q'#26#132'8'#254'/J'#254#17'.'#170#15'u>['#232 + +#202#17']'#201#128#249#14#4#13'A'#228'?`'#209#4'2'#17'b'#228','#140'32 '#159 + +#0#167#13#136#8#0'5'#2'/'#146#130#159#255#219#227'qA'#135#179#25':'#28#141'h' + +'R'#132'92Hj'#5';'#16#129#31#207#255#24#238#239'A"h'#148#224#227#25'V'#24'#' + +#128'n'#128#194#191#27#238#30'EA'#163#144'^'#138#224'+yU_'#141'6'#188#6'7' + +#163'9'#15'l'#133#149'`'#177#230#163#176#227'J'#143#130'n'#212#171#217'mN' + +#232#213'('#244'h'#235'k95_'#205'<'#250#188#7'_'#217#25#183#239'N'#173'g'#231 + +#22'.j8|S]'#202#7'RR'#135'E'#230'B,'#193#231#20#240#161'Cf"'#136'|'#3'$'#244 + +'^A+'#240#163'6 '#236'}~p'#180#213'!'#17'4'#224#243#130#140#8':#'#9#169'D' + +#128#231#14#224'%'#220#137#219'_'#198#156#133'=c8'#252#172#178#6#20#252'<' + +#220#221#137#194'w.'#240'2'#152'"'#248#188#154#175'A'#219#221'd)`'#130'oE5' + +#223'hP3'#161'7'#25'4L'#232#13#188#202#159#180#241#153#224#139#156'y'#188'z/' + +#8#190'8'#127'?'#165#208'g'#128#182'{'#174#161''''#167'b2'#225#136'O2'#226 + +#180#2'!'#140'H>'#130'X'#167#143#0#137#192'C'#194#207#8' '#12'n'#220'{'#188 + +'~p'#182#215#131#203'^'#15'A'#127#144#249#10'z!'#2#170'X'#188#24'I'#224'?R' + +#127#30#185#136#225#253#11'K'#19'x;'#255','#220#238'B'#161#203#23#156'{2'#133 + +#160#234's+'#183#22'W|'#147#181#8#242#138'+'#193'l'#182#129#137#9'='''#248'&' + +'#'#238'Q'#240'uL'#229'W'#177#24#190#134'9'#243'RU|qr'#14#8#222'z'#254':d#' + +#248#235#216#161'z0'#25'f'#228'3'#17#197'&'#2'i'#5'Q^+ '#18#8'F'#152#22#224 + +#245#133#192'C$'#224'#R'#8#129#215#27#0#167#189#1#156#168#21'P'#174'A('#140 + +'D@9'#9'T'#215#192';'#11#227#157#213#141#175#225#238#10'$'#130#6#169'?'#139 + +'\'#194#200#253#197#245#19'('#252#187#224#238'o('#152'{'#136#195'y,'#227#142 + +'6'#18'|T'#227'-'#214#18#176#21'U'#160#224'['#153#208#155'I'#232'y'#225'g'#26 + +#128#150#19'|q'#248'N'#156#158'+'#8'>'#147#249#212'z'#222#209#9'Q'#232'1'#233 + +'7'#224#137#128#204#132#8#159'tDQ'#0#166#17#132#200'9'#136#155#143#211#8#220 + +'H'#6'D'#4#28')'#4#145#8#26#145#8'j'#193#239#247'!qt'#18#1#167'm'#196#5'm' + +#128#26#156#220#138#219#3'H'#4'Q'#169'?'#130'\'#192'h'#253#249#9'Uyw'#160'0^' + +#128'{'#133#160#238#179'"'#27#222#185'G'#9':'#228#205'/('#169'F'#193'71a'#239 + +'I'#240#5#199#30'K'#203'U'#202'S'#236'zN'#232#187#177#235#199#176'C'#30'BB' + +#172#25#176#236'CN+'#8'G'#163#157'D'#192#251#4'8m'#128'#'#2#143'@'#4'm'#13 + +#224'h'#169'A'#205'!'#192#136' '#194#155#6']'#204#2'*8'#186#16'I'#224#11#169 + +#223#191#212#24#149#191'E'#20#254'Spw'#15#229#234'''Km'#21'|J-+'#190'A;'#222 + +'hB'#193#159#4#182#252'"&'#244'f#'''#252'f^'#240#13#188'W_'#219'e'#197'O&' + +#231#240'R'#223#25#162#147#250']'#231'>D'#193#4'n/'#242#21'$S'#144'{'#210#8 + +#188'!'#232' '#18#160'}'#135#23#218#155#183#130#203#217#4#193'`'#152#249#21 + +#136#8#226#172#246' %'#153#232'y'#220']'#141'D'#208'&'#245'{'#151#10#163#234 + +'g'#137#130'O'#141'0'#31'G'#193'?'#145#254#22'Vh'#5#191#234#171'U*'#180#225 + +'5'#204#185'WP2'#30','#6#29'XL'#26#176#24'9'#2#160'U'#159#9#190'F'#136#225'+' + +'9'#167#30#139#219#11'y'#255'\'#213']'#231'''<'#170'>'#226#244'A'#228'@L@gM' + +#2#249#9'"'#2#17#136#162#6#130'Y'#208#225#9'22'#160#205#225'h'#135#246#166'M' + +'H'#10#29#156'6'#192#242#8#226#156#127#160'S'#27#160'P'#225#137'H'#2#255#147 + +#250'-K'#129'Q'#243#235'D'#225#159#141#187#127#160#144'N'#17'V}'#5#159'i'#199 + ,#169#251'h'#215'['#11#160#176't2'#218#251'f&'#244'V'#163#22#204'D'#0#6'-S' + +#251'){'#143#4#159#203#244#227#146'u'#196'e'#183'];'#248#140'a'#232#16#151#11 + +#11#230'A,'#193#167#30'G'#184#228'"'#230','#196#205#195#155#5#29#222' '#18'A' + +#136#237#221'H'#8#237#173#181#224'l'#217#14#254'`'#16'B'#225'0'#159'f'#28'Oj' + +#24#192'U'#30#222#130#251';G['#161#209#168#248#165#162#240#159#135#187#7'PH' + +#181'2'#190#6'_H'#217#165#144#158#222'`'#196#21#127'"'#228#229#151#178#149 + +#158'V}+['#249'9'#193'7'#232#213'l'#213#167#172'='#242#234's'#9';\'#201#173 + +'Pp'#195'>'#204'Q'#241'iJ'#131#206'DDn'#229'N'#166#31#147'F'#16#229#170#16')' + +#143#128#210#138#189#188'I'#224#18#17'A'#135#219#11'mM'#155#161#195#209#130 + +'&'#4#146#0'%'#19#9#209#130'Nm'#224'#<'#193')H'#2#173'R'#191#223'laD'#255'd' + +#249'N<'#143#137'U~'#193#214#167'D'#30#29#174#250'yE'#168#238#23'O'#0#179'Y' + +#199#4'>'#185#242#27'9[_H'#217'e'#169#186#138#212#226#155#222#26'm'#142'!3' + +#224#139#21#147#14#195'd>A'#148'K7'#230'2'#11'9"'#224#28#132'H'#4'n$'#0#242 + +#13#144'Y`o'#133#246#230'M'#224#243'x:'#181#129'h\'#28')h'#194'3'#156#140'$' + +#240#153#212#239'5'#27#24#177'?]^'#229#127#141#186#234#138'='#252#172#180'VE' + +'N>#'#148#148#239#4'V[>'#191#226'k'#25#1#144#202'O'#241'}'#178#245'uj~'#213 + +#23'j'#237'E^}'#246#225#141#216'O/'#247#145'$'#2#232#236'AH)'#199'Q'#190#0 + +#137#10#142#168#208#200#231#227#136#128#132#223#229#9'2'#31'A'#135''''#0#173 + +#13#191#177#208'a'#144'O-'#142'&C'#134#236#200#184'K'#220#142#251#255#27#233 + +'&'#193#136#252#9#163#240#255#1'w'#247#139'U~'#174#147#14#197#244'U`'#177#21 + +'Cq'#249'4'#176#153#13'('#252'Z&'#252#164#242's'#153'|\'#234'.'#173#250'\5' + +#30#223'aG&'#235'6'#23#127#12#210'"'#145'd'#1#224#27#152#242'D'#16#137#179 + +#162'#"'#2#31#239'$'#228#132'?'#4'N'#158#8#236'm'#13#208#214#248#27'j'#11'A' + +#150'D$D'#10'D&'#193#167#192'i'#3'#'#182'5'#217#136#250'%'#243'*?y'#249'O' + +#160#191#197'*'#191'FM'#130#173#129#252#210'j(,'#169'bj'#190#213#162#5#155'I' + +#155#12#241#137#227#249'B'#18'Ogn>$k'#236#199#144'['#160#214#229#157#185#4 + +#188'Y'#192#218#152'qY'#133#212#153'('#192#215#23'0'#223#0#145#128';'#128#166 + +#1#238#157'Nh'#169'_'#15'^O'#7#231#27#216#209'$h'#1#206'/'#240#177#212#239'3' + +#19#24'1'#191'f'#20'~'#26#139#245#30#10#255#188#174'I=\\'#159'T'#254#25'`' + +#203#207'c+'#190#205#164#3#171'Y'#203#135#247#212#172'XGH'#221'e'#13'7'#146 + +#234#190'h'#229#151#250'M'#142#161'G'#136'|'#132#220','#131'8'#223#201'('#193 + +'7)'#9'sNB'#210#6#220#188'9@'#190#1#167#155#246#254#164'I'#16#224#27#146'DY' + +#155#244'$'#9'P'#214#224#217'H'#2#207'K'#253'>'#211#141#17#241#155'F'#225#159 + +#128#187#255#160#240'O'#18#132#159'b'#243#228#229'gi'#188#182'"T'#249#167#163 + +#192#163#202#143'B'#159#135#155#133'_'#249#141'|}'#190#154'o'#192'A'#141':' + +#229'2Q'#231#220#17#241#9#141'B'#240#13'L'#200#128#23'Z'#153#9#185#3'T['#224 + +#241#134#185'('#1'j'#1#14#212#6#220#168#21#180#183#212'C['#243'&'#214#152#132 + +#202#142#133#156#1#222'/'#128'<'#144'X'#134'$p'#143#212'o-'#157#24#246'?o' + +#222#217#247#1#10#127#137#216#222#167#226#29#157'V'#203#210'x'#11'H'#229''';' + +#223#204#169#252't'#155'e'#243#233':='#252#201#10'='#161':O'#234'76'#134#161 + +'#'#193#165#26#11'-'#200#163#188#147#144#186#19#177#188#1'_8'#169#13'8'#153 + +'F'#16'@'#147#160#3'Z'#234#214'1'#147#128#146#135'('#5'YD'#2't'#172#187'qw' + +#237'H'#153'l4'#172#127#231'('#252'4a'#231'-'#20'~'#139' '#252','#163#143'T~' + +#131#1#138'+f@^^A'#167#224#155#185'0'#31#9'?+'#213#229#227#250'B'#231#29#232 + +'R'#142';'#134#145#1'q'#163#211'd'#164' '#202#165#19#11#225'Br'#14':'#220#28 + +#9#208#214'Z'#191#1'\'#246'&'#212#24#194','#170#16''''#191#0'$M'#130#231#240 + +#128#231#140#132#130#162'a'#251'sG'#225'?'#10'w/'#161#240'k'#132#240#28#169 + +#252'j'#170#213'7'#153#160#164'r6'#216'lff'#235#219#204#218#164#189'/'#180 + +#228'R'#243#173#183#200#209''''#212#225#143#9#255#200#133#144'H'#148'lJ'#130 + +'&A'#24#237#252#16'_n'#204#162#4'nN'#27' '#147#128#162#4'-'#13#155#192#209'Z' + +#203#234#9'('#162' '#174'%@'#18#248'7'#30#238'8$'#129#128#212#239'm('#24#150 + +'?y>'#204'G%'#188'r'#193#211'/8'#251#168#15'_i'#213'L'#176'YM'#144'G'#206'>' + +#139'.'#25#226#211#179'&'#29#202'd'#223'='#161'D'#151#251' '#134#229'G1'#134 + +#1'B<'#216'Th^J+'#188'@'#2'd'#18#144'c'#208#217#17'`'#251#182#230#237#208#214 + +#180#9#130#129'03'#7#186'D'#8#190#194'C'#30#142'$'#224#148#250'}'#13#22#195 + +#238'W'#143#194#127'3'#10#238'mt['#16'~5_'#193'g'#177#22'@i'#229'L'#176'Z' + +#245'L'#240#137#0#200#233#199#132#159'o'#201'%'#30#160#193'>'#128#177'e'#127 + +#212'A<'#2']'#156'' + +#129#253#135#147'c0'#231#197#1#133#159#198'o'#189#141#178#175#18#219#252':' + +#173#26#10#203#166'@Aq%'#243#240''''#133#159'<'#253'$'#252#201#10'>'#174'tW6' + +#22#219#135#223#29'0'#11#2#254#29#167'hi'#181':'#184#231#161#151'`'#234#244 + +'YR_'#162'd'#224'9 '#233#23#136'D'#184#209'f'#228#28'd'#21#133#148''''#208#17 + +'d'#161'B'#167#203#141'$'#240#19'x<'#29#221#145#192';x'#168'#'#145#4'bR'#191 + +#167#254' '#167'e'#130#239#207#255')'#10#191'A,'#252#180#242#23#148'N'#130 + +#162#210#241'I'#225#23'r'#250#5#225#231'Fi'#203'E='#249'r'#250#173'f'#5'''' + +#31#181#16#218#219#186#175'kQ('#148'p'#239'#'#175#192#244#25#187'H}'#153#146 + +'AhP'#10#2#9'D'#185#225'%b'#18'pv'#8#155#27#154'j'#214#128#215#227'fm'#201 + +#187'8'#6#159'F'#2'8['#234#247#211#31#228#172'T'#160#240'O'#193#221'W('#184#5 + +'B'#146#143' '#252#249'EU'#156#205#207#132#159#203#235'gi'#189'z.'#179#143#28 + +#131#138#148#148'^'#24#157'F'#127#23','#191#252#20#248'i'#245#183'=>N$p'#215 + +#131'/'#194#140#153#243#165#190'T'#233#144#28'f'#2#201#129#167'D'#2#212#127 + +#144#230#18#8'$@'#230#128#195#233'B'#18#248#17'|>'#127'2:'#192'&'#21'q'#14 + +#198'?#'#9'\'''#245#219#233#11'9)'#21'('#252#165#184#251#26#133#127#188'8' + +#195#143'9'#252#10#199'AI'#197'N,'#185''''#143#247#246#179#236'>'#157#154#13 + +#215'd'#194'/j'#211#149#179'oR'#2#216#219'Z'#224#180#227#150#224#15#180#231 + +#18'w'#185'B'#1'w'#222#251'<'#204#156#179#155#212#151'+'#9#196#195'P'#133#206 + +'CD'#2'!VC'#16'e'#221#135#133'""'#202#21' '#199' i'#2#1#170#31#160#241#230 + +#204#28'H'#8'$@s'#8#238#151#250'='#245#134#156#147#13#190']'#247#255'Pxg%' + +#133#31#127#148#26#190#168#167#140#226#252#164#242'S'#156#223',R'#251#213'JP' + +#170#184'>}c!'#190#158'q'#255']'#215#194''''#31#190#217#235's'#228'r'#5#252 + +#249#129#21'h'#14#204#149#250'r%'#133#16'*'#20'r'#5'h'#132#25#149#21#139#205 + +#1#210#4#236#237#173#208#178#253'g'#8#132#130#140'('#132#218#129#4'7R'#249 + +#148#134#159'^zI'#234#247#210#19'rJJP'#248#201#21#253#17#141#223#22#170#250 + +#148'|'#134#159#217#146#7'%'#19'fC'#158#201#0'6'#171#150#197#250#217#202#143 + +#194#175#213'(S'#187#246#228#212#187#202'-'#196#227'Q8'#254#176'y'#16#194#31 + +'ko'#208'hu'#240#220'k_'#130'^o'#148#250#146'%'#133#216'1('#152#3#204''''#224 + +#237'L'#27'&'#231' '#151','#180#129#235'0'#20'I!'#129#8#30#225'0$'#129#156#28 + +'M'#150'S'#162#130#4#240#16#10#255#197#226#146'^'#141#138'r'#251'-P:a'#23'\' + +#249#141'l'#213'g'#194'o'#226'V~-'#133#250'D'#243#246'r'#234#13#229'('#222 + +#254#231#179#240#244#223#255#220#231#243#202'+'#171#225#225#167#222#147#250 + +'r%Grr'#17#175#9#4#187#144#128#144''''#208#218'T'#3#246#166#205#157'$'#208 + +#217'O'#192#145'H'#196'vi\'#251'J'#173#212#239#165'+rF^'#248#226#158#127#138 + +#19'}'#168'A'#7'5'#242'('#173#154#11'y63W'#213#199#215#242#147#195#143'*'#250 + +#132#129#28#178#177#149#127'@8'#251#132'%'#224't'#244'='#15'c'#191#131#143 + +#133#11#175#184']'#234#203#149#28'B1'#17'9'#249'"|'#187'1.O '#204'J'#137#137 + +#4':P'#19'hi'#220#4#246#214#237#16#162#198'"'#169'ME'#190#142#4#28'K['#127'{' + +'?"'#245'{'#17'#''D'#134'o'#232#241'#'#149#245#10#225'>'#18'~'#157'^'#15#165 + +#227'w'#1#155#205#154't'#248'Y'#153#218#175#225#235#248';'#213'~!'#183#127#12 + +#253#195'/?}'#7#183',;'#163'_'#207#189#234#134#251'`'#193#146#131#164#190'd' + +#201#145#28'Y'#22#227#204#1#210#4'|B'#155#177'dw'#161' 4'#213#173#131#14#190 + +#148'85<'#24#191#27'M'#129'k!e'#144#186#180#144'\jx'#187#255'K'#20#254']'#187 + +#134#251#138'+w'#134#130#130#210'd'#172#191#179'}'#151#138#235#207#207#183 + +#232#22#6'}'#140'a`8'#239#228#165#168#5#244#221#2#159#194#131#15'='#253#1#20 + +#22#149'I}'#201#146#131'K'#27#230'5'#1#190#185#8'M.'#166#218#1#18'~'#135'''' + +#192'Z'#140'5m'#253#17'' + +#202#242'3'#25#185#149#159#230#241'q'#133'=\'#168'Oj'#6#251#237#215#31#225 + +#230'kNM'#185#143'H'#224#222#199#222#134#210#210'*'#137#175#174'wl\'#183#26 + +'n'#185#246#180'~?'#127#238#174'{'#193#178'['#30#145#250#178's'#2#180'|s-' + +#200#169#187#16#154#3'An"'#17#235','#212#17#20#149#17#175'Ov'#27#22#249#3#190 + ,#12'y['#246'n'#223#242#177#228#29#133'$'#147#31#20'~'#146#14#178#251'm'#226 + +'4_='#218#253'e'#19#230#161#221'oa'#130#207'9'#253'h'#229'W'#179#22'^\I'#175 + +'<9r[j'#220'y'#243'y'#240#243#143#223#236'p'#127'qi'#5#220#247'xnz'#208#219 + +'['#155#224#213#23#30#128'5?|'#1'>'#175'{@'#175'='#243#130#27'`'#255'CN'#144 + +#250'-H'#14'![0'#193#135#7'I'#192'i"'#145#208'^'#140'5'#20'Am'#160#185#238'W' + +'p'#182#215'C8'#196'u'#26'&'#194#224#15'pg'#253'O+n'#0#137'M'#1'ID'#8#133'_' + +#5'\'#178#207#30#226'L?'#157'F'#3'E'#21';'#163#250'_'#146'l'#229'%T'#246'Q3' + +#15#214#194'K)'#227#166#239#230#130#244'#'#206'8z.D#;:v'#149'J'#21'<'#251#198 + +'j'#169'//'#137'p8'#12#239#188#254#4#252#247#227'7'#193#209#222'2'#232#227 + +#200#240#187':'#253#188#235'`'#191'1'#18'H'#166#13#11#227#203'Y'#162#144'P7' + +#144#236'%'#224'GS`5x'#221#174#29#252#1'h1'#30'R'#183'f'#197#135' !'#9'HE'#0 + +'w'#161#240'/'#163#219#10#161#139#175'F'#9#249#133#227#161#168'|2o'#247'wv' + +#239'e'#225#190'd'''#159#220'q'#248#213'l^'#15'7]'#221#179' <'#241#202#183 + +#160#213#234'%'#189#198'`'#208#15#127#185#245#15#176'y'#227#207#189#166#0#15 + +#20#147#167#205#134#229#183'?'#1'j'#181'V'#210#247'''5'#18#162'a'#165'\'#142 + +#0'?{'#128'H'#128#138#134'<\'#205'@'#179#216#31#208'i'#10#180'i'#212#138#217 + +'['#191#127#190#25'$"'#129#172'K'#18#10#255#28#220#253#128#4#160#16#199#251 + +#141'f'#206#238#183#176#6#158#188#221'o'#224'j'#250#233'q*'#238#145#201'd9' + +#21#239#127#255'_'#207#193'+'#207#253#181#199#199#175#189#237'q'#216'i'#214 + +#238#146']'#223#166#13'?'#193#221'('#252#161'Pf'#202#211#213#26'-\t'#245#221 + +'0g'#254#18#201#222#163#212'H$'''#18#9#21#132#220'\'#194'dk1'#26'C'#198'g'#10 + +#182'5n`'#13'F'#187#148#15#191#220#240#211#10#234'w'#193#15'8'#203'.'#178'*J' + +'('#252't'#190#175#197#170#191'`'#247#151#140'G'#187#223'jN'#246#239#167'Q]' + +#212#193'W'#173#22'M'#229#205#21#201#231#241#183'{'#151#193#247'_'#247#156 + +#225'y'#197#13#15#195#172#185#139'$'#185#182#230#198#237'p'#253#165'G'#166'u' + +#213#239#9#187'.'#216#31'.'#188#234'nI'#222'g'#174'@('#30'bN'#193#8#231#15 + +#160'Qd'#212'i'#216#201#166#19#147'?`='#184#218#27'v('#26#146#203#18#251#213 + +#173'y'#137#166#17'g'#157#4#178'M'#0#231#2'7'#187#143#169#254#148#234#171'U' + +#171'Q'#237#223#9#237#254'q,'#212'G'#4'@'#19'z'#141#186'N'#187'_'#220#202'+' + +#151'p'#203'U'#199'A}'#237#166#30#31'?'#245#188#27'a'#233#254'GKrm'#203'/:' + +#12'W'#157#236#181#168'3'#154#173'p'#205#205#143'Cy'#213'dI'#222'o.@p'#10'F' + +#226#220'(2'#214'iX(!&'#18#240#248#161'q'#235#15#224#247'y'#216'0R'#145')' + +#176#161#208#28#223'e'#205#23'/'#135'`'#164#18#0#10#127#1#238'6'#162#240#231 + +#145',+'#168#194#15#5#220'l-'#130#210#170#217#220#136'nQ'#129#15#169#254#201 + +#210#222#28#136#245'w'#135#171#207';'#0':\'#237'=>>{'#222#18#184#248#218#236 + +'W'#131#174#250#246#19#248#251'_'#175#201#250'y'#169#148#248#162'k'#254#138 + +'Z'#207#226#172#159';W@>'#129'x'#12#152#199#159':'#10#249#168#183#160#159's' + +#10#18#17#216#219'['#160#165'v-'#155':'#20#21'B'#131'@?'#239#196#245'{L'#14 + +#255#229#181#215'^'#139'C'#22'I '#155#4#240'4'#10#255#153'B'#194#15'e'#242'i' + +#181#26'('#171#222#21'l'#22'+X-'#26#150#227'o'#210#11#241'~E'#206'W'#247']y' + +#206#190#224#245#184'z|'#220'`'#180#192'}O}'#154#245#235'z'#230'o'#183#192'7' + +#255#253#183'$'#159#9'iw'''#156#185#12#246'>0'#247#19#161'2'#1'nE'#231'z'#11 + +'R'#166' '#181#26'gIB'#194'@R'#26'8R'#251#11#184#28'M]K'#135'}'#10'Yd'#230'Y' + +'G'#236#180#253#214'[o'#205#154')'#144#21#209'B'#225'_'#136#187'/'#196'M=)' + +#225''''#191'x'#2#20#150'M'#228#236'~'#190#159#31#27#209#205''''#251#200#20 + +'|'#154'o'#142#142#228#190#242#156#165'L'#157#235#13#203'n'#127#22#170'''' + +#207#204#234'u'#253#241#186#147#160#174'f'#163#148#31#13#236'{'#200#201'p' + +#236#169'WJz'#13'R!'#217'e'#152'2'#5'Q'#19#160#162'!'#174#155#16'_='#232'rC' + +#211#214#239'!'#16#12'tI'#16#138#191'5'#217#214'x'#204#231#159#127'.h'#1#25 + +''''#129#140'K'#22#10#191#18'w'#171'Q'#246'g'#138#29#127#6#163#9'W'#255#221 + +'P'#232'u'#220#234'o'#20'B~'#156#221#175#148'Q?'#191#172'\'#226#160'q'#229'Y' + +'KX'#152#173'7L'#156':'#27#174#186#229')v'#155#190#232#141#235#190#135'_~' + +#252#2'j6'#255#2#173'-u'#16#14#5#161#176#184#28'f'#238#178#24#150#236#127',' + +#216#242#139#135'|]w\{<4'#214'm'#145#250#227#129'='#150#28#6#167#157#127#171 + +#212#151'!'#13'(*'#144#224#187#9#133'R'#203#135'iko'#222#14#237'M'#155' '#28 + +#230'M'#1#222'!'#168#144#197#143#216'}r'#244#223#217'2'#5#178'A'#0#201'~'#254 + +#130#227#143'V'#255#226#138'Y'#144'_X'#194#170#251#204#204#235#175'f3'#251'4' + +#194#164'^'#5#191#242#231#174#252#195#21'g.'#198'/0'#216#231#243'*''L'#135 + +#246#214#6'^['#232#253';'#173#154'8'#3'.^'#246' '#232#141#230'A_'#215#223#239 + +#189#18'~^'#253#133#212#31#15#195#137'g]'#7#139#246'=J'#234#203#200':'#196 + +#249#1#194#172#1#242#7'P4'#192#229#14#129#27'I'#160'q'#219#15#204#132#236#146 + +#27#176#173#196#26#155'S]'#20#243'e'#131#4'2*^('#252#229#184#251#21#133#223 + +'(8'#254'h'#245'7'#219#138#161#164'r&'#179#249#201#243'o'#22#169#254#148#240 + +#195#138'j'#134#193#140#238'+'#206'\'#4#209'H8'#237#199#165#234#187#227#207 + ,#188#22#246'\'#250#251'A'#189#254#173#151#31#130#143#223'}A'#234#143#135#129 + +'4'#190#229#127'Z'#1#165#229#19#165#190#148#172'#9'#131#144'R'#133#249#209'c' + +'n'#26'I'#206#180#128#16'8'#236'm'#208'R'#187#134#213#10#136#27#138#202'e' + +#137'?'#21')6'#222#186'j'#213'*j-'#158'QS '#211#4#240','#238'N'#231#194'x\' + +#165#159'N'#167#129#210#9#187#162#218'o'#6'3o'#247#155'x'#213'_'#165'Rt'#198 + +#251's\'#248#9'W'#158#177'p'#135'A'#27#233#2'}'#6'W'#160#233'@'#26#193'@'#225 + +#180#183#192#173#151#255'N'#234#143''''#9#157#222#8'w<'#244'>(G'#227#240#145 + +#132#184#167' '#167#5#176#198#162#158#16#155'@'#220'Z'#255'+t8'#26#152'C0'#22 + +#139#9#164#17#210'(";W'#154'[k>'#255#252's'#129#4'2'#130#140#137#25'_'#236 + +#179#25#127#200#202'd'#147#15'\'#225#243'J&Aa'#201#4'&'#248#22'>'#219#143#188 + +#254'B'#194#143#208#214'K6'#28'4'#128'3'#22#160#234#150#185#249#15#148'F'#252 + +#199'G>'#4#165'j'#224#130#243#199'k'#143#131#214#166#237'R~<)'#168#24'?'#13 + +#174#190#253'9'#169'/#'#171'H'#206#31#20'G'#5#130'\'#150' E'#5#152'&'#224#246 + +'A'#211#182#149#16#240#7#146#25#130'd6'#160#22#240#216#30#147'#'#151#226#203 + +'c'#153'4'#5'2I'#0#127#195#221#5#194#234'O'#171#187#222'`'#198#213#127'>'#174 + +#252#186#164#234'O1'#127#13#175#250#11#173#188's5'#236#215#21'W"'#1'd:'#211 + +'n'#206'n'#251#194#233#23#253'q'#192#175'['#245#205#135#240#226#223'o'#145 + +#234#163#233#22'{'#29'x'#2#28'q'#210#229'R_FV'#145'L'#21'&_'#0#223'T4'#16#226 + +#18#132'H'#3' "ho'#169#5'{'#211#198#174'a'#193#160'Y'#23#157#174#143'ln'#200 + +#164')'#144#17'Q'#227#251#250'oCa'#214#8#171#191#150#194'~'#227'v'#130#130 + +#194'q,'#233#135'R}'#169#198#159#10'}'#146#173#189#134'Y['#175#171#207'^'#136 + +'_lf'#9'@'#173#209#193#157#127#31'\.'#193'u'#231#239#3#225#12#213#1#12#22#231 + +'^y'#31'L'#155#185#135#212#151#145'u'#136'G'#145'S'#130#16#171#21#224'K'#135 + +'I'#19' -'#192#231#245'$'#147#131#226#156'/'#224#129#137#214#198#229#133#133 + +#133#145'Li'#1#153'"'#128'{pw'#149#216#246'7'#24'q'#245#175#222#21'W}m'#146#0 + +'('#215'_'#163'Q'#138'r'#253'3'#253'5'#164#23#203#206'Y'#196#190#172'L'#131 + +#132'f'#234#206#3'/*'#250#199'3'#127#130#149'_H'#147#16#212#19#242#10'J'#225 + +#250#191#252'S'#234#203#200':'#132#4'!'#161'V'#128#229#6#8#166'@W-'#128#250#8 + +#178'(B'#194'k'#209#248#166#203'|'#155'Z'#143'='#246#216'h&'#18#132#210'.r(' + +#252#249#184#219'.'#158#231'G*~~'#233'4(('#174'`'#182#191'9'#153#238#171'J' + +#233#231'?'#220#176#252#188#197#25#245#1#8#152#188#211#174'H'#2#15#12#248'u~' + +#159#27'n'#187#252#224#164'-'#154'+'#184#244#198#167#161'|'#252'4'#169'/#' + +#235'`i'#194#162#178'a'#214'U'#152#143#10'Px'#176'i'#203'w'#224#247#251#152 + +#22' D'#4#20#178#248'_'#198#233'jn'#213'h4'#145'L8'#4'3A'#0#255#135#187#27 + +#133#184'?'#173#254'z'#189#1#202'&'#238#193#4#159'<'#255#20#243#167#176#31 + +#149#249#178'b'#31#190#189#207'p'#226#128#166#186#205'p'#255'm'#167'g'#229'\' + +'&K>'#220'xo'#255'z'#247'u'#197#227#247'\'#10'[6'#172#202#230'G'#211'''*'#171 + +'w'#134#139#174#127'L'#234#203'H'#162'v'#235'z'#248#224#141#191#179'U'#248 + +#202#219'^'#4'm'#6#134#161#236'P6LZ'#0's'#8#134'Xkq'#242#7#216'['#182#131#189 + +'y'#19#203#11#16'E'#4':'#10#13#222#25#165#150'p'#187#209'h'#140#166#219#20'H' + +#171#200#161#240'S'#246#10#173#254#214'd'#193#15#10'y^'#233#20#200'/'#170'd' + +#4'`'#225'+'#253#132#213'_.'#204#241'K'#251'G'#158'Y<'#245#192#149#176'i'#221 + +#202#172#156#139#138'l'#254#244#232#127#7#245'Z'#183#171#13#238#188#246#168 + +#156#210#2'hq'#184#225#158'w'#192'h'#178'Jz'#29'?'#175#250#12#222'z'#233#175 + +#224#245'8'#147#247'Yl'#133'p'#237#157#175#225'oR'#153#246#243#9'#'#200#147 + +#29#132#216#188#193#8'x'#242#5'P'#181#224'w'#16#164#136'@'#172'S'#11 + +'P'#202#227#255'7'#181#208'~'#151#221'n'#15#167#219'!'#152'n'#2#184#30'w'#127 + +#20#175#254#172#183#127#245#238#184#234#235'p'#245'Ws'#157'}'#249'b'#159'd' + +#216'o8-'#253#192#133'tn'#190'x'#31#136'g('#7#160';\'#247#151#183#152'&0'#24 + +';d'#213'_'#204#156#191#15#156'x'#174#180#3'G'#222'|'#225'.'#248 + +#254#203'wv'#184#191'x\5\v'#243#243#25'9'#167'0'#130'<'#22#19#194#130#145'd' + +#243#16#210#4#218#155#183#130#179'uk'#215'r'#225#246#170'<'#255',u'#194#233 + +'L'#183'C0m'#146#135#194'O'#189#175'jP'#152#11#133#156#127'J'#249#205'+'#158 + +#4#249#197#227'q'#245'Ws'#131'6'#127#209#225'p'#196')'#203'2r^'#241#152'1'#234'#'#232#167 + +#228' >*@Z@'#211#150'o!'#24#10'B4'#210'Y#'#160'R'#196'o'#24#167#171'}'#200 + +#229'r'#133#210#233#16'L'''#1'\'#134#187#251#133#22#223'JV'#238#171#195#213 + +#127#15'0'#25#185')'#190#228#249#215#137'W'#255'af'#247#11#248#203'uG'#130 + +#167#195#158#213's'#206#156#191'/'#28'w'#214#224#227#250#143#254#249'\h'#172 + +#149#182'B'#176'+'#14':'#234'"X'#184#223#241#146#157#127#235#198#213#168#29 + +'u'#159#151' '#147#201#225#218#187#254#5#6'cf'#204#148#148#185#2'4v<'#16#6 + +#143#151'#'#129#246#166#205#224'j'#171'I'#169#17#192#127#154'&'#216#218#230 + ,'DC'#30'O:'#29#130#233'$'#128#159#196'#'#189')'#231#223'VT'#13#249'%'#213',' + +#219#143'y'#254'u'#157#147'|'#5#219#127#184#161#177#246'7x'#236#174's'#179'~' + +#222#130#226'J'#184#228#230#193#231#247'?'#250#167#179#160#185'A'#250#10'A1' + +#170#167#205#131#211'/'#249#235#208#15'4H'#4#253'^'#184#243#154'C{|'#188'j' + +#210'l8'#235#138#7'3rn'#161'N'#128#204#0'J'#14#242#5#195#172'd'#152#204#0#183 + +#199#11#205#219'V'#162#22#16'Ji'#29#166'SFO'#221'i\'#224'-$'#128#208#140#25 + +'3'#210#162#5#164'E'#2#199#205':q'#14#200#228'?'#166#14#248'PC'#217#196'=' + +#193'h'#212'%'#195'~]m'#127'v'#1#195'L'#5'x'#246#129#203#160'f'#211#154#172 + +#159'W'#161'T'#193'M'#247#127'<'#232#215'?p'#203#9#224#180'7e'#253#186'{'#131 + +#209#156#15'W'#255#233#13'I'#175#225#214'K'#150'v'#186#232#187#193'y'#203#158 + +#128#178#202')i='#167'`'#138'u'#230#5#196'Y#Qj'#28'Bu'#2#20#26'lk'#218#8#238 + +#246':'#22'-'#16#210#131#21#242#196#191''''#231#181#156#145#151#151#231'okkK' + +#139#22#144#30#2#152'}'#242#189#184#187'R'#156#248'c'#206'+'#133#162#242#25 + +'l'#245#167#141'l'#255#174#5'?'#195'L'#246#25#238#184'|'#191#140#21#0#245#133 + +#195'O'#186#6#230#238'y'#232#160'^{'#207#245'G0_@.'#129'4'#197#155#30#200'~' + +#199'$1'#250#250'>+&'#236#12'g]'#249#240#0#142#216'?'#8#26'@gD'#160#179#135 + +' +'#22'r9'#160#173'v'#245#14'EB'#165'F'#215#156'Bs'#188#209'h4'#6#211#161#5 + +#12'Y'#4#11'&'#238#167#212#24#139#235'P'#160'K'#196#206#191#194#242'Y`'#205 + +'+J'#18#0'7'#211'O'#148#243#159#246#143'4'#243#168#223#182#14#158#185#255'b' + +#201#206'o+('#131#139'oZ1'#168#215#222'u'#237#161#16#238#163'y'#137#20#184 + +#225#222#143'@'#174#148#206#17'x'#247#242#195'!'#24#240#246#248'8'#249#2#150 + +#223#243'>.j'#233#175'd'#20#198#139#209#198':'#9#135'"\'#15'A$'#0'2'#7#154'k' + +#190'g'#201'\bg'#160'F'#17#185'~'#130#205#254'x'#186#180#128'!'#203#225#184 + +#217''''#29#130#135'yW'#172#254#235'tz('#157#184#7#152#244#26#214#229#135'e' + +#253#241#171'?'#169#255#220#7#155#246#207'3'#227'xg'#197#159'a'#237#247#255 + +#25#250#129#134#128'E'#7#158#10'{'#29'|'#230#128'_'#247#231#171#15'D{2'#167 + +'F'#211'3\q'#199#27#160#207#144#163#173'?x'#232#182#19#192#237#236'}B'#242 + +#194#253'N'#130#165#135#157#147#145#243''''#135#138#196'83'#128#178#3'='#188 + +')`o'#169#1'g'#203#230'd'#219'0'#190'Jp'#213#228#188#230#223#163#6#224'N'#135 + +'/`'#168'b(C'#245#255'%'#220#159' '#174#250#179#20'TAA'#233'd'#182#242#147 + +#240#179#156#127'a'#180#215'0'#140#251#11'x'#152'~,'#174#190#199'ig'#18#244 + +#217#157'q'#249'#PZ9'#176'T'#218';'#175#220'/+3'#2#6#138#11#174#127#1'l'#133 + +#227'$;'#255'S'#247#156#7'-'#13#155'{}'#142#193'd'#131#203'n'#207'L'#253#2 + +#203#11#192#175'%'#154#156'''@y'#1'\'#207#0#143#199#3#205#219#190#235'j'#6'$' + +#242#180#158#189#139#140#190'_'#210#161#5#12'I'#18'Kw>'#214'"W'#168#155#240 + +'G'#169#19'w'#252')'#170#154#7#22#139#141#9#191#208#231'O'#205#175#254#178'a' + +#24#247#23'p'#215'5'#251'g'#188#250#175'?'#208'h'#13'p'#217'mo'#12'Hu'#206 + +#149'k'#239#138#11'oz'#5#204#214'B'#201#206#255#226#195#151#161'i'#247'K'#159 + +#207';'#227#138'G'#161#164'<'#189#206'@'#1#226'J'#193#0#211#2#194'L'#11' 3' + +#160#165'n'#13#248#220#246#20'3@'#173#136'>2)'#223#241''''#157'N'#231#25#170 + +#22'0'#20'I'#148#141#155'u'#210'Y('#205'O'#138'c'#255':'#189#25'J&'#236#202 + +'B~F'#3#183#250'k'#133#138'?'#129#0'2'#242'1f'#30'w]'#189#159#212#151#144'DE' + +#245',8'#233#194#254#135#208#238'^v@V*'#23#7#2#250#221','#187#251#163#172#159 + +#215#209'V'#7#171#190#252#23'4'#213'n'#128#182#230'm'#253'j'#235'V5i'#23'8' + +#225#252#244'O?'#18'$'#150#141#26#143'u:'#3'}'#228#12'D"p'#182'7'#128#189#241 + +#215#20'3@&K'#212'M'#201'k'#222#27'??'#215'P'#181#128#161#17#192#236#147'?' + +#199#253#18'.'#166#207'M'#248#181#22'q'#153#127'$'#248#194'`O'#173#134'k'#244 + +#169#16#226#254#195'P'#3#8#6#189#240#208'MGH}'#25')'#216#231'w'#23#194#188 + +#197#253'k'#184'y'#239#181#7'f'#165'rq '#160'^'#7#151#221#241#206#208#15#212 + +#7#162#209'0'#252#188#242#3#216#176#230'S'#166#238'G'#250#209#200#181'+'#228 + +'r'#5'\q'#231#251#236'w'#158'v'#240#209#0#193#25#200'B'#130#188'/'#192#231#11 + +'@'#243#214'o'#184#190#129#157'f'#0'X'#181#129'S'#202#173#190'OQ'#3#240'644' + +#4#15'?'#252#240#216'`'#180#128'AKb'#217#204#227#170'er'#21#181#252#146#137 + +#213#255#226#234#221#209#246'7'#166#172#254#164#254#211#7''''#31#198#234#127 + +'['#211'Vx'#238#190'?H}'#25') '#15#245'YW?'#133'6ty'#159#207#253#235#242#131 + +'r'#142#0#242#138'*'#217#245'g'#18#159#189#243'wX'#245#5#229#26#12'='#13'z' + +#241'Ag'#194#238#251#156#148#145#235'$'#225#23#18#131#184'"!./'#128#234#4#218 + +#234#215#131#167#163#169'Kjp'#236#141')'#5#142#171'U*'#149#203#135',1'#216#26 + +#129#193'J'#163#172'|'#246#201'7'#226#153'n'#23'{'#255#141#230#2'('#172#152 + +#205#173#254'z'#21#232#209#12#160'6'#223'*'#149#144#246';<'#133#159#176'm' + +#195'w'#240#230#179'7I}'#25';'#128'<'#232#231#223#248#143'>'#159'w'#255#13 + +#135'd'#181'x'#169'?'#216#251#240#11'`'#151#133'Gf'#236#248#219'6'#174#132'7' + +#159#185'1m'#199#179#228#149#194#217#203'2'#211#215'P'#152'+'#200':'#8'G'#185 + +#225#162'>'#161'i'#136#179#21#218#235#215#166'$'#5#201' '#209'19'#191'u'#145 + ,'\'#150'h'#195#197#215'+'#170#20#28#144#157'7h'#2'@'#245#159#234'S'#23#139'+' + +#255#242'J'#167#131'-'#191#12#244'zU2'#244#199#138'~'#134'q'#222#191#128#159 + +#191#127#31'>~#'#251's'#254#250#131'I;/'#130#195'O'#238#157#156#30#188#241'P' + +#201#18#152#186#3#149'8_v'#251#191'I'#183#206#200#241#253'^'#23''#232#163'7|'#247#217#10#248#230#163#204 + +#148#136#166#3#135#156'p=L'#153#181'W'#143#143'?q'#231#137#224#243'8'#164#190 + +#204'$'#170'&'#207#131'#'#207#252'S'#198#142#255#244#221#167#129#219#217#146 + +#246#227#238#182#247#137#176'`'#255'3'#210'~\'#241' '#145#168#168'y('#133#4 + +'I'#19'ho\'#7#30'gsJm'#128'^'#21'y'#180#210'b'#191#31'I'#193#129'&'#128'o0' + +#206#192'A'#17'@'#197#156#147#247#195#235#252#143'X'#253#215#234#200#251'?' + +#159#9#190#1'5'#0#193#249#199#133#254#134'o'#234#175#128#207#223'y'#4#214'~' + +#155'y'#135#213'`'#161'Ti'#224#194'['#223#234#241#241#247'^'#186#3'6'#175#251 + +'R'#234#203#228#175'U'#13#231','#127'%c+'#233#251#175#222#9#155#214#14#174 + +#129'J'#223#215#174#129#243'o~3#'#206'@ae'#167'h@'#152#31'$B'#137'AD'#0'N{=8' + +#155'6'#166#180#11'S'#202'c'#223'O'#202'k;'#7#175#165'='#18#137#184'='#30'Oh' + +#160#13'C'#6'E'#0'h'#255#255#9#143#190'\'#28#254'3'#219'*'#209#4#152#204#236 + +#127#218'h'#188#183'Z'#24#243'5'#12#171#254#186#226#235#15#159#130#213'_'#190 + +'.'#245'e'#244#138#5#7#156#9's'#23'w?'#149'w'#203#250#175#224#253#151#239#144 + +#250#18#25#14';'#229'6'#24'?u'#183#140#28';'#232'w'#195#147#127'>'#161#215#2 + +#159#161'b'#202#172#189#225#128'c3'#215'+'#128#181#12#19#204#0#158#0'|^/'#180 + +#212'|'#151','#17#230#252#0#16#156'\'#208#182#31#138'Y'#227'`'#157#129#3#149 + +'L'#217#173#183#222'*{'#226#205'M_'#225#237'='#196#197'?y'#227'v'#6#171#173 + +#152#23'~n'#245#231#188#255#178'a'#217#240#179'+'#182#172#255#18'>x%s*k:'#160 + +#213#153#224#236#235'^'#237#254'A'#252#209#252#237#182#195'%o'#10'2e'#246#222 + +#176#255#209#215'd'#236#248#159#188'q/lX'#243'IF'#223#3'-|''_'#246'$s'#10#166 + +#27'I3 '#206#153#1','''#0#9#128#136#128#8' '#24#240#165#248#1#10#244#254'K' + +#11#13#158#143'Q'#11#176'SH'#16#181#128#240'@'#204#128#1#19#192#148#221'N2' + +#251'B'#178'v'#154#248#211'i'#255#171#160#164'zO'#208#235'u'#172#232#135#156 + +#127'Z>'#245'W>'#12#219'}w'#7'ZY'#158#185#235'D'#169'/'#163'O'#236'{'#212#213 + +'L'#200#186#195#11#247#158#14'^w'#187'd'#215'V4n2'#28'}^f'#29#169'O'#220'q' + +#20'D#'#161#140#191#23'K'#254'88'#233#210#199#211'~'#220#174#237#195')'#26'@' + +'$'#16' ?@'#211#6#240'8'#27#187#250#1'^'#172'0'#183#223#135'ZA'#171'N'#167's' + +#15#180'Jp'#160#162')/'#159'}'#226'!'#9#144#191'#'#216#244#20#255#215#27#172 + +'PX9'#151#9'?'#249#0#152#250#175'$'#239#191#208#244'cd'#144#192'cl'#5#205#173 + +'l'#186#174'(.'#159#6'G'#158'so'#183#143#173#252#228'9X'#253'E'#223'!'#195'L' + +' '#191'x'#2#28'{A'#250#203'j'#197#248'u'#213#7#240#223'w'#30#202#218'{Zt' + +#240#249#176#243#238#135#167#245#152'|'#247#31#212#0#184'nA'#194'hq6^'#220 + +#209#4#142#166'_'#187#250#1#214'M'#206'o?'#31#9#160#9#205#0'g('#20#242#15#196 + +#12#24#136'X2I.'#159's'#242#221'x'#222'+'#197#14'@s~%'#235#253'G'#194#175'G' + +#225#167'a'#31'D'#0'r'#133'l'#216#135#255#196'x'#225#222'S'#193#239'u'#14#253 + +'@'#25#132'Zk'#128'3'#175'}'#181#199#199#223'x'#252'rhk'#218'<'#128'#'#14#29 + +#214#130'r8'#254'"'#154#20#151#153#144#159#128#151#30'8'#27'<'#174#244'{'#254 + +'{'#2#245'5fV'#248 + +#219#26'7'#193#191#158#186'2+'#239'I'#140#25#187#30#6#11#14'Jo'#134'hgRPg' + +#159#0#193#20'h'#175#253#129#245#8#16'u'#12#134'|'#157#247#230'b'#147#255'}' + +#148#201#22'$'#128#14'2'#3'P'#3#136'B?'#162#1#3#17'O'#249#132'9G'#230#133#19 + +#250'f'#188#173'H'#150#255#170')'#254#191#16#237'~'#174#233#7#197#254'5|'#242 + +#15#215#245'w'#228'0'#128#179'm;'#188#241#152't'#13'A'#250#139#197#135']'#10 + +'S'#230#236#223#235#251'x'#243#241'K3n'#206#204'^x'#28#204#223#251#212#172 + +#188#231#183#159#190#10'I'#224#183#172#156'K'#12#149'Z'#11#167'-{-'#189#7'Mp' + +'9'#1#228#8#140'D'#184'h'#128#16#18't'#182'lBS'#160'N'#1'D'#2'd'#226 + +#216#27#215#165'8'#2'U'#242#216'&4'#3'.'#198#219#13']'#204#128'>'#163#1#253 + +'&'#0'R'#255#191#217#164#186')'#145#144#221'"'#216#255'4'#247#207#156'?'#30 + +#172'E'#19#152#240#147#243#143'&'#1#177#220#127#249#200#178#255#5'|'#251#225 + +'c'#240#235#170#247#164#190#140'^ '#195#21#233#31'h'#154#245#175#133#213#170 + +#207'_'#128'u+'#223#198#31'T'#223'%'#177'}'#158#25'5'#194#9#211#23#194'B'#212 + +'@2'#209'B'#171'''|'#242#250#157'P'#251#219#183'Y;_W'#152'l%p'#204#5#233#27 + +'u&D'#2#132#226' V'#27#16#138'23 '#16#8'B'#203#182#175#240#251#138''''#29#129 + +'2Y'#194'7'#173#160#245'd4'#11#234'('#26'`6'#155';'#182'l'#217#18'Z'#183'n' + +#29#153#1#189#170'y'#253'&'#128#165'K'#151'*6'#187#198#189#128#231';A'#236#0 + +#180#149'L'#7#147#181#132#9'?'#167#254'wv'#254'aC?F'#152#6#16#143'Ga'#5'j'#1 + +#180#207'E'#232#12'68'#238#146'g'#7#250#174#224#251'O'#158#133#223#214'|0@' + +#141'@'#198#178#250'4:3'#20#148'N'#130#5#7'_'#12'jm'#250#231#234#245'z'#229 + +#236#251'8N'#210'JG'#146#135#211#174#253'WZ'#143#201'R'#131'y?'#0#155#29#128 + +#4'@'#27#17'A'#235#182#239' '#28#246#167#248#1#198'['#237#231'j'#20#225#245 + +'J'#165#178#9'W'#127#167'N'#167#11#244#167'6'#160#191#210')'#159'7o'#158#162 + +'9:'#141'hv'#174#152#0#10'*'#230#130#201'le'#194#175#213't'#134#255#134's' + +#235#175#190#240#213'{'#15#194#230#28'u'#6#142#199#21'x'#175#223#15'>'#209 + +#134#242#29#234'6}'#7'M'#219#215#178'N4'#241'X'#132'U'#17#146#160#145#160'[' + +#242#203#153#176#23'W'#236#4#230'<'#233'Zy'#9#248#254#147#167'a'#253#247#131 + +#27#156#154'N,='#234'Z'#168#154#178'g'#218#142#215'u'#132#24'5'#10#9#242'Z@{' + +#253'Oh'#246#216'S'#8#160#216#232#249#147'M'#235#251#24#239'k'#196#191#237 + +#161'P'#200#215#159#1'"'#253#145'Pf'#255#31'|'#240#193#170#181#141'ymx'#219 + +'$'#142#0#20'MX'#8#6#157#134'['#253#133#226#31#249#200'I'#0#234#14'$'#12#175 + +'=tF'#214'<'#233#253#6'~'#224'G'#254#225'Q0Z'#138#165#190#146#172#225#229#191 + +#158#136'Z'#203#192#27'|'#164#27#21#147'wC'#18#184'.m'#199'K'#13#7'v'#18#0 + +#141#21'w4'#253#6'^WC'#151#6'!'#254#23#139#244#174#151#209#254#175#139'F'#163 + +'mj'#181#218#211#159#18#225'~'#17#0#217#255#171'6'#199'+Cq'#237#214#164#3#16 + +#237'='#181'F'#143#4#176#27#203#250'c'#171#191'Z'#193#186#2')'#21'#'''#249 + +#167''''#216'['#182#192#7'/,'#203'h'#206#249'@Q9e'#15'X'#252#251#204#228#168 + +#231'"6'#253#248#1#172#252'8'#253#217'x'#131#129'Vo'#129#163'/z&'#173#199#20 + +#210#130#201#214''''#2#16#162#1#29#246':'#232'h'#221#156#18#9'0'#168'C'#159 + +'UZ\'#15#163'|'#214#14'$'#28#216#31#17#149#163#253'/'#175'q'#151#238#23#137 + +#201#223'O'#137#0#24#242'!'#191'b'#22#155#3'@'#177#127'F'#0#138#206#8#192'H' + +#199#154#255#189#0#235'W'#190')'#245'e0'#144#231#253#152'K^'#204#170#243'Mj' + +#188#249#232#217#16#240#229'Fb'#150#12#127#240'''^'#153#222'b1a'#148'x'#140 + +#207#7' '#2#8#134'#'#224#235#176#131#189#241#231#148'H'#128'F'#25#253#181#218 + +'f'#191#3#229's;'#254#221#20#12#6#157'J'#165#178#207#226#160'~'#17#192#140#25 + +'3'#148'n'#213#172#11#226#9#249#253'b'#2'0'#217#202#193'V<'#25'U'#255'N'#2'H' + +#142#252#30#225#26#128#128#207'^'#191#29#154'j'#178'?*L'#12#242#190#239'}' + +#204'MPR5['#234#143'#kh'#220#182#26'>'#255'gnT7'#10'8'#225#242'W@'#158'&'#2 + +'f'#170'='#223'#@'#240#3#176'~'#129#148#16#228#247'B'#235#246#149')'#4#160 + +#148#199#237#147#242'Z'#175'E'#185#164#9#221#13#129'@'#192#238#247#251'}&' + +#147#169#215#226#160#190'D'#148#169#255'^'#175'W'#249'K'#147#237#190'xBv'#129 + +#152#0#172#197'S'#192#130'$'#160#161#8#128'J!'#234#254#3#204#30#29#13#4'@' + +#248#238#195'G`'#235'/'#210'8'#5#233#251'Xr'#228#245'P6a'#174#212#31'CV'#241 + +#239#167'/'#6#143'3'#183'f'#29#238'{'#252#237'l'#28'^'#186#144#236#15' '#26 + +'%N&@'#24'5'#129#230'-_B4'#18'I'#18#0'">5'#191#229'r'#20#203#173#248'w]8'#28 + +#166'Va'#30'Q'#143#128'n'#253#0#253'"'#128#182#182'6'#213'fW'#217';'#137#132 + +'l?q'#17'P'#222#184#153'`4'#23#178#213#159#171#254#235','#0#26'%'#178#159#196 + +'/'#223#252#3#183'W'#135'~'#160#1#128':'#213'.8'#236'*('#159#180#187#212'o?' + +#171'p'#182'l'#133#15'Wd'#174#164'x'#176#152#179#228't'#152'6'#255'wi;'#30'_' + +#23#196'|'#0#177'(?D'#20'M'#0'r'#6#182'm'#255#1#194'A/'#171#9#16#136#162#210 + +#226#252#139'A'#29#254#142#252#0#161'P'#168#197'`0t'#212#214#214#6'{'#203#7 + +#232#147#0'('#254#143'j'#132#250#199'Z'#243'z'#27#205#196#146'wv'#1'RB'#209#132'E'#160#165#236'?u'#151#177#223#195#184 + +#253#247'PA'#171#211#234'O'#30#3'G3'#253'@'#211'O'#4'*'#181#30'v^t'#18'L'#154 + +'s'#176#212'oU'#18#248#221'm'#240#238#147#231'K}'#25#221'b'#210#156#131'`' + +#151'}'#206'M'#235'1'#217'b'#194#143#14#139#242'&'#0#249#1'\'#246'm'#224'm' + ,#175'I!'#0#139'6'#240'q'#153#201'M'#163#250#182#225#223#141#184'''?'#128#191 + +#188#188'<g'#255 + +#167'$'#0#201'G'#141#237#223#27#130'~'#23#172#254#244'Ih'#216#250'=2'#248#208 + +#179#212#244'hj'#237#188#231#9'0~'#250'^C>'#214'p'#198#127#223#248'?h'#169 + +#253'I'#234#203#232#22'S'#230#30#206#204#128'tB'#136#4'P80'#18#163'\'#0#218 + +'"'#172'1'#136#171'ecJ2'#16#170#255'?V'#152#29#143#201#229#242'mx'#127'='#154 + +#233#237'}u'#9#234'MTY'#251#175#239#190#251'N'#245'['#171'q~0'#170#254'R'#198 + +#229#246'2'#2#208#26#242#160#160'|6'#18#0'7'#248'S'#171#230#186#255#202'y' + +#239#255#232#243#2't'#15#250#130'~'#254#250'%'#168#221#240'?'#22#178#234'o'#5 + +#30'y'#246#13#150'"('#169#154#3#147#231#28#2'f'#155#244'YwR#'#26#14#194#27 + +#143#158'"y['#179#158'0}'#215#163'`'#214#194#147#211'v'#248'1'#228#14#254#249#192#9'h'#3#167's'#208'gzA+'#255'A' + +#167#167#127#230'A'#178',8'#193'E'#148#136#0'hX('#245#5'h'#221#250#5#27#248 + +'*Z'#145#187#141'N'#20'*'#13#28'}'#233#203#25 + +';'#190#160#248'PYp'#8'5'#0#31#18#128'?D3'#2'VA$'#232'N!'#128#234'<'#251#11 + +#26'Et='#222#220#138#191#231#237'h'#2#244#26#10#236#145#0'('#4'XXX'#168'B3' + +#192#248'K'#147#237#159#241#132'l1{@ '#128'q'#179#193'h'#202#7#147#137''''#0 + +#26#3#206#183#1#207#4#9#188#243#216#185#224#239'E'#160#199#207#216#27'v?'#248 + +#18#230')^'#245#241#19#3'N'#191'U'#170#180#176#199'!'#151#193#184#201#163#171 + +#178'n8'#128'l'#223#215#239';6g3'#0#231#238's6'#211'&3'#5'!'#29#152'"'#1#212 + ,#25#200#235#11#177'\'#0'J'#4#10#251#157')'#4'0'#222#234#248#135'N'#21'YK&'#0 + +#229#2#224#234'O'#205'A\'#212'$t'#247#221'w'#143#12#136#0'('#7' '#20#10#25 + +#127'm-x'#27#9#128'IF'''#1#204#5#163#217#10'f'#163#22#180'H'#0#212#9'H'#166 + +#200'\'#15#128#143'W,'#7'{'#227#198#30#31'''/l'#193#184'i'#208'Z'#251#243#144 + +#206'SX1'#3#150#28'u#j'#19#218#204#188#145'1'#12#10#239'>q'#1'x]'#205'R_'#198 + +#14#160#26#141#195#255#144#217#182'd'#9'^d'#217#192#208'p'#20'<^'#158#0#234 + +#215'B8`O!'#128'J'#139#227#13#189'*L'#197#18#201'\'#0#212#226#157'H'#6#221 + +#230#2#244'J'#0'j'#181'Z'#19#139#197#140#155#28'E'#175#196#226#242#165#236#1 + +#222#203'o+'#157#131'&@>'#243#1'P$@'#145't'#2'f'#134#1'V~'#240' l'#203'R'#211 + +#13#5#146#201#220#253#206#131#234#153#251#15#253'`cH'#11#214'|'#254'LN'#166#1 + +#31'p'#234'=`+'#158#148#209's'#8#233#192'q'#158#0#220'D'#0#254'0'#18#192#26 + +'4'#1'\)'#4'0'#193#230'x]'#171#140#172#3'>'#27#144#186#4#247'6-'#168'O'#2#8 + +#135#195#166'm'#29#165'OF'#227'r'#166#227#8#4'`)'#153#9'f['#17#24'y'#2#160'f' + +' '#178#12'N'#2'j'#174'Y'#3#255'}'#237#214#140'~'#208']a+'#158#8'K'#143#187 + +'-'#235#189#238#199#176'#'#130#254#14'x'#251'og'#230#212't'#230#146#9#187#192 + +'^'#199#220#146#241#243#8'EAqf'#2'D'#192#235#14#129#151#8#160'n'#21'DB'#30 + +#238'9<'#1'L'#180#181#189#162'R'#196'6Q='#128#208#30#12'I'#192#209'S2PO'#210 + +#154#204#2'D'#152'6'#180#218#238#143#198#21#201'('#0#17#128#185#136#250#194 + +#151#128#201#164#3#131'^'#197#17'@'#134#235#0'^'#187#247'('#180#131#178#251#3 + +#144#203#149'0{'#233#25'0y'#222'aY='#239#24'v'#196#166#213#239#194#143#159'<' + +'!'#245'e0'#208#140#132'C'#207#251'{'#210#241#156#13#196#248'T`'#143''''#8'>' + +'$'#0'J'#5#142#133#131')'#190#145')'#249'-+'#208#26#175#1'>'#25#8#247#13'(' + +#252#164#1#248#186#235#11#208''''#1#168'T*'#243'f{'#254#31#195'1'#197#25#236 + +#5'<'#1#152#10#166#176'D '#179'Y'#139#4#160'a'#4#192'f'#1'f'#144#4#200#14#244 + +'8'#26#135'~'#160'A'#192'RP'#9'{'#31#127#27'h'#141'y'#146#156#127#12#28'>}' + +#233#6'h'#173#251'E'#210'k'#208#155#242#225#16#18#254',u`f&@'#28'X'#243#15'J' + +#0'r'#187#3#204#7#208'F'#169#192#209#136#152#0#18#211#11'[^'#196#191#235'I'#3 + +'P('#20#219'"'#145'H'#3#222#223'>h'#2'@5'#194'R'#227'*'#188'>'#20'S^'#200'^' + +#192#11#184')'#127'"'#152#11#171#192'l'#210#128#209#160#3#165#138'k'#6#154 + +#201'>'#0#171'>~'#156#173#2'R'#129'Z?'#239#188#240'$'#152#177'gzK>'#135#27 + +#220#246'zh'#216#252#29#11#183#6'|.'#8#5#220#172'V_'#165#214#129'Zg'#2#173 + +#222#12'Fk)TN['#12'zsAZ'#207'MCY'#222#127'J'#186#134#160#244#190#14'9'#231'a' + +#166#25'f'#11#156#15#144'/'#7#14'F'#160#163'#'#192#178#1#219#182#254#143'/' + +#20#226#228'Y.KDP'#3'x'#149'R'#128#129#171#5'`'#233#192#184#136#183#187'\.ow' + +#147#130'z%'#0#170#3#192#23'['#234#189#197#151#6'"'#202'd'#23'F"'#1#131#181 + +#10#172'%'#19#193'd'#208#130#201#172'I'#154#0#178#12#134#210'i '#194#7'OH?' + +#158#219'd+'#133#165''''#252#31#232'-'#133'R_J'#198'A'#130']'#187#225'Kh'#218 + +#242#3'ks'#22#244#216#7'4'#135#143#134#148#26#172#197'P1u'#1#236#180#240#184 + +#180#9#206#215'o'#221#13'u'#191'~'#153#213#207#194'Z4'#30#14'<'#235'>'#188 + +#149#253'|'#17#166#1#160#249#27'@'#193'w'#185#209#4#240#5#161'}'#235#23#220 + +'c<'#1'('#229#241#224#164#188#214#127#226'M'#154#18'L'#234#255#214#190':'#3 + +#245'J'#0#227#198#141#211#6#131'Ak'#141#211'r'#182'/'#172'Nz;H'#208#245#214 + +'r'#176'P='#0#154#0'&'#147'6'#217#15' '#211'x'#253#158'c'#210'2'#201'v'#168 + +#160#228#163'Is'#15#129#185#251#159''''#245#165#164#21'm'#245#235#161'n'#195 + +'W'#208'^'#183#142#173#178#209'4'#142'B'#167#207#172#160'b'''#152#179#247#153 + +#144'W:y'#200#199#219#188#250'='#248#241#227'''3>'#168#149#186'/O'#158#127'8' + +#204#217#231#172#140#158#167'W$'#184#17'a'#1#180#253']'#164#1'x}`'#223#254#13 + +#255#16''''#207'*E'#204';)'#175#157#6'%'#146#218#207'4'#0#154#24'L#'#195#245 + +'z'#189#167#191#4#192#10#129#208'VPVVVjc'#177#152'e'#187#211'|'#162'7'#172 + +#185'+'#249#4'j'#9'f*'#5'['#201'4\'#253#181','#23'@'#165'Qr'#149#128#221#229 + +'j'#164#145#23#254#243#236#149',3,W@'#17#130'='#127'w5'#148'T'#15#207#190#252 + +'q$'#211#205'?~'#0'5'#235'>'#135#142#182#154'n'#11#174'2'#129#252#178#169#176 + +#232#152#27#217'H'#173'!]?'#10#255#143#31'?'#1'['#127#250#152#13'2M+'#240'w^' + +'>y'#15#216#253#176'+'#178#155#23#210#141#12'%d'#192'f'#3#4#252'!'#232'p'#5 + +#192#235'q'#131#163'ne'#138#3'P'#163#140'vT'#219#236'4'#187#190#129#132#159 + +'6'#165'RY'#135'2'#220'6h'#2#136'D"'#214#6#183#249'w'#238#144#238'!'#241#147 + +#180#166'b'#176#149#206'`y'#0'&'#139#142'M'#7'b'#29#129'2'#252#217#172#251 + +#250#31#240#243#127'_'#200#222#151#209'O'#20#148'O'#135'%'#199#222'<,B'#134 + +'^\'#217'7'#174#252#23#218#241#223#131#223#211'.Y'#145#13#249'T'#166#237'~$' + +#139#178#12#29'qX'#243#201'3Hd'#255'e'#205'C'#134#2#133#146#146#202#166#163 + +#224'_'#206#18'}r'#1'T'#13#24#141#198'P'#245#15#129#219#229#7#175#219#1#206 + +#134#31'S'#8'@'#167#140#216#171#172#246#143#128#215#0#168'"'#16#247#140#0#240 + +#182#183#187#138#192'~'#17'@'#179#199#184#175'3hxZ'#252'$'#141#161#0#242#198 + +#237#12'F'#163#14#205#0#29'k'#14#154#169'^'#0'b'#208'D'#222'7'#239#203#205 + ,#194#16#25#170#138';-8'#22'v^'#156#190#198#144#233'BG{'#29#252#244#233#211 + +#208#142'*~$'#228#151#250'rR`-'#154#0#251#159'y'#127#218'j1(g`'#195'7'#175'C' + +#253#198#175#193#215'A'#3#173#251'&8r`'#22'V'#238#12'Sw;'#2#138#170'fI'#253 + +#145#236#0'z'#7#17'j'#7#230#9#162#9#224#199#247#213#14#206#198#212#238#200'z' + +'U'#184#165#210#226#248#12':}'#0#228#4#172#29#18#1#144#9#208#234#209#237#209 + +#230'7'#254'#'#229#3#211'Z!'#191'b'#14#24'P'#253#183#152#245#172''''#0'u'#4 + +#202'F3'#208#127#221'w'#18#251#146's'#21'Z'#163#13#22#163'z'#155'?n'#154#212 + +#151#2#174#214#26#248#238#223#247#129#179')w'#204#166#238'@'#159#217'!'#231 + +#254#13#212#250#244#14':!'#19#193#217#188#21':Z'#183#129#27'I'#208#227'jfu"F' + +'['#25'X'#11'+Y'#178#151#165#184':'#183#11#193'X'#166#31#215#11#192#235#13 + +#176'('#128#199#209#12#238#150'u)O3'#170'C'#141#21#22#215#127#249'N@d'#2'l' + +#29#148#9'@'#155#216#9#232#244#171'f6z'#172')'#241'7'#133'J'#7#5'U'#187#131 + +#193#160#1'3'#154#0':'#150#11' '#239#182#31'X'#186')'#225#203#127#222#153'u' + +#15#240'`0e'#215#195'a'#222#129#210#12#177#8#251#221#240#217#203'7'#131#163 + +'i'#147#212#31'C'#191'A'#5'Y'#135#156#255'(k'#135'>'#154#209#157#190'B'#9'pa' + +'>'#9#168#3'M'#0'w'#251'v'#240#218'S'#167'#Y'#180#193#154'2S'#7'y'#6#27#248 + +'$ F'#0#209'ht@N@BJ'#24'P'#169'R'#149'nh-'#250#2'_'#165'I>'#3#5#189'p'#194'"' + +'$'#0#29'X'#172'z'#208#27'5'#172'5x'#159'y'#0'i`'#131#230'mk'#224#211#23#174 + +#207#202#151'1T'#152#11'*'#224#128#179#238#205#170'o`'#235#154#255#192#202'w' + +#31#206#154'C/'#157#160'<'#130#163#174'x!mSv'#135#5#250#180'P'#184#28#128'`0' + +#2#30'w'#0#220#168#1#184'Z6@'#160'#5)'#174#208#224']W'#160#247#253'D'#137'@d' + +#2#240#142#192#186'A'#135#1#137#0#240#133#164#147#21'ov'#20#191#30'K'#200'''' + +'$'#159#129#4#144'W1'#15'L'#22#27'j'#0#6'V'#19#160#226'C'#129']'#223'O&'#140 + +#130'W'#238'8l@'#241'h)A'#177#240#189'N'#184'%+'#145#130'O'#158'_'#14'-5'#185 + +'99'#167#191#176#20#141#135'C'#207#127'T'#234#203#144#4'='#5#209'('#2#16#12 + +#132'Q'#248#253#168#5#4#192'Q'#207#149#2#139'Qnv'#174'D3`'#19'%'#255#8#26#128 + +#144#8#132#154#128'o'#192#4' '#164#2#227#193#138#183'8'#10#30#12#199#20#139 + +#196#151'E]'#129','#249'e`'#178#234#192'd'#212#129'ZC~'#128#236#204#5'x'#239 + +#209#11#192#217#178'-+'#231'J'#23#166#237'q$'#204';(}'#195'#S'#128'6'#226'{' + +#127#191'h'#216'}&=a'#194#236'}a'#193#145#185'7'#1'X'#10'P'#18#16'E'#0'('#4 + +#200#17'@'#16#218#183'}'#3#177'h0'#229'y'#19#243#218'>U+'#226#164#254#215#163 + +#224'3'' j'#2#245#129'@'#192#142'f'#128'w'#208#181#0#248'wQ'#141#211'v'#173 + +'?'#162'Jq'#191#27#242#171#217#20#27#179'Y'#159#12#5#210'x'#176#158'k'#12#211 + +#247#161#172#253#244'yX'#251#249#138#236#127#27'C'#196'n'#135']'#12'Sv;<'#189 + +#7'E'#251#240#237#135#207'cN'#174#145#3#25#28'~'#201'c`)'#172#146#250'B'#178 + +#131'^'#204#0'j'#6#18#165'n'#192'>'#206#254#247'z'#252#208#182#245#139#148#16 + +#160'\'#150#136'N'#201'o'#249#8#5#159#194#30'uB'#30#0'nD'#8#246#129#214#2'$' + +#203#129#241#128'fd'#143#194'F'#143#229#20'wH'#151'B'#201'ZS'#9#228#143#155#1 + +'&'#179#14#204'V=h'#132#178#224',('#1'>W'#11#188'q'#239#169#153'?Q'#154'AYeG' + +']'#189#2't'#166#244#21#21#189#247#247'K'#192#222#176'q'#232#7#202'1'#152#242 + +#199#193#17#151'?#'#245'eH'#10'a&'#0#245#1#240'y'#3','#7#192#237'p'#160#9#240 + +'Cj'#18#144'"'#234#169#206#179#127#129#247#181#161#204#210'J'#192'f'#3#12#182 + +#28'8'#165#31#0#218#15#133#142#128'ai'#139#215#248#160#248'Ij'#141#5#10#198 + +#207#3'#O'#0','#18#160'R'#176#142'A'#137','#12#7'}'#233#214'Cr"-x'#160'`?' + +#236'+'#158'K'#203#177'H'#19#250#9#183#145#138'='#143#184#10'&'#205#31#157 + +#163#208'9$ '#30#163#8#0#239#0't'#250#193#213#214#0#238#214#245')'#4#128#182 + +#127'K'#133#197#245#3#222'l%'#199#31#240#229#192#168#193#147#167'pp'#13'A' + +#168'%'#152#223#239'7!'#131#20'D'#19#170#201'['#157#133'o'#136'_'#163'P*'#161 + +#176'z1K'#6#162'H'#128#206#168'ERP'#246'/'#23' '#13#252#240#206#131#231#177 + +#24#239'p'#196#188#131#207#131#25#139#143#27#210'1'#236#13#191#193'{'#127#187 + +'(g{'#229#165#3'r'#133#18#142#185#246#21#208#26#173'R_J'#250#209#143#175#141 + +'u'#2'B'#251#159#28#128#140#0'P'#3'p6o'#1#175'c[J'#6'g'#158#206#191#173#200 + +#224#166#196#128'VJ'#254#17'z'#2#146#6'0'#232#150'`BO@T'#31#10#240'GV'#190 + +#201'Q'#242'J}'#246'F)'#191#167'A'#129'j'#227#207#184 + +#251#179'A'#189'6'#28#244#195#138#27'G'#167'c'#172#176'r''8'#248#194#7'Xr' + +#213#136'@'#143#250'?O'#0#188#253'O+'#191#199#229'C'#18'p'#130#189'v%'#211#12 + +#4'('#229#177#224#228#252#246#175#240#249#2#1#212#0#231#4#164#209'`-h'#198 + +#187#131#136#1'M'#6#18#15#7#141'F'#163'6'#180'%J'#28'~'#221#190'->'#243#29 + +#226''''#170#212'z('#172#222#19#140'&'#29#152'mD'#0'\B'#144#208'&<'#27'j'#192 + +#11#215#31#8#145'P'#250#26'Wd'#3#244#3'>'#253#174#143#7#245#218'_'#254#251'*' + +#172'|{'#244#14'DUi'#13#176#223#153#127'd~'#148#145#138#4'_'#0'D'#241#255#160 + +'?'#4#30#180#255#189#184'9[j'#192#221#250'['#138#227#215#160#14#219'+'#204 + +#142#213'('#252#14#138#251#211'<'#0'>'#19#144'*'#1'['#7'3'#28#148' G'#155#129 + +'U'#4#250'|>'#139'F'#163')'#142#199'a'#194'F{'#225#243#137#132','#217#29#129 + +#170#168#24#1'X,'#204#15'`'#160#210'`'#230#7'P$'#29#129';'#156'-'#205'N'#235 + +'_'#191'z'#19#190#249#231'_%'#249#162#6#11's'#193'88'#230#250#193#141#147#254 + +#247#131#23'@k'#141#180#141'1s'#1'TA8m'#193#239'a'#206#1#167'g'#181'G_Z'#209 + +#131#134'L+<'#133#255#200#254#15#160#253'/'#16'@{'#221'Z'#8#186'[S'#8#160#208 + +#224#221'R'#160#247'Q'#185'g;'#17'@'#127#235#0#196#167#239#14';d'#3#226'V' + +#185#197#158#255#167'PL1#'#249'$'#20'rK'#241'N`-'#174#0#147'U'#143#4'`'#0#173 + +'A'#13'*%'#154#1#138#204#205#10#236#138'Wn;'#10'|'#206#214#236#156','#13#152 + +'0go'#216#231#140#255#27#212'k'#159'_~'#0'D'#130#185'U'#211'/%'#168#15'C'#233 + +#164']'#160'z'#151'}'#161'j'#230#226'a'#31'2dFz'#156'S'#255'#A'#222#254#167 + +#30#0#184'o'#222#252#5#196'#'#225#20#2#24'o'#181#175#210#169#162'-x'#179#29#6 + +#144#5#200'>'#187#222'>W'#241't d'#146'B4'#5'*'#154#188#182#179#221'!'#237 + +#209#201'''Q'#131'PK)'#228'W'#206'dQ'#0#163#197#0':'#147#150#21#6#201#149#217 + +#233#15'@h'#217#250#19#252#251#129#225#227'%^t'#194'r'#152#186#231#224'R'#130 + +#159#185'b'#201#176')'#132#146#2#148';'#160'3'#231#225#162'4'#30'J'#170'g' + +#195#196'y'#251#131#9'5'#174'a'#131#4'7'#9#184#211#254#199#213#159'e'#0#182 + +#131#189#230#7'6"L'#144'c'#133'<'#30#153#146#223#246'5'#10#186#7'e'#141'V@' + +#178#251#5#2'h'#196#197#219#217'S'#18#16#161'W'#2#16'&'#4#163#253'o'#212#233 + +'t'#249#241'x'#188#188'#'#168']'#220#232#177#220#156'|'#18#10#184'R'#163#131 + +#226#137#11#153#31#192'h3'#128#158#18#130#180#252#184#176#12'N'#12#238#138 + +#183#239#251#3#180'n'#27#218'l'#192'l'#225#212'?'#127#0#154'A6'#191'x'#242 + +#210#133#144'v;j'#132#131'HAo)'#128#252#242')P>mw'#152#186#224#240#156'4'#27 + +#216#234#159#224#212#255'('#170#255'd'#255#147#240'3'#251#191'y+'#218#255#155 + +'Xn'#128#0#163':'#212'^aq'#145'='#216#129#178#216#140#143#17#1#176#8#0'.'#220 + +#212';'#189#199#193#160#132'>'#9'@'#28#10#196#251#202#240#160#213#155#28'%' + +#143#196#19'2'#29'{'#18'k'#5'.'#135#194#9'{'#128#201'f'#227#205#0#174'.@AZ'#0 + +#171#14#236'>)'#168#219#147#14#225#195#11#184#29#240#210#141#135#231'|^@~' + +#197'T8r'#217#179#131'z-E'#0#158#191'f_'#169#223#194#176#135'J'#171#135#165 + +#167#222#2'U'#179#150'd'#252'\'#253#253#221#211#243'h'#177#140#199'x'#245'?' + +#20#129#128'7'#136#194#239#227#226#255#219#127#132#128#167'-%'#2'Pd'#240'l' + +#201#211#249#182#163#28#186#144'8'#154#132'$ '#218#227#202#223'b0'#24'X'#8'p' + +#221#186'u'#20'7'#140'ww'#222#30#175#137'"'#1#223'}'#247#157'*'#16#8#232#208 + +#20#176#161#9'P'#138'D0~'#155'3'#255#250'`T9C8'#4#249#1#172#165#211'Q'#229 + +#170#2#163'@'#0'z'#13#168#132'h@'#182'T'#0#196#202#127'='#12'k?z1k'#231#27'(' + +#232#179'8'#254#246'7'#192#152'W:'#168#215#7#189'Nx'#241#218#209#25#2#204#4 + +#138#170'g'#194#129#23#220';hm,'#221'`'#222#127'Z'#253#163'Q'#8#163#250'O' + +#246#191#151'%'#0#249#161#5#237#255'h'#23#251#191#218#214#190'J'#173#136'R' + +#248#207#129#127'6R'#8#144#239#7'H'#154'@k$'#18'q{<'#158'Pw!@B'#175#4'@'#155 + +#16#9#160#230#160#212#23#0#239#171'j'#246'ZNv'#5'uG'#8'O$'#2#208'['#202' ' + +#175'b&'#18#0#154#1'f'#3'W'#23'@'#141'B'#217#200'0'#25'd'#205#14'@'#188#255 + +#224'%'#208#176'ae'#214#206'7'#16'L'#156#191'?'#236'}'#214#29'C:'#198#147#23 + +#238'.'#245#219#24'Q '#243'`'#223's'#239#204#138'6'#208#27'HB'#168#244'7'#30 + +'E'#2#8#161#250#31#8#129#223#205#169#255'n{+'#180'o_'#197'Z'#131'u'#14#2#137 + +#133'&'#229#181'}'#143#194#239#195'?'#237'|'#8#144#217#255#168#181#215#247 + +#214#12'T|'#206'^?'#27#161'3'#144'^'#175'7'#1#31#9#240#132#212'{'#214'uX'#151 + +''''#15'"''?'#128#22#138'''.b'#171'?e'#4#234'L|8'#144#175#13'`'#166'B'#22'?' + ,#204'Wo>'#10#220'm'#245'Y'#3'p;'#202#27#253#221#209'S'#17#144#128'~'#17#0#213#4'x<'#30 + +#180#2#244'Vr'#4'"'#17'T5{'#244'G8'#2#198'dA;'#9#184'Zg'#132#162#137'{2'#2' ' + +#13'@'#199#178#2'5'#172'6@'#208#2#178#146#27',B'#243#230'5'#240#254'}'#23'B4' + +#18#202#234'y'#197#216#237#168'K`'#246'Ag'#164#237'x/\'#181#31#174#6'C'#155 + +'~3'#134#238'A'#157#154'N'#185#247#163#172#159#151#171#252#227#212#255'p0'#12 + +'Ao'#144#9'?'#173#254'T'#244#229'j'#222#200#156#131#130#253#175'VD'#253#19 + +#243#236'?'#226#223#148#17#230'@'#18'`'#14'@'#222#254#167#134' }:'#0#9#253 + +#145'F9'#146#128#18'I'#128#210#127#205'h'#10#20'#'#9'T'#198#19#138')'#155#157 + +#133#183''''#18'2V'#149'A'#194'M'#13'B'#10'*'#231#161#25'P'#8#6#19#18#0#211#2 + +#136#0'T'#160#16'*'#4'3gK'#198#223#195'h'#197#180'%G'#193#226#211'o'#202#206 + +#201#184#170#31#142#0#248#216#127#208#23'd'#130#207#212#127#167#19#9#224';' + +#212#12'"b'#251'?1)'#191'}'#21#170#255#228#8'"'#251#159#26#129#214'R'#248#15 + +#23'h'#234#1#208#136#194#239#232#203#254''''#244'G'#10#153'#'#16#15#166'"?'#0 + +#10'p>'#158#168#140#252#0#206#128'vi'#179#215#194#21'h'#147'#PFf'#128#14#205 + +#128#5#140#0'H'#3#224#162#1#252#244'`j'#24'*'#151'u'#27#17#200#240'P'#225'$' + +#26#127']'#9#31'>|%D'#130#190'L|'#157'L'#203#153#186#232#8'Xr'#234#13'd'#23 + +'e'#228#28'O'#253'a7'#246#131#24'Cf`*('#131#19#239'zw'#200#199#233#235'7-<' + +#206#21#254#196#208'LE'#2' '#231#31#18'@'#160#131'['#253#157'M'#155#192'M' + +#222#255'h4'#169#254#235'U'#225#142'J'#139'c'#29#202'Q'#0#239's'#1#215#4#164 + +'V'#176#255'qk'#17#154#128#160#240'G'#249'S'#13#158#0#186#250#1#144'eJ'#240 + +'~'#234#215'\'#189#201'Q'#180'<'#22#151'S'#136#144#17#0'e'#255#217#202'g'#130 + +#185#176#140'#'#1'3o'#6'h'#133#204#192#206'nA;'#148'Bw'#185#154'L'#182#186 + +#219#248#191'7'#224#199'w'#159#2'O['#250'Zj'#149'M'#155#15#251'^xOF'#139'Q' + +#234#214'~'#9#31#220'?z:'#1'I'#1'J_?'#231#137#31#134'D'#224#221')'#184']'#127 + +#207','#251'/'#193'y'#254#185#213'?'#138#230'j'#136'y'#255'I'#253#15'P'#243 + +#143'-'#223'@'#200#239'I'#137#255#151#24#221'[l'#186#0#165#249#250#241'>'#150 + +#0'$'#148#0#227#177#234'PKo'#235#143#253'/\C'#127#192#252#0#168#5'h'#220'n' + +#183#5#217#165#8'OXIf@'#131#219'r'#130';'#164#221#141#29#140#198#131'+'#20 + +#172'8('#175'j&o'#6#232#144#0't'#160#210#169#147'Z'#128#16#17#200#5'8'#27#182 + +#194#183'/'#255#5#26'~]'#201#134'F'#14#4'T'#133'f-'#29#15#19#230#239#15';' + +#239#127'2h'#12#153#207'&{'#239#238'?@'#195#250'o'#165#250#184'F'#13#246#189 + +#240'n'#168#222#245#128#140#158'#!'#168#255#148#249#23#137'B4'#200#169#255'd' + +#255#7#220'T'#252#211#10#142#237#171'!'#134#143#197#249#231#202'e'#137#216 + +#228#252#182#213'2'#136#7#248#248'?9'#131'X'#252#31#229#170#6'o7'#160#156#182 + +'['#173'V__'#246'?'#161#223#4#128'f'#128'\'#156#15#128#251'rd'#155#9#193#152 + +'v'#238'v'#151#237'\v02'#3'P'#184#149#26'5'#20#146#25'`6'#161#9#192#145#128 + +'Z'#199#229#4#144'/@&'#242#5#236#176#234#15#225'"'#135#2'R'#177#234'~'#254#10 + +#26#214'}'#11'm'#219#214'1'#205#128'&'#203#138#175#130'VvKq'#5's'#16#149'M' + +#159#15'e;e?#'#239#233'sw'#131'hX'#186#136#198'hA'#213'.K'#225#192#203#31#24 + +#212'k'#251'j'#132#155'L'#250#137'sC?c'#164#254#211#234#31#8'A'#136#188#255 + ,'l'#245'G'#245#191'a=x'#237#245')'#225'?'#179'&'#216'^fr'#209#196'W'#26#11 + +#228#22'*'#0#137#0#132#30#128#129'@'#192#137#230'z'#159#246#127'w'#215#214 + +#227#243#132'|'#0#178#1#168'0('#26#141#150'Q8'#16#31#155#176#197#145#127'a8' + +#166','#226#252#0'\4'#192'R6'#13#204'EU,$H~'#0#202#9' -@'#201#198#135')'#144 + +#4#184#196#160#28'Q'#4#134#5'>z'#248'*'#216#246'}'#246'CT'#163#17#182#242'Ip' + +#236#31#223#200#216#241')'#233''''#17#3'V'#214'M+'#249'C'#250#15#156#224#226#254'@'#158#255'8'#231#249#143#6#195','#243 + +#143#169#255#168#250#19#9#216'kV'#163#25'`gY'#172#130#250'o'#211#249#27'K' + +#140#30'R'#247#131'|'#250'/'#27#3'F'#241#127'R'#255#169#1#8#154#19#142#190 + +#242#255#197#24#136#228'%'#195#129'V'#171#213#24#12#6#169'Sp'#25#17#0#238#171 + +'j'#156'yg'#4#162#170'*'#193#12#160#162#10#163#173#4'l'#21#179#144#0#180'<'#9 + +'hy_'#128#154'9'#3#169'T'#24'dBX'#176#135#14#194#144'$'#205'~^e'#250#191'3)A' + +'~'#136#215#151#31#1#174#198#209#212#2'\zP'#133#224'9'#207#241'c'#214#135#26 + +#141#226#139#253#19#252#129#216#234#207'l'#127#170#250#139#176#208#31'9'#255 + +'H'#240#131'H'#0'>G'#27'8jWC$'#28'I'#241#254'O'#176#182#175#213#170'b'#30'R' + +#255#241'O'#23'5'#0#1#222#254''''#239'?'#223#16#164#163#183#6' '#221']Z'#191 + +#223#134#16#14#164#254#0#248#183#21'U'#13#150#21'H='#2':'#130#186#5#141#30'3' + +'+'#17'f'#177'~'#185#2'Tj5'#20'T'#239#10'z'#139#141'E'#2#136#0'4d'#10#176'f!' + +'*'#166#5'0_'#128#140#159'(<'#194#132'w'#168#160#130#159#215#151#253#14#127 + +#16'cI?'#217#134'B'#165#129#179#158']'#157#222#131#242#131'>'#133#142'?'#204 + +#246'G'#2#8'3'#225#231#9#0#247#142#186#159#192#239'la'#142'iA'#253#215#169'"' + +#238#241'V'#199#175#188#250'O'#9'@'#164#254#179#240#31'%'#255#144#250'O'#225 + +'?\'#160'='#253#9#255#9#24#16#1#208'&'#152#1#8#19#153#1#148#21'H'#4#128#143 + +'Umu'#22#156#25#142')'#11#133'.A'#20#247'7'#228#149#129'm'#220#206'I-@C$@CDY' + +#179#16'!/'#128'F'#137'e?E8'#151'AQ'#136'7'#174';r'#172#234'O"'#168'tF8'#227 + +#201#244#246#148#16#135#253'('#238'O'#158#255'H'#16'U'#127'"'#0#15'n>'#170 + +#254#179#163#250#191#10#205#189'0'#243#15#8#234#127#185#217#185#193#168#14 + +#145#211#143#169#255#192#13#1#173#23#17'@'#147#160#254#163'lF'#250#10#255#9 + +#24#168#196'13'#160#176#176'PE#'#195#168':'#144#6#134#224#133'T'#145')'#224 + +#10#234#23'4{'#205#7#2#175#210'S'#21' '#211#2#198#239#14':'#139#5'4F'#29's' + +#10#170#13'|'#207'@'#181#138'=G!'#231'g'#9#202#248'K'#234'O'#154#224'`'#223 + +#193'0@'#235#166#159#224#223#183#159'6,'''#31#143#20'h'#205'yp'#234'c_u'#255 + +'`_b'#213#205#239#151#21#251#240#163#190'H'#176#227#201#213#191#211#249'G' + +#171#191#179#254'g\'#253#155'8'#231#31#175#254'k'#149#17#239'x'#171'}='#10'{' + +#132#138#127#200#251'O'#237#191#240#200#181'|'#2#16#169#255#164'&v'#168'T' + +#170'`w3'#0#251'{'#169'}>_0'#3'('#26#128#127'['#168'K'#16#158#188#130#8#0#168 + +'m'#184#179#240#244'HLa'#21'j'#3#148#168#234#27#243#202#193':n:'#168'Q'#11 + +#160#193'!D'#4'j'#22#18'$'#18'P'#240'aA9?V|'#16'W5'#130#176#229#235#247#224 + +#243'G'#174'a'#182#223#24#164#3#133#1#143#190#251#157#244#28#140#15#252'S.' + +#127'"'#202#175#254'h'#223'G'#130'a^'#253#15#176#172#191'@'#135#19'W'#255#239 + +#185#213'?'#130'$'#193'1'#7#140'3w'#252'f'#214#4')'#244#23'F'#185#242#240#201 + +'?'#228#253#167#240'_'#13#202'"'#205#4'l'#31#136#247'_'#192'`D-'#165'8'#8#184 + +#193#161#204#25'H'#154#128'#`X'#208#234'3-'#21'F'#131#145'3P'#169#209'@'#225 + +#132#221'@k'#178'0'#19#128#242#2'Th'#6#8'Z'#0#171#20'Lv'#16#150'%'#157'&'#253 + +'m$:R'#176#254'?+'#224#235'g'#239#200'l'#14#244#24#250#133#233#251#159#8#11 + +#207#186'eP'#175'M'#249#221#242'!?'#230#253#143'q'#5'?'#156#237#31#134#8#31 + +#250#163#212'_'#218';'#27#214#129#223#209#8#209'H$'#25#251#215'('#162#254#9 + +#182'v'#234#250'K1}'#10#3'Q'#247#223#22'~'#213#175#193#191'k)'#249#167#175 + +#246#223#189']'#235#128#223#159#208'-'#24'm'#13'='#178#143#141#204#0#188#191 + +#146'i'#1'2Y'#229#22'{'#193'I'#145#184#194#196'r'#2#228#10'P'#170#149'`'#200 + +#175#2'k'#233'T\'#253#181'H'#2#168#5#232#185#196' V)H'#179#4'),'#168#232#140 + +#10#176#19#245#148'" zk'#178#228'?'#195#27#171'^{'#8'V'#191#254#176#212#151 + +'1'#6#30#135#223#186#2'J'#166#207#239#246#177#148#223'_/'#191#189#4#223#232 + ,'#E'#245#167#213'?'#24'a5'#255#17'?'#231#252#11#177#216#127#7#180'o['#9'Q$'#6 + +'z'#14#181#6#163#215#149#153':'#182'X'#180'A'#154#248#19#225'{'#255#145'&@+>' + +#9'>'#133#255#234'q'#223#170#211#233#220'='#13#0#237#13#131'"'#0'J'#10'B'#150 + +'a'#205'B'#3#129#128#153'J'#132'c'#177'X'#5'e'#6'rZ'#128#17#181#0#227#158#130 + +'3'#144'T|'#138#255#231'O'#216#3'W'#127#19'G'#2#212'4T'#207#151#10#147'CP' + +#221#233#16#148#241#166#128'l'#7#233#30#204#202#152#251#236#240#213#147#183 + +#192#175#31#189','#245'e'#140#129#7#253#6#207'~'#249#215#129#190'Jt;'#145#12 + +']'''#189#254'd'#207'Gx'#199#31#173#254#254'P'#210#251'O{W'#227#175#224'u' + +#212#177'~'#0#148#31'@i'#194'jE4Pmk'#251#5#229'!'#138#199#160#252'o'#15'nT' + +#250'['#207''''#255'lG'#217'#2p'#244#167#246#191#175#171#30#208#187'%g'#160 + +#201'dR'#163#218'a'#196#191'Yj0'#229#3#224#237'*|'#175#228#11'8>'#154'P'#232 + +#153'3'#16'Ww'#188'P0'#20#146#22'0'#133'9'#1'Y8'#144'6=_)H)'#194'h'#6'P'#18 + +#145'L('#22#202#206'lQIa'#175#217#0'o.'#251#157#212#151'1'#6#17'J'#166#205 + +#135#195'n'#127'iH'#199#232'n'#245#143#161#240#179#184#127'0'#196'9'#255'|A' + +#206#1#232'qC{'#205'w'#168#25#132'x'#207'?'#183#250#151#24#221#219#172'Z'#127 + +#155#200#249#151','#253'%'#225'GY'#169'C'#185'k'#182'Z'#173'.'#148#195#192'@' + +#156#127#2#6'M'#0#130'3'#16#153'G'#231'r'#185#200#233'W'#140#23'T'#1'\'#153 + +'pe'#155#207#184#208#30'0'#206'Kj'#1'H'#2'*'#141#22#242'(='#216'bE'#2#208'$' + +#137#128#180#3#133'P($T'#11#138#251#6#140'`'#22'x'#251#250'c'#161'u'#211#26 + +#169'/c'#12'"'#28'q'#215#155'PP'#189#243#160'_'#207#249#252'D'#141'>H'#168'#' + +#188#227'/'#192#173#254'L'#248'}AF'#4#174'z'#180#253#157'h'#251'S'#211#15'z.' + +#190'T%'#139#134'&'#230#183#255','#227'l'#255#16#18#0#139#253#163'l4'#144#240 + +#227'mr'#0#178#206'?]b'#255#253'V'#255#9#131'&'#0#232#146#19#128#23'H'#163 + +#195'h'#0'[%nU1'#210#2#28#133#199#198'P'#180#217#160'p'#210#2'P'#192'u'#150 + +'"'#176'U'#204'fu'#1'I'#2'`'#14'A$'#1'V.'#204#153#2#192'L'#7#254#242'Fh'#170 + +#176#223#217#10'/'#159#183'p'#204#233#151'C0'#20#148#194#9#127#255'b'#208#175 + +#151#241#169#190#204#8#136'w'#198#252#185#130#31'A'#245#199#205#31'`'#197'?' + +#1#23'e'#253#173#225'<'#255#209#206#213#191#216#232#169#177'i}'#173#252#234 + +'O'#153#127#212#5#150'B}'#245'T'#246'KN@Z'#253#145#0#156'~D'#127'S'#127'w' + +#184#222'!|V'#201#10'A'#179#217#172'#g '#222#199'B'#130#184#175#162'=j'#1#11 + +#218#253#134#185#204#169'Ge'#194'D'#2'j'#13'X'#199#205#0'}~)S'#255#213#6#29 + +#211#6'Tz'#13#31#22#228'{'#6'$'#253#1#248#142'd'#217'm)'#158'-|'#244#231's' + +#161#246#135'O'#165#190#140'1'#136'p'#240#205#207'C'#217#172#133#131'|5'#159 + +#236#203#219#253'B'#177'O'#156#217#254#188#234'O'#4#224#193#149'?'#192#217 + +#254#142#237'?@'#200#211#193'&'#1'1'#2#192#255'T'#242'hp'#162#205#142#182#127 + +'"'#202#135#254#216#234'/'#196#254#129#235#250'['#143'2'#215'N'#206'?'#170 + +#252#235#173#243'oo'#24#18#1#144'3p'#221#186'u'#172'QH '#16'0'#161#6'P'#128 + +#23'Im'#195#153#22#128'W2n'#155#179#224#247#225#184#202'"h'#1#148#2#172#209 + +#27#208#20#216#13#212#148#19' '#242#5'(u'#184'Qr'#16#159#27' h'#2'2'#161#157 + +'xOq'#193#158#222'E'#142'/'#172#207#158#176#19#174#12'c'#181#253#185#130#202 + +#249#251#192#254#215'='#193#253'1'#136#223#148'X'#248'i'#229#135'8'#151#238 + +'K'#142'='#177#227'/B'#234'?'#222#246#180#214#128#167'e'#243#14#171#127#185 + +#197#181#209#168#10'R'#184#143#250#190#177#208#31'n'#173'(_'#245'|'#209#15'%' + +#0'5S'#230#31'j'#224#254#193'8'#255#4#12'uYMf'#6':'#28#14#189'R'#169#180#225 + +'E'#22#227'F'#137'AL'#11#240#133'5'#211#235#220#182'}'#4'-@'#193#180#0'5'#24 + +#11''''#128#185'x"'#175#5'p$'#192#180#0#161'u'#24#223'>'#172#147#4#248#203#29 + +'A'#138#192'sD'#0'c'#21'~9'#1#26#22'z'#242#243#171'Q'#251'T'#15#238#0#188#25 + +#215#185#242#243#170#127#152's'#252#145#131#143#179#253#3#16#246'"'#17'x=,' + +#233''''#18#12'B'#140#250#253'E'#185#196#31#20'|G'#133#197#181#5#15#21#19'V' + +#127#161#237#23#169#253#192#245#252'k'#224#203'~'#221'}'#245#253#239#11'C&'#0 + +'A'#11#160#182#225#168#9#144'/'#160#0#137#128#249#2#144#8'H'#19'(k'#240#216 + +#246#246#132#181#149'r'#150#29#168'`5'#0#10#10#11'V'#206#3#141#201#10#26'#g' + +#10#168#146#17#1'5'#243#7#176'b!'#218#152'#'#145'+'#27#30'I'#166#192#138#211 + +'v'#129#144#215'%'#245'e'#140'zP'#225#218#161'w'#188#10'E'#211#230#13#234#245 + +#9#174#212#143#247#250#199#217'l'#191#4#223#230'+'#30#140'$W'#127#138#251'3' + +#199#31#222'v5'#252#2'AWK'#202#234'/C'#218#168'F'#213'_)'#143#134'zZ'#253#5 + +#207'?n'#142#254#182#253#234#245#189#167#227#243#19#215#7'h4'#26#214'4'#148 + +'O'#15#166#188#128#242'h\^'#177#213'Yxp'#2#215'uA'#11'P'#168#212#160#181#20 + +#176'ra'#181#174'S'#3'P'#11'Z'#0#229#6#8'Q'#1#190#155'0'#136#202#134'G'#130 + +'_'#240#213's'#22#130#175#189'Q'#234#203#24#213#160#197'e'#191#27#158#132#10 + +'T'#255#7#140#132'x'#166#31#231#244'#Afv?'#173#252#225#8'K'#250#137#6'B'#172 + +#221'W'#132#247#250'S'#165#159#139#154'}'#160#240#211' '#16'a'#245'/'#212'{' + +#234#10#244'>'#10#243'u]'#253'i'#236'7'#181#253#222#142#130#223'@U'#127'H'#8 + +#238#129#230#253'w'#251#254#211#241#25'v'#213#2#240#194#10#132#136#128#160#5 + ,'8'#2#198'9'#173'~'#211'l'#210#2'@'#161'`'#14'A'#5#154#2#150#178#157'@'#159 + +'W'#202#146#130#152#240#147#22#160#227'H'#128#181#15'S'#241#237#196'EY'#130 + +'2y'#186'.]Z'#252#235#210#3#193'Y'#187'Q'#234#203#24#189#192#223#210#146#203 + +#255#10#19#247#26#194#236#6#22#231#7#214#224#143#229#250#243'N'#191'X'#132#19 + +#254#8#175#250'G|'#156#6#16#246#243#142'?'#159#155#21#4#9'q'#127#149'<'#26 + +#168#206'k_'#143#199#139#241#171'?y'#254'Y'#213#31#173#254#184#175'U('#20#181 + +#180#250'k'#181'Z'#7#146#192#144'W'#127#246#17#164#235#163#236'N'#11' _'#0'p' + +#17#1#26'$R'#180#213#153#191#127'8'#166#178#10#217#129'$'#220'j'#189#145#229 + +#6#168#13'z.)'#136'O'#17'V'#178#220#0#222#20'`'#141'D'#249#14'Bra'#196#24'$' + +#213#128#225'J'#5#31#222'r24'#174#249'R'#234#203#24#149' '#13't'#191#27#159 + +#134#178'9'#139#7#252'Za'#213#231#179'}x'#187#159#19'~Z'#209'i'#245#143#133 + +'"'#201#176#31#229#252'GI'#248'q'#239'i'#217#10#222#214'm'#140' '#152#237'O9' + +#255#248'_'#165#217#177#193#160#14'S'#166#31#9'4y'#134#133#145#223'Md'#251 + +#147#240#163'L'#213#167's'#245''''#164#141#0#186#243#5#0'7H'#180#146#15#13 + +#150#249'#'#234#9#181#238#252'%l'#29'Wt'#154#2#134#252'r0'#151'N'#229'j'#3 + +#152#6' r'#8'R'#247' '#149#146'+'#24#18#154#137#178','#193#225#239#24'l\'#243 + +#5#252#231#230#147#165#190#140'Q'#7'CA'#25#28'~'#223#187'h'#130#230#15#252 + +#197#157#195'y:'#139'|'#226#156#205'O'#182'?'#173#234'L'#245#167#132#31'a' + +#245#199'-'#26#8#254#127'{_'#22'kYv'#158#181#246'x'#230's'#238'XsWwW'#187#219 + +'v'#187#227')'#241#0'v'#136#193#145#8#194'F'#8#5#148#4')'#145#176'P'#132#132 + +#20#241#18'!9'#188#0'/H'#188'!'#224#1'x'#2#9#17#144#128'XHH$`x'#128#7#144#172 + +'$'#216#198#221#158#186'k'#174'[w:'#243#176#7#254#239'_'#255'Z{'#237'}'#207 + +#173#186#213']w'#170#190'K'#218'w'#15#247#12#251#236#189#191#239#159#255#165 + +#166#253'='#181#243#222'wT2'#155#209'k'#23'\'#25#8#159'A;'#158'n'#223#232#238 + +#161#229#19#192#159#152#184'?:'#254#162#230'_'#233'Y'#127'n/'#145#254#0#255#7 + +'*'#27'}'#158#208')E'#4#136#173'V'#137#165'.'#139#22#128#174'A'#215'Q:|o'#208 + +#251'b'#127#214'x'#153'+'#255'B"'#129' d'#144#247#174#146')'#176'zUH@'#8#160 + +#225#248#3#184'V@'#155#2'l'#14#248#158'T'#15#150#127'I'#158#23'?'#201#243#206 + +'x'#28#144#198#191#254#181'O'#169#217#197'D'#159'''3'#232'ay'#245#203'_S'#191 + +#240#219#255#248'H/_'#250','#229#198#225'/'#137'>'#22#252#186#208''''#227'2_' + +'m'#247'c'#129#218#191#24'C'#19#152'p'#155#175#249#184#207#182#191'Q'#253'=z' + +#247'k'#171'['#127#28'x)'#138'}JY'#127#180#127'_<'#255'h'#251'u'#239'yK'#127 + +#254']'#207#243#242'.'#203#11#160#31'q'#21'~'#0#163#5'dyp'#229'G{'#27#191#152 + +#229'~'#13#0#246'E'#11#136#234#13#181#242#210'gT'#173#211#213'&'#128#144#0 + +#182#131'Z'#173'0'#5#196#31'P'#174#28'<'#191'Z'#192'w'#254#229'?P'#127#244 + +#187#23'U'#128#199'=z/}D'#253#153'o'#254#11#213#189'~'#235#253#127#8'W'#248 + +#228',ssW'#242'['#187#159'l'#250#217'\K'#127'V'#253#167'"'#253#231'j'#255#222 + +#247#213'd'#239'>{'#253'a&(N'#249'e'#199#223'{'#235#205#17'z'#251'C'#250#163 + +#3#12#247#251#163#5'Y'#128','#253#197#7#240'p>'#159#239':'#158#255#15','#253 + +'1'#158'7ll'#227'Pd'#7#146#22#128'9'#178'.!'#18' Q'#1#172'/'#239'Oko'#220#31 + +#174'~'#206#19#135#160'1'#5#226#246#138'Z}'#233#211'l'#2'@'#250'G-q'#8'J'#243 + +#16'?'#150'Ta3'#211#176';'#229#184#167'='#186#207#214'A'#244#244'G'#150#204 + +#213#191#250'K'#175'?'#243#172'D'#23#227'h'#163#181'y]'#253#220'_'#251#166'z' + +#229#231#223'g'#193#149#17#252'z'#30#175#178#211#15#246#187#145#252'H'#248 + +#129#228'g'#2#152#217#176#31'r'#255'G'#219'w'#200#246#127#135'$'#255#140'I"O' + +'u'#185'o=\'#244'_'#233'm'#191#157#231#252#137'\'#239'o'#26'~@'#250#211#254 + +'m4'#251#132#244#199#12#192#181'Z'#13'>'#130#217'Q'#27'~'#30'e'#251#6'x' + +#138'/'#237#248#203'otw'#223'i'#199'3'#132#249#172#227#143#176#129#164#159'-' + +'H|'#241#252#179#227#143'0'#180'3'#164#177#183#183'7{'#214#134#31'O'#27#199 + ,'B'#0'J*'#5#209'6'#140#206#187#213'h4`'#10'\VZ'#250#223#148#245#165'E'#26'\!' + +#18#248'R'#166#194#136'I'#128#147'~"'#235#15#136#219#29#173#1#136'C'#16#25 + +#130'a='#226#181'o'#138#134'l'#142#128#152#3'b'#18#148#148#128'e'#191#242#164 + +#177#246#148'+'#253'?'#255#225'o'#169#31#253#193#191'='#225#147'z1'#6#188#249 + +#31#251#139#127']'#253#204'_'#254#155#207'>'#163#239#147#158#13#145#250#182 + +#194#207#218#252#162#250'/t'#184#143#19'z&s'#209#0'D'#253#167#237'>'#236#254 + +#253#251#252#154''#174 + +#230#163#254'i'#159#202#185#25'+/'#127'T}'#246#27#127'G]'#255#220'W'#223#215 + +#251#151#206'>g5'#254#188'P'#251#179'\l~'#29#235#207#165#188'W'#199#251#181 + +#218#159#10#248#19'&'#130#153#26'o'#223'S'#253#135'?`'#211' [,'#172#215#191 + +#17#206#251'/'#147#221'/'#223#4#213#31'&'#192#152#22#132#130#224#12#180#170 + +'?-'#152#231#15#14#193#145#211#236#243#185'I'#127#251#155#143'iX'#135' &'#20 + +'%'#192'cZ'#241'Mt'#14#130'/'#0#166#0#189#230#10'-k'#15'G'#189#183'v'''#205 + +#151#141'w_;'#250'b'#213'\'#135'?'#224'u'#21#213'$1'#168#17'["'#240'M[q'#19 + +#30#180'='#5'i'#9#138#217#134'r'#201#21'8'#15'n'#129'{'#255#231#191#169#255 + +#250';'#191'z'#218#167'q'#166'Gs'#253#138'z'#233#203'_S?'#243'+'#191#165#234 + +#171#155#207#245#179'M#'#15'//'#8#0#21'}'#153#16#0#219#253#146#230#11#149#30 + +'E> '#0#150#254#0#255'Tk'#1#179#193#158#218#187#253#135#244#191#194#238'W' + +#176#251#189'd'#241#234#202#246#247'B'#178#255#149#168#254#180'L'#137#4'0' + +#203'/:'#253#222#147'f'#159'w$'#1'h'#219'8'#254#158'W'#216#175':'#142#149#0 + +#224#16#252#214#183#190#197'MC'#136#201'Z'#244#195'`'#152']'#22'-'#0'$pM!J' + +#160#188#149'w'#247#214#190'0Kk=eH'#0#210#157'H'#160's'#249'5'#186#233'/IRP' + +#205'j'#1#8#13#194#28#240'b'#157'#'#160#195#131#18'"4'#25#131#158''''#10#192 + +#249#9#19#254#254#223#254'e'#245#240'";'#176'4'#26'kW'#212#205#159#255#154'z' + +#235#24'@_'#26#206#196#157'6'#209'G&'#241#204#165#161'g.'#177'~V'#253#167#218 + +#238'O'#5#252')'#183#249#30#178#211'o1'#30'j'#233#159'&'#186'4'#152#237#254 + +#189'w'#218#209#180'oT'#127'z>9'#230'Ok4'#250#228'f'#31' '#0#244#249#203#178 + +#12#190#128#253#227'p'#252#185#227#184'aa'#29#130#244#163'j'#164#1'tMn'#0'H@' + +#136#0#29#133#215#147'<'#218#248#233#222#250#23'3'#130#189'q'#10#194#31#0'{' + +#191's'#245#227#170#209#187','#192#143#181'?'#192'5'#7'b]>\'#20#14'A'#11#208 + +'D'#144#151#10#136#156#159#251#164'_~'#18#254#129'C'#190#31's'#1#254#222#175 + +#127'A'#141#30#221'9'#129#147'8'#187#163#177'vYK'#250'_'#251'['#31#12#244'O{' + +#194#141#202#159#231#142#237'o'#192#159#217#226#158'\'#178#252'8'#140'7[X' + +#192'C'#242#167'Sc'#255#143#9#252#127#164'f'#163'}Q'#253#19#235'7Xo'#142#238 + +'m6'#251#144#240#244'Hz'#166#216'g'#12#144'#'#227'O'#21#210#255'.'#225#4#181 + +#254#187#180' '#230'?'#251#250#215#191#158'>O'#199#223#179'\'#158#231#241#249 + +#236#16#188'v'#237'ZD?'#166'I?'#142'M'#1':~]'#242#2#224#16#132'V'#176#218#159 + +'7n'#222#31#174'|'#138#253#1#220#16'$'#212#243#6#196#177#234'^{K'#213'z'#235 + +'L'#0'69'#168')'#249#1'5m'#10#232'D'#161'P'#207'1`'#252#2#158'8'#6#13#1'x:' + +#195#235','#155#4#217'|'#170#254#227'o|^M'#182#31#156#246#169#156#232#208#160 + +#255#243#234#19#4'zl'#31#247'0A'#23#207#216#251#210#196#147#255'!'#192'5Y~' + +#185#128#31#146'?'#19#181#127'!$'#144'Ng'#236#245#239#223#253#174#154#13'w4' + +#248#209#223#15#170#127#134'x?'#236#254#157#183#229#27'!'#253#145#245'7'#161 + +#239#178'1'#127'I'#246'A'#143'?T'#254'm#'#227#143#204#229#217'q8'#254#220'q' + +#18'0`-'#128#214#193#189'{'#247'0'#181'x'#11#141'C'#148#6#189'!'#1#248#5'6i{' + +'e{'#210'}'#227#241#164#253#154'.'#24#242#25#208' '#129#176#214'P'#221#171'o' + +'q'#255#128'@'#204#129#192#248#3#140'S'#208'!'#1#27#29'p'#27#140'B#p'#253#1 + +'v6'#226#167'\'#134#147'L)'#150's'#193#148#224#223#250#245#159'S'#211#189#173 + +#147#251#238#19#30'A\S'#221#151'^W'#215#190#240#139#234#245#191#240#13#213'X' + +#127'N'#160'?'#202#253't<'#253'&'#191'7wm'#254#212'H'#254#2#252#25#131'_''' + +#251'X'#181#31#14#192#217'L'#245#31'|_M'#247#183#216''#239#186#170#127#179#217#156#16 + +'^'#22#199#225#248'+]'#138#227#248#208'e'#223'cL'#1#218#174#199'q'#220'Y,'#22 + +'k'#196'vp'#2#26#18#192#246#6#189#180#247'`'#216'{s'#127#214#188'a'#253#1'a' + +#164'g'#24#170#183'T'#239#198'[*nuu'#211#16'h'#2#13#153'h'#148#246#217#31'P3' + +#230'@A'#2'z'#242'Q_'#151#17'{^'#209'r'#253'e'#245#234'/'#253'U'#181#249#214#23#143#241#203#158#208 + +#198'/'#175#188#206'H{'''#179'O'#247#242'3'#224#207'X'#234'g'#21#201#207#241 + +'~'#2'}'#6'{_'#136#0#165#189#147#157#247#24#252#186#181#151#158#212#211#207 + +#210#228#229#149#237#31#212#130#197#196#181#251#149#14#249#193#238#223#18#213 + +#31's'#252'q'#200#143#182'w'#8#15#195#231'Y'#236's'#132#203'vb'#195#166#9'_' + +#191'~'#29#154'@'#11#181#2#240#7#208#15#191'*aA'#204'1'#8'=p5'#247#252#206 + +#157#254#234#167#198'I}'#213#23#167#160#23#232','#192#184#217'c'#18#8#26'uM' + +#0'l'#18'D'#146')'#136#16#161'4'#18'A'#152#208#180#21#243#29#18'0'#221#133'<' + +'!'#0#229#2#255'9D'#12#142'a6'#227#225#253#159#168#255#254#219#191#172#134 + +#247'~z'#130#183#236#217#6#8#186#190#178#169#214'>'#254#179#234#213'?'#251'+' + +#234#218#159#248#165#163#191#249#176'k'#246'<'#158'PG'#218'kG'#191#201#231 + +#207'm#'#143#194#230'/'#210'{y'#153#27#169#191#208#192#135#148#135#250'O'#132 + +'0'#217#190#163'F[?"'#146#152'Ks'#15']'#223#143'?7'#187'{o7'#194#217#208#177 + +#251#231#244'l'#163#197#23#18'='#182'%'#215#159#193'O8'#128#25#176#141#132 + +#159#157#157#157#169'x'#253#13#248'_'#24#2#224#239's'#19#132#8#248#173'$I' + +#216#31'@'#11'B'#130#208#4#216#31'@'#235#149'\'#249#157'w'#247#214'?='#205 + +#162#14#146#132#152#4#184'7'#0#145'@gMu'#174#189'%'#229#194#162#1#152#252#0 + +'h'#1#146'-X8'#6#203#154'@a'#18#248#197#228'#N1'#209'Y'#237'='#248#255#254 + +#205'?R?'#248'w'#255'DMw'#30#158#234'y'#4#245#166'jn\S+'#175'}'#130'$'#252 + +#159'R7'#190#244#231'T}'#253#202'i_'#158#202#200#203#210'_Rz='#227#236#147'r' + +'^'#6#191#163#246'['#240#139#202#15#224#179'z'#207'*'#191#246#1#204'v'#31#168 + +#193#195#183#233'usn'#238#193#239'Cyo'#154#229'W'#187'{?'#236#196#147#190#168 + +'l'#214#238#23#167#223'.'#236'~ZX'#245#135#211#143'0'#240#152#222#187'O'#166 + +#241#4#9'?'#199#233#245#175#142#211'x'#202'}'#152#2#180#6#9'X'#127#0#217'?' + +#151#29'S'#0#26#1#252#1#221'$'#243#187#239#246#215'?'#179#200#163#134'o'#204 + +#1#216#247'$'#233#153#4#174'|'#156'H'#160'nA'#207'f'#128'h'#4'L'#2#145'&'#1 + +#21#233#168#2#147'@h'#8'@r'#5'|'#129';'#214'2)'#225'Y'#159#166'|'#240#222#219 + +#234#143#255#249#223'W'#15#254#247#31#208'C99'#190'/'#162'k'#17#183'{'#170'u' + +#245'e'#181#250#209#207#168'+'#159#251#170#186#250#249#175#210#245#175#159 + +#246'%x'#250'03L'#219#130#30'c'#231#23#253#251#140#167#223'H~V'#225#231'I'#1 + +'x'#6#255#156#155'{'#178'&@'#255#155#238#222'U'#163'G'#210#206'{Q'#168#253' ' + +#146#203#173'}L'#231#181#131'/q'#156'~H'#245'E'#188#127#15#133'='#180#141'F' + +#144'P'#251#225#244'{D'#207#245#222'I'#218#253#238'8'#141'G|'#169'?@f'#22'b' + +#167#160#210'Z'#0#182#215#233#1#236#204#147'`'#229#189#254#250#167#19#21#198 + +''#28#234'#p'#231'R'#217#151'I' + +#184#15#142'>'#14#251#137#31'`'#188#253#30'-'#239'jR'#224'i'#188'S'#142#22#0 + +#252#27#205#193#237#245#198#240#145#11'~z'#182#140#221#15#240'o'#153'J?z'#230 + +#239#201'4'#223#232#240#131#6' '#199#150#237#247','#151#242#196#190#215#245#7 + +#208#197'h'#18#248'{'#164#10'm'#18#192#175'Hx'#144#179#4'iY'#3#9#204#210'x' + +#237#246#254#250'''3'#207#15'Yr#<'#24'j'#18#8#27'm'#213'!'#18#136#154#29#2'~' + +'h'#181#0#228#8'x'#236#20',H'#128#181#129'J'#152#208#212#17#24#18'`'#231' t' + +#148#220#153#144#164'`'#132#234#147#246#244'+y'#10#4'1'#219'{'#172#230#253#29 + +'5'#31#236#210'zO-'#134#251'\9'#217'}'#249#13#213#185#249#250#217#149#224'G' + +#189#142'K'#239'C'#17#222's[u'#219#16#159#11#254#170#212#151#220#254'L'#154 + +'z'#148#9'@K'#255#209#214#143#213'd'#239#30#189'n'#206#145#1'~'#159#228#248 + +#175#214'F'#15#174#180#251'w'#243#2#252#200#244#131#221#15#240#195#238#127',' + +'!'#191'{R'#223#15#27'n{:'#157#14#136#0#160#194'%''e'#247#31#245'r'#31#251'w' + +'W'#243#3#200#28'@3'#209'Md'#10'*'#237#16#196#26'$'#176'J m'#141#23#181#205 + +#187#253#213#183#136#4#2'm'#207#11#9'p'#4#160#201#230'@D'#234#170#213#4#156 + +#181#23#11#17#24'M'#128'L'#2#21'j'#191#130'2s'#17#26's'#192'M'#30'2UEn'#163 + +#145'3l'#26'|'#232'F^'#10#226#8#224'M'#21#159#210#158'}'#137#239#187'i'#189 + +#218#230#215#128#207#13#248#173#228'_0'#200#217#241'7'#211#161#190#225#163 + ,#183#213#172#255'H'#146'|'#140#218#175'k'#251#187#209'd'#235'zw'#239'=m]d' + +#153'x'#252#145#236#3#240'#'#151#127'['#233'y'#253#24#252#216'F'#178#207'I' + +#198#251#15#27#167#253'('#151'R'#133'I'#11'h#'#25#136#180#128'K'#208#4'h'#31 + +'Z'#0'H'#0#164#176'B@lM'#147'x'#237'N'#127#245#19#169#23#198#218#179'/>'#1 + +#174#12#172#17#9'|L'#197#157'uM'#10#198#15'`'#192'/m'#198'=!'#2'_z'#10'('#19 + +'%'#16#231#160'2'#230#128#239#21#4'`'#174#214#139'>]'#241'y'#25'.'#234']sGl|' + +'O'#202'wm'#3#143#170#179#207'8'#250#0'f'#212#243'/'#28#240#27#231#31#175#167 + +'j'#240#240#7#164'ImK'#140'?'#209#196#145'j'#240#175#213'F'#247'/'#183#145 + +#226'k'#193#159'I'#154'/g'#250')]'#226#251'H'#230#245#131#228#199#164#30#143 + +'1'#171#207'|>'#31#31'w'#170#239'Q.'#227'i'#223'F'#207'8'#5#209'@'#4']'#132 + +#208'P'#212#9#15'"O'#224#138#201#20#4#9'$y'#220#189#189#191#250#214'BE'#245 + +#18#9#136's'#176's'#249#13#21'w/'#177'/'#192'3'#181#2#177#244#16#176'&A'#164 + +#253#2'b'#14#168#208'/'#146#134#140'i '#13'F'#172'F`'#175#152#163#10#156#159 + +':'#163#23'f'#148#146'xl'#171'.}'#140#193#159'i'#201'oc'#251#169'n'#226#1#240 + +'+'''#204#151'K'#190'>'#171#244'3'#241#250#211#177'\B'#127#201't'#162#6#247 + +#191#175#18#228#246'''s'#157#21#232#128#127#163'1'#184#189#217#28'>'#210#138 + +'F'#150';'#146#31'*={'#252#149#238#237#7#240#223#151'p'#223'cH'#254#197'b1' + +#186'v'#237#26#156#131''''#234#244#171#142#179#240#236'Z'#18#232't:1'#177'b' + +#157'.T'#27#149#131#232'$'#4#2'0$ '#173#198'A'#2#205'L'#133#237#219#253#181 + +'7gY'#220#214'}'#0#196#174#143't)qk'#243#150'j'#172'^'#215#146#222#1#189#217 + +'f-'#160#166#147#139'8Dh'#219#142#7#133's0'#240#10#141#192'I rs'#137#205'f~' + +#224'''='#225#10'?'#211#173'>'#175']'#130#142#248'h='#245#250','#191#178#185 + +#211#151#223#5#191#246#238#235#248#190'J'#181#202#175#4#176#156#155#159':' + +#246#254'\'#131'?'#183'j'#191'd'#242#17#25'$'#147#161#234#223#255#158'Ji]H~' + +#157#225#167#210','#191#220#217#255#201'j<'#217#21#193'o'#193#175#138#190'~' + +#166#190#255#1#164#191#132#254#30#163#190#159#198#168#209'h'#204#143';'#207 + +#255'9'#222#165#227'?'#15'S:'#140#162#161#241'x'#140#134#162#29#169#25#184'd' + +'4'#1#165#251#7#160#177'H'#143#174'X'#147#16#218#188#211'_'#251#216'8'#173 + +#173'x2'#239#160#206#254#211#18#191#190'rU'#181#214'oiM'#192#250#1'B'#157',$' + +'d'#224'I%'#161#138#138#190#2#166#152'Hq'#132#192#244#23#240#203#145#2#167 + +#243'P.'#161#195#234#21#245#202#127#158'q'#228'O'#220'='#179#195'{'#234#129 + +#167#255#238'|'#201#207#21#144#27#129#175#14#11#237'9'#133'<*-b'#251#197#162 + +#129#207#210#127#190#144'p'#223'B'#180#129#5#255'o>'#216'a'#155'?'#157#142'u' + +''''#31'Z'#148#128#223'#'#241#127#181#187#247#163'n8'#27','#3#191#210#225'>' + +#128#31'-'#188#31#144'&'#203#14'?'#228#248'#'#220'G'#175#27#161#200'G'#157 + +#146#211#239#131#222#157'c='#23#248#3'~'#252#227#31#251'h%F'#154'@'#195#228#8 + +'`V!'#164#12#131#8'h'#141#164'!4'#26#237#210'Uk'#17#240#234#247#6'k'#175#15 + +#23#245#13'c'#14'0'#17'DP'#241#145':'#220'Sm2'#9'PG'#224'K?'#193#2#252#142'6' + +#192#254#0'c'#14#232'm'#155'8Ti9f'#195#134#158#201'(tr'#207#171#253#7#204#173 + +'=KW'#250','#143#202#245#202#157#166#156'%'#208#27#162#200#164'eW'#150#29'H' + +#231'Ui'#1'z'#227#237'O%'#212#151#207#231#142#195'O|'#0'D'#2#147#221#219'j' + +#178#253#158#222'w$?>'#223#167#15#184#222#219'{'#167#21#204#199'K'#192'ob' + +#253'h'#234#137'4_+'#249#233#153'}L'#160#223#165#231#23'5'#0' '#137'3'#1'~' + +#231'2'#159#153#193'$'#240#189#239'}/@x'#16'$@Z@W'#26#137#184#154#0'"'#3#235 + +'('#28#162#27#129#18#227#248#254#160'wko'#222#188#234'['#245']k'#2#200#26#244 + +#227#26#153#4#31'Q'#181#206#166#150#248#174#244#23#223#128#206#17'0'#249#2 + +#129#205#30'TN'#6#161#237'@'#236#251#5#1'8m'#201#221#26#3#235#164#170#22#27 + +#157#181'+~F'#134'Wr'#228#185#155#249#1#240'k'''#159'H'#251#180#144#250#165 + +'t^'#168#251#137#238#215#175#9'@<'#254#226#237'7'#26#0#19#0#166#233#154'N' + +#213#136#164#254'|'#180#171#227#251'IR'#2#127#160#146#217'K'#221#221#31#214 + +#131#197'T'#192'o'#28'~F'#242's'#129#15'r'#252#209#220#3#146#31#26#0#212#254 + +'('#138'v'#7#131#193#136#180#218#19'M'#243'='#210'u?'#237#19'XvN&<'#184#181 + +#181#21#211'Ek'#208#5'4$'#128'lA'#180#24#135')'#192'$@'#251']'#248#4#232'X' + +#237#209#168#243#210#246#180'}SO8bH@2'#0#137#8#234#189#171#170#185#241'*'#131 + +#222's'#181#129'H'#147#129'''-'#199#149'q'#14'F'#21'm'#192'u'#16#154'z'#2'&' + +#3'eg)'#202#29'2p'#181#255#220'!'#133#15'f'#26#188'(C'#210'u\'#137#159#23#181 + +#249#202'sT}'#199#201'W'#168#249'"'#245#197#214#231'2'#222#180'p'#242'1'#232 + +#165#148#215'z'#252#141#234'/'#170'>'#219#254#201'B-'#250#187'j'#184#245#14 + +#29#27#219#200#128#174#229#151#137';'#189#249#228#165#238#222#15#185#170#143 + +#235#8'l'#168#143'S|'#149'd'#249')'#237#224'C'#184#15'R'#255#1#212'~'#178#249 + +'w'#233#249#29'6'#155#205')i'#183#201'iz'#252#151#141#179#250#4#150'H'#160'A' + +'c2'#153#160#145#8#155#3'B'#2' '#3#209#4'T'#151#128#136#190#131#181#253'Yc' + +#243#225#168#251'Z'#166#194'PKn'#169'!'#8'C1'#9#186#164#13#188#193#213#132#0 + +'>'#28#129#158'D'#4#220#16#161#155'9'#168#156'Z'#2#229#18#129#231#23#179#22 + ,#251#198'I'#232'j'#3'E'#30'a'#238#148#25'z'#213#146#195#3#153'mg'#245#182#188 + +#223#187#249#4#127#134#233#191#167#156#198#28'|'#188#2'zP'#168#3'~'#211#173 + +#135'U}'#9#239')'#167'O?'#188#245#249#28#251#11'+'#249's)'#238#201'%'#207'?' + +''''#240#143'wn'#171')-'#153'y]*R_f'#238'iG'#147#237#171#173#253#219#129#151 + +'&:'#151'(3e'#189#240#246'3'#248#149#206#242'CO?'#246#248#195#230'G'#168#15 + +#224#167'eH'#166#236#20#177#254#179#6'~}'#205#207#238#176#133'C'#4#254#136'.' + +'b'#147'L'#130'.H@:'#10']6'#225'A%$'#128#16'!H`'#158#133#237#187#131#222#235 + +#179#172#214#230'y'#3#140'o'#192#132#10#163#186'j_zM'#197#221#205#2#248'f1'#4 + +#16'W'#142#7#186#211#144#178#243#19#6'em@'#26#143#148'#'#6#158#149#244#172#29 + +','#137#30#152#249#11#142'zG'#206#204#147#227#222#168#167#189' ?'#252#128'i' + +#197#229'y'#14#248'3'''#150#175#28#27#223'Q'#247'y'#31#182#190#27#222'K'#11 + +#137#159#27#208''':'#181'7/'#145'@'#194#245#19'#'#146#250#243#225#142'h'#11 + +':'#188#167#138#30'~'#217#165'F'#255#246'Zc'#244#152'S{%'#212#167'tz/O'#223 + +'-s'#248'A'#237'7'#137'>'#15#207#19#248#143't'#239'N'#251#252#12#9#244#251 + +#253#184#213'j5'#232#226#162#197#248#154#132#4#225#16#188#12#173'@i'#18#232 + +'1'#9'('#175#158#7'~'#252'p'#208#189#185'?o]-'#146'|t'#184#15'&'#129'oL'#130 + +#245'W'#8#236#177#205#9#240'L'#5'a'#172'5'#6#171#9'p'#10'qPT'#21#210':'#15 + +#220')'#202#140'V'#224#21'D'#160#138#237'"JP'#172'K%'#200#206'f^9'#236'='#235 + +#173'z'#158'w'#245#153#31#215#188#152'>'#219'='#149#188#188#145';/'#178#245 + +#249'n'#18#143#177#243'MG^'#145#250'*u$'#191'c'#235#27'/?'#219#237#12#244'E' + +#161#254#207#11'R'#192#255#23#240#242'?'#254'!i'#1#19#177#247'u|'#223'|n'#228 + +'/&'#215#218'{?i'#132's'#174#229#23'G'#4#236'}'#147#222';'#145'P'#31#171#253 + +'J'#194'}'#178'F'#169#239#222'y'#0#127#233#254#156#209#193#231'W%'#1'd'#12'"' + +'Y'#136'.'#178'!'#1#152#5#151'0'#247#128#210'y'#2'm'#186#212'u'#146#184#241 + +'p'#222'X{0^'#185#149#145#236#215'@-'#155#4'H!'#6#9#196#157#13#201#7#144#136 + +#128#1#191')$'#10'+$ '#11#147#138'h'#6#156'N,'#145#130'\'#162#6'V'#27'x'#26 + +#17'8'#221#137'rG;'#240#202'^'#196''''#220#177#147#184#149#249#225#135'+'#167 + +'i'#140'{'#175#244'6'#167'<'#23#0'WO'#0'~^'#150#248#202#22#239'8N>c'#239#187 + +'v'#191#149#252#139#18#240'Y'#19#152'N'#213'd'#251#167'j6'#220'b'#130'@'#179 + +#15'+'#241'3=__'''#154'<'#190#210#234#223'!'#149'?'#205'm'#147'@]'#210#235'd' + +#248#245#165#178#15#222#254'G'#146#215#255'H4'#129'}8'#252'666'#206'<'#248 + +#237#253'9'#227#195#146#128#18#159#128#146'2b"'#130#21'h'#2#146'%h'#178#5'9Y' + +#136'$r'#155#192#211#160';'#23'''Y'#212#184';'#236#189'6Kk'#29'S'#0'd'#27#140 + +#8#184#163#214#26#19'APo'#21#17#1#167#138#208's'#251#10'<'#137#8#220#148'b' + +#153#194#220#134#14#205#196'%'#165')'#204#202'k7'#132'h'#230'4'#176#135#14 + +#132#20#143'n:<'#151'q'#152'*o'#156'v'#246#144#145#236#230#127#249#146#216 + +#189'~'#157#14#227'I'#230#158'!'#2'k'#227'/Q'#247'S'#145#248#2'|'#181#208#149 + +'|J'#236'w'#215#222'7'#206'?E'#251#147#254'=5'#221#189#173#19#127#210'%*?}' + +#209#229#198#224#189#149#198'h'#199#203'MI'#143#14#243')'#1'?'#173#199#180 + +#223#151#154'~4k'#132#196'GE'#31#182#183'I('#161#145'''{'#251#201'\=s'#14#191 + +'e'#227'<'#16#128'=OC'#2#251#251#251#17']'#228':]x'#174#29#136#162'h'#157#246 + +'a'#6'\'#18''''#225#134#212#14'th'#27'}'#4'b'#210#0#162'G'#195#206'K{U'#147 + +' '#212#201'C'#138#171#11'#U'#235']S'#245#181#27#156'M'#200#14'@'#199#4#0#1 + +'(''Dh'#136#192#148#24'+'#153#181'X'#249#229#198'#'#182#21'Y%'#179'P'#231#15 + +'-'''#3#207#209#255#139#222#4#166#151#161'{UN'#136#4#170#143#176#19#182'+m' + +#229#5'Y'#149'CxN'#165#158#27#198'3N='''#150'oA'#159#154'm'#0'>#b'#0#160'u' + +#17#143'Z'#20#13';'#173#199'?IJ>'#0#132#0#147#209#158#154#236#252'D-&'#131'B' + +#213#135#169#128#207'pU'#254#238#238'O'#234'^2'#245't'#229'@'#213#211'?'#147 + +#22#222#168#234#219'q'#193#15'O'#127#24#134#232#235#223'_,'#22#227#25#141#243 + +#2'~'#140#243'B'#0#246'\'#221'<'#1'8'#252#232#194#183#232'p'#143'.'#254#186 + +'8'#7'A'#4#156','#132'V'#227'$'#129';$u'#27#180'_#'#240'E'#131'i}'#237#193 + +#164#247'j'#150#235#249#7#180#147'0`'#21#222#244#16#132'Y'#208'X{'#133#139 + +#138#188#208#137#6#200#220#3#134#8'4q'#4#162#29#136'&`{'#13'8]'#137#131#138 + +#163'P'#8#161'hF"'#19#152#28'H76'#161#195#162','#185#240#15'T='#3'G'#200'1' + +#248#160'%'#203'y^yi'#25#240'z'#229'4'#218'TE|'#159'%'#189#153'l'#195#190#230 + +#160#154#207#246'~'#154#149#218'r+'#150#250#153#6#173#0'_'#137'='#175#164#131 + +#143'2'#4#144'h'#239#127':''u'#127#231']5'#239'?'#210#173#186'L'#26'p'#146#10 + +#209'h'#149#31#149'|'#151'['#253#187'P'#249'9'#188#143#254'}'#160'!m'#239#219 + +#24#191#1#191#210'e'#189#15'e'#198#222#199'R'#207'? '#1'4>K'#25'~G'#29#231 + +#137#0#236'9'#155#180'a'#218#142#26#141'F'#13#17#2#164#7#27#231#160'8'#5'/' + +#217#218#1#29'&'#132's'#176#6#147' Sa'#252'h'#220'~'#169'?onz@'#166#137#20 + +#216'f!Z'#226#195',h'#192', B'#176'R'#223#1#188'Bd '#22'B'#16'M@9'#25#132#214 + +'I'#24'>A+8'#204'GP'#154#242#188#186'v:'#26'['#13#193#161#130#165#190#130'CB' + +#143'O'#200#187#183#160'.%'#224#23#26'H.'#234'})Q'#199'%'#0#215#147'/'#158'}' + ,#163#226#219'p'#158'q'#240'Y'#208#167'b'#231';'#158'}l'#11#192#181#202#175 + +#215':'#175#223'8'#2'%vO'#235#217#222'}5'#222#131#186'?'#211#199#229'3y'#157 + +#167'"'#245#147#201#149#230#254#237'f<'#27'z'#26#247'8'#15#146#250'%{'#223'&' + +#248#208#178'C'#210#254'1'#9#153'G'#210#213'g'#155#128#191'K'#160#31#160#149 + +#23#13#152#8#231#10#252'K'#158#138's3,'#9#208#197#15'k4'#200#12'h"B'#16#4#193 + +#170#227#23#128'F'#0#18'X'#5'A B &A'#148#19#196''''#139#176#253'p'#178#242 + +#202','#141'ZE'#235#240#162'('#200#147'9'#10'k'#221'+'#170#182'rM'#5'h'#162 + +#17#154'y'#8#3#199#28'pM'#3#9#17#134'RK`'#10#140'l'#14'A Z'#129#201'$t'#218 + +#146'U'#137#160'j*'#148#202#146'+'#21#137#21'G'#162';'#242''''#146'A'#165#216 + +'f'#217'c'#235'Jw'#222#168#172'e;7'#137'<'#153#27#190'3'#137'<'#142#164'wc' + +#249#2'|'#29#203'/'#192#175#137#192#9#241#217't^'#13'r'#237#3'H'#10''' -'#139 + +#225#14#219#249#9#171#251#186'I'#167#146'L>'#179#246#232#207'j}t'#127#189'1x' + +#228#177#180#207'3'#147#214#171'$'#190'O'#203'\j'#249#135#226#233#135's'#15 + +#210#30#249#252'['#178#191'O'#207#220#160#223#239'O'#187#221#238#156#8' =o' + +#224#175'>'#9#231'm'#148'J'#137'I'#19#136'%u'#152#157#131't'#140#181#1#144#0 + +#250#11#210'z'#141#253#2#202'k#}'#152#182'czDc rw'#218#186#180'=m_'#207'H' + +#164#235#226#31#237'$'#132'fP'#168#249#145#170#181'/'#169#6#17#129#31'7'#180 + +#244'7j'#191'k'#14#24#127'@'#224#164#17#187#166#129#201'!p'#29#133#198'<'#176 + +#4#224'W'#18#139#180'G'#192#246'.'#180'='#11#141'iP'#152#3'n'#194'Q'#217';' + +#239#29'XU"s'#202'Az'#217#181#144#187#161'='#137#215#231'y'#197#214#151'B'#29 + +#163#226'gy'#145#167'oSu'#139')'#183'\'#201'_H'#253#20'M5'#197'VO-'#9#184'a' + +#190#220#170#251#198'!H'#18#127#184#173#166'{wU:'#27#22'f'#129#11'~'#241')' + +#180#162#217'.I'#253';'#152#156#211'C/`}n'#172#242'+'#221#187#207#228#244#143 + +#140#167#159#182#183#197#219#191'Ej'#254'6'#9#24'h'#2'}'#147#215#239#244#241 + +'3'#192'?7'#224'w'#30#135's;,'#9#16#1#4#8#19#18#27#195'9'#216#154#205'f=h'#3 + +#244#127#244#26'D'#171'1h'#2#240#11#160'r'#144#211#135#17'% '#192'D'#244#17 + +'A'#146#249#241#163'I'#247#230'`'#214'X'#247'l'#241'O'#1'^?0 '#142#184#166#0 + +#206'B'#244#211'3'#166#0#167#13'['#208#23#161'A'#27'!'#136#180#244#207#131 + +#224'@wb'#235'#p*'#15#11'"P:'#164'h'#211#139#165']'#153'*L'#4#151#24#150'^"' + +#175'r'#197#170#26#192'!'#14#190#18#15#184#245#246#216#204#242#146#189'o5'#0 + +'7W'#223#128#221'z'#244#141#202'/'#246'~'#166#167#219'V'#226#228#179#128#183 + +#29'{'#202#224#183#197'='#236#253'_'#168#217'`K'#205#246#239#17#240#199#146 + +#16#148'X'#147#1#251'J:'#246'D^2'#187#212#26#220'n'#215#166'}'#248#28'<'#143 + +'U~V'#252#233#146#177#163'Oz'#247'Me'#178'Nk'#239'C'#237#151#153'{9'#190#15 + +#149#159#20#206'1b'#252#245'z'#29#164'a'#234#249#237'U:O'#227#188#19#128#249 + +#13'H'#24#194#154'#'#4'p'#14#18#1'4E'#27'X5'#190#1'!'#1'6'#9'h'#191#7#191#0 + +'m'#195'A'#8'm'#128#222#231#251#163'$'#238'>'#28'uo.'#178#168#233#154#5#202 + +'I+V'#226''''#136#219#27#170#222#187#174#130'F'#235#160#212'7'#170#191'C'#4 + +#134'L'#148'K'#2#2'z'#229'U'#157#133#14')x'#166#10'Q9~'#130'J7cq$'#30#152#241 + +#232#176#154#3'[m'#231#188#196'm'#180'a6'#189'B+'#240#158#2'zW'#213#247'*' + +#222'|'#29#215#207#172'Df'#7'`R'#168#251#158#1'}'#226'H~'#163#13'd'#134#8'2' + +#142#223#207#6#143#24#248#217'bb'#237'~'#227#216#203'\u'#159#132#252'J}'#252 + +'p'#179'9x'#224#209#142#199#165#130#224#29#218'f%'#198':'#250'f'#210#187#207 + +'t'#238#133#167#223#130#31#19'v'#160#137#7#254#143#254'}'#163#209'h^'#241#244 + +'+u'#14#193#127#200#147'q.'#135#141#16#160#156#248#214#173'['#225#214#214'V' + +#141#14#213#137#173#17'*'#236#145#250#134'b'#162'u''u'#24#251#200'#hC'#27#160 + +#237#26#251#6''#199#245'3'#201#231#183'R'#159#22 + +#19#226'c'#149#31#160#199#2#149'_'#8#1#29'|'#198#244#182')'#217#253' '#140 + +#132#180#206#236'<'#132#249#142#4#156#23'h'#176's'#240#219#223#254'6'#251#5 + +#232#166'E'#4#234':'#28#132'259'#155#4'XD'#27'0$'#208#165#183#146'>'#175#26#4 + +#167#24'f'#1#129'='#160#199'%'#220#157#183'6'#247'&'#173#203#137#10#226#3'D' + +#224#23#246'>4'#130#176#209'!'#173'`'#147#8'a]'#249'a,m'#198#140#3#240'0'#167 + +#224'!'#5'F'#146'3'#224#149'|'#3#166#23'A1'#169#137'%'#2#153#224#196'LuV'#10 + +#18#10'7'#148#156#132#14#3'xF'#210'Wd'#153#145#246#7#28'{N'#252#222#149#252 + +#182'B'#207#237#200'c'#192'/'#132#160'\'#167#159#149#242#142#211#207#233#224 + +#131#255'-'#166#251'j1'#220#162'e'#155'I w'#205#128','#147#150'_'#236#220#195 + +'~'#222#138'g'#187#27#141#193#131'Z'#184#152#150#212'}'#199#214#151#182']' + +#166'c/l'#249'}i'#226#193#158'~Z?Fl'#159#164#252'>='''#3'2/'#199#244','#205 + ,'{'#189#30#192#127'n'#237#253#165#128'9'#237#19'8'#166#223'T2'#9'h N'#211'di' + +'O'#128#167#155'j'#137'@'#204#3#236#19#9#168#14#1#174'A'#251'u:'#30#25#179 + +#128'@'#21#236#205'Z'#27#187#227#230#229#133#10#235#218'F'#247#203#211#141#17 + +#1'('#223#183'ZA'#173#177#170'""'#131#176#185#162#163#4#230#181#142'3'#208'H' + +'~'#255'0-'#192#152#8'&'#147#208#248#7#248#23'V2'#12#221#28#130#220#137#12#8 + +#27#152#196#220#131#209#130'Jz'#174#167#172'j/'#255'V'#226#245'+Iyc'#227#27 + +'{'#223'4'#227#176'Z'#128#1#186#172#165#192#166't'#220'M'#237'u'#215'('#203 + +#157#13#31'3'#240'S'#132#242'2'']W'#166#220#206'e'#209#192'O'#243'vm'#182#189 + +#217#24'>'#140'|H|'#28#23#191'>'#171#251#220'%'#208#205#232#227#240#30#242 + +#249'i'#189'/'#237#187#182#205'"'#206'?'#28#199'k'#166'F'#229''''#205'2;'#207 + +#246#254'a`y'#17'G'#201'$@'#168#176#213'j'#197#2'lT'#12'v'#197#25#184'J'#140 + +#143#232#0#22#248#5'D'#27'P-!'#2#152#5'a'#206'd'#128#174#225#190#191'7k'#174 + +#237#142'[W'#230'y'#216#176#206':'#3'|'#207'H'#242#162#2#17#154'@'#212#222' ' + +#173'`C'#5#141#142#227#252#11#184#231#160#231'8'#2#139#168'@u'#10'3'#207#2 + +#222'F'#5#2#209#4'\'#237#192#151#144#161#149#252'U'#7'`%'#159#192#12#183#149 + +'6'#239'+'#235#28#176#213'zF'#229'O'#171#234'~&fA'#230'T'#234#21#206'?~'#189 + +#209#0'*a'#191#18#9','#230'j6'#218'f'#208''''#211'A'#161'!'#152'L@'#199'l0}' + +#0#16#210#235#198#147#199#27#4'|x'#246'M'#190#241#19#212'}k'#235#211#210#151 + +#238'='#12'~'#186#207#144#254#216#222#15#130#128#19'{h'#153#145#244'_ '#196 + +#247#162#168#252'K'#129#242#2#15'k'#18' J'#128#178'b'#186#185'54'#25'!R@'#227 + +'Q'#152#5'+ '#1#133'Y'#137'5'#9'@'#27#232#209#210#17#179#160#238'{~Lk'#16'A' + +#8'"'#240#9'}'#251#179#250#234#206#164'ue'#150'!'#135#192#128#177#144#218#5 + +#176#3'K'#10'a'#212'Tq'#7'Z'#193#154#10'j'#141'2'#184#157#210'bo'#9'!'#184#9 + +'C'#133#25#224#21'~'#2'''R`o'#173'u'#11'H'#180#192'M$'#146'W'#185'~'#128#210 + +#172#185#178'*'#194'}'#174#244#207#156#233#180#225#240#203'd'#178#205#138#183 + +#191'*'#245#179#188#18#1'H'#212'b'#178#175#230'P'#241#199#187#156#216#147';6' + +#189#251'~K '#244'}>1B'#183'6f'#224#7#200#15'6'#192#231#138#221'2'#240#149#6 + +'?'#128#143'N'#189'#'#201#229#223#23#240#195#185#135#25'y'#25#248#240#240'+M' + +#14#211'N'#167'3G'#3#143'7'#223'|'#243#133'R'#249#15#0#228#180'O'#224#132'~#' + +#155#4#208#6'h;Z]]'#141#160#13#200#140'D0'#11'z'#162#17#172#233#244'aM'#4#180 + +'&'#18'Pm'#186#235#220'l'#4'&'#129'o'#136' '#131'F'#224'y'#195#164#209#219 + +#153'4/O'#211'Z'#7#200#180#192'tH'#160'4'#231#128#152#0#232'I'#16#212'z*jt' + +#201#168#232#210'~'#173#210'[`I'#231'!G'#213'/'#171#254'x'#173#18#159#128#241 + +#234'{'#182#152#168#8#4'x'#149#181'*7'#222'PE'#218#190#178#13'8'#157#146#221 + +#204#13#241#21#234#190'w'#192#23'P'#201#233'7'#145#0#2'v2'#27#170#20'v'#253 + +#164'O'#219#131'"'#219#207'x'#239#197#137#231#153#254'~v;'#231'p^'#167'6'#217 + +'^'#175#143#182'|'#143'sy'#213'2'#224';'#237#185#173#147'O'#233#9':'#160#214 + +#239#25#240#3#248'$'#12#246#200#222#135#3#16'z'#254#132'l'#253#217#139#230 + +#232'{'#26'8>,'#227#128'6P'#171#213'bz^0G'#22#166'*G'#159#129#30#28#133#240 + +#17#28#212#6'T'#211#152#5#4#180#18#17'(.'#25#11#163#253'yc}0k'#172#205#210 + +#168'Y'#0#180#172#198#27#245'>'#247#202#196#0'B'#8#27'+*'#170'wT'#0'B'#128#19 + +#209'!'#0#27#14#148#162#162'jc'#210#146#9#224'4"'#177'w'#185#218#140'D'#194 + +'~n'#233'n)'#12#232'j'#2#198#9#232#168#251'n'#184'/'#207'+I?yA'#0'H'#206'I' + +#166'}'#150#244#201'tH'#255'J'#10''' '#155#20'i)4'#200'Q'#0'K&'#184#184'Y' + +#138#4#158#149#218'x'#167#25#209#135'i'#204#231#154#160#24#248#0'<'#235#252 + +'b'#231'/*'#234#254'H'#226#250#198#214'G'#136'oW'#188#251'}'#186#215'C'#168 + +#251#176#245'www'#23'd'#231'sl'#255#19#159#248'D'#254#162#131#223'yB>4'#163 + +#164#13#192'7'#176#178#178#18#17#25#208'f'#204'}'#6'h'#1#216#225'(\1'#218#128 + +#210#26#2#250#18'"'#164'h'#136#0'Y'#132'1a.'#160'g=dg!'#20'r'#210#11#166'i' + +#220#216#155'5'#215'G'#179#218'Z'#162#130#200'S'#5#25#20#146#220#169#7#240 + +#141#243#207#28#15#148#31'7Y;'#8#226#22'}B'#131#9#130#29#141#202'5'#3#156#181 + +#141#18#136#170#159#171#194'$'#200#171#209#1'U'#16#130#155#244#227'6'#222'4' + +#7#149#201#4#212'$'#192' u'#18'}'#12#232#177'dp'#188#211#146'/'#198'l'#199'c' + +#201#200'4/'#1#190#186'm'#181#137#204#250#20'`'#195'7'#195'y'#191'S'#159#236 + +'t'#163#233#158#199'I'#5'b'#143#232#188#131'Ll|l'#1#244#236#224's'#128#143 + +#134#29'#'#153#153#135#195'{'#198#222'7'#14'>'#216#249't'#175#199't'#159#167 + +'('#224'[b'#235';W'#224#197#29#31'6'#2#176#191#217'h'#3#155#155#155#254't:' + +#13'1S1'#252#3'0'#11#232#223'-'#178#7#225#12'D6'#225#138'8'#7'W'#196'y'#168 + +#157#132#158#215#164#199#177'A'#159'V;@'#4#30#224#166'Q:'#152#215#187#253'Yc' + +'}'#148#196'+'#185#22#233'V'#133'7)'#191'E'#135#225#162#243#176'K'#8#185#152 + +#0#164'x'#16#25#212#153#28#130#176#206')'#201'>'#214'd>'#148#10#139'J'#191 + +#244'`'#219#242'"G'#160#236#237#247'Jf@^$'#7#25'3'#1#248'K'#209'H'#19'@'#159 + +'p'#197']'#150#152#245#212#206#198#163#242#195#0#15#252'f%'#147#1#239'1'#251 + +#181'`1&'#21#127#167'GK'#232#193'!'#160'L'#237'0'#147'B'#154'iu'#223#177#241 + ,#171#18#223#216#249#3#1'?'#146'w'#0'~^'#144#194'K'#210#30#197';'#172#238'w' + +#187#221#217#214#214'V'#226'x'#248'_X['#255#176#241'a$'#128#210'o_f'#22#208 + +#225#26#217#130#28'6$'#2#128'F'#208's'#23#209#6#208'k'#160'm'#136#128#128#140 + +'(CL'#251#16#211'Rc'#204#157#238'|'#180'*O'#9#206#251#179#198#234'h^'#235'M' + +#211#168#157#230#162#25#24#199#158'r'#10#131'J'#132'`'#156#127#190'>ig'#187 + +#152#199#16']'#144#27'*'#8'"q:'#134'tX"'#17#158#164'"'#243#233#232#181'/Z' + +#134#150#190#137#216#218'R)'#151'9'#139's'#28#146#28#18#158'_'#207#225'7'#7 + +#196#182#196#183#240#1#184#0'W'#165#130' 1#8T'#167#242#154#191#24#213#163#249 + +#176'G*>Zn'#23#17#8#145#246'8'#3#2'>x'#18#206'}''o'#223#134#244#164'K'#207 + +#184#2'|'#187#208'=d'#224'#'#172#135'L>"'#2#246#238'#'#149#151#8' '#251#176 + +'I}w|'#152#9#192#140#3'f'#1'B'#127#244'p'#196#198'QH'#255'o'#9#216#187#244' ' + +#245#184#150#128#136'@4'#2'v'#20'*'#204'T'#164#188':4'#2')4'#10#173'V'#224'#' + +#29'E'#251#10#176#13#208#18#9#212#137#12#186#147'E'#220#157'$q'#139#224#16#26 + +'S'#161#232''''#232';'#205'D+'#246#190#152#2#150','#148#155'*l~'#150#252'@.' + +#30':$$'#232#216#255#182'EW'#169'1'#191#201#250'S'#165'\'#0'['#221#167#138 + +#148'`'#6'u'#166'T'#158'/'#7'<'#214#181' '#25#215#131#249#176#25#207#251#237 + +'h6'#242#149'8'#243'<61'#140'moA'#175't'#202'.'#24#133#213'|Y'#230#198#179'o' + +'T}'#19#211#151#5#158#254'>'#128'OD>'#140#162'h'#12#137'O'#199#167't'#127#23 + +'t<'#249'0'#170#251#203#198#5#1#20#195's'#205#130';w'#238#4#198'?'#128'9'#7 + +#232'!B'#205'@'#203#241#19#244'$'#140#200'k'#248#7#20'"'#6'9W'#26#214#161#209 + +#18#216#17'm@BQ'#24#248#30#200' '#160'c>'#180'^F'#165'/'#229'<'#244'wL$@'#132 + +#208#153'.'#162#206'4'#141#219#153#14#8#138#237'^T'#4#22'e'#194#170#168#10'T' + +#254'R'#240#219#191'U'#207#127#241#207'J'#246'_'#197#7'`Gn'#205#0#3'z'#183 + +#145'g'#225'G(^g'#0#31#251#201#164#22#206#135#173'h>h'#147#164#15#252'4)^c' + +#153#197#128'^Y'#21#255#160#180'/'#169#250#144#248'p'#224')'#1#187#164#242 + +#150#164#189#1'~'#171#213#154#141'F#'#246#236#147#169#151'~X'#213#253'e'#227 + +#130#0#202#227#128#127#192#16#1'=H'#28':'#164#127's2'#17#173'['#244#0#162#216 + +#168'+'#26#129#171#13#176#143#0#175#229#228'#'#223#135'Ya'#200' 8@'#6#128#174 + +#158'`'#132'a'#142'|<"'#132#246'x'#17#183#146'4'#168#207#179#176#190'H'#131 + +'Z'#170#160#219'k'#251#221'8'#245#140'K'#191'T'#13#184'$'#239#223#141#8#228 + +#203'~t5'#20'h'#134'['#251#239#185#210#221#253#191#6'n'#228#167#211#208#207 + +'fQ'#144#204#234#225'bL'#18'~'#16'.'#3#188#233#18'"'#182'C'#174#127#145#168 + +#248'E'#214#30'-'#11'g'#218'-'#171#234'+'#157#190#203#224#167'{'#224#18#192 + +#144'#'#179'I'#194#210#254#2#248'O'#31#23#4#176'|,%'#2'Z'#135#244'@'#177'F'#0 + +'`'#211#186'I*f'#139#236'J'#214#10#132#16#12#9'X"@'#19#18#218#6'y'#212'@'#6 + +' '#2#218#14#133#12'|'#218#151#194#2#206#177#169#16#130#178#128'N'#179' '#154 + +'fQm'#158#16')'#164'!'#19'C'#146#250#181'E'#22#214'r'#195#2'y'#17#247#207#221 + +#219#235#29#248'y2'#242#165#155#252#170'R'#11'0'#253'7'#240#178'E'#236#167 + +#179#200'O'#166'Q'#152#206#226' '#153#214'BZ'#252'd^'#10#31#28#4#188#212#222 + +#235#20']Ro'#178#220#168#19#185'JM'''#30'U'#150#246'('#207#157'J?>'#11'|'#168 + +#251't'#157#135#0#191#0#30'j>&'#221#132'I0E'#6#159#249#172'%'#192'_'#242'K?' + +#188#227#130#0#158'<'#150#18#1'|'#4#237'6'#201#183#217#140';'#20#19#1#160#203 + +#144#169'5h'#201#186'm'#246#141#198#0#243'@i'#13#2#4#2'2`"'#144#133#181#2'!' + +#4#175'B'#8#162#229#235'F'#0'E*'#191#201#243#247#2'"'#129'('#205#252' '#205 + +#149#159#229'~'#0#19'"'#203#184#160')'#160#181#143#207'&'#158#241#233'8'#142 + +#249'x'#15' '#233'{y'#202#139#162'Wy'#10#219#153'g'#142'y'#244#137'~'#158#6#4 + +'N'#218'N#?K0C'#14#127#181#237#249#167#247#204'1}Z'#185#20#11'j'#213#222#145 + +#240#12'B'#237#197#183'q{+'#237'Mi'#174#210#192#159'HW'#158#145'*'#128#15#169 + +#143#184'='#239#147#186#143#10#189'1'#173'!'#241#209#140'snl'#252'G'#143#30 + +'e'#23#192#127#250#184' '#128#163#13'K'#4#223#253#238'w=4%'#5#25#208#161#144 + +#164'N'#212'l6'#1'd'#214#10#232#129'lxz'#174'B'#180'('#3#240#153#4'h'#223#144 + +'C'#211#209#10'jB'#6#136#30'DJG'#16't'#20'A'#19#2#242#10#8#139#220#2'Dr'#130 + +#217'y^'#164#249#225#143#239#219'm'#140#220'sN'#250#224#207#240#14#252'#?' + +#176#225#202#240#138#242' '#249#0'z;/'#210#133'9'#25#152#147'!3'#237'P'#212 + +#21'x'#158#199#217#3'.'#224#233'X"'#221'vy'#150#29#167'@'#7#224#7#152'a'#223 + +#143' '#229#165' '#135#215't|'#4#208'C'#210#3#244#240#230'c!'#2'^'#192#171'O' + +#199#211#11#224'?'#219#184' '#128'g'#27'%"@'#212#224#210#165'K>I'#164#144#30 + +'D&'#3#180''''#4#168#145'a'#8'2'#192#2'2P'#152#202#220'Y'#132#8#140'i'#192 + +#230#1'k'#5#30';'#14']B`2'#160'c'#1'b'#8#162#29'0'#17#152#22' '#24'y'#145#223 + +#167'r'#183#11'`'#165#17#192#129'y'#9#151#254'J'#227#225'We'#253'_)'#227#164 + +#211'h'#215'L$'#130']'#25#231#157#150#242#136#238#231'6Vo='#248#6#240'R'#142 + +'k'#194'x'#0#255'd'#137#212#231'E'#18'vX'#189#23#21#127#14#208'c'#166']'#196 + +#241'WVV2x'#245#137#148#243#11#224'?'#219#184' '#128#247'7l^-'#194#135#244#16 + +'z'#198'<'#160#135#18#128'E'#143'B6'#17#224'/'#160'}'#16'B'#131#164#22#8#129 + ,'5'#0#172'}'#157'Q'#216#144'F'#165'L'#4'R'#177#200#239#177'D'#160#29#136#161 + +#199'A}'#144#129'v '#210#182#246#31'(]'#151' '#219#170#152'}'#132#165's'#209 + +'4'#200#156#244'!, '#160'Vy^v'#3'j'#183#164'W'#184#253#10'U>7'#157't'#217#129 + +''''#222'{'#165#165#188#5#190'S'#127#207'^|'#165#165'=/p'#236#161#209#6#253 + +'~'#168#243#19#172'%'#166'?!'#160'c'#31#196'0C=>'#169#247' '#142#132#142'!y' + +#7#128#207#156'8'#190#156#253#5#232#159'e\'#16#192#7#27#150#8#240#0#186'Z'#1 + +'I'#168'`gg'#7'R;'#132#137#0#243#20'd'#0'p'#139#218'_'#23#240'#'#215#192#128 + +#159'5'#2'G30D`4'#3#215'g`'#9'Ai'#13#1'$'#16'pI?'#231#28's'#242#156'''`'#247 + +#12#17'('#19';8D'#19'p'#192#207#0'/'#8'AK~'#165'{'#230#27#213'>'#173#0#222 + +#196#233#141#138'o'#156'y'#0#191#241#228'O'#5#220'v'#27#199#1'~'#243#127#168 + +#245'x}'#20'Es'#0#31#210#30#234'='#17'jz'#227#198#141#20#160#135#180'w'#242 + +#245#249'|O'#251'a8'#143#227#130#0#158#223'8'#160#21#12#6#3#175#211#233#4#180 + +#248#244#0#179#153#0'I'#14'S'#129#30#234#152#30'n'#164#31'C'#202#215#232'X' + +#141#142#25'S'#192#152#5#150#4#232#189#186'eY'#161#21#132'UBP'#154#20'x'#246 + +'$!'#4#156#147'/'#224#247'DK'#176#219#149#243#182#170#188'2'#210#221#181#225 + +'s''>/'#210']z'#234#25#208'/'#28#208'W'#213'|+'#245'E'#221#231#181#144#194#12 + +'*=IwH'#249#5'@O@_'#200'g&'#0'=T|c'#219#11#232#205'y'#186#235#139#241'>'#198 + +#5#1#28#207'Xj"'#208#218#7#25'@3'#160#7#157'M'#5','#4'nL'#127#142#233#206'"' + +#151#16'|'#157'?`4'#6#248#22'P'#189#24#11#17'D'#134#16'@*'#244#186'RD'#1'D@' + +#175'E'#196#194#19'2`"'#192#182#28#243#212#146'x`'#201#142'/'#0#159#27#21'_' + +#21'j=7'#212#196'B'#223#195#192#167#207#157#211#246#1#2#192'B'#191'k'#230#2 + +#158#200#14#210#29#239'Y@'#194#131'H'#232'xj$'#189#1'=]'#175#188#162#226#187 + +#235#139#241#1#199#5#1#28#239#176#215#215'8'#14#141'f'#0'3aoo'#143#9'!@i'#218 + +'`'#16#192'l'#160#151#134' '#3#172'A'#8' '#7':'#206'k'#128#158'^'#202'k9'#30 + +#154#227'J'#252#4#202'1'#13#180'I'#192'f'#128'oH'#0#231#148'!.X'#144'@q'#178 + +#5#208'sQ'#237'-'#240#177#166#247'X'#201#175#196#161''''#4#176'0'#251#134#0 + +'d!<'''#6#228#144#236#176#223#23'Fk'#0#224#137#3#210#181#181#181#148'~?'#212 + +#250#140'L'#168#28#160#191'p'#232#157#204#184' '#128#147#27#165'D\'#233'Y' + +#168'@'#8#208#12'n'#222#188#233'-#'#4#12#2'M '#160#14#5#212'au'#219#172#149 + +'&'#14#214#0'0'#0'v'#1'k6'#155#217't:'#205#232#156#243'e'#18'~'#9#224#171#219#23#227#152 + +#199#5#1#156#141'Q'#186#15#198'\'#192#182'1'#25#8'H'#30'H'#129'H'#192'#py' + +#134#24#8#148#30#200#129#128#232#25'r'#160'}'#143'@j'#23':'#206#128#199'6>' + +#19#219#4'V'#187#141#181#207#253'L'#148'"'#0#27#192#243'>}/o'#155#133#190'?' + +#7#208#137'Dr'#128#156#190'+'#235#247#251'9'#129#222#2#29#146#189#221'n'#231 + +#6#236#248#156#11#192#159#205'qA'#0'gsT'#239#139''''#192'Q.1`'#13'r'#184'u' + +#235#150'7'#28#14'-9'#224'8'#8#2'k'#179'O'#192#230'5'#8#3#235#245#245'u'#187 + +'m'#6#128#140'5Iy'#11'J'#2';o'#3#220'X?~'#252'8'#199'6@'#142#253'e@'#199#250 + +#16#176'/'#219#191#24#167'8.'#8#224'|'#141'e'#247#235#0'9`'#24#130'0'#3'D' + +#177#236#3#161'Y`]'#175#215#15#0#211#128#218#29#6#224#24#0'9'#214#135#0#253 + +#176'c'#23#227#12#141#11#2'x1'#198#179#220#199#163#190#246#168#224#189#0#249 + +'9'#30#23#4'p1.'#198#135'x'#252#127'p'#251'ut'#3#215#244'"'#0#0#0#0'IEND'#174 + +'B`'#130'('#0#0#0#128#0#0#0#0#1#0#0#1#0' '#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#1#0#0#0#1#0#0#0#1#0#0#0#1#0#0#0#1#0#0#0#1#0#0#0#1#0#0 + +#0#1#0#0#0#1#0#0#0#1#0#0#0#1#0#0#0#1#0#0#0#1#0#0#0#1#0#0#0#1#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + ,#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#1#0#0#0#1#0#0#0#2#128#128#128#2'UUU'#3'@@@'#4'333'#5'III'#7'@@@'#8 + +'999'#9'999'#9'MMM'#10'FFF'#11'FFF'#11'FFF'#11'MMM'#10'999'#9'@@@'#8'@@@'#8 + +'UUU'#6'333'#5'UUU'#3#128#128#128#2#0#0#0#2#0#0#0#1#0#0#0#1#0#0#0#1#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#1#0#0#0#1#128#128#128#2'UUU'#3'UUU'#6'@@@'#8'FFF'#11'III'#14'<<' + +'<'#17'III'#21'EEE'#26'DDD'#30'DDD"EEE%AAA''DDD)AAA+AAA+AAA+DDD)AAA''GGG$FFF' + +'!DDD'#30'==='#25'@@@'#20'@@@'#16';;;'#13'FFF'#11'@@@'#8'333'#5'UUU'#3#128 + +#128#128#2#0#0#0#1#0#0#0#1#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#1#0#0#0 + +#2'UUU'#3'+++'#6'999'#9'NNN'#13'CCC'#19'BBB'#27'GGG$DDD-CCC5DDD'#211'SC6'#219'W@0'#227'[>+'#235']<('#238'^<'''#240 + +'_<%'#243'`<#'#245'a;"'#247'a:!'#248'a;"'#246'`<$'#245'_<%'#242'^='''#240'\=' + +')'#237'Z=,'#233'V@1'#225'RD8'#217'NG?'#210'JHD'#204'IHC'#204'HHD'#204'GEC' + +#203'FEC'#202'EED'#198'EED'#195'DDC'#190'DDC'#183'DDD'#172'DDD'#157'DDD'#138 + +'DDDtCCC\DDDDCCC.@@@'#28'DDD'#15'III'#7'UUU'#3#0#0#0#1#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#1'UUU'#3'@@' + +'@'#8'KKK'#17'HHH CCC5CCCPDDDlCCC'#134'DDC'#156'EED'#172'FEC'#185'GFD'#193'G' + +'FC'#198'HFC'#202'IGD'#203'PE;'#213'VA0'#227']<('#239'a;#'#246'd9'#30#254'g:' + +#29#255'g:'#30#255'i<'#30#255'j='#31#255'j>'#30#255'k>'#30#255'l?'#31#255'l@' + +#31#255'mA'#31#255'nA'#31#255'm@'#31#255'l@'#31#255'l?'#31#255'k>'#30#255'j>' + +#30#255'j='#31#255'i<'#30#255'g:'#30#255'f:'#29#255'd9'#31#252'`<#'#245'[=*' + +#236'UA3'#223'MF?'#210'IHC'#204'HFD'#204'FFC'#203'FFE'#200'DDC'#197'EED'#191 + +'DCC'#182'DDD'#170'CCC'#152'CCC'#129'DDDfDDDKDDD1FFF'#29'@@@'#16'III'#7'UUU' + +#3#0#0#0#1#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#1'UUU'#3'II' + +'I'#7'@@@'#16'@@@ FFF7DDDRCCCoCCC'#140'DDC'#163'EED'#180'EED'#191'FFC'#198'I' + +'GD'#201'ME?'#208'UA2'#224'\<('#238'b9 '#250'f:'#29#255'h;'#30#255'j>'#30#255 + +'m@'#31#255'oB '#255'qD '#255'sF '#255'uH!'#255'|L#'#255#128'O$'#255#133'Q%' + +#255#136'S&'#255#139'V'''#255#143'X('#255#145'Y)'#255#142'W('#255#139'U''' + +#255#135'S&'#255#131'Q%'#255#128'O$'#255'yK"'#255'tG!'#255'rE '#255'pD '#255 + +'nA '#255'l@'#31#255'j='#31#255'g;'#30#255'e9'#29#255'a;!'#247'Z=+'#234'RB5' + +#221'JGC'#207'HFD'#204'FEC'#203'FFE'#200'EED'#196'DDC'#189'DDD'#177'CCC'#159 + +'DDD'#135'CCCjBBBMBBB2FFF'#29'III'#14'UUU'#6#128#128#128#2#0#0#0#1#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#2'333'#5';;;'#13'BBB'#27'AAA3BBBQDDDqDDD'#142'EED'#165 + +'EDB'#183'FEC'#194'HFD'#200'IFB'#205'SA3'#223'^;&'#242'e8'#29#255'g;'#30#255 + +'j>'#31#255'mA'#31#255'pD!'#255'tG!'#255'~M#'#255#141'W('#255#151']*'#255#160 + +'c-'#255#169'i0'#255#178'n1'#255#181'q2'#255#182's3'#255#183't3'#255#184't3' + +#255#184'v3'#255#185'v4'#255#186'w3'#255#185'v3'#255#184'u3'#255#184't3'#255 + +#183't3'#255#182'r3'#255#181'q2'#255#175'l1'#255#166'h/'#255#158'a,'#255#149 + ,'\*'#255#138'U('#255'zK"'#255'sF '#255'pC '#255'l@'#31#255'i='#31#255'g;'#30 + +#255'c8'#31#252'[<*'#237'RC8'#218'IGD'#205'HFD'#204'EED'#201'DDC'#198'EED' + +#191'DDD'#179'CCC'#161'DDD'#136'CCCkEEEJDDD-@@@'#24'FFF'#11'@@@'#4#0#0#0#1#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#1'UUU'#3'999'#9'FFF'#22'CCC*DDDGDDDiCCC'#138'EED'#165'FEC'#184'FEC'#194 + +'HHD'#200'QC9'#216'[<*'#237'c8'#31#253'g;'#30#255'j>'#31#255'nA '#255'sF!' + +#255'|M#'#255#141'W('#255#158'a,'#255#173'k1'#255#181'r3'#255#185'v4'#255#187 + +'y4'#255#189'{4'#255#191'~5'#255#193#129'5'#255#195#131'5'#255#196#132'6'#255 + +#197#134'6'#255#198#134'6'#255#199#136'6'#255#200#136'6'#255#200#137'6'#255 + +#199#136'6'#255#198#135'6'#255#198#134'6'#255#197#133'5'#255#196#132'6'#255 + +#195#131'5'#255#193#128'5'#255#191'~4'#255#188'z4'#255#186'x4'#255#184'u3' + +#255#181'q2'#255#168'i/'#255#153'_+'#255#137'T'''#255'yJ"'#255'rE '#255'm@' + +#31#255'i<'#31#255'f:'#30#255'b9!'#249'X>.'#232'MD>'#212'HFD'#204'EED'#202'E' + +'ED'#198'EED'#192'CCC'#180'CCC'#160'DDD'#132'DDDbCCCACCC&CCC'#19'@@@'#8'UUU' + +#3#0#0#0#1#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#1'333'#5 + +'III'#14'>>>!DDD'#255 + +#232#177'>'#255#234#179'?'#255#236#181'>'#255#236#182'?'#255#237#183'?'#255 + ,#237#183'?'#255#238#183'@'#255#238#184'?'#255#238#185'?'#255#238#184'?'#255 + +#238#183'@'#255#237#182'?'#255#237#183'?'#255#236#182'?'#255#236#181'>'#255 + +#234#179'>'#255#232#176'>'#255#230#175'>'#255#229#172'='#255#227#169'='#255 + +#224#167'='#255#220#161'<'#255#217#157'<'#255#213#153';'#255#209#148':'#255 + +#204#142'9'#255#198#135'8'#255#193#129'7'#255#188'{6'#255#183't5'#255#171'k2' + +#255#142'W)'#255'tH"'#255'nA '#255'h<'#31#255'd7'#30#255'[:('#240'KD?'#211'G' + +'FD'#204'DDC'#201'EDD'#195'CCC'#182'CCC'#159'CCC}EEEUBBB2@@@'#24'999'#9'UUU' + +#3#0#0#0#1#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#1'333'#5'III'#14'BBB#EEECCCCkEEE'#145'DDC'#174'FFE'#192'KE@'#206'Z;)' + +#238'c8'#30#255'i<'#31#255'oB!'#255'|M%'#255#153'_-'#255#178'o4'#255#186'x6' + +#255#192#128'7'#255#198#135'9'#255#204#142':'#255#209#149';'#255#214#155'=' + +#255#219#161'>'#255#223#167'>'#255#227#170'>'#255#230#174'?'#255#232#177'@' + +#255#235#181'A'#255#237#183'A'#255#238#185'A'#255#240#187'A'#255#241#188'A' + +#255#242#189'B'#255#243#190'A'#255#244#191'B'#255#244#192'B'#255#244#191'B' + +#255#244#192'B'#255#244#192'B'#255#245#193'A'#255#244#192'B'#255#244#192'B' + +#255#244#191'B'#255#244#192'B'#255#244#191'B'#255#243#190'A'#255#242#189'B' + +#255#240#187'A'#255#239#186'A'#255#238#184'@'#255#237#183'A'#255#235#179'@' + +#255#232#176'?'#255#229#173'?'#255#226#169'?'#255#223#165'>'#255#218#160'=' + +#255#213#153'<'#255#208#147';'#255#202#140':'#255#196#133'9'#255#190'~7'#255 + +#184'v6'#255#173'l3'#255#145'Y+'#255'uH$'#255'm@ '#255'g;'#31#255'b7'#31#253 + +'U>/'#230'IEC'#206'FFE'#202'EED'#199'CCC'#189'DDD'#170'DDD'#139'BBBdCCC=BBB' + +#31'@@@'#12'UUU'#3#0#0#0#1#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#1'UUU'#6'KKK'#17'DDD)EEENDDDxDCC'#157'DDC'#182'GGC'#197'T=1'#225'a7 ' + +#252'g;'#31#255'l@ '#255'wI$'#255#154'^.'#255#179'o6'#255#186'x7'#255#193#128 + +'9'#255#200#137':'#255#207#146'<'#255#212#153'>'#255#217#159'>'#255#222#166 + +'?'#255#227#170'@'#255#231#175'A'#255#234#180'B'#255#236#182'B'#255#238#185 + +'B'#255#240#187'B'#255#242#190'D'#255#243#191'C'#255#244#192'D'#255#245#193 + +'C'#255#246#194'D'#255#247#194'D'#255#247#196'E'#255#247#196'D'#255#247#196 + +'D'#255#248#197'D'#255#248#197'D'#255#248#197'D'#255#248#197'D'#255#248#197 + +'D'#255#248#197'D'#255#248#196'D'#255#247#196'D'#255#247#196'D'#255#247#195 + +'E'#255#246#195'D'#255#245#193'D'#255#245#193'C'#255#244#192'D'#255#243#191 + +'C'#255#242#189'C'#255#240#186'C'#255#238#184'C'#255#236#182'B'#255#233#179 + +'B'#255#230#174'A'#255#226#169'@'#255#221#164'?'#255#216#157'>'#255#211#151 + +'='#255#205#143'<'#255#198#135':'#255#191#127'8'#255#184'w7'#255#174'l4'#255 + +#144'X+'#255'rE"'#255'j> '#255'e9'#30#255'_8"'#247'O@8'#219'GFD'#204'DDC'#201 + +'CCC'#194'CCC'#178'DDD'#151'DDDqDDDGGGG$III'#14'@@@'#4#0#0#0#1#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#2'III'#7'@@@'#20'CCC.DDDVCCC'#130'EED'#165'DDC'#189 + +'LB='#207']7$'#244'd7'#31#255'j> '#255'qE"'#255#140'W+'#255#174'l5'#255#186 + +'x8'#255#193#129':'#255#200#138'<'#255#207#146'>'#255#213#155'?'#255#220#163 + +'@'#255#225#169'A'#255#229#174'B'#255#233#179'D'#255#236#182'D'#255#239#185 + +'D'#255#241#189'E'#255#242#190'E'#255#244#192'E'#255#245#194'E'#255#246#195 + +'F'#255#247#195'F'#255#247#196'G'#255#247#197'F'#255#248#197'F'#255#248#197 + +'F'#255#249#198'F'#255#249#198'G'#255#249#198'G'#255#249#198'G'#255#249#198 + +'G'#255#249#198'G'#255#249#198'G'#255#249#198'G'#255#249#198'G'#255#249#198 + +'G'#255#249#198'G'#255#249#198'G'#255#249#198'F'#255#248#197'F'#255#248#197 + +'F'#255#247#196'F'#255#247#196'F'#255#247#195'F'#255#246#194'F'#255#244#193 + +'F'#255#243#191'E'#255#242#190'E'#255#240#188'E'#255#238#185'D'#255#235#181 + +'D'#255#232#178'C'#255#228#172'C'#255#223#167'B'#255#218#161'@'#255#212#153 + +'?'#255#205#144'='#255#198#135';'#255#191#127'9'#255#183'u7'#255#167'g3'#255 + +#130'P('#255'oB"'#255'h< '#255'c7'#30#255'X:*'#237'HFB'#207'EEE'#202'DCC'#197 + +'DDD'#184'CCC'#160'CCCzEEENFFF(@@@'#16'333'#5#0#0#0#1#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + ,#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#2 + +'III'#7'FFF'#22'BBB2CCC\DDD'#136'DDC'#171'EED'#192'Q?5'#219'a6'#31#252'f:'#31 + +#255'mA!'#255#127'N'''#255#164'f3'#255#182'u8'#255#190#127':'#255#199#138'=' + +#255#207#147'?'#255#213#155'A'#255#220#163'B'#255#225#170'D'#255#230#177'E' + +#255#234#181'E'#255#237#184'F'#255#240#188'G'#255#242#189'G'#255#243#192'G' + +#255#244#193'H'#255#245#194'H'#255#246#195'H'#255#247#196'H'#255#247#197'H' + +#255#247#197'H'#255#248#198'H'#255#248#198'H'#255#248#197'H'#255#248#198'H' + +#255#248#198'I'#255#249#198'I'#255#249#198'I'#255#249#198'I'#255#249#198'I' + +#255#249#198'I'#255#249#198'I'#255#249#198'I'#255#249#198'I'#255#249#198'I' + +#255#249#198'I'#255#249#198'I'#255#248#198'I'#255#248#198'H'#255#248#198'H' + +#255#248#198'H'#255#248#198'H'#255#247#197'H'#255#247#196'I'#255#247#195'H' + +#255#246#195'H'#255#245#195'H'#255#244#193'H'#255#243#191'G'#255#241#189'G' + +#255#239#186'G'#255#236#183'F'#255#233#180'F'#255#229#175'D'#255#224#168'D' + +#255#218#161'B'#255#211#153'@'#255#205#144'?'#255#196#134'='#255#188'{:'#255 + +#180'r8'#255#155'_/'#255'wJ$'#255'j? '#255'e8'#30#255']8#'#246'LB<'#213'FEE' + +#203'EED'#199'DDD'#188'DDD'#165'DDD'#128'DDDSFFF,GGG'#18'+++'#6#0#0#0#1#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#2'III'#7'CCC'#23'BBB6DDDaCCC'#141'DDC'#174'GDB'#196'V:+'#233'c7'#30#255'h; ' + +#255'pC#'#255#146'Z-'#255#179'p7'#255#187'{;'#255#196#133'='#255#204#144'?' + +#255#212#154'B'#255#219#163'E'#255#225#170'E'#255#230#176'G'#255#234#181'H' + +#255#238#185'I'#255#240#189'I'#255#242#190'J'#255#243#192'J'#255#244#193'J' + +#255#245#195'J'#255#246#195'J'#255#246#196'J'#255#247#196'K'#255#247#196'K' + +#255#247#197'K'#255#247#197'K'#255#247#197'K'#255#247#197'J'#255#247#197'J' + +#255#247#198'J'#255#247#198'J'#255#247#198'J'#255#247#198'J'#255#247#198'J' + +#255#247#198'J'#255#247#198'J'#255#247#198'J'#255#247#198'J'#255#247#198'J' + +#255#247#198'J'#255#247#198'J'#255#247#198'J'#255#247#198'J'#255#247#197'J' + +#255#247#197'J'#255#247#197'J'#255#247#197'K'#255#247#197'K'#255#247#197'K' + +#255#247#196'K'#255#246#196'K'#255#246#196'J'#255#246#195'J'#255#245#195'J' + +#255#244#194'J'#255#243#191'I'#255#241#189'I'#255#239#188'I'#255#236#184'H' + +#255#233#180'H'#255#228#174'G'#255#223#168'E'#255#217#160'C'#255#210#151'B' + +#255#202#141'?'#255#193#130'<'#255#185'x:'#255#174'm6'#255#134'S*'#255'mA"' + +#255'f:'#31#255'a6'#30#253'R>4'#224'FFE'#203'EED'#200'CCC'#190'DDD'#169'CCC' + +#133'CCCXAAA/CCC'#19'+++'#6#0#0#0#1#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#1'III'#7'CCC'#23'BBB6CCCcCCC'#144'EED'#177'JC>'#202 + +'[6"'#244'c8'#31#255'j?!'#255'xI&'#255#162'd2'#255#183'u:'#255#192#129'='#255 + +#200#140'@'#255#209#150'B'#255#217#160'E'#255#223#169'G'#255#229#176'H'#255 + +#233#181'J'#255#236#185'J'#255#239#188'K'#255#241#190'K'#255#242#192'K'#255 + +#243#193'L'#255#244#194'L'#255#245#195'L'#255#245#195'L'#255#245#195'L'#255 + +#246#196'L'#255#246#196'L'#255#246#196'L'#255#246#196'L'#255#246#196'M'#255 + +#246#196'M'#255#246#197'M'#255#246#197'M'#255#246#197'M'#255#246#197'M'#255 + +#246#197'M'#255#246#197'M'#255#246#197'M'#255#246#197'M'#255#246#197'M'#255 + +#246#197'M'#255#246#197'M'#255#246#197'M'#255#246#197'M'#255#246#197'M'#255 + +#246#197'M'#255#246#197'M'#255#246#197'M'#255#246#197'M'#255#246#196'M'#255 + +#246#196'M'#255#246#196'M'#255#246#196'L'#255#246#196'L'#255#246#196'L'#255 + +#246#196'L'#255#245#195'L'#255#245#196'L'#255#244#195'M'#255#244#194'L'#255 + +#243#193'L'#255#242#192'L'#255#241#190'K'#255#238#188'K'#255#236#184'J'#255 + +#232#179'I'#255#228#173'H'#255#222#166'F'#255#215#158'E'#255#207#148'B'#255 + +#198#137'?'#255#190'~<'#255#180'r9'#255#150']/'#255'qE$'#255'h< '#255'b6'#30 + +#255'W9*'#235'GED'#204'DDC'#201'DDD'#192'CCC'#172'CCC'#137'DDDZAAA/GGG'#18'3' + +'33'#5#0#0#0#1#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#1'+++'#6'II' + +'I'#21'CCC5DDDbCCC'#145'DDC'#178'LB;'#206'^6 '#249'd8'#31#255'l@!'#255#131'Q' + +'*'#255#172'k7'#255#186'z;'#255#196#133'?'#255#205#146'C'#255#213#156'E'#255 + +#220#165'G'#255#227#173'I'#255#232#180'K'#255#236#184'L'#255#238#187'L'#255 + ,#240#189'N'#255#241#191'N'#255#242#192'N'#255#243#193'N'#255#244#194'N'#255 + +#244#194'N'#255#244#194'O'#255#244#195'O'#255#244#195'O'#255#244#195'O'#255 + +#244#195'O'#255#244#195'O'#255#244#195'O'#255#244#195'O'#255#244#195'O'#255 + +#244#195'O'#255#244#195'O'#255#244#195'O'#255#244#195'O'#255#244#195'O'#255 + +#244#195'O'#255#244#195'O'#255#244#195'O'#255#244#195'O'#255#244#195'O'#255 + +#244#195'O'#255#244#195'O'#255#244#195'O'#255#244#195'O'#255#244#195'O'#255 + +#244#195'O'#255#244#195'O'#255#244#195'O'#255#244#195'O'#255#244#195'O'#255 + +#244#195'O'#255#244#195'O'#255#244#195'O'#255#244#195'O'#255#244#195'O'#255 + +#244#195'O'#255#244#195'O'#255#244#194'O'#255#244#195'N'#255#244#194'N'#255 + +#243#193'N'#255#242#192'M'#255#241#190'N'#255#240#189'M'#255#237#186'M'#255 + +#235#182'L'#255#230#178'K'#255#225#171'I'#255#219#163'G'#255#211#153'D'#255 + +#202#143'B'#255#192#130'>'#255#183'u:'#255#164'f4'#255'yK&'#255'i=!'#255'c7' + +#30#255'Z8%'#241'GEC'#205'DDC'#201'CCC'#193'DDD'#173'DDD'#136'BBBYDDD-KKK'#17 + +'333'#5#0#0#0#1#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#1'333'#5'CCC'#19'BBB2CCC_DD' + +'D'#143'DDC'#178'M@8'#211'_5'#31#251'e9'#31#255'lA"'#255#144'Y/'#255#179'r9' + +#255#188'}='#255#198#138'B'#255#208#149'D'#255#217#161'H'#255#223#170'K'#255 + +#229#177'L'#255#234#181'M'#255#236#186'N'#255#239#188'O'#255#240#190'P'#255 + +#241#191'P'#255#242#192'P'#255#242#192'P'#255#242#193'P'#255#243#193'P'#255 + +#243#194'P'#255#243#194'P'#255#243#194'P'#255#243#194'P'#255#243#194'P'#255 + +#243#194'P'#255#243#194'P'#255#243#194'P'#255#243#194'P'#255#243#194'P'#255 + +#243#194'P'#255#243#194'P'#255#243#194'P'#255#243#194'P'#255#243#194'P'#255 + +#243#194'P'#255#243#194'P'#255#243#194'P'#255#243#194'P'#255#243#194'P'#255 + +#243#194'P'#255#243#194'P'#255#243#194'P'#255#243#194'P'#255#243#194'P'#255 + +#243#194'P'#255#243#194'P'#255#243#194'P'#255#243#194'P'#255#243#194'P'#255 + +#243#194'P'#255#243#194'P'#255#243#194'P'#255#243#194'P'#255#243#194'P'#255 + +#243#194'P'#255#243#194'P'#255#243#194'P'#255#243#194'P'#255#243#193'P'#255 + +#242#193'P'#255#242#192'O'#255#242#192'P'#255#241#192'P'#255#240#190'P'#255 + +#238#188'O'#255#236#185'N'#255#232#180'M'#255#228#175'L'#255#222#167'I'#255 + +#215#159'H'#255#205#147'D'#255#196#134'@'#255#186'y<'#255#173'm7'#255#130'O*' + +#255'j?!'#255'c8'#31#255'[7#'#245'HDA'#208'DDC'#201'CCC'#193'CCC'#172'CCC' + +#134'AAAVAAA+@@@'#16'@@@'#4#0#0#0#1#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#1'@@@'#4'<<<'#17'CCC.CC' + +'C[CCC'#140'EED'#176'O>5'#213'_5'#30#253'e9'#31#255'nB#'#255#151'\1'#255#181 + +'s:'#255#191#129'@'#255#201#142'C'#255#211#154'G'#255#219#164'K'#255#226#173 + +'M'#255#231#179'O'#255#234#184'P'#255#237#187'Q'#255#239#189'Q'#255#240#190 + +'R'#255#240#191'Q'#255#241#192'R'#255#241#192'R'#255#241#192'R'#255#242#192 + +'R'#255#242#192'R'#255#242#193'R'#255#242#193'R'#255#242#193'R'#255#242#193 + +'R'#255#242#193'R'#255#242#193'R'#255#242#193'R'#255#242#193'R'#255#242#193 + +'R'#255#242#193'R'#255#242#193'R'#255#242#193'R'#255#242#193'R'#255#242#193 + +'R'#255#242#193'R'#255#242#193'R'#255#242#193'R'#255#242#193'R'#255#242#193 + +'R'#255#242#193'R'#255#242#193'R'#255#242#193'R'#255#242#193'R'#255#242#193 + +'R'#255#242#193'R'#255#242#193'R'#255#242#193'R'#255#242#193'R'#255#242#193 + +'R'#255#242#193'R'#255#242#193'R'#255#242#193'R'#255#242#193'R'#255#242#193 + +'R'#255#242#193'R'#255#242#193'R'#255#242#193'R'#255#242#193'R'#255#242#193 + +'R'#255#242#192'R'#255#242#192'R'#255#241#192'R'#255#241#192'R'#255#241#192 + +'R'#255#240#191'Q'#255#240#190'R'#255#238#189'Q'#255#236#186'P'#255#234#182 + +'O'#255#230#177'N'#255#224#171'L'#255#217#162'J'#255#208#150'F'#255#198#138 + +'C'#255#188'}>'#255#177'o:'#255#136'S,'#255'k?"'#255'c8'#31#255'\6!'#248'JC?' + +#211'DCC'#201'CCC'#193'CCC'#171'BBB'#131'DDDRAAA''777'#14'UUU'#3#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +'UUU'#3';;;'#13'AAA''CCCTBBB'#135'DDC'#174'N=5'#213'`4'#29#254'e9'#31#255'oC' + +'$'#255#156'`3'#255#181'u<'#255#193#131'A'#255#204#146'E'#255#213#157'I'#255 + +#221#167'M'#255#227#175'O'#255#232#180'Q'#255#235#184'R'#255#237#187'S'#255 + +#238#189'S'#255#239#190'S'#255#240#191'T'#255#240#191'T'#255#240#191'T'#255 + +#240#191'T'#255#240#191'T'#255#240#191'T'#255#240#191'T'#255#240#191'T'#255 + +#240#191'T'#255#240#191'T'#255#240#191'T'#255#240#191'T'#255#240#191'T'#255 + +#240#191'T'#255#240#191'T'#255#240#191'T'#255#240#191'T'#255#240#191'T'#255 + ,#240#191'T'#255#240#191'T'#255#240#191'T'#255#240#191'T'#255#240#191'T'#255 + +#234#187'R'#255#202#161'G'#255#232#185'R'#255#240#191'T'#255#240#191'T'#255 + +#240#191'T'#255#240#191'T'#255#240#191'T'#255#240#191'T'#255#240#191'T'#255 + +#240#191'T'#255#240#191'T'#255#240#191'T'#255#240#191'T'#255#240#191'T'#255 + +#240#191'T'#255#240#191'T'#255#240#191'T'#255#240#191'T'#255#240#191'T'#255 + +#240#191'T'#255#240#191'T'#255#240#191'T'#255#240#191'T'#255#240#191'T'#255 + +#240#191'T'#255#240#191'T'#255#240#191'T'#255#240#191'T'#255#240#191'T'#255 + +#239#189'S'#255#238#188'R'#255#236#186'R'#255#234#184'Q'#255#231#179'Q'#255 + +#226#173'O'#255#219#165'L'#255#211#154'H'#255#201#142'E'#255#190#128'@'#255 + +#179'q:'#255#140'V.'#255'l@"'#255'c8'#31#255'\4'#31#250'JC>'#211'CCC'#201'DD' + +'D'#192'CCC'#168'CCC~DDDKFFF!MMM'#10#128#128#128#2#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#128#128#128#2'333'#10'@@@ EEE' + +'JCCC~EDD'#169'L?8'#208'^4'#30#253'd8 '#255'pD%'#255#159'b4'#255#182'v='#255 + +#194#132'C'#255#205#147'H'#255#215#160'L'#255#222#169'O'#255#228#176'Q'#255 + +#232#181'S'#255#235#185'T'#255#236#187'T'#255#237#188'U'#255#238#189'U'#255 + +#238#190'U'#255#238#190'U'#255#238#191'U'#255#239#190'U'#255#239#190'U'#255 + +#239#190'U'#255#239#190'U'#255#239#190'U'#255#239#190'U'#255#239#190'U'#255 + +#239#190'U'#255#239#190'U'#255#239#190'U'#255#239#190'U'#255#239#190'U'#255 + +#239#190'U'#255#239#190'U'#255#239#190'U'#255#239#190'U'#255#181#144'@'#255 + +';/'#21#255#21#16#7#255#9#7#3#255#2#2#1#255#0#0#0#255#0#0#0#255#0#0#0#255#1#1 + +#1#255#7#6#3#255#17#14#6#255#31#25#11#255'2'''#18#255'SB'#29#255#157'}8'#255 + +#233#186'S'#255#239#190'U'#255#239#190'U'#255#239#190'U'#255#239#190'U'#255 + +#239#190'U'#255#239#190'U'#255#239#190'U'#255#239#190'U'#255#239#190'U'#255 + +#239#190'U'#255#239#190'U'#255#239#190'U'#255#239#190'U'#255#239#190'U'#255 + +#239#190'U'#255#239#190'U'#255#239#190'U'#255#238#190'U'#255#238#190'U'#255 + +#238#190'U'#255#238#189'U'#255#237#188'U'#255#236#186'T'#255#234#184'T'#255 + +#231#180'S'#255#226#175'Q'#255#220#166'N'#255#212#156'K'#255#202#143'F'#255 + +#190#129'A'#255#179'r<'#255#145'Y0'#255'k?"'#255'c7'#31#255'[4 '#248'IC@'#209 + +'DDD'#200'CCC'#190'CCC'#163'DDDtCCCAEEE'#26'III'#7#0#0#0#1#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#1'III'#7'==='#25'AAA?CCCsBBB' + +#162'K?;'#202'^4'#30#252'c8 '#255'oB%'#255#160'b5'#255#183'v>'#255#194#134'D' + +#255#205#148'J'#255#215#161'M'#255#223#171'Q'#255#228#177'T'#255#232#182'U' + +#255#234#185'V'#255#236#187'V'#255#236#187'V'#255#237#188'W'#255#237#189'W' + +#255#237#188'W'#255#237#188'W'#255#237#188'W'#255#237#188'W'#255#237#188'W' + +#255#237#188'W'#255#237#188'W'#255#237#188'W'#255#237#188'W'#255#237#188'W' + +#255#237#188'W'#255#237#188'W'#255#237#188'W'#255#237#188'W'#255#237#188'W' + +#255#237#188'W'#255#237#188'W'#255#159'~:'#255#16#13#6#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#1#0#0#255#16#13#6 + +#255'9-'#21#255'y`,'#255#208#165'M'#255#237#188'W'#255#237#188'W'#255#237#188 + +'W'#255#237#188'W'#255#237#188'W'#255#237#188'W'#255#237#188'W'#255#237#188 + +'W'#255#237#188'W'#255#237#188'W'#255#237#188'W'#255#237#188'W'#255#237#188 + +'W'#255#237#188'W'#255#237#188'W'#255#237#188'W'#255#237#189'W'#255#237#188 + +'W'#255#236#187'V'#255#235#186'V'#255#234#184'U'#255#231#180'U'#255#227#175 + +'R'#255#221#169'Q'#255#213#157'L'#255#202#144'H'#255#191#129'C'#255#180's=' + +#255#145'X0'#255'j>#'#255'b6'#31#255'Z5#'#245'GDB'#206'DDD'#200'CCC'#186'DDD' + +#154'EEEhBBB6@@@'#20'333'#5#0#0#0#1#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#1'@@@'#4'GGG'#18'AAA3DDDfCCC'#152'IA>'#195'\4 '#250'c7'#31#255'm@#'#255 + +#156'_5'#255#182'v?'#255#194#134'E'#255#206#148'K'#255#215#161'O'#255#223#171 + +'S'#255#228#178'V'#255#232#182'V'#255#233#185'X'#255#234#186'X'#255#235#187 + +'X'#255#236#187'X'#255#236#188'X'#255#236#188'X'#255#236#188'X'#255#236#188 + +'X'#255#236#188'X'#255#236#188'X'#255#236#188'X'#255#236#188'X'#255#236#188 + +'X'#255#236#188'X'#255#236#188'X'#255#236#188'X'#255#236#188'X'#255#236#188 + +'X'#255#236#188'X'#255#236#188'X'#255#236#188'X'#255#236#188'X'#255'9-'#21 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#6 + +#5#2#255'$'#29#14#255'ZH"'#255#169#135'@'#255#234#186'X'#255#236#188'X'#255 + ,#236#188'X'#255#236#188'X'#255#236#188'X'#255#236#188'X'#255#236#188'X'#255 + +#236#188'X'#255#236#188'X'#255#236#188'X'#255#236#188'X'#255#236#188'X'#255 + +#236#188'X'#255#236#187'X'#255#235#187'Y'#255#235#186'X'#255#234#186'X'#255 + +#233#184'W'#255#231#180'W'#255#227#176'T'#255#221#169'R'#255#213#158'N'#255 + +#203#145'J'#255#192#130'D'#255#179's='#255#139'U/'#255'i="'#255'a5'#30#255'X' + +'7%'#242'FDC'#204'CCC'#198'DDD'#180'CCC'#144'CCC[AAA+III'#14'UUU'#3#0#0#0#1#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#128#128#128#2'@@@'#12'AAA''CCCWCCC'#140'GB?' + +#185'Z4!'#247'a6'#30#255'j?"'#255#151']2'#255#181't>'#255#194#133'F'#255#206 + +#149'M'#255#215#161'Q'#255#223#170'T'#255#228#178'W'#255#231#181'Y'#255#232 + +#183'Y'#255#233#185'Z'#255#234#185'Y'#255#234#186'Y'#255#234#186'Y'#255#234 + +#186'Z'#255#234#186'Z'#255#234#186'Z'#255#234#186'Z'#255#234#186'Z'#255#234 + +#186'Z'#255#234#186'Z'#255#234#186'Z'#255#234#186'Z'#255#234#186'Z'#255#234 + +#186'Z'#255#234#186'Z'#255#234#186'Z'#255#234#186'Z'#255#234#186'Z'#255#234 + +#186'Z'#255#234#186'Z'#255'C5'#26#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255 + +#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#1#1#1#255#20#16#8#255'K;'#29#255#189#150'I'#255#234#186'Z'#255#234#186 + +'Z'#255#234#186'Z'#255#234#186'Z'#255#234#186'Z'#255#234#186'Z'#255#234#186 + +'Z'#255#234#186'Z'#255#234#186'Z'#255#234#186'Z'#255#234#186'Y'#255#234#186 + +'Y'#255#234#185'Y'#255#233#185'Z'#255#232#183'Y'#255#230#181'X'#255#226#176 + +'W'#255#221#169'T'#255#213#159'O'#255#203#145'K'#255#190#129'D'#255#178'p=' + +#255#134'Q-'#255'g;"'#255'`4'#29#255'U7('#238'CCC'#202'DDD'#195'DDD'#173'BBB' + +#131'CCCL@@@ 999'#9#0#0#0#2#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#1'III'#7'BBB'#27'CC' + +'CEDDD|DDD'#170'V6%'#238'`5'#30#255'h<"'#255#145'Y1'#255#179's?'#255#192#132 + +'F'#255#205#148'M'#255#215#161'R'#255#222#171'U'#255#227#176'X'#255#230#181 + +'Z'#255#231#183'Z'#255#232#183'['#255#232#184'['#255#233#185'['#255#233#185 + +'['#255#233#185'['#255#233#185'['#255#233#185'['#255#233#185'['#255#233#185 + +'['#255#233#185'['#255#233#185'['#255#233#185'['#255#233#185'['#255#233#185 + +'['#255#233#185'['#255#233#185'['#255#233#185'['#255#233#185'['#255#233#185 + +'['#255#233#185'['#255#233#185'['#255#127'd1'#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#13#11#5 + +#255'N>'#31#255#193#153'L'#255#233#185'['#255#233#185'['#255#233#185'['#255 + +#233#185'['#255#233#185'['#255#233#185'['#255#233#185'['#255#233#185'['#255 + +#233#185'['#255#233#184'['#255#232#184'['#255#232#183'Z'#255#231#182'Z'#255 + +#229#180'Y'#255#226#175'X'#255#220#168'U'#255#213#158'R'#255#201#144'K'#255 + +#189#127'D'#255#175'n<'#255#128'N+'#255'e9 '#255'_3'#29#255'Q;1'#227'CCC'#201 + +'CCC'#191'CCC'#163'CCCrAAA;FFF'#22'333'#5#0#0#0#1#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#1'@@@'#4'<<<' + +#17'AAA3EEEhCCC'#156'R:/'#220'_3'#29#255'e: '#255#134'Q-'#255#178'p>'#255#190 + +#130'F'#255#203#145'M'#255#213#161'S'#255#221#170'W'#255#226#176'Z'#255#229 + +#180'Z'#255#230#182'\'#255#231#182'\'#255#231#183'\'#255#231#183'\'#255#231 + +#183'\'#255#231#183'\'#255#231#183'\'#255#231#183'\'#255#231#183'\'#255#231 + +#183'\'#255#231#183'\'#255#231#183'\'#255#231#183'\'#255#231#183'\'#255#231 + +#183'\'#255#231#183'\'#255#231#183'\'#255#231#183'\'#255#231#183'\'#255#231 + +#183'\'#255#231#183'\'#255#231#183'\'#255#180#142'G'#255#1#1#1#255#0#0#0#255 + +#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#15#12#6#255'VE"'#255#215#171'V'#255 + +#231#183'\'#255#231#183'\'#255#231#183'\'#255#231#183'\'#255#231#183'\'#255 + +#231#183'\'#255#231#183'\'#255#231#183'\'#255#231#183'\'#255#231#182'\'#255 + +#230#181'['#255#228#178'['#255#225#175'Y'#255#219#168'W'#255#211#156'Q'#255 + +#200#142'K'#255#187'|D'#255#172'k<'#255'wF('#255'c7 '#255'^1'#30#254'K@:'#214 + +'DDD'#199'CCC'#184'CCC'#148'AAA^GGG+NNN'#13'UUU'#3#0#0#0#0#0#0#0#0#0#0#0#0#0 + ,#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#2'MMM'#10'@' + +'@@$DDDSDDD'#139'L?8'#197'^1'#29#254'c7 '#255'wG)'#255#173'l<'#255#188#127'E' + +#255#201#144'N'#255#212#158'T'#255#220#169'X'#255#225#175'['#255#228#179'\' + +#255#229#180'\'#255#230#181']'#255#230#181']'#255#230#182']'#255#230#182']' + +#255#230#182']'#255#230#182']'#255#230#182']'#255#230#182']'#255#230#182']' + +#255#230#182']'#255#230#182']'#255#230#182']'#255#230#182']'#255#230#182']' + +#255#230#182']'#255#230#182']'#255#230#182']'#255#230#182']'#255#230#182']' + +#255#230#182']'#255#230#182']'#255#221#175'Y'#255#10#8#4#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#1#1#1#255'4' + +')'#21#255#184#146'J'#255#230#182']'#255#230#182']'#255#230#182']'#255#230 + +#182']'#255#230#182']'#255#230#182']'#255#230#182']'#255#230#181']'#255#229 + +#182']'#255#228#180']'#255#227#178'\'#255#224#174'['#255#218#166'W'#255#209 + +#155'R'#255#198#139'K'#255#184'zC'#255#162'd8'#255'l@$'#255'a5'#30#255'Z3 ' + +#249'FBA'#206'DDD'#196'CCC'#174'CCC'#129'BBBIFFF'#29'@@@'#8#0#0#0#1#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#1'333'#5'FF' + +'F'#22'BBB>CCCvFA?'#174'Z3'#31#248'`5'#30#255'l@$'#255#163'd9'#255#184'{D' + +#255#199#142'N'#255#210#156'T'#255#218#167'Y'#255#223#174'\'#255#226#177'^' + +#255#228#179'^'#255#228#179'^'#255#228#180'_'#255#228#180'_'#255#228#180'_' + +#255#228#180'_'#255#228#180'_'#255#228#180'_'#255#228#180'_'#255#228#180'_' + +#255#228#180'_'#255#228#180'_'#255#228#180'_'#255#228#180'_'#255#228#180'_' + +#255#228#180'_'#255#228#180'_'#255#228#180'_'#255#228#180'_'#255#228#180'_' + +#255#228#180'_'#255#228#180'_'#255#228#180'_'#255'bM)'#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#27#21#11#255#140'o;'#255#228#180'_'#255#228#180 + +'_'#255#228#180'_'#255#228#180'_'#255#228#180'_'#255#228#180'_'#255#228#180 + +'_'#255#228#179'^'#255#227#179'^'#255#226#176']'#255#222#172'['#255#216#164 + +'X'#255#207#152'R'#255#195#137'K'#255#181'tA'#255#149'Z3'#255'g<"'#255'_3'#29 + +#255'V6'''#239'CCC'#201'CCC'#190'CCC'#159'CCCkCCC5GGG'#18'@@@'#4#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#2'@@@'#12'CCC' + +'*DDD^DDD'#150'U6('#230'^2'#28#255'f:!'#255#149'Z3'#255#181'uB'#255#195#137 + +'K'#255#208#154'T'#255#216#165'Y'#255#221#172']'#255#225#176'^'#255#226#178 + +'_'#255#227#178'_'#255#227#178'_'#255#227#179'_'#255#227#179'_'#255#227#179 + +'_'#255#227#179'_'#255#227#179'_'#255#227#179'_'#255#227#179'_'#255#227#179 + +'_'#255#227#179'_'#255#227#179'_'#255#227#179'_'#255#227#179'_'#255#227#179 + +'_'#255#227#179'_'#255#227#179'_'#255#227#179'_'#255#227#179'_'#255#227#179 + +'_'#255#227#179'_'#255#227#179'_'#255#227#179'_'#255#13#10#6#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255'&'#30#16#255#208#164 + +'W'#255#227#179'_'#255#227#179'_'#255#227#179'_'#255#227#179'_'#255#227#178 + +'_'#255#227#178'_'#255#226#179'`'#255#226#177'_'#255#224#176'^'#255#220#170 + +'\'#255#214#162'X'#255#205#149'R'#255#191#131'I'#255#177'p?'#255#131'O.'#255 + +'c7 '#255']1'#29#255'N;3'#222'DDD'#199'DDD'#181'CCC'#140'DDDSDDD"999'#9#0#0#0 + +#1#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#1'+++'#6'@@@'#24 + +'EEECCCC~K=7'#193']0'#28#255'b6'#31#255#129'M,'#255#177'o@'#255#191#131'J' + +#255#204#149'S'#255#214#163'Z'#255#220#171']'#255#223#174'_'#255#225#176'`' + +#255#225#177'`'#255#226#177'`'#255#226#177'`'#255#226#177'`'#255#226#177'`' + +#255#226#177'`'#255#226#177'`'#255#226#177'`'#255#226#177'`'#255#226#177'`' + +#255#226#177'`'#255#226#177'`'#255#226#177'`'#255#226#177'`'#255#226#177'`' + ,#255#226#177'`'#255#226#177'`'#255#226#177'`'#255#226#177'`'#255#226#177'`' + +#255#226#177'`'#255#226#177'`'#255#226#177'`'#255#161'~D'#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#4#3#2 + +#255#134'i9'#255#226#177'`'#255#226#177'`'#255#226#177'`'#255#226#177'`'#255 + +#226#177'`'#255#225#178'`'#255#225#177'`'#255#224#176'_'#255#222#174'^'#255 + +#219#169']'#255#212#159'X'#255#200#144'Q'#255#187'~G'#255#170'j<'#255'qB%' + +#255'`5'#30#255'Z2'#31#250'FBA'#205'CCC'#193'DDD'#166'CCCsCCC9CCC'#19'@@@'#4 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#2'@@@'#12'AAA+BBB' + +'aDBB'#155'Y3!'#244'_3'#29#255'l?$'#255#167'f;'#255#186'}H'#255#200#144'R' + +#255#211#158'Y'#255#218#168']'#255#221#172'`'#255#223#174'a'#255#223#176'a' + +#255#224#176'b'#255#224#176'b'#255#224#176'b'#255#224#176'b'#255#224#176'b' + +#255#224#176'b'#255#224#176'b'#255#224#176'b'#255#224#176'b'#255#224#176'b' + +#255#224#176'b'#255#224#176'b'#255#224#176'b'#255#224#176'b'#255#224#176'b' + +#255#224#176'b'#255#224#176'b'#255#224#176'b'#255#224#176'b'#255#224#176'b' + +#255#224#176'b'#255#224#176'b'#255#224#176'b'#255'hR.'#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255'qY2'#255#224#176'b'#255#224#176'b'#255#224#176'b'#255#224#176 + +'b'#255#224#176'b'#255#224#176'b'#255#223#176'a'#255#223#174'`'#255#221#172 + +'_'#255#217#166']'#255#208#155'W'#255#196#139'O'#255#182'wE'#255#152'\5'#255 + +'e9!'#255'^2'#29#255'S7*'#233'DDD'#200'CCC'#183'DDD'#143'EEEUDDD"UUU'#9#0#0#0 + +#1#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#1'333'#5'@@@'#24'DDDDCCC~P8-' + +#211']0'#29#255'c8!'#255#144'V2'#255#180'uD'#255#196#138'P'#255#207#155'X' + +#255#215#165']'#255#220#171'`'#255#221#173'b'#255#222#174'a'#255#222#175'b' + +#255#222#175'b'#255#222#175'b'#255#222#175'b'#255#222#175'b'#255#222#175'b' + +#255#222#175'b'#255#222#175'b'#255#222#175'b'#255#222#175'b'#255#222#175'b' + +#255#222#175'b'#255#222#175'b'#255#222#175'b'#255#222#175'b'#255#222#175'b' + +#255#222#175'b'#255#222#175'b'#255#222#175'b'#255#222#175'b'#255#222#175'b' + +#255#222#175'b'#255#222#175'b'#255#222#175'b'#255'VD&'#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#1#1#0#255#166#132'J'#255#222#175'b'#255#222#175'b'#255#222#175 + +'b'#255#222#175'b'#255#222#175'b'#255#222#175'b'#255#222#174'a'#255#221#173 + +'a'#255#219#170'`'#255#213#163'\'#255#205#150'V'#255#192#132'M'#255#176'oA' + +#255'}K,'#255'a5'#31#255'\0'#28#254'I?;'#212'CCC'#194'DDD'#166'CCCrDDD8GGG' + +#18'@@@'#4#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#2'FFF'#11'DDD)BBB`G@<' + +#164'[1'#29#252'_3'#29#255'uD)'#255#174'l?'#255#189#130'L'#255#204#150'V'#255 + +#213#162'^'#255#217#168'`'#255#220#172'b'#255#221#173'b'#255#221#173'c'#255 + +#221#173'c'#255#221#173'c'#255#221#173'c'#255#221#173'c'#255#221#173'c'#255 + +#221#173'c'#255#221#173'c'#255#221#173'c'#255#221#173'c'#255#221#173'c'#255 + +#221#173'c'#255#221#173'c'#255#221#173'c'#255#221#173'c'#255#221#173'c'#255 + +#221#173'c'#255#221#173'c'#255#221#173'c'#255#221#173'c'#255#221#173'c'#255 + +#221#173'c'#255#221#173'c'#255#221#173'c'#255#221#173'c'#255'gQ.'#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + ,#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#8#6#4#255#207#163']'#255#221#173'c'#255 + +#221#173'c'#255#221#173'c'#255#221#173'c'#255#221#173'c'#255#221#173'c'#255 + +#221#172'b'#255#219#171'b'#255#217#167'`'#255#211#159'['#255#200#145'T'#255 + +#185'{H'#255#164'd;'#255'h<#'#255'^1'#29#255'X3#'#244'DDD'#200'CCC'#183'DDD' + +#142'DDDSFFF!@@@'#8#0#0#0#1#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'@@@'#4'III'#21'EEE?DD' + +'D|S5'''#222'\1'#28#255'c8!'#255#158'_8'#255#183'yH'#255#198#142'S'#255#209 + +#158'\'#255#215#166'`'#255#218#170'b'#255#219#171'c'#255#219#171'd'#255#219 + +#172'd'#255#219#172'd'#255#219#172'd'#255#219#172'd'#255#219#172'd'#255#219 + +#172'd'#255#219#172'd'#255#219#172'd'#255#219#172'd'#255#219#172'd'#255#219 + +#172'd'#255#219#172'd'#255#219#172'd'#255#219#172'd'#255#219#172'd'#255#219 + +#172'd'#255#219#172'd'#255#219#172'd'#255#219#172'd'#255#219#172'd'#255#219 + +#172'd'#255#219#172'd'#255#219#172'd'#255#219#172'd'#255#219#172'd'#255#213 + +#168'b'#255#3#3#1#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255'M<#'#255#219#172 + +'d'#255#219#172'd'#255#219#172'd'#255#219#172'd'#255#219#172'd'#255#219#172 + +'d'#255#219#171'd'#255#219#170'c'#255#217#168'b'#255#214#164'`'#255#207#153 + +'Z'#255#194#136'P'#255#178'rD'#255#139'R1'#255'a4'#31#255'\0'#28#255'L<5'#219 + +'CCC'#193'DDD'#164'CCCoCCC5@@@'#16'UUU'#3#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#1'@@@'#8 + +'BBB#CCCWHA='#158'\0'#28#253'_3'#29#255'~I+'#255#175'nB'#255#191#133'O'#255 + +#205#151'Z'#255#213#163'a'#255#216#167'c'#255#217#169'c'#255#218#170'd'#255 + +#218#170'd'#255#218#170'd'#255#218#170'd'#255#218#170'd'#255#218#170'd'#255 + +#218#170'd'#255#218#170'd'#255#218#170'd'#255#218#170'd'#255#218#170'd'#255 + +#218#170'd'#255#218#170'd'#255#218#170'd'#255#218#170'd'#255#218#170'd'#255 + +#218#170'd'#255#218#170'd'#255#218#170'd'#255#218#170'd'#255#218#170'd'#255 + +#218#170'd'#255#218#170'd'#255#218#170'd'#255#218#170'd'#255#218#170'd'#255 + +#218#170'd'#255#218#170'd'#255'YF)'#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#15#12#7#255#218#170'd'#255#218#170'd'#255#218#170'd'#255#218#170'd'#255 + +#218#170'd'#255#218#170'd'#255#218#170'd'#255#218#169'c'#255#217#168'c'#255 + +#215#166'b'#255#211#160'_'#255#201#147'W'#255#187#127'L'#255#169'h>'#255'l=$' + +#255'^1'#29#255'W3"'#244'DDD'#199'DDD'#180'DDD'#136'DDDKBBB'#27'UUU'#6#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0'UUU'#3'DDD'#15'EEE4BBBpS6)'#215'\1'#28#255'b7!'#255#158'_9' + +#255#184'{J'#255#199#144'W'#255#209#158'_'#255#214#165'c'#255#216#168'd'#255 + +#217#168'd'#255#217#168'd'#255#217#168'd'#255#217#168'd'#255#217#168'd'#255 + +#217#168'd'#255#217#168'd'#255#217#168'd'#255#217#168'd'#255#217#168'd'#255 + +#217#168'd'#255#217#168'd'#255#217#168'd'#255#217#168'd'#255#217#168'd'#255 + +#217#168'd'#255#217#168'd'#255#217#168'd'#255#217#168'd'#255#217#168'd'#255 + +#217#168'd'#255#217#168'd'#255#217#168'd'#255#217#168'd'#255#217#168'd'#255 + +#217#168'd'#255#217#168'd'#255#217#168'd'#255#217#168'd'#255#217#168'd'#255 + +'YD)'#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#189#147'W'#255#217#168'd' + +#255#217#168'd'#255#217#168'd'#255#217#168'd'#255#217#168'd'#255#217#168'd' + +#255#217#168'd'#255#216#168'd'#255#215#167'c'#255#213#164'a'#255#207#154']' + +#255#195#138'S'#255#179'tF'#255#139'R1'#255'`5'#30#255'\0'#28#255'K=7'#216'D' + +'DD'#191'DDD'#157'CCCcAAA+FFF'#11#0#0#0#1#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + ,#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'+++'#6'EEE'#26'BBBIE?=' + +#144'Z0'#28#252'^2'#29#255'zF*'#255#174'mB'#255#192#135'R'#255#205#152'\'#255 + +#211#161'b'#255#214#165'd'#255#215#166'd'#255#215#166'd'#255#215#166'd'#255 + +#215#166'd'#255#215#166'd'#255#215#166'd'#255#215#166'd'#255#215#166'd'#255 + +#215#166'd'#255#215#166'd'#255#215#166'd'#255#215#166'd'#255#215#166'd'#255 + +#215#166'd'#255#215#166'd'#255#215#166'd'#255#215#166'd'#255#215#166'd'#255 + +#215#166'd'#255#215#166'd'#255#215#166'd'#255#215#166'd'#255#215#166'd'#255 + +#215#166'd'#255#215#166'd'#255#215#166'd'#255#215#166'd'#255#215#166'd'#255 + +#215#166'd'#255#215#166'd'#255#215#166'd'#255#215#166'd'#255'jR1'#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255'fN/'#255#215#166'd'#255#215#166'd'#255#215#166'd' + +#255#215#166'd'#255#215#166'd'#255#215#166'd'#255#215#166'd'#255#215#166'd' + +#255#215#167'e'#255#214#164'c'#255#210#159'a'#255#202#148'Z'#255#187#128'N' + +#255#168'f='#255'i;#'#255'\1'#28#255'V3#'#242'CCC'#197'DDD'#173'BBB{FFF>@@@' + +#20'@@@'#4#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#1'MMM'#10'FFF(CCC_R6*'#206'\0'#28#255'`5'#31#255#154'\8' + +#255#182'yJ'#255#199#144'Y'#255#208#156'`'#255#212#163'd'#255#213#165'd'#255 + +#214#165'e'#255#214#165'e'#255#214#165'e'#255#214#165'e'#255#214#165'e'#255 + +#214#165'e'#255#214#165'e'#255#214#165'e'#255#214#165'e'#255#214#165'e'#255 + +#214#165'e'#255#214#165'e'#255#214#165'e'#255#214#165'e'#255#214#165'e'#255 + +#214#165'e'#255#214#165'e'#255#214#165'e'#255#214#165'e'#255#214#165'e'#255 + +#214#165'e'#255#214#165'e'#255#214#165'e'#255#214#165'e'#255#214#165'e'#255 + +#214#165'e'#255#214#165'e'#255#214#165'e'#255#214#165'e'#255#214#165'e'#255 + +#214#165'e'#255#214#165'e'#255#214#165'e'#255#135'h@'#255#2#1#1#255#0#0#0#255 + +#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255'b' + +'L/'#255#214#165'e'#255#214#165'e'#255#214#165'e'#255#214#165'e'#255#214#165 + +'e'#255#214#165'e'#255#214#165'e'#255#214#165'e'#255#213#165'e'#255#213#164 + +'d'#255#211#161'c'#255#206#154'^'#255#194#139'U'#255#177'sF'#255#135'P/'#255 + +'^3'#29#255'[/'#27#255'J>9'#213'DDD'#185'CCC'#144'DDDSHHH III'#7#0#0#0#1#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'UUU'#3 + +'<<<'#17'DDD8DBAyZ0'#29#248'\1'#28#255'uB'''#255#172'lA'#255#190#132'Q'#255 + +#203#151'^'#255#209#160'c'#255#211#162'e'#255#212#163'e'#255#212#163'e'#255 + +#212#163'e'#255#212#163'e'#255#212#163'e'#255#212#163'e'#255#212#163'e'#255 + +#212#163'e'#255#212#163'e'#255#212#163'e'#255#212#163'e'#255#212#163'e'#255 + +#212#163'e'#255#212#163'e'#255#212#163'e'#255#212#163'e'#255#212#163'e'#255 + +#212#163'e'#255#212#163'e'#255#212#163'e'#255#212#163'e'#255#212#163'e'#255 + +#212#163'e'#255#212#163'e'#255#212#163'e'#255#212#163'e'#255#212#163'e'#255 + +#212#163'e'#255#212#163'e'#255#212#163'e'#255#212#163'e'#255#212#163'e'#255 + +#212#163'e'#255#212#163'e'#255#212#163'e'#255#156'xK'#255#1#0#0#255#0#0#0#255 + +#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255'jQ2'#255#212 + +#163'e'#255#212#163'e'#255#212#163'e'#255#212#163'e'#255#212#163'e'#255#212 + +#163'e'#255#212#163'e'#255#212#163'e'#255#212#163'e'#255#212#162'e'#255#211 + +#162'd'#255#208#158'b'#255#200#147'['#255#186'~M'#255#165'd<'#255'd8!'#255'\' + +'0'#28#255'T5'''#237'CCC'#193'DDD'#162'CCCjCCC.@@@'#12#0#0#0#2#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'333'#5'GGG'#25'BB' + +'BIN:1'#174'[/'#27#255'^2'#29#255#145'T3'#255#180'vI'#255#196#142'Y'#255#206 + +#155'a'#255#209#161'e'#255#211#162'e'#255#211#162'e'#255#211#162'e'#255#211 + +#162'e'#255#211#162'e'#255#211#162'e'#255#211#162'e'#255#211#162'e'#255#211 + +#162'e'#255#211#162'e'#255#211#162'e'#255#211#162'e'#255#211#162'e'#255#211 + ,#162'e'#255#211#162'e'#255#211#162'e'#255#211#162'e'#255#211#162'e'#255#211 + +#162'e'#255#211#162'e'#255#211#162'e'#255#211#162'e'#255#211#162'e'#255#211 + +#162'e'#255#211#162'e'#255#211#162'e'#255#211#162'e'#255#211#162'e'#255#211 + +#162'e'#255#211#162'e'#255#211#162'e'#255#211#162'e'#255#211#162'e'#255#211 + +#162'e'#255#211#162'e'#255#211#162'e'#255#211#162'e'#255'O=&'#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255'sX7'#255#211 + +#162'e'#255#211#162'e'#255#211#162'e'#255#211#162'e'#255#211#162'e'#255#211 + +#162'e'#255#211#162'e'#255#211#162'e'#255#211#162'e'#255#211#162'e'#255#210 + +#161'f'#255#209#159'd'#255#204#153'`'#255#192#135'U'#255#175'pE'#255'~H+'#255 + +']0'#29#255'Z0'#28#253'FBA'#201'DDD'#176'CCC~FFF>CCC'#19'@@@'#4#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#1'999'#9'EEE%CCC[V3' + +'$'#222'\0'#27#255'f7!'#255#167'd>'#255#187#128'Q'#255#200#148'^'#255#207#156 + +'d'#255#209#159'e'#255#209#160'e'#255#209#160'e'#255#209#160'e'#255#209#160 + +'e'#255#209#160'e'#255#209#160'e'#255#209#160'e'#255#209#160'e'#255#209#160 + +'e'#255#209#160'e'#255#209#160'e'#255#209#160'e'#255#209#160'e'#255#209#160 + +'e'#255#209#160'e'#255#209#160'e'#255#151'tI'#255'2&'#25#255#27#21#13#255#15 + +#12#7#255#7#5#3#255#7#5#3#255' '#25#16#255'P='''#255#151'tI'#255#209#160'e' + +#255#209#160'e'#255#209#160'e'#255#209#160'e'#255#209#160'e'#255#209#160'e' + +#255#209#160'e'#255#209#160'e'#255#209#160'e'#255#209#160'e'#255#209#160'e' + +#255#209#160'e'#255#209#160'e'#255#6#5#3#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#146'pF'#255#209#160'e'#255#209#160'e'#255 + +#209#160'e'#255#209#160'e'#255#209#160'e'#255#209#160'e'#255#209#160'e'#255 + +#209#160'e'#255#209#160'e'#255#209#160'e'#255#209#160'e'#255#209#159'e'#255 + +#206#155'c'#255#198#143'['#255#182'zM'#255#151'Y6'#255'^3'#29#255'[/'#27#255 + +'N:1'#222'DDD'#185'DDD'#142'DDDOIII'#28'+++'#6#0#0#0#1#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#2';;;'#13'DDD1F@=x[/'#28#253'\1'#28 + +#255'~G+'#255#174'oE'#255#193#137'X'#255#203#151'b'#255#207#156'e'#255#207 + +#158'f'#255#208#158'f'#255#208#158'f'#255#208#158'f'#255#208#158'f'#255#208 + +#158'f'#255#208#158'f'#255#208#158'f'#255#208#158'f'#255#208#158'f'#255#208 + +#158'f'#255#208#158'f'#255#208#158'f'#255#208#158'f'#255#208#158'f'#255'x[;' + +#255#15#12#8#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255 + +#0#0#0#255#0#0#0#255#0#0#0#255#4#3#2#255'bJ0'#255#208#158'f'#255#208#158'f' + +#255#208#158'f'#255#208#158'f'#255#208#158'f'#255#208#158'f'#255#208#158'f' + +#255#208#158'f'#255#208#158'f'#255#208#158'f'#255#208#158'f'#255'3'''#25#255 + +#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#2#2#1#255#208#158'f' + +#255#208#158'f'#255#208#158'f'#255#208#158'f'#255#208#158'f'#255#208#158'f' + +#255#208#158'f'#255#208#158'f'#255#208#158'f'#255#208#158'f'#255#208#158'f' + +#255#208#158'f'#255#207#158'e'#255#206#156'd'#255#201#149'_'#255#189#131'T' + +#255#169'h@'#255'j:#'#255'\0'#28#255'V3#'#242'DDD'#191'CCC'#156'BBB`AAA''333' + +#10#0#0#0#1#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'@@@'#4'C' + +'CC'#19'EEE?Q7+'#179'[/'#27#255'^1'#29#255#152'X6'#255#181'yM'#255#197#144']' + +#255#204#153'c'#255#206#155'f'#255#206#156'e'#255#206#156'e'#255#206#156'e' + +#255#206#156'e'#255#206#156'e'#255#206#156'e'#255#206#156'e'#255#206#156'e' + +#255#206#156'e'#255#206#156'e'#255#206#156'e'#255#206#156'e'#255#206#156'e' + +#255#202#154'c'#255'6)'#27#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#14#10#7#255#178#135'W'#255#206#156'e'#255#206#156'e'#255#206#156'e' + +#255#206#156'e'#255#206#156'e'#255#206#156'e'#255#206#156'e'#255#206#156'e' + +#255#206#156'e'#255'WB+'#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + ,#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#29#22#14#255#206#156'e'#255#206#156'e'#255#206#156'e'#255#206#156'e' + +#255#206#156'e'#255#206#156'e'#255#206#156'e'#255#206#156'e'#255#206#156'e' + +#255#206#156'e'#255#206#156'e'#255#206#156'e'#255#206#156'e'#255#205#156'e' + +#255#203#151'c'#255#194#139'Z'#255#176'qH'#255#131'K-'#255'\1'#28#255'[/'#27 + +#255'HA='#204'DDD'#169'DDDqEEE4III'#14#128#128#128#2#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#1'+++'#6'BBB'#27'EEENW2!'#228'[/'#27#255'i9!' + +#255#168'e?'#255#187#130'T'#255#200#147'`'#255#203#153'e'#255#205#154'e'#255 + +#205#154'e'#255#205#154'e'#255#205#154'e'#255#205#154'e'#255#205#154'e'#255 + +#205#154'e'#255#205#154'e'#255#205#154'e'#255#205#154'e'#255#205#154'e'#255 + +#205#154'e'#255#205#154'e'#255#199#150'a'#255#19#14#9#255#0#0#0#255#0#0#0#255 + +#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#7#6#4#255#178#133'W' + +#255#205#154'e'#255#205#154'e'#255#205#154'e'#255#205#154'e'#255#205#154'e' + +#255#205#154'e'#255#205#154'e'#255#205#154'e'#255'S>)'#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#128'a?'#255#205#154'e'#255#205#154'e' + +#255#205#154'e'#255#205#154'e'#255#205#154'e'#255#205#154'e'#255#205#154'e' + +#255#205#154'e'#255#205#154'e'#255#205#154'e'#255#205#154'e'#255#205#154'e' + +#255#205#154'e'#255#204#154'e'#255#203#152'd'#255#197#145'^'#255#182'zO'#255 + +#157'Z8'#255']1'#29#255'[/'#27#255'P9.'#226'CCC'#179'CCC'#129'CCCA@@@'#20'@@' + +'@'#4#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#1'999'#9'EEE%EA?' + +'b[/'#27#253'\0'#27#255#127'F*'#255#173'nG'#255#191#136'Z'#255#200#149'c'#255 + +#202#152'e'#255#202#152'e'#255#202#153'e'#255#202#153'e'#255#202#153'e'#255 + +#202#153'e'#255#202#153'e'#255#202#153'e'#255#202#153'e'#255#202#153'e'#255 + +#202#153'e'#255#202#153'e'#255#202#153'e'#255#202#153'e'#255#31#24#16#255#0#0 + +#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255 + +#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#11#8#6#255#200#151'e'#255#202#153'e'#255#202#153'e'#255#202 + +#153'e'#255#202#153'e'#255#202#153'e'#255#202#153'e'#255#202#153'e'#255'O;''' + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255''''#29#19#255#202#153'e'#255 + +#202#153'e'#255#202#153'e'#255#202#153'e'#255#202#153'e'#255#202#153'e'#255 + +#202#153'e'#255#202#153'e'#255#202#153'e'#255#202#153'e'#255#202#153'e'#255 + +#202#153'e'#255#202#153'e'#255#202#153'e'#255#202#152'e'#255#202#151'd'#255 + +#199#147'b'#255#188#130'U'#255#168'e@'#255'k:"'#255'[/'#27#255'V3$'#241'CCC' + +#186'BBB'#142'EEENBBB'#27'+++'#6#0#0#0#1#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#2'@@@'#12'DDD-O:0'#146'[/'#27#255'\0'#28#255#145'R2'#255#179'wM' + +#255#194#141'^'#255#200#148'c'#255#201#150'e'#255#201#150'e'#255#201#150'e' + +#255#201#150'e'#255#201#150'e'#255#201#150'e'#255#201#150'e'#255#201#150'e' + +#255#201#150'e'#255#201#150'e'#255#201#150'e'#255#201#150'e'#255#201#150'e' + +#255';,'#30#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255'S>*'#255#201#150'e' + +#255#201#150'e'#255#201#150'e'#255#201#150'e'#255#201#150'e'#255#201#150'e' + +#255#201#150'e'#255'K8&'#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#29#22#14#255 + +#184#138']'#255#201#150'e'#255#201#150'e'#255#201#150'e'#255#201#150'e'#255 + ,#201#150'e'#255#201#150'e'#255#201#150'e'#255#201#150'e'#255#201#150'e'#255 + +#201#150'e'#255#201#150'e'#255#201#150'e'#255#201#150'e'#255#201#150'e'#255 + +#201#150'e'#255#200#149'd'#255#199#148'c'#255#191#136'['#255#173'mG'#255'}D(' + +#255'\0'#27#255'Z0'#28#253'DBB'#192'CCC'#152'DDDZBBB#@@@'#8#0#0#0#1#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#128#128#128#2'III'#14'CCC5T5'''#190'[/'#27#255 + +'_2'#29#255#162'^:'#255#184'}S'#255#195#142'`'#255#198#147'd'#255#199#148'd' + +#255#199#148'd'#255#199#148'd'#255#199#148'd'#255#199#148'd'#255#199#148'd' + +#255#199#148'd'#255#199#148'd'#255#199#148'd'#255#199#148'd'#255#199#148'd' + +#255#199#148'd'#255#147'mJ'#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#3#2#1#255#195#144'b'#255#199#148'd'#255#199#148'd'#255#199#148'd'#255 + +#199#148'd'#255#199#148'd'#255#199#148'd'#255'H6$'#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#3#2#1#255#23#17#12 + +#255'qT8'#255#199#148'd'#255#199#148'd'#255#199#148'd'#255#199#148'd'#255#199 + +#148'd'#255#199#148'd'#255#199#148'd'#255#199#148'd'#255#199#148'd'#255#199 + +#148'd'#255#199#148'd'#255#199#148'd'#255#199#148'd'#255#199#148'd'#255#199 + +#148'd'#255#199#148'd'#255#199#148'd'#255#199#148'd'#255#198#146'c'#255#193 + +#140'^'#255#178'uN'#255#143'O1'#255'\0'#28#255'[/'#27#255'J=7'#208'CCC'#161 + +'DDDfAAA+FFF'#11#0#0#0#2#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'UUU'#3'<<<' + +#17'CCC=X1 '#227'[/'#27#255'm:"'#255#167'eA'#255#187#130'X'#255#195#143'a' + +#255#196#144'c'#255#197#145'c'#255#197#145'c'#255#197#145'c'#255#197#145'c' + +#255#197#145'c'#255#197#145'c'#255#197#145'c'#255#197#145'c'#255#197#145'c' + +#255#197#145'c'#255#197#145'c'#255#197#145'c'#255#19#14#10#255#0#0#0#255#0#0 + +#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255 + +#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#135'cD'#255#197#145'c'#255#197 + +#145'c'#255#197#145'c'#255#197#145'c'#255#197#145'c'#255#197#145'c'#255'I5$' + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#19#14#10#255'4&'#26#255'cI2'#255 + +#161'vP'#255#197#145'c'#255#197#145'c'#255#197#145'c'#255#197#145'c'#255#197 + +#145'c'#255#197#145'c'#255#197#145'c'#255#197#145'c'#255#197#145'c'#255#197 + +#145'c'#255#197#145'c'#255#197#145'c'#255#197#145'c'#255#197#145'c'#255#197 + +#145'c'#255#197#145'c'#255#197#145'c'#255#197#145'c'#255#197#145'c'#255#197 + +#145'c'#255#197#145'b'#255#196#144'c'#255#194#140'`'#255#182'|S'#255#159'\:' + +#255']2'#28#255'[/'#27#255'Q8-'#226'DDD'#168'DDDqAAA3NNN'#13#128#128#128#2#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'@@@'#4':::'#22'G@/[/'#27 + +#254'[/'#27#255'}A&'#255#167'gD'#255#180'zW'#255#181'|Y'#255#181'|Y'#255#181 + +'|Y'#255#181'|Y'#255#181'|Y'#255#181'|Y'#255#181'|Y'#255#181'|Y'#255#181'|Y' + +#255#181'|Y'#255#181'|Y'#255#181'|Y'#255#136']C'#255#0#0#0#255#0#0#0#255#0#0 + +#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255 + +#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#19#13#9#255#151'gJ'#255#181'|Y'#255#181'|Y'#255#181 + +'|Y'#255#181'|Y'#255#181'|Y'#255#181'|Y'#255#181'|Y'#255#181'|Y'#255#181'|Y' + +#255#181'|Y'#255#181'|Y'#255#181'|Y'#255#181'|Y'#255#171'vU'#255'1"'#24#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#1#0#0#255'}V>'#255 + +#181'|Y'#255#181'|Y'#255#181'|Y'#255#181'|Y'#255#181'|Y'#255#181'|Y'#255#181 + +'|Y'#255#181'|Y'#255#181'|Y'#255#181'|Y'#255#181'|Y'#255#181'|Y'#255#181'|Y' + +#255#181'|Y'#255#181'|Y'#255#181'|Y'#255#181'|Y'#255#181'|Y'#255#181'|Y'#255 + +#181'|Y'#255#181'|Y'#255#181'|Y'#255#181'|Y'#255#181'|Y'#255#181'|Y'#255#181 + +'|Y'#255#181'|Y'#255#181'|Y'#255#181'|Y'#255#181'|Y'#255#181'|Y'#255#181'|Y' + +#255#181'|Y'#255#181'|Y'#255#178'wT'#255#161'];'#255'k8 '#255'[/'#27#255'V3#' + +#238'DDD'#151'CCCWFFF!@@@'#8#0#0#0#1#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#2'FFF'#11 + +'K:3?[/'#27#255'[/'#27#255#131'F*'#255#169'iH'#255#179'xV'#255#180'zW'#255 + +#180'{W'#255#180'{W'#255#180'{W'#255#180'{W'#255#180'{W'#255#180'{W'#255#180 + +'{W'#255#180'{W'#255#180'{W'#255#180'{W'#255#180'{W'#255'<)'#29#255#0#0#0#255 + +#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#1#1#1#255'O6&'#255#180'{W'#255#180'{W'#255#180'{W'#255#180 + +'{W'#255#180'{W'#255#180'{W'#255#180'{W'#255#180'{W'#255#180'{W'#255#180'{W' + +#255#180'{W'#255#180'{W'#255#180'{W'#255#180'{W'#255#180'{W'#255#180'{W'#255 + +#180'{W'#255#142'aE'#255#27#19#13#255#2#1#1#255#0#0#0#255#0#0#0#255#0#0#0#255 + ,#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#8#5#4#255 + +#135']A'#255#180'{W'#255#180'{W'#255#180'{W'#255#180'{W'#255#180'{W'#255#180 + +'{W'#255#180'{W'#255#180'{W'#255#180'{W'#255'pL6'#255'+'#29#20#255'('#28#19 + +#255'*'#28#20#255'+'#29#21#255'-'#30#21#255'fF2'#255#180'{W'#255#180'{W'#255 + +#180'{W'#255#180'{W'#255#180'{W'#255#180'{W'#255#180'{W'#255#180'{W'#255#180 + +'{W'#255#180'{W'#255#180'{W'#255#180'{W'#255#180'{W'#255#180'{W'#255#180'{W' + +#255#180'{W'#255#180'{W'#255#180'{W'#255#180'zX'#255#178'vU'#255#163'_>'#255 + +'r<"'#255'[/'#27#255'X2!'#243'CCC'#152'BBBYDDD"@@@'#8#0#0#0#1#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#2'FFF'#11'N8.J[/'#27#255'[/'#27#255#135'H,'#255#170'kI'#255 + +#178'wV'#255#179'yX'#255#179'yX'#255#179'yX'#255#179'yX'#255#179'yX'#255#179 + +'yX'#255#179'yX'#255#179'yX'#255#179'yX'#255#179'yX'#255#179'yX'#255#179'yX' + +#255#16#11#8#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255 + +#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#19#13#10#255#150'fJ'#255#179'yX'#255#179 + +'yX'#255#179'yX'#255#179'yX'#255#179'yX'#255#179'yX'#255#179'yX'#255#179'yX' + +#255#179'yX'#255#179'yX'#255#179'yX'#255#179'yX'#255#179'yX'#255#179'yX'#255 + +#179'yX'#255#179'yX'#255#179'yX'#255#179'yX'#255#179'yX'#255#179'yX'#255#179 + +'yX'#255'~V>'#255'=)'#30#255#19#13#9#255#1#1#1#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255'$'#24#17#255#172'uT'#255#179'yX'#255#179'yX'#255#179'yX' + +#255#179'yX'#255#179'yX'#255#179'yX'#255#179'yX'#255#158'kN'#255'=)'#30#255#6 + +#4#3#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#6#4#3#255'?+'#31#255#164'oP'#255#179'yX'#255#179'yX'#255#179'yX'#255#179 + +'yX'#255#179'yX'#255#179'yX'#255#179'yX'#255#179'yX'#255#179'yX'#255#179'yX' + +#255#179'yX'#255#179'yX'#255#179'yX'#255#179'yX'#255#179'yX'#255#179'yX'#255 + +#177'uU'#255#164'b@'#255'v?%'#255'[/'#27#255'Y1'#31#246'CCC'#152'BBBYDDD"@@@' + +#8#0#0#0#1#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#1'FFF'#11'Q7+U[/'#27#255'\0'#28#255 + +#139'J-'#255#171'lL'#255#177'wW'#255#178'wV'#255#178'wV'#255#178'wV'#255#178 + +'wV'#255#178'wV'#255#178'wV'#255#178'wV'#255#178'wV'#255#178'wV'#255#178'wV' + +#255#178'wV'#255#172'sT'#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#1#1#1#255'O5&'#255#178'wV'#255#178'wV' + +#255#178'wV'#255#178'wV'#255#178'wV'#255#178'wV'#255#178'wV'#255#178'wV'#255 + +#178'wV'#255#178'wV'#255#178'wV'#255#178'wV'#255#178'wV'#255#178'wV'#255#178 + +'wV'#255#178'wV'#255#178'wV'#255#178'wV'#255#178'wV'#255#178'wV'#255#178'wV' + +#255#178'wV'#255#178'wV'#255#178'wV'#255#178'wV'#255#178'wV'#255#176'wV'#255 + +'vO9'#255'7%'#27#255#16#10#8#255#1#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0 + +#0#255#0#0#0#255#11#8#6#255'9&'#28#255#137'\C'#255#178'wV'#255#178'wV'#255 + +#178'wV'#255#178'wV'#255#178'wV'#255#178'wV'#255#178'wV'#255#178'wV'#255'M3%' + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#1#0#0#255'4"'#25#255#178'wV' + +#255#178'wV'#255#178'wV'#255#178'wV'#255#178'wV'#255#178'wV'#255#178'wV'#255 + +#178'wV'#255#178'wV'#255#178'wV'#255#178'wV'#255#178'wV'#255#178'wV'#255#178 + +'wV'#255#178'wV'#255#176'tT'#255#165'cC'#255'yA'''#255'[/'#27#255'Z0'#29#250 + +'DDD'#150'CCCWFFF!III'#7#0#0#0#1#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#1'MMM'#10'R4' + +'''^[/'#27#255'\0'#28#255#142'M.'#255#171'nN'#255#177'uV'#255#177'wX'#255#177 + +'wX'#255#177'wX'#255#177'wX'#255#177'wX'#255#177'wX'#255#177'wX'#255#177'wX' + +#255#177'wX'#255#177'wX'#255#177'wX'#255'gF3'#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#23#16#12#255#152'fK'#255#177 + +'wX'#255#177'wX'#255#177'wX'#255#177'wX'#255#177'wX'#255#177'wX'#255#177'wX' + +#255#177'wX'#255#177'wX'#255#177'wX'#255#177'wX'#255#177'wX'#255#177'wX'#255 + +#177'wX'#255#177'wX'#255#177'wX'#255#177'wX'#255#177'wX'#255#177'wX'#255#177 + +'wX'#255#177'wX'#255#177'wX'#255#177'wX'#255#177'wX'#255#177'wX'#255#177'wX' + +#255#177'wX'#255#177'wX'#255#177'wX'#255#177'wX'#255#177'wX'#255#173'uV'#255 + +#136'\D'#255#133'YB'#255#131'XA'#255#128'V@'#255#153'gL'#255#177'wX'#255#177 + +'wX'#255#177'wX'#255#177'wX'#255#177'wX'#255#177'wX'#255#177'wX'#255#177'wX' + +#255#177'wX'#255#177'wX'#255'S8)'#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255 + +#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255'"'#23#17#255#175'wX'#255#177'wX'#255#177 + +'wX'#255#177'wX'#255#177'wX'#255#177'wX'#255#177'wX'#255#177'wX'#255#177'wX' + +#255#177'wX'#255#177'wX'#255#177'wX'#255#177'wX'#255#177'wX'#255#175'tU'#255 + +#166'eE'#255'}B)'#255'\0'#28#255'[/'#28#253'CCC'#148'CCCTBBB'#31'III'#7#0#0#0 + ,#1#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#1'999'#9'V4%h[/'#27#255'\0'#28#255#145'O0' + +#255#171'mN'#255#175'sU'#255#175'uW'#255#175'uW'#255#175'uW'#255#175'uW'#255 + +#175'uW'#255#175'uW'#255#175'uW'#255#175'uW'#255#175'uW'#255#175'uW'#255#175 + +'uW'#255'*'#29#21#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#2 + +#1#1#255'X;,'#255#175'uW'#255#175'uW'#255#175'uW'#255#175'uW'#255#175'uW'#255 + +#175'uW'#255#175'uW'#255#175'uW'#255#175'uW'#255#175'uW'#255#175'uW'#255#175 + +'uW'#255#175'uW'#255#175'uW'#255#175'uW'#255#175'uW'#255#175'uW'#255#175'uW' + +#255#175'uW'#255#175'uW'#255#175'uW'#255#175'uW'#255#175'uW'#255#175'uW'#255 + +#175'uW'#255#175'uW'#255#175'uW'#255#175'uW'#255#175'uW'#255#175'uW'#255#175 + +'uW'#255#175'uW'#255#175'uW'#255#175'uW'#255#175'uW'#255#175'uW'#255#175'uW' + +#255#175'uW'#255#175'uW'#255#175'uW'#255#175'uW'#255#175'uW'#255#175'uW'#255 + +#175'uW'#255#175'uW'#255#175'uW'#255#175'uW'#255#175'uW'#255'^?/'#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255'$'#24#18#255#175'uW'#255#175'uW'#255#175'uW'#255#175'uW'#255 + +#175'uW'#255#175'uW'#255#175'uW'#255#175'uW'#255#175'uW'#255#175'uW'#255#175 + +'uW'#255#175'uW'#255#175'uW'#255#175'sT'#255#166'eE'#255#128'D*'#255'\0'#28 + +#255'[/'#27#255'ECB'#149'CCCP@@@'#28'UUU'#6#0#0#0#1#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#1'@@@'#8'W3#q[/'#27#255'\1'#29#255#150'Q1'#255#171'mN'#255#174'sU'#255 + +#175'uV'#255#175'uV'#255#175'uV'#255#175'uV'#255#175'uV'#255#175'uV'#255#175 + +'uV'#255#175'uV'#255#175'uV'#255#175'uV'#255#175'uV'#255#15#10#8#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#4#3#2#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#29#19#14#255#156'iM'#255#175'uV'#255 + +#175'uV'#255#175'uV'#255#175'uV'#255#175'uV'#255#175'uV'#255#175'uV'#255#175 + +'uV'#255#175'uV'#255#175'uV'#255#175'uV'#255#175'uV'#255#175'uV'#255#175'uV' + +#255#175'uV'#255#175'uV'#255#175'uV'#255#175'uV'#255#175'uV'#255#175'uV'#255 + +#175'uV'#255#175'uV'#255#175'uV'#255#175'uV'#255#175'uV'#255#175'uV'#255#175 + +'uV'#255#175'uV'#255#175'uV'#255#175'uV'#255#175'uV'#255#175'uV'#255#175'uV' + +#255#175'uV'#255#175'uV'#255#175'uV'#255#175'uV'#255#175'uV'#255#175'uV'#255 + +#175'uV'#255#175'uV'#255#175'uV'#255#175'uV'#255#175'uV'#255#175'uV'#255#175 + +'uV'#255#175'uV'#255#175'uV'#255#175'uV'#255#11#7#6#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255'sM9'#255#175'uV'#255#175'uV'#255#175'uV'#255#175'uV'#255#175'uV'#255 + +#175'uV'#255#175'uV'#255#175'uV'#255#175'uV'#255#175'uV'#255#175'uV'#255#175 + +'tV'#255#174'rS'#255#167'fG'#255#131'G,'#255'\0'#28#255'[/'#27#255'GA?'#150 + +'CCCLGGG'#25'333'#5#0#0#0#1#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#1'III'#7'W3#k[/'#27 + +#255'\1'#29#255#149'P2'#255#169'lM'#255#174'qT'#255#175'tV'#255#175'tV'#255 + +#175'tV'#255#175'tV'#255#175'tV'#255#175'tV'#255#175'tV'#255#175'tV'#255#175 + +'tV'#255#175'tV'#255#175'tV'#255#9#6#4#255#0#0#0#255#0#0#0#255#0#0#0#255#136 + +'ZC'#255'T8*'#255#1#1#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#7#5#3#255 + +'bA0'#255#175'tV'#255#175'tV'#255#175'tV'#255#175'tV'#255#175'tV'#255#175'tV' + +#255#175'tV'#255#175'tV'#255#175'tV'#255#175'tV'#255#175'tV'#255#175'tV'#255 + +#175'tV'#255#175'tV'#255#175'tV'#255#175'tV'#255#175'tV'#255#175'tV'#255#175 + +'tV'#255#175'tV'#255#175'tV'#255#175'tV'#255#175'tV'#255#175'tV'#255#175'tV' + +#255#175'tV'#255#175'tV'#255#175'tV'#255#175'tV'#255#175'tV'#255#175'tV'#255 + +#175'tV'#255#175'tV'#255#175'tV'#255#175'tV'#255#175'tV'#255#175'tV'#255#175 + +'tV'#255#175'tV'#255#175'tV'#255#175'tV'#255#175'tV'#255#175'tV'#255#175'tV' + +#255#175'tV'#255#175'tV'#255#175'tV'#255#175'tV'#255#175'tV'#255#175'tV'#255 + +#165'nR'#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0 + +#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255 + +#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#10#7#5#255#175'tV'#255#175 + +'tV'#255#175'tV'#255#175'tV'#255#175'tV'#255#175'tV'#255#175'tV'#255#175'tV' + +#255#175'tV'#255#175'tV'#255#175'tV'#255#174'sU'#255#173'qR'#255#166'eG'#255 + +#131'F,'#255'\0'#28#255'[/'#27#255'EA?'#145'DDDGFFF'#22'@@@'#4#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#1'333'#5'W3#\[/'#27#255'\1'#29#255#146'P3'#255#168 + +'jM'#255#173'pT'#255#173'rU'#255#173'rU'#255#173'rU'#255#173'rU'#255#173'rU' + +#255#173'rU'#255#173'rU'#255#173'rU'#255#173'rU'#255#173'rU'#255#173'rU'#255 + +#4#3#2#255#0#0#0#255#0#0#0#255#21#14#10#255#173'rU'#255#173'rU'#255#152'dK' + +#255'dB1'#255'A+ '#255'D-!'#255#141']E'#255#173'rU'#255#173'rU'#255#173'rU' + +#255#173'rU'#255#173'rU'#255#173'rU'#255#173'rU'#255#173'rU'#255#173'rU'#255 + +#173'rU'#255#173'rU'#255#173'rU'#255#173'rU'#255#173'rU'#255#173'rU'#255#173 + +'rU'#255#173'rU'#255#173'rU'#255#173'rU'#255#173'rU'#255#173'rU'#255#173'rU' + ,#255#173'rU'#255#173'rU'#255#173'rU'#255#173'rU'#255#173'rU'#255#173'rU'#255 + +#173'rU'#255#173'rU'#255#173'rU'#255#173'rU'#255#173'rU'#255#173'rU'#255#173 + +'rU'#255#173'rU'#255#173'rU'#255#173'rU'#255#173'rU'#255#173'rU'#255#173'rU' + +#255#173'rU'#255#173'rU'#255#173'rU'#255#173'rU'#255#173'rU'#255#173'rU'#255 + +#173'rU'#255#173'rU'#255#173'rU'#255#173'rU'#255#173'rU'#255#169'pS'#255#0#0 + +#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255 + +#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#139'\D'#255#173'rU'#255#173'rU' + +#255#173'rU'#255#173'rU'#255#173'rU'#255#173'rU'#255#173'rU'#255#173'rU'#255 + +#173'rU'#255#173'rU'#255#173'qT'#255#172'oR'#255#165'cF'#255#128'E+'#255'\0' + +#28#255'[/'#27#255'CBA'#132'DDD@CCC'#19'UUU'#3#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0'@@@'#4'U2"L[/'#27#255'\1'#29#255#143'N3'#255#168'hK'#255#172'oT' + +#255#173'qU'#255#173'rV'#255#173'rV'#255#173'rV'#255#173'rV'#255#173'rV'#255 + +#173'rV'#255#173'rV'#255#173'rV'#255#173'rV'#255#173'rV'#255#1#1#1#255#0#0#0 + +#255#0#0#0#255'nI7'#255#173'rV'#255#173'rV'#255#173'rV'#255#173'rV'#255#173 + +'rV'#255#173'rV'#255#173'rV'#255#173'rV'#255#173'rV'#255#173'rV'#255#173'rV' + +#255#173'rV'#255#173'rV'#255#173'rV'#255#173'rV'#255#173'rV'#255#173'rV'#255 + +#173'rV'#255#173'rV'#255#173'rV'#255#173'rV'#255#173'rV'#255#173'rV'#255#173 + +'rV'#255#173'rV'#255#173'rV'#255#173'rV'#255#173'rV'#255#173'rV'#255#173'rV' + +#255#173'rV'#255#173'rV'#255#173'rV'#255#173'rV'#255#173'rV'#255#173'rV'#255 + +#173'rV'#255#173'rV'#255#173'rV'#255#173'rV'#255#173'rV'#255#173'rV'#255#173 + +'rV'#255#173'rV'#255#173'rV'#255#173'rV'#255#173'rV'#255#173'rV'#255#173'rV' + +#255#173'rV'#255#173'rV'#255#173'rV'#255#173'rV'#255#173'rV'#255#173'rV'#255 + +#173'rV'#255#173'rV'#255#173'rV'#255#173'rV'#255#173'rV'#255#2#1#1#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255'H0$'#255#173'rV'#255#173'rV'#255#173'rV' + +#255#173'rV'#255#173'rV'#255#173'rV'#255#173'rV'#255#173'rV'#255#173'rV'#255 + +#173'rV'#255#173'qU'#255#171'nQ'#255#165'dF'#255'~D+'#255'\1'#29#255'Z0'#28 + +#252'CCCzCCC9@@@'#16#128#128#128#2#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'U' + +'UU'#3'T2#=[/'#27#255'\1'#29#255#140'N1'#255#166'gI'#255#171'oR'#255#173'qU' + +#255#173'qU'#255#173'qU'#255#173'qU'#255#173'qU'#255#173'qU'#255#173'qU'#255 + +#173'qU'#255#173'qU'#255#173'qU'#255#173'qU'#255#1#1#1#255#27#18#13#255'a@0' + +#255#173'qU'#255#173'qU'#255#173'qU'#255#173'qU'#255#173'qU'#255#173'qU'#255 + +#173'qU'#255#173'qU'#255#173'qU'#255#173'qU'#255#173'qU'#255#173'qU'#255#173 + +'qU'#255#173'qU'#255#173'qU'#255#173'qU'#255#173'qU'#255#173'qU'#255#173'qU' + +#255#173'qU'#255#173'qU'#255#173'qU'#255#173'qU'#255#173'qU'#255#173'qU'#255 + +#173'qU'#255#173'qU'#255#173'qU'#255#173'qU'#255#173'qU'#255#173'qU'#255#173 + +'qU'#255#173'qU'#255#173'qU'#255#173'qU'#255#173'qU'#255#173'qU'#255#173'qU' + +#255#173'qU'#255#173'qU'#255#173'qU'#255#173'qU'#255#173'qU'#255#173'qU'#255 + +#173'qU'#255#173'qU'#255#173'qU'#255#173'qU'#255#173'qU'#255#173'qU'#255#173 + +'qU'#255#173'qU'#255#173'qU'#255#173'qU'#255#173'qU'#255#173'qU'#255#173'qU' + +#255#173'qU'#255#173'qU'#255#173'qU'#255#173'qU'#255'$'#24#18#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#31#20#15#255#173'qU'#255#173'qU'#255#173'qU'#255 + +#173'qU'#255#173'qU'#255#173'qU'#255#173'qU'#255#173'qU'#255#173'qU'#255#173 + +'qU'#255#172'pT'#255#169'lP'#255#164'aD'#255'{C*'#255'\1'#29#255'Y0'#30#247 + +'CCCoBBB2;;;'#13#0#0#0#2#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#128#128#128 + +#2'V6''-[/'#27#255'\1'#29#255#137'L0'#255#165'fH'#255#170'mQ'#255#172'pT'#255 + +#172'pU'#255#172'pU'#255#172'pU'#255#172'pU'#255#172'pU'#255#172'pU'#255#172 + +'pU'#255#172'pU'#255#172'pU'#255#172'pU'#255#166'lS'#255#172'pU'#255#172'pU' + +#255#172'pU'#255#172'pU'#255#172'pU'#255#172'pU'#255#172'pU'#255#172'pU'#255 + +#172'pU'#255#172'pU'#255#172'pU'#255#172'pU'#255#172'pU'#255#172'pU'#255#172 + +'pU'#255#172'pU'#255#172'pU'#255#172'pU'#255#172'pU'#255#172'pU'#255#172'pU' + +#255#172'pU'#255#172'pU'#255#172'pU'#255#168'nS'#255#134'WB'#255'b@0'#255'tK' + +'9'#255#166'lS'#255#172'pU'#255#172'pU'#255#172'pU'#255#172'pU'#255#172'pU' + +#255#172'pU'#255#172'pU'#255#172'pU'#255#172'pU'#255#172'pU'#255#172'pU'#255 + +#172'pU'#255#172'pU'#255#172'pU'#255#172'pU'#255#172'pU'#255#172'pU'#255#172 + +'pU'#255#172'pU'#255#172'pU'#255#172'pU'#255#172'pU'#255#172'pU'#255#172'pU' + +#255#172'pU'#255#172'pU'#255#172'pU'#255#172'pU'#255#172'pU'#255#172'pU'#255 + +#172'pU'#255#172'pU'#255#172'pU'#255#172'pU'#255#129'T@'#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + ,#255#0#0#0#255#0#0#0#255#22#14#11#255#172'pU'#255#172'pU'#255#172'pU'#255#172 + +'pU'#255#172'pU'#255#172'pU'#255#172'pU'#255#172'pU'#255#172'pU'#255#172'pU' + +#255#172'oT'#255#170'mP'#255#163'`C'#255'xB*'#255'\1'#29#255'Y1'#31#241'BBBd' + +'CCC*MMM'#10#0#0#0#1#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#2'T7*'#29 + +'[/'#27#255'\1'#29#255#134'J0'#255#165'dG'#255#169'lQ'#255#171'pU'#255#172'q' + +'W'#255#172'qW'#255#172'qW'#255#172'qW'#255#172'qW'#255#172'qW'#255#172'qW' + +#255#172'qW'#255#172'qW'#255#172'qW'#255#172'qW'#255#172'qW'#255#172'qW'#255 + +#172'qW'#255#172'qW'#255#172'qW'#255#172'qW'#255#172'qW'#255#172'qW'#255#172 + +'qW'#255#172'qW'#255#172'qW'#255#172'qW'#255#172'qW'#255#172'qW'#255#172'qW' + +#255#172'qW'#255#172'qW'#255#172'qW'#255#172'qW'#255#172'qW'#255#172'qW'#255 + +#135'YD'#255'$'#24#18#255#3#2#2#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#8#5#4#255#30#20#16#255'xO='#255#172'qW'#255#172'qW'#255#172'qW'#255 + +#172'qW'#255#172'qW'#255#172'qW'#255#172'qW'#255#172'qW'#255#172'qW'#255#172 + +'qW'#255#172'qW'#255#172'qW'#255#172'qW'#255#172'qW'#255#172'qW'#255#172'qW' + +#255#172'qW'#255#172'qW'#255#172'qW'#255#172'qW'#255#172'qW'#255#172'qW'#255 + +#172'qW'#255#172'qW'#255#172'qW'#255#172'qW'#255#172'qW'#255#172'qW'#255#172 + +'qW'#255#172'qW'#255#172'qW'#255#172'qW'#255#14#9#7#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#20#13#10#255#172'qW'#255#172'qW'#255#172'qW'#255#172'qW'#255#172'qW' + +#255#172'qW'#255#172'qW'#255#172'qW'#255#172'qW'#255#172'qW'#255#171'oT'#255 + +#169'jM'#255#162'_A'#255's>'''#255'\1'#29#255'X2 '#234'CCCXDDD"@@@'#8#0#0#0#1 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#1'C><'#9'[/'#27#247'\1'#29#255 + +'}F-'#255#164'bE'#255#169'lO'#255#171'pT'#255#172'qV'#255#172'qV'#255#172'qV' + +#255#172'qV'#255#172'qV'#255#172'qV'#255#172'qV'#255#172'qV'#255#172'qV'#255 + +#172'qV'#255#172'qV'#255#172'qV'#255#172'qV'#255#172'qV'#255#172'qV'#255#172 + +'qV'#255#172'qV'#255#172'qV'#255#172'qV'#255#172'qV'#255#172'qV'#255#172'qV' + +#255#172'qV'#255#172'qV'#255#172'qV'#255#172'qV'#255#172'qV'#255#172'qV'#255 + +#172'qV'#255#172'qV'#255#154'eM'#255#22#15#11#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#25#17#13#255#136'ZE'#255#172'qV'#255#172'qV'#255#172'qV'#255#172'qV' + +#255#172'qV'#255#172'qV'#255#172'qV'#255#172'qV'#255#172'qV'#255#172'qV'#255 + +#172'qV'#255#172'qV'#255#172'qV'#255#172'qV'#255#172'qV'#255#172'qV'#255#172 + +'qV'#255#172'qV'#255#172'qV'#255#172'qV'#255#172'qV'#255#172'qV'#255#172'qV' + +#255#172'qV'#255#172'qV'#255#172'qV'#255#172'qV'#255#172'qV'#255#172'qV'#255 + +#172'qV'#255'U7*'#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#17#11#9#255#172'qV'#255#172 + +'qV'#255#172'qV'#255#172'qV'#255#172'qV'#255#172'qV'#255#172'qV'#255#172'qV' + +#255#172'qV'#255#172'qV'#255#171'oT'#255#168'jM'#255#161'^@'#255'k;%'#255'\0' + +#28#255'V3#'#220'CCCLEEE'#26'333'#5#0#0#0#1#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0'+++'#6'[/'#28#214'\1'#29#255't@)'#255#162'`B'#255#168'jO'#255 + +#172'pV'#255#173'rX'#255#173'rX'#255#173'rX'#255#173'rX'#255#173'rX'#255#173 + +'rX'#255#173'rX'#255#173'rX'#255#173'rX'#255#173'rX'#255#173'rX'#255#173'rX' + +#255#173'rX'#255#173'rX'#255#173'rX'#255#173'rX'#255#173'rX'#255#173'rX'#255 + +#173'rX'#255#173'rX'#255#173'rX'#255#173'rX'#255#173'rX'#255#173'rX'#255#173 + +'rX'#255#173'rX'#255#173'rX'#255#173'rX'#255#173'rX'#255#144'_I'#255#6#4#3 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255'Z;-'#255 + +#173'rX'#255#173'rX'#255#173'rX'#255#173'rX'#255#173'rX'#255#173'rX'#255#173 + +'rX'#255#173'rX'#255#173'rX'#255#173'rX'#255#173'rX'#255#173'rX'#255#173'rX' + +#255#173'rX'#255#173'rX'#255#173'rX'#255#173'rX'#255#173'rX'#255#173'rX'#255 + +#173'rX'#255#173'rX'#255#173'rX'#255#173'rX'#255#173'rX'#255#173'rX'#255#173 + +'rX'#255#173'rX'#255#173'rX'#255#173'rX'#255#171'pV'#255#3#2#1#255#0#0#0#255 + +#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255'!'#22#17#255#173'rX'#255#173'rX'#255#173'rX'#255#173'rX'#255#173'rX' + +#255#173'rX'#255#173'rX'#255#173'rX'#255#173'rX'#255#172'qX'#255#171'oU'#255 + +#167'hM'#255#160'[>'#255'b5!'#255'\0'#28#255'S5'''#196'EEE?CCC'#19'@@@'#4#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'UUU'#3'Z0'#29#176'\1'#29 + +#255'k:%'#255#162'^A'#255#169'jN'#255#173'qV'#255#174'sY'#255#174'sY'#255#174 + +'sY'#255#174'sY'#255#174'sY'#255#174'sY'#255#174'sY'#255#174'sY'#255#174'sY' + +#255#174'sY'#255#174'sY'#255#174'sY'#255#174'sY'#255#174'sY'#255#174'sY'#255 + +#174'sY'#255#174'sY'#255#174'sY'#255#174'sY'#255#174'sY'#255#174'sY'#255#174 + ,'sY'#255#174'sY'#255#174'sY'#255#174'sY'#255#174'sY'#255#174'sY'#255#174'sY' + +#255#151'dM'#255#4#2#2#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255 + +#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#1#1#1#255#136'YF'#255#174'sY'#255#174'sY'#255#174's' + +'Y'#255#174'sY'#255#174'sY'#255#174'sY'#255#174'sY'#255#174'sY'#255#174'sY' + +#255#174'sY'#255#174'sY'#255#174'sY'#255#174'sY'#255#174'sY'#255#174'sY'#255 + +#174'sY'#255#174'sY'#255#174'sY'#255#174'sY'#255#174'sY'#255#174'sY'#255#174 + +'sY'#255#174'sY'#255#174'sY'#255#174'sY'#255#174'sY'#255#174'sY'#255#174'sY' + +#255#174'sY'#255'5#'#27#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255 + +#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255'G.$'#255#174'sY'#255#174'sY'#255 + +#174'sY'#255#174'sY'#255#174'sY'#255#174'sY'#255#174'sY'#255#174'sY'#255#174 + +'sY'#255#174'sY'#255#172'pV'#255#167'gK'#255#153'X:'#255'^3'#31#255'\0'#28 + +#255'Q7+'#166'BBB2777'#14#0#0#0#2#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#2'Z0'#29#137'\0'#28#255'a5!'#255#160']>'#255#168'jN'#255 + +#173'sY'#255#175'v\'#255#175'v\'#255#175'v\'#255#175'v\'#255#175'v\'#255#175 + +'v\'#255#175'v\'#255#175'v\'#255#175'v\'#255#175'v\'#255#175'v\'#255#175'v\' + +#255#175'v\'#255#175'v\'#255#175'v\'#255#175'v\'#255#175'v\'#255#175'v\'#255 + +#175'v\'#255#175'v\'#255#175'v\'#255#175'v\'#255#175'v\'#255#175'v\'#255#175 + +'v\'#255#175'v\'#255#175'v\'#255#175'v\'#255#29#20#15#255#0#0#0#255#0#0#0#255 + +#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#8 + +#5#4#255#169'rX'#255#175'v\'#255#175'v\'#255#175'v\'#255#175'v\'#255#175'v\' + +#255#175'v\'#255#175'v\'#255#175'v\'#255#175'v\'#255#175'v\'#255#175'v\'#255 + +#175'v\'#255#175'v\'#255#175'v\'#255#175'v\'#255#175'v\'#255#175'v\'#255#175 + +'v\'#255#175'v\'#255#175'v\'#255#175'v\'#255#175'v\'#255#175'v\'#255#175'v\' + +#255#175'v\'#255#175'v\'#255#175'v\'#255#175'v\'#255#156'jR'#255#1#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255'yQ?'#255#175'v\'#255#175'v\'#255#175'v\'#255#175'v\'#255#175'v\'#255 + +#175'v\'#255#175'v\'#255#175'v\'#255#175'v\'#255#174'u['#255#172'qV'#255#166 + +'gJ'#255#143'S6'#255'^2'#31#255'[/'#27#255'O;2'#130'CCC&999'#9#0#0#0#1#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#1'Z0'#29'a\0'#28#255 + +'^3'#31#255#153'W;'#255#168'jN'#255#174'tZ'#255#176'x_'#255#176'y_'#255#176 + +'y_'#255#176'y_'#255#176'y_'#255#176'y_'#255#176'y_'#255#176'y_'#255#176'y_' + +#255#176'y_'#255#176'y_'#255#176'y_'#255#176'y_'#255#176'y_'#255#176'y_'#255 + +#176'y_'#255#176'y_'#255#176'y_'#255#176'y_'#255#176'y_'#255#176'y_'#255#176 + +'y_'#255#176'y_'#255#176'y_'#255#176'y_'#255#176'y_'#255#176'y_'#255'oL='#255 + +#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255']@2'#255#176'y_'#255#176'y_'#255#176 + +'y_'#255#176'y_'#255#176'y_'#255#176'y_'#255'Z=1'#255')'#28#22#255#26#18#14 + +#255#14#10#8#255#10#7#5#255#23#16#12#255'+'#30#23#255'E0&'#255#138'_J'#255 + +#176'y_'#255#176'y_'#255#176'y_'#255#176'y_'#255#176'y_'#255#176'y_'#255#176 + +'y_'#255#176'y_'#255#176'y_'#255#176'y_'#255#176'y_'#255#176'y_'#255#176'y_' + +#255#176'y_'#255'#'#24#19#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#172'w]'#255#176'y_'#255#176'y_'#255 + +#176'y_'#255#176'y_'#255#176'y_'#255#176'y_'#255#176'y_'#255#176'y_'#255#176 + +'y_'#255#175'w^'#255#172'rW'#255#165'fI'#255#134'K2'#255']1'#30#255'[/'#27 + +#255'H?:ZBBB'#27'+++'#6#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0'X/'#29'7[/'#27#255'^2'#31#255#141'P5'#255#167'hK'#255#174 + +'sY'#255#177'x_'#255#177'za'#255#177'za'#255#177'za'#255#177'za'#255#177'za' + +#255#177'za'#255#177'za'#255#177'za'#255#177'za'#255#177'za'#255#177'za'#255 + +#177'za'#255#177'za'#255#177'za'#255#177'za'#255#177'za'#255#177'za'#255#177 + +'za'#255#177'za'#255#177'za'#255#177'za'#255#177'za'#255#177'za'#255#177'za' + +#255#177'za'#255#177'za'#255#9#6#5#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255'%'#25#20#255#177'za'#255#177'za'#255#177'za'#255#177'za'#255'bD6'#255#8 + +#6#4#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255'>+"'#255#175'za'#255#177'za'#255#177'za'#255#177'za' + +#255#177'za'#255#177'za'#255#177'za'#255#177'za'#255#177'za'#255#177'za'#255 + +#177'za'#255#177'za'#255#177'za'#255#136'^K'#255#0#0#0#255#0#0#0#255#0#0#0 + ,#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#16#11#9#255#177'za'#255#177 + +'za'#255#177'za'#255#177'za'#255#177'za'#255#177'za'#255#177'za'#255#177'za' + +#255#177'za'#255#177'za'#255#176'x^'#255#172'qV'#255#164'cF'#255'{E,'#255']1' + +#30#255'Z0'#29#245'DDD'#255 + +'`5!'#255'\0'#28#255'T5'''#155'DDD'#30'III'#7#0#0#0#1#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'Z/'#28'w\0'#28#255 + +'`5!'#255#157'\?'#255#172'pU'#255#179'}d'#255#181#129'i'#255#182#129'j'#255 + +#182#129'j'#255#182#129'j'#255#182#129'j'#255#182#129'j'#255#182#129'j'#255 + +#182#129'j'#255#182#129'j'#255#182#129'j'#255#182#129'j'#255#182#129'j'#255 + +#182#129'j'#255#182#129'j'#255#182#129'j'#255#182#129'j'#255#182#129'j'#255 + +#182#129'j'#255#182#129'j'#255#182#129'j'#255#182#129'j'#255#182#129'j'#255 + +#182#129'j'#255#182#129'j'#255#182#129'j'#255'.!'#27#255#0#0#0#255#0#0#0#255 + +#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#2#1#1#255#166'va'#255#182#129'j'#255#182#129'j'#255'A.&' + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#9#6#5#255#170'yd'#255#182#129'j'#255#182#129'j'#255#182#129'j'#255#182 + +#129'j'#255#182#129'j'#255#182#129'j'#255#182#129'j'#255#182#129'j'#255#182 + +#129'j'#255#182#129'j'#255#182#129'j'#255#8#6#5#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#135'`O'#255#182#129'j'#255#182#129'j'#255#182#129'j'#255 + +#182#129'j'#255#182#129'j'#255#182#129'j'#255#182#129'j'#255#182#129'j'#255 + +#182#129'j'#255#182#129'j'#255#181#128'h'#255#177'za'#255#169'kP'#255#139'Q7' + +#255'^3'#31#255'\0'#28#255'N9/\GGG'#18'UUU'#3#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'X.'#26'4\0'#28#255 + ,'^3'#31#255#141'S8'#255#170'mQ'#255#179'|c'#255#182#130'k'#255#184#132'm'#255 + +#184#132'm'#255#184#132'm'#255#184#132'm'#255#184#132'm'#255#184#132'm'#255 + +#184#132'm'#255#184#132'm'#255#184#132'm'#255#184#132'm'#255#184#132'm'#255 + +#184#132'm'#255#184#132'm'#255#184#132'm'#255#184#132'm'#255#184#132'm'#255 + +#184#132'm'#255#184#132'm'#255#184#132'm'#255#184#132'm'#255#184#132'm'#255 + +#184#132'm'#255#184#132'm'#255#184#132'm'#255#20#15#12#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255'N8.'#255#184#132'm'#255#184#132'm'#255#184#132'm' + +#255#22#16#13#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255 + +#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#21#15#13#255#182#130'm'#255#184#132'm'#255#184#132 + +'m'#255#184#132'm'#255#184#132'm'#255#184#132'm'#255#184#132'm'#255#184#132 + +'m'#255#184#132'm'#255#184#132'm'#255#184#132'm'#255'N8.'#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#23#17#13#255#184#132'm'#255#184#132'm'#255#184#132'm'#255 + +#184#132'm'#255#184#132'm'#255#184#132'm'#255#184#132'm'#255#184#132'm'#255 + +#184#132'm'#255#184#132'm'#255#183#131'l'#255#182#129'j'#255#177'x_'#255#167 + +'hK'#255'zG/'#255']1'#30#255'Z0'#28#241'@@@(MMM'#10#0#0#0#1#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'='#31 + +#18#3'[/'#27#238']1'#30#255'{G/'#255#167'hL'#255#177'za'#255#183#131'l'#255 + +#185#134'p'#255#185#134'p'#255#185#134'p'#255#185#134'p'#255#185#134'p'#255 + +#185#134'p'#255#185#134'p'#255#185#134'p'#255#185#134'p'#255#185#134'p'#255 + +#185#134'p'#255#185#134'p'#255#185#134'p'#255#185#134'p'#255#185#134'p'#255 + +#185#134'p'#255#185#134'p'#255#185#134'p'#255#185#134'p'#255#185#134'p'#255 + +#185#134'p'#255#185#134'p'#255#185#134'p'#255#185#134'p'#255#26#19#16#255#0#0 + +#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255 + +#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#12#9#7#255#185#134'p'#255#185#134'p'#255#185#134'p' + +#255#185#134'p'#255#3#2#2#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255'U>4'#255#185#134'p'#255#185 + +#134'p'#255#185#134'p'#255#185#134'p'#255#185#134'p'#255#185#134'p'#255#185 + +#134'p'#255#185#134'p'#255#185#134'p'#255#185#134'p'#255#185#134'p'#255#25#18 + +#15#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255 + +#0#0#0#255#0#0#0#255#0#0#0#255'xWI'#255#185#134'p'#255#185#134'p'#255#185#134 + +'p'#255#185#134'p'#255#185#134'p'#255#185#134'p'#255#185#134'p'#255#185#134 + +'p'#255#185#134'p'#255#185#134'p'#255#184#134'o'#255#182#129'j'#255#175'v\' + +#255#165'dG'#255'h;&'#255'\1'#29#255'X2 '#193'==='#25'+++'#6#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0'[/'#27#170'\1'#29#255'f9%'#255#164'bG'#255#175'v]'#255#183#131 + +'l'#255#186#135'r'#255#186#137's'#255#186#137's'#255#186#137's'#255#186#137 + +'s'#255#186#137's'#255#186#137's'#255#186#137's'#255#186#137's'#255#186#137 + +'s'#255#186#137's'#255#186#137's'#255#186#137's'#255#186#137's'#255#186#137 + +'s'#255#186#137's'#255#186#137's'#255#186#137's'#255#186#137's'#255#186#137 + +'s'#255#186#137's'#255#186#137's'#255#186#137's'#255#186#137's'#255'$'#27#23 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#129'_P'#255#186#137's'#255#186#137's'#255 + +#186#137's'#255#186#137's'#255#1#1#1#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255' '#23#19#255#186 + +#137's'#255#186#137's'#255#186#137's'#255#186#137's'#255#186#137's'#255#186 + +#137's'#255#186#137's'#255#186#137's'#255#186#137's'#255#186#137's'#255#186 + +#137's'#255#172#127'j'#255#7#5#4#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255 + +#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#12#9#7#255#186#137's'#255#186#137's' + +#255#186#137's'#255#186#137's'#255#186#137's'#255#186#137's'#255#186#137's' + +#255#186#137's'#255#186#137's'#255#186#137's'#255#186#137's'#255#185#135'q' + +#255#181#129'i'#255#173'qW'#255#149'X='#255'`5!'#255'\0'#28#255'V4%'#127'333' + +#15#0#0#0#3#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'Z/'#27'O\0'#28#255'_4 '#255#144'U:' + +#255#172'qV'#255#182#130'k'#255#187#137't'#255#188#139'u'#255#188#140'v'#255 + +#188#140'v'#255#188#140'v'#255#188#140'v'#255#188#140'v'#255#188#140'v'#255 + +#188#140'v'#255#188#140'v'#255#188#140'v'#255#188#140'v'#255#188#140'v'#255 + ,#188#140'v'#255#188#140'v'#255#188#140'v'#255#188#140'v'#255#188#140'v'#255 + +#188#140'v'#255#188#140'v'#255#188#140'v'#255#188#140'v'#255#188#140'v'#255 + +#188#140'v'#255'1$'#31#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255 + +#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255':+$'#255#188#140'v'#255#188#140 + +'v'#255#188#140'v'#255#188#140'v'#255#188#140'v'#255#1#1#1#255#0#0#0#255#0#0 + +#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255 + +#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#4#3#3#255#188#140'v'#255#188#140'v'#255#188#140'v'#255#188#140'v'#255 + +#188#140'v'#255#188#140'v'#255#188#140'v'#255#188#140'v'#255#188#140'v'#255 + +#188#140'v'#255#188#140'v'#255#188#140'v'#255#188#140'v'#255'}]N'#255'6("' + +#255#14#11#9#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255'S>5'#255 + +#188#140'v'#255#188#140'v'#255#188#140'v'#255#188#140'v'#255#188#140'v'#255 + +#188#140'v'#255#188#140'v'#255#188#140'v'#255#188#140'v'#255#188#140'v'#255 + +#188#139'u'#255#186#136'r'#255#180'~f'#255#169'kP'#255'|H1'#255'^2'#31#255'[' + +'/'#27#249'L=6+III'#7#0#0#0#1#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'[/'#27#5'[/'#27#235 + +']1'#30#255'wD/'#255#169'jO'#255#180#127'g'#255#187#137'u'#255#189#141'x'#255 + +#189#142'y'#255#189#142'y'#255#189#142'y'#255#189#142'y'#255#189#142'y'#255 + +#189#142'y'#255#189#142'y'#255#189#142'y'#255#189#142'y'#255#189#142'y'#255 + +#189#142'y'#255#189#142'y'#255#189#142'y'#255#189#142'y'#255#189#142'y'#255 + +#189#142'y'#255#189#142'y'#255#189#142'y'#255#189#142'y'#255#189#142'y'#255 + +#189#142'y'#255#189#142'y'#255'J7/'#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#16#12#11#255#187#140'y'#255 + +#189#142'y'#255#189#142'y'#255#189#142'y'#255#189#142'y'#255#189#142'y'#255#1 + +#1#1#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#181#136'u'#255#189#142'y'#255#189#142 + +'y'#255#189#142'y'#255#189#142'y'#255#189#142'y'#255#189#142'y'#255#189#142 + +'y'#255#189#142'y'#255#189#142'y'#255#189#142'y'#255#189#142'y'#255#189#142 + +'y'#255#189#142'y'#255#189#142'y'#255#189#142'y'#255#11#8#7#255#0#0#0#255#0#0 + +#0#255#0#0#0#255#1#1#1#255#181#136's'#255#189#142'y'#255#189#142'y'#255#189 + +#142'y'#255#189#142'y'#255#189#142'y'#255#189#142'y'#255#189#142'y'#255#189 + +#142'y'#255#189#142'y'#255#189#142'y'#255#189#141'x'#255#186#136'q'#255#177 + +'za'#255#164'dG'#255'f:&'#255'\1'#29#255'Y1'#31#186'@@@'#16'UUU'#3#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'Z/'#27#147'\1'#29#255'b8$'#255#160'bF'#255 + +#177'y`'#255#186#137's'#255#190#143'z'#255#191#145'|'#255#191#145'|'#255#191 + +#145'|'#255#191#145'|'#255#191#145'|'#255#191#145'|'#255#191#145'|'#255#191 + +#145'|'#255#191#145'|'#255#191#145'|'#255#191#145'|'#255#191#145'|'#255#191 + +#145'|'#255#191#145'|'#255#191#145'|'#255#191#145'|'#255#191#145'|'#255#191 + +#145'|'#255#191#145'|'#255#191#145'|'#255#191#145'|'#255#191#145'|'#255#162 + +'{i'#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#1#1#1#255#162'{i'#255#191#145'|'#255#191#145'|'#255#191#145'|'#255 + +#191#145'|'#255#191#145'|'#255#191#145'|'#255#2#1#1#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#1 + +#1#1#255#191#145'|'#255#191#145'|'#255#191#145'|'#255#191#145'|'#255#191#145 + +'|'#255#191#145'|'#255#191#145'|'#255#191#145'|'#255#191#145'|'#255#191#145 + +'|'#255#191#145'|'#255#191#145'|'#255#191#145'|'#255#191#145'|'#255#191#145 + +'|'#255#191#145'|'#255#5#4#3#255#0#0#0#255#0#0#0#255#0#0#0#255'&'#29#25#255 + +#191#145'|'#255#191#145'|'#255#191#145'|'#255#191#145'|'#255#191#145'|'#255 + +#191#145'|'#255#191#145'|'#255#191#145'|'#255#191#145'|'#255#191#145'|'#255 + +#191#145'|'#255#189#142'y'#255#184#134'o'#255#174'sY'#255#143'U;'#255'`5!' + +#255'\0'#28#255'U3$`@@@'#8#0#0#0#1#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0'Z.'#27'5\0'#28#255'_4 '#255#137'Q8'#255#173'rX'#255#184#134'o'#255#190#144 + +'{'#255#192#147#127#255#192#147#127#255#192#147#127#255#192#147#127#255#192 + +#147#127#255#192#147#127#255#192#147#127#255#192#147#127#255#192#147#127#255 + +#192#147#127#255#192#147#127#255#192#147#127#255#192#147#127#255#192#147#127 + +#255#192#147#127#255#192#147#127#255#192#147#127#255#192#147#127#255#192#147 + +#127#255#192#147#127#255#192#147#127#255#192#147#127#255#192#147#127#255#14 + ,#11#9#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255' ' + +#24#21#255#192#147#127#255#192#147#127#255#192#147#127#255#192#147#127#255 + +#192#147#127#255#192#147#127#255#192#147#127#255#4#3#3#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#8#6#5#255#192#147#127#255#192#147#127#255#192#147#127#255#192#147#127 + +#255#192#147#127#255#192#147#127#255#192#147#127#255#192#147#127#255#192#147 + +#127#255#192#147#127#255#192#147#127#255#192#147#127#255#192#147#127#255#192 + +#147#127#255#192#147#127#255#192#147#127#255#1#1#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#137'iZ'#255#192#147#127#255#192#147#127#255#192#147#127#255#192#147 + +#127#255#192#147#127#255#192#147#127#255#192#147#127#255#192#147#127#255#192 + +#147#127#255#192#147#127#255#192#146'~'#255#189#142'y'#255#182#129'j'#255#169 + +'lP'#255'uD.'#255'^2'#31#255'[/'#28#237'NFB'#21'UUU'#3#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'[/'#27#211']1'#30#255'l>)'#255#167'iM' + +#255#181#127'g'#255#190#143'z'#255#193#148#128#255#194#149#130#255#194#149 + +#130#255#194#149#130#255#194#149#130#255#194#149#130#255#194#149#130#255#194 + +#149#130#255#194#149#130#255#194#149#130#255#194#149#130#255#194#149#130#255 + +#194#149#130#255#194#149#130#255#194#149#130#255#194#149#130#255#194#149#130 + +#255#194#149#130#255#194#149#130#255#194#149#130#255#194#149#130#255#194#149 + +#130#255#194#149#130#255'G60'#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0 + +#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255 + +#0#0#0#255#0#0#0#255'ZE<'#255#194#149#130#255#194#149#130#255#194#149#130#255 + +#194#149#130#255#194#149#130#255#194#149#130#255#194#149#130#255#7#6#5#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#23#17#15#255#194#149#130#255#194#149#130#255#194#149#130 + +#255#194#149#130#255#194#149#130#255#194#149#130#255#194#149#130#255#194#149 + +#130#255#194#149#130#255#194#149#130#255#194#149#130#255#194#149#130#255#194 + +#149#130#255#194#149#130#255#194#149#130#255#179#137'x'#255#0#0#0#255#0#0#0 + +#255#0#0#0#255'-#'#30#255#194#149#130#255#194#149#130#255#194#149#130#255#194 + +#149#130#255#194#149#130#255#194#149#130#255#194#149#130#255#194#149#130#255 + +#194#149#130#255#194#149#130#255#194#149#130#255#192#147#127#255#188#140'v' + +#255#177'za'#255#156'_D'#255'a6#'#255'\1'#29#255'Y1'#31#153'@@@'#8#0#0#0#1#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'Z/'#27']\0'#28#255 + +'`5!'#255#143'V='#255#175'v]'#255#187#138'u'#255#193#149#129#255#195#152#132 + +#255#195#152#133#255#195#152#133#255#195#152#133#255#195#152#133#255#195#152 + +#133#255#195#152#133#255#195#152#133#255#195#152#133#255#195#152#133#255#195 + +#152#133#255#195#152#133#255#195#152#133#255#195#152#133#255#195#152#133#255 + +#195#152#133#255#195#152#133#255#195#152#133#255#195#152#133#255#195#152#133 + +#255#195#152#133#255#195#152#133#255#170#133't'#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#172#133'u'#255#195#152#133#255#195#152 + +#133#255#195#152#133#255#195#152#133#255#195#152#133#255#195#152#133#255#146 + +'rd'#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255'_JA'#255#195#152#133#255#195#152#133 + +#255#195#152#133#255#195#152#133#255#195#152#133#255#195#152#133#255#195#152 + +#133#255#195#152#133#255#195#152#133#255#195#152#133#255#195#152#133#255#195 + +#152#133#255#195#152#133#255#195#152#133#255#195#152#133#255#140'm`'#255#0#0 + +#0#255#0#0#0#255#6#5#4#255#186#145#127#255#195#152#133#255#195#152#133#255 + +#195#152#133#255#195#152#133#255#195#152#133#255#195#152#133#255#195#152#133 + +#255#195#152#133#255#195#152#133#255#195#152#133#255#195#152#132#255#192#147 + +#127#255#185#134'p'#255#172'pU'#255'|I2'#255'^3'#31#255'\0'#28#250'R5()UUU'#3 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'[/'#27#3 + +'[/'#27#221']1'#30#255'oA,'#255#169'lP'#255#183#131'l'#255#192#147#127#255 + +#196#154#135#255#197#155#136#255#197#155#136#255#197#155#136#255#197#155#136 + +#255#197#155#136#255#197#155#136#255#197#155#136#255#197#155#136#255#197#155 + +#136#255#197#155#136#255#197#155#136#255#197#155#136#255#197#155#136#255#197 + +#155#136#255#197#155#136#255#197#155#136#255#197#155#136#255#197#155#136#255 + +#197#155#136#255#197#155#136#255#197#155#136#255#197#155#136#255#26#20#18#255 + ,#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#8#6#5#255#197#155#136#255#197 + +#155#136#255#197#155#136#255#197#155#136#255#197#155#136#255#197#155#136#255 + +#197#155#136#255#28#22#19#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#4#3#3#255#193#153#134#255 + +#197#155#136#255#197#155#136#255#197#155#136#255#197#155#136#255#197#155#136 + +#255#197#155#136#255#197#155#136#255#197#155#136#255#197#155#136#255#197#155 + +#136#255#197#155#136#255#197#155#136#255#197#155#136#255#197#155#136#255#197 + +#155#136#255#182#143'~'#255'=0*'#255#7#5#5#255#130'fY'#255#197#155#136#255 + +#197#155#136#255#197#155#136#255#197#155#136#255#197#155#136#255#197#155#136 + +#255#197#155#136#255#197#155#136#255#197#155#136#255#197#155#136#255#196#154 + +#136#255#195#152#133#255#190#144'{'#255#180'~f'#255#159'bG'#255'c8%'#255'\1' + +#29#255'Z0'#30#163'III'#7#0#0#0#1#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'[/'#27'g\0'#28#255'a6#'#255#147'Y@'#255#177 + +'za'#255#190#143'z'#255#196#154#135#255#198#157#139#255#198#157#139#255#198 + +#157#139#255#198#157#139#255#198#157#139#255#198#157#139#255#198#157#139#255 + +#198#157#139#255#198#157#139#255#198#157#139#255#198#157#139#255#198#157#139 + +#255#198#157#139#255#198#157#139#255#198#157#139#255#198#157#139#255#198#157 + +#139#255#198#157#139#255#198#157#139#255#198#157#139#255#198#157#139#255#198 + +#157#139#255'<0+'#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255'*!'#29#255 + +#198#157#139#255#198#157#139#255#198#157#139#255#198#157#139#255#198#157#139 + +#255#198#157#139#255#164#130's'#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255'?2,'#255#198 + +#157#139#255#198#157#139#255#198#157#139#255#198#157#139#255#198#157#139#255 + +#198#157#139#255#198#157#139#255#198#157#139#255#198#157#139#255#198#157#139 + +#255#198#157#139#255#198#157#139#255#198#157#139#255#198#157#139#255#198#157 + +#139#255#198#157#139#255#198#157#139#255#198#157#139#255#198#157#139#255#198 + +#157#139#255#198#157#139#255#198#157#139#255#198#157#139#255#198#157#139#255 + +#198#157#139#255#198#157#139#255#198#157#139#255#198#157#139#255#198#157#139 + +#255#198#157#139#255#198#156#138#255#195#152#132#255#187#138't'#255#173'sY' + +#255#127'L5'#255'^3'#31#255'\0'#28#252'U3$,'#128#128#128#2#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'[/'#27#7 + +'[/'#27#229'^2'#31#255'qB.'#255#171'nS'#255#185#134'p'#255#194#151#131#255 + +#198#158#140#255#200#160#142#255#200#160#142#255#200#160#142#255#200#160#142 + +#255#200#160#142#255#200#160#142#255#200#160#142#255#200#160#142#255#200#160 + +#142#255#200#160#142#255#200#160#142#255#200#160#142#255#200#160#142#255#200 + +#160#142#255#200#160#142#255#200#160#142#255#200#160#142#255#200#160#142#255 + +#200#160#142#255#200#160#142#255#200#160#142#255'9.)'#255#0#0#0#255#0#0#0#255 + +#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255'hSJ'#255#200#160#142#255#200#160#142#255#200#160#142 + +#255#200#160#142#255#200#160#142#255#200#160#142#255'6+'''#255#0#0#0#255#0#0 + +#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255 + +#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#6#5#5#255#184#148#131#255#200#160#142#255#200#160#142#255#200#160#142 + +#255#200#160#142#255#200#160#142#255#200#160#142#255#200#160#142#255#200#160 + +#142#255#200#160#142#255#200#160#142#255#200#160#142#255#200#160#142#255#200 + +#160#142#255#200#160#142#255#200#160#142#255#200#160#142#255#200#160#142#255 + +#200#160#142#255#200#160#142#255#200#160#142#255#200#160#142#255#200#160#142 + +#255#200#160#142#255#200#160#142#255#200#160#142#255#200#160#142#255#200#160 + +#142#255#200#160#142#255#200#160#142#255#199#159#141#255#198#157#139#255#192 + +#147#127#255#181#127'g'#255#161'dI'#255'd:&'#255'\1'#29#255'Z0'#29#171'@@@'#4 + +#0#0#0#1#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0'[/'#27'q\1'#29#255'a6#'#255#143'W?'#255#177'za'#255 + +#191#144'|'#255#198#157#139#255#200#161#144#255#201#162#145#255#201#163#145 + +#255#201#163#145#255#201#163#145#255#201#163#145#255#201#163#145#255#201#163 + +#145#255#201#163#145#255#201#163#145#255#201#163#145#255#201#163#145#255#201 + +#163#145#255#201#163#145#255#201#163#145#255#201#163#145#255#201#163#145#255 + +#201#163#145#255#201#163#145#255#201#163#145#255#201#163#145#255'=2,'#255#0#0 + ,#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255 + +#0#0#0#255#0#0#0#255#0#0#0#255'!'#27#24#255#197#161#143#255#201#163#145#255 + +#201#163#145#255#201#163#145#255#201#163#145#255#201#163#145#255#197#161#143 + +#255#3#2#2#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#1#1#1#255#149'zl'#255#201#163#145#255#201#163#145 + +#255#201#163#145#255#201#163#145#255#201#163#145#255#201#163#145#255#201#163 + +#145#255#201#163#145#255#201#163#145#255#201#163#145#255#201#163#145#255#201 + +#163#145#255#201#163#145#255#201#163#145#255#201#163#145#255#201#163#145#255 + +#201#163#145#255#201#163#145#255#201#163#145#255#201#163#145#255#201#163#145 + +#255#201#163#145#255#201#163#145#255#201#163#145#255#201#163#145#255#201#163 + +#145#255#201#163#145#255#201#163#145#255#201#163#145#255#201#162#145#255#200 + +#161#143#255#197#155#136#255#187#138'u'#255#173'rX'#255'|I3'#255'_4 '#255'\0' + +#28#253'W1 2'#0#0#0#1#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'[/'#27#6'\0'#28#216'^2'#31#255 + +'i=)'#255#165'jP'#255#184#133'n'#255#196#152#134#255#201#162#145#255#202#164 + +#148#255#202#165#148#255#202#165#148#255#202#165#148#255#202#165#148#255#202 + +#165#148#255#202#165#148#255#202#165#148#255#202#165#148#255#202#165#148#255 + +#202#165#148#255#202#165#148#255#202#165#148#255#202#165#148#255#202#165#148 + +#255#202#165#148#255#202#165#148#255#202#165#148#255#202#165#148#255#202#165 + +#148#255'E82'#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#2#2#2#255#1#1#1#255 + +#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255'.&"'#255#202#165#148#255#202#165#148 + +#255#202#165#148#255#202#165#148#255#202#165#148#255#202#165#148#255#202#165 + +#148#255#146'wk'#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255'eRI'#255#202#165#148#255#202#165#148 + +#255#202#165#148#255#202#165#148#255#202#165#148#255#202#165#148#255#202#165 + +#148#255#202#165#148#255#202#165#148#255#202#165#148#255#202#165#148#255#202 + +#165#148#255#202#165#148#255#202#165#148#255#202#165#148#255#202#165#148#255 + +#202#165#148#255#202#165#148#255#202#165#148#255#202#165#148#255#202#165#148 + +#255#202#165#148#255#202#165#148#255#202#165#148#255#202#165#148#255#202#165 + +#148#255#202#165#148#255#202#165#148#255#202#165#148#255#202#165#148#255#202 + +#164#147#255#200#160#143#255#193#148#128#255#180'~f'#255#151'^D'#255'a7$'#255 + +'\1'#29#255'Z0'#28#156'UUU'#3#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'[/'#27 + +'D\0'#28#255'`5!'#255#128'N8'#255#175'v]'#255#190#143'{'#255#200#159#142#255 + +#203#165#150#255#204#167#151#255#204#167#151#255#204#167#151#255#204#167#151 + +#255#204#167#151#255#204#167#151#255#204#167#151#255#204#167#151#255#204#167 + +#151#255#204#167#151#255#204#167#151#255#204#167#151#255#204#167#151#255#204 + +#167#151#255#204#167#151#255#204#167#151#255#204#167#151#255#204#167#151#255 + +#204#167#151#255'N?9'#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255'vaW'#255 + +#204#167#151#255#160#131'w'#255'cRI'#255'WG@'#255#168#137'|'#255#204#167#151 + +#255#204#167#151#255#204#167#151#255#204#167#151#255#204#167#151#255#204#167 + +#151#255#204#167#151#255#204#167#151#255#145'wk'#255#0#0#0#255#0#0#0#255#0#0 + +#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255 + +#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255'G:4'#255#204#167 + +#151#255#204#167#151#255#204#167#151#255#204#167#151#255#204#167#151#255#204 + +#167#151#255#204#167#151#255#204#167#151#255#204#167#151#255#204#167#151#255 + +#204#167#151#255#204#167#151#255#204#167#151#255#204#167#151#255#204#167#151 + +#255#204#167#151#255#204#167#151#255#204#167#151#255#204#167#151#255#204#167 + +#151#255#204#167#151#255#204#167#151#255#204#167#151#255#204#167#151#255#204 + +#167#151#255#204#167#151#255#204#167#151#255#204#167#151#255#204#167#151#255 + +#204#167#151#255#204#167#150#255#202#165#148#255#198#155#138#255#186#137's' + +#255#171'nU'#255'oB.'#255'^2'#31#255'\0'#28#235'V2"'#21#0#0#0#1#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'[/'#27#169'\1'#29#255'c9&'#255#155'aH'#255 + +#182#128'j'#255#195#152#133#255#202#164#148#255#205#169#154#255#206#169#155 + +#255#206#169#155#255#206#169#155#255#206#169#155#255#206#169#155#255#206#169 + +#155#255#206#169#155#255#206#169#155#255#206#169#155#255#206#169#155#255#206 + +#169#155#255#206#169#155#255#206#169#155#255#206#169#155#255#206#169#155#255 + +#206#169#155#255#206#169#155#255#206#169#155#255'VGA'#255#0#0#0#255#0#0#0#255 + ,#0#0#0#255#5#4#4#255#206#169#155#255#206#169#155#255#206#169#155#255#206#169 + +#155#255#206#169#155#255#206#169#155#255#206#169#155#255#206#169#155#255#206 + +#169#155#255#206#169#155#255#206#169#155#255#206#169#155#255#206#169#155#255 + +#206#169#155#255#152'}r'#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#2#1#1#255'vaY'#255#206#169#155#255#206#169#155#255#206#169 + +#155#255#206#169#155#255#206#169#155#255#206#169#155#255#206#169#155#255#206 + +#169#155#255#206#169#155#255#206#169#155#255#206#169#155#255#206#169#155#255 + +#206#169#155#255#206#169#155#255#206#169#155#255#206#169#155#255#206#169#155 + +#255#206#169#155#255#206#169#155#255#206#169#155#255#206#169#155#255#206#169 + +#155#255#206#169#155#255#206#169#155#255#206#169#155#255#206#169#155#255#206 + +#169#155#255#206#169#155#255#206#169#155#255#206#169#155#255#206#169#155#255 + +#205#167#152#255#201#162#145#255#192#147#127#255#177'za'#255#138'T='#255'`6"' + +#255'\1'#29#255'[0'#29'e'#0#0#0#1#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0'[/'#27#27'\0'#28#243'^3'#31#255'pC/'#255#171'oU'#255#188#138'u' + +#255#199#158#141#255#205#169#154#255#207#171#157#255#207#172#158#255#207#172 + +#158#255#207#172#158#255#207#172#158#255#207#172#158#255#207#172#158#255#207 + +#172#158#255#207#172#158#255#207#172#158#255#207#172#158#255#207#172#158#255 + +#207#172#158#255#207#172#158#255#207#172#158#255#207#172#158#255#207#172#158 + +#255#207#172#158#255'~i`'#255#0#0#0#255#0#0#0#255#0#0#0#255#22#18#16#255#207 + +#172#158#255#207#172#158#255#207#172#158#255#207#172#158#255#207#172#158#255 + +#207#172#158#255#207#172#158#255#207#172#158#255#207#172#158#255#207#172#158 + +#255#207#172#158#255#207#172#158#255#207#172#158#255#207#172#158#255#207#172 + +#158#255'/''$'#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#9#7#7#255 + +#164#136'~'#255#207#172#158#255#207#172#158#255#207#172#158#255#207#172#158 + +#255#207#172#158#255#207#172#158#255#207#172#158#255#207#172#158#255#207#172 + +#158#255#207#172#158#255#207#172#158#255#207#172#158#255#207#172#158#255#207 + +#172#158#255#207#172#158#255#207#172#158#255#207#172#158#255#207#172#158#255 + +#207#172#158#255#207#172#158#255#207#172#158#255#207#172#158#255#207#172#158 + +#255#207#172#158#255#207#172#158#255#207#172#158#255#207#172#158#255#207#172 + +#158#255#207#172#158#255#207#172#158#255#207#172#158#255#207#171#157#255#204 + +#167#151#255#196#153#136#255#183#131'l'#255#160'fK'#255'f;('#255']1'#30#255 + +'[/'#27#199'te^'#3#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0'[/'#27'q\0'#28#255'`6"'#255#130'P9'#255#177'x`'#255#192#146 + +#127#255#203#164#149#255#208#173#159#255#209#175#161#255#209#175#161#255#209 + +#175#161#255#209#175#161#255#209#175#161#255#209#175#161#255#209#175#161#255 + +#209#175#161#255#209#175#161#255#209#175#161#255#209#175#161#255#209#175#161 + +#255#209#175#161#255#209#175#161#255#209#175#161#255#209#175#161#255#209#175 + +#161#255#199#167#153#255#0#0#0#255#0#0#0#255#0#0#0#255'.&#'#255#209#175#161 + +#255#209#175#161#255#209#175#161#255#209#175#161#255#209#175#161#255#209#175 + +#161#255#209#175#161#255#209#175#161#255#209#175#161#255#209#175#161#255#209 + +#175#161#255#209#175#161#255#209#175#161#255#209#175#161#255#209#175#161#255 + +#209#175#161#255'*$!'#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255'"'#28#26#255#197#165#153#255 + +#209#175#161#255#209#175#161#255#209#175#161#255#209#175#161#255#209#175#161 + +#255#209#175#161#255#209#175#161#255#209#175#161#255#209#175#161#255#209#175 + +#161#255#209#175#161#255#209#175#161#255#209#175#161#255#209#175#161#255#209 + +#175#161#255#209#175#161#255#209#175#161#255#209#175#161#255#209#175#161#255 + +#209#175#161#255#209#175#161#255#209#175#161#255#209#175#161#255#209#175#161 + +#255#209#175#161#255#209#175#161#255#209#175#161#255#209#175#161#255#209#175 + +#161#255#209#175#161#255#209#175#161#255#209#174#160#255#207#171#157#255#200 + +#160#144#255#188#139'w'#255#171'pV'#255'rD0'#255'^3'#31#255'\0'#28#250'\2'#30 + +'1'#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0'[/'#27#1'[/'#27#184']1'#30#255'c9&'#255#148'^E'#255#182#128'j'#255#197 + +#154#136#255#206#170#155#255#210#176#163#255#211#178#164#255#211#178#165#255 + +#211#178#165#255#211#178#165#255#211#178#165#255#211#178#165#255#211#178#165 + +#255#211#178#165#255#211#178#165#255#211#178#165#255#211#178#165#255#211#178 + ,#165#255#211#178#165#255#211#178#165#255#211#178#165#255#211#178#165#255#211 + +#178#165#255#12#10#9#255#0#0#0#255#0#0#0#255'MA<'#255#211#178#165#255#211#178 + +#165#255#211#178#165#255#211#178#165#255#211#178#165#255#211#178#165#255#211 + +#178#165#255#211#178#165#255#211#178#165#255#211#178#165#255#211#178#165#255 + +#211#178#165#255#211#178#165#255#211#178#165#255#211#178#165#255#211#178#165 + +#255#211#178#165#255#178#150#139#255'D95'#255#9#7#7#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255'VIC'#255#211#178#165#255#211#178#165 + +#255#211#178#165#255#211#178#165#255#211#178#165#255#211#178#165#255#211#178 + +#165#255#211#178#165#255#211#178#165#255#211#178#165#255#211#178#165#255#211 + +#178#165#255#211#178#165#255#211#178#165#255#211#178#165#255#211#178#165#255 + +#211#178#165#255#211#178#165#255#211#178#165#255#211#178#165#255#211#178#165 + +#255#211#178#165#255#211#178#165#255#211#178#165#255#211#178#165#255#211#178 + +#165#255#211#178#165#255#211#178#165#255#211#178#165#255#211#178#165#255#211 + +#178#165#255#211#178#165#255#211#178#164#255#209#176#162#255#204#167#151#255 + +#193#148#129#255#177'x`'#255#129'P9'#255'`6"'#255'\0'#28#255'[0'#28't'#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0'[/'#27#21'\0'#28#229'^2'#31#255'i?+'#255#163'jP'#255#186#136 + +'s'#255#200#160#144#255#209#174#160#255#212#180#167#255#213#181#169#255#213 + +#181#169#255#213#181#169#255#213#181#169#255#213#181#169#255#213#181#169#255 + +#213#181#169#255#213#181#169#255#213#181#169#255#213#181#169#255#213#181#169 + +#255#213#181#169#255#213#181#169#255#213#181#169#255#213#181#169#255#213#181 + +#169#255'.''%'#255#0#0#0#255',%#'#255#200#170#159#255#213#181#169#255#213#181 + +#169#255#213#181#169#255#213#181#169#255#213#181#169#255#213#181#169#255#213 + +#181#169#255#213#181#169#255#213#181#169#255#213#181#169#255#213#181#169#255 + +#213#181#169#255#213#181#169#255#213#181#169#255#213#181#169#255#213#181#169 + +#255#213#181#169#255#213#181#169#255#213#181#169#255#139'vo'#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255'.''$'#255#213#181#169#255#213#181#169 + +#255#213#181#169#255#213#181#169#255#213#181#169#255#213#181#169#255#213#181 + +#169#255#213#181#169#255#213#181#169#255#213#181#169#255#213#181#169#255#213 + +#181#169#255#213#181#169#255#213#181#169#255#213#181#169#255#213#181#169#255 + +#213#181#169#255#213#181#169#255#213#181#169#255#213#181#169#255#213#181#169 + +#255#213#181#169#255#213#181#169#255#213#181#169#255#213#181#169#255#213#181 + +#169#255#213#181#169#255#213#181#169#255#213#181#169#255#213#181#169#255#213 + +#181#169#255#213#181#169#255#212#180#168#255#211#178#165#255#207#171#157#255 + +#197#155#137#255#182#128'j'#255#148']E'#255'c9&'#255']1'#30#255'[/'#27#179#0 + +#0#0#1#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'[/'#27'?\0'#28#252'_4 '#255'tF1'#255#172 + +'sY'#255#190#142'z'#255#203#165#150#255#211#178#164#255#213#183#170#255#214 + +#184#172#255#214#184#172#255#214#184#172#255#214#184#172#255#214#184#172#255 + +#214#184#172#255#214#184#172#255#214#184#172#255#214#184#172#255#214#184#172 + +#255#214#184#172#255#214#184#172#255#214#184#172#255#214#184#172#255#214#184 + +#172#255#127'ng'#255'{ib'#255#214#184#172#255#214#184#172#255#214#184#172#255 + +#214#184#172#255#214#184#172#255#214#184#172#255#214#184#172#255#214#184#172 + +#255#214#184#172#255#214#184#172#255#214#184#172#255#214#184#172#255#214#184 + +#172#255#214#184#172#255#214#184#172#255#214#184#172#255#214#184#172#255#214 + +#184#172#255#214#184#172#255#214#184#172#255#214#184#172#255' '#28#26#255#0#0 + +#0#255#0#0#0#255#0#0#0#255#0#0#0#255#14#12#11#255#209#180#168#255#214#184#172 + +#255#214#184#172#255#214#184#172#255#214#184#172#255#214#184#172#255#214#184 + +#172#255#214#184#172#255#214#184#172#255#214#184#172#255#214#184#172#255#214 + +#184#172#255#214#184#172#255#214#184#172#255#214#184#172#255#214#184#172#255 + +#214#184#172#255#214#184#172#255#214#184#172#255#214#184#172#255#214#184#172 + +#255#214#184#172#255#214#184#172#255#214#184#172#255#214#184#172#255#214#184 + +#172#255#214#184#172#255#214#184#172#255#214#184#172#255#214#184#172#255#214 + +#184#172#255#214#184#172#255#214#184#172#255#213#182#169#255#209#176#161#255 + +#200#161#143#255#186#135'q'#255#161'gO'#255'h=*'#255'^2'#31#255'\0'#28#226'W' + +'-'#26#19#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'[/'#27'}\1'#29#255'`6"' + +#255'|M8'#255#175'x^'#255#192#147#127#255#205#170#154#255#213#181#169#255#215 + ,#185#173#255#216#187#175#255#216#187#175#255#216#187#175#255#216#187#175#255 + +#216#187#175#255#216#187#175#255#216#187#175#255#216#187#175#255#216#187#175 + +#255#216#187#175#255#216#187#175#255#216#187#175#255#216#187#175#255#216#187 + +#175#255#216#187#175#255#216#187#175#255#216#187#175#255#216#187#175#255#216 + +#187#175#255#216#187#175#255#216#187#175#255#216#187#175#255#216#187#175#255 + +#216#187#175#255#216#187#175#255#216#187#175#255#216#187#175#255#216#187#175 + +#255#216#187#175#255#216#187#175#255#216#187#175#255#216#187#175#255#216#187 + +#175#255#216#187#175#255#216#187#175#255#216#187#175#255#187#162#151#255#0#0 + +#0#255#0#0#0#255#0#0#0#255#0#0#0#255#2#2#2#255#180#156#146#255#216#187#175 + +#255#216#187#175#255#216#187#175#255#216#187#175#255#216#187#175#255#216#187 + +#175#255#216#187#175#255#216#187#175#255#216#187#175#255#216#187#175#255#216 + +#187#175#255#216#187#175#255#216#187#175#255#216#187#175#255#216#187#175#255 + +#216#187#175#255#216#187#175#255#216#187#175#255#216#187#175#255#216#187#175 + +#255#216#187#175#255#216#187#175#255#216#187#175#255#216#187#175#255#216#187 + +#175#255#216#187#175#255#216#187#175#255#216#187#175#255#216#187#175#255#216 + +#187#175#255#216#187#175#255#216#187#175#255#215#185#173#255#211#179#166#255 + +#202#165#148#255#188#139'w'#255#167'mU'#255'nC/'#255'^3'#31#255'\0'#28#251'Z' + +'.'#27';'#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'[/'#27#2'[/'#27 + +#170'\1'#29#255'a7$'#255#130'Q<'#255#178'{c'#255#195#151#132#255#208#173#159 + +#255#215#185#173#255#217#189#178#255#217#189#178#255#217#189#178#255#217#189 + +#178#255#217#189#178#255#217#189#178#255#217#189#178#255#217#189#178#255#217 + +#189#178#255#217#189#178#255#217#189#178#255#217#189#178#255#217#189#178#255 + +#217#189#178#255#217#189#178#255#217#189#178#255#217#189#178#255#217#189#178 + +#255#217#189#178#255#217#189#178#255#217#189#178#255#217#189#178#255#217#189 + +#178#255#217#189#178#255#217#189#178#255#217#189#178#255#217#189#178#255#217 + +#189#178#255#217#189#178#255#217#189#178#255#217#189#178#255#217#189#178#255 + +#217#189#178#255#217#189#178#255#217#189#178#255#217#189#178#255'.(&'#255#0#0 + +#0#255#0#0#0#255#0#0#0#255#0#0#0#255#128'oi'#255#217#189#178#255#217#189#178 + +#255#217#189#178#255#217#189#178#255#217#189#178#255#217#189#178#255#217#189 + +#178#255#217#189#178#255#217#189#178#255#217#189#178#255#217#189#178#255#217 + +#189#178#255#217#189#178#255#217#189#178#255#217#189#178#255#217#189#178#255 + +#217#189#178#255#217#189#178#255#217#189#178#255#217#189#178#255#217#189#178 + +#255#217#189#178#255#217#189#178#255#217#189#178#255#217#189#178#255#217#189 + +#178#255#217#189#178#255#217#189#178#255#217#189#178#255#217#189#178#255#217 + +#189#178#255#217#189#178#255#217#188#177#255#213#183#170#255#205#168#153#255 + +#191#144'|'#255#170'rZ'#255'sF2'#255'`5!'#255'\0'#28#255'Z/'#27'g'#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'[/'#27#6'[/'#27 + +#188']1'#30#255'c9&'#255#136'V?'#255#180'~g'#255#197#154#136#255#209#176#162 + +#255#216#187#176#255#219#192#181#255#219#192#182#255#219#193#183#255#219#193 + +#183#255#219#193#183#255#219#193#183#255#219#193#183#255#219#193#183#255#219 + +#193#183#255#219#193#183#255#219#193#183#255#219#193#183#255#219#193#183#255 + +#219#193#183#255#219#193#183#255#219#193#183#255#219#193#183#255#219#193#183 + +#255#219#193#183#255#219#193#183#255#219#193#183#255#219#193#183#255#219#193 + +#183#255#219#193#183#255#219#193#183#255#219#193#183#255#219#193#183#255#219 + +#193#183#255#219#193#183#255#219#193#183#255#219#193#183#255#219#193#183#255 + +#219#193#183#255#219#193#183#255#158#138#131#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#1#1#1#255#131'sm'#255#219#193#183#255#219#193#183#255#219#193#183#255 + +#219#193#183#255#219#193#183#255#219#193#183#255#219#193#183#255#219#193#183 + +#255#219#193#183#255#219#193#183#255#219#193#183#255#219#193#183#255#219#193 + +#183#255#219#193#183#255#219#193#183#255#219#193#183#255#219#193#183#255#219 + +#193#183#255#219#193#183#255#219#193#183#255#219#193#183#255#219#193#183#255 + +#219#193#183#255#219#193#183#255#219#193#183#255#219#193#183#255#219#193#183 + +#255#219#193#183#255#219#193#183#255#219#193#183#255#219#193#183#255#219#192 + +#182#255#218#191#180#255#215#185#173#255#207#172#156#255#193#147#128#255#174 + +'v^'#255'wJ6'#255'`6"'#255'\1'#29#255'[/'#27'~'#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + ,#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'[/'#27#12'[/'#27#203 + +']1'#30#255'c:'''#255#141'YC'#255#181#128'h'#255#198#155#138#255#210#177#164 + +#255#217#190#178#255#220#194#184#255#221#195#185#255#221#196#186#255#221#196 + +#186#255#221#196#186#255#221#196#186#255#221#196#186#255#221#196#186#255#221 + +#196#186#255#221#196#186#255#221#196#186#255#221#196#186#255#221#196#186#255 + +#221#196#186#255#221#196#186#255#221#196#186#255#221#196#186#255#221#196#186 + +#255#221#196#186#255#221#196#186#255#221#196#186#255#221#196#186#255#221#196 + +#186#255#221#196#186#255#221#196#186#255#221#196#186#255#221#196#186#255#221 + +#196#186#255#221#196#186#255#221#196#186#255#221#196#186#255#221#196#186#255 + +#221#196#186#255're_'#255#0#0#0#255#0#0#0#255#4#4#4#255#160#142#134#255#221 + +#196#186#255#221#196#186#255#221#196#186#255#221#196#186#255#221#196#186#255 + +#221#196#186#255#221#196#186#255#221#196#186#255#221#196#186#255#221#196#186 + +#255#221#196#186#255#221#196#186#255#221#196#186#255#221#196#186#255#221#196 + +#186#255#221#196#186#255#221#196#186#255#221#196#186#255#221#196#186#255#221 + +#196#186#255#221#196#186#255#221#196#186#255#221#196#186#255#221#196#186#255 + +#221#196#186#255#221#196#186#255#221#196#186#255#221#196#186#255#221#196#186 + +#255#221#196#186#255#221#196#186#255#221#195#185#255#219#193#183#255#216#187 + +#175#255#207#172#158#255#194#148#130#255#176'x_'#255'{M8'#255'a6#'#255'\1'#29 + +#255'[/'#27#148#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'[/'#27#21'\0'#28#217']1'#30#255'c:''' + +#255#138'XB'#255#181#127'h'#255#197#156#137#255#211#178#164#255#218#191#180 + +#255#221#196#187#255#222#198#188#255#223#198#189#255#223#198#189#255#223#198 + +#189#255#223#198#189#255#223#198#189#255#223#198#189#255#223#198#189#255#223 + +#198#189#255#223#198#189#255#223#198#189#255#223#198#189#255#223#198#189#255 + +#223#198#189#255#223#198#189#255#223#198#189#255#223#198#189#255#223#198#189 + +#255#223#198#189#255#223#198#189#255#223#198#189#255#223#198#189#255#223#198 + +#189#255#223#198#189#255#223#198#189#255#223#198#189#255#223#198#189#255#223 + +#198#189#255#223#198#189#255#223#198#189#255#223#198#189#255#221#196#187#255 + +#6#6#5#255#10#9#8#255#188#167#159#255#223#198#189#255#223#198#189#255#223#198 + +#189#255#223#198#189#255#223#198#189#255#223#198#189#255#223#198#189#255#223 + +#198#189#255#223#198#189#255#223#198#189#255#223#198#189#255#223#198#189#255 + +#223#198#189#255#223#198#189#255#223#198#189#255#223#198#189#255#223#198#189 + +#255#223#198#189#255#223#198#189#255#223#198#189#255#223#198#189#255#223#198 + +#189#255#223#198#189#255#223#198#189#255#223#198#189#255#223#198#189#255#223 + +#198#189#255#223#198#189#255#223#198#189#255#223#198#189#255#223#198#189#255 + +#222#198#188#255#221#196#186#255#217#188#177#255#208#173#159#255#193#149#129 + +#255#174'w^'#255'zM8'#255'a7$'#255'\1'#29#255'[/'#27#170'[/'#27#2#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0'[/'#27' \0'#28#223']1'#30#255'c:'''#255#132'T?'#255#180 + +'~g'#255#197#155#136#255#211#178#164#255#219#193#181#255#223#198#189#255#224 + +#201#192#255#224#201#192#255#224#201#192#255#224#201#192#255#224#201#192#255 + +#224#201#192#255#224#201#192#255#224#201#192#255#224#201#192#255#224#201#192 + +#255#224#201#192#255#224#201#192#255#224#201#192#255#224#201#192#255#224#201 + +#192#255#224#201#192#255#224#201#192#255#224#201#192#255#224#201#192#255#224 + +#201#192#255#224#201#192#255#224#201#192#255#224#201#192#255#224#201#192#255 + +#224#201#192#255#224#201#192#255#224#201#192#255#224#201#192#255#224#201#192 + +#255#224#201#192#255#224#201#192#255#134'xr'#255#205#184#176#255#224#201#192 + +#255#224#201#192#255#224#201#192#255#224#201#192#255#224#201#192#255#224#201 + +#192#255#224#201#192#255#224#201#192#255#224#201#192#255#224#201#192#255#224 + +#201#192#255#224#201#192#255#224#201#192#255#224#201#192#255#224#201#192#255 + +#224#201#192#255#224#201#192#255#224#201#192#255#224#201#192#255#224#201#192 + +#255#224#201#192#255#224#201#192#255#224#201#192#255#224#201#192#255#224#201 + +#192#255#224#201#192#255#224#201#192#255#224#201#192#255#224#201#192#255#224 + +#201#192#255#224#201#192#255#223#200#191#255#222#197#187#255#217#189#178#255 + +#207#172#158#255#192#147#127#255#171'u\'#255'vI6'#255'a6#'#255'\1'#29#255'[/' + +#27#179'[/'#27#6#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + ,#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'[/'#27#25'\' + +'0'#28#209']1'#30#255'c9&'#255#128'Q='#255#177'{c'#255#195#151#133#255#209 + +#176#162#255#219#192#181#255#223#200#191#255#225#203#194#255#226#204#196#255 + +#226#204#196#255#226#204#196#255#226#204#196#255#226#204#196#255#226#204#196 + +#255#226#204#196#255#226#204#196#255#226#204#196#255#226#204#196#255#226#204 + +#196#255#226#204#196#255#226#204#196#255#226#204#196#255#226#204#196#255#226 + +#204#196#255#226#204#196#255#226#204#196#255#226#204#196#255#226#204#196#255 + +#226#204#196#255#226#204#196#255#226#204#196#255#226#204#196#255#226#204#196 + +#255#226#204#196#255#226#204#196#255#226#204#196#255#226#204#196#255#226#204 + +#196#255#226#204#196#255#226#204#196#255#226#204#196#255#226#204#196#255#226 + +#204#196#255#226#204#196#255#226#204#196#255#226#204#196#255#226#204#196#255 + +#226#204#196#255#226#204#196#255#226#204#196#255#226#204#196#255#226#204#196 + +#255#226#204#196#255#226#204#196#255#226#204#196#255#226#204#196#255#226#204 + +#196#255#226#204#196#255#226#204#196#255#226#204#196#255#226#204#196#255#226 + +#204#196#255#226#204#196#255#226#204#196#255#226#204#196#255#226#204#196#255 + +#226#204#196#255#226#204#196#255#226#203#195#255#225#202#193#255#222#198#188 + +#255#217#188#177#255#206#169#155#255#191#144'|'#255#168'qY'#255'rG3'#255'`6"' + +#255'\1'#29#255'[/'#27#159'[/'#27#4#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0'[/'#27#15'\0'#28#193']1'#30#255'b8%'#255'yM8'#255#170 + +'u\'#255#192#146'~'#255#207#171#156#255#217#189#178#255#223#200#191#255#226 + +#205#197#255#227#206#198#255#228#207#199#255#228#207#199#255#228#207#199#255 + +#228#207#199#255#228#207#199#255#228#207#199#255#228#207#199#255#228#207#199 + +#255#228#207#199#255#228#207#199#255#228#207#199#255#228#207#199#255#228#207 + +#199#255#228#207#199#255#228#207#199#255#228#207#199#255#228#207#199#255#228 + +#207#199#255#228#207#199#255#228#207#199#255#228#207#199#255#228#207#199#255 + +#228#207#199#255#228#207#199#255#228#207#199#255#228#207#199#255#228#207#199 + +#255#228#207#199#255#228#207#199#255#228#207#199#255#228#207#199#255#228#207 + +#199#255#228#207#199#255#228#207#199#255#228#207#199#255#228#207#199#255#228 + +#207#199#255#228#207#199#255#228#207#199#255#228#207#199#255#228#207#199#255 + +#228#207#199#255#228#207#199#255#228#207#199#255#228#207#199#255#228#207#199 + +#255#228#207#199#255#228#207#199#255#228#207#199#255#228#207#199#255#228#207 + +#199#255#228#207#199#255#228#207#199#255#228#207#199#255#228#207#199#255#228 + +#207#199#255#228#207#199#255#227#206#198#255#226#204#196#255#222#198#188#255 + +#215#185#173#255#202#165#148#255#187#137'u'#255#159'jR'#255'nD0'#255'`6"'#255 + +'\1'#29#255'[/'#27#137#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'[/'#27#8'[/'#27#175'\1'#29#255'`6"'#255'n' + +'D0'#255#158'iR'#255#187#137'u'#255#202#165#148#255#215#186#174#255#223#199 + +#190#255#227#205#198#255#229#208#201#255#229#209#202#255#229#210#202#255#229 + +#210#202#255#229#210#202#255#229#210#202#255#229#210#202#255#229#210#202#255 + +#229#210#202#255#229#210#202#255#229#210#202#255#229#210#202#255#229#210#202 + +#255#229#210#202#255#229#210#202#255#229#210#202#255#229#210#202#255#229#210 + +#202#255#229#210#202#255#229#210#202#255#229#210#202#255#229#210#202#255#229 + +#210#202#255#229#210#202#255#229#210#202#255#229#210#202#255#229#210#202#255 + +#229#210#202#255#229#210#202#255#229#210#202#255#229#210#202#255#229#210#202 + +#255#229#210#202#255#229#210#202#255#229#210#202#255#229#210#202#255#229#210 + +#202#255#229#210#202#255#229#210#202#255#229#210#202#255#229#210#202#255#229 + +#210#202#255#229#210#202#255#229#210#202#255#229#210#202#255#229#210#202#255 + +#229#210#202#255#229#210#202#255#229#210#202#255#229#210#202#255#229#210#202 + +#255#229#210#202#255#229#210#202#255#229#210#202#255#229#210#202#255#229#209 + +#202#255#228#207#201#255#226#204#197#255#221#196#187#255#212#180#168#255#198 + +#157#140#255#183#130'l'#255#143'^G'#255'g>+'#255'_4 '#255'\1'#29#254'[/'#27 + +'q'#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + ,#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'[/'#27#3'[/'#27#132'\1'#29#254'_4 '#255'g>+' + +#255#140'[F'#255#181#129'j'#255#198#155#138#255#211#178#165#255#221#195#185 + +#255#227#204#197#255#230#209#203#255#230#212#205#255#231#212#206#255#231#212 + +#206#255#231#212#206#255#231#212#206#255#231#212#206#255#231#212#206#255#231 + +#212#206#255#231#212#206#255#231#212#206#255#231#212#206#255#231#212#206#255 + +#231#212#206#255#231#212#206#255#231#212#206#255#231#212#206#255#231#212#206 + +#255#231#212#206#255#231#212#206#255#231#212#206#255#231#212#206#255#231#212 + +#206#255#231#212#206#255#231#212#206#255#231#212#206#255#231#212#206#255#231 + +#212#206#255#231#212#206#255#231#212#206#255#231#212#206#255#231#212#206#255 + +#231#212#206#255#231#212#206#255#231#212#206#255#231#212#206#255#231#212#206 + +#255#231#212#206#255#231#212#206#255#231#212#206#255#231#212#206#255#231#212 + +#206#255#231#212#206#255#231#212#206#255#231#212#206#255#231#212#206#255#231 + +#212#206#255#231#212#206#255#231#212#206#255#231#212#206#255#231#212#206#255 + +#231#212#206#255#231#211#206#255#230#211#205#255#229#209#201#255#225#203#194 + +#255#219#191#181#255#208#173#159#255#193#149#129#255#173'w`'#255'~Q='#255'c:' + +''''#255'^2'#31#255'\0'#28#238'[/'#27'O'#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0'[/'#27'F\0'#28#234'^2'#31#255'c:'''#255'zN:'#255#168's['#255 + +#190#143'{'#255#205#167#152#255#217#187#177#255#225#201#193#255#229#209#202 + +#255#232#213#207#255#232#214#209#255#233#215#210#255#233#215#210#255#233#215 + +#210#255#233#215#210#255#233#215#210#255#233#215#210#255#233#215#210#255#233 + +#215#210#255#233#215#210#255#233#215#210#255#233#215#210#255#233#215#210#255 + +#233#215#210#255#233#215#210#255#233#215#210#255#233#215#210#255#233#215#210 + +#255#233#215#210#255#233#215#210#255#233#215#210#255#233#215#210#255#233#215 + +#210#255#233#215#210#255#233#215#210#255#233#215#210#255#233#215#210#255#233 + +#215#210#255#233#215#210#255#233#215#210#255#233#215#210#255#233#215#210#255 + +#233#215#210#255#233#215#210#255#233#215#210#255#233#215#210#255#233#215#210 + +#255#233#215#210#255#233#215#210#255#233#215#210#255#233#215#210#255#233#215 + +#210#255#233#215#210#255#233#215#210#255#233#215#210#255#233#215#210#255#233 + +#215#210#255#232#215#209#255#232#214#208#255#231#212#206#255#228#207#201#255 + +#223#198#189#255#213#182#170#255#200#160#144#255#186#136'r'#255#158'iR'#255 + +'pE2'#255'a7$'#255']1'#30#255'\0'#28#201'[/'#27#31#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'[/'#27#26'\0'#28#193']1'#30#255'`' + +'6"'#255'iA.'#255#142']H'#255#179#128'h'#255#196#153#135#255#210#176#163#255 + +#220#194#184#255#227#205#198#255#231#212#206#255#233#216#211#255#234#217#212 + +#255#234#218#213#255#234#218#213#255#234#218#213#255#234#218#213#255#234#218 + +#213#255#234#218#213#255#234#218#213#255#234#218#213#255#234#218#213#255#234 + +#218#213#255#234#218#213#255#234#218#213#255#234#218#213#255#234#218#213#255 + +#234#218#213#255#234#218#213#255#234#218#213#255#234#218#213#255#234#218#213 + +#255#234#218#213#255#234#218#213#255#234#218#213#255#234#218#213#255#234#218 + +#213#255#234#218#213#255#234#218#213#255#234#218#213#255#234#218#213#255#234 + +#218#213#255#234#218#213#255#234#218#213#255#234#218#213#255#234#218#213#255 + +#234#218#213#255#234#218#213#255#234#218#213#255#234#218#213#255#234#218#213 + +#255#234#218#213#255#234#218#213#255#234#218#213#255#234#218#213#255#234#217 + +#212#255#234#216#211#255#233#215#210#255#230#211#205#255#226#203#195#255#218 + +#190#179#255#206#170#155#255#192#146#127#255#172'v`'#255#129'S?'#255'e<)'#255 + +'_4 '#255'\1'#29#255'[/'#27#143'[/'#27#5#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'[/'#27#3'[/'#27#127'\0'#28 + +#248'^3'#31#255'c:'''#255'sI6'#255#158'kT'#255#186#136's'#255#200#160#143#255 + ,#213#180#169#255#222#197#187#255#229#208#201#255#232#214#209#255#234#218#213 + +#255#235#219#215#255#236#220#215#255#236#220#216#255#236#220#216#255#236#220 + +#216#255#236#220#216#255#236#220#216#255#236#220#216#255#236#220#216#255#236 + +#220#216#255#236#220#216#255#236#220#216#255#236#220#216#255#236#220#216#255 + +#236#220#216#255#236#220#216#255#236#220#216#255#236#220#216#255#236#220#216 + +#255#236#220#216#255#236#220#216#255#236#220#216#255#236#220#216#255#236#220 + +#216#255#236#220#216#255#236#220#216#255#236#220#216#255#236#220#216#255#236 + +#220#216#255#236#220#216#255#236#220#216#255#236#220#216#255#236#220#216#255 + +#236#220#216#255#236#220#216#255#236#220#216#255#236#220#216#255#236#220#216 + +#255#236#220#216#255#236#220#215#255#235#219#215#255#234#217#212#255#232#213 + +#207#255#227#205#198#255#219#193#183#255#209#176#162#255#196#153#136#255#181 + +#129'l'#255#145'`K'#255'lB0'#255'a7$'#255']1'#30#255'\0'#28#231'[/'#27'O'#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'[/'#27'$\0'#28#185'\1'#29#255'`5!'#255 + +'f=*'#255#128'S>'#255#166'r['#255#188#139'v'#255#201#161#145#255#213#181#169 + +#255#223#197#189#255#229#209#202#255#233#216#210#255#235#219#215#255#236#221 + +#217#255#237#222#219#255#238#223#220#255#238#223#220#255#238#223#220#255#238 + +#223#220#255#238#223#220#255#238#223#220#255#238#223#220#255#238#223#220#255 + +#238#223#220#255#238#223#220#255#238#223#220#255#238#223#220#255#238#223#220 + +#255#238#223#220#255#238#223#220#255#238#223#220#255#238#223#220#255#238#223 + +#220#255#238#223#220#255#238#223#220#255#238#223#220#255#238#223#220#255#238 + +#223#220#255#238#223#220#255#238#223#220#255#238#223#220#255#238#223#220#255 + +#238#223#220#255#238#223#220#255#238#223#220#255#238#223#220#255#238#223#220 + +#255#237#222#219#255#237#222#218#255#236#221#217#255#235#218#214#255#232#214 + +#208#255#228#206#199#255#220#193#184#255#210#176#163#255#197#155#137#255#184 + +#134'o'#255#155'iR'#255'uI7'#255'c:'''#255'^3'#31#255'\1'#29#252'[/'#27#144 + +'[/'#27#14#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'[' + +'/'#27'U\0'#28#228']1'#30#255'`6"'#255'g>,'#255#127'R?'#255#164'qZ'#255#188 + +#139'v'#255#200#159#144#255#211#179#166#255#220#194#184#255#228#206#199#255 + +#232#214#209#255#235#219#215#255#237#222#219#255#238#225#221#255#239#225#222 + +#255#239#225#222#255#239#226#223#255#239#226#223#255#239#226#223#255#239#226 + +#223#255#239#226#223#255#239#226#223#255#239#226#223#255#239#226#223#255#239 + +#226#223#255#239#226#223#255#239#226#223#255#239#226#223#255#239#226#223#255 + +#239#226#223#255#239#226#223#255#239#226#223#255#239#226#223#255#239#226#223 + +#255#239#226#223#255#239#226#223#255#239#226#223#255#239#226#223#255#239#226 + +#223#255#239#226#223#255#239#226#223#255#239#225#222#255#238#225#221#255#238 + +#224#220#255#237#222#218#255#235#218#214#255#231#212#206#255#226#203#195#255 + +#218#191#180#255#209#174#160#255#197#154#136#255#184#132'o'#255#154'hR'#255 + +'uK8'#255'e;('#255'_4 '#255'\1'#29#255'\0'#28#197'[/'#27'/'#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'[/'#27 + +#12'[/'#27#134'\0'#28#242'^2'#31#255'a5#'#255'g>+'#255'|Q='#255#160'lV'#255 + +#184#133'p'#255#196#152#134#255#207#170#156#255#216#187#175#255#224#200#192 + +#255#230#210#203#255#234#216#211#255#236#220#216#255#238#224#220#255#239#226 + +#223#255#240#227#225#255#240#228#225#255#240#228#225#255#241#229#226#255#241 + +#229#226#255#241#229#226#255#241#229#226#255#241#229#227#255#241#229#227#255 + +#241#229#227#255#241#229#227#255#241#229#227#255#241#229#227#255#241#229#227 + +#255#241#229#227#255#241#229#227#255#241#229#226#255#241#229#226#255#241#229 + ,#226#255#241#229#226#255#240#228#225#255#240#228#225#255#240#227#224#255#239 + +#225#222#255#238#223#220#255#236#220#215#255#233#215#210#255#228#207#201#255 + +#222#196#187#255#213#183#170#255#204#166#150#255#192#147#127#255#179#127'i' + +#255#150'fO'#255'tI7'#255'e;('#255'`5!'#255']1'#30#255'\0'#28#223'[/'#27'`[/' + +#27#1#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'[/'#27#17'[/'#27#127'\0'#28#238']1' + +#30#255'`6"'#255'e<)'#255'rI6'#255#142'_J'#255#170'wa'#255#188#140'w'#255#199 + +#158#141#255#208#173#159#255#216#186#175#255#222#196#187#255#227#206#198#255 + +#232#213#208#255#235#219#214#255#237#222#218#255#238#224#220#255#239#226#223 + +#255#240#227#225#255#241#229#226#255#242#230#228#255#242#230#228#255#242#231 + +#229#255#242#231#229#255#242#231#229#255#242#231#229#255#242#231#229#255#242 + +#231#229#255#242#231#229#255#242#230#228#255#241#229#227#255#241#229#226#255 + +#240#227#225#255#239#225#222#255#238#224#220#255#236#221#217#255#234#218#213 + +#255#231#211#206#255#226#204#196#255#220#194#184#255#214#183#171#255#206#169 + +#155#255#196#153#135#255#185#135'r'#255#162'q['#255#134'XD'#255'lC1'#255'c:' + +''''#255'_4 '#255']0'#30#255'\0'#28#217'[/'#27'`[/'#27#4#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'[/'#27#13'[/'#27'w\0'#28#233 + +']1'#30#255'_4 '#255'b8%'#255'h?-'#255'zN;'#255#149'dP'#255#170'xa'#255#187 + +#137't'#255#194#150#131#255#202#164#148#255#210#176#163#255#216#187#175#255 + +#220#194#184#255#224#200#192#255#228#207#199#255#231#212#206#255#234#217#211 + +#255#236#220#215#255#236#222#217#255#237#222#219#255#238#223#220#255#238#223 + +#220#255#238#224#220#255#238#223#220#255#237#223#219#255#237#223#218#255#236 + +#221#217#255#235#219#215#255#233#216#210#255#230#211#204#255#227#204#197#255 + +#223#199#190#255#219#192#183#255#215#185#173#255#208#173#159#255#200#160#144 + +#255#192#146#127#255#183#133'o'#255#164's\'#255#142']J'#255'rI7'#255'f=*'#255 + +'a6#'#255'^3'#31#255'\1'#29#255'\0'#28#210'[/'#27'X[/'#27#2#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0'[/'#27#5'[/'#27'P\0'#28#173'\1'#29#249']1'#30#255'`5!'#255'c9&'#255'g' + +'>,'#255'qH6'#255#133'YE'#255#153'iT'#255#172'yd'#255#186#136'q'#255#191#144 + +'}'#255#196#153#136#255#202#162#146#255#207#171#156#255#211#178#165#255#214 + +#183#171#255#216#186#175#255#217#188#177#255#218#190#179#255#219#191#182#255 + +#219#192#182#255#219#192#181#255#218#189#179#255#217#187#177#255#215#185#173 + +#255#213#182#169#255#210#176#163#255#205#169#154#255#200#160#144#255#195#151 + +#133#255#190#142'z'#255#183#132'o'#255#167'u_'#255#148'eP'#255#127'S@'#255'm' + +'E2'#255'f=*'#255'b7%'#255'_4 '#255']1'#30#255'\0'#28#235'[/'#27#147'[/'#27 + +'5'#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'[' + ,'/'#27#18'[/'#27'i\0'#28#199'\1'#29#254']1'#30#255'_4 '#255'a6#'#255'd9('#255 + +'g>,'#255'oF3'#255'}Q>'#255#138'[G'#255#149'fQ'#255#160'oZ'#255#170'xa'#255 + +#176'}h'#255#180#128'l'#255#183#133'p'#255#186#136's'#255#188#138'u'#255#188 + +#139'v'#255#187#138'u'#255#186#135'r'#255#183#132'n'#255#178#128'j'#255#174 + +'|e'#255#168'v`'#255#158'mW'#255#146'bN'#255#133'YE'#255'yM;'#255'mC1'#255'g' + +'>+'#255'c9&'#255'`6"'#255'^3'#31#255']1'#30#255'\0'#28#248'\0'#28#173'[/'#27 + +'O[/'#27#5#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'[/'#27#20'[/'#27'V\0'#28#153 + +'\0'#28#220'\1'#29#255']1'#30#255'^3'#31#255'`5!'#255'a7$'#255'c9&'#255'e;(' + +#255'f=*'#255'g>,'#255'i@.'#255'jB0'#255'mE2'#255'qH5'#255'tJ7'#255'qG5'#255 + +'lC1'#255'jA0'#255'h?-'#255'g>+'#255'e<)'#255'd:('#255'c9&'#255'a6#'#255'`5!' + +#255'^2'#31#255']1'#30#255'\1'#29#252'\0'#28#201'[/'#27#134'[/'#27'C[/'#27#8 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0'[/'#27#31'[/'#27'_[/'#27#138'\0'#28#176'\0'#28#213'\0'#28 + +#248'\1'#29#255'\1'#29#255'\1'#29#255']1'#30#255'^2'#31#255'^2'#31#255'^3'#31 + +#255'^3'#31#255'^3'#31#255'^2'#31#255']1'#30#255']1'#30#255'\1'#29#255'\1'#29 + +#255'\1'#29#255'\0'#28#241'\0'#28#203'\0'#28#165'[/'#27#127'[/'#27'N[/'#27#15 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0'[/'#27#2'[/'#27'![/'#27'E[/'#27'U[/'#27'a[/'#27'm[/'#27'y[/'#27 + +#134'\0'#29#141'[/'#27#130'[/'#27'v[/'#27'j[/'#27'^[/'#27'Q[/'#27'=[/'#27#23 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + ,#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#255#255#255#255#255#255#255#128#0#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#224#0#0#3#255#255#255#255#255 + +#255#255#255#255#255#255#254#0#0#0#0'?'#255#255#255#255#255#255#255#255#255 + +#255#240#0#0#0#0#7#255#255#255#255#255#255#255#255#255#255#128#0#0#0#0#0#255 + +#255#255#255#255#255#255#255#255#254#0#0#0#0#0#0'?'#255#255#255#255#255#255 + +#255#255#248#0#0#0#0#0#0#15#255#255#255#255#255#255#255#255#224#0#0#0#0#0#0#3 + +#255#255#255#255#255#255#255#255#128#0#0#0#0#0#0#0#255#255#255#255#255#255 + +#255#254#0#0#0#0#0#0#0#0'?'#255#255#255#255#255#255#252#0#0#0#0#0#0#0#0#31 + +#255#255#255#255#255#255#240#0#0#0#0#0#0#0#0#7#255#255#255#255#255#255#224#0 + +#0#0#0#0#0#0#0#3#255#255#255#255#255#255#128#0#0#0#0#0#0#0#0#1#255#255#255 + +#255#255#255#0#0#0#0#0#0#0#0#0#0#127#255#255#255#255#254#0#0#0#0#0#0#0#0#0#0 + +'?'#255#255#255#255#252#0#0#0#0#0#0#0#0#0#0#31#255#255#255#255#248#0#0#0#0#0 + +#0#0#0#0#0#15#255#255#255#255#240#0#0#0#0#0#0#0#0#0#0#7#255#255#255#255#224#0 + +#0#0#0#0#0#0#0#0#0#3#255#255#255#255#192#0#0#0#0#0#0#0#0#0#0#1#255#255#255 + +#255#128#0#0#0#0#0#0#0#0#0#0#0#255#255#255#255#0#0#0#0#0#0#0#0#0#0#0#0#127 + +#255#255#254#0#0#0#0#0#0#0#0#0#0#0#0#127#255#255#254#0#0#0#0#0#0#0#0#0#0#0#0 + +'?'#255#255#252#0#0#0#0#0#0#0#0#0#0#0#0#31#255#255#248#0#0#0#0#0#0#0#0#0#0#0 + +#0#15#255#255#240#0#0#0#0#0#0#0#0#0#0#0#0#7#255#255#240#0#0#0#0#0#0#0#0#0#0#0 + +#0#7#255#255#224#0#0#0#0#0#0#0#0#0#0#0#0#3#255#255#192#0#0#0#0#0#0#0#0#0#0#0 + +#0#3#255#255#192#0#0#0#0#0#0#0#0#0#0#0#0#1#255#255#128#0#0#0#0#0#0#0#0#0#0#0 + +#0#1#255#255#128#0#0#0#0#0#0#0#0#0#0#0#0#0#255#255#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#255#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0#127#254#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#127#254#0#0#0#0#0#0#0#0#0#0#0#0#0#0'?'#254#0#0#0#0#0#0#0#0#0#0#0#0#0#0'?' + +#252#0#0#0#0#0#0#0#0#0#0#0#0#0#0'?'#252#0#0#0#0#0#0#0#0#0#0#0#0#0#0#31#252#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#31#248#0#0#0#0#0#0#0#0#0#0#0#0#0#0#15#248#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#15#248#0#0#0#0#0#0#0#0#0#0#0#0#0#0#15#240#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#7#240#0#0#0#0#0#0#0#0#0#0#0#0#0#0#7#240#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#7#224#0#0#0#0#0#0#0#0#0#0#0#0#0#0#7#224#0#0#0#0#0#0#0#0#0#0#0#0#0#0#3 + +#224#0#0#0#0#0#0#0#0#0#0#0#0#0#0#3#224#0#0#0#0#0#0#0#0#0#0#0#0#0#0#3#224#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#3#224#0#0#0#0#0#0#0#0#0#0#0#0#0#0#3#192#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#3#192#0#0#0#0#0#0#0#0#0#0#0#0#0#0#3#192#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#1#192#0#0#0#0#0#0#0#0#0#0#0#0#0#0#1#192#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#1#192#0#0#0#0#0#0#0#0#0#0#0#0#0#0#1#192#0#0#0#0#0#0#0#0#0#0#0#0#0#0#1#192#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#1#192#0#0#0#0#0#0#0#0#0#0#0#0#0#0#1#192#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#1#192#0#0#0#0#0#0#0#0#0#0#0#0#0#0#1#192#0#0#0#0#0#0#0#0#0 + ,#0#0#0#0#0#1#192#0#0#0#0#0#0#0#0#0#0#0#0#0#0#3#192#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#3#224#0#0#0#0#0#0#0#0#0#0#0#0#0#0#3#224#0#0#0#0#0#0#0#0#0#0#0#0#0#0#3#224 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#3#224#0#0#0#0#0#0#0#0#0#0#0#0#0#0#3#224#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#3#240#0#0#0#0#0#0#0#0#0#0#0#0#0#0#7#240#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#7#240#0#0#0#0#0#0#0#0#0#0#0#0#0#0#7#240#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#15#248#0#0#0#0#0#0#0#0#0#0#0#0#0#0#15#248#0#0#0#0#0#0#0#0#0#0#0#0#0#0#15 + +#248#0#0#0#0#0#0#0#0#0#0#0#0#0#0#15#252#0#0#0#0#0#0#0#0#0#0#0#0#0#0#31#252#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#31#252#0#0#0#0#0#0#0#0#0#0#0#0#0#0'?'#254#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0'?'#254#0#0#0#0#0#0#0#0#0#0#0#0#0#0'?'#254#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#127#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0#127#255#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#255#255#128#0#0#0#0#0#0#0#0#0#0#0#0#0#255#255#128#0#0#0#0#0#0#0#0 + +#0#0#0#0#1#255#255#128#0#0#0#0#0#0#0#0#0#0#0#0#1#255#255#192#0#0#0#0#0#0#0#0 + +#0#0#0#0#3#255#255#192#0#0#0#0#0#0#0#0#0#0#0#0#3#255#255#224#0#0#0#0#0#0#0#0 + +#0#0#0#0#7#255#255#224#0#0#0#0#0#0#0#0#0#0#0#0#15#255#255#240#0#0#0#0#0#0#0#0 + +#0#0#0#0#15#255#255#248#0#0#0#0#0#0#0#0#0#0#0#0#31#255#255#248#0#0#0#0#0#0#0 + +#0#0#0#0#0'?'#255#255#252#0#0#0#0#0#0#0#0#0#0#0#0#127#255#255#252#0#0#0#0#0#0 + +#0#0#0#0#0#0#255#255#255#254#0#0#0#0#0#0#0#0#0#0#0#0#255#255#255#255#0#0#0#0 + +#0#0#0#0#0#0#0#1#255#255#255#255#128#0#0#0#0#0#0#0#0#0#0#3#255#255#255#255 + +#128#0#0#0#0#0#0#0#0#0#0#7#255#255#255#255#192#0#0#0#0#0#0#0#0#0#0#15#255#255 + +#255#255#224#0#0#0#0#0#0#0#0#0#0#31#255#255#255#255#240#0#0#0#0#0#0#0#0#0#0 + +#31#255#255#255#255#248#0#0#0#0#0#0#0#0#0#0'?'#255#255#255#255#252#0#0#0#0#0 + +#0#0#0#0#0#127#255#255#255#255#254#0#0#0#0#0#0#0#0#0#1#255#255#255#255#255 + +#255#0#0#0#0#0#0#0#0#0#3#255#255#255#255#255#255#128#0#0#0#0#0#0#0#0#7#255 + +#255#255#255#255#255#224#0#0#0#0#0#0#0#0#15#255#255#255#255#255#255#240#0#0#0 + +#0#0#0#0#0#31#255#255#255#255#255#255#248#0#0#0#0#0#0#0#0#127#255#255#255#255 + +#255#255#254#0#0#0#0#0#0#0#0#255#255#255#255#255#255#255#255#128#0#0#0#0#0#0 + +#3#255#255#255#255#255#255#255#255#192#0#0#0#0#0#0#7#255#255#255#255#255#255 + +#255#255#240#0#0#0#0#0#0#31#255#255#255#255#255#255#255#255#252#0#0#0#0#0#0 + +#127#255#255#255#255#255#255#255#255#255#0#0#0#0#0#3#255#255#255#255#255#255 + +#255#255#255#255#224#0#0#0#0#15#255#255#255#255#255#255#255#255#255#255#252#0 + +#0#0#0#127#255#255#255#255#255#255#255#255#255#255#255#192#0#0#7#255#255#255 + +#255#255#255#255#255#255#255#255#255#254#0#1#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255'('#0#0#0'@'#0#0#0#128#0#0#0#1#0' '#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#1'@@@'#4'III'#7'III'#7 + +'333'#5#128#128#128#2#0#0#0#1#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#1'UUU'#6'DDD' + +#15'FFF'#22'EEE'#26'DDD'#30'III#GGG/DDD'#30#255'j>'#31#253'g>#'#249'[>+'#235'PB8'#218'HE' + +'C'#203'FEC'#195'EED'#184'DDD'#166'DDDqEEE4@@@'#20'@@@'#4#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#1 + +'999'#9'BBB'#31'CCCPEDD'#143'FFE'#182'NB:'#211'Z?-'#231'g>#'#249'l?'#31#255 + +'zK$'#253#150']*'#255#165'h.'#255#172'm0'#255#180's2'#255#186'x4'#255#189'{4' + +#255#192#127'5'#255#190'|4'#255#187'x4'#255#182'u3'#255#175'p1'#255#167'j/' + +#255#156'b+'#255#131'R&'#254'oB '#255'i>!'#253'_>)'#238'S@6'#222'FEB'#203'DD' + +'C'#190'DDD'#164'CCCkCCC.PPP'#16'UUU'#3#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#128#128#128#2'CCC'#19'BBBBDDD'#136'EED'#179'LA9' + +#209'`=&'#243'k?'#31#255#127'N&'#254#154'`,'#255#176'q1'#255#191'~5'#255#200 + +#138'7'#255#207#145'8'#255#210#149'9'#255#213#153'9'#255#217#157':'#255#219 + +#160';'#255#221#162';'#255#220#162':'#255#217#158':'#255#215#155':'#255#211 + +#151'9'#255#208#146'8'#255#203#141'8'#255#194#129'6'#255#183'v4'#255#163'f.' + +#255#137'U('#254'qC"'#254'f' + +'>>!+++'#6#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'@@@'#4'BBB'#27'CC' + +'C[CCB'#165'LD='#203']<('#238'j> '#255#135'R('#254#176'p3'#255#193#128'7'#255 + +#202#139'9'#255#211#151';'#255#220#162'<'#255#227#170'>'#255#232#176'?'#255 + +#234#180'?'#255#237#182'?'#255#239#185'@'#255#241#187'@'#255#242#188'A'#255 + +#241#187'@'#255#240#185'A'#255#238#183'@'#255#235#180'@'#255#233#178'?'#255 + +#229#173'>'#255#222#165'='#255#215#156'<'#255#205#144':'#255#196#133'8'#255 + +#185'x5'#255#152'^-'#255'oC"'#254'd<#'#247'QA7'#220'FFE'#200'CCC'#180'CCC}AA' + +'A/UUU'#9#0#0#0#1#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#1'III'#7'CCC&DDDpECC'#180'X<,'#232'i=' + +'!'#254#128'O('#254#170'l3'#255#194#130':'#255#210#150'>'#255#220#163'?'#255 + +#227#171'A'#255#234#180'B'#255#240#187'D'#255#242#190'D'#255#244#193'E'#255 + +#246#194'D'#255#247#195'E'#255#248#197'E'#255#249#197'E'#255#249#198'E'#255 + +#249#197'E'#255#248#196'E'#255#247#195'E'#255#246#195'E'#255#245#194'D'#255 + +#243#191'D'#255#240#188'C'#255#236#183'C'#255#230#174'B'#255#223#165'@'#255 + +#215#156'?'#255#200#137';'#255#182'u6'#255#146'[,'#255'm@!'#254'`:%'#244'KA;' + +#211'CCC'#189'CCC'#144'BBB>PPP'#16#128#128#128#2#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#1'999'#9'@@@4CCC'#133 + +'HD@'#192'_9$'#244'rE%'#254#164'h3'#255#191#127';'#255#206#146'?'#255#219#163 + +'C'#255#232#178'F'#255#238#185'G'#255#241#189'H'#255#244#193'H'#255#246#195 + +'I'#255#247#196'I'#255#247#197'J'#255#247#197'I'#255#247#198'I'#255#248#198 + +'I'#255#248#198'I'#255#248#197'I'#255#248#198'I'#255#248#198'I'#255#248#198 + +'I'#255#247#197'I'#255#247#197'I'#255#247#196'I'#255#246#196'I'#255#245#194 + +'H'#255#242#190'H'#255#239#187'H'#255#235#182'G'#255#224#168'D'#255#211#153 + +'A'#255#196#134'='#255#177'q7'#255#133'Q)'#254'e: '#253'N?7'#218'DDC'#195'CC' + +'C'#160'FFFP@@@'#20#0#0#0#2#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0'III'#7'FFF3CCC'#145'LB;'#204'd:"'#250'|L('#254#180's9'#255 + +#202#143'A'#255#216#159'F'#255#228#174'I'#255#236#184'K'#255#241#191'L'#255 + +#243#193'M'#255#244#194'M'#255#244#195'M'#255#245#196'M'#255#245#195'M'#255 + +#245#195'M'#255#245#195'M'#255#245#195'M'#255#245#195'M'#255#245#195'M'#255 + +#245#195'M'#255#245#195'M'#255#245#195'M'#255#245#195'M'#255#245#195'M'#255 + +#245#195'M'#255#245#195'M'#255#245#196'M'#255#245#195'M'#255#244#194'M'#255 + +#243#194'M'#255#242#192'M'#255#238#186'L'#255#232#179'J'#255#220#165'F'#255 + +#208#150'C'#255#190#127'<'#255#147'[.'#255'h< '#255'S=1'#228'EED'#199'DDD' + +#168'BBBUGGG'#18#0#0#0#1#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +'@@@'#4'FFF(EEE'#134'P?5'#212'e:!'#254#137'U,'#254#186'z='#255#208#150'E'#255 + +#224#171'L'#255#233#181'O'#255#238#187'P'#255#240#191'P'#255#242#192'Q'#255 + +#242#193'Q'#255#242#193'Q'#255#242#193'P'#255#242#193'Q'#255#242#193'Q'#255 + +#242#193'Q'#255#242#193'Q'#255#242#193'Q'#255#242#193'Q'#255#242#193'Q'#255 + ,#242#193'Q'#255#242#193'Q'#255#242#193'Q'#255#242#193'Q'#255#242#193'Q'#255 + +#242#193'Q'#255#242#193'Q'#255#242#193'Q'#255#242#193'Q'#255#242#193'Q'#255 + +#242#193'Q'#255#242#193'Q'#255#241#192'Q'#255#239#189'P'#255#234#184'O'#255 + +#228#175'M'#255#215#159'I'#255#194#132'@'#255#160'd3'#255'k?"'#254'X:*'#236 + +'FDC'#201'CCC'#164'AAAG;;;'#13#0#0#0#1#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'U' + +'UU'#3'BBB'#31'CCCvO=3'#211'f:'#31#255#150']2'#255#190#128'A'#255#211#155'I' + +#255#226#175'Q'#255#234#185'S'#255#237#188'T'#255#238#190'T'#255#239#191'U' + +#255#239#191'U'#255#239#191'U'#255#239#191'U'#255#239#191'U'#255#239#191'U' + +#255#239#191'U'#255#239#191'U'#255#235#189'S'#255'|d,'#255'N>'#28#255'4*'#19 + +#255'=1'#22#255'WE'#31#255'w_*'#255#173#139'='#255#239#191'U'#255#239#191'U' + +#255#239#191'U'#255#239#191'U'#255#239#191'U'#255#239#191'U'#255#239#191'U' + +#255#239#191'U'#255#239#191'U'#255#239#190'T'#255#238#189'U'#255#236#187'S' + +#255#230#179'R'#255#217#162'L'#255#198#138'D'#255#170'l8'#255'pC$'#254'Z8''' + +#240'DBB'#197'CCC'#153'FFF:@@@'#8#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#2'FFF'#22 + +'BBBeJ?9'#195'b8 '#254#150']2'#255#194#133'E'#255#213#158'N'#255#226#176'T' + +#255#233#185'W'#255#236#187'W'#255#236#188'X'#255#236#188'X'#255#236#188'X' + +#255#236#188'X'#255#236#188'X'#255#236#188'X'#255#236#188'X'#255#236#188'X' + +#255#236#188'X'#255'cO%'#255#4#3#1#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#1#1#0#255#18#14#7#255'A4'#24#255#134'k2' + +#255#218#174'R'#255#236#188'X'#255#236#188'X'#255#236#188'X'#255#236#188'X' + +#255#236#188'X'#255#236#188'X'#255#236#187'W'#255#234#186'W'#255#229#180'U' + +#255#218#165'P'#255#201#143'H'#255#173'o<'#255'k>#'#254'S;-'#231'CCC'#193'CC' + +'C'#141'DDD-fff'#5#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'@@@'#12'DDDKFA='#179'`7 '#251#137'S-' + +#255#192#131'E'#255#214#161'Q'#255#226#176'W'#255#231#183'Y'#255#233#185'[' + +#255#233#186'['#255#234#185'Z'#255#234#185'Z'#255#234#185'Z'#255#234#185'Z' + +#255#234#185'Z'#255#234#185'Z'#255#234#185'Z'#255#234#185'Z'#255'L<'#29#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#8#7#3#255'P' + +'?'#31#255#203#161'N'#255#234#185'Z'#255#234#185'Z'#255#234#185'Z'#255#234 + +#185'Z'#255#233#186'['#255#232#183'Z'#255#228#178'Y'#255#219#167'T'#255#201 + +#143'K'#255#163'g8'#255'f: '#255'O=4'#222'DDD'#188'CCCzBBB'#27#0#0#0#1#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'U' + +'UU'#3'GGG$D@@'#147'\6#'#245'{I*'#254#185'{C'#255#211#157'R'#255#225#175'Z' + +#255#229#181'\'#255#230#183']'#255#230#183']'#255#230#183']'#255#230#183']' + +#255#230#183']'#255#230#183']'#255#230#183']'#255#230#183']'#255#230#183']' + +#255#230#183']'#255#138'm8'#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#24#20#10#255'x_0' + +#255#226#181'['#255#230#183']'#255#230#183']'#255#230#183']'#255#230#181'\' + +#255#227#177'['#255#217#165'V'#255#196#136'J'#255#151']4'#255'b8 '#254'K@9' + +#214'CCC'#175'AAAJ...'#11#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0'@@@'#16'CCC\V6'''#228'nA&'#254#178'tA'#255#205 + +#151'R'#255#221#172'\'#255#226#179'_'#255#228#180'_'#255#228#180'_'#255#228 + +#180'_'#255#228#180'_'#255#228#180'_'#255#228#180'_'#255#228#180'_'#255#228 + +#180'_'#255#228#180'_'#255#228#180'_'#255#228#180'_'#255#17#13#7#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#2#1#1#255'H9'#30#255#224#178']' + +#255#228#180'_'#255#228#180'_'#255#227#179'^'#255#224#175']'#255#213#160'W' + +#255#190#129'H'#255#137'T/'#255'^4 '#252'FB?'#201'CCC'#140'DDD"'#0#0#0#3#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'@@@'#4'FFF,J=7' + +#175'`4'#30#255#165'g;'#255#200#144'Q'#255#217#166'\'#255#223#176'`'#255#225 + +#177'`'#255#225#177'a'#255#225#177'a'#255#225#177'a'#255#225#177'a'#255#225 + +#177'a'#255#225#177'a'#255#225#177'a'#255#225#177'a'#255#225#177'a'#255#225 + +#177'a'#255#218#171'^'#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255 + +#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#11#9#5#255#196#154'U'#255#225#177'a'#255#225#177 + +'`'#255#224#177'a'#255#220#171'^'#255#208#154'W'#255#184'{F'#255'nA%'#254'T8' + +'*'#233'DDD'#180'CCCX333'#15#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0'CCC'#19'CCCjY5#'#239'~J,'#254#191#132'M'#255#213#162']'#255 + ,#220#171'a'#255#221#173'c'#255#222#174'b'#255#222#174'b'#255#222#174'b'#255 + +#222#174'b'#255#222#174'b'#255#222#174'b'#255#222#174'b'#255#222#174'b'#255 + +#222#174'b'#255#222#174'b'#255#222#174'b'#255#154'yC'#255#0#0#0#255#0#0#0#255 + +#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#15#11#6 + +#255#218#172'`'#255#222#174'b'#255#222#174'b'#255#221#173'b'#255#217#167'_' + +#255#202#146'T'#255#156'a9'#255'^4'#30#254'G@='#206'DDD'#151'>>>)@@@'#4#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'UUU'#3'AAA+L;4'#188'b6 '#254#170 + +'l@'#255#206#152'Z'#255#217#168'b'#255#219#171'd'#255#219#171'd'#255#219#171 + +'d'#255#219#171'd'#255#219#171'd'#255#219#171'd'#255#219#171'd'#255#219#171 + +'d'#255#219#171'd'#255#219#171'd'#255#219#171'd'#255#219#171'd'#255#219#171 + +'d'#255#219#171'd'#255#26#20#12#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255'oW3'#255#219#171'd'#255#219 + +#171'd'#255#219#171'd'#255#218#169'c'#255#212#161'_'#255#187#127'L'#255'uD)' + +#254'W6('#238'CCC'#182'CCC[III'#14#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0'@@@'#12'EBBS[3'#31#244#134'O/'#255#192#134'Q'#255#212#162'b'#255#215 + +#167'd'#255#216#168'd'#255#216#168'd'#255#216#168'd'#255#216#168'd'#255#216 + +#168'd'#255#216#168'd'#255#216#168'd'#255#216#168'd'#255#216#168'd'#255#216 + +#168'd'#255#216#168'd'#255#216#168'd'#255#216#168'd'#255#216#168'd'#255#198 + +#154'\'#255#5#4#2#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255'!'#25#15#255#216#168'd'#255#216#168'd'#255#216#168 + +'d'#255#216#168'd'#255#214#166'd'#255#202#147'Y'#255#161'e='#255'^2'#29#255 + +'J?:'#208'CCC'#137'EEE'#26#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'C' + +'CC'#23'O9/'#171'`3'#31#254#174'pD'#255#203#150']'#255#212#163'e'#255#213#164 + +'e'#255#213#164'e'#255#213#164'e'#255#213#164'e'#255#213#164'e'#255#213#164 + +'e'#255#213#164'e'#255#213#164'e'#255#213#164'e'#255#213#164'e'#255#213#164 + +'e'#255#213#164'e'#255#213#164'e'#255#213#164'e'#255#213#164'e'#255#213#164 + +'e'#255#173#133'R'#255#3#2#1#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0 + +#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255 + +#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#22#17#11#255#213#164'e'#255#213#164'e'#255#213#164 + +'e'#255#213#164'e'#255#213#164'f'#255#209#158'a'#255#187#128'O'#255'yD)'#254 + +'W4$'#241'BBB'#169'DDD1@@@'#4#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#2'FFF(W4' + +'$'#229'{E)'#255#191#134'T'#255#207#157'c'#255#210#160'f'#255#210#160'f'#255 + +#210#160'f'#255#210#160'f'#255#210#160'f'#255#210#160'f'#255#210#160'f'#255 + +#210#160'f'#255#152'tJ'#255'[E,'#255'K9$'#255'{]<'#255#196#149'_'#255#210#160 + +'f'#255#210#160'f'#255#210#160'f'#255#210#160'f'#255#210#160'f'#255#159'yM' + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255'"' + +#26#17#255#210#160'f'#255#210#160'f'#255#210#160'f'#255#210#160'f'#255#210 + +#160'f'#255#209#160'e'#255#199#146']'#255#156'_;'#255'\1'#28#254'FBA'#188'FF' + +'FXNNN'#13#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'FFF'#11'F@=T\/'#28#253#151'\9'#255 + +#200#147'_'#255#207#156'e'#255#207#156'e'#255#207#156'e'#255#207#156'e'#255 + +#207#156'e'#255#207#156'e'#255#207#156'e'#255#178#135'W'#255'$'#27#17#255#0#0 + +#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255'N:&'#255#207#156'e'#255#207 + +#156'e'#255#207#156'e'#255#207#156'e'#255#207#156'e'#255#3#2#1#255#0#0#0#255 + +#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255'uX9'#255#207#156'e'#255#207 + +#156'e'#255#207#156'e'#255#207#156'e'#255#207#156'e'#255#207#157'e'#255#204 + +#153'b'#255#180'wK'#255'a4'#30#254'M;3'#216'DDD'#132'==='#25#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0'CCC'#19'N9.'#159'^2'#30#254#176'rI'#255#202#150'c'#255#203 + +#153'e'#255#203#153'f'#255#203#153'f'#255#203#153'f'#255#203#153'f'#255#203 + +#153'f'#255#163'zQ'#255#1#1#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0 + +#0#255#0#0#0#255#0#0#0#255#29#22#15#255#203#153'f'#255#203#153'f'#255#203#153 + +'f'#255#203#153'f'#255#14#10#7#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + ,#0#0#255#4#3#2#255#203#153'f'#255#203#153'f'#255#203#153'f'#255#203#153'f' + +#255#203#153'f'#255#203#153'f'#255#203#153'f'#255#203#152'e'#255#190#134'X' + +#255'yC)'#254'V5&'#239'DDD'#165'FFF('#128#128#128#2#0#0#0#0#0#0#0#0#0#0#0#0 + +'GGG'#25'V4%'#212's@&'#254#186#128'U'#255#199#148'd'#255#200#148'd'#255#200 + +#148'd'#255#200#148'd'#255#200#148'd'#255#200#148'd'#255#198#146'd'#255#12#9 + +#6#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255 + +#0#0#0#255#0#0#0#255#138'fE'#255#200#148'd'#255#200#148'd'#255#200#148'd'#255 + +#15#11#7#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0 + +#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255 + +#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#1#0#0#255'&'#28#19#255#145'kH'#255 + +#200#148'd'#255#200#148'd'#255#200#148'd'#255#200#148'd'#255#200#148'd'#255 + +#200#148'd'#255#200#148'd'#255#200#148'd'#255#194#141'^'#255#146'W6'#255'[0' + +#28#254'EBB'#178'CCC9UUU'#6#0#0#0#0#0#0#0#0#0#0#0#0'JAA'#31'\1'#29#249#140'P' + +'2'#255#190#135'\'#255#196#143'c'#255#196#143'c'#255#196#143'c'#255#196#143 + +'c'#255#196#143'c'#255#196#143'c'#255'>-'#31#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255'&' + +#28#19#255#196#143'c'#255#196#143'c'#255#196#143'c'#255#25#18#12#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#2#2#1 + +#255'*'#31#21#255'kM6'#255#187#137'_'#255#196#143'c'#255#196#143'c'#255#196 + +#143'c'#255#196#143'c'#255#196#143'c'#255#196#143'c'#255#196#143'c'#255#196 + +#143'c'#255#196#143'c'#255#196#143'c'#255#194#141'b'#255#170'kF'#255'\0'#28 + +#254'L<5'#203'CCCH333'#10#0#0#0#0#0#0#0#0#0#0#0#1'K3+@[/'#27#255#160'`>'#255 + +#190#136'_'#255#191#137'`'#255#191#137'`'#255#191#137'`'#255#191#137'`'#255 + +#191#137'`'#255#189#135'`'#255#1#1#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#30#21#15#255 + +#191#137'`'#255#191#137'`'#255#191#137'`'#255'aF1'#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#5#3#2#255#165'vS'#255#191#137'`' + +#255#191#137'`'#255#191#137'`'#255#191#137'`'#255#191#137'`'#255#191#137'`' + +#255#191#137'`'#255#191#137'`'#255#191#137'`'#255#191#137'`'#255#191#137'`' + +#255#191#137'`'#255#191#137'`'#255#191#136'`'#255#178'vQ'#255'h7 '#253'Q8,' + +#220'DDDV;;;'#13#0#0#0#0#0#0#0#0'UUU'#3'R4''^[/'#27#255#169'hF'#255#187#131 + +']'#255#187#132'^'#255#187#132'^'#255#187#132'^'#255#187#132'^'#255#187#132 + +'^'#255'uS;'#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255 + +#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255'{W>'#255#187#132'^'#255 + +#187#132'^'#255#187#132'^'#255#185#130'^'#255#19#14#10#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#1#1#1#255#158'oO'#255#187#132'^'#255#187#132'^' + +#255#187#132'^'#255#187#132'^'#255#187#132'^'#255#187#132'^'#255#187#132'^' + +#255#187#132'^'#255#187#132'^'#255#187#132'^'#255#187#132'^'#255#187#132'^' + +#255#187#132'^'#255#187#132'^'#255#187#132'^'#255#181'{V'#255'r<"'#255'T6''' + +#228'BBBd@@@'#16#0#0#0#0#0#0#0#0'UUU'#6'T5''}_2'#30#253#171'kI'#255#183'}Z' + +#255#183'~Z'#255#183'~Z'#255#183'~Z'#255#183'~Z'#255#183'~Z'#255'. '#23#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#1#1#0#255'S9)'#255#183'~Z'#255#183'~Z'#255#183'~Z'#255#183'~Z' + +#255#183'~Z'#255#173'xV'#255#31#21#15#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255'b' + +'C0'#255#183'~Z'#255#183'~Z'#255#183'~Z'#255#183'~Z'#255#183'~Z'#255#183'~Z' + +#255#183'~Z'#255#183'~Z'#255#183'~Z'#255#183'~Z'#255#183'~Z'#255#183'~Z'#255 + +#183'~Z'#255#183'~Z'#255#183'~Z'#255#183'~Z'#255#181'zV'#255'zA%'#255'X4$' + +#237'DDDqCCC'#19#0#0#0#0#0#0#0#0'@@@'#8'U4%'#149'f5'#31#252#172'mK'#255#180 + +'yX'#255#180'yX'#255#180'yX'#255#180'yX'#255#180'yX'#255#180'yX'#255#6#4#3 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#19#13#9#255#153'gK'#255#180'yX'#255#180'yX'#255#180'yX'#255#180'yX' + +#255#180'yX'#255#180'yX'#255#180'yX'#255#180'yX'#255'{S<'#255'+'#29#21#255#7 + +#4#3#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#1#1#1 + +#255'gF3'#255#180'yX'#255#180'yX'#255#180'yX'#255#139']D'#255'+'#29#21#255#8 + +#6#4#255#8#6#4#255#16#11#8#255'W:*'#255#178'wV'#255#180'yX'#255#180'yX'#255 + +#180'yX'#255#180'yX'#255#180'yX'#255#180'yX'#255#180'yX'#255#179'yV'#255#131 + +'F+'#255'[3!'#245'CCCyIII'#21#0#0#0#0#0#0#0#0'UUU'#6'X3"'#165'n:"'#253#172'p' + +'O'#255#177'wW'#255#177'wW'#255#177'wW'#255#177'wW'#255#177'wW'#255#173'uU' + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#1 + +#0#0#255'P6'''#255#177'wW'#255#177'wW'#255#177'wW'#255#177'wW'#255#177'wW' + ,#255#177'wW'#255#177'wW'#255#177'wW'#255#177'wW'#255#177'wW'#255#177'wW'#255 + +#177'wW'#255#177'wW'#255#158'jM'#255'W;+'#255''''#26#19#255'"'#23#17#255'%' + +#25#18#255'W:+'#255#167'qS'#255#177'wW'#255#177'wW'#255#177'wW'#255'@+'#31 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#3#2#1#255 + +#149'dI'#255#177'wW'#255#177'wW'#255#177'wW'#255#177'wW'#255#177'wW'#255#177 + +'wW'#255#177'vV'#255#139'M0'#255'[1'#30#250'DDDpCCC'#19#0#0#0#0#0#0#0#0'UUU' + +#3'Y1'#31#182'v>%'#255#172'oQ'#255#175'tW'#255#175'tW'#255#175'tW'#255#175't' + +'W'#255#175'tW'#255'}S?'#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#26#17#13#255#150'cK'#255#175'tW'#255#175'tW'#255#175'tW'#255 + +#175'tW'#255#175'tW'#255#175'tW'#255#175'tW'#255#175'tW'#255#175'tW'#255#175 + +'tW'#255#175'tW'#255#175'tW'#255#175'tW'#255#175'tW'#255#175'tW'#255#175'tW' + +#255#175'tW'#255#175'tW'#255#175'tW'#255#175'tW'#255#175'tW'#255#175'tW'#255 + +#175'tW'#255'dC2'#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#9#6#4#255#169'pU'#255#175'tW'#255#175'tW'#255#175't' + +'W'#255#175'tW'#255#175'tW'#255#174'sU'#255#145'S6'#255']0'#28#254'DBBd@@@' + +#16#0#0#0#0#0#0#0#0#0#0#0#0'Z0'#30#175'v=%'#255#171'nP'#255#174'rV'#255#174 + +'rV'#255#174'rV'#255#174'rV'#255#174'rV'#255'L2&'#255#0#0#0#255'/'#31#23#255 + +'}R>'#255' '#21#16#255'!'#22#17#255#139'[E'#255#174'rV'#255#174'rV'#255#174 + +'rV'#255#174'rV'#255#174'rV'#255#174'rV'#255#174'rV'#255#174'rV'#255#174'rV' + +#255#174'rV'#255#174'rV'#255#174'rV'#255#174'rV'#255#174'rV'#255#174'rV'#255 + +#174'rV'#255#174'rV'#255#174'rV'#255#174'rV'#255#174'rV'#255#174'rV'#255#174 + +'rV'#255#174'rV'#255#174'rV'#255#174'rV'#255'?*'#31#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255'6#'#27 + +#255#174'rV'#255#174'rV'#255#174'rV'#255#174'rV'#255#174'rV'#255#173'qT'#255 + +#145'S7'#255'\1'#29#254'AAAV;;;'#13#0#0#0#0#0#0#0#0#0#0#0#0'Z1'#30#150'n;$' + +#252#169'jM'#255#172'qU'#255#172'qU'#255#172'qU'#255#172'qU'#255#172'qU'#255 + +#149'bI'#255'@* '#255#170'qU'#255#172'qU'#255#172'qU'#255#172'qU'#255#172'qU' + +#255#172'qU'#255#172'qU'#255#172'qU'#255#172'qU'#255#172'qU'#255#172'qU'#255 + +#172'qU'#255#172'qU'#255#172'qU'#255#172'qU'#255#172'qU'#255#172'qU'#255#172 + +'qU'#255#172'qU'#255#172'qU'#255#172'qU'#255#172'qU'#255#172'qU'#255#172'qU' + +#255#172'qU'#255#172'qU'#255#172'qU'#255#172'qU'#255#172'qU'#255#172'qU'#255 + +'G/#'#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#24#16#12#255#172'qU'#255#172'qU'#255#172'qU'#255#172 + +'qU'#255#172'qU'#255#171'oS'#255#138'N3'#255'\2'#31#249'DDDG999'#9#0#0#0#0#0 + +#0#0#0#0#0#0#0'X1!|g7#'#250#167'gI'#255#172'pT'#255#172'qU'#255#172'qU'#255 + +#172'qU'#255#172'qU'#255#172'qU'#255#172'qU'#255#172'qU'#255#172'qU'#255#172 + +'qU'#255#172'qU'#255#172'qU'#255#172'qU'#255#172'qU'#255#172'qU'#255#172'qU' + +#255#172'qU'#255'P5('#255')'#27#20#255#27#18#13#255'5#'#26#255'pJ8'#255#172 + +'qU'#255#172'qU'#255#172'qU'#255#172'qU'#255#172'qU'#255#172'qU'#255#172'qU' + +#255#172'qU'#255#172'qU'#255#172'qU'#255#172'qU'#255#172'qU'#255#172'qU'#255 + +#172'qU'#255#172'qU'#255#162'jO'#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255 + +#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#9#6#4#255#172'qU'#255#172 + +'qU'#255#172'qU'#255#172'qU'#255#172'qU'#255#170'mR'#255#131'I.'#255'[4"'#241 + +'FFF7UUU'#6#0#0#0#0#0#0#0#0#0#0#0#0'Y1!`b5 '#251#164'cG'#255#172'pU'#255#173 + +'rW'#255#173'rW'#255#173'rW'#255#173'rW'#255#173'rW'#255#173'rW'#255#173'rW' + +#255#173'rW'#255#173'rW'#255#173'rW'#255#173'rW'#255#173'rW'#255#173'rW'#255 + +#173'rW'#255'}S?'#255#9#6#5#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#16#11#8#255#152'dM'#255#173'rW'#255#173'rW'#255#173'rW'#255#173'rW'#255 + +#173'rW'#255#173'rW'#255#173'rW'#255#173'rW'#255#173'rW'#255#173'rW'#255#173 + +'rW'#255#173'rW'#255#173'rW'#255#173'rW'#255'$'#24#18#255#0#0#0#255#0#0#0#255 + +#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#4#3#2#255#173'r' + +'W'#255#173'rW'#255#173'rW'#255#173'rW'#255#173'rW'#255#170'mQ'#255'|C*'#255 + +'W4$'#229'CCC&'#0#0#0#2#0#0#0#0#0#0#0#0#0#0#0#0'X5!A^2'#31#254#162'bE'#255 + +#173'rV'#255#175'tY'#255#175'tY'#255#175'tY'#255#175'tY'#255#175'tY'#255#175 + +'tY'#255#175'tY'#255#175'tY'#255#175'tY'#255#175'tY'#255#175'tY'#255#175'tY' + +#255#175'tY'#255'{Q?'#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#14#9#7#255#173'tY'#255#175'tY'#255#175'tY'#255 + +#175'tY'#255#175'tY'#255#175'tY'#255#175'tY'#255#175'tY'#255#175'tY'#255#175 + +'tY'#255#175'tY'#255#175'tY'#255#175'tY'#255#175'tY'#255#132'XC'#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#21 + +#14#11#255#175'tY'#255#175'tY'#255#175'tY'#255#175'tY'#255#174'tY'#255#170'm' + +'P'#255't?('#254'U5&'#203'@@@'#24#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'X0'#24' ^2' + +#31#255#156'\A'#255#175'v\'#255#177'y`'#255#177'y`'#255#177'y`'#255#177'y`' + +#255#177'y`'#255#177'y`'#255#177'y`'#255#177'y`'#255#177'y`'#255#177'y`'#255 + ,#177'y`'#255#177'y`'#255#177'y`'#255#11#8#6#255#0#0#0#255#0#0#0#255#0#0#0#255 + +#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#136']J'#255#177 + +'y`'#255#177'y`'#255'7%'#30#255#9#6#5#255#13#9#7#255#16#11#9#255#26#18#14#255 + +#139'_K'#255#177'y`'#255#177'y`'#255#177'y`'#255#177'y`'#255#177'y`'#255#177 + +'y`'#255#18#12#9#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255'<)!'#255#177'y`'#255#177'y`'#255#177'y`'#255#177'y`'#255#176 + +'x^'#255#169'kP'#255'j<&'#253'U4%'#168';;;'#13#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0'^2'#29#234#136'O4'#255#176'x^'#255#180'~f'#255#180'~f'#255#180'~f' + +#255#180'~f'#255#180'~f'#255#180'~f'#255#180'~f'#255#180'~f'#255#180'~f'#255 + +#180'~f'#255#180'~f'#255#180'~f'#255#146'gS'#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255 + +#139'bO'#255#170'x`'#255#20#14#11#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255 + +#0#0#0#255#0#0#0#255']A4'#255#180'~f'#255#180'~f'#255#180'~f'#255#180'~f'#255 + +#180'~f'#255'qO@'#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#1#1#0#255#165't^'#255#180'~f'#255#180'~f'#255#180'~f'#255#180'~f'#255 + +#178'zb'#255#162'dH'#255'_3'#31#254'R6)c@@@'#4#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0'[/'#29#153'r?)'#252#174'sZ'#255#182#129'j'#255#183#131'l'#255#183 + +#131'l'#255#183#131'l'#255#183#131'l'#255#183#131'l'#255#183#131'l'#255#183 + +#131'l'#255#183#131'l'#255#183#131'l'#255#183#131'l'#255#183#131'l'#255'ZA5' + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#5#3#3#255#179#127'j'#255'uTE'#255#0#0#0#255#0#0#0#255#0#0 + +#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255'{XI'#255#183#131'l' + +#255#183#131'l'#255#183#131'l'#255#183#131'l'#255#183#131'l'#255#20#15#12#255 + +#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255':)"'#255#183#131'l'#255 + +#183#131'l'#255#183#131'l'#255#183#131'l'#255#183#131'l'#255#179'|c'#255#140 + +'R9'#255'\2'#31#248'@@6'#28#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +'[/'#29'E`5 '#252#166'iO'#255#183#131'l'#255#186#136'q'#255#186#136'q'#255 + +#186#136'q'#255#186#136'q'#255#186#136'q'#255#186#136'q'#255#186#136'q'#255 + +#186#136'q'#255#186#136'q'#255#186#136'q'#255#186#136'q'#255'\D8'#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255'oQC'#255#186#136'q'#255'X@6'#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#12#9#7#255#186#136'q'#255#186 + +#136'q'#255#186#136'q'#255#186#136'q'#255#186#136'q'#255#148'lZ'#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#169'|g'#255#186#136'q'#255#186 + +#136'q'#255#186#136'q'#255#186#136'q'#255#185#134'q'#255#177'y`'#255'tB+'#254 + +'W2!'#194'III'#14#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'@@'#0#4'^3' + +#30#245#144'W='#255#184#134'o'#255#189#141'x'#255#189#141'x'#255#189#141'x' + +#255#189#141'x'#255#189#141'x'#255#189#141'x'#255#189#141'x'#255#189#141'x' + +#255#189#141'x'#255#189#141'x'#255#189#141'x'#255'tWJ'#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255'('#30#26#255 + +#189#141'x'#255#189#141'x'#255'?/('#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#187#139'v'#255#189#141 + +'x'#255#189#141'x'#255#189#141'x'#255#189#141'x'#255#189#141'x'#255#172#128 + +'m'#255'_G<'#255#1#0#0#255#0#0#0#255'-"'#28#255#189#141'x'#255#189#141'x'#255 + +#189#141'x'#255#189#141'x'#255#189#141'x'#255#186#137's'#255#171'oU'#255'a6"' + +#253'T5$jUUU'#3#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'\/' + +#27#170'vD,'#252#181#128'h'#255#190#144'{'#255#192#146'~'#255#192#146'~'#255 + +#192#146'~'#255#192#146'~'#255#192#146'~'#255#192#146'~'#255#192#146'~'#255 + +#192#146'~'#255#192#146'~'#255#192#146'~'#255#186#142'z'#255#1#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#2#1#1#255#186#142'z' + +#255#192#146'~'#255#192#146'~'#255'=.('#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0 + +#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#192#146'~'#255#192 + +#146'~'#255#192#146'~'#255#192#146'~'#255#192#146'~'#255#192#146'~'#255#192 + +#146'~'#255#192#146'~'#255#0#0#0#255#0#0#0#255#167#127'n'#255#192#146'~'#255 + +#192#146'~'#255#192#146'~'#255#192#146'~'#255#191#145'}'#255#186#137's'#255 + +#149'[A'#255'^1'#31#250'F:.'#22#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0'\.'#28'H`5 '#252#164'jP'#255#190#143'z'#255#194#151#131 + +#255#194#151#131#255#194#151#131#255#194#151#131#255#194#151#131#255#194#151 + +#131#255#194#151#131#255#194#151#131#255#194#151#131#255#194#151#131#255#194 + +#151#131#255#27#21#18#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255' '#25#21#255#194#151#131#255#194#151#131#255#194#151#131#255'7*%' + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#12#9#8#255#194#151#131#255#194#151#131#255#194#151#131#255#194#151 + +#131#255#194#151#131#255#194#151#131#255#194#151#131#255#190#149#129#255#0#0 + ,#0#255'0% '#255#194#151#131#255#194#151#131#255#194#151#131#255#194#151#131 + +#255#194#151#131#255#192#147#127#255#180'~f'#255'q@+'#252'Z0'#29#180#0#0#0#2 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0']0' + +#28#199'{H2'#252#184#134'o'#255#196#153#134#255#197#156#137#255#197#156#137 + +#255#197#156#137#255#197#156#137#255#197#156#137#255#197#156#137#255#197#156 + +#137#255#197#156#137#255#197#156#137#255#197#156#137#255'G81'#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255'WE='#255#197#156#137#255#197 + +#156#137#255#191#152#133#255#1#1#1#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#135'k^'#255#197#156#137#255#197 + +#156#137#255#197#156#137#255#197#156#137#255#197#156#137#255#197#156#137#255 + +#197#156#137#255#197#156#137#255#16#12#11#255#174#138'y'#255#197#156#137#255 + +#197#156#137#255#197#156#137#255#197#156#137#255#197#155#136#255#191#145'|' + +#255#151'_F'#255'^3'#31#253'T2!-'#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'[0'#29'5_4 '#254#161'hP'#255#195#152#132 + +#255#200#161#143#255#200#161#144#255#200#161#144#255#200#161#144#255#200#161 + +#144#255#200#161#144#255#200#161#144#255#200#161#144#255#200#161#144#255#200 + +#161#144#255'xaW'#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#1#1#1 + +#255#171#138'{'#255#200#161#144#255#200#161#144#255#127'f\'#255#0#0#0#255#0#0 + +#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255')!'#30#255 + +#200#161#144#255#200#161#144#255#200#161#144#255#200#161#144#255#200#161#144 + +#255#200#161#144#255#200#161#144#255#200#161#144#255#200#161#144#255#153'{n' + +#255#200#161#144#255#200#161#144#255#200#161#144#255#200#161#144#255#200#161 + +#144#255#198#156#138#255#181#128'h'#255'l>*'#252'Z1'#30#159#0#0#0#1#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0'^0'#27#173'uE/'#249#186#136'r'#255#201#162#145#255#203#165#150#255#203#165 + +#150#255#203#165#150#255#203#165#150#255#203#165#150#255#203#165#150#255#203 + +#165#150#255#203#165#150#255#203#165#150#255#163#132'x'#255#0#0#0#255#0#0#0 + +#255#26#21#19#255',$!'#255'-%!'#255#156'~s'#255#203#165#150#255#203#165#150 + +#255#203#165#150#255'@4/'#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#4#3#3#255#186#151#138#255#203#165#150#255#203#165 + +#150#255#203#165#150#255#203#165#150#255#203#165#150#255#203#165#150#255#203 + +#165#150#255#203#165#150#255#203#165#150#255#203#165#150#255#203#165#150#255 + +#203#165#150#255#203#165#150#255#203#165#150#255#203#164#149#255#195#152#132 + +#255#146'\D'#255'_3'#31#247'R3'#30#25#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'Z-'#30'"^4 '#252#155 + +'cK'#255#196#153#136#255#206#169#155#255#207#171#156#255#207#171#156#255#207 + +#171#156#255#207#171#156#255#207#171#156#255#207#171#156#255#207#171#156#255 + +#207#171#156#255#203#167#152#255#0#0#0#255#0#0#0#255#193#159#145#255#207#171 + +#156#255#207#171#156#255#207#171#156#255#207#171#156#255#207#171#156#255#207 + +#171#156#255'E94'#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#15#12#11#255#182#150#137#255#207#171#156#255#207#171#156#255#207#171#156 + +#255#207#171#156#255#207#171#156#255#207#171#156#255#207#171#156#255#207#171 + +#156#255#207#171#156#255#207#171#156#255#207#171#156#255#207#171#156#255#207 + +#171#156#255#207#171#156#255#206#170#155#255#201#162#145#255#178'}f'#255'h<(' + +#250'[0'#28#129#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0']1'#29#130'f:&'#250#171'u' + +'^'#255#202#164#148#255#210#176#163#255#210#177#164#255#210#177#164#255#210 + +#177#164#255#210#177#164#255#210#177#164#255#210#177#164#255#210#177#164#255 + +#210#177#164#255#2#1#1#255#27#22#21#255#210#177#164#255#210#177#164#255#210 + +#177#164#255#210#177#164#255#210#177#164#255#210#177#164#255#210#177#164#255 + +#210#177#164#255'I=8'#255#6#5#4#255#0#0#0#255#0#0#0#255#0#0#0#255'''!'#31#255 + +#206#175#162#255#210#177#164#255#210#177#164#255#210#177#164#255#210#177#164 + +#255#210#177#164#255#210#177#164#255#210#177#164#255#210#177#164#255#210#177 + +#164#255#210#177#164#255#210#177#164#255#210#177#164#255#210#177#164#255#210 + +#177#164#255#210#176#163#255#206#170#155#255#188#139'w'#255'zI4'#252'^2'#29 + +#222']/'#23#11#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#1'^1'#29#181'oA-' + +#249#182#132'n'#255#208#173#159#255#213#182#169#255#213#183#170#255#213#183 + +#170#255#213#183#170#255#213#183#170#255#213#183#170#255#213#183#170#255#213 + +#183#170#255#12#10#9#255#159#136#127#255#213#183#170#255#213#183#170#255#213 + +#183#170#255#213#183#170#255#213#183#170#255#213#183#170#255#213#183#170#255 + +#213#183#170#255#213#183#170#255#139'xo'#255#0#0#0#255#0#0#0#255'% '#30#255 + +#213#183#170#255#213#183#170#255#213#183#170#255#213#183#170#255#213#183#170 + +#255#213#183#170#255#213#183#170#255#213#183#170#255#213#183#170#255#213#183 + ,#170#255#213#183#170#255#213#183#170#255#213#183#170#255#213#183#170#255#213 + +#183#170#255#213#183#170#255#211#178#165#255#196#152#134#255#136'T?'#254'`1 ' + +#243'U+'#28'$'#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'U+'#21#12 + +']2'#30#218'zK5'#251#192#146#127#255#212#180#168#255#216#187#176#255#217#188 + +#177#255#217#188#177#255#217#188#177#255#217#188#177#255#217#188#177#255#217 + +#188#177#255'o`Z'#255#217#188#177#255#217#188#177#255#217#188#177#255#217#188 + +#177#255#217#188#177#255#217#188#177#255#217#188#177#255#217#188#177#255#217 + +#188#177#255#217#188#177#255#27#24#22#255#0#0#0#255#9#8#7#255#209#180#171#255 + +#217#188#177#255#217#188#177#255#217#188#177#255#217#188#177#255#217#188#177 + +#255#217#188#177#255#217#188#177#255#217#188#177#255#217#188#177#255#217#188 + +#177#255#217#188#177#255#217#188#177#255#217#188#177#255#217#188#177#255#217 + +#188#177#255#215#185#173#255#202#163#147#255#152'cM'#255'`5 '#252'X.'#27'B'#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'].'#23'!_' + +'3 '#241#135'V@'#254#197#155#137#255#215#185#173#255#219#193#183#255#220#194 + +#184#255#220#194#184#255#220#194#184#255#220#194#184#255#220#194#184#255#220 + +#194#184#255#220#194#184#255#220#194#184#255#220#194#184#255#220#194#184#255 + +#220#194#184#255#220#194#184#255#220#194#184#255#220#194#184#255#220#194#184 + +#255#220#194#184#255#4#4#4#255#13#11#11#255#197#173#164#255#220#194#184#255 + +#220#194#184#255#220#194#184#255#220#194#184#255#220#194#184#255#220#194#184 + +#255#220#194#184#255#220#194#184#255#220#194#184#255#220#194#184#255#220#194 + +#184#255#220#194#184#255#220#194#184#255#220#194#184#255#220#194#183#255#218 + +#190#179#255#205#169#154#255#165'pY'#255'b8$'#252'[/'#27'h'#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'Y1'#28'?_' + +'3!'#249#132'T?'#252#193#148#130#255#215#186#174#255#223#198#189#255#223#200 + +#191#255#223#200#191#255#223#200#191#255#223#200#191#255#223#200#191#255#223 + +#200#191#255#223#200#191#255#223#200#191#255#223#200#191#255#223#200#191#255 + +#223#200#191#255#223#200#191#255#223#200#191#255#223#200#191#255#223#200#191 + +#255#199#179#171#255#215#192#183#255#223#200#191#255#223#200#191#255#223#200 + +#191#255#223#200#191#255#223#200#191#255#223#200#191#255#223#200#191#255#223 + +#200#191#255#223#200#191#255#223#200#191#255#223#200#191#255#223#200#191#255 + +#223#200#191#255#223#200#191#255#223#199#190#255#219#192#183#255#203#165#150 + +#255#158'kS'#255'c9%'#251']0'#30#147#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'Z-'#25'3_3'#30 + +#234'wI5'#250#185#138'v'#255#215#186#174#255#225#203#194#255#227#205#197#255 + +#227#205#197#255#227#205#197#255#227#205#197#255#227#205#197#255#227#205#197 + +#255#227#205#197#255#227#205#197#255#227#205#197#255#227#205#197#255#227#205 + +#197#255#227#205#197#255#227#205#197#255#227#205#197#255#227#205#197#255#227 + +#205#197#255#227#205#197#255#227#205#197#255#227#205#197#255#227#205#197#255 + +#227#205#197#255#227#205#197#255#227#205#197#255#227#205#197#255#227#205#197 + +#255#227#205#197#255#227#205#197#255#227#205#197#255#227#205#197#255#226#204 + +#196#255#220#194#183#255#200#159#143#255#144'_H'#254'a6"'#253'\1'#30'y'#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'\3'#31#25'^2'#29#207'nB.'#249#175'~i'#255 + +#213#182#169#255#225#202#193#255#230#209#203#255#230#211#205#255#230#211#205 + +#255#230#211#205#255#230#211#205#255#230#211#205#255#230#211#205#255#230#211 + +#205#255#230#211#205#255#230#211#205#255#230#211#205#255#230#211#205#255#230 + +#211#205#255#230#211#205#255#230#211#205#255#230#211#205#255#230#211#205#255 + +#230#211#205#255#230#211#205#255#230#211#205#255#230#211#205#255#230#211#205 + +#255#230#211#205#255#230#211#205#255#230#211#205#255#230#211#205#255#230#210 + +#204#255#227#205#198#255#219#191#181#255#193#149#131#255#131'R='#251'_4 '#247 + +'Z0'#26'O'#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'` '#8']0' + +#28#169'e:'''#250#148'aL'#255#196#153#136#255#220#193#183#255#229#209#202#255 + +#233#216#210#255#234#216#211#255#234#216#211#255#234#216#211#255#234#216#211 + +#255#234#216#211#255#234#216#211#255#234#216#211#255#234#216#211#255#234#216 + +#211#255#234#216#211#255#234#216#211#255#234#216#211#255#234#216#211#255#234 + +#216#211#255#234#216#211#255#234#216#211#255#234#216#211#255#234#216#211#255 + +#234#216#211#255#234#216#211#255#234#216#211#255#233#216#211#255#231#212#206 + ,#255#224#200#192#255#207#171#156#255#168'va'#255'rE1'#249'^3'#31#230'Y,'#28 + +'.'#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0'^1'#29'h`3'#31#237'nA/'#249#158'mW'#255#203#165#150#255#224#201#192 + +#255#232#213#208#255#235#219#215#255#237#222#218#255#237#222#218#255#237#222 + +#218#255#237#222#218#255#237#222#218#255#237#222#218#255#237#222#218#255#237 + +#222#218#255#237#222#218#255#237#222#218#255#237#222#218#255#237#222#218#255 + +#237#222#218#255#237#222#218#255#237#222#218#255#237#222#218#255#237#222#218 + +#255#236#220#216#255#233#216#211#255#228#206#200#255#213#182#170#255#177#131 + +'n'#255'}M:'#250'a6"'#253']1'#29#155'U1'#24#21#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'].'#23#11 + +']1'#29'~`5!'#246'tF5'#249#166'u`'#255#202#164#148#255#221#195#186#255#230 + +#210#203#255#234#218#213#255#238#224#220#255#240#227#224#255#240#227#225#255 + +#240#227#225#255#240#227#225#255#240#227#225#255#240#227#225#255#240#227#225 + +#255#240#227#225#255#240#227#225#255#240#227#225#255#240#227#225#255#239#225 + +#222#255#236#220#215#255#232#213#207#255#225#203#194#255#210#176#164#255#183 + +#138'u'#255#133'UA'#252'c9&'#254'^2'#30#178'\.'#26''''#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'U1'#24#21']0'#30#147'`7"'#251'jA-'#249#133'UA' + +#253#169'zf'#255#201#162#146#255#220#194#184#255#230#211#205#255#233#215#210 + +#255#234#217#212#255#236#220#215#255#237#222#218#255#238#223#220#255#237#222 + +#219#255#236#220#216#255#234#219#213#255#233#216#211#255#231#213#206#255#225 + +#203#194#255#209#174#160#255#181#136'u'#255#145'`L'#255'sG4'#249'c9&'#255'_2' + +#30#198'].'#28'7'#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0'U+'#28#18'\.'#27'^_1'#30#179'c7$'#248'h?,'#251#127 + +'Q;'#251#148'dN'#255#163't_'#255#175#129'n'#255#186#143'~'#255#198#157#141 + +#255#204#167#151#255#201#161#145#255#191#149#132#255#179#135'u'#255#167'ye' + +#255#153'iT'#255#136'WC'#254'pE2'#249'c9&'#255'_3'#31#212'Z/'#27'|].'#29','#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'U9'#28#9'\.'#26'N^0'#29#157'`' + +'4 '#203'c6#'#230'c7%'#249'd:('#255'f=*'#255'i?-'#252'g>+'#255'e;('#255'd9&' + +#253'b7$'#237'a5!'#214'_1'#30#180'\/'#26'lX,'#26#29#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0'`0 '#16'[1'#24'*].'#27'B]1'#29'4\3'#31#25'UU'#0#3#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#255#255#255#248#15#255 + +#255#255#255#255#254#0#0#127#255#255#255#255#240#0#0#7#255#255#255#255#192#0 + +#0#1#255#255#255#255#0#0#0#0#255#255#255#252#0#0#0#0'?'#255#255#248#0#0#0#0 + +#31#255#255#240#0#0#0#0#7#255#255#192#0#0#0#0#3#255#255#128#0#0#0#0#1#255#255 + +#128#0#0#0#0#0#255#255#0#0#0#0#0#0#127#254#0#0#0#0#0#0#127#252#0#0#0#0#0#0'?' + +#252#0#0#0#0#0#0#31#248#0#0#0#0#0#0#31#248#0#0#0#0#0#0#15#240#0#0#0#0#0#0#15 + ,#240#0#0#0#0#0#0#7#224#0#0#0#0#0#0#7#224#0#0#0#0#0#0#7#224#0#0#0#0#0#0#3#192 + +#0#0#0#0#0#0#3#192#0#0#0#0#0#0#3#192#0#0#0#0#0#0#1#192#0#0#0#0#0#0#1#192#0#0 + +#0#0#0#0#1#128#0#0#0#0#0#0#1#128#0#0#0#0#0#0#1#128#0#0#0#0#0#0#1#128#0#0#0#0 + +#0#0#1#128#0#0#0#0#0#0#1#128#0#0#0#0#0#0#1#192#0#0#0#0#0#0#1#192#0#0#0#0#0#0 + +#1#192#0#0#0#0#0#0#1#192#0#0#0#0#0#0#1#192#0#0#0#0#0#0#3#192#0#0#0#0#0#0#3 + +#224#0#0#0#0#0#0#3#224#0#0#0#0#0#0#7#224#0#0#0#0#0#0#7#224#0#0#0#0#0#0#7#240 + +#0#0#0#0#0#0#15#240#0#0#0#0#0#0#15#248#0#0#0#0#0#0#31#248#0#0#0#0#0#0#31#252 + +#0#0#0#0#0#0'?'#252#0#0#0#0#0#0#127#254#0#0#0#0#0#0#127#254#0#0#0#0#0#0#255 + +#255#0#0#0#0#0#1#255#255#128#0#0#0#0#3#255#255#192#0#0#0#0#7#255#255#224#0#0 + +#0#0#15#255#255#240#0#0#0#0#31#255#255#248#0#0#0#0'?'#255#255#254#0#0#0#0#127 + +#255#255#255#0#0#0#1#255#255#255#255#192#0#0#7#255#255#255#255#240#0#0#31#255 + +#255#255#255#254#0#0#255#255#255#255#255#255#248#31#255#255#255#255#255#255 + +#255#255#255#255#255'('#0#0#0'0'#0#0#0'`'#0#0#0#1#0' '#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0'UUU'#3'333'#5'UUU'#6'III'#7'@@@'#8'@@@'#8'III'#7 + +'UUU'#6'333'#5'UUU'#3#0#0#0#1#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#1'@@@' + +#4'@@@'#8'@@@'#16'DDD1BBBMCCC_FCCrDBB'#129'FDD'#133'CCCvCCCcDDDRDDD('#240'l@!'#252'qE!' + +#253'yJ$'#252#129'R&'#252#138'X)'#253#134'T('#253'}N%'#252'uG#'#252'oC"'#253 + +'h=#'#248'Z>.'#230'OC;'#211'FEC'#198'DDC'#187'BBB|CCC&999'#9#0#0#0#1#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#2'<<<'#17'CCCWEED'#170'OB9'#211'd=&'#244'qE"'#253#137'V)'#253 + +#164'h.'#255#186'y3'#255#194#130'5'#255#198#135'6'#255#203#140'7'#255#207#145 + +'8'#255#205#143'7'#255#201#137'7'#255#196#132'6'#255#192#127'5'#255#177'r1' + +#255#152'_+'#254'{L%'#252'k?"'#251'[>-'#233'IEA'#203'EDD'#184'DDDq<<<'#30'@@' + +'@'#4#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0'@@@'#4'BBB#EDD'#146'KB<'#205'a='''#242'yK&'#252#166'i/'#255#192#128'6' + +#255#205#143'9'#255#217#159'<'#255#226#169'>'#255#230#173'>'#255#232#176'>' + +#255#235#180'?'#255#237#182'@'#255#236#181'?'#255#234#178'>'#255#231#175'>' + +#255#228#171'>'#255#223#165'<'#255#211#150':'#255#199#136'8'#255#182'v5'#255 + +#146'\,'#253'k@"'#252'W?1'#227'GFE'#199'CCC'#171'???=@@@'#8#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'III'#7'DDD8ECB'#170'[>,'#234'sF$' + +#252#160'e0'#255#196#133';'#255#216#158'@'#255#227#170'A'#255#234#180'C'#255 + +#241#189'D'#255#245#193'E'#255#246#195'F'#255#247#195'F'#255#247#196'E'#255 + +#248#197'F'#255#248#197'E'#255#247#195'F'#255#247#194'F'#255#246#194'E'#255 + +#244#192'E'#255#238#184'C'#255#230#176'C'#255#223#166'A'#255#207#147'='#255 + +#182'w7'#255#138'V+'#253'h>#'#250'NA9'#215'CCC'#186'@@@[;;;'#13#0#0#0#1#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'@@@'#8'EEENGC?'#189'b;%'#245#139'W-'#253#190 + +#127';'#255#212#153'B'#255#227#172'F'#255#239#186'I'#255#242#191'J'#255#244 + +#193'K'#255#246#195'K'#255#247#196'K'#255#247#196'K'#255#247#196'L'#255#247 + +#196'L'#255#247#196'L'#255#247#196'L'#255#247#196'L'#255#247#196'K'#255#247 + +#196'K'#255#246#196'K'#255#245#195'J'#255#243#193'J'#255#242#190'J'#255#234 + +#180'H'#255#221#165'E'#255#202#142'@'#255#173'o5'#255'oC$'#252'T?3'#225'CCC' + +#193'AAAy@@@'#16#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'+++'#6'DDD@K@<'#198'g<"'#250#154 + +'a2'#254#200#141'B'#255#222#168'J'#255#234#183'N'#255#239#189'P'#255#242#192 + +'P'#255#242#193'P'#255#243#193'P'#255#243#193'P'#255#243#193'P'#255#243#193 + +'P'#255#243#193'P'#255#243#193'P'#255#243#193'P'#255#243#193'P'#255#243#193 + ,'P'#255#243#193'P'#255#243#193'P'#255#243#193'P'#255#243#193'P'#255#242#193 + +'P'#255#242#193'P'#255#241#191'P'#255#238#187'N'#255#229#176'L'#255#214#158 + +'G'#255#183'y;'#255'yJ)'#252'[=,'#236'CCB'#195'EEEoFFF'#11#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'UUU'#3 + +'CCC.J?;'#190'g=#'#252#167'k7'#255#205#147'H'#255#226#173'P'#255#235#186'T' + +#255#238#189'T'#255#239#190'U'#255#239#190'U'#255#239#190'U'#255#239#190'U' + +#255#239#190'U'#255#239#190'U'#255#191#152'D'#255'A4'#23#255'>1'#22#255'D6' + +#24#255'H9'#26#255'RA'#29#255#146's4'#255#228#182'Q'#255#239#190'U'#255#239 + +#190'U'#255#239#190'U'#255#239#190'U'#255#239#190'U'#255#238#190'U'#255#237 + +#187'T'#255#232#182'S'#255#217#162'M'#255#191#129'B'#255#132'R-'#253'[9('#240 + +'DDD'#191'CCCW@@@'#8#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#1'>>>'#29'F@='#169'd9#'#250#165'i8'#255#208#151'L'#255 + +#226#174'U'#255#233#184'Y'#255#235#186'Y'#255#235#187'Y'#255#235#187'Y'#255 + +#235#187'Y'#255#235#187'Y'#255#235#187'Y'#255#235#187'Y'#255'<0'#23#255#1#1#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#1#1#0#255#0#0#0#255#6 + +#5#2#255'*!'#16#255'w^-'#255#227#181'W'#255#235#187'Y'#255#235#187'Y'#255#235 + +#186'Y'#255#234#186'Y'#255#231#181'X'#255#218#164'Q'#255#194#133'E'#255'{J*' + +#252'U=/'#230'CCC'#186'EEE?@@@'#4#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0'333'#10'DAAw_9%'#244#150'^4'#254#204#148'N'#255#225#175 + +'Y'#255#230#181'\'#255#231#183'\'#255#231#183'\'#255#231#183'\'#255#231#183 + +'\'#255#231#183'\'#255#231#183'\'#255#231#183'\'#255'hR*'#255#1#1#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#1#1#0#255#1#1#0#255'*!'#17#255#164#130'B'#255#231#183'\' + +#255#231#183'\'#255#231#182']'#255#228#179'['#255#217#165'V'#255#185'|C'#255 + +'nA'''#252'N>5'#219'CCC'#163'@@@'#20#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#128#128#128#2'@@@,W8*'#227#132'P/'#253#196#139'M'#255#220 + +#170'['#255#226#179'_'#255#227#179'_'#255#227#179'_'#255#227#179'_'#255#227 + +#179'_'#255#227#179'_'#255#227#179'_'#255#227#179'_'#255#227#179'_'#255#4#3#2 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#1#1#0 + +#255#7#6#3#255#178#141'J'#255#227#179'_'#255#227#179'_'#255#225#176'^'#255 + +#211#158'U'#255#174'q?'#255'c9"'#252'GA>'#203'BBB]III'#7#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0'FFF'#11'H>:'#150'e:#'#252#186'~H'#255#214#164'\' + +#255#222#174'a'#255#223#175'b'#255#223#175'b'#255#223#175'b'#255#223#175'b' + +#255#223#175'b'#255#223#175'b'#255#223#175'b'#255#223#175'b'#255#188#148'S' + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#1#1#1#255#154'yC'#255#223#175'b'#255#223#175'a'#255 + +#220#171'`'#255#204#150'U'#255#145'Y5'#254'Y8('#238'CCC'#175'FFF'#29#0#0#0#1 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'UUU'#3'AAA3Z7'''#236#148'\6'#255#207#154'Z' + +#255#218#170'b'#255#219#171'd'#255#219#171'd'#255#219#171'd'#255#219#171'd' + +#255#219#171'd'#255#219#171'd'#255#219#171'd'#255#219#171'd'#255#219#171'd' + +#255#211#165'`'#255#6#5#3#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#2#2#1#255#219#171'd'#255#219 + +#171'd'#255#219#171'd'#255#215#166'`'#255#189#129'M'#255'h=$'#252'H>;'#207'E' + +'EEhIII'#7#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'III'#7'K<5'#137'h;$'#252#188#130 + +'O'#255#213#164'b'#255#215#167'd'#255#215#167'd'#255#215#167'd'#255#215#167 + +'d'#255#215#167'd'#255#215#167'd'#255#215#167'd'#255#215#167'd'#255#215#167 + +'d'#255#215#167'd'#255#215#167'd'#255#168#130'N'#255#1#1#1#255#0#0#0#255#0#0 + +#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255 + +#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#200#155']'#255#215#167'd'#255#215#167'd'#255#215#166'd'#255#205#153']' + +#255#153'`:'#255'[6$'#243'CCC'#164';;;'#13#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'7' + +'77'#14'Z5%'#229#150'[8'#255#203#150'^'#255#211#162'e'#255#211#162'e'#255#211 + +#162'e'#255#211#162'e'#255#211#162'e'#255#211#162'e'#255#211#162'e'#255#211 + +#162'e'#255#211#162'e'#255#211#162'e'#255#211#162'e'#255#211#162'e'#255#211 + +#162'e'#255#142'mD'#255#1#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0 + +#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255 + +#0#0#0#255#0#0#0#255#0#0#0#255#1#1#0#255#145'pF'#255#211#162'e'#255#211#162 + +'e'#255#211#162'e'#255#210#159'd'#255#189#131'R'#255'f9#'#252'I@;'#202'===.' + +#128#128#128#2#0#0#0#0#0#0#0#0#128#128#128#2'D??4]3'#30#252#181'yM'#255#206 + +#155'd'#255#207#157'f'#255#207#157'f'#255#207#157'f'#255#207#157'f'#255#205 + +#155'f'#255'S?('#255#1#1#1#255#1#0#0#255#3#2#1#255#15#11#7#255#169#128'S'#255 + ,#207#157'f'#255#207#157'f'#255#207#157'f'#255#16#12#8#255#0#0#0#255#0#0#0#255 + +#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#1#0#0#255#186#141'\' + +#255#207#157'f'#255#207#157'f'#255#207#157'f'#255#207#157'e'#255#201#148'`' + +#255#135'O0'#254'R9-'#226'BBBeIII'#7#0#0#0#0#0#0#0#0'UUU'#6'O8/'#141'o>''' + +#251#193#139'['#255#203#151'e'#255#203#152'e'#255#203#152'e'#255#203#152'e' + +#255#203#152'e'#255#23#17#11#255#1#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0 + +#0#255#1#1#1#255#153'rL'#255#203#152'e'#255#203#152'e'#255',!'#22#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#1#0#0#255' '#24#16 + +#255#203#152'e'#255#203#152'e'#255#203#152'e'#255#203#152'e'#255#203#152'e' + +#255#202#150'd'#255#165'jC'#255'\3!'#247'DDD'#151'MMM'#10#0#0#0#0#0#0#0#0'@@' + +'@'#8'Z6%'#206#142'T5'#255#195#142'a'#255#198#145'c'#255#198#145'c'#255#198 + +#145'c'#255#198#145'c'#255'W@,'#255#1#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255'%'#27#19#255#198#145'c'#255#198#145'c'#255'U>+' + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#1#0#0#255#1#1#1#255#27#20#13#255'vW;' + +#255#198#145'c'#255#198#145'c'#255#198#145'c'#255#198#145'c'#255#198#145'c' + +#255#198#145'c'#255#198#145'c'#255#184'}S'#255'`4 '#252'FA>'#183'@@@'#12#0#0 + +#0#0#0#0#0#0'999'#9']2'#30#243#166'gD'#255#192#138'`'#255#192#139'a'#255#192 + +#139'a'#255#192#139'a'#255#190#137'a'#255#1#1#1#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#8#6#4#255#192#139'a'#255#192#139 + +'a'#255#129']B'#255#1#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#1#0#0#255'Q;)'#255#192#139'a' + +#255#192#139'a'#255#192#139'a'#255#192#139'a'#255#192#139'a'#255#192#139'a' + +#255#192#139'a'#255#192#139'a'#255#192#139'a'#255#192#139'a'#255#188#132'[' + +#255'u@'''#252'M;3'#212'999'#18#0#0#0#0#0#0#0#0'FFF'#11'^1'#29#250#174'oK' + +#255#186#131'\'#255#186#131'\'#255#186#131'\'#255#186#131'\'#255'vS:'#255#1#1 + +#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#1#0#0#255 + +'S:)'#255#186#131'\'#255#186#131'\'#255#184#129'\'#255'('#28#20#255#1#0#0#255 + +#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255'Q9('#255#186#131'\'#255#186#131'\'#255#186#131'\'#255#186#131'\'#255#186 + +#131'\'#255#186#131'\'#255#186#131'\'#255#186#131'\'#255#186#131'\'#255#186 + +#131'\'#255#186#131'\'#255#186#130'['#255#131'I-'#255'Q9-'#221'FFF!'#0#0#0#1 + +#0#0#0#0'M33'#20'_2'#30#251#173'pN'#255#180'{X'#255#180'{X'#255#180'{X'#255 + +#180'{X'#255'-'#30#22#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#2#1#1#255'dE1'#255#180'{X'#255#180'{X'#255#180'{X'#255#180'{X'#255 + +#180'{X'#255'O6&'#255#2#1#1#255#1#1#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255'G0#'#255#180'{X'#255#180'{X'#255#178'{X'#255'hH3'#255'U:)'#255 + +'mK5'#255#180'{X'#255#180'{X'#255#180'{X'#255#180'{X'#255#180'{X'#255#180'{X' + +#255#180'{X'#255#139'P3'#255'U7)'#231'BBB2UUU'#3#0#0#0#0'T1&,c5 '#249#174'rQ' + +#255#178'wW'#255#178'wW'#255#178'wW'#255#178'wW'#255#8#5#4#255#0#0#0#255#0#0 + +#0#255#0#0#0#255#0#0#0#255#1#0#0#255#27#18#13#255#164'nQ'#255#178'wW'#255#178 + +'wW'#255#178'wW'#255#178'wW'#255#178'wW'#255#178'wW'#255#178'wW'#255#178'wW' + +#255#142'_F'#255'H0#'#255#20#13#10#255#25#16#12#255'9'''#28#255'lI5'#255#178 + +'wW'#255#178'wW'#255'kG4'#255#1#1#1#255#1#1#0#255#1#0#0#255#1#0#0#255#3#2#1 + +#255'zQ<'#255#178'wW'#255#178'wW'#255#178'wW'#255#178'wW'#255#178'wW'#255#149 + +'W9'#255'Z5%'#238'DDD-'#128#128#128#2#0#0#0#0'Y3 Bj8#'#248#173'qS'#255#175't' + +'W'#255#175'tW'#255#175'tW'#255#175'tW'#255#1#0#0#255#1#1#1#255#0#0#0#255#0#0 + +#0#255#5#3#3#255'cB2'#255#175'tW'#255#175'tW'#255#175'tW'#255#175'tW'#255#175 + +'tW'#255#175'tW'#255#175'tW'#255#175'tW'#255#175'tW'#255#175'tW'#255#175'tW' + +#255#175'tW'#255#175'tW'#255#175'tW'#255#175'tW'#255#175'tW'#255#175'tW'#255 + +#173'rU'#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#2#1 + +#1#255#152'eL'#255#175'tW'#255#175'tW'#255#175'tW'#255#175'tW'#255#155'[>' + +#255'\4"'#244'@@@'#28#0#0#0#1#0#0#0#0'X0!3g7"'#246#172'oR'#255#174'rV'#255 + +#174'rV'#255#174'rV'#255#166'lR'#255#7#5#3#255#131'VA'#255#155'fM'#255'oI7' + +#255#174'rV'#255#174'rV'#255#174'rV'#255#174'rV'#255#174'rV'#255#174'rV'#255 + +#174'rV'#255#174'rV'#255#174'rV'#255#174'rV'#255#174'rV'#255#174'rV'#255#174 + +'rV'#255#174'rV'#255#174'rV'#255#174'rV'#255#174'rV'#255#174'rV'#255#174'rV' + +#255#153'dL'#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255 + +#0#0#0#255'<'''#29#255#174'rV'#255#174'rV'#255#174'rV'#255#173'qU'#255#151'Y' + +'='#255']6%'#239'333'#15#0#0#0#0#0#0#0#0'O1'''#25'b3'#31#247#168'jN'#255#172 + +'oU'#255#172'oU'#255#172'oU'#255#172'oU'#255#172'oU'#255#172'oU'#255#172'oU' + +#255#172'oU'#255#172'oU'#255#172'oU'#255#172'oU'#255#172'oU'#255#136'XD'#255 + ,'U7*'#255'^=/'#255'kE5'#255#170'oU'#255#172'oU'#255#172'oU'#255#172'oU'#255 + +#172'oU'#255#172'oU'#255#172'oU'#255#172'oU'#255#172'oU'#255#172'oU'#255#172 + +'oU'#255#172'oU'#255#5#3#2#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255'!'#21#16#255#172'oU'#255#172'oU'#255#172'oU'#255#172'oT'#255 + +#143'R7'#255'Y6('#225'@@@'#12#0#0#0#0#0#0#0#0'333'#5'_2'#31#248#167'hL'#255 + +#172'qW'#255#172'qX'#255#172'qX'#255#172'qX'#255#172'qX'#255#172'qX'#255#172 + +'qX'#255#172'qX'#255#172'qX'#255#172'qX'#255#172'qX'#255':&'#30#255#1#0#0#255 + +#1#1#0#255#1#1#1#255#1#1#0#255#4#2#2#255#133'WD'#255#172'qX'#255#172'qX'#255 + +#172'qX'#255#172'qX'#255#172'qX'#255#172'qX'#255#172'qX'#255#172'qX'#255#172 + +'qX'#255#172'qX'#255'E.$'#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#30#20#15#255#172'qX'#255#172'qX'#255#172'qX'#255#172'pV'#255 + +#134'K2'#255'V8)'#199'999'#9#0#0#0#0#0#0#0#0#0#0#0#1'_3'#30#239#164'fJ'#255 + +#175'w]'#255#175'w^'#255#175'w^'#255#175'w^'#255#175'w^'#255#175'w^'#255#175 + +'w^'#255#175'w^'#255#175'w^'#255#175'w^'#255'hF7'#255#1#0#0#255#0#0#0#255#0#0 + +#0#255#0#0#0#255#0#0#0#255#0#0#0#255#7#5#4#255#175'w^'#255#175'w^'#255'{TB' + +#255'X;/'#255']?2'#255#127'VD'#255#175'w^'#255#175'w^'#255#175'w^'#255#175'w' + +'^'#255#165'qY'#255#1#1#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#1#1#1 + +#255'fF7'#255#175'w^'#255#175'w^'#255#175'w^'#255#175'v\'#255'{D-'#253'S5(' + +#154'333'#5#0#0#0#0#0#0#0#0#0#0#0#0'a3'#30#200#149'Z?'#255#179'|c'#255#179'}' + +'e'#255#179'}e'#255#179'}e'#255#179'}e'#255#179'}e'#255#179'}e'#255#179'}e' + +#255#179'}e'#255#179'}e'#255#19#13#11#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#2#1#1#255#179'}e'#255'E0'''#255#1#0#0#255#1#1#0#255 + +#1#1#0#255#0#0#0#255'R:/'#255#179'}e'#255#179'}e'#255#179'}e'#255#179'}e'#255 + +'.!'#26#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#1#1#1#255#177'}e'#255#179 + +'}e'#255#179'}e'#255#179'}e'#255#175'v\'#255'g8$'#251'W7*O'#0#0#0#1#0#0#0#0#0 + +#0#0#0#0#0#0#0'[0'#29'lyD-'#249#181#128'i'#255#183#131'l'#255#183#131'l'#255 + +#183#131'l'#255#183#131'l'#255#183#131'l'#255#183#131'l'#255#183#131'l'#255 + +#183#131'l'#255#183#131'l'#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255'"'#25#20#255#183#131'l'#255#0#0#0#255#0#0#0#255#0#0 + +#0#255#0#0#0#255#0#0#0#255#0#0#0#255'B/'''#255#183#131'l'#255#183#131'l'#255 + +#183#131'l'#255#169'yd'#255#1#1#1#255#0#0#0#255#0#0#0#255#0#0#0#255'#'#25#21 + +#255#183#131'l'#255#183#131'l'#255#183#131'l'#255#183#131'l'#255#167'lQ'#255 + +'^3'#31#248'@@@'#12#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'Y1'#30#26'b5 '#244#178'z' + +'c'#255#187#138't'#255#187#138'u'#255#187#138'u'#255#187#138'u'#255#187#138 + +'u'#255#187#138'u'#255#187#138'u'#255#187#138'u'#255#187#138'u'#255#2#2#1#255 + +#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#1#1#0#255#170'~j'#255#177 + +#130'o'#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#4#3#3 + +#255#187#138'u'#255#187#138'u'#255#187#138'u'#255#187#138'u'#255'jNB'#255#11 + +#8#7#255#0#0#0#255#0#0#0#255#152'p`'#255#187#138'u'#255#187#138'u'#255#187 + +#138'u'#255#186#136'r'#255#144'W?'#255']6#'#193'333'#5#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0'`4'#31#217#160'gN'#255#190#143'{'#255#191#145'}'#255#191 + +#145'}'#255#191#145'}'#255#191#145'}'#255#191#145'}'#255#191#145'}'#255#191 + +#145'}'#255#191#145'}'#255#19#14#12#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255'7*$'#255#191#145'}'#255#164'|k'#255#1#1#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#2#2#1#255#191#145'}'#255#191#145'}'#255 + +#191#145'}'#255#191#145'}'#255#191#145'}'#255#191#145'}'#255#0#0#0#255#30#23 + +#20#255#191#145'}'#255#191#145'}'#255#191#145'}'#255#191#145'}'#255#187#138 + +'t'#255'p>('#249'Y2#U'#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'[/'#27 + +'huB+'#244#190#142'z'#255#195#152#132#255#195#152#132#255#195#152#132#255#195 + +#152#132#255#195#152#132#255#195#152#132#255#195#152#132#255#195#152#132#255 + +'A3,'#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#1#0#0#255#183#142'|'#255 + +#195#152#132#255#138'k]'#255#1#1#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#9#7#6#255#195#152#132#255#195#152#132#255#195#152#132#255#195 + +#152#132#255#195#152#132#255#195#152#132#255#1#1#1#255#160'}m'#255#195#152 + +#132#255#195#152#132#255#195#152#132#255#194#150#131#255#167'pW'#255'`4 '#240 + +'M33'#10#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'@@'#0#4'`3'#30#229 + +#164'nU'#255#197#156#137#255#199#159#141#255#199#159#141#255#199#159#141#255 + +#199#159#141#255#199#159#141#255#199#159#141#255#199#159#141#255'x`U'#255#1#1 + +#1#255#0#0#0#255#0#0#0#255#0#0#0#255#18#14#13#255#199#159#141#255#199#159#141 + +#255' '#26#23#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#1#1#0#255 + +#139'oc'#255#199#159#141#255#199#159#141#255#199#159#141#255#199#159#141#255 + +#199#159#141#255#199#159#141#255'^KC'#255#199#159#141#255#199#159#141#255#199 + +#159#141#255#199#159#141#255#192#147#127#255'rB-'#249'\1 k'#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'\.'#28'Sn>('#243#194#149#131 + ,#255#202#165#148#255#203#165#149#255#203#165#149#255#203#165#149#255#203#165 + +#149#255#203#165#149#255#203#165#149#255#169#138'|'#255#0#0#0#255#1#1#1#255 + +#16#13#11#255#23#19#17#255#171#139'~'#255#203#165#149#255#203#165#149#255#3#3 + +#2#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#1#0#0#255'*"'#31#255#203#165 + +#149#255#203#165#149#255#203#165#149#255#203#165#149#255#203#165#149#255#203 + +#165#149#255#203#165#149#255#203#165#149#255#203#165#149#255#203#165#149#255 + +#203#165#149#255#201#162#145#255#163'mU'#255'_3'#31#227'U'#0#0#3#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'a3'#30#213#153 + +'eM'#254#204#167#151#255#207#172#158#255#207#172#158#255#207#172#158#255#207 + +#172#158#255#207#172#158#255#207#172#158#255#205#170#156#255#0#0#0#255'<1.' + +#255#207#172#158#255#207#172#158#255#207#172#158#255#207#172#158#255#207#172 + +#158#255#20#16#15#255#1#0#0#255#0#0#0#255#0#0#0#255#1#0#0#255'?40'#255#207 + +#172#158#255#207#172#158#255#207#172#158#255#207#172#158#255#207#172#158#255 + +#207#172#158#255#207#172#158#255#207#172#158#255#207#172#158#255#207#172#158 + +#255#207#172#158#255#207#171#156#255#192#147#127#255'k<'''#244'Z.'#29'L'#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +'^/'#27'&b5!'#240#174'{f'#255#209#176#162#255#212#180#167#255#212#180#167#255 + +#212#180#167#255#212#180#167#255#212#180#167#255#212#180#167#255#6#5#5#255 + +#179#151#140#255#212#180#167#255#212#180#167#255#212#180#167#255#212#180#167 + +#255#212#180#167#255#212#180#167#255'gXR'#255#0#0#0#255#0#0#0#255'gXR'#255 + +#212#180#167#255#212#180#167#255#212#180#167#255#212#180#167#255#212#180#167 + +#255#212#180#167#255#212#180#167#255#212#180#167#255#212#180#167#255#212#180 + +#167#255#212#180#167#255#211#179#166#255#202#162#146#255#127'M7'#248'`2'#31 + +#169#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0'[/'#26'Fg:#'#242#190#145#127#255#214#184#172#255#216 + +#187#176#255#216#187#176#255#216#187#176#255#216#187#176#255#216#187#176#255 + +'k]X'#255#216#187#176#255#216#187#176#255#216#187#176#255#216#187#176#255#216 + +#187#176#255#216#187#176#255#216#187#176#255'E<8'#255#0#0#0#255'>63'#255#216 + +#187#176#255#216#187#176#255#216#187#176#255#216#187#176#255#216#187#176#255 + +#216#187#176#255#216#187#176#255#216#187#176#255#216#187#176#255#216#187#176 + +#255#216#187#176#255#216#187#175#255#210#176#163#255#147'_H'#252'`4'#31#210 + +'U++'#6#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'\0'#29'trB-'#242#198#157#140#255#218#191 + +#180#255#221#195#185#255#221#195#185#255#221#195#185#255#221#195#185#255#221 + +#195#185#255#221#195#185#255#221#195#185#255#221#195#185#255#221#195#185#255 + +#221#195#185#255#221#195#185#255#221#195#185#255',''%'#255'920'#255#221#195 + +#185#255#221#195#185#255#221#195#185#255#221#195#185#255#221#195#185#255#221 + +#195#185#255#221#195#185#255#221#195#185#255#221#195#185#255#221#195#185#255 + +#221#195#185#255#220#194#184#255#213#183#170#255#162'oW'#255'b5 '#232'].'#23 + +#22#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'_1'#30#138'l>)'#242#187#143'|' + +#255#221#196#186#255#225#202#193#255#225#203#194#255#225#203#194#255#225#203 + +#194#255#225#203#194#255#225#203#194#255#225#203#194#255#225#203#194#255#225 + +#203#194#255#225#203#194#255#225#203#194#255#225#203#194#255#225#203#194#255 + +#225#203#194#255#225#203#194#255#225#203#194#255#225#203#194#255#225#203#194 + +#255#225#203#194#255#225#203#194#255#225#203#194#255#225#203#194#255#225#203 + +#194#255#224#201#192#255#212#180#168#255#149'aK'#252'a5!'#230']2'#25')'#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'[/'#28'\d9$'#241#172 + +'|h'#255#222#197#187#255#228#206#200#255#230#209#203#255#230#209#203#255#230 + +#209#203#255#230#209#203#255#230#209#203#255#230#209#203#255#230#209#203#255 + +#230#209#203#255#230#209#203#255#230#209#203#255#230#209#203#255#230#209#203 + +#255#230#209#203#255#230#209#203#255#230#209#203#255#230#209#203#255#230#209 + +#203#255#230#209#203#255#230#209#203#255#229#209#202#255#226#204#197#255#208 + +#173#159#255#131'R;'#245'a3'#31#207'Y3'#26#20#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'].'#28'7a5!'#236#137'WB'#248#201 + +#163#148#255#229#210#202#255#233#215#210#255#234#217#212#255#234#217#212#255 + +#234#217#212#255#234#217#212#255#234#217#212#255#234#217#212#255#234#217#212 + +#255#234#217#212#255#234#217#212#255#234#217#212#255#234#217#212#255#234#217 + +#212#255#234#217#212#255#234#217#212#255#234#217#212#255#234#216#211#255#231 + +#212#206#255#221#195#185#255#174#128'm'#255'm>*'#242'`1'#29#163'f33'#5#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + ,#0#0#0#0#0'b'''#20#13'`2'#29#140'd8$'#241#151'hR'#251#211#179#167#255#233#215 + +#210#255#236#220#215#255#237#222#219#255#238#225#221#255#238#225#221#255#238 + +#225#221#255#238#225#221#255#238#225#221#255#238#225#221#255#238#225#221#255 + +#238#225#221#255#238#225#221#255#238#223#220#255#236#221#217#255#234#219#213 + +#255#227#205#198#255#188#146#128#255'wH2'#242'b5 '#219'].'#27'B'#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'X1'#29#26'a3'#30#168'f:$'#242#134'T?' + +#246#179#136'v'#255#214#183#172#255#235#218#214#255#238#225#221#255#239#226 + +#223#255#240#227#224#255#240#227#225#255#240#227#225#255#239#226#223#255#239 + +#225#222#255#238#224#220#255#226#204#196#255#199#161#145#255#158'o['#254'rD-' + +#239'b4"'#232'^2'#30'\'#0#0#0#1#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0'`+ '#24']/'#30'fd6#'#197'c8#'#243'vE0'#240#140'ZF' + +#247#156'mY'#255#171#127'm'#255#184#143#127#255#178#136'v'#255#164'wd'#255 + +#148'dP'#252#130'Q;'#243'l<('#239'b6"'#234'b5!'#151'Z-'#29'>UU'#0#3#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0'].'#23#11'Z/'#29'G^4 fa4!'#130'd6!'#166'd7#'#194 + +'d7"'#182'c6"'#150'_3'#31's\0'#29'YY/'#30'+'#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#255#255#224#3#255#255#255 + +#255#255#254#0#0#127#255#255#255#255#248#0#0#31#255#255#255#255#224#0#0#7#255 + +#255#255#255#192#0#0#3#255#255#255#255#128#0#0#1#255#255#255#255#0#0#0#0#127 + +#255#255#254#0#0#0#0#127#255#255#252#0#0#0#0'?'#255#255#248#0#0#0#0#31#255 + +#255#240#0#0#0#0#15#255#255#240#0#0#0#0#15#255#255#224#0#0#0#0#7#255#255#224 + +#0#0#0#0#3#255#255#192#0#0#0#0#3#255#255#192#0#0#0#0#3#255#255#192#0#0#0#0#1 + +#255#255#128#0#0#0#0#1#255#255#128#0#0#0#0#1#255#255#128#0#0#0#0#1#255#255 + +#128#0#0#0#0#1#255#255#128#0#0#0#0#0#255#255#128#0#0#0#0#0#255#255#128#0#0#0 + +#0#0#255#255#128#0#0#0#0#0#255#255#128#0#0#0#0#1#255#255#128#0#0#0#0#1#255 + +#255#128#0#0#0#0#1#255#255#128#0#0#0#0#1#255#255#192#0#0#0#0#1#255#255#192#0 + +#0#0#0#3#255#255#192#0#0#0#0#3#255#255#224#0#0#0#0#7#255#255#224#0#0#0#0#7 + +#255#255#224#0#0#0#0#15#255#255#240#0#0#0#0#15#255#255#248#0#0#0#0#31#255#255 + +#248#0#0#0#0'?'#255#255#252#0#0#0#0'?'#255#255#254#0#0#0#0#127#255#255#255#0 + +#0#0#0#255#255#255#255#128#0#0#1#255#255#255#255#192#0#0#3#255#255#255#255 + +#224#0#0#15#255#255#255#255#248#0#0#31#255#255#255#255#254#0#0#127#255#255 + +#255#255#255#192#7#255#255#255#255#255#255#255#255#255#255#255#255'('#0#0#0 + +' '#0#0#0'@'#0#0#0#1#0' '#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#2'CCC'#19'FFF'#22'UUU'#3#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0'@@@'#12'EAAGDDB'#133'DDC'#181'HC?'#205'LA;'#213 + +'JB='#212'FC@'#204'EED'#185'DDC'#145'DDDSFFF'#22#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'III'#14'EEBoLA;'#208'eE-'#235'xK(' + +#246#131'R)'#250#139'W*'#251#149'_,'#252#145'\+'#252#136'V*'#250#128'Q('#249 + +'rI)'#244'\D2'#227'FB?'#207'CCC'#134'DDD'#30#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0'EEENMA9'#206'oF)'#245#147']-'#252#187'}4'#255#211#150'9'#255#224 + +#167';'#255#230#174'='#255#234#179'>'#255#233#178'>'#255#228#171'='#255#221 + +#163'<'#255#205#143'8'#255#175'r2'#255#131'R*'#250'eC,'#238'FB?'#205'CCCoUUU' + +#3#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0'@@@'#4'GEA|dB+'#239#142'[.'#252#198#137'<'#255#227#172'C'#255 + +#236#183'E'#255#242#190'F'#255#246#195'G'#255#248#198'G'#255#249#199'H'#255 + +#249#198'H'#255#247#196'G'#255#245#193'G'#255#240#188'F'#255#234#180'D'#255 + +#220#163'A'#255#183'y8'#255'}O*'#250'WA4'#225'CCC'#152'<<<'#17#0#0#0#0#0#0#0 + ,#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#1'G@='#148 + +'lD*'#245#175'u8'#254#221#166'I'#255#234#182'M'#255#242#193'P'#255#243#194'O' + +#255#244#195'O'#255#244#195'P'#255#244#195'P'#255#244#195'P'#255#244#195'P' + +#255#244#195'P'#255#244#195'P'#255#243#194'O'#255#243#194'O'#255#240#190'O' + +#255#230#179'L'#255#212#155'F'#255#148'^1'#252'`A.'#234'CCC'#171'@@@'#12#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'FA>vmB)'#247#189 + +#130'A'#255#224#172'P'#255#236#187'U'#255#238#189'W'#255#238#190'V'#255#238 + +#190'V'#255#238#190'V'#255'fQ%'#255#17#14#6#255#17#13#6#255#16#13#6#255',#' + +#16#255#155'|8'#255#238#190'V'#255#238#190'V'#255#238#189'V'#255#238#189'W' + +#255#233#184'U'#255#217#163'M'#255#164'l8'#254'_>+'#238'DDD'#147#128#128#128 + +#2#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'FDD=e?*'#243#183'}B'#255 + +#223#171'W'#255#232#183'['#255#232#183'\'#255#232#183'\'#255#232#183'\'#255 + +#232#183'\'#255'>1'#25#255#1#1#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255 + +#1#1#1#255#5#4#2#255#22#17#9#255'pX,'#255#218#171'V'#255#232#183'\'#255#230 + +#182'['#255#217#164'T'#255#152'a7'#252'V=1'#228'DDDb'#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#128#128#128#2'Z<-'#215#163'k='#254#217#166'['#255#226#178'`' + +#255#226#179'a'#255#226#179'a'#255#226#179'a'#255#226#179'a'#255#226#179'a' + +#255#5#4#2#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#3#3#1#255',#'#19#255#226#179'a'#255#225#177'_' + +#255#208#154'T'#255#129'O1'#251'H?;'#205'@@@'#20#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0'J@<[vF,'#249#206#153'Y'#255#220#172'b'#255#220#172'c'#255#220#172'c'#255 + +#220#172'c'#255#220#172'c'#255#220#172'c'#255#205#160']'#255#4#3#2#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#1#0#0#255'.$'#21#255#220#172'c'#255#218#170'a'#255#190#132 + +'N'#255'c=)'#242'CCCz'#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'\9('#218#177'vG'#255 + +#213#164'c'#255#214#166'e'#255#214#166'e'#255#214#166'e'#255#214#166'e'#255 + +#214#166'e'#255#214#166'e'#255#214#166'e'#255'v\8'#255#2#2#1#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#11#9#5#255#214#166'e'#255#214#166'e'#255#209#159'a'#255#139'Y' + +'6'#252'K>7'#206'333'#5#0#0#0#0#0#0#0#0'?;9'#19'mA+'#247#201#148'^'#255#209 + +#159'e'#255#209#159'e'#255#209#159'e'#255#146'oF'#255#18#14#9#255#21#16#10 + +#255'O<&'#255#209#159'e'#255#209#159'e'#255'$'#27#17#255#0#0#0#255#0#0#0#255 + +#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#11#8#5#255#209#159'e'#255#209#159'e'#255#208#158'e'#255#185#128'Q'#255 + +'^9)'#240'BBB6'#0#0#0#0#0#0#0#0'P8-q'#144'Z:'#252#201#150'd'#255#202#151'd' + +#255#202#151'd'#255'uW:'#255#2#1#1#255#0#0#0#255#0#0#0#255#1#0#0#255'-!'#22 + +#255#202#151'd'#255'ZC-'#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#1#1#0#255#5#4#3#255'gM3'#255#202#151'd' + +#255#202#151'd'#255#202#151'd'#255#197#145'`'#255'l@*'#248'CCBo'#0#0#0#0#0#0 + +#0#0'^7$'#194#171'pK'#255#194#140'a'#255#194#140'a'#255#194#140'a'#255#6#4#3 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#7#5#4#255#194#140'a'#255#139'eE' + +#255#1#1#1#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#13 + +#9#6#255'wV<'#255#192#138'a'#255#194#140'a'#255#194#140'a'#255#194#140'a'#255 + +#194#140'a'#255#193#140'a'#255#137'T7'#252'K=6'#158#0#0#0#0#0#0#0#0'a6#'#220 + +#177'uQ'#255#185#129'['#255#185#129'['#255#127'Y>'#255#1#1#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#2#1#1#255'8'''#27#255#185#129'['#255#185#129'['#255'+'#30 + +#21#255#2#1#1#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#13#9#6#255#179'}Y' + +#255#185#129'['#255#185#129'['#255#185#129'['#255#185#129'['#255#185#129'[' + +#255#185#129'['#255#185#129'['#255#152'^>'#255'P:1'#190#0#0#0#0#0#0#0#0'c7#' + +#227#175'sS'#255#178'xW'#255#178'xW'#255','#30#21#255#0#0#0#255#0#0#0#255#0#0 + +#0#255#5#4#3#255'uO:'#255#178'xW'#255#178'xW'#255#178'xW'#255#178'xW'#255'xP' + +':'#255'('#26#19#255#10#7#5#255#10#7#5#255#28#19#13#255#168'rS'#255#163'nO' + +#255#25#17#12#255#6#4#3#255#17#11#8#255'bB/'#255#178'xW'#255#178'xW'#255#178 + +'xW'#255#158'aB'#255'V9,'#210#0#0#0#0#0#0#0#0'f7"'#227#173'sT'#255#175'tW' + +#255#175'tW'#255#15#10#7#255#13#8#6#255#5#4#3#255'+'#29#21#255#169'pU'#255 + +#175'tW'#255#175'tW'#255#175'tW'#255#175'tW'#255#175'tW'#255#175'tW'#255#175 + +'tW'#255#175'tW'#255#175'tW'#255#175'tW'#255#175'tW'#255#17#11#8#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#2#2#1#255#136'ZD'#255#175'tW'#255#175'tW'#255#161'd' + +'G'#255'[8('#211#0#0#0#0#0#0#0#0'e6"'#218#171'nR'#255#173'qV'#255#173'qV'#255 + +#136'YC'#255#173'qV'#255#173'qV'#255#173'qV'#255#173'qV'#255#173'qV'#255'sK9' + +#255'uM:'#255#159'gN'#255#173'qV'#255#173'qV'#255#173'qV'#255#173'qV'#255#173 + +'qV'#255#173'qV'#255#173'qV'#255'5"'#27#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0 + +#0#255'H/$'#255#173'qV'#255#173'qV'#255#153'^D'#255'Y8*'#188#0#0#0#0#0#0#0#0 + +'c5 '#203#170'kQ'#255#174'sY'#255#174'sY'#255#174'sY'#255#174'sY'#255#174'sY' + ,#255#174'sY'#255#164'mU'#255#11#7#6#255#1#1#1#255#1#1#1#255#5#3#2#255#127'TA' + +#255#174'sY'#255#174'sY'#255#174'sY'#255#174'sY'#255#174'sY'#255#174'sY'#255 + +#128'UA'#255#2#1#1#255#0#0#0#255#0#0#0#255#0#0#0#255'J1&'#255#174'sY'#255#174 + +'sY'#255#147'X?'#255'S8,'#140#0#0#0#0#0#0#0#0'd4'#30#153#162'gM'#255#178'{c' + +#255#178'{c'#255#178'{c'#255#178'{c'#255#178'{c'#255#178'{c'#255'A-$'#255#0#0 + +#0#255#0#0#0#255#0#0#0#255#0#0#0#255#20#14#11#255'xSB'#255#6#4#3#255#5#4#3 + +#255#18#12#10#255#170'u_'#255#178'{c'#255#178'{c'#255#9#6#5#255#0#0#0#255#0#0 + +#0#255#3#2#2#255#166's]'#255#178'{c'#255#178'{c'#255#131'P8'#252'S3$>'#0#0#0 + +#0#0#0#0#0'[/'#27'3'#137'T='#247#184#134'o'#255#184#134'o'#255#184#134'o'#255 + +#184#134'o'#255#184#134'o'#255#184#134'o'#255#14#10#9#255#0#0#0#255#0#0#0#255 + +#0#0#0#255#1#1#1#255'\C7'#255#14#10#8#255#0#0#0#255#0#0#0#255#0#0#0#255#14#10 + +#8#255#184#134'o'#255#184#134'o'#255'xWI'#255#2#1#1#255#0#0#0#255#18#14#11 + +#255#184#134'o'#255#184#134'o'#255#183#131'l'#255'h:&'#240#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0'n<%'#218#189#140'x'#255#190#143'z'#255#190#143'z'#255#190#143 + +'z'#255#190#143'z'#255#190#143'z'#255',!'#28#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#9#7#6#255#190#143'z'#255#9#7#6#255#0#0#0#255#0#0#0#255#0#0#0#255#5#4#3 + +#255#190#143'z'#255#190#143'z'#255#190#143'z'#255#159'xe'#255#0#0#0#255#140 + +'jZ'#255#190#143'z'#255#190#143'z'#255#175'yc'#255'b6"'#193#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0'd4'#30#151#167's\'#254#196#154#135#255#196#154#135#255#196#154 + +#135#255#196#154#135#255#196#154#135#255'qYN'#255#0#0#0#255#0#0#0#255#1#1#1 + +#255'v]R'#255#194#152#133#255#5#4#4#255#0#0#0#255#0#0#0#255#0#0#0#255#10#8#7 + +#255#196#154#135#255#196#154#135#255#196#154#135#255#196#154#135#255'"'#27#24 + +#255#196#154#135#255#196#154#135#255#196#154#135#255#131'R<'#248'^1'#28'1'#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'[/'#27#14'o>('#224#198#157#140#255#202#163#146 + +#255#202#163#146#255#202#163#146#255#202#163#146#255#170#138'{'#255#0#0#0#255 + +#8#6#6#255#26#21#19#255#202#163#146#255#143'th'#255#1#1#1#255#0#0#0#255#0#0#0 + +#255#2#2#2#255#143'sg'#255#202#163#146#255#202#163#146#255#202#163#146#255 + +#202#163#146#255#191#155#138#255#202#163#146#255#202#163#146#255#183#135'r' + +#255'd5 '#193#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'd3'#30'{'#156 + +'jS'#248#209#174#160#255#209#174#160#255#209#174#160#255#209#174#160#255#209 + +#174#160#255#2#2#2#255#205#172#158#255#209#174#160#255#209#174#160#255#169 + +#140#129#255#11#9#9#255#1#1#0#255#4#3#3#255#132'oe'#255#209#174#160#255#209 + +#174#160#255#209#174#160#255#209#174#160#255#209#174#160#255#209#174#160#255 + +#209#174#160#255#205#167#152#255'yG3'#235'[/'#27'"'#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'd4'#30#181#179#134'r'#254#215#185#173#255#215 + +#185#173#255#215#185#173#255#215#185#173#255'm^X'#255#215#185#173#255#215#185 + +#173#255#215#185#173#255#215#185#173#255#133'sk'#255#0#0#0#255#156#134'}'#255 + +#215#185#173#255#215#185#173#255#215#185#173#255#215#185#173#255#215#185#173 + +#255#215#185#173#255#215#185#173#255#214#183#172#255#143'^I'#243'b3'#29'`'#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'[/'#27#8'f6 ' + +#205#189#148#131#254#222#197#187#255#222#197#187#255#222#197#187#255#222#197 + +#187#255#222#197#187#255#222#197#187#255#222#197#187#255#222#197#187#255#127 + +'qk'#255#134'wq'#255#222#197#187#255#222#197#187#255#222#197#187#255#222#197 + +#187#255#222#197#187#255#222#197#187#255#222#197#187#255#220#193#183#255#159 + +'o['#247'd3'#30#147#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0'[/'#27#15'c3'#30#193#176#132'q'#248#228#206#199#255 + +#228#208#201#255#228#208#201#255#228#208#201#255#228#208#201#255#228#208#201 + +#255#228#208#201#255#228#208#201#255#228#208#201#255#228#208#201#255#228#208 + +#201#255#228#208#201#255#228#208#201#255#228#208#201#255#228#208#201#255#221 + +#196#186#255#141']I'#237'c3'#29#129#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'[/'#27#2'c3'#29#150 + +#135'XD'#231#208#176#164#255#235#219#215#255#235#219#215#255#235#219#215#255 + +#235#219#215#255#235#219#215#255#235#219#215#255#235#219#215#255#235#219#215 + +#255#235#219#215#255#235#219#215#255#235#219#215#255#232#214#209#255#189#149 + +#133#253'qA+'#220'a2'#29'O'#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'[/'#27 + +'"e4'#30#185#144'cO'#235#195#158#144#254#230#209#203#255#242#231#229#255#242 + +#231#229#255#242#231#229#255#242#231#229#255#242#231#229#255#241#230#226#255 + +#220#193#184#255#180#141'|'#251'zK6'#226'd3'#30#142'[/'#27#10#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'[/'#27#28'b3'#29'{g5'#30 + +#198'xH2'#218#137']J'#229#156'r`'#236#151'mZ'#234#132'VB'#227'q?)'#213'f4'#30 + +#182'_1'#28'W[/'#27#11#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + ,#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'[/'#27#5'[/' + +#27#30'[/'#27#22'[/'#27#1#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#255#252'?'#255 + +#255#192#3#255#255#0#0#255#254#0#0'?'#248#0#0#31#240#0#0#15#240#0#0#7#224#0#0 + +#7#192#0#0#3#192#0#0#3#192#0#0#1#128#0#0#1#128#0#0#1#128#0#0#1#128#0#0#1#128 + +#0#0#1#128#0#0#1#128#0#0#1#128#0#0#1#128#0#0#1#128#0#0#3#192#0#0#3#192#0#0#3 + +#192#0#0#7#224#0#0#7#240#0#0#15#240#0#0#31#248#0#0'?'#252#0#0#127#255#0#0#255 + +#255#192#3#255#255#252'?'#255'('#0#0#0#16#0#0#0' '#0#0#0#1#0' '#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +';;;'#13'ICB7M=4zL>6xFBA;@@@'#16#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0'III'#7'W;,'#171'nC('#245#145'`+'#250#181#127'2'#253#175 + +'z1'#253#139'\*'#250'h?&'#244'P=3'#159'@@@'#12#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0'K921d;'''#235#191#137'7'#254#249#198'E'#255#251#199'F'#255#251#200 + +'F'#255#251#200'F'#255#251#199'F'#255#246#194'E'#255#173'y3'#253'\9)'#229'E>' + +';2'#0#0#0#0#0#0#0#0#0#0#0#0'>2,'#7'nC'''#238#223#171'N'#255#239#191'U'#255 + +#240#192'U'#255#164#131':'#255'@3'#23#255'J;'#26#255'~e-'#255#196#157'E'#255 + +#239#191'U'#255#212#159'J'#255'a<('#231'MMM'#10#0#0#0#0#0#0#0#0'[7('#183#195 + +#145'N'#254#228#180'_'#255#228#180'_'#255#228#180'_'#255'40'#255#210#176#163#255 + +#148'|s'#255'RD?'#255#210#176#163#255#140'fW'#243'[/'#27#2#0#0#0#0'tI6'#209 + +#216#188#178#255#221#195#185#255#213#188#178#255'$'#31#30#255#131'sn'#255'sf' + +'`'#255#0#0#0#255'eYU'#255#221#195#185#255#221#195#185#255#204#180#170#255 + +#207#178#166#255'k>+'#182#0#0#0#0#0#0#0#0'[/'#27#31#156'xi'#240#232#213#207 + +#255#232#213#207#255#180#165#161#255#232#213#207#255#182#167#162#255'ICA'#255 + +#226#207#201#255#232#213#207#255#232#213#207#255#231#213#206#255#134'_O'#233 + +'[/'#27#12#0#0#0#0#0#0#0#0#0#0#0#0'd3'#30'e'#171#139'~'#240#239#226#224#255 + +#242#231#229#255#242#231#229#255#240#229#227#255#242#231#229#255#242#231#229 + +#255#242#231#229#255#235#221#216#255#153'uh'#236'a2'#29'?'#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0'\0'#27'*'#131'\I'#215#212#191#183#252#239#229#226#255 + +#253#250#252#255#253#249#250#255#236#223#220#255#204#180#172#250'yM;'#196'[/' + +#27#23#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'[/'#27#3'[/' + +#27'>c3'#29#131'uI4'#190'oA-'#183'b2'#29'v[/'#27'4'#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#248#31#172'A'#224#7#172'A'#192#3#172'A'#128#1#172'A'#128#1#172 + +'A'#0#0#172'A'#0#0#172'A'#0#0#172'A'#0#0#172'A'#0#0#172'A'#0#0#172'A'#128#1 + +#172'A'#128#1#172'A'#192#3#172'A'#224#7#172'A'#240#31#172'A' +]); + diff --git a/Sources/CentOS/Demos/CallInterfaceMethod/project2.rc b/Sources/CentOS/Demos/CallInterfaceMethod/project2.rc new file mode 100644 index 0000000..cf8429d --- /dev/null +++ b/Sources/CentOS/Demos/CallInterfaceMethod/project2.rc @@ -0,0 +1,7 @@ +#define RT_MANIFEST 24 +#define CREATEPROCESS_MANIFEST_RESOURCE_ID 1 +#define ISOLATIONAWARE_MANIFEST_RESOURCE_ID 2 +#define ISOLATIONAWARE_NOSTATICIMPORT_MANIFEST_RESOURCE_ID 3 + +CREATEPROCESS_MANIFEST_RESOURCE_ID RT_MANIFEST "project2.manifest" +MAINICON ICON "project2.ico" diff --git a/Sources/CentOS/Demos/CallInterfaceMethod/unit2.lfm b/Sources/CentOS/Demos/CallInterfaceMethod/unit2.lfm new file mode 100644 index 0000000..d6cf306 --- /dev/null +++ b/Sources/CentOS/Demos/CallInterfaceMethod/unit2.lfm @@ -0,0 +1,50 @@ +object Form1: TForm1 + Left = 291 + Height = 444 + Top = 153 + Width = 400 + Caption = 'Form1' + ClientHeight = 444 + ClientWidth = 400 + LCLVersion = '0.9.28.2' + object Button1: TButton + Left = 14 + Height = 25 + Top = 416 + Width = 96 + Caption = 'Run script' + OnClick = Button1Click + TabOrder = 0 + end + object Memo1: TMemo + Left = 14 + Height = 392 + Top = 16 + Width = 370 + Lines.Strings = ( + 'type' + ' TMyScriptClass = class(TInterfacedObject, IMyInterface)' + ' public ' + ' function Add(X, Y: Integer): Integer; ' + ' destructor Destroy; override;' + ' end;' + 'function TMyScriptClass.Add(X, Y: Integer): Integer;' + 'begin' + ' print ''Hello from script!'';' + ' result := X + Y;' + 'end;' + 'destructor TMyScriptClass.Destroy; ' + 'begin' + ' print ''Script object has been destroyed.'';' + ' inherited;' + 'end;' + 'var' + ' X: TMyScriptClass;' + 'begin' + ' X := TMyScriptClass.Create;' + ' PassToHost(X, 3, 4);' + 'end.' + ) + TabOrder = 1 + end +end diff --git a/Sources/CentOS/Demos/CallInterfaceMethod/unit2.lrs b/Sources/CentOS/Demos/CallInterfaceMethod/unit2.lrs new file mode 100644 index 0000000..6f404fb --- /dev/null +++ b/Sources/CentOS/Demos/CallInterfaceMethod/unit2.lrs @@ -0,0 +1,19 @@ +{ This is an automatically generated lazarus resource file } + +LazarusResources.Add('TForm1','FORMDATA',[ + 'TPF0'#6'TForm1'#5'Form1'#4'Left'#3'#'#1#6'Height'#3#188#1#3'Top'#3#153#0#5'W' + +'idth'#3#144#1#7'Caption'#6#5'Form1'#12'ClientHeight'#3#188#1#11'ClientWidth' + +#3#144#1#10'LCLVersion'#6#8'0.9.28.2'#0#7'TButton'#7'Button1'#4'Left'#2#14#6 + +'Height'#2#25#3'Top'#3#160#1#5'Width'#2'`'#7'Caption'#6#10'Run script'#7'OnC' + +'lick'#7#12'Button1Click'#8'TabOrder'#2#0#0#0#5'TMemo'#5'Memo1'#4'Left'#2#14 + +#6'Height'#3#136#1#3'Top'#2#16#5'Width'#3'r'#1#13'Lines.Strings'#1#6#4'type' + +#6'9 TMyScriptClass = class(TInterfacedObject, IMyInterface)'#6#10' publi' + +'c '#6', function Add(X, Y: Integer): Integer; '#6'# destructor De' + +'stroy; override;'#6#7' end;'#6'4function TMyScriptClass.Add(X, Y: Integer' + +'): Integer;'#6#5'begin'#6#30' print ''Hello from script!'';'#6#19' resu' + +'lt := X + Y;'#6#4'end;'#6'#destructor TMyScriptClass.Destroy; '#6#5'begin'#6 + +', print ''Script object has been destroyed.'';'#6#13' inherited;'#6#4'en' + +'d;'#6#3'var'#6#21' X: TMyScriptClass;'#6#5'begin'#6#30' X := TMyScriptC' + +'lass.Create;'#6#23' PassToHost(X, 3, 4);'#6#4'end.'#0#8'TabOrder'#2#1#0#0 + +#0 +]); diff --git a/Sources/CentOS/Demos/CallInterfaceMethod/unit2.pas b/Sources/CentOS/Demos/CallInterfaceMethod/unit2.pas new file mode 100644 index 0000000..a2c8189 --- /dev/null +++ b/Sources/CentOS/Demos/CallInterfaceMethod/unit2.pas @@ -0,0 +1,86 @@ +unit Unit2; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, FileUtil, LResources, Forms, Controls, Graphics, Dialogs, + StdCtrls, + PaxCompilerRegister, + PaxCompiler, PaxInterpreter, PaxRegister; + +type + + { TForm1 } + + TForm1 = class(TForm) + Button1: TButton; + Memo1: TMemo; + procedure Button1Click(Sender: TObject); + private + { private declarations } + public + { public declarations } + end; + + IMyInterface = interface + ['{D13115CA-4D57-4242-A54B-3684870CC7B3}'] + function Add(X, Y: Integer): Integer; + end; + +var + Form1: TForm1; + +implementation + +{ TForm1 } + +procedure PassToHost(X: IMyInterface; P1, P2: Integer); +begin + ShowMessage('Result = ' + IntToStr(X.Add(P1, P2))); +end; + +procedure TForm1.Button1Click(Sender: TObject); +var + PaxCompiler1: TPaxCompiler; + PaxInterpreter1: TPaxInterpreter; + PaxPascalLanguage1: TPaxPascalLanguage; + I: Integer; +begin + I := RegisterInterfaceType(0, 'IMyInterface', IMyInterface); + RegisterHeader(I, + 'function Add(X, Y: Integer): Integer;', nil, -1); + + RegisterHeader(0, + 'procedure PassToHost(X: IMyInterface; P1, P2: Integer);', + @ PassToHost); + + PaxCompiler1 := TPaxCompiler.Create(nil); + PaxInterpreter1 := TPaxInterpreter.Create(nil); + PaxPascalLanguage1 := TPaxPascalLanguage.Create(nil); + + try + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + PaxCompiler1.AddModule('1', 'Pascal'); + PaxCompiler1.AddCode('1', Memo1.Lines.Text); + if PaxCompiler1.Compile(PaxInterpreter1) then + begin + PaxInterpreter1.Run; + end + else + begin + ShowMessage(PaxCompiler1.ErrorMessage[0]); + end; + finally + PaxCompiler1.Free; + PaxInterpreter1.Free; + PaxPascalLanguage1.Free; + end; +end; + +initialization + {$I unit2.lrs} + +end. + diff --git a/Sources/CentOS/Demos/Hello/project3.ico b/Sources/CentOS/Demos/Hello/project3.ico new file mode 100644 index 0000000..0341321 Binary files /dev/null and b/Sources/CentOS/Demos/Hello/project3.ico differ diff --git a/Sources/CentOS/Demos/Hello/project3.lpi b/Sources/CentOS/Demos/Hello/project3.lpi new file mode 100644 index 0000000..a969301 --- /dev/null +++ b/Sources/CentOS/Demos/Hello/project3.lpi @@ -0,0 +1,124 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/Sources/CentOS/Demos/Hello/project3.lpr b/Sources/CentOS/Demos/Hello/project3.lpr new file mode 100644 index 0000000..c58807c --- /dev/null +++ b/Sources/CentOS/Demos/Hello/project3.lpr @@ -0,0 +1,20 @@ +program project3; + +{$mode objfpc}{$H+} + +uses + {$IFDEF UNIX}{$IFDEF UseCThreads} + cthreads, + {$ENDIF}{$ENDIF} + Interfaces, // this includes the LCL widgetset + Forms, Unit3, LResources; + +{$IFDEF WINDOWS}{$R project3.rc}{$ENDIF} + +begin + {$I project3.lrs} + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. + diff --git a/Sources/CentOS/Demos/Hello/project3.lrs b/Sources/CentOS/Demos/Hello/project3.lrs new file mode 100644 index 0000000..2747aa9 --- /dev/null +++ b/Sources/CentOS/Demos/Hello/project3.lrs @@ -0,0 +1,5237 @@ +LazarusResources.Add('MAINICON','ICO',[ + #0#0#1#0#6#0#0#0#0#0#1#0' '#0#226#145#0#0'f'#0#0#0#128#128#0#0#1#0' '#0'('#8#1 + +#0'H'#146#0#0'@@'#0#0#1#0' '#0'(B'#0#0'p'#154#1#0'00'#0#0#1#0' '#0#168'%'#0#0 + +#152#220#1#0' '#0#0#1#0' '#0#168#16#0#0'@'#2#2#0#16#16#0#0#1#0' '#0'h'#4#0#0 + +#232#18#2#0#137'PNG'#13#10#26#10#0#0#0#13'IHDR'#0#0#1#0#0#0#1#0#8#6#0#0#0'\r' + +#168'f'#0#0#145#169'IDATx'#218#236']'#5#128#28#245#213#127#235'n'#231'w9I.N' + +#136#144#4#139#17#220'['#220#221#138';!'#184'|'#180#148#2#197'Kq'#13'R('#20 + +'(V'#180#197#3#9'!'#144#144#16#187#156#219#202#173#251'~'#239#253'gfo'#246'r' + +'~'#187';{'#242#131#201#236#173#204#204#202#251#253#159'?'#25#140'a'#12'c'#24 + +#181#144'I}'#1'c'#24#195#24#164#195#24#1#140'a'#12#163#24'c'#4'0'#134'1'#140 + +'b'#140#17#192#24#198'0'#138'1F'#0'c'#24#195'('#198#24#1#140'"'#140#155'}2}' + +#223#6#220'L'#184#25'q'#11#227#230#161#173#225#167#21#17#169#175'o'#12#217 + +#199#24#1#12'c'#160'@'#155'q7'#21#183'i'#184'M'#198#173#8'8'#225'N'#217'd2' + +#153'p'#155#132#191#167#239'<'#132#155''''#145'H0B'#224'7'#175#232'v'#7'n' + +#219'p'#219#128#219'F'#220'j'#145'4'#18'R'#127#6'c'#24#26#198#8' '#199#129'B' + +'.'#199#221'x'#224#132'|'#170#176#161'P'#211#223'%='#189'N'#214#195'7+'#235 + +#230'+O@'#207'r'#156#232#249#161#0#146#197'&'#232'$'#132#228#134#196#224#145 + +#250's'#27'C'#255'0F'#0'9'#6#20'x'#18#234#189'q'#219#7#183'=P'#208'ie'#215 + +#136#159'#'#22'nA'#160'e'#194#157#226#199'DO'#20'nwG'#12'b!O'#240#127'$R'#238 + +#236#230'q'#209#157']I'#2#159#211#136#187#181#184'}'#198'o'#171#145#20'bR' + +#127#182'c'#216#17'c'#4' 1P'#224#11'p'#183#20'8'#161#223#27#5'u'#186#240'X' + +#167'L'#239'('#228't'#155#219#0#228#244#12#185#140'{'#158#140'{'#157#140#191 + +'!'#235#250'|'#232'<'#166' '#196#130#252#146'ps'#27'pRM'#255#203#184#191#197 + +#143#209#235#196#247'AbGb'#232'B'#10#29#248#248#255#160#147#16'~'#26'3'#31'r' + +#3'c'#4#144'e'#160#192'[p'#183#23#240#171'<'#10#229'L'#224#191#7#177#192#203 + +'8)'#6#185'\'#158#20'h'#185#156#187'_.'#227#4#158#30#163#219#10'z'#142#188 + +#203#227#252#30'D'#247#201#21#10#220'+AF{P@\'#22#135'D,'#134#194#26#131'8' + +#238#227#241#24'/'#216'qn'#31'O'#0#222#194#251#241#223'8@'#28#255#137#199#185 + +#191#227#137#4#187#157#224#239'#'#2#136''''#186''''#134'nH'#193#129#247#127 + +#14''#193#238#139#11'['#146'(R'#9#161#139#217'A&' + +#195#10#220#158'G2'#248'E'#234#239'k4a'#140#0'2'#4#20'z%'#238#246#7'N'#232 + +#127#143'{'#29#221'/'#172#230#226#21'^,'#240'$'#172'$'#224'J'#165#2#148#180 + +'W)A'#163#214'3'#1#215#144#176'ku'#160#209#242'B'#175'V'#129#10#159#175'T' + +#202#217's'#233'u'#10#185'p'#172'.'#26#129#130'3'#21#184#251#216#149'p'#23 + +#202'Vn'#224'Vo'#129#4#226#156#128#198'x'#1#142#197'8'#161#142'E'#19#16'E!' + +#143'D'#227#16'Eb'#8'!'#9#132#131'~n'#11's'#251#16'#'#135'0>/'#134#207#225'6' + +#129#16#24'A'#136#8#129#206#215'U;'#192#251#215#224#238#5#220'^B2h'#150#250 + +'{'#28#233#24'#'#128'4'#3#5#127'.'#238'N'#197#237'D'#20#190'b'#186'O,'#244 + +#130#170#174#144#209'*.c'#2#175#228#133'^'#173'T'#162'P'#171'Ao'#178#130'^o' + +#3#157#209#10'Z'#29#10#187'J'#129#171'=nL'#208#233#182#156#221'V)'#21#201'=#' + +#11'%G'#0'D$r9g'#247#211#185#146'&'#3#179#8'd)'#206'AnE'#134#20'5'#30'e'#149 + +#187#29#231'6"'#128'h'#156#132'9'#158'$'#128'H'#132#246'1'#238#182'h'#31#198 + +'}8'#24#130#128#175#3#252'^'''#248'}N'#8#5'}'#236'1'#129#16#162#177#174#132 + +#16'g'#218#1#153#24#220'5'#177']'#12#175#225'c'#224#200#224'M$'#3#191#212#223 + +#237'H'#196#24#1#164#1'('#244#21#184';'#25#183'SQ'#184'v'#162#251#186#21'z~' + +#133#231'Vv'#18'^'#20'x'#149#10#244'('#232'z'#163#13#12#6#220#27#204#184#226 + +#227#170#175'Q'#130'V'#173'`'#194'O'#127#171'U'#188#192#171':'#133'^'#197#142 + +#195#173#254't'#31'g&p'#171#127#210#148#160#235#224#29#132#130#250#159#18#9 + +#224#205#0#178#245#133#21#153#217#251#252#223'$'#155'$'#160#209'8'#183#250'w' + +#146#0#10'2'#145#0#222#14'G8'#2#160'=m'#161'H'#20#205#132#24#4#195#220#237'@' + +' '#0'~'#143#139#145#1#145'B'#136#204#8#188#159'#'#131#24'gJ'#224'qbq'#193 + +#223#176#131#153#224'E2'#248'''pd@>'#131#184#212#223#249'H'#193#24#1#12#1'(' + +#248#243'pw='#10#219#17#192'-'#174#12'rN'#210'8'#149'\&O'#170#244'*'#21#9#178 + +#146#9#188#193'd'#195'}'#30'nf'#208'jT'#160#19#132#30'7'#29#19'~%G'#4'<'#9 + +#168#149#220#202'O'#171'<'#169#253#10#165#12#148'ra'#213#167's'#164#10'>]'#2 + +'wA'#188#192#11#209#129'D*'#1'$U'#239#164'g'#159#255#139#183#215#227#188'3P' + +#16#206'(o'#14#16#9#196#4'2Hj'#5#164#1#160#208#147#224#135#163'l'#31#8'E!(' + +#222'P'#240#253'>'#31#4#188'.'#240'!'#25#248'<'#14'4'#27#130#248#218'(#'#5'F' + +#4#140#12'x"'#232#226'3'#192#191')'#25#233'/'#184'='#131'D'#16#146#250'70' + +#220'1F'#0#131#0#10#254'"'#220#221#128#194'v'#16#253#157'\'#237'y'#207''#198#147'BLl'#30#136#136#0#133'>'#16'N%'#1#250 + +';'#16#196'-'#20#129'` '#2#30#183#3'<'#174'f'#240'x'#218'Q;'#8'32 '#13'C'#236 + +'d'#20'L'#4#17#17#144#227#240'^'#220#30'C"'#240'I'#253#155#24#174#24'#'#128#1 + +#0#5#159#156'z7'#162'0-'#161#191#185#24'<-'#181#220'j'#159'j'#203#163'0'#235 + +'t`'#182#20#131#201'V'#2'F'#147#25#244'Z'#21#24'p'#163#189'^G'#130#174'b'#194 + +#175#21'V|'#141#130#9'='#17#6#19#252#164#131#143#183#229#153#195#16'D6=''' + +#224#178#174#241#254'.'#215'-'#147#13#236'k'#22''''#1#137's'#4#128#251#159'#' + +#2#193'THtF'#16#146#132'@'#26'B$'#158'4'#11'B'#145'N'#141' '#200#147'A '#24#1 + +'?'#146#128#31'I'#192#239#167#219#184#5#130#224'v'#181#129#219#217#194'i'#6 + +','#242#16'c'#14#199#164#137#16#139#167'h'#5'x'#187#29'/'#233'~'#220#30'F"' + +#232#144#250'72'#220'0F'#0'}'#128'/'#160#249#29'p+'#254#174't'#31#23'^'#239 + +#12#209'1!Ur'#234#189'V'#171#1#147#165#136#173#244'&K'#30'/'#236'j0'#232'T' + +#201'M'#199#147#128'V'#195#169#248#156#208'+83A'#201#31'O.'#178#231'{'#17'v' + +#254'&'#183#239'A'#208#7'"'#255'='#165#254'v%'#133'D'#167#154#176#3')p^'#255 + +#4#243#27#196'D'#142'C'#210#10#194#188'_'#128#153#7'A'#142#8'|'#129'0n'#17 + +#182#249'i'#143'Z'#128#23#205#4#15#18#1#145#129#223#239#193#215'E'#153'f'#192 + +#162#11#188#19#177#139#175#128#146#141#30#193#253'}H'#4#237'R'#255'n'#134#11 + +#198#8#160#7#240'9'#248#199#1'g'#227'S'#178#206#14#130#175#18#236'z\'#189#13 + +'&+X'#243#199#161#224#23#162#144#235'P'#232'U`'#228#5#158#8#192#168#231#132 + +'^'''#8'>'#9#189'Z'#145't'#230'q'#26#132'8'#254'/J'#254#17'.'#170#15'u>['#232 + +#202#17']'#201#128#249#14#4#13'A'#228'?`'#209#4'2'#17'b'#228','#140'32 '#159 + +#0#167#13#136#8#0'5'#2'/'#146#130#159#255#219#227'qA'#135#179#25':'#28#141'h' + +'R'#132'92Hj'#5';'#16#129#31#207#255#24#238#239'A"h'#148#224#227#25'V'#24'#' + +#128'n'#128#194#191#27#238#30'EA'#163#144'^'#138#224'+yU_'#141'6'#188#6'7' + +#163'9'#15'l'#133#149'`'#177#230#163#176#227'J'#143#130'n'#212#171#217'mN' + +#232#213'('#244'h'#235'k95_'#205'<'#250#188#7'_'#217#25#183#239'N'#173'g'#231 + +#22'.j8|S]'#202#7'RR'#135'E'#230'B,'#193#231#20#240#161'Cf"'#136'|'#3'$'#244 + +'^A+'#240#163'6 '#236'}~p'#180#213'!'#17'4'#224#243#130#140#8':#'#9#169'D' + +#128#231#14#224'%'#220#137#219'_'#198#156#133'=c8'#252#172#178#6#20#252'<' + +#220#221#137#194'w.'#240'2'#152'"'#248#188#154#175'A'#219#221'd)`'#130'oE5' + +#223'hP3'#161'7'#25'4L'#232#13#188#202#159#180#241#153#224#139#156'y'#188'z/' + +#8#190'8'#127'?'#165#208'g'#128#182'{'#174#161''''#167'b2'#225#136'O2'#226 + +#180#2'!'#140'H>'#130'X'#167#143#0#137#192'C'#194#207#8' '#12'n'#220'{'#188 + +'~p'#182#215#131#203'^'#15'A'#127#144#249#10'z!'#2#170'X'#188#24'I'#224'?R' + +#127#30#185#136#225#253#11'K'#19'x;'#255','#220#238'B'#161#203#23#156'{2'#133 + +#160#234's+'#183#22'W|'#147#181#8#242#138'+'#193'l'#182#129#137#9'='''#248'&' + +'#'#238'Q'#240'uL'#229'W'#177#24#190#134'9'#243'RU|qr'#14#8#222'z'#254':d#' + +#248#235#216#161'z0'#25'f'#228'3'#17#197'&'#2'i'#5'Q^+ '#18#8'F'#152#22#224 + +#245#133#192'C$'#224'#R'#8#129#215#27#0#167#189#1#156#168#21'P'#174'A('#140 + +'D@9'#9'T'#215#192';'#11#227#157#213#141#175#225#238#10'$'#130#6#169'?'#139 + +'\'#194#200#253#197#245#19'('#252#187#224#238'o('#152'{'#136#195'y,'#227#142 + +'6'#18'|T'#227'-'#214#18#176#21'U'#160#224'['#153#208#155'I'#232'y'#225'g'#26 + +#128#150#19'|q'#248'N'#156#158'+'#8'>'#147#249#212'z'#222#209#9'Q'#232'1'#233 + +'7'#224#137#128#204#132#8#159'tDQ'#0#166#17#132#200'9'#136#155#143#211#8#220 + +'H'#6'D'#4#28')'#4#145#8#26#145#8'j'#193#239#247'!qt'#18#1#167'm'#196#5'm' + +#128#26#156#220#138#219#3'H'#4'Q'#169'?'#130'\'#192'h'#253#249#9'Uyw'#160'0^' + +#128'{'#133#160#238#179'"'#27#222#185'G'#9':'#228#205'/('#169'F'#193'71a'#239 + +'I'#240#5#199#30'K'#203'U'#202'S'#236'zN'#232#187#177#235#199#176'C'#30'BB' + +#172#25#176#236'CN+'#8'G'#163#157'D'#192#251#4'8m'#128'#'#2#143'@'#4'm'#13 + +#224'h'#169'A'#205'!'#192#136' '#194#155#6']'#204#2'*8'#186#16'I'#224#11#169 + +#223#191#212#24#149#191'E'#20#254'Spw'#15#229#234'''Km'#21'|J-+'#190'A;'#222 + +'hB'#193#159#4#182#252'"&'#244'f#'''#252'f^'#240#13#188'W_'#219'e'#197'O&' + +#231#240'R'#223#25#162#147#250']'#231'>D'#193#4'n/'#242#21'$S'#144'{'#210#8 + +#188'!'#232' '#18#160'}'#135#23#218#155#183#130#203#217#4#193'`'#152#249#21 + +#136#8#226#172#246' %'#153#232'y'#220']'#141'D'#208'&'#245'{'#151#10#163#234 + +'g'#137#130'O'#141'0'#31'G'#193'?'#145#254#22'Vh'#5#191#234#171'U*'#180#225 + +'5'#204#185'WP2'#30','#6#29'XL'#26#176#24'9'#2#160'U'#159#9#190'F'#136#225'+' + +'9'#167#30#139#219#11'y'#255'\'#213']'#231'''<'#170'>'#226#244'A'#228'@L@gM' + +#2#249#9'"'#2#17#136#162#6#130'Y'#208#225#9'22'#160#205#225'h'#135#246#166'M' + +'H'#10#29#156'6'#192#242#8#226#156#127#160'S'#27#160'P'#225#137'H'#2#255#147 + +#250'-K'#129'Q'#243#235'D'#225#159#141#187#127#160#144'N'#17'V}'#5#159'i'#199 + ,#169#251'h'#215'['#11#160#176't2'#218#251'f&'#244'V'#163#22#204'D'#0#6'-S' + +#251'){'#143#4#159#203#244#227#146'u'#196'e'#183'];'#248#140'a'#232#16#151#11 + +#11#230'A,'#193#167#30'G'#184#228'"'#230','#196#205#195#155#5#29#222' '#18'A' + +#136#237#221'H'#8#237#173#181#224'l'#217#14#254'`'#16'B'#225'0'#159'f'#28'Oj' + +#24#192'U'#30#222#130#251';G['#161#209#168#248#165#162#240#159#135#187#7'PH' + +#181'2'#190#6'_H'#217#165#144#158#222'`'#196#21#127'"'#228#229#151#178#149 + +#158'V}+['#249'9'#193'7'#232#213'l'#213#167#172'='#242#234's'#9';\'#201#173 + +'Pp'#195'>'#204'Q'#241'iJ'#131#206'DDn'#229'N'#166#31#147'F'#16#229#170#16')' + +#143#128#210#138#189#188'I'#224#18#17'A'#135#219#11'mM'#155#161#195#209#130 + +'&'#4#146#0'%'#19#9#209#130'Nm'#224'#<'#193')H'#2#173'R'#191#223'laD'#255'd' + +#249'N<'#143#137'U~'#193#214#167'D'#30#29#174#250'yE'#168#238#23'O'#0#179'Y' + +#199#4'>'#185#242#27'9[_H'#217'e'#169#186#138#212#226#155#222#26'm'#142'!3' + +#224#139#21#147#14#195'd>A'#148'K7'#230'2'#11'9"'#224#28#132'H'#4'n$'#0#242 + +#13#144'Y`o'#133#246#230'M'#224#243'x:'#181#129'h\'#28')h'#194'3'#156#140'$' + +#240#153#212#239'5'#27#24#177'?]^'#229#127#141#186#234#138'='#252#172#180'VE' + +'N>#'#148#148#239#4'V[>'#191#226'k'#25#1#144#202'O'#241'}'#178#245'uj~'#213 + +#23'j'#237'E^}'#246#225#141#216'O/'#247#145'$'#2#232#236'AH)'#199'Q'#190#0 + +#137#10#142#168#208#200#231#227#136#128#132#223#229#9'2'#31'A'#135''''#0#173 + +#13#191#177#208'a'#144'O-'#142'&C'#134#236#200#184'K'#220#142#251#255#27#233 + +'&'#193#136#252#9#163#240#255#1'w'#247#139'U~'#174#147#14#197#244'U`'#177#21 + +'Cq'#249'4'#176#153#13'('#252'Z&'#252#164#242's'#153'|\'#234'.'#173#250'\5' + +#30#223'aG&'#235'6'#23#127#12#210'"'#145'd'#1#224#27#152#242'D'#16#137#179 + +#162'#"'#2#31#239'$'#228#132'?'#4'N'#158#8#236'm'#13#208#214#248#27'j'#11'A' + +#150'D$D'#10'D&'#193#167#192'i'#3'#'#182'5'#217#136#250'%'#243'*?y'#249'O' + +#160#191#197'*'#191'FM'#130#173#129#252#210'j(,'#169'bj'#190#213#162#5#155'I' + +#155#12#241#137#227#249'B'#18'Ogn>$k'#236#199#144'['#160#214#229#157#185#4 + +#188'Y'#192#218#152'qY'#133#212#153'('#192#215#23'0'#223#0#145#128';'#128#166 + +#1#238#157'Nh'#169'_'#15'^O'#7#231#27#216#209'$h'#1#206'/'#240#177#212#239'3' + +#19#24'1'#191'f'#20'~'#26#139#245#30#10#255#188#174'I=\\'#159'T'#254#25'`' + +#203#207'c+'#190#205#164#3#171'Y'#203#135#247#212#172'XGH'#221'e'#13'7'#146 + +#234#190'h'#229#151#250'M'#142#161'G'#136'|'#132#220','#131'8'#223#201'('#193 + +'7)'#9'sNB'#210#6#220#188'9@'#190#1#167#155#246#254#164'I'#16#224#27#146'DY' + +#155#244'$'#9'P'#214#224#217'H'#2#207'K'#253'>'#211#141#17#241#155'F'#225#159 + +#128#187#255#160#240'O'#18#132#159'b'#243#228#229'gi'#188#182'"T'#249#167#163 + +#192#163#202#143'B'#159#135#155#133'_'#249#141'|}'#190#154'o'#192'A'#141':' + +#229'2Q'#231#220#17#241#9#141'B'#240#13'L'#200#128#23'Z'#153#9#185#3'T['#224 + +#241#134#185'('#1'j'#1#14#212#6#220#168#21#180#183#212'C['#243'&'#214#152#132 + +#202#142#133#156#1#222'/'#128'<'#144'X'#134'$p'#143#212'o-'#157#24#246'?o' + +#222#217#247#1#10#127#137#216#222#167#226#29#157'V'#203#210'x'#11'H'#229''';' + +#223#204#169#252't'#155'e'#243#233':='#252#201#10'='#161':O'#234'76'#134#161 + +'#'#193#165#26#11'-'#200#163#188#147#144#186#19#177#188#1'_8'#169#13'8'#153 + +'F'#16'@'#147#160#3'Z'#234#214'1'#147#128#146#135'('#5'YD'#2't'#172#187'qw' + +#237'H'#153'l4'#172#127#231'('#252'4a'#231'-'#20'~'#139' '#252','#163#143'T~' + +#131#1#138'+f@^^A'#167#224#155#185'0'#31#9'?+'#213#229#227#250'B'#231#29#232 + +'R'#142';'#134#145#1'q'#163#211'd'#164' '#202#165#19#11#225'Br'#14':'#220#28 + +#9#208#214'Z'#191#1'\'#246'&'#212#24#194','#170#16''''#191#0'$M'#130#231#240 + +#128#231#140#132#130#162'a'#251'sG'#225'?'#10'w/'#161#240'k'#132#240#28#169 + +#252'j'#170#213'7'#153#160#164'r6'#216'lff'#235#219#204#218#164#189'/'#180 + +#228'R'#243#173#183#200#209''''#212#225#143#9#255#200#133#144'H'#148'lJ'#130 + +'&A'#24#237#252#16'_n'#204#162#4'nN'#27' '#147#128#162#4'-'#13#155#192#209'Z' + +#203#234#9'('#162' '#174'%@'#18#248'7'#30#238'8$'#129#128#212#239'm('#24#150 + +'?y>'#204'G%'#188'r'#193#211'/8'#251#168#15'_i'#213'L'#176'YM'#144'G'#206'>' + +#139'.'#25#226#211#179'&'#29#202'd'#223'='#161'D'#151#251' '#134#229'G1'#134 + +#1'B<'#216'Th^J+'#188'@'#2'd'#18#144'c'#208#217#17'`'#251#182#230#237#208#214 + +#180#9#130#129'03'#7#186'D'#8#190#194'C'#30#142'$'#224#148#250'}'#13#22#195 + +#238'W'#143#194#127'3'#10#238'mt['#16'~5_'#193'g'#177#22'@i'#229'L'#176'Z' + +#245'L'#240#137#0#200#233#199#132#159'o'#201'%'#30#160#193'>'#128#177'e'#127 + +#212'A<'#2']'#156'' + +#129#253#135#147'c0'#231#197#1#133#159#198'o'#189#141#178#175#18#219#252':' + +#173#26#10#203#166'@Aq%'#243#240''''#133#159'<'#253'$'#252#201#10'>'#174'tW6' + +#22#219#135#223#29'0'#11#2#254#29#167'hi'#181':'#184#231#161#151'`'#234#244 + +'YR_'#162'd'#224'9 '#233#23#136'D'#184#209'f'#228#28'd'#21#133#148''''#208#17 + +'d'#161'B'#167#203#141'$'#240#19'x<'#29#221#145#192';x'#168'#'#145#4'bR'#191 + +#167#254' '#167'e'#130#239#207#255')'#10#191'A,'#252#180#242#23#148'N'#130 + +#162#210#241'I'#225#23'r'#250#5#225#231'Fi'#203'E='#249'r'#250#173'f'#5'''' + +#31#181#16#218#219#186#175'kQ('#148'p'#239'#'#175#192#244#25#187'H}'#153#146 + +'AhP'#10#2#9'D'#185#225'%b'#18'pv'#8#155#27#154'j'#214#128#215#227'fm'#201 + +#187'8'#6#159'F'#2'8['#234#247#211#31#228#172'T'#160#240'O'#193#221'W('#184#5 + +'B'#146#143' '#252#249'EU'#156#205#207#132#159#203#235'gi'#189'z.'#179#143#28 + +#131#138#148#148'^'#24#157'F'#127#23','#191#252#20#248'i'#245#183'=>N$p'#215 + +#131'/'#194#140#153#243#165#190'T'#233#144#28'f'#2#201#129#167'D'#2#212#127 + +#144#230#18#8'$@'#230#128#195#233'B'#18#248#17'|>'#127'2:'#192'&'#21'q'#14 + +#198'?#'#9'\'''#245#219#233#11'9)'#21'('#252#165#184#251#26#133#127#188'8' + +#195#143'9'#252#10#199'AI'#197'N,'#185''''#143#247#246#179#236'>'#157#154#13 + +#215'd'#194'/j'#211#149#179'oR'#2#216#219'Z'#224#180#227#150#224#15#180#231 + +#18'w'#185'B'#1'w'#222#251'<'#204#156#179#155#212#151'+'#9#196#195'P'#133#206 + +'CD'#2'!VC'#16'e'#221#135#133'""'#202#21' '#199' i'#2#1#170#31#160#241#230 + +#204#28'H'#8'$@s'#8#238#151#250'='#245#134#156#147#13#190']'#247#255'Pxg%' + +#133#31#127#148#26#190#168#167#140#226#252#164#242'S'#156#223',R'#251#213'JP' + +#170#184'>}c!'#190#158'q'#255']'#215#194''''#31#190#217#235's'#228'r'#5#252 + +#249#129#21'h'#14#204#149#250'r%'#133#16'*'#20'r'#5'h'#132#25#149#21#139#205 + +#1#210#4#236#237#173#208#178#253'g'#8#132#130#140'('#132#218#129#4'7R'#249 + +#148#134#159'^zI'#234#247#210#19'rJJP'#248#201#21#253#17#141#223#22#170#250 + +#148'|'#134#159#217#146#7'%'#19'fC'#158#201#0'6'#171#150#197#250#217#202#143 + +#194#175#213'(S'#187#246#228#212#187#202'-'#196#227'Q8'#254#176'y'#16#194#31 + +'ko'#208'hu'#240#220'k_'#130'^o'#148#250#146'%'#133#216'1('#152#3#204''''#224 + +#237'L'#27'&'#231' '#151','#180#129#235'0'#20'I!'#129#8#30#225'0$'#129#156#28 + +'M'#150'S'#162#130#4#240#16#10#255#197#226#146'^'#141#138'r'#251'-P:a'#23'\' + +#249#141'l'#213'g'#194'o'#226'V~-'#133#250'D'#243#246'r'#234#13#229'('#222 + +#254#231#179#240#244#223#255#220#231#243#202'+'#171#225#225#167#222#147#250 + +'r%Grr'#17#175#9#4#187#144#128#144''''#208#218'T'#3#246#166#205#157'$'#208 + +#217'O'#192#145'H'#196'vi\'#251'J'#173#212#239#165'+rF^'#248#226#158#127#138 + +#19'}'#168'A'#7'5'#242'('#173#154#11'y63W'#213#199#215#242#147#195#143'*'#250 + +#132#129#28#178#177#149#127'@8'#251#132'%'#224't'#244'='#15'c'#191#131#143 + +#133#11#175#184']'#234#203#149#28'B1'#17'9'#249'"|'#187'1.O '#204'J'#137#137 + +#4':P'#19'hi'#220#4#246#214#237#16#162#198'"'#169'ME'#190#142#4#28'K['#127'{' + +'?"'#245'{'#17'#''D'#134'o'#232#241'#'#149#245#10#225'>'#18'~'#157'^'#15#165 + +#227'w'#1#155#205#154't'#248'Y'#153#218#175#225#235#248';'#213'~!'#183#127#12 + +#253#195'/?}'#7#183',;'#163'_'#207#189#234#134#251'`'#193#146#131#164#190'd' + +#201#145#28'Y'#22#227#204#1#210#4'|B'#155#177'dw'#161' 4'#213#173#131#14#190 + +#148'85<'#24#191#27'M'#129'k!e'#144#186#180#144'\jx'#187#255'K'#20#254']'#187 + +#134#251#138'+w'#134#130#130#210'd'#172#191#179'}'#151#138#235#207#207#183 + +#232#22#6'}'#140'a`8'#239#228#165#168#5#244#221#2#159#194#131#15'='#253#1#20 + +#22#149'I}'#201#146#131'K'#27#230'5'#1#190#185#8'M.'#166#218#1#18'~'#135'''' + +#192'Z'#140'5m'#253#17'' + +#202#242'3'#25#185#149#159#230#241'q'#133'=\'#168'Oj'#6#251#237#215#31#225 + +#230'kNM'#185#143'H'#224#222#199#222#134#210#210'*'#137#175#174'wl\'#183#26 + +'n'#185#246#180'~?'#127#238#174'{'#193#178'['#30#145#250#178's'#2#180'|s-' + +#200#169#187#16#154#3'An"'#17#235','#212#17#20#149#17#175'Ov'#27#22#249#3#190 + ,#12'y['#246'n'#223#242#177#228#29#133'$'#147#31#20'~'#146#14#178#251'm'#226 + +'4_='#218#253'e'#19#230#161#221'oa'#130#207'9'#253'h'#229'W'#179#22'^\I'#175 + +'<9r[j'#220'y'#243'y'#240#243#143#223#236'p'#127'qi'#5#220#247'xnz'#208#219 + +'['#155#224#213#23#30#128'5?|'#1'>'#175'{@'#175'='#243#130#27'`'#255'CN'#144 + +#250'-H'#14'![0'#193#135#7'I'#192'i"'#145#208'^'#140'5'#20'Am'#160#185#238'W' + +'p'#182#215'C8'#196'u'#26'&'#194#224#15'pg'#253'O+n'#0#137'M'#1'ID'#8#133'_' + +#5'\'#178#207#30#226'L?'#157'F'#3'E'#21';'#163#250'_'#146'l'#229'%T'#246'Q3' + +#15#214#194'K)'#227#166#239#230#130#244'#'#206'8z.D#;:v'#149'J'#21'<'#251#198 + +'j'#169'//'#137'p8'#12#239#188#254#4#252#247#227'7'#193#209#222'2'#232#227 + +#200#240#187':'#253#188#235'`'#191'1'#18'H'#166#13#11#227#203'Y'#162#144'P7' + +#144#236'%'#224'GS`5x'#221#174#29#252#1'h1'#30'R'#183'f'#197#135' !'#9'HE'#0 + +'w'#161#240'/'#163#219#10#161#139#175'F'#9#249#133#227#161#168'|2o'#247'wv' + +#239'e'#225#190'd'''#159#220'q'#248#213'l^'#15'7]'#221#179' <'#241#202#183 + +#160#213#234'%'#189#198'`'#208#15#127#185#245#15#176'y'#227#207#189#166#0#15 + +#20#147#167#205#134#229#183'?'#1'j'#181'V'#210#247'''5'#18#162'a'#165'\'#142 + +#0'?{'#128'H'#128#138#134'<\'#205'@'#179#216#31#208'i'#10#180'i'#212#138#217 + +'['#191#127#190#25'$"'#129#172'K'#18#10#255#28#220#253#128#4#160#16#199#251 + +#141'f'#206#238#183#176#6#158#188#221'o'#224'j'#250#233'q*'#238#145#201'd9' + +#21#239#127#255'_'#207#193'+'#207#253#181#199#199#175#189#237'q'#216'i'#214 + +#238#146']'#223#166#13'?'#193#221'('#252#161'Pf'#202#211#213#26'-\t'#245#221 + +'0g'#254#18#201#222#163#212'H$'''#18#9#21#132#220'\'#194'dk1'#26'C'#198'g'#10 + +#182'5n`'#13'F'#187#148#15#191#220#240#211#10#234'w'#193#15'8'#203'.'#178'*J' + +'('#252't'#190#175#197#170#191'`'#247#151#140'G'#187#223'jN'#246#239#167'Q]' + +#212#193'W'#173#22'M'#229#205#21#201#231#241#183'{'#151#193#247'_'#247#156 + +#225'y'#197#13#15#195#172#185#139'$'#185#182#230#198#237'p'#253#165'G'#166'u' + +#213#239#9#187'.'#216#31'.'#188#234'nI'#222'g'#174'@('#30'bN'#193#8#231#15 + +#160'Qd'#212'i'#216#201#166#19#147'?`='#184#218#27'v('#26#146#203#18#251#213 + +#173'y'#137#166#17'g'#157#4#178'M'#0#231#2'7'#187#143#169#254#148#234#171'U' + +#171'Q'#237#223#9#237#254'q,'#212'G'#4'@'#19'z'#141#186'N'#187'_'#220#202'+' + +#151'p'#203'U'#199'A}'#237#166#30#31'?'#245#188#27'a'#233#254'GKrm'#203'/:' + +#12'W'#157#236#181#168'3'#154#173'p'#205#205#143'Cy'#213'dI'#222'o.@p'#10'F' + +#226#220'(2'#214'iX(!&'#18#240#248#161'q'#235#15#224#247'y'#216'0R'#145')' + +#176#161#208#28#223'e'#205#23'/'#135'`'#164#18#0#10#127#1#238'6'#162#240#231 + +#145',+'#168#194#15#5#220'l-'#130#210#170#217#220#136'nQ'#129#15#169#254#201 + +#210#222#28#136#245'w'#135#171#207';'#0':\'#237'=>>{'#222#18#184#248#218#236 + +'W'#131#174#250#246#19#248#251'_'#175#201#250'y'#169#148#248#162'k'#254#138 + +'Z'#207#226#172#159';W@>'#129'x'#12#152#199#159':'#10#249#168#183#160#159's' + +#10#18#17#216#219'['#160#165'v-'#155':'#20#21'B'#131'@?'#239#196#245'{L'#14 + +#255#229#181#215'^'#139'C'#22'I '#155#4#240'4'#10#255#153'B'#194#15'e'#242'i' + +#181#26'('#171#222#21'l'#22'+X-'#26#150#227'o'#210#11#241'~E'#206'W'#247']y' + +#206#190#224#245#184'z|'#220'`'#180#192'}O}'#154#245#235'z'#230'o'#183#192'7' + +#255#253#183'$'#159#9'iw'''#156#185#12#246'>0'#247#19#161'2'#1'nE'#231'z'#11 + +'R'#166' '#181#26'gIB'#194'@R'#26'8R'#251#11#184#28'M]K'#135'}'#10'Yd'#230'Y' + +'G'#236#180#253#214'[o'#205#154')'#144#21#209'B'#225'_'#136#187'/'#196'M=)' + +#225''''#191'x'#2#20#150'M'#228#236'~'#190#159#31#27#209#205''''#251#200#20 + +'|'#154'o'#142#142#228#190#242#156#165'L'#157#235#13#203'n'#127#22#170'''' + +#207#204#234'u'#253#241#186#147#160#174'f'#163#148#31#13#236'{'#200#201'p' + +#236#169'WJz'#13'R!'#217'e'#152'2'#5'Q'#19#160#162'!'#174#155#16'_='#232'rC' + +#211#214#239'!'#16#12'tI'#16#138#191'5'#217#214'x'#204#231#159#127'.h'#1#25 + +''''#129#140'K'#22#10#191#18'w'#171'Q'#246'g'#138#29#127#6#163#9'W'#255#221 + +'P'#232'u'#220#234'o'#20'B~'#156#221#175#148'Q?'#191#172'\'#226#160'q'#229'Y' + +'KX'#152#173'7L'#156':'#27#174#186#229')v'#155#190#232#141#235#190#135'_~' + +#252#2'j6'#255#2#173'-u'#16#14#5#161#176#184#28'f'#238#178#24#150#236#127',' + +#216#242#139#135'|]w\{<4'#214'm'#145#250#227#129'='#150#28#6#167#157#127#171 + +#212#151'!'#13'(*'#144#224#187#9#133'R'#203#135'iko'#222#14#237'M'#155' '#28 + +#230'M'#1#222'!'#168#144#197#143#216'}r'#244#223#217'2'#5#178'A'#0#201'~'#254 + +#130#227#143'V'#255#226#138'Y'#144'_X'#194#170#251#204#204#235#175'f3'#251'4' + +#194#164'^'#5#191#242#231#174#252#195#21'g.'#198'/0'#216#231#243'*''L'#135 + +#246#214#6'^['#232#253';'#173#154'8'#3'.^'#246' '#232#141#230'A_'#215#223#239 + +#189#18'~^'#253#133#212#31#15#195#137'g]'#7#139#246'=J'#234#203#200':'#196 + +#249#1#194#172#1#242#7'P4'#192#229#14#129#27'I'#160'q'#219#15#204#132#236#146 + +#27#176#173#196#26#155'S]'#20#243'e'#131#4'2*^('#252#229#184#251#21#133#223 + +'(8'#254'h'#245'7'#219#138#161#164'r&'#179#249#201#243'o'#22#169#254#148#240 + +#195#138'j'#134#193#140#238'+'#206'\'#4#209'H8'#237#199#165#234#187#227#207 + ,#188#22#246'\'#250#251'A'#189#254#173#151#31#130#143#223'}A'#234#143#135#129 + +'4'#190#229#127'Z'#1#165#229#19#165#190#148#172'#9'#131#144'R'#133#249#209'c' + +'n'#26'I'#206#180#128#16'8'#236'm'#208'R'#187#134#213#10#136#27#138#202'e' + +#137'?'#21')6'#222#186'j'#213'*j-'#158'QS '#211#4#240','#238'N'#231#194'x\' + +#165#159'N'#167#129#210#9#187#162#218'o'#6'3o'#247#155'x'#213'_'#165'Rt'#198 + +#251's\'#248#9'W'#158#177'p'#135'A'#27#233#2'}'#6'W'#160#233'@'#26#193'@'#225 + +#180#183#192#173#151#255'N'#234#143''''#9#157#222#8'w<'#244'>(G'#227#240#145 + +#132#184#167' '#167#5#176#198#162#158#16#155'@'#220'Z'#255'+t8'#26#152'C0'#22 + +#139#9#164#17#210'(";W'#154'[k>'#255#252's'#129#4'2'#130#140#137#25'_'#236 + +#179#25#127#200#202'd'#147#15'\'#225#243'J&Aa'#201#4'&'#248#22'>'#219#143#188 + +#254'B'#194#143#208#214'K6'#28'4'#128'3'#22#160#234#150#185#249#15#148'F'#252 + +#199'G>'#4#165'j'#224#130#243#199'k'#143#131#214#166#237'R~<)'#168#24'?'#13 + +#174#190#253'9'#169'/#'#171'H'#206#31#20'G'#5#130'\'#150' E'#5#152'&'#224#246 + +'A'#211#182#149#16#240#7#146#25#130'd6'#160#22#240#216#30#147'#'#151#226#203 + +'c'#153'4'#5'2I'#0#127#195#221#5#194#234'O'#171#187#222'`'#198#213#127'>'#174 + +#252#186#164#234'O1'#127#13#175#250#11#173#188's5'#236#215#21'W"'#1'd:'#211 + +'n'#206'n'#251#194#233#23#253'q'#192#175'['#245#205#135#240#226#223'o'#145 + +#234#163#233#22'{'#29'x'#2#28'q'#210#229'R_FV'#145'L'#21'&_'#0#223'T4'#16#226 + +#18#132'H'#3' "ho'#169#5'{'#211#198#174'a'#193#160'Y'#23#157#174#143'ln'#200 + +#164')'#144#17'Q'#227#251#250'oCa'#214#8#171#191#150#194'~'#227'v'#130#130 + +#194'q,'#233#135'R}'#169#198#159#10'}'#146#173#189#134'Y['#175#171#207'^'#136 + +'_lf'#9'@'#173#209#193#157#127#31'\.'#193'u'#231#239#3#225#12#213#1#12#22#231 + +'^y'#31'L'#155#185#135#212#151#145'u'#136'G'#145'S'#130#16#171#21#224'K'#135 + +'I'#19' -'#192#231#245'$'#147#131#226#156'/'#224#129#137#214#198#229#133#133 + +#133#145'Li'#1#153'"'#128'{pw'#149#216#246'7'#24'q'#245#175#222#21'W}m'#146#0 + +'('#215'_'#163'Q'#138'r'#253'3'#253'5'#164#23#203#206'Y'#196#190#172'L'#131 + +#132'f'#234#206#3'/*'#250#199'3'#127#130#149'_H'#147#16#212#19#242#10'J'#225 + +#250#191#252'S'#234#203#200':'#132#4'!'#161'V'#128#229#6#8#166'@W-'#128#250#8 + +#178'(B'#194'k'#209#248#166#203'|'#155'Z'#143'='#246#216'h&'#18#132#210'.r(' + +#252#249#184#219'.'#158#231'G*~~'#233'4(('#174'`'#182#191'9'#153#238#171'J' + +#233#231'?'#220#176#252#188#197#25#245#1#8#152#188#211#174'H'#2#15#12#248'u~' + +#159#27'n'#187#252#224#164'-'#154'+'#184#244#198#167#161'|'#252'4'#169'/#' + +#235'`i'#194#162#178'a'#214'U'#152#143#10'Px'#176'i'#203'w'#224#247#251#152 + +#22' D'#4#20#178#248'_'#198#233'jn'#213'h4'#145'L8'#4'3A'#0#255#135#187#27 + +#133#184'?'#173#254'z'#189#1#202'&'#238#193#4#159'<'#255#20#243#167#176#31 + +#149#249#178'b'#31#190#189#207'p'#226#128#166#186#205'p'#255'm'#167'g'#229'\' + +'&K>'#220'xo'#255'z'#247'u'#197#227#247'\'#10'[6'#172#202#230'G'#211'''*'#171 + +'w'#134#139#174#127'L'#234#203'H'#162'v'#235'z'#248#224#141#191#179'U'#248 + +#202#219'^'#4'm'#6#134#161#236'P6LZ'#0's'#8#134'Xkq'#242#7#216'['#182#131#189 + +'y'#19#203#11#16'E'#4':'#10#13#222#25#165#150'p'#187#209'h'#140#166#219#20'H' + +#171#200#161#240'S'#246#10#173#254#214'd'#193#15#10'y^'#233#20#200'/'#170'd' + +#4'`'#225'+'#253#132#213'_.'#204#241'K'#251'G'#158'Y<'#245#192#149#176'i'#221 + +#202#172#156#139#138'l'#254#244#232#127#7#245'Z'#183#171#13#238#188#246#168 + +#156#210#2'hq'#184#225#158'w'#192'h'#178'Jz'#29'?'#175#250#12#222'z'#233#175 + +#224#245'8'#147#247'Yl'#133'p'#237#157#175#225'oR'#153#246#243#9'#'#200#147 + +#29#132#216#188#193#8'x'#242#5'P'#181#224'w'#16#164#136'@'#172'S'#11 + +'P'#202#227#255'7'#181#208'~'#151#221'n'#15#167#219'!'#152'n'#2#184#30'w'#127 + +#20#175#254#172#183#127#245#238#184#234#235'p'#245'Ws'#157'}'#249'b'#159'd' + +#216'o8-'#253#192#133'tn'#190'x'#31#136'g('#7#160';\'#247#151#183#152'&0'#24 + +';d'#213'_'#204#156#191#15#156'x'#174#180#3'G'#222'|'#225'.'#248 + +#254#203'wv'#184#191'x\5\v'#243#243#25'9'#167'0'#130'<'#22#19#194#130#145'd' + +#243#16#210#4#218#155#183#130#179'uk'#215'r'#225#246#170'<'#255',u'#194#233 + +'L'#183'C0m'#146#135#194'O'#189#175'jP'#152#11#133#156#127'J'#249#205'+'#158 + +#4#249#197#227'q'#245'Ws'#131'6'#127#209#225'p'#196')'#203'2r^'#241#152'1'#234'#'#232#167 + +#228' >*@Z@'#211#150'o!'#24#10'B4'#210'Y#'#160'R'#196'o'#24#167#171'}'#200 + +#229'r'#133#210#233#16'L'''#1'\'#134#187#251#133#22#223'JV'#238#171#195#213 + +#127#15'0'#25#185')'#190#228#249#215#137'W'#255'af'#247#11#248#203'uG'#130 + +#167#195#158#213's'#206#156#191'/'#28'w'#214#224#227#250#143#254#249'\h'#172 + +#149#182'B'#176'+'#14':'#234'"X'#184#223#241#146#157#127#235#198#213#168#29 + +'u'#159#151' '#147#201#225#218#187#254#5#6'cf'#204#148#148#185#2'4v<'#16#6 + +#143#151'#'#129#246#166#205#224'j'#171'I'#169#17#192#127#154'&'#216#218#230 + ,'DC'#30'O:'#29#130#233'$'#128#159#196'#'#189')'#231#223'VT'#13#249'%'#213',' + +#219#143'y'#254'u'#157#147'|'#5#219#127#184#161#177#246'7x'#236#174's'#179'~' + +#222#130#226'J'#184#228#230#193#231#247'?'#250#167#179#160#185'A'#250#10'A1' + +#170#167#205#131#211'/'#249#235#208#15'4H'#4#253'^'#184#243#154'C{|'#188'j' + +#210'l8'#235#138#7'3rn'#161'N'#128#204#0'J'#14#242#5#195#172'd'#152#204#0#183 + +#199#11#205#219'V'#162#22#16'Ji'#29#166'SFO'#221'i\'#224'-$'#128#208#140#25 + +'3'#210#162#5#164'E'#2#199#205':q'#14#200#228'?'#166#14#248'PC'#217#196'=' + +#193'h'#212'%'#195'~]m'#127'v'#1#195'L'#5'x'#246#129#203#160'f'#211#154#172 + +#159'W'#161'T'#193'M'#247#127'<'#232#215'?p'#203#9#224#180'7e'#253#186'{'#131 + +#209#156#15'W'#255#233#13'I'#175#225#214'K'#150'v'#186#232#187#193'y'#203#158 + +#128#178#202')i='#167'`'#138'u'#230#5#196'Y#Qj'#28'Bu'#2#20#26'lk'#218#8#238 + +#246':'#22'-'#16#210#131#21#242#196#191''''#231#181#156#145#151#151#231'okkK' + +#139#22#144#30#2#152'}'#242#189#184#187'R'#156#248'c'#206'+'#133#162#242#25 + +'l'#245#167#141'l'#255#174#5'?'#195'L'#246#25#238#184'|'#191#140#21#0#245#133 + +#195'O'#186#6#230#238'y'#232#160'^{'#207#245'G0_@.'#129'4'#197#155#30#200'~' + +#199'$1'#250#250'>+&'#236#12'g]'#249#240#0#142#216'?'#8#26'@gD'#160#179#135 + +' +'#22'r9'#160#173'v'#245#14'EB'#165'F'#215#156'Bs'#188#209'h4'#6#211#161#5 + +#12'Y'#4#11'&'#238#167#212#24#139#235'P'#160'K'#196#206#191#194#242'Y`'#205 + +'+J'#18#0'7'#211'O'#148#243#159#246#143'4'#243#168#223#182#14#158#185#255'b' + +#201#206'o+('#131#139'oZ1'#168#215#222'u'#237#161#16#238#163'y'#137#20#184 + +#225#222#143'@'#174#148#206#17'x'#247#242#195'!'#24#240#246#248'8'#249#2#150 + +#223#243'>.j'#233#175'd'#20#198#139#209#198':'#9#135'"\'#15'A$'#0'2'#7#154'k' + +#190'g'#201'\bg'#160'F'#17#185'~'#130#205#254'x'#186#180#128'!'#203#225#184 + +#217''''#29#130#135'yW'#172#254#235'tz('#157#184#7#152#244#26#214#229#135'e' + +#253#241#171'?'#169#255#220#7#155#246#207'3'#227'xg'#197#159'a'#237#247#255 + +#25#250#129#134#128'E'#7#158#10'{'#29'|'#230#128'_'#247#231#171#15'D{2'#167 + +'F'#211'3\q'#199#27#160#207#144#163#173'?x'#232#182#19#192#237#236'}B'#242 + +#194#253'N'#130#165#135#157#147#145#243''''#135#138#196'83'#128#178#3'='#188 + +')`o'#169#1'g'#203#230'd'#219'0'#190'Jp'#213#228#188#230#223#163#6#224'N'#135 + +'/`'#168'b(C'#245#255'%'#220#159' '#174#250#179#20'TAA'#233'd'#182#242#147 + +#240#179#156#127'a'#180#215'0'#140#251#11'x'#152'~,'#174#190#199'ig'#18#244 + +#217#157'q'#249'#PZ9'#176'T'#218';'#175#220'/+3'#2#6#138#11#174#127#1'l'#133 + +#227'$;'#255'S'#247#156#7'-'#13#155'{}'#142#193'd'#131#203'n'#207'L'#253#2 + +#203#11#192#175'%'#154#156'''@y'#1'\'#207#0#143#199#3#205#219#190#235'j'#6'$' + +#242#180#158#189#139#140#190'_'#210#161#5#12'I'#18'Kw>'#214'"W'#168#155#240 + +'G'#169#19'w'#252')'#170#154#7#22#139#141#9#191#208#231'O'#205#175#254#178'a' + +#24#247#23'p'#215'5'#251'g'#188#250#175'?'#208'h'#13'p'#217'mo'#12'Hu'#206 + +#149'k'#239#138#11'oz'#5#204#214'B'#201#206#255#226#195#151#161'i'#247'K'#159 + +#207';'#227#138'G'#161#164'<'#189#206'@'#1#226'J'#193#0#211#2#194'L'#11' 3' + +#160#165'n'#13#248#220#246#20'3@'#173#136'>2)'#223#241''''#157'N'#231#25#170 + +#22'0'#20'I'#148#141#155'u'#210'Y('#205'O'#138'c'#255':'#189#25'J&'#236#202 + +'B~F'#3#183#250'k'#133#138'?'#129#0'2'#242'1f'#30'w]'#189#159#212#151#144'DE' + +#245',8'#233#194#254#135#208#238'^v@V*'#23#7#2#250#221','#187#251#163#172#159 + +#215#209'V'#7#171#190#252#23'4'#213'n'#128#182#230'm'#253'j'#235'V5i'#23'8' + +#225#252#244'O?'#18'$'#150#141#26#143'u:'#3'}'#228#12'D"p'#182'7'#128#189#241 + +#215#20'3@&K'#212'M'#201'k'#222#27'??'#215'P'#181#128#161#17#192#236#147'?' + +#199#253#18'.'#166#207'M'#248#181#22'q'#153#127'$'#248#194'`O'#173#134'k'#244 + +#169#16#226#254#195'P'#3#8#6#189#240#208'MGH}'#25')'#216#231'w'#23#194#188 + +#197#253'k'#184'y'#239#181#7'f'#165'rq '#160'^'#7#151#221#241#206#208#15#212 + +#7#162#209'0'#252#188#242#3#216#176#230'S'#166#238'G'#250#209#200#181'+'#228 + +'r'#5'\q'#231#251#236'w'#158'v'#240#209#0#193#25#200'B'#130#188'/'#192#231#11 + +'@'#243#214'o'#184#190#129#157'f'#0'X'#181#129'S'#202#173#190'OQ'#3#240'644' + +#4#15'?'#252#240#216'`'#180#128'AKb'#217#204#227#170'er'#21#181#252#146#137 + +#213#255#226#234#221#209#246'7'#166#172#254#164#254#211#7''''#31#198#234#127 + +'['#211'Vx'#238#190'?H}'#25') '#15#245'YW?'#133'6ty'#159#207#253#235#242#131 + +'r'#142#0#242#138'*'#217#245'g'#18#159#189#243'wX'#245#5#229#26#12'='#13'z' + +#241'Ag'#194#238#251#156#148#145#235'$'#225#23#18#131#184'"!./'#128#234#4#218 + +#234#215#131#167#163#169'Kjp'#236#141')'#5#142#171'U*'#149#203#135',1'#216#26 + +#129#193'J'#163#172'|'#246#201'7'#226#153'n'#23'{'#255#141#230#2'('#172#152 + +#205#173#254'z'#21#232#209#12#160'6'#223'*'#149#144#246';<'#133#159#176'm' + +#195'w'#240#230#179'7I}'#25';'#128'<'#232#231#223#248#143'>'#159'w'#255#13 + +#135'd'#181'x'#169'?'#216#251#240#11'`'#151#133'Gf'#236#248#219'6'#174#132'7' + +#159#185'1m'#199#179#228#149#194#217#203'2'#211#215'P'#152'+'#200':'#8'G'#185 + +#225#162'>'#161'i'#136#179#21#218#235#215#166'$'#5#201' '#209'19'#191'u'#145 + ,'\'#150'h'#195#197#215'+'#170#20#28#144#157'7h'#2'@'#245#159#234'S'#23#139'+' + +#255#242'J'#167#131'-'#191#12#244'zU2'#244#199#138'~'#134'q'#222#191#128#159 + +#191#127#31'>~#'#251's'#254#250#131'I;/'#130#195'O'#238#157#156#30#188#241'P' + +#201#18#152#186#3#149'8_v'#251#191'I'#183#206#200#241#253'^'#23''#232#163'7|'#247#217#10#248#230#163#204 + +#148#136#166#3#135#156'p=L'#153#181'W'#143#143'?q'#231#137#224#243'8'#164#190 + +#204'$'#170'&'#207#131'#'#207#252'S'#198#142#255#244#221#167#129#219#217#146 + +#246#227#238#182#247#137#176'`'#255'3'#210'~\'#241' '#145#168#168'y('#133#4 + +'I'#19'ho\'#7#30'gsJm'#128'^'#21'y'#180#210'b'#191#31'I'#193#129'&'#128'o0' + +#206#192'A'#17'@'#197#156#147#247#195#235#252#143'X'#253#215#234#200#251'?' + +#159#9#190#1'5'#0#193#249#199#133#254#134'o'#234#175#128#207#223'y'#4#214'~' + +#155'y'#135#213'`'#161'Ti'#224#194'['#223#234#241#241#247'^'#186#3'6'#175#251 + +'R'#234#203#228#175'U'#13#231','#127'%c+'#233#251#175#222#9#155#214#14#174 + +#129'J'#223#215#174#129#243'o~3#'#206'@ae'#167'h@'#152#31'$B'#137'AD'#0'N{=8' + +#155'6'#166#180#11'S'#202'c'#223'O'#202'k;'#7#175#165'='#18#137#184'='#30'Oh' + +#160#13'C'#6'E'#0'h'#255#255#9#143#190'\'#28#254'3'#219'*'#209#4#152#204#236 + +#127#218'h'#188#183'Z'#24#243'5'#12#171#254#186#226#235#15#159#130#213'_'#190 + +'.'#245'e'#244#138#5#7#156#9's'#23'w?'#149'w'#203#250#175#224#253#151#239#144 + +#250#18#25#14';'#229'6'#24'?u'#183#140#28';'#232'w'#195#147#127'>'#161#215#2 + +#159#161'b'#202#172#189#225#128'c3'#215'+'#128#181#12#19#204#0#158#0'|^/'#180 + +#212'|'#151','#17#230#252#0#16#156'\'#208#182#31#138'Y'#227'`'#157#129#3#149 + +'L'#217#173#183#222'*{'#226#205'M_'#225#237'='#196#197'?y'#227'v'#6#171#173 + +#152#23'~n'#245#231#188#255#178'a'#217#240#179'+'#182#172#255#18'>x%s*k:'#160 + +#213#153#224#236#235'^'#237#254'A'#252#209#252#237#182#195'%o'#10'2e'#246#222 + +#176#255#209#215'd'#236#248#159#188'q/lX'#243'IF'#223#3'-|''_'#246'$s'#10#166 + +#27'I3 '#206#153#1','''#0#9#128#136#128#8' '#24#240#165#248#1#10#244#254'K' + +#11#13#158#143'Q'#11#176'SH'#16#181#128#240'@'#204#128#1#19#192#148#221'N2' + +#251'B'#178'v'#154#248#211'i'#255#171#160#164'zO'#208#235'u'#172#232#135#156 + +#127'Z>'#245'W>'#12#219'}w'#7'ZY'#158#185#235'D'#169'/'#163'O'#236'{'#212#213 + +'L'#200#186#195#11#247#158#14'^w'#187'd'#215'V4n2'#28'}^f'#29#169'O'#220'q' + +#20'D#'#161#140#191#23'K'#254'88'#233#210#199#211'~'#220#174#237#195')'#26'@' + +'$'#16' ?@'#211#6#240'8'#27#187#250#1'^'#172'0'#183#223#135'ZA'#171'N'#167's' + +#15#180'Jp'#160#162')/'#159'}'#226'!'#9#144#191'#'#216#244#20#255#215#27#172 + +'PX9'#151#9'?'#249#0#152#250#175'$'#239#191#208#244'cd'#144#192'cl'#5#205#173 + +'l'#186#174'(.'#159#6'G'#158'so'#183#143#173#252#228'9X'#253'E'#223'!'#195'L' + +' '#191'x'#2#28'{A'#250#203'j'#197#248'u'#213#7#240#223'w'#30#202#218'{Zt' + +#240#249#176#243#238#135#167#245#152'|'#247#31#212#0#184'nA'#194'hq6^'#220 + +#209#4#142#166'_'#187#250#1#214'M'#206'o?'#31#9#160#9#205#0'g('#20#242#15#196 + +#12#24#136'X2I.'#159's'#242#221'x'#222'+'#197#14'@s~%'#235#253'G'#194#175'G' + +#225#167'a'#31'D'#0'r'#133'l'#216#135#255#196'x'#225#222'S'#193#239'u'#14#253 + +'@'#25#132'Zk'#128'3'#175'}'#181#199#199#223'x'#252'rhk'#218'<'#128'#'#14#29 + +#214#130'r8'#254'"'#154#20#151#153#144#159#128#151#30'8'#27'<'#174#244'{'#254 + +'{'#2#245'5fV'#248 + +#219#26'7'#193#191#158#186'2+'#239'I'#140#25#187#30#6#11#14'Jo'#134'hgRPg' + +#159#0#193#20'h'#175#253#129#245#8#16'u'#12#134'|'#157#247#230'b'#147#255'}' + +#148#201#22'$'#128#14'2'#3'P'#3#136'B?'#162#1#3#17'O'#249#132'9G'#230#133#19 + +#250'f'#188#173'H'#150#255#170')'#254#191#16#237'~'#174#233#7#197#254'5|'#242 + +#15#215#245'w'#228'0'#128#179'm;'#188#241#152't'#13'A'#250#139#197#135']'#10 + +'S'#230#236#223#235#251'x'#243#241'K3n'#206#204'^x'#28#204#223#251#212#172 + +#188#231#183#159#190#10'I'#224#183#172#156'K'#12#149'Z'#11#167'-{-'#189#7'Mp' + +'9'#1#228#8#140'D'#184'h'#128#16#18't'#182'lBS'#160'N'#1'D'#2'd'#226 + +#216#27#215#165'8'#2'U'#242#216'&4'#3'.'#198#219#13']'#204#128'>'#163#1#253 + +'&'#0'R'#255#191#217#164#186')'#145#144#221'"'#216#255'4'#247#207#156'?'#30 + +#172'E'#19#152#240#147#243#143'&'#1#177#220#127#249#200#178#255#5'|'#251#225 + +'c'#240#235#170#247#164#190#140'^ '#195#21#233#31'h'#154#245#175#133#213#170 + +#207'_'#128'u+'#223#198#31'T'#223'%'#177'}'#158#25'5'#194#9#211#23#194'B'#212 + +'@2'#209'B'#171'''|'#242#250#157'P'#251#219#183'Y;_W'#152'l%p'#204#5#233#27 + +'u&D'#2#132#226' V'#27#16#138'23 '#16#8'B'#203#182#175#240#251#138''''#29#129 + +'2Y'#194'7'#173#160#245'd4'#11#234'('#26'`6'#155';'#182'l'#217#18'Z'#183'n' + +#29#153#1#189#170'y'#253'&'#128#165'K'#151'*6'#187#198#189#128#231';A'#236#0 + +#180#149'L'#7#147#181#132#9'?'#167#254'wv'#254'aC?F'#152#6#16#143'Ga'#5'j'#1 + +#180#207'E'#232#12'68'#238#146'g'#7#250#174#224#251'O'#158#133#223#214'|0@' + +#141'@'#198#178#250'4:3'#20#148'N'#130#5#7'_'#12'jm'#250#231#234#245'z'#229 + +#236#251'8N'#210'JG'#146#135#211#174#253'WZ'#143#201'R'#131'y?'#0#155#29#128 + +#4'@'#27#17'A'#235#182#239' '#28#246#167#248#1#198'['#237#231'j'#20#225#245 + +'J'#165#178#9'W'#127#167'N'#167#11#244#167'6'#160#191#210')'#159'7o'#158#162 + +'9:'#141'hv'#174#152#0#10'*'#230#130#201'le'#194#175#213't'#134#255#134's' + +#235#175#190#240#213'{'#15#194#230#28'u'#6#142#199#21'x'#175#223#15'>'#209 + +#134#242#29#234'6}'#7'M'#219#215#178'N4'#241'X'#132'U'#17#146#160#145#160'[' + +#242#203#153#176#23'W'#236#4#230'<'#233'Zy'#9#248#254#147#167'a'#253#247#131 + +#27#156#154'N,='#234'Z'#168#154#178'g'#218#142#215'u'#132#24'5'#10#9#242'Z@{' + +#253'Oh'#246#216'S'#8#160#216#232#249#147'M'#235#251#24#239'k'#196#191#237 + +#161'P'#200#215#159#1'"'#253#145'Pf'#255#31'|'#240#193#170#181#141'ymx'#219 + +'$'#142#0#20'MX'#8#6#157#134'['#253#133#226#31#249#200'I'#0#234#14'$'#12#175 + +'=tF'#214'<'#233#253#6'~'#224'G'#254#225'Q0Z'#138#165#190#146#172#225#229#191 + +#158#136'Z'#203#192#27'|'#164#27#21#147'wC'#18#184'.m'#199'K'#13#7'v'#18#0 + +#141#21'w4'#253#6'^WC'#151#6'!'#254#23#139#244#174#151#209#254#175#139'F'#163 + +'mj'#181#218#211#159#18#225'~'#17#0#217#255#171'6'#199'+Cq'#237#214#164#3#16 + +#237'='#181'F'#143#4#176#27#203#250'c'#171#191'Z'#193#186#2')'#21'#'''#249 + +#167''''#216'['#182#192#7'/,'#203'h'#206#249'@Q9e'#15'X'#252#251#204#228#168 + +#231'"6'#253#248#1#172#252'8'#253#217'x'#131#129'Vo'#129#163'/z&'#173#199#20 + +#210#130#201#214''''#2#16#162#1#29#246':'#232'h'#221#156#18#9'0'#168'C'#159 + +'UZ\'#15#163'|'#214#14'$'#28#216#31#17#149#163#253'/'#175'q'#151#238#23#137 + +#201#223'O'#137#0#24#242'!'#191'b'#22#155#3'@'#177#127'F'#0#138#206#8#192'H' + +#199#154#255#189#0#235'W'#190')'#245'e0'#144#231#253#152'K^'#204#170#243'Mj' + +#188#249#232#217#16#240#229'Fb'#150#12#127#240'''^'#153#222'b1a'#148'x'#140 + +#207#7' '#2#8#134'#'#224#235#176#131#189#241#231#148'H'#128'F'#25#253#181#218 + +'f'#191#3#229's;'#254#221#20#12#6#157'J'#165#178#207#226#160'~'#17#192#140#25 + +'3'#148'n'#213#172#11#226#9#249#253'b'#2'0'#217#202#193'V<'#25'U'#255'N'#2'H' + +#142#252#30#225#26#128#128#207'^'#191#29#154'j'#178'?*L'#12#242#190#239'}' + +#204'MPR5['#234#143'#kh'#220#182#26'>'#255'gnT7'#10'8'#225#242'W@'#158'&'#2 + +'f'#170'='#223'#@'#240#3#176'~'#129#148#16#228#247'B'#235#246#149')'#4#160 + +#148#199#237#147#242'Z'#175'E'#185#164#9#221#13#129'@'#192#238#247#251'}&' + +#147#169#215#226#160#190'D'#148#169#255'^'#175'W'#249'K'#147#237#190'xBv'#129 + +#152#0#172#197'S'#192#130'$'#160#161#8#128'J!'#234#254#3#204#30#29#13#4'@' + +#248#238#195'G`'#235'/'#210'8'#5#233#251'Xr'#228#245'P6a'#174#212#31'CV'#241 + +#239#167'/'#6#143'3'#183'f'#29#238'{'#252#237'l'#28'^'#186#144#236#15' '#26 + +'%N&@'#24'5'#129#230'-_B4'#18'I'#18#0'">5'#191#229'r'#20#203#173#248'w]8'#28 + +#166'Va'#30'Q'#143#128'n'#253#0#253'"'#128#182#182'6'#213'fW'#217';'#137#132 + +'l?q'#17'P'#222#184#153'`4'#23#178#213#159#171#254#235','#0#26'%'#178#159#196 + +'/'#223#252#3#183'W'#135'~'#160#1#128':'#213'.8'#236'*('#159#180#187#212'o?' + +#171'p'#182'l'#133#15'Wd'#174#164'x'#176#152#179#228't'#152'6'#255'wi;'#30'_' + +#23#196'|'#0#177'(?D'#20'M'#0'r'#6#182'm'#255#1#194'A/'#171#9#16#136#162#210 + +#226#252#139'A'#29#254#142#252#0#161'P'#168#197'`0t'#212#214#214#6'{'#203#7 + +#232#147#0'('#254#143'j'#132#250#199'Z'#243'z'#27#205#196#146'wv'#1'RB'#209#132'E'#160#165#236'?u'#151#177#223#195#184 + +#253#247'PA'#171#211#234'O'#30#3'G3'#253'@'#211'O'#4'*'#181#30'v^t'#18'L'#154 + +'s'#176#212'oU'#18#248#221'm'#240#238#147#231'K}'#25#221'b'#210#156#131'`' + +#151'}'#206'M'#235'1'#217'b'#194#143#14#139#242'&'#0#249#1'\'#246'm'#224'm' + ,#175'I!'#0#139'6'#240'q'#153#201'M'#163#250#182#225#223#141#184'''?'#128#191 + +#188#188'<g'#255 + +#167'$'#0#201'G'#141#237#223#27#130'~'#23#172#254#244'Ih'#216#250'=2'#248#208 + +#179#212#244'hj'#237#188#231#9'0~'#250'^C>'#214'p'#198#127#223#248'?h'#169 + +#253'I'#234#203#232#22'S'#230#30#206#204#128'tB'#136#4'P80'#18#163'\'#0#218 + +'"'#172'1'#136#171'ecJ2'#16#170#255'?V'#152#29#143#201#229#242'mx'#127'='#154 + +#233#237'}u'#9#234'MTY'#251#175#239#190#251'N'#245'['#171'q~0'#170#254'R'#198 + +#229#246'2'#2#208#26#242#160#160'|6'#18#0'7'#248'S'#171#230#186#255#202'y' + +#239#255#232#243#2't'#15#250#130'~'#254#250'%'#168#221#240'?'#22#178#234'o'#5 + +#30'y'#246#13#150'"('#169#154#3#147#231#28#2'f'#155#244'YwR#'#26#14#194#27 + +#143#158'"y['#179#158'0}'#215#163'`'#214#194#147#211'v'#248'1'#228#14#254#249#192#9'h'#3#167's'#208'gzA+'#255'A' + +#167#167#127#230'A'#178',8'#193'E'#148#136#0'hX('#245#5'h'#221#250#5#27#248 + +'*Z'#145#187#141'N'#20'*'#13#28'}'#233#203#25 + +';'#190#160#248'PYp'#8'5'#0#31#18#128'?D3'#2'VA$'#232'N!'#128#234'<'#251#11 + +#26'Et='#222#220#138#191#231#237'h'#2#244#26#10#236#145#0'('#4'XXX'#168'B3' + +#192#248'K'#147#237#159#241#132'l1{@ '#128'q'#179#193'h'#202#7#147#137''''#0 + +#26#3#206#183#1#207#4#9#188#243#216#185#224#239'E'#160#199#207#216#27'v?'#248 + +#18#230')^'#245#241#19#3'N'#191'U'#170#180#176#199'!'#151#193#184#201#163#171 + +#178'n8'#128'l'#223#215#239';6g3'#0#231#238's6'#211'&3'#5'!'#29#152'"'#1#212 + ,#25#200#235#11#177'\'#0'J'#4#10#251#157')'#4'0'#222#234#248#135'N'#21'YK&'#0 + +#229#2#224#234'O'#205'A\'#212'$t'#247#221'w'#143#12#136#0'('#7' '#20#10#25 + +#127'm-x'#27#9#128'IF'''#1#204#5#163#217#10'f'#163#22#180'H'#0#212#9'H'#166 + +#200'\'#15#128#143'W,'#7'{'#227#198#30#31'''/l'#193#184'i'#208'Z'#251#243#144 + +#206'SX1'#3#150#28'u#j'#19#218#204#188#145'1'#12#10#239'>q'#1'x]'#205'R_'#198 + +#14#160#26#141#195#255#144#217#182'd'#9'^d'#217#192#208'p'#20'<^'#158#0#234 + +#215'B8`O!'#128'J'#139#227#13#189'*L'#197#18#201'\'#0#212#226#157'H'#6#221 + +#230#2#244'J'#0'j'#181'Z'#19#139#197#140#155#28'E'#175#196#226#242#165#236#1 + +#222#203'o+'#157#131'&@>'#243#1'P$@'#145't'#2'f'#134#1'V~'#240' l'#203'R'#211 + +#13#5#146#201#220#253#206#131#234#153#251#15#253'`cH'#11#214'|'#254'LN'#166#1 + +#31'p'#234'=`+'#158#148#209's'#8#233#192'q'#158#0#220'D'#0#254'0'#18#192#26 + +'4'#1'\)'#4'0'#193#230'x]'#171#140#172#3'>'#27#144#186#4#247'6-'#168'O'#2#8 + +#135#195#166'm'#29#165'OF'#227'r'#166#227#8#4'`)'#153#9'f['#17#24'y'#2#160'f' + +' '#178#12'N'#2'j'#174'Y'#3#255'}'#237#214#140'~'#208']a+'#158#8'K'#143#187 + +'-'#235#189#238#199#176'#'#130#254#14'x'#251'og'#230#212't'#230#146#9#187#192 + +'^'#199#220#146#241#243#8'EAqf'#2'D'#192#235#14#129#151#8#160'n'#21'DB'#30 + +#238'9<'#1'L'#180#181#189#162'R'#196'6Q='#128#208#30#12'I'#192#209'S2PO'#210 + +#154#204#2'D'#152'6'#180#218#238#143#198#21#201'('#0#17#128#185#136#250#194 + +#151#128#201#164#3#131'^'#197#17'@'#134#235#0'^'#187#247'('#180#131#178#251#3 + +#144#203#149'0{'#233#25'0y'#222'aY='#239#24'v'#196#166#213#239#194#143#159'<' + +'!'#245'e0'#208#140#132'C'#207#251'{'#210#241#156#13#196#248'T`'#143''''#8'>' + +'$'#0'J'#5#142#133#131')'#190#145')'#249'-+'#208#26#175#1'>'#25#8#247#13'(' + +#252#164#1#248#186#235#11#208''''#1#168'T*'#243'f{'#254#31#195'1'#197#25#236 + +#5'<'#1#152#10#166#176'D '#179'Y'#139#4#160'a'#4#192'f'#1'f'#144#4#200#14#244 + +'8'#26#135'~'#160'A'#192'RP'#9'{'#31#127#27'h'#141'y'#146#156#127#12#28'>}' + +#233#6'h'#173#251'E'#210'k'#208#155#242#225#16#18#254',u`f&@'#28'X'#243#15'J' + +#0'r'#187#3#204#7#208'F'#169#192#209#136#152#0#18#211#11'[^'#196#191#235'I'#3 + +'P('#20#219'"'#145'H'#3#222#223'>h'#2'@5'#194'R'#227'*'#188'>'#20'S^'#200'^' + +#192#11#184')'#127'"'#152#11#171#192'l'#210#128#209#160#3#165#138'k'#6#154 + +#201'>'#0#171'>~'#156#173#2'R'#129'Z?'#239#188#240'$'#152#177'gzK>'#135#27 + +#220#246'zh'#216#252#29#11#183#6'|.'#8#5#220#172'V_'#165#214#129'Zg'#2#173 + +#222#12'Fk)TN['#12'zsAZ'#207'MCY'#222#127'J'#186#134#160#244#190#14'9'#231'a' + +#166#25'f'#11#156#15#144'/'#7#14'F'#160#163'#'#192#178#1#219#182#254#143'/' + +#20#226#228'Y.KDP'#3'x'#149'R'#128#129#171#5'`'#233#192#184#136#183#187'\.ow' + +#147#130'z%'#0#170#3#192#23'['#234#189#197#151#6'"'#202'd'#23'F"'#1#131#181 + +#10#172'%'#19#193'd'#208#130#201#172'I'#154#0#178#12#134#210'i '#194#7'OH?' + +#158#219'd+'#133#165''''#252#31#232'-'#133'R_J'#198'A'#130']'#187#225'Kh'#218 + +#242#3'ks'#22#244#216#7'4'#135#143#134#148#26#172#197'P1u'#1#236#180#240#184 + +#180#9#206#215'o'#221#13'u'#191'~'#153#213#207#194'Z4'#30#14'<'#235'>'#188 + +#149#253'|'#17#166#1#160#249#27'@'#193'w'#185#209#4#240#5#161'}'#235#23#220 + +'c<'#1'('#229#241#224#164#188#214#127#226'M'#154#18'L'#234#255#214#190':'#3 + +#245'J'#0#227#198#141#211#6#131'Ak'#141#211'r'#182'/'#172'Nz;H'#208#245#214 + +'r'#176'P='#0#154#0'&'#147'6'#217#15' '#211'x'#253#158'c'#210'2'#201'v'#168 + +#160#228#163'Is'#15#129#185#251#159''''#245#165#164#21'm'#245#235#161'n'#195 + +'W'#208'^'#183#142#173#178#209'4'#142'B'#167#207#172#160'b'''#152#179#247#153 + +#144'W:y'#200#199#219#188#250'='#248#241#227'''3>'#168#149#186'/O'#158#127'8' + +#204#217#231#172#140#158#167'W$'#184#17'a'#1#180#253']'#164#1'x}`'#223#254#13 + +#255#16''''#207'*E'#204';)'#175#157#6'%'#146#218#207'4'#0#154#24'L#'#195#245 + +'z'#189#167#191#4#192#10#129#208'VPVVVjc'#177#152'e'#187#211'|'#162'7'#172 + +#185'+'#249#4'j'#9'f*'#5'['#201'4\'#253#181','#23'@'#165'Qr'#149#128#221#229 + +'j'#164#145#23#254#243#236#149',3,W@'#17#130'='#127'w5'#148'T'#15#207#190#252 + +'q$'#211#205'?~'#0'5'#235'>'#135#142#182#154'n'#11#174'2'#129#252#178#169#176 + +#232#152#27#217'H'#173'!]?'#10#255#143#31'?'#1'['#127#250#152#13'2M+'#240'w^' + +'>y'#15#216#253#176'+'#178#155#23#210#141#12'%d'#192'f'#3#4#252'!'#232'p'#5 + +#192#235'q'#131#163'ne'#138#3'P'#163#140'vT'#219#236'4'#187#190#129#132#159 + +'6'#165'RY'#135'2'#220'6h'#2#136'D"'#214#6#183#249'w'#238#144#238'!'#241#147 + +#180#166'b'#176#149#206'`y'#0'&'#139#142'M'#7'b'#29#129'2'#252#217#172#251 + +#250#31#240#243#127'_'#200#222#151#209'O'#20#148'O'#135'%'#199#222'<,B'#134 + +'^\'#217'7'#174#252#23#218#241#223#131#223#211'.Y'#145#13#249'T'#166#237'~$' + +#139#178#12#29'qX'#243#201'3Hd'#255'e'#205'C'#134#2#133#146#146#202#166#163 + +#224'_'#206#18'}r'#1'T'#13#24#141#198'P'#245#15#129#219#229#7#175#219#1#206 + +#134#31'S'#8'@'#167#140#216#171#172#246#143#128#215#0#168'"'#16#247#140#0#240 + +#182#183#187#138#192'~'#17'@'#179#199#184#175'3hxZ'#252'$'#141#161#0#242#198 + +#237#12'F'#163#14#205#0#29'k'#14#154#169'^'#0'b'#208'D'#222'7'#239#203#205 + ,#194#16#25#170#138';-8'#22'v^'#156#190#198#144#233'BG{'#29#252#244#233#211 + +#208#142'*~$'#228#151#250'rR`-'#154#0#251#159'y'#127#218'j1(g`'#195'7'#175'C' + +#253#198#175#193#215'A'#3#173#251'&8r`'#22'V'#238#12'Sw;'#2#138#170'fI'#253 + +#145#236#0'z'#7#17'j'#7#230#9#162#9#224#199#247#213#14#206#198#212#238#200'z' + +'U'#184#165#210#226#248#12':}'#0#228#4#172#29#18#1#144#9#208#234#209#237#209 + +#230'7'#254'#'#229#3#211'Z!'#191'b'#14#24'P'#253#183#152#245#172''''#0'u'#4 + +#202'F3'#208#127#221'w'#18#251#146's'#21'Z'#163#13#22#163'z'#155'?n'#154#212 + +#151#2#174#214#26#248#238#223#247#129#179')w'#204#166#238'@'#159#217'!'#231 + +#254#13#212#250#244#14':!'#19#193#217#188#21':Z'#183#129#27'I'#208#227'jfu"F' + +'['#25'X'#11'+Y'#178#151#165#184':'#183#11#193'X'#166#31#215#11#192#235#13 + +#176'('#128#199#209#12#238#150'u)O3'#170'C'#141#21#22#215#127#249'N@d'#2'l' + +#29#148#9'@'#155#216#9#232#244#171'f6z'#172')'#241'7'#133'J'#7#5'U'#187#131 + +#193#160#1'3'#154#0':'#150#11' '#239#182#31'X'#186')'#225#203#127#222#153'u' + +#15#240'`0e'#215#195'a'#222#129#210#12#177#8#251#221#240#217#203'7'#131#163 + +'i'#147#212#31'C'#191'A'#5'Y'#135#156#255'(k'#135'>'#154#209#157#190'B'#9'pa' + +'>'#9#168#3'M'#0'w'#251'v'#240#218'S'#167'#Y'#180#193#154'2S'#7'y'#6#27#248 + +'$ F'#0#209'ht@N@BJ'#24'P'#169'R'#149'nh-'#250#2'_'#165'I>'#3#5#189'p'#194'"' + +'$'#0#29'X'#172'z'#208#27'5'#172'5x'#159'y'#0'i`'#131#230'mk'#224#211#23#174 + +#207#202#151'1T'#152#11'*'#224#128#179#238#205#170'o`'#235#154#255#192#202'w' + +#31#206#154'C/'#157#160'<'#130#163#174'x!mSv'#135#5#250#180'P'#184#28#128'`0' + +#2#30'w'#0#220#168#1#184'Z6@'#160'#5)'#174#208#224']W'#160#247#253'D'#137'@d' + +#2#240#142#192#186'A'#135#1#137#0#240#133#164#147#21'ov'#20#191#30'K'#200'''' + +'$'#159#129#4#144'W1'#15'L'#22#27'j'#0#6'V'#19#160#226'C'#129']'#223'O&'#140 + +#130'W'#238'8l@'#241'h)A'#177#240#189'N'#184'%+'#145#130'O'#158'_'#14'-5'#185 + +'99'#167#191#176#20#141#135'C'#207#127'T'#234#203#144#4'='#5#209'('#2#16#12 + +#132'Q'#248#253#168#5#4#192'Q'#207#149#2#139'Qnv'#174'D3`'#19'%'#255#8#26#128 + +#144#8#132#154#128'o'#192#4' '#164#2#227#193#138#183'8'#10#30#12#199#20#139 + +#196#151'E]'#129','#249'e`'#178#234#192'd'#212#129'ZC~'#128#236#204#5'x'#239 + +#209#11#192#217#178'-+'#231'J'#23#166#237'q$'#204';(}'#195'#S'#128'6'#226'{' + +#127#191'h'#216'}&=a'#194#236'}a'#193#145#185'7'#1'X'#10'P'#18#16'E'#0'('#4 + +#200#17'@'#16#218#183'}'#3#177'h0'#229'y'#19#243#218'>U+'#226#164#254#215#163 + +#224'3'' j'#2#245#129'@'#192#142'f'#128'w'#208#181#0#248'wQ'#141#211'v'#173 + +'?'#162'Jq'#191#27#242#171#217#20#27#179'Y'#159#12#5#210'x'#176#158'k'#12#211 + +#247#161#172#253#244'yX'#251#249#138#236#127#27'C'#196'n'#135']'#12'Sv;<'#189 + +#7'E'#251#240#237#135#207'cN'#174#145#3#25#28'~'#201'c`)'#172#146#250'B'#178 + +#131'^'#204#0'j'#6#18#165'n'#192'>'#206#254#247'z'#252#208#182#245#139#148#16 + +#160'\'#150#136'N'#201'o'#249#8#5#159#194#30'uB'#30#0'nD'#8#246#129#214#2'$' + +#203#129#241#128'fd'#143#194'F'#143#229#20'wH'#151'B'#201'ZS'#9#228#143#155#1 + +'&'#179#14#204'V=h'#132#178#224',('#1'>W'#11#188'q'#239#169#153'?Q'#154'AYeG' + +']'#189#2't'#166#244#21#21#189#247#247'K'#192#222#176'q'#232#7#202'1'#152#242 + +#199#193#17#151'?#'#245'eH'#10'a&'#0#245#1#240'y'#3','#7#192#237'p'#160#9#240 + +'Cj'#18#144'"'#234#169#206#179#127#129#247#181#161#204#210'J'#192'f'#3#12#182 + +#28'8'#165#31#0#218#15#133#142#128'ai'#139#215#248#160#248'Ij'#141#5#10#198 + +#207#3'#O'#0','#18#160'R'#176#142'A'#137','#12#7'}'#233#214'Cr"-x'#160'`?' + +#236'+'#158'K'#203#177'H'#19#250#9#183#145#138'='#143#184#10'&'#205#31#157 + +#163#208'9$ '#30#163#8#0#239#0't'#250#193#213#214#0#238#214#245')'#4#128#182 + +#127'K'#133#197#245#3#222'l%'#199#31#240#229#192#168#193#147#167'pp'#13'A' + +#168'%'#152#223#239'7!'#131#20'D'#19#170#201'['#157#133'o'#136'_'#163'P*'#161 + +#176'z1K'#6#162'H'#128#206#168'ERP'#246'/'#23' '#13#252#240#206#131#231#177 + +#24#239'p'#196#188#131#207#131#25#139#143#27#210'1'#236#13#191#193'{'#127#187 + +'(g{'#229#165#3'r'#133#18#142#185#246#21#208#26#173'R_J'#250#209#143#175#141 + +'u'#2'B'#251#159#28#128#140#0'P'#3'p6o'#1#175'c[J'#6'g'#158#206#191#173#200 + +#224#166#196#128'VJ'#254#17'z'#2#146#6'0'#232#150'`BO@T'#31#10#240'GV'#190 + +#201'Q'#242'J}'#246'F)'#191#167'A'#129'j'#227#207#184 + +#251#179'A'#189'6'#28#244#195#138#27'G'#167'c'#172#176'r''8'#248#194#7'Xr' + +#213#136'@'#143#250'?O'#0#188#253'O+'#191#199#229'C'#18'p'#130#189'v%'#211#12 + +#4'('#229#177#224#228#252#246#175#240#249#2#1#212#0#231#4#164#209'`-h'#198 + +#187#131#136#1'M'#6#18#15#7#141'F'#163'6'#180'%J'#28'~'#221#190'->'#243#29 + +#226''''#170#212'z('#172#222#19#140'&'#29#152'mD'#0'\B'#144#208'&<'#27'j'#192 + +#11#215#31#8#145'P'#250#26'Wd'#3#244#3'>'#253#174#143#7#245#218'_'#254#251'*' + +#172'|{'#244#14'DUi'#13#176#223#153#127'd~'#148#145#138#4'_'#0'D'#241#255#160 + +'?'#4#30#180#255#189#184'9[j'#192#221#250'['#138#227#215#160#14#219'+'#204 + +#142#213'('#252#14#138#251#211'<'#0'>'#19#144'*'#1'['#7'3'#28#148' G'#155#129 + +'U'#4#250'|>'#139'F'#163')'#142#199'a'#194'F{'#225#243#137#132','#217#29#129 + +#170#168#24#1'X,'#204#15'`'#160#210'`'#230#7'P$'#29#129';'#156'-'#205'N'#235 + +'_'#191'z'#19#190#249#231'_%'#249#162#6#11's'#193'88'#230#250#193#141#147#254 + +#247#131#23'@k'#141#180#141'1s'#1'TA8m'#193#239'a'#206#1#167'g'#181'G_Z'#209 + +#131#134'L+<'#133#255#200#254#15#160#253'/'#16'@{'#221'Z'#8#186'[S'#8#160#208 + +#224#221'R'#160#247'Q'#185'g;'#17'@'#127#235#0#196#167#239#14';d'#3#226'V' + +#185#197#158#255#167'PL1#'#249'$'#20'rK'#241'N`-'#174#0#147'U'#143#4'`'#0#173 + +'A'#13'*%'#154#1#138#204#205#10#236#138'Wn;'#10'|'#206#214#236#156','#13#152 + +'0go'#216#231#140#255#27#212'k'#159'_~'#0'D'#130#185'U'#211'/%'#168#15'C'#233 + +#164']'#160'z'#151'}'#161'j'#230#226'a'#31'2dFz'#156'S'#255'#A'#222#254#167 + +#30#0#184'o'#222#252#5#196'#'#225#20#2#24'o'#181#175#210#169#162'-x'#179#29#6 + +#144#5#200'>'#187#222'>W'#241't d'#146'B4'#5'*'#154#188#182#179#221'!'#237 + +#209#201'''Q'#131'PK)'#228'W'#206'dQ'#0#163#197#0':'#147#150#21#6#201#149#217 + +#233#15'@h'#217#250#19#252#251#129#225#227'%^t'#194'r'#152#186#231#224'R'#130 + +#159#185'b'#201#176')'#132#146#2#148';'#160'3'#231#225#162'4'#30'J'#170'g' + +#195#196'y'#251#131#9'5'#174'a'#131#4'7'#9#184#211#254#199#213#159'e'#0#182 + +#131#189#230#7'6"L'#144'c'#133'<'#30#153#146#223#246'5'#10#186#7'e'#141'V@' + +#178#251#5#2'h'#196#197#219#217'S'#18#16#161'W'#2#16'&'#4#163#253'o'#212#233 + +'t'#249#241'x'#188#188'#'#168']'#220#232#177#220#156'|'#18#10#184'R'#163#131 + +#226#137#11#153#31#192'h3'#128#158#18#130#180#252#184#176#12'N'#12#238#138 + +#183#239#251#3#180'n'#27#218'l'#192'l'#225#212'?'#127#0#154'A6'#191'x'#242 + +#210#133#144'v;j'#132#131'HAo)'#128#252#242')P>mw'#152#186#224#240#156'4'#27 + +#216#234#159#224#212#255'('#170#255'd'#255#147#240'3'#251#191'y+'#218#255#155 + +'Xn'#128#0#163':'#212'^aq'#145'='#216#129#178#216#140#143#17#1#176#8#0'.'#220 + +#212';'#189#199#193#160#132'>'#9'@'#28#10#196#251#202#240#160#213#155#28'%' + +#143#196#19'2'#29'{'#18'k'#5'.'#135#194#9'{'#128#201'f'#227#205#0#174'.@AZ'#0 + +#171#14#236'>)'#168#219#147#14#225#195#11#184#29#240#210#141#135#231'|^@~' + +#197'T8r'#217#179#131'z-E'#0#158#191'f_'#169#223#194#176#135'J'#171#135#165 + +#167#222#2'U'#179#150'd'#252'\'#253#253#221#211#243'h'#177#140#199'x'#245'?' + +#20#129#128'7'#136#194#239#227#226#255#219#127#132#128#167'-%'#2'Pd'#240'l' + +#201#211#249#182#163#28#186#144'8'#154#132'$ '#218#227#202#223'b0'#24'X'#8'p' + +#221#186'u'#20'7'#140'ww'#222#30#175#137'"'#1#223'}'#247#157'*'#16#8#232#208 + +#20#176#161#9'P'#138'D0~'#155'3'#255#250'`T9C8'#4#249#1#172#165#211'Q'#229 + +#170#2#163'@'#0'z'#13#168#132'h@'#182'T'#0#196#202#127'='#12'k?z1k'#231#27'(' + +#232#179'8'#254#246'7'#192#152'W:'#168#215#7#189'Nx'#241#218#209#25#2#204#4 + +#138#170'g'#194#129#23#220';hm,'#221'`'#222#127'Z'#253#163'Q'#8#163#250'O' + +#246#191#151'%'#0#249#161#5#237#255'h'#23#251#191#218#214#190'J'#173#136'R' + +#248#207#129#127'6R'#8#144#239#7'H'#154'@k$'#18'q{<'#158'Pw!@B'#175#4'@'#155 + +#16#9#160#230#160#212#23#0#239#171'j'#246'ZNv'#5'uG'#8'O$'#2#208'['#202' ' + +#175'b&'#18#0#154#1'f'#3'W'#23'@'#141'B'#217#200'0'#25'd'#205#14'@'#188#255 + +#224'%'#208#176'ae'#214#206'7'#16'L'#156#191'?'#236'}'#214#29'C:'#198#147#23 + +#238'.'#245#219#24'Q '#243'`'#223's'#239#204#138'6'#208#27'HB'#168#244'7'#30 + +'E'#2#8#161#250#31#8#129#223#205#169#255'n{+'#180'o_'#197'Z'#131'u'#14#2#137 + +#133'&'#229#181'}'#143#194#239#195'?'#237'|'#8#144#217#255#168#181#215#247 + +#214#12'T|'#206'^?'#27#161'3'#144'^'#175'7'#1#31#9#240#132#212'{'#214'uX'#151 + +''''#15'"''?'#128#22#138'''.b'#171'?e'#4#234'L|8'#144#175#13'`'#166'B'#22'?' + ,#204'Wo>'#10#220'm'#245'Y'#3'p;'#202#27#253#221#209'S'#17#144#128'~'#17#0#213#4'x<'#30 + +#180#2#244'Vr'#4'"'#17'T5{'#244'G8'#2#198'dA;'#9#184'Zg'#132#162#137'{2'#2' ' + +#13'@'#199#178#2'5'#172'6@'#208#2#178#146#27',B'#243#230'5'#240#254'}'#23'B4' + +#18#202#234'y'#197#216#237#168'K`'#246'Ag'#164#237'x/\'#181#31#174#6'C'#155 + +'~3'#134#238'A'#157#154'N'#185#247#163#172#159#151#171#252#227#212#255'p0'#12 + +'Ao'#144#9'?'#173#254'T'#244#229'j'#222#200#156#131#130#253#175'VD'#253#19 + +#243#236'?'#226#223#148#17#230'@'#18'`'#14'@'#222#254#167#134' }:'#0#9#253 + +#145'F9'#146#128#18'I'#128#210#127#205'h'#10#20'#'#9'T'#198#19#138')'#155#157 + +#133#183''''#18'2V'#149'A'#194'M'#13'B'#10'*'#231#161#25'P'#8#6#19#18#0#211#2 + +#136#0'T'#160#16'*'#4'3gK'#198#223#195'h'#197#180'%G'#193#226#211'o'#202#206 + +#201#184#170#31#142#0#248#216#127#208#23'd'#130#207#212#127#167#19#9#224';' + +#212#12'"b'#251'?1)'#191'}'#21#170#255#228#8'"'#251#159#26#129#214'R'#248#15 + +#23'h'#234#1#208#136#194#239#232#203#254''''#244'G'#10#153'#'#16#15#166'"?'#0 + +#10'p>'#158#168#140#252#0#206#128'vi'#179#215#194#21'h'#147'#PFf'#128#14#205 + +#128#5#140#0'H'#3#224#162#1#252#244'`j'#24'*'#151'u'#27#17#200#240'P'#225'$' + +#26#127']'#9#31'>|%D'#130#190'L|'#157'L'#203#153#186#232#8'Xr'#234#13'd'#23 + +'e'#228#28'O'#253'a7'#246#131#24'Cf`*('#131#19#239'zw'#200#199#233#235'7-<' + +#206#21#254#196#208'LE'#2' '#231#31#18'@'#160#131'['#253#157'M'#155#192'M' + +#222#255'h4'#169#254#235'U'#225#142'J'#139'c'#29#202'Q'#0#239's'#1#215#4#164 + +'V'#176#255'qk'#17#154#128#160#240'G'#249'S'#13#158#0#186#250#1#144'eJ'#240 + +'~'#234#215'\'#189#201'Q'#180'<'#22#151'S'#136#144#17#0'e'#255#217#202'g'#130 + +#185#176#140'#'#1'3o'#6'h'#133#204#192#206'nA;'#148'Bw'#185#154'L'#182#186 + +#219#248#191'7'#224#199'w'#159#2'O['#250'Zj'#149'M'#155#15#251'^xOF'#139'Q' + +#234#214'~'#9#31#220'?z:'#1'I'#1'J_?'#231#137#31#134'D'#224#221')'#184']'#127 + +#207','#251'/'#193'y'#254#185#213'?'#138#230'j'#136'y'#255'I'#253#15'P'#243 + +#143'-'#223'@'#200#239'I'#137#255#151#24#221'[l'#186#0#165#249#250#241'>'#150 + +#0'$'#148#0#227#177#234'PKo'#235#143#253'/\C'#127#192#252#0#168#5'h'#220'n' + +#183#5#217#165#8'OXIf@'#131#219'r'#130';'#164#221#141#29#140#198#131'+'#20 + +#172'8('#175'j&o'#6#232#144#0't'#160#210#169#147'Z'#128#16#17#200#5'8'#27#182 + +#194#183'/'#255#5#26'~]'#201#134'F'#14#4'T'#133'f-'#29#15#19#230#239#15';' + +#239#127'2h'#12#153#207'&{'#239#238'?@'#195#250'o'#165#250#184'F'#13#246#189 + +#240'n'#168#222#245#128#140#158'#!'#168#255#148#249#23#137'B4'#200#169#255'd' + +#255#7#220'T'#252#211#10#142#237#171'!'#134#143#197#249#231#202'e'#137#216 + +#228#252#182#213'2'#136#7#248#248'?9'#131'X'#252#31#229#170#6'o7'#160#156#182 + +'['#173'V__'#246'?'#161#223#4#128'f'#128'\'#156#15#128#251'rd'#155#9#193#152 + +'v'#238'v'#151#237'\v02'#3'P'#184#149#26'5'#20#146#25'`6'#161#9#192#145#128 + +'Z'#199#229#4#144'/@&'#242#5#236#176#234#15#225'"'#135#2'R'#177#234'~'#254#10 + +#26#214'}'#11'm'#219#214'1'#205#128'&'#203#138#175#130'VvKq'#5's'#16#149'M' + +#159#15'e;e?#'#239#233'sw'#131'hX'#186#136#198'hA'#213'.K'#225#192#203#31#24 + +#212'k'#251'j'#132#155'L'#250#137'sC?c'#164#254#211#234#31#8'A'#136#188#255 + ,'l'#245'G'#245#191'a=x'#237#245')'#225'?'#179'&'#216'^fr'#209#196'W'#26#11 + +#228#22'*'#0#137#0#132#30#128#129'@'#192#137#230'z'#159#246#127'w'#215#214 + +#227#243#132'|'#0#178#1#168'0('#26#141#150'Q8'#16#31#155#176#197#145#127'a8' + +#166','#226#252#0'\4'#192'R6'#13#204'EU,$H~'#0#202#9' -@'#201#198#135')'#144 + +#4#184#196#160#28'Q'#4#134#5'>z'#248'*'#216#246'}'#246'CT'#163#17#182#242'Ip' + +#236#31#223#200#216#241')'#233''''#17#3'V'#214'M+'#249'C'#250#15#156#224#226#254'@'#158#255'8'#231#249#143#6#195','#243 + +#143#169#255#168#250#19#9#216'kV'#163#25'`gY'#172#130#250'o'#211#249#27'K' + +#140#30'R'#247#131'|'#250'/'#27#3'F'#241#127'R'#255#169#1#8#154#19#142#190 + +#242#255#197#24#136#228'%'#195#129'V'#171#213#24#12#6#169'Sp'#25#17#0#238#171 + +'j'#156'yg'#4#162#170'*'#193#12#160#162#10#163#173#4'l'#21#179#144#0#180'<'#9 + +'hy_'#128#154'9'#3#169'T'#24'dBX'#176#135#14#194#144'$'#205'~^e'#250#191'3)A' + +'~'#136#215#151#31#1#174#198#209#212#2'\zP'#133#224'9'#207#241'c'#214#135#26 + +#141#226#139#253#19#252#129#216#234#207'l'#127#170#250#139#176#208#31'9'#255 + +'H'#240#131'H'#0'>G'#27'8jWC$'#28'I'#241#254'O'#176#182#175#213#170'b'#30'R' + +#255#241'O'#23'5'#0#1#222#254''''#239'?'#223#16#164#163#183#6' '#221']Z'#191 + +#223#134#16#14#164#254#0#248#183#21'U'#13#150#21'H='#2':'#130#186#5#141#30'3' + +'+'#17'f'#177'~'#185#2'Tj5'#20'T'#239#10'z'#139#141'E'#2#136#0'4d'#10#176'f!' + +'*'#166#5'0_'#128#140#159'(<'#194#132'w'#168#160#130#159#215#151#253#14#127 + +#16'cI?'#217#134'B'#165#129#179#158']'#157#222#131#242#131'>'#133#142'?'#204 + +#246'G'#2#8'3'#225#231#9#0#247#142#186#159#192#239'la'#142'iA'#253#215#169'"' + +#238#241'V'#199#175#188#250'O'#9'@'#164#254#179#240#31'%'#255#144#250'O'#225 + +'?\'#160'='#253#9#255#9#24#16#1#208'&'#152#1#8#19#153#1#148#21'H'#4#128#143 + +'Umu'#22#156#25#142')'#11#133'.A'#20#247'7'#228#149#129'm'#220#206'I-@C$@CDY' + +#179#16'!/'#128'F'#137'e?E8'#151'AQ'#136'7'#174';r'#172#234'O"'#168'tF8'#227 + +#201#244#246#148#16#135#253'('#238'O'#158#255'H'#16'U'#127'"'#0#15'n>'#170 + +#254#179#163#250#191#10#205#189'0'#243#15#8#234#127#185#217#185#193#168#14 + +#145#211#143#169#255#192#13#1#173#23#17'@'#147#160#254#163'lF'#250#10#255#9 + +#24#168#196'13'#160#176#176'PE#'#195#168':'#144#6#134#224#133'T'#145')'#224 + +#10#234#23'4{'#205#7#2#175#210'S'#21' '#211#2#198#239#14':'#139#5'4F'#29's' + +#10#170#13'|'#207'@'#181#138'=G!'#231'g'#9#202#248'K'#234'O'#154#224'`'#223 + +#193'0@'#235#166#159#224#223#183#159'6,'''#31#143#20'h'#205'yp'#234'c_u'#255 + +'`_b'#213#205#239#151#21#251#240#163#190'H'#176#227#201#213#191#211#249'G' + +#171#191#179#254'g\'#253#155'8'#231#31#175#254'k'#149#17#239'x'#171'}='#10'{' + +#132#138#127#200#251'O'#237#191#240#200#181'|'#2#16#169#255#164'&v'#168'T' + +#170'`w3'#0#251'{'#169'}>_0'#3'('#26#128#127'['#168'K'#16#158#188#130#8#0#168 + +'m'#184#179#240#244'HLa'#21'j'#3#148#168#234#27#243#202#193':n:'#168'Q'#11 + +#160#193'!D'#4'j'#22#18'$'#18'P'#240'aA9?V|'#16'W5'#130#176#229#235#247#224 + +#243'G'#174'a'#182#223#24#164#3#133#1#143#190#251#157#244#28#140#15#252'S.' + +#127'"'#202#175#254'h'#223'G'#130'a^'#253#15#176#172#191'@'#135#19'W'#255#239 + +#185#213'?'#130'$'#193'1'#7#140'3w'#252'f'#214#4')'#244#23'F'#185#242#240#201 + +'?'#228#253#167#240'_'#13#202'"'#205#4'l'#31#136#247'_'#192'`D-'#165'8'#8#184 + +#193#161#204#25'H'#154#128'#`X'#208#234'3-'#21'F'#131#145'3P'#169#209'@'#225 + +#132#221'@k'#178'0'#19#128#242#2'Th'#6#8'Z'#0#171#20'Lv'#16#150'%'#157'&'#253 + +'m$:R'#176#254'?+'#224#235'g'#239#200'l'#14#244#24#250#133#233#251#159#8#11 + +#207#186'eP'#175'M'#249#221#242'!?'#230#253#143'q'#5'?'#156#237#31#134#8#31 + +#250#163#212'_'#218';'#27#214#129#223#209#8#209'H$'#25#251#215'('#162#254#9 + +#182'v'#234#250'K1}'#10#3'Q'#247#223#22'~'#213#175#193#191'k)'#249#167#175 + +#246#223#189']'#235#128#223#159#208'-'#24'm'#13'='#178#143#141#204#0#188#191 + +#146'i'#1'2Y'#229#22'{'#193'I'#145#184#194#196'r'#2#228#10'P'#170#149'`'#200 + +#175#2'k'#233'T\'#253#181'H'#2#168#5#232#185#196' V)H'#179#4'),'#168#232#140 + +#10#176#19#245#148'" zk'#178#228'?'#195#27#171'^{'#8'V'#191#254#176#212#151 + +'1'#6#30#135#223#186#2'J'#166#207#239#246#177#148#223'_/'#191#189#4#223#232 + ,'#E'#245#167#213'?'#24'a5'#255#17'?'#231#252#11#177#216#127#7#180'o['#9'Q$'#6 + +'z'#14#181#6#163#215#149#153':'#182'X'#180'A'#154#248#19#225'{'#255#145'&@+>' + +#9'>'#133#255#234'q'#223#170#211#233#220'='#13#0#237#13#131'"'#0'J'#10'B'#150 + +'a'#205'B'#3#129#128#153'J'#132'c'#177'X'#5'e'#6'rZ'#128#17#181#0#227#158#130 + +'3'#144'T|'#138#255#231'O'#216#3'W'#127#19'G'#2#212'4T'#207#151#10#147'CP' + +#221#233#16#148#241#166#128'l'#7#233#30#204#202#152#251#236#240#213#147#183 + +#192#175#31#189','#245'e'#140#129#7#253#6#207'~'#249#215#129#190'Jt;'#145#12 + +']'''#189#254'd'#207'Gx'#199#31#173#254#254'P'#210#251'O{W'#227#175#224'u' + +#212#177'~'#0#148#31'@i'#194'jE4Pmk'#251#5#229'!'#138#199#160#252'o'#15'nT' + +#250'['#207''''#255'lG'#217'#2p'#244#167#246#191#175#171#30#208#187'%g'#160 + +#201'dR'#163#218'a'#196#191'Yj0'#229#3#224#237'*|'#175#228#11'8>'#154'P'#232 + +#153'3'#16'Ww'#188'P0'#20#146#22'0'#133'9'#1'Y8'#144'6=_)H)'#194'h'#6'P'#18 + +#145'L('#22#202#206'lQIa'#175#217#0'o.'#251#157#212#151'1'#6#17'J'#166#205 + +#135#195'n'#127'iH'#199#232'n'#245#143#161#240#179#184#127'0'#196'9'#255'|A' + +#206#1#232'qC{'#205'w'#168#25#132'x'#207'?'#183#250#151#24#221#219#172'Z'#127 + +#155#200#249#151','#253'%'#225'GY'#169'C'#185'k'#182'Z'#173'.'#148#195#192'@' + +#156#127#2#6'M'#0#130'3'#16#153'G'#231'r'#185#200#233'W'#140#23'T'#1'\'#153 + +'pe'#155#207#184#208#30'0'#206'Kj'#1'H'#2'*'#141#22#242'(='#216'bE'#2#208'$' + +#137#128#180#3#133'P($T'#11#138#251#6#140'`'#22'x'#251#250'c'#161'u'#211#26 + +#169'/c'#12'"'#28'q'#215#155'PP'#189#243#160'_'#207#249#252'D'#141'>H'#168'#' + +#188#227'/'#192#173#254'L'#248'}AF'#4#174'z'#180#253#157'h'#251'S'#211#15'z.' + +#190'T%'#139#134'&'#230#183#255','#227'l'#255#16#18#0#139#253#163'l4'#144#240 + +#227'mr'#0#178#206'?]b'#255#253'V'#255#9#131'&'#0#232#146#19#128#23'H'#163 + +#195'h'#0'[%nU1'#210#2#28#133#199#198'P'#180#217#160'p'#210#2'P'#192'u'#150 + +'"'#176'U'#204'fu'#1'I'#2'`'#14'A$'#1'V.'#204#153#2#192'L'#7#254#242'Fh'#170 + +#176#223#217#10'/'#159#183'p'#204#233#151'C0'#20#148#194#9#127#255'b'#208#175 + +#151#241#169#190#204#8#136'w'#198#252#185#130#31'A'#245#199#205#31'`'#197'?' + +#1#23'e'#253#173#225'<'#255#209#206#213#191#216#232#169#177'i}'#173#252#234 + +'O'#153#127#212#5#150'B}'#245'T'#246'KN@Z'#253#145#0#156'~D'#127'S'#127'w' + +#184#222'!|V'#201#10'A'#179#217#172'#g '#222#199'B'#130#184#175#162'=j'#1#11 + +#218#253#134#185#204#169'Ge'#194'D'#2'j'#13'X'#199#205#0'}~)S'#255#213#6#29 + +#211#6'Tz'#13#31#22#228'{'#6'$'#253#1#248#142'd'#217'm)'#158'-|'#244#231's' + +#161#246#135'O'#165#190#140'1'#136'p'#240#205#207'C'#217#172#133#131'|5'#159 + +#236#203#219#253'B'#177'O'#156#217#254#188#234'O'#4#224#193#149'?'#192#217 + +#254#142#237'?@'#200#211#193'&'#1'1'#2#192#255'T'#242'hp'#162#205#142#182#127 + +'"'#202#135#254#216#234'/'#196#254#129#235#250'['#143'2'#215'N'#206'?'#170 + +#252#235#173#243'oo'#24#18#1#144'3p'#221#186'u'#172'QH '#16'0'#161#6'P'#128 + +#23'Im'#195#153#22#128'W2n'#155#179#224#247#225#184#202'"h'#1#148#2#172#209 + +#27#208#20#216#13#212#148#19' '#242#5'(u'#184'Qr'#16#159#27' h'#2'2'#161#157 + +'xOq'#193#158#222'E'#142'/'#172#207#158#176#19#174#12'c'#181#253#185#130#202 + +#249#251#192#254#215'='#193#253'1'#136#223#148'X'#248'i'#229#135'8'#151#238 + +'K'#142'='#177#227'/B'#234'?'#222#246#180#214#128#167'e'#243#14#171#127#185 + +#197#181#209#168#10'R'#184#143#250#190#177#208#31'n'#173'(_'#245'|'#209#15'%' + +#0'5S'#230#31'j'#224#254#193'8'#255#4#12'uYMf'#6':'#28#14#189'R'#169#180#225 + +'E'#22#227'F'#137'AL'#11#240#133'5'#211#235#220#182'}'#4'-@'#193#180#0'5'#24 + +#11''''#128#185'x"'#175#5'p$'#192#180#0#161'u'#24#223'>'#172#147#4#248#203#29 + +'A'#138#192'sD'#0'c'#21'~9'#1#26#22'z'#242#243#171'Q'#251'T'#15#238#0#188#25 + +#215#185#242#243#170#127#152's'#252#145#131#143#179#253#3#16#246'"'#17'x=,' + +#233''''#18#12'B'#140#250#253'E'#185#196#31#20'|G'#133#197#181#5#15#21#19'V' + +#127#161#237#23#169#253#192#245#252'k'#224#203'~'#221'}'#245#253#239#11'C&'#0 + +'A'#11#160#182#225#168#9#144'/'#160#0#137#128#249#2#144#8'H'#19'(k'#240#216 + +#246#246#132#181#149'r'#150#29#168'`5'#0#10#10#11'V'#206#3#141#201#10#26'#g' + +#10#168#146#17#1'5'#243#7#176'b!'#218#152'#'#145'+'#27#30'I'#166#192#138#211 + +'v'#129#144#215'%'#245'e'#140'zP'#225#218#161'w'#188#10'E'#211#230#13#234#245 + +#9#174#212#143#247#250#199#217'l'#191#4#223#230'+'#30#140'$W'#127#138#251'3' + +#199#31#222'v5'#252#2'AWK'#202#234'/C'#218#168'F'#213'_)'#143#134'zZ'#253#5 + +#207'?n'#142#254#182#253#234#245#189#167#227#243#19#215#7'h4'#26#214'4'#148 + +'O'#15#166#188#128#242'h\^'#177#213'Yxp'#2#215'uA'#11'P'#168#212#160#181#20 + +#176'ra'#181#174'S'#3'P'#11'Z'#0#229#6#8'Q'#1#190#155'0'#136#202#134'G'#130 + +'_'#240#213's'#22#130#175#189'Q'#234#203#24#213#160#197'e'#191#27#158#132#10 + +'T'#255#7#140#132'x'#166#31#231#244'#Afv?'#173#252#225#8'K'#250#137#6'B'#172 + +#221'W'#132#247#250'S'#165#159#139#154'}'#160#240#211' '#16'a'#245'/'#212'{' + +#234#10#244'>'#10#243'u]'#253'i'#236'7'#181#253#222#142#130#223'@U'#127'H'#8 + +#238#129#230#253'w'#251#254#211#241#25'v'#213#2#240#194#10#132#136#128#160#5 + ,'8'#2#198'9'#173'~'#211'l'#210#2'@'#161'`'#14'A'#5#154#2#150#178#157'@'#159 + +'W'#202#146#130#152#240#147#22#160#227'H'#128#181#15'S'#241#237#196'EY'#130 + +'2y'#186'.]Z'#252#235#210#3#193'Y'#187'Q'#234#203#24#189#192#223#210#146#203 + +#255#10#19#247#26#194#236#6#22#231#7#214#224#143#229#250#243'N'#191'X'#132#19 + +#254#8#175#250'G|'#156#6#16#246#243#142'?'#159#155#21#4#9'q'#127#149'<'#26 + +#168#206'k_'#143#199#139#241#171'?y'#254'Y'#213#31#173#254#184#175'U('#20#181 + +#180#250'k'#181'Z'#7#146#192#144'W'#127#246#17#164#235#163#236'N'#11' _'#0'p' + +#17#1#26'$R'#180#213#153#191#127'8'#166#178#10#217#129'$'#220'j'#189#145#229 + +#6#168#13'z.)'#136'O'#17'V'#178#220#0#222#20'`'#141'D'#249#14'Bra'#196#24'$' + +#213#128#225'J'#5#31#222'r24'#174#249'R'#234#203#24#149' '#13't'#191#27#159 + +#134#178'9'#139#7#252'Za'#213#231#179'}x'#187#159#19'~Z'#209'i'#245#143#133 + +'"'#201#176#31#229#252'GI'#248'q'#239'i'#217#10#222#214'm'#140' '#152#237'O9' + +#255#248'_'#165#217#177#193#160#14'S'#166#31#9'4y'#134#133#145#223'Md'#251 + +#147#240#163'L'#213#167's'#245''''#164#141#0#186#243#5#0'7H'#180#146#15#13 + +#150#249'#'#234#9#181#238#252'%l'#29'Wt'#154#2#134#252'r0'#151'N'#229'j'#3 + +#152#6' r'#8'R'#247' '#149#146'+'#24#18#154#137#178','#193#225#239#24'l\'#243 + +#5#252#231#230#147#165#190#140'Q'#7'CA'#25#28'~'#223#187'h'#130#230#15#252 + +#197#157#195'y:'#139'|'#226#156#205'O'#182'?'#173#234'L'#245#167#132#31'a' + +#245#199'-'#26#8#254#127'{_'#22'kYv'#158#181#246'x'#230's'#238'XsWwW'#187#219 + +'v'#187#227')'#241#0'v'#136#193#145#8#194'F'#8#5#148#4')'#145#176'P'#132#132 + +#20#241#18'!9'#188#0'/H'#188'!'#224#1'x'#2#9#17#144#128'XHH$`x'#128#7#144#172 + +'$'#216#198#221#158#186'k'#174'[w:'#243#176#7#254#239'_'#255'Z{'#237'}'#207 + +#173#186#213']w'#170#190'K'#218'w'#15#247#12#251#236#189#191#239#159#255#165 + +#166#253'='#181#243#222'wT2'#155#209'k'#23'\'#25#8#159'A;'#158'n'#223#232#238 + +#161#229#19#192#159#152#184'?:'#254#162#230'_'#233'Y'#127'n/'#145#254#0#255#7 + +'*'#27'}'#158#208')E'#4#136#173'V'#137#165'.'#139#22#128#174'A'#215'Q:|o'#208 + +#251'b'#127#214'x'#153'+'#255'B"'#129' d'#144#247#174#146')'#176'zUH@'#8#160 + +#225#248#3#184'V@'#155#2'l'#14#248#158'T'#15#150#127'I'#158#23'?'#201#243#206 + +'x'#28#144#198#191#254#181'O'#169#217#197'D'#159'''3'#232'ay'#245#203'_S'#191 + +#240#219#255#248'H/_'#250','#229#198#225'/'#137'>'#22#252#186#208''''#227'2_' + +'m'#247'c'#129#218#191#24'C'#19#152'p'#155#175#249#184#207#182#191'Q'#253'=z' + +#247'k'#171'['#127#28'x)'#138'}JY'#127#180#127'_<'#255'h'#251'u'#239'yK'#127 + +#254']'#207#243#242'.'#203#11#160#31'q'#21'~'#0#163#5'dyp'#229'G{'#27#191#152 + +#229'~'#13#0#246'E'#11#136#234#13#181#242#210'gT'#173#211#213'&'#128#144#0 + +#182#131'Z'#173'0'#5#196#31'P'#174#28'<'#191'Z'#192'w'#254#229'?P'#127#244 + +#187#23'U'#128#199'=z/}D'#253#153'o'#254#11#213#189'~'#235#253#127#8'W'#248 + +#228',ssW'#242'['#187#159'l'#250#217'\K'#127'V'#253#167'"'#253#231'j'#255#222 + +#247#213'd'#239'>{'#253'a&(N'#249'e'#199#223'{'#235#205#17'z'#251'C'#250#163 + +#3#12#247#251#163#5'Y'#128','#253#197#7#240'p>'#159#239':'#158#255#15','#253 + +'1'#158'7ll'#227'Pd'#7#146#22#128'9'#178'.!'#18' Q'#1#172'/'#239'Oko'#220#31 + +#174'~'#206#19#135#160'1'#5#226#246#138'Z}'#233#211'l'#2'@'#250'G-q'#8'J'#243 + +#16'?'#150'Ta3'#211#176';'#229#184#167'='#186#207#214'A'#244#244'G'#150#204 + +#213#191#250'K'#175'?'#243#172'D'#23#227'h'#163#181'y]'#253#220'_'#251#166'z' + +#229#231#223'g'#193#149#17#252'z'#30#175#178#211#15#246#187#145#252'H'#248 + +#129#228'g'#2#152#217#176#31'r'#255'G'#219'w'#200#246#127#135'$'#255#140'I"O' + +'u'#185'o=\'#244'_'#233'm'#191#157#231#252#137'\'#239'o'#26'~@'#250#211#254 + +'m4'#251#132#244#199#12#192#181'Z'#13'>'#130#217'Q'#27'~'#30'e'#251#6'x' + +#138'/'#237#248#203'otw'#223'i'#199'3'#132#249#172#227#143#176#129#164#159'-' + +'H|'#241#252#179#227#143'0'#180'3'#164#177#183#183'7{'#214#134#31'O'#27#199 + ,'B'#0'J*'#5#209'6'#140#206#187#213'h4`'#10'\VZ'#250#223#148#245#165'E'#26'\!' + +#18#248'R'#166#194#136'I'#128#147'~"'#235#15#136#219#29#173#1#136'C'#16#25 + +#130'a='#226#181'o'#138#134'l'#142#128#152#3'b'#18#148#148#128'e'#191#242#164 + +#177#246#148'+'#253'?'#255#225'o'#169#31#253#193#191'='#225#147'z1'#6#188#249 + +#31#251#139#127']'#253#204'_'#254#155#207'>'#163#239#147#158#13#145#250#182 + +#194#207#218#252#162#250'/t'#184#143#19'z&s'#209#0'D'#253#167#237'>'#236#254 + +#253#251#252#154''#174 + +#230#163#254'i'#159#202#185#25'+/'#127'T}'#246#27#127'G]'#255#220'W'#223#215 + +#251#151#206'>g5'#254#188'P'#251#179'\l~'#29#235#207#165#188'W'#199#251#181 + +#218#159#10#248#19'&'#130#153#26'o'#223'S'#253#135'?`'#211' [,'#172#215#191 + +#17#206#251'/'#147#221'/'#223#4#213#31'&'#192#152#22#132#130#224#12#180#170 + +'?-'#152#231#15#14#193#145#211#236#243#185'I'#127#251#155#143'iX'#135' &'#20 + +'%'#192'cZ'#241'Mt'#14#130'/'#0#166#0#189#230#10'-k'#15'G'#189#183'v'''#205 + +#151#141'w_;'#250'b'#213'\'#135'?'#224'u'#21#213'$1'#168#17'["'#240'M[q'#19 + +#30#180'='#5'i'#9#138#217#134'r'#201#21'8'#15'n'#129'{'#255#231#191#169#255 + +#250';'#191'z'#218#167'q'#166'Gs'#253#138'z'#233#203'_S?'#243'+'#191#165#234 + +#171#155#207#245#179'M#'#15'//'#8#0#21'}'#153#16#0#219#253#146#230#11#149#30 + +'E> '#0#150#254#0#255'Tk'#1#179#193#158#218#187#253#135#244#191#194#238'W' + +#176#251#189'd'#241#234#202#246#247'B'#178#255#149#168#254#180'L'#137#4'0' + +#203'/:'#253#222#147'f'#159'w$'#1'h'#219'8'#254#158'W'#216#175':'#142#149#0 + +#224#16#252#214#183#190#197'MC'#136#201'Z'#244#195'`'#152']'#22'-'#0'$pM!J' + +#160#188#149'w'#247#214#190'0Kk=eH'#0#210#157'H'#160's'#249'5'#186#233'/IRP' + +#205'j'#1#8#13#194#28#240'b'#157'#'#160#195#131#18'"4'#25#131#158''''#10#192 + +#249#9#19#254#254#223#254'e'#245#240'";'#176'4'#26'kW'#212#205#159#255#154'z' + +#235#24'@_'#26#206#196#157'6'#209'G&'#241#204#165#161'g.'#177'~V'#253#167#218 + +#238'O'#5#252')'#183#249#30#178#211'o1'#30'j'#233#159'&'#186'4'#152#237#254 + +#189'w'#218#209#180'oT'#127'z>9'#230'Ok4'#250#228'f'#31' '#0#244#249#203#178 + +#12#190#128#253#227'p'#252#185#227#184'aa'#29#130#244#163'j'#164#1'tMn'#0'H@' + +#136#0#29#133#215#147'<'#218#248#233#222#250#23'3'#130#189'q'#10#194#31#0'{' + +#191's'#245#227#170#209#187','#192#143#181'?'#192'5'#7'b]>\'#20#14'A'#11#208 + +'D'#144#151#10#136#156#159#251#164'_~'#18#254#129'C'#190#31's'#1#254#222#175 + +#127'A'#141#30#221'9'#129#147'8'#187#163#177'vYK'#250'_'#251'['#31#12#244'O{' + +#194#141#202#159#231#142#237'o'#192#159#217#226#158'\'#178#252'8'#140'7[X' + +#192'C'#242#167'Sc'#255#143#9#252#127#164'f'#163'}Q'#253#19#235'7Xo'#142#238 + +'m6'#251#144#240#244'Hz'#166#216'g'#12#144'#'#227'O'#21#210#255'.'#225#4#181 + +#254#187#180' '#230'?'#251#250#215#191#158'>O'#199#223#179'\'#158#231#241#249 + +#236#16#188'v'#237'ZD?'#166'I?'#142'M'#1':~]'#242#2#224#16#132'V'#176#218#159 + +'7n'#222#31#174'|'#138#253#1#220#16'$'#212#243#6#196#177#234'^{K'#213'z'#235 + +'L'#0'69'#168')'#249#1'5m'#10#232'D'#161'P'#207'1`'#252#2#158'8'#6#13#1'x:' + +#195#235','#155#4#217'|'#170#254#227'o|^M'#182#31#156#246#169#156#232#208#160 + +#255#243#234#19#4'zl'#31#247'0A'#23#207#216#251#210#196#147#255'!'#192'5Y~' + +#185#128#31#146'?'#19#181#127'!$'#144'Ng'#236#245#239#223#253#174#154#13'w4' + +#248#209#223#15#170#127#134'x?'#236#254#157#183#229#27'!'#253#145#245'7'#161 + +#239#178'1'#127'I'#246'A'#143'?T'#254'm#'#227#143#204#229#217'q8'#254#220'q' + +#18'0`-'#128#214#193#189'{'#247'0'#181'x'#11#141'C'#148#6#189'!'#1#248#5'6i{' + +'e{'#210'}'#227#241#164#253#154'.'#24#242#25#208' '#129#176#214'P'#221#171'o' + +'q'#255#128'@'#204#129#192#248#3#140'S'#208'!'#1#27#29'p'#27#140'B#p'#253#1 + +'v6'#226#167'\'#134#147'L)'#150's'#193#148#224#223#250#245#159'S'#211#189#173 + +#147#251#238#19#30'A\S'#221#151'^W'#215#190#240#139#234#245#191#240#13#213'X' + +#127'N'#160'?'#202#253't<'#253'&'#191'7wm'#254#212'H'#254#2#252#25#131'_''' + +#251'X'#181#31#14#192#217'L'#245#31'|_M'#247#183#216''#239#186#170#127#179#217#156#16 + +'^'#22#199#225#248'+]'#138#227#248#208'e'#223'cL'#1#218#174#199'q'#220'Y,'#22 + +'k'#196'vp'#2#26#18#192#246#6#189#180#247'`'#216'{s'#127#214#188'a'#253#1'a' + +#164'g'#24#170#183'T'#239#198'[*nuu'#211#16'h'#2#13#153'h'#148#246#217#31'P3' + +#230'@A'#2'z'#242'Q_'#151#17'{^'#209'r'#253'e'#245#234'/'#253'U'#181#249#214#23#143#241#203#158#208 + +#198'/'#175#188#206'H{'''#179'O'#247#242'3'#224#207'X'#234'g'#21#201#207#241 + +'~'#2'}'#6'{_'#136#0#165#189#147#157#247#24#252#186#181#151#158#212#211#207 + +#210#228#229#149#237#31#212#130#197#196#181#251#149#14#249#193#238#223#18#213 + +#31's'#252'q'#200#143#182'w'#8#15#195#231'Y'#236's'#132#203'vb'#195#166#9'_' + +#191'~'#29#154'@'#11#181#2#240#7#208#15#191'*aA'#204'1'#8'=p5'#247#252#206 + +#157#254#234#167#198'I}'#213#23#167#160#23#232','#192#184#217'c'#18#8#26'uM' + +#0'l'#18'D'#146')'#136#16#161'4'#18'A'#152#208#180#21#243#29#18'0'#221#133'<' + +'!'#0#229#2#255'9D'#12#142'a6'#227#225#253#159#168#255#254#219#191#172#134 + +#247'~z'#130#183#236#217#6#8#186#190#178#169#214'>'#254#179#234#213'?'#251'+' + +#234#218#159#248#165#163#191#249#176'k'#246'<'#158'PG'#218'kG'#191#201#231 + +#207'm#'#143#194#230'/'#210'{y'#153#27#169#191#208#192#135#148#135#250'O'#132 + +'0'#217#190#163'F[?"'#146#152'Ks'#15']'#223#143'?7'#187'{o7'#194#217#208#177 + +#251#231#244'l'#163#197#23#18'='#182'%'#215#159#193'O8'#128#25#176#141#132 + +#159#157#157#157#169'x'#253#13#248'_'#24#2#224#239's'#19#132#8#248#173'$I' + +#216#31'@'#11'B'#130#208#4#216#31'@'#235#149'\'#249#157'w'#247#214'?='#205 + +#162#14#146#132#152#4#184'7'#0#145'@gMu'#174#189'%'#229#194#162#1#152#252#0 + +'h'#1#146'-X8'#6#203#154'@a'#18#248#197#228'#N1'#209'Y'#237'='#248#255#254 + +#205'?R?'#248'w'#255'DMw'#30#158#234'y'#4#245#166'jn\S+'#175'}'#130'$'#252 + +#159'R7'#190#244#231'T}'#253#202'i_'#158#202#200#203#210'_Rz='#227#236#147'r' + +'^'#6#191#163#246'['#240#139#202#15#224#179'z'#207'*'#191#246#1#204'v'#31#168 + +#193#195#183#233'usn'#238#193#239'Cyo'#154#229'W'#187'{?'#236#196#147#190#168 + +'l'#214#238#23#167#223'.'#236'~ZX'#245#135#211#143'0'#240#152#222#187'O'#166 + +#241#4#9'?'#199#233#245#175#142#211'x'#202'}'#152#2#180#6#9'X'#127#0#217'?' + +#151#29'S'#0#26#1#252#1#221'$'#243#187#239#246#215'?'#179#200#163#134'o'#204 + +#1#216#247'$'#233#153#4#174'|'#156'H'#160'nA'#207'f'#128'h'#4'L'#2#145'&'#1 + +#21#233#168#2#147'@h'#8'@r'#5'|'#129';'#214'2)'#225'Y'#159#166'|'#240#222#219 + +#234#143#255#249#223'W'#15#254#247#31#208'C99'#190'/'#162'k'#17#183'{'#170'u' + +#245'e'#181#250#209#207#168'+'#159#251#170#186#250#249#175#210#245#175#159 + +#246'%x'#250'03L'#219#130#30'c'#231#23#253#251#140#167#223'H~V'#225#231'I'#1 + +'x'#6#255#156#155'{'#178'&@'#255#155#238#222'U'#163'G'#210#206'{Q'#168#253' ' + +#146#203#173'}L'#231#181#131'/q'#156'~H'#245'E'#188#127#15#133'='#180#141'F' + +#144'P'#251#225#244'{D'#207#245#222'I'#218#253#238'8'#141'G|'#169'?@f'#22'b' + +#167#160#210'Z'#0#182#215#233#1#236#204#147'`'#229#189#254#250#167#19#21#198 + +''#28#234'#p'#231'R'#217#151'I' + +#184#15#142'>'#14#251#137#31'`'#188#253#30'-'#239'jR'#224'i'#188'S'#142#22#0 + +#252#27#205#193#237#245#198#240#145#11'~z'#182#140#221#15#240'o'#153'J?z'#230 + +#239#201'4'#223#232#240#131#6' '#199#150#237#247','#151#242#196#190#215#245#7 + +#208#197'h'#18#248'{'#164#10'm'#18#192#175'Hx'#144#179#4'iY'#3#9#204#210'x' + +#237#246#254#250'''3'#207#15'Yr#<'#24'j'#18#8#27'm'#213'!'#18#136#154#29#2'~' + +'h'#181#0#228#8'x'#236#20',H'#128#181#129'J'#152#208#212#17#24#18'`'#231' t' + +#148#220#153#144#164'`'#132#234#147#246#244'+y'#10#4'1'#219'{'#172#230#253#29 + +'5'#31#236#210'zO-'#134#251'\9'#217'}'#249#13#213#185#249#250#217#149#224'G' + +#189#142'K'#239'C'#17#222's[u'#219#16#159#11#254#170#212#151#220#254'L'#154 + +'z'#148#9'@K'#255#209#214#143#213'd'#239#30#189'n'#206#145#1'~'#159#228#248 + +#175#214'F'#15#174#180#251'w'#243#2#252#200#244#131#221#15#240#195#238#127',' + +'!'#191'{R'#223#15#27'n{:'#157#14#136#0#160#194'%''e'#247#31#245'r'#31#251'w' + +'W'#243#3#200#28'@3'#209'Md'#10'*'#237#16#196#26'$'#176'J m'#141#23#181#205 + +#187#253#213#183#136#4#2'm'#207#11#9'p'#4#160#201#230'@D'#234#170#213#4#156 + +#181#23#11#17#24'M'#128'L'#2#21'j'#191#130'2s'#17#26's'#192'M'#30'2UEn'#163 + +#145'3l'#26'|'#232'F^'#10#226#8#224'M'#21#159#210#158'}'#137#239#187'i'#189 + +#218#230#215#128#207#13#248#173#228'_0'#200#217#241'7'#211#161#190#225#163 + ,#183#213#172#255'H'#146'|'#140#218#175'k'#251#187#209'd'#235'zw'#239'=m]d' + +#153'x'#252#145#236#3#240'#'#151#127'['#233'y'#253#24#252#216'F'#178#207'I' + +#198#251#15#27#167#253'('#151'R'#133'I'#11'h#'#25#136#180#128'K'#208#4'h'#31 + +'Z'#0'H'#0#164#176'B@lM'#147'x'#237'N'#127#245#19#169#23#198#218#179'/>'#1 + +#174#12#172#17#9'|L'#197#157'uM'#10#198#15'`'#192'/m'#198'=!'#2'_z'#10'('#19 + +'%'#16#231#160'2'#230#128#239#21#4'`'#174#214#139'>]'#241'y'#25'.'#234']sGl|' + +'O'#202'wm'#3#143#170#179#207'8'#250#0'f'#212#243'/'#28#240#27#231#31#175#167 + +'j'#240#240#7#164'ImK'#140'?'#209#196#145'j'#240#175#213'F'#247'/'#183#145 + +#226'k'#193#159'I'#154'/g'#250')]'#226#251'H'#230#245#131#228#199#164#30#143 + +'1'#171#207'|>'#31#31'w'#170#239'Q.'#227'i'#223'F'#207'8'#5#209'@'#4']'#132 + +#208'P'#212#9#15'"O'#224#138#201#20#4#9'$y'#220#189#189#191#250#214'BE'#245 + +#18#9#136's'#176's'#249#13#21'w/'#177'/'#192'3'#181#2#177#244#16#176'&A'#164 + +#253#2'b'#14#168#208'/'#146#134#140'i '#13'F'#172'F`'#175#152#163#10#156#159 + +':'#163#23'f'#148#146'xl'#171'.}'#140#193#159'i'#201'oc'#251#169'n'#226#1#240 + +'+'''#204#151'K'#190'>'#171#244'3'#241#250#211#177'\B'#127#201't'#162#6#247 + +#191#175#18#228#246'''s'#157#21#232#128#127#163'1'#184#189#217#28'>'#210#138 + +'F'#150';'#146#31'*={'#252#149#238#237#7#240#223#151'p'#223'cH'#254#197'b1' + +#186'v'#237#26#156#131''''#234#244#171#142#179#240#236'Z'#18#232't:1'#177'b' + +#157'.T'#27#149#131#232'$'#4#2'0$ '#173#198'A'#2#205'L'#133#237#219#253#181 + +'7gY'#220#214'}'#0#196#174#143't)qk'#243#150'j'#172'^'#215#146#222#1#189#217 + +'f-'#160#166#147#139'8Dh'#219#142#7#133's0'#240#10#141#192'I rs'#137#205'f~' + +#224'''='#225#10'?'#211#173'>'#175']'#130#142#248'h='#245#250','#191#178#185 + +#211#151#223#5#191#246#238#235#248#190'J'#181#202#175#4#176#156#155#159':' + +#246#254'\'#131'?'#183'j'#191'd'#242#17#25'$'#147#161#234#223#255#158'Ji]H~' + +#157#225#167#210','#191#220#217#255#201'j<'#217#21#193'o'#193#175#138#190'~' + +#166#190#255#1#164#191#132#254#30#163#190#159#198#168#209'h'#204#143';'#207 + +#255'9'#222#165#227'?'#15'S:'#140#162#161#241'x'#140#134#162#29#169#25#184'd' + +'4'#1#165#251#7#160#177'H'#143#174'X'#147#16#218#188#211'_'#251#216'8'#173 + +#173'x2'#239#160#206#254#211#18#191#190'rU'#181#214'oiM'#192#250#1'B'#157',$' + +'d'#224'I%'#161#138#138#190#2#166#152'Hq'#132#192#244#23#240#203#145#2#167 + +#243'P.'#161#195#234#21#245#202#127#158'q'#228'O'#220'='#179#195'{'#234#129 + +#167#255#238'|'#201#207#21#144#27#129#175#14#11#237'9'#133'<*-b'#251#197#162 + +#129#207#210#127#190#144'p'#223'B'#180#129#5#255'o>'#216'a'#155'?'#157#142'u' + +''''#31'Z'#148#128#223'#'#241#127#181#187#247#163'n8'#27','#3#191#210#225'>' + +#128#31'-'#188#31#144'&'#203#14'?'#228#248'#'#220'G'#175#27#161#200'G'#157 + +#146#211#239#131#222#157'c='#23#248#3'~'#252#227#31#251'h%F'#154'@'#195#228#8 + +'`V!'#164#12#131#8'h'#141#164'!4'#26#237#210'Uk'#17#240#234#247#6'k'#175#15 + +#23#245#13'c'#14'0'#17'DP'#241#145':'#220'Sm2'#9'PG'#224'K?'#193#2#252#142'6' + +#192#254#0'c'#14#232'm'#155'8Ti9f'#195#134#158#201'(tr'#207#171#253#7#204#173 + +'=KW'#250','#143#202#245#202#157#166#156'%'#208#27#162#200#164'eW'#150#29'H' + +#231'Ui'#1'z'#227#237'O%'#212#151#207#231#142#195'O|'#0'D'#2#147#221#219'j' + +#178#253#158#222'w$?>'#223#167#15#184#222#219'{'#167#21#204#199'K'#192'ob' + +#253'h'#234#137'4_+'#249#233#153'}L'#160#223#165#231#23'5'#0' '#137'3'#1'~' + +#231'2'#159#153#193'$'#240#189#239'}/@x'#16'$@Z@W'#26#137#184#154#0'"'#3#235 + +'('#28#162#27#129#18#227#248#254#160'wko'#222#188#234'['#245']k'#2#200#26#244 + +#227#26#153#4#31'Q'#181#206#166#150#248#174#244#23#223#128#206#17'0'#249#2 + +#129#205#30'TN'#6#161#237'@'#236#251#5#1'8m'#201#221#26#3#235#164#170#22#27 + +#157#181'+~F'#134'Wr'#228#185#155#249#1#240'k'''#159'H'#251#180#144#250#165 + +'t^'#168#251#137#238#215#175#9'@<'#254#226#237'7'#26#0#19#0#166#233#154'N' + +#213#136#164#254'|'#180#171#227#251'IR'#2#127#160#146#217'K'#221#221#31#214 + +#131#197'T'#192'o'#28'~F'#242's'#129#15'r'#252#209#220#3#146#31#26#0#212#254 + +'('#138'v'#7#131#193#136#180#218#19'M'#243'='#210'u?'#237#19'XvN&<'#184#181 + +#181#21#211'Ek'#208#5'4$'#128'lA'#180#24#135')'#192'$@'#251']'#248#4#232'X' + +#237#209#168#243#210#246#180'}SO8bH@2'#0#137#8#234#189#171#170#185#241'*'#131 + +#222's'#181#129'H'#147#129'''-'#199#149'q'#14'F'#21'm'#192'u'#16#154'z'#2'&' + +#3'eg)'#202#29'2p'#181#255#220'!'#133#15'f'#26#188'(C'#210'u\'#137#159#23#181 + +#249#202'sT}'#199#201'W'#168#249'"'#245#197#214#231'2'#222#180'p'#242'1'#232 + +#165#148#215'z'#252#141#234'/'#170'>'#219#254#201'B-'#250#187'j'#184#245#14 + +#29#27#219#200#128#174#229#151#137';'#189#249#228#165#238#222#15#185#170#143 + +#235#8'l'#168#143'S|'#149'd'#249')'#237#224'C'#184#15'R'#255#1#212'~'#178#249 + +'w'#233#249#29'6'#155#205')i'#183#201'iz'#252#151#141#179#250#4#150'H'#160'A' + +'c2'#153#160#145#8#155#3'B'#2' '#3#209#4'T'#151#128#136#190#131#181#253'Yc' + +#243#225#168#251'Z'#166#194'PKn'#169'!'#8'C1'#9#186#164#13#188#193#213#132#0 + +'>'#28#129#158'D'#4#220#16#161#155'9'#168#156'Z'#2#229#18#129#231#23#179#22 + ,#251#198'I'#232'j'#3'E'#30'a'#238#148#25'z'#213#146#195#3#153'mg'#245#182#188 + +#223#187#249#4#127#134#233#191#167#156#198#28'|'#188#2'zP'#168#3'~'#211#173 + +#135'U}'#9#239')'#167'O?'#188#245#249#28#251#11'+'#249's)'#238#201'%'#207'?' + +''''#240#143'wn'#171')-'#153'y]*R_f'#238'iG'#147#237#171#173#253#219#129#151 + +'&:'#151'(3e'#189#240#246'3'#248#149#206#242'CO?'#246#248#195#230'G'#168#15 + +#224#167'eH'#166#236#20#177#254#179#6'~}'#205#207#238#176#133'C'#4#254#136'.' + +'b'#147'L'#130'.H@:'#10']6'#225'A%$'#128#16'!H`'#158#133#237#187#131#222#235 + +#179#172#214#230'y'#3#140'o'#192#132#10#163#186'j_zM'#197#221#205#2#248'f1'#4 + +#16'W'#142#7#186#211#144#178#243#19#6'em@'#26#143#148'#'#6#158#149#244#172#29 + +','#137#30#152#249#11#142'zG'#206#204#147#227#222#168#167#189' ?'#252#128'i' + +#197#229'y'#14#248'3'''#150#175#28#27#223'Q'#247'y'#31#182#190#27#222'K'#11 + +#137#159#27#208''':'#181'7/'#145'@'#194#245#19'#'#146#250#243#225#142'h'#11 + +':'#188#167#138#30'~'#217#165'F'#255#246'Zc'#244#152'S{%'#212#167'tz/O'#223 + +'-s'#248'A'#237'7'#137'>'#15#207#19#248#143't'#239'N'#251#252#12#9#244#251 + +#253#184#213'j5'#232#226#162#197#248#154#132#4#225#16#188#12#173'@i'#18#232 + +'1'#9'('#175#158#7'~'#252'p'#208#189#185'?o]-'#146'|t'#184#15'&'#129'oL'#130 + +#245'W'#8#236#177#205#9#240'L'#5'a'#172'5'#6#171#9'p'#10'qPT'#21#210':'#15 + +#220')'#202#140'V'#224#21'D'#160#138#237'"JP'#172'K%'#200#206'f^9'#236'='#235 + +#173'z'#158'w'#245#153#31#215#188#152'>'#219'='#149#188#188#145';/'#178#245 + +#249'n'#18#143#177#243'MG^'#145#250'*u$'#191'c'#235#27'/?'#219#237#12#244'E' + +#161#254#207#11'R'#192#255#23#240#242'?'#254'!i'#1#19#177#247'u|'#223'|n'#228 + +'/&'#215#218'{?i'#132's'#174#229#23'G'#4#236'}'#147#222';'#145'P'#31#171#253 + +'J'#194'}'#178'F'#169#239#222'y'#0#127#233#254#156#209#193#231'W%'#1'd'#12'"' + +'Y'#136'.'#178'!'#1#152#5#151'0'#247#128#210'y'#2'm'#186#212'u'#146#184#241 + +'p'#222'X{0^'#185#149#145#236#215'@-'#155#4'H!'#6#9#196#157#13#201#7#144#136 + +#128#1#191')$'#10'+$ '#11#147#138'h'#6#156'N,'#145#130'\'#162#6'V'#27'x'#26 + +#17'8'#221#137'rG;'#240#202'^'#196''''#220#177#147#184#149#249#225#135'+'#167 + +'i'#140'{'#175#244'6'#167'<'#23#0'WO'#0'~^'#150#248#202#22#239'8N>c'#239#187 + +'v'#191#149#252#139#18#240'Y'#19#152'N'#213'd'#251#167'j6'#220'b'#130'@'#179 + +#15'+'#241'3=__'''#154'<'#190#210#234#223'!'#149'?'#205'm'#147'@]'#210#235'd' + +#248#245#165#178#15#222#254'G'#146#215#255'H4'#129'}8'#252'666'#206'<'#248 + +#237#253'9'#227#195#146#128#18#159#128#146'2b"'#130#21'h'#2#146'%h'#178#5'9Y' + +#136'$r'#155#192#211#160';'#23'''Y'#212#184';'#236#189'6Kk'#29'S'#0'd'#27#140 + +#8#184#163#214#26#19'APo'#21#17#1#167#138#208's'#251#10'<'#137#8#220#148'b' + +#153#194#220#134#14#205#196'%'#165')'#204#202'k7'#132'h'#230'4'#176#135#14 + +#132#20#143'n:<'#151'q'#152'*o'#156'v'#246#144#145#236#230#127#249#146#216 + +#189'~'#157#14#227'I'#230#158'!'#2'k'#227'/Q'#247'S'#145#248#2'|'#181#208#149 + +'|J'#236'w'#215#222'7'#206'?E'#251#147#254'=5'#221#189#173#19#127#210'%*?}' + +#209#229#198#224#189#149#198'h'#199#203'MI'#143#14#243')'#1'?'#173#199#180 + +#223#151#154'~4k'#132#196'GE'#31#182#183'I('#161#145'''{'#251#201'\=s'#14#191 + +'e'#227'<'#16#128'=OC'#2#251#251#251#17']'#228':]x'#174#29#136#162'h'#157#246 + +'a'#6'\'#18''''#225#134#212#14'th'#27'}'#4'b'#210#0#162'G'#195#206'K{U'#147 + +' '#212#201'C'#138#171#11'#U'#235']S'#245#181#27#156'M'#200#14'@'#199#4#0#1 + +'(''Dh'#136#192#148#24'+'#153#181'X'#249#229#198'#'#182#21'Y%'#179'P'#231#15 + +'-'''#3#207#209#255#139#222#4#166#151#161'{UN'#136#4#170#143#176#19#182'+m' + +#229#5'Y'#149'CxN'#165#158#27#198'3N='''#150'oA'#159#154'm'#0'>#b'#0#160'u' + +#17#143'Z'#20#13';'#173#199'?IJ>'#0#132#0#147#209#158#154#236#252'D-&'#131'B' + +#213#135#169#128#207'pU'#254#238#238'O'#234'^2'#245't'#229'@'#213#211'?'#147 + +#22#222#168#234#219'q'#193#15'O'#127#24#134#232#235#223'_,'#22#227#25#141#243 + +#2'~'#140#243'B'#0#246'\'#221'<'#1'8'#252#232#194#183#232'p'#143'.'#254#186 + +'8'#7'A'#4#156','#132'V'#227'$'#129';$u'#27#180'_#'#240'E'#131'i}'#237#193 + +#164#247'j'#150#235#249#7#180#147'0`'#21#222#244#16#132'Y'#208'X{'#133#139 + +#138#188#208#137#6#200#220#3#134#8'4q'#4#162#29#136'&`{'#13'8]'#137#131#138 + +#163'P'#8#161'hF"'#19#152#28'H76'#161#195#162','#185#240#15'T='#3'G'#200'1' + +#248#160'%'#203'y^yi'#25#240'z'#229'4'#218'TE|'#159'%'#189#153'l'#195#190#230 + +#160#154#207#246'~'#154#149#218'r+'#150#250#153#6#173#0'_'#137'='#175#164#131 + +#143'2'#4#144'h'#239#127':''u'#127#231']5'#239'?'#210#173#186'L'#26'p'#146#10 + +#209'h'#149#31#149'|'#151'['#253#187'P'#249'9'#188#143#254'}'#160'!m'#239#219 + +#24#191#1#191#210'e'#189#15'e'#198#222#199'R'#207'? '#1'4>K'#25'~G'#29#231 + +#137#0#236'9'#155#180'a'#218#142#26#141'F'#13#17#2#164#7#27#231#160'8'#5'/' + +#217#218#1#29'&'#132's'#176#6#147' Sa'#252'h'#220'~'#169'?onz@'#166#137#20 + +#216'f!Z'#226#195',h'#192', B'#176'R'#223#1#188'Bd '#22'B'#16'M@9'#25#132#214 + +'I'#24'>A+8'#204'GP'#154#242#188#186'v:'#26'['#13#193#161#130#165#190#130'CB' + +#143'O'#200#187#183#160'.%'#224#23#26'H.'#234'})Q'#199'%'#0#215#147'/'#158'}' + ,#163#226#219'p'#158'q'#240'Y'#208#167'b'#231';'#158'}l'#11#192#181#202#175 + +#215':'#175#223'8'#2'%vO'#235#217#222'}5'#222#131#186'?'#211#199#229'3y'#157 + +#167'"'#245#147#201#149#230#254#237'f<'#27'z'#26#247'8'#15#146#250'%{'#223'&' + +#248#208#178'C'#210#254'1'#9#153'G'#210#213'g'#155#128#191'K'#160#31#160#149 + +#23#13#152#8#231#10#252'K'#158#138's3,'#9#208#197#15'k4'#200#12'h"B'#16#4#193 + +#170#227#23#128'F'#0#18'X'#5'A B &A'#148#19#196''''#139#176#253'p'#178#242 + +#202','#141'ZE'#235#240#162'('#200#147'9'#10'k'#221'+'#170#182'rM'#5'h'#162 + +#17#154'y'#8#3#199#28'pM'#3#9#17#134'RK`'#10#140'l'#14'A Z'#129#201'$t'#218 + +#146'U'#137#160'j*'#148#202#146'+'#21#137#21'G'#162';'#242''''#146'A'#165#216 + +'f'#217'c'#235'Jw'#222#168#172'e;7'#137'<'#153#27#190'3'#137'<'#142#164'wc' + +#249#2'|'#29#203'/'#192#175#137#192#9#241#217't^'#13'r'#237#3'H'#10''' -'#139 + +#225#14#219#249#9#171#251#186'I'#167#146'L>'#179#246#232#207'j}t'#127#189'1x' + +#228#177#180#207'3'#147#214#171'$'#190'O'#203'\j'#249#135#226#233#135's'#15 + +#210#30#249#252'['#178#191'O'#207#220#160#223#239'O'#187#221#238#156#8' =o' + +#224#175'>'#9#231'm'#148'J'#137'I'#19#136'%u'#152#157#131't'#140#181#1#144#0 + +#250#11#210'z'#141#253#2#202'k#}'#152#182'czDc rw'#218#186#180'=m_'#207'H' + +#164#235#226#31#237'$'#132'fP'#168#249#145#170#181'/'#169#6#17#129#31'7'#180 + +#244'7j'#191'k'#14#24#127'@'#224#164#17#187#166#129#201'!p'#29#133#198'<'#176 + +#4#224'W'#18#139#180'G'#192#246'.'#180'='#11#141'iP'#152#3'n'#194'Q'#217';' + +#239#29'XU"s'#202'Az'#217#181#144#187#161'='#137#215#231'y'#197#214#151'B'#29 + +#163#226'gy'#145#167'oSu'#139')'#183'\'#201'_H'#253#20'M5'#197'VO-'#9#184'a' + +#190#220#170#251#198'!H'#18#127#184#173#166'{wU:'#27#22'f'#129#11'~'#241')' + +#180#162#217'.I'#253';'#152#156#211'C/`}n'#172#242'+'#221#187#207#228#244#143 + +#140#167#159#182#183#197#219#191'Ej'#254'6'#9#24'h'#2'}'#147#215#239#244#241 + +'3'#192'?7'#224'w'#30#135's;,'#9#16#1#4#8#19#18#27#195'9'#216#154#205'f=h'#3 + +#244#127#244#26'D'#171'1h'#2#240#11#160'r'#144#211#135#17'% '#192'D'#244#17 + +'A'#146#249#241#163'I'#247#230'`'#214'X'#247'l'#241'O'#1'^?0 '#142#184#166#0 + +#206'B'#244#211'3'#166#0#167#13'['#208#23#161'A'#27'!'#136#180#244#207#131 + +#224'@wb'#235'#p*'#15#11'"P:'#164'h'#211#139#165']'#153'*L'#4#151#24#150'^"' + +#175'r'#197#170#26#192'!'#14#190#18#15#184#245#246#216#204#242#146#189'o5'#0 + +'7W'#223#128#221'z'#244#141#202'/'#246'~'#166#167#219'V'#226#228#179#128#183 + +#29'{'#202#224#183#197'='#236#253'_'#168#217'`K'#205#246#239#17#240#199#146 + +#16#148'X'#147#1#251'J:'#246'D^2'#187#212#26#220'n'#215#166'}'#248#28'<'#143 + +'U~V'#252#233#146#177#163'Oz'#247'Me'#178'Nk'#239'C'#237#151#153'{9'#190#15 + +#149#159#20#206'1b'#252#245'z'#29#164'a'#234#249#237'U:O'#227#188#19#128#249 + +#13'H'#24#194#154'#'#4'p'#14#18#1'4E'#27'X5'#190#1'!'#1'6'#9'h'#191#7#191#0 + +'m'#195'A'#8'm'#128#222#231#251#163'$'#238'>'#28'uo.'#178#168#233#154#5#202 + +'I+V'#226''''#136#219#27#170#222#187#174#130'F'#235#160#212'7'#170#191'C'#4 + +#134'L'#148'K'#2#2'z'#229'U'#157#133#14')x'#166#10'Q9~'#130'J7cq$'#30#152#241 + +#232#176#154#3'[m'#231#188#196'm'#180'a6'#189'B+'#240#158#2'zW'#213#247'*' + +#222'|'#29#215#207#172'Df'#7'`R'#168#251#158#1'}'#226'H~'#163#13'd'#134#8'2' + +#142#223#207#6#143#24#248#217'bb'#237'~'#227#216#203'\u'#159#132#252'J}'#252 + +'p'#179'9x'#224#209#142#199#165#130#224#29#218'f%'#198':'#250'f'#210#187#207 + +'t'#238#133#167#223#130#31#19'v'#160#137#7#254#143#254'}'#163#209'h^'#241#244 + +'+u'#14#193#127#200#147'q.'#135#141#16#160#156#248#214#173'['#225#214#214'V' + +#141#14#213#137#173#17'*'#236#145#250#134'b'#162'u''u'#24#251#200'#hC'#27#160 + +#237#26#251#6''#199#245'3'#201#231#183'R'#159#22 + +#19#226'c'#149#31#160#199#2#149'_'#8#1#29'|'#198#244#182')'#217#253' '#140 + +#132#180#206#236'<'#132#249#142#4#156#23'h'#176's'#240#219#223#254'6'#251#5 + +#232#166'E'#4#234':'#28#132'259'#155#4'XD'#27'0$'#208#165#183#146'>'#175#26#4 + +#167#24'f'#1#129'='#160#199'%'#220#157#183'6'#247'&'#173#203#137#10#226#3'D' + +#224#23#246'>4'#130#176#209'!'#173'`'#147#8'a]'#249'a,m'#198#140#3#240'0'#167 + +#224'!'#5'F'#146'3'#224#149'|'#3#166#23'A1'#169#137'%'#2#153#224#196'LuV'#10 + +#18#10'7'#148#156#132#14#3'xF'#210'Wd'#153#145#246#7#28'{N'#252#222#149#252 + +#182'B'#207#237#200'c'#192'/'#132#160'\'#167#159#149#242#142#211#207#233#224 + +#131#255'-'#166#251'j1'#220#162'e'#155'I w'#205#128','#147#150'_'#236#220#195 + +'~'#222#138'g'#187#27#141#193#131'Z'#184#152#150#212'}'#199#214#151#182']' + +#166'c/l'#249'}i'#226#193#158'~Z?Fl'#159#164#252'>='''#3'2/'#199#244','#205 + ,'{'#189#30#192#127'n'#237#253#165#128'9'#237#19'8'#166#223'T2'#9'h N'#211'di' + +'O'#128#167#155'j'#137'@'#204#3#236#19#9#168#14#1#174'A'#251'u:'#30#25#179 + +#128'@'#21#236#205'Z'#27#187#227#230#229#133#10#235#218'F'#247#203#211#141#17 + +#1'('#223#183'ZA'#173#177#170'""'#131#176#185#162#163#4#230#181#142'3'#208'H' + +'~'#255'0-'#192#152#8'&'#147#208#248#7#248#23'V2'#12#221#28#130#220#137#12#8 + +#27#152#196#220#131#209#130'Jz'#174#167#172'j/'#255'V'#226#245'+Iyc'#227#27 + +'{'#223'4'#227#176'Z'#128#1#186#172#165#192#166't'#220'M'#237'u'#215'('#203 + +#157#13#31'3'#240'S'#132#242'2'']W'#166#220#206'e'#209#192'O'#243'vm'#182#189 + +#217#24'>'#140'|H|'#28#23#191'>'#171#251#220'%'#208#205#232#227#240#30#242 + +#249'i'#189'/'#237#187#182#205'"'#206'?'#28#199'k'#166'F'#229''''#205'2;'#207 + +#246#254'a`y'#17'G'#201'$@'#168#176#213'j'#197#2'lT'#12'v'#197#25#184'J'#140 + +#143#232#0#22#248#5'D'#27'P-!'#2#152#5'a'#206'd'#128#174#225#190#191'7k'#174 + +#237#142'[W'#230'y'#216#176#206':'#3'|'#207'H'#242#162#2#17#154'@'#212#222' ' + +#173'`C'#5#141#142#227#252#11#184#231#160#231'8'#2#139#168'@u'#10'3'#207#2 + +#222'F'#5#2#209#4'\'#237#192#151#144#161#149#252'U'#7'`%'#159#192#12#183#149 + +'6'#239'+'#235#28#176#213'zF'#229'O'#171#234'~&fA'#230'T'#234#21#206'?~'#189 + +#209#0'*a'#191#18#9','#230'j6'#218'f'#208''''#211'A'#161'!'#152'L@'#199'l0}' + +#0#16#210#235#198#147#199#27#4'|x'#246'M'#190#241#19#212'}k'#235#211#210#151 + +#238'='#12'~'#186#207#144#254#216#222#15#130#128#19'{h'#153#145#244'_ '#196 + +#247#162#168#252'K'#129#242#2#15'k'#18' J'#128#178'b'#186#185'54'#25'!R@'#227 + +'Q'#152#5'+ '#1#133'Y'#137'5'#9'@'#27#232#209#210#17#179#160#238'{~Lk'#16'A' + +#8'"'#240#9'}'#251#179#250#234#206#164'ue'#150'!'#135#192#128#177#144#218#5 + +#176#3'K'#10'a'#212'Tq'#7'Z'#193#154#10'j'#141'2'#184#157#210'bo'#9'!'#184#9 + +'C'#133#25#224#21'~'#2'''R`o'#173'u'#11'H'#180#192'M$'#146'W'#185'~'#128#210 + +#172#185#178'*'#194'}'#174#244#207#156#233#180#225#240#203'd'#178#205#138#183 + +#191'*'#245#179#188#18#1'H'#212'b'#178#175#230'P'#241#199#187#156#216#147';6' + +#189#251'~K '#244'}>1B'#183'6f'#224#7#200#15'6'#192#231#138#221'2'#240#149#6 + +'?'#128#143'N'#189'#'#201#229#223#23#240#195#185#135#25'y'#25#248#240#240'+M' + +#14#211'N'#167'3G'#3#143'7'#223'|'#243#133'R'#249#15#0#228#180'O'#224#132'~#' + +#155#4#208#6'h;Z]]'#141#160#13#200#140'D0'#11'z'#162#17#172#233#244'aM'#4#180 + +'&'#18'Pm'#186#235#220'l'#4'&'#129'o'#136' '#131'F'#224'y'#195#164#209#219 + +#153'4/O'#211'Z'#7#200#180#192'tH'#160'4'#231#128#152#0#232'I'#16#212'z*jt' + +#201#168#232#210'~'#173#210'[`I'#231'!G'#213'/'#171#254'x'#173#18#159#128#241 + +#234'{'#182#152#168#8#4'x'#149#181'*7'#222'PE'#218#190#178#13'8'#157#146#221 + +#204#13#241#21#234#190'w'#192#23'P'#201#233'7'#145#0#2'v2'#27#170#20'v'#253 + +#164'O'#219#131'"'#219#207'x'#239#197#137#231#153#254'~v;'#231'p^'#167'6'#217 + +'^'#175#143#182'|'#143'sy'#213'2'#224';'#237#185#173#147'O'#233#9':'#160#214 + +#239#25#240#3#248'$'#12#246#200#222#135#3#16'z'#254#132'l'#253#217#139#230 + +#232'{'#26'8>,'#227#128'6P'#171#213'bz^0G'#22#166'*G'#159#129#30#28#133#240 + +#17#28#212#6'T'#211#152#5#4#180#18#17'(.'#25#11#163#253'yc}0k'#172#205#210 + +#168'Y'#0#180#172#198#27#245'>'#247#202#196#0'B'#8#27'+*'#170'wT'#0'B'#128#19 + +#209'!'#0#27#14#148#162#162'jc'#210#146#9#224'4"'#177'w'#185#218#140'D'#194 + +'~n'#233'n)'#12#232'j'#2#198#9#232#168#251'n'#184'/'#207'+I?yA'#0'H'#206'I' + +#166'}'#150#244#201'tH'#255'J'#10''' '#155#20'i)4'#200'Q'#0'K&'#184#184'Y' + +#138#4#158#149#218'x'#167#25#209#135'i'#204#231#154#160#24#248#0'<'#235#252 + +'b'#231'/*'#234#254'H'#226#250#198#214'G'#136'oW'#188#251'}'#186#215'C'#168 + +#251#176#245'www'#23'd'#231'sl'#255#19#159#248'D'#254#162#131#223'yB>4'#163 + +#164#13#192'7'#176#178#178#18#17#25#208'f'#204'}'#6'h'#1#216#225'(\1'#218#128 + +#210#26#2#250#18'"'#164'h'#136#0'Y'#132'1a.'#160'g=dg!'#20'r'#210#11#166'i' + +#220#216#155'5'#215'G'#179#218'Z'#162#130#200'S'#5#25#20#146#220#169#7#240 + +#141#243#207#28#15#148#31'7Y;'#8#226#22'}B'#131#9#130#29#141#202'5'#3#156#181 + +#141#18#136#170#159#171#194'$'#200#171#209#1'U'#16#130#155#244#227'6'#222'4' + +#7#149#201#4#212'$'#192' u'#18'}'#12#232#177'dp'#188#211#146'/'#198'l'#199'c' + +#201#200'4/'#1#190#186'm'#181#137#204#250#20'`'#195'7'#195'y'#191'S'#159#236 + +'t'#163#233#158#199'I'#5'b'#143#232#188#131'Ll|l'#1#244#236#224's'#128#143 + +#134#29'#'#153#153#135#195'{'#198#222'7'#14'>'#216#249't'#175#199't'#159#167 + +'('#224'[b'#235';W'#224#197#29#31'6'#2#176#191#217'h'#3#155#155#155#254't:' + +#13'1S1'#252#3'0'#11#232#223'-'#178#7#225#12'D6'#225#138'8'#7'W'#196'y'#168 + +#157#132#158#215#164#199#177'A'#159'V;@'#4#30#224#166'Q:'#152#215#187#253'Yc' + +'}'#148#196'+'#185#22#233'V'#133'7)'#191'E'#135#225#162#243#176'K'#8#185#152 + +#0#164'x'#16#25#212#153#28#130#176#206')'#201'>'#214'd>'#148#10#139'J'#191 + +#244'`'#219#242'"G'#160#236#237#247'Jf@^$'#7#25'3'#1#248'K'#209'H'#19'@'#159 + +'p'#197']'#150#152#245#212#206#198#163#242#195#0#15#252'f%'#147#1#239'1'#251 + +#181'`1&'#21#127#167'GK'#232#193'!'#160'L'#237'0'#147'B'#154'iu'#223#177#241 + ,#171#18#223#216#249#3#1'?'#146'w'#0'~^'#144#194'K'#210#30#197';'#172#238'w' + +#187#221#217#214#214'V'#226'x'#248'_X['#255#176#241'a$'#128#210'o_f'#22#208 + +#225#26#217#130#28'6$'#2#128'F'#208's'#23#209#6#208'k'#160'm'#136#128#128#140 + +'(CL'#251#16#211'Rc'#204#157#238'|'#180'*O'#9#206#251#179#198#234'h^'#235'M' + +#211#168#157#230#162#25#24#199#158'r'#10#131'J'#132'`'#156#127#190'>ig'#187 + +#152#199#16']'#144#27'*'#8'"q:'#134'tX"'#17#158#164'"'#243#233#232#181'/Z' + +#134#150#190#137#216#218'R)'#151'9'#139's'#28#146#28#18#158'_'#207#225'7'#7 + +#196#182#196#183#240#1#184#0'W'#165#130' 1#8T'#167#242#154#191#24#213#163#249 + +#176'G*>Zn'#23#17#8#145#246'8'#3#2'>x'#18#206'}''o'#223#134#244#164'K'#207 + +#184#2'|'#187#208'=d'#224'#'#172#135'L>"'#2#246#238'#'#149#151#8' '#251#176 + +'I}w|'#152#9#192#140#3'f'#1'B'#127#244'p'#196#198'QH'#255'o'#9#216#187#244' ' + +#245#184#150#128#136'@4'#2'v'#20'*'#204'T'#164#188':4'#2')4'#10#173'V'#224'#' + +#29'E'#251#10#176#13#208#18#9#212#137#12#186#147'E'#220#157'$q'#139#224#16#26 + +'S'#161#232''''#232';'#205'D+'#246#190#152#2#150','#148#155'*l~'#150#252'@.' + +#30':$$'#232#216#255#182'EW'#169'1'#191#201#250'S'#165'\'#0'['#221#167#138 + +#148'`'#6'u'#166'T'#158'/'#7'<'#214#181' '#25#215#131#249#176#25#207#251#237 + +'h6'#242#149'8'#243'<61'#140'moA'#175't'#202'.'#24#133#213'|Y'#230#198#179'o' + +'T}'#19#211#151#5#158#254'>'#128'OD>'#140#162'h'#12#137'O'#199#167't'#127#23 + +'t<'#249'0'#170#251#203#198#5#1#20#195's'#205#130';w'#238#4#198'?'#128'9'#7 + +#232'!B'#205'@'#203#241#19#244'$'#140#200'k'#248#7#20'"'#6'9W'#26#214#161#209 + +#18#216#17'm@BQ'#24#248#30#200' '#160'c>'#180'^F'#165'/'#229'<'#244'wL$@'#132 + +#208#153'.'#162#206'4'#141#219#153#14#8#138#237'^T'#4#22'e'#194#170#168#10'T' + +#254'R'#240#219#191'U'#207#127#241#207'J'#246'_'#197#7'`Gn'#205#0#3'z'#183 + +#145'g'#225'G(^g'#0#31#251#201#164#22#206#135#173'h>h'#147#164#15#252'4)^c' + +#153#197#128'^Y'#21#255#160#180'/'#169#250#144#248'p'#224')'#1#187#164#242 + +#150#164#189#1'~'#171#213#154#141'F#'#246#236#147#169#151'~X'#213#253'e'#227 + +#130#0#202#227#128#127#192#16#1'=H'#28':'#164#127's2'#17#173'['#244#0#162#216 + +#168'+'#26#129#171#13#176#143#0#175#229#228'#'#223#135'Ya'#200' 8@'#6#128#174 + +#158'`'#132'a'#142'|<"'#132#246'x'#17#183#146'4'#168#207#179#176#190'H'#131 + +'Z'#170#160#219'k'#251#221'8'#245#140'K'#191'T'#13#184'$'#239#223#141#8#228 + +#203'~t5'#20'h'#134'['#251#239#185#210#221#253#191#6'n'#228#167#211#208#207 + +'fQ'#144#204#234#225'bL'#18'~'#16'.'#3#188#233#18'"'#182'C'#174#127#145#168 + +#248'E'#214#30'-'#11'g'#218'-'#171#234'+'#157#190#203#224#167'{'#224#18#192 + +#144'#'#179'I'#194#210#254#2#248'O'#31#23#4#176'|,%'#2'Z'#135#244'@'#177'F'#0 + +'`'#211#186'I*f'#139#236'J'#214#10#132#16#12#9'X"@'#19#18#218#6'y'#212'@'#6 + +' '#2#218#14#133#12'|'#218#151#194#2#206#177#169#16#130#178#128'N'#179' '#154 + +'fQm'#158#16')'#164'!'#19'C'#146#250#181'E'#22#214'r'#195#2'y'#17#247#207#221 + +#219#235#29#248'y2'#242#165#155#252#170'R'#11'0'#253'7'#240#178'E'#236#167 + +#179#200'O'#166'Q'#152#206#226' '#153#214'BZ'#252'd^'#10#31#28#4#188#212#222 + +#235#20']Ro'#178#220#168#19#185'JM'''#30'U'#150#246'('#207#157'J?>'#11'|'#168 + +#251't'#157#135#0#191#0#30'j>&'#221#132'I0E'#6#159#249#172'%'#192'_'#242'K?' + +#188#227#130#0#158'<'#150#18#1'|'#4#237'6'#201#183#217#140';'#20#19#1#160#203 + +#144#169'5h'#201#186'm'#246#141#198#0#243'@i'#13#2#4#2'2`"'#144#133#181#2'!' + +#4#175'B'#8#162#229#235'F'#0'E*'#191#201#243#247#2'"'#129'('#205#252' '#205 + +#149#159#229'~'#0#19'"'#203#184#160')'#160#181#143#207'&'#158#241#233'8'#142 + +#249'x'#15' '#233'{y'#202#139#162'Wy'#10#219#153'g'#142'y'#244#137'~'#158#6#4 + +'N'#218'N#?K0C'#14#127#181#237#249#167#247#204'1}Z'#185#20#11'j'#213#222#145 + +#240#12'B'#237#197#183'q{+'#237'Mi'#174#210#192#159'HW'#158#145'*'#128#15#169 + +#143#184'='#239#147#186#143#10#189'1'#173'!'#241#209#140'snl'#252'G'#143#30 + +'e'#23#192#127#250#184' '#128#163#13'K'#4#223#253#238'w=4%'#5#25#208#161#144 + +#164'N'#212'l6'#1'd'#214#10#232#129'lxz'#174'B'#180'('#3#240#153#4'h'#223#144 + +'C'#211#209#10'jB'#6#136#30'DJG'#16't'#20'A'#19#2#242#10#8#139#220#2'Dr'#130 + +#217'y^'#164#249#225#143#239#219'm'#140#220'sN'#250#224#207#240#14#252'#?' + +#176#225#202#240#138#242' '#249#0'z;/'#210#133'9'#25#152#147'!3'#237'P'#212 + +#21'x'#158#199#217#3'.'#224#233'X"'#221'vy'#150#29#167'@'#7#224#7#152'a'#223 + +#143' '#229#165' '#135#215't|'#4#208'C'#210#3#244#240#230'c!'#2'^'#192#171'O' + +#199#211#11#224'?'#219#184' '#128'g'#27'%"@'#212#224#210#165'K>I'#164#144#30 + +'D&'#3#180''''#4#168#145'a'#8'2'#192#2'2P'#152#202#220'Y'#132#8#140'i'#192 + +#230#1'k'#5#30';'#14']B`2'#160'c'#1'b'#8#162#29'0'#17#152#22' '#24'y'#145#223 + +#167'r'#183#11'`'#165#17#192#129'y'#9#151#254'J'#227#225'We'#253'_)'#227#164 + +#211'h'#215'L$'#130']'#25#231#157#150#242#136#238#231'6Vo='#248#6#240'R'#142 + +'k'#194'x'#0#255'd'#137#212#231'E'#18'vX'#189#23#21#127#14#208'c'#166']'#196 + +#241'WVV2x'#245#137#148#243#11#224'?'#219#184' '#128#247'7l^-'#194#135#244#16 + +'z'#198'<'#160#135#18#128'E'#143'B6'#17#224'/'#160'}'#16'B'#131#164#22#8#129 + ,'5'#0#172'}'#157'Q'#216#144'F'#165'L'#4'R'#177#200#239#177'D'#160#29#136#161 + +#199'A}'#144#129'v '#210#182#246#31'(]'#151' '#219#170#152'}'#132#165's'#209 + +'4'#200#156#244'!, '#160'Vy^v'#3'j'#183#164'W'#184#253#10'U>7'#157't'#217#129 + +''''#222'{'#165#165#188#5#190'S'#127#207'^|'#165#165'=/p'#236#161#209#6#253 + +'~'#168#243#19#172'%'#166'?!'#160'c'#31#196'0C=>'#169#247' '#142#132#142'!y' + +#7#128#207#156'8'#190#156#253#5#232#159'e\'#16#192#7#27#150#8#240#0#186'Z'#1 + +'I'#168'`gg'#7'R;'#132#137#0#243#20'd'#0'p'#139#218'_'#23#240'#'#215#192#128 + +#159'5'#2'G30D`4'#3#215'g`'#9'Ai'#13#1'$'#16'pI?'#231#28's'#242#156'''`'#247 + +#12#17'('#19';8D'#19'p'#192#207#0'/'#8'AK~'#165'{'#230#27#213'>'#173#0#222 + +#196#233#141#138'o'#156'y'#0#191#241#228'O'#5#220'v'#27#199#1'~'#243#127#168 + +#245'x}'#20'Es'#0#31#210#30#234'='#17'jz'#227#198#141#20#160#135#180'w'#242 + +#245#249'|O'#251'a8'#143#227#130#0#158#223'8'#160#21#12#6#3#175#211#233#4#180 + +#248#244#0#179#153#0'I'#14'S'#129#30#234#152#30'n'#164#31'C'#202#215#232'X' + +#141#142#25'S'#192#152#5#150#4#232#189#186'eY'#161#21#132'UBP'#154#20'x'#246 + +'$!'#4#156#147'/'#224#247'DK'#176#219#149#243#182#170#188'2'#210#221#181#225 + +'s''>/'#210']z'#234#25#208'/'#28#208'W'#213'|+'#245'E'#221#231#181#144#194#12 + +'*=IwH'#249#5'@O@_'#200'g&'#0'=T|c'#219#11#232#205'y'#186#235#139#241'>'#198 + +#5#1#28#207'Xj"'#208#218#7#25'@3'#160#7#157'M'#5','#4'nL'#127#142#233#206'"' + +#151#16'|'#157'?`4'#6#248#22'P'#189#24#11#17'D'#134#16'@*'#244#186'RD'#1'D@' + +#175'E'#196#194#19'2`"'#192#182#28#243#212#146'x`'#201#142'/'#0#159#27#21'_' + +#21'j=7'#212#196'B'#223#195#192#167#207#157#211#246#1#2#192'B'#191'k'#230#2 + +#158#200#14#210#29#239'Y@'#194#131'H'#232'xj$'#189#1'=]'#175#188#162#226#187 + +#235#139#241#1#199#5#1#28#239#176#215#215'8'#14#141'f'#0'3aoo'#143#9'!@i'#218 + +'`'#16#192'l'#160#151#134' '#3#172'A'#8' '#7':'#206'k'#128#158'^'#202'k9'#30 + +#154#227'J'#252#4#202'1'#13#180'I'#192'f'#128'oH'#0#231#148'!.X'#144'@q'#178 + +#5#208'sQ'#237'-'#240#177#166#247'X'#201#175#196#161''''#4#176'0'#251#134#0 + +'d!<'''#6#228#144#236#176#223#23'Fk'#0#224#137#3#210#181#181#181#148'~?'#212 + +#250#140'L'#168#28#160#191'p'#232#157#204#184' '#128#147#27#165'D\'#233'Y' + +#168'@'#8#208#12'n'#222#188#233'-#'#4#12#2'M '#160#14#5#212'au'#219#172#149 + +'&'#14#214#0'0'#0'v'#1'k6'#155#217't:'#205#232#156#243'e'#18'~'#9#224#171#219#23#227#152 + +#199#5#1#156#141'Q'#186#15#198'\'#192#182'1'#25#8'H'#30'H'#129'H'#192'#py' + +#134#24#8#148#30#200#129#128#232#25'r'#160'}'#143'@j'#23':'#206#128#199'6>' + +#19#219#4'V'#187#141#181#207#253'L'#148'"'#0#27#192#243'>}/o'#155#133#190'?' + +#7#208#137'Dr'#128#156#190'+'#235#247#251'9'#129#222#2#29#146#189#221'n'#231 + +#6#236#248#156#11#192#159#205'qA'#0'gsT'#239#139''''#192'Q.1`'#13'r'#184'u' + +#235#150'7'#28#14'-9'#224'8'#8#2'k'#179'O'#192#230'5'#8#3#235#245#245'u'#187 + +'m'#6#128#140'5Iy'#11'J'#2';o'#3#220'X?~'#252'8'#199'6@'#142#253'e@'#199#250 + +#16#176'/'#219#191#24#167'8.'#8#224'|'#141'e'#247#235#0'9`'#24#130'0'#3'D' + +#177#236#3#161'Y`]'#175#215#15#0#211#128#218#29#6#224#24#0'9'#214#135#0#253 + +#176'c'#23#227#12#141#11#2'x1'#198#179#220#199#163#190#246#168#224#189#0#249 + +'9'#30#23#4'p1.'#198#135'x'#252#127'p'#251'ut'#3#215#244'"'#0#0#0#0'IEND'#174 + +'B`'#130'('#0#0#0#128#0#0#0#0#1#0#0#1#0' '#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#1#0#0#0#1#0#0#0#1#0#0#0#1#0#0#0#1#0#0#0#1#0#0#0#1#0#0 + +#0#1#0#0#0#1#0#0#0#1#0#0#0#1#0#0#0#1#0#0#0#1#0#0#0#1#0#0#0#1#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + ,#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#1#0#0#0#1#0#0#0#2#128#128#128#2'UUU'#3'@@@'#4'333'#5'III'#7'@@@'#8 + +'999'#9'999'#9'MMM'#10'FFF'#11'FFF'#11'FFF'#11'MMM'#10'999'#9'@@@'#8'@@@'#8 + +'UUU'#6'333'#5'UUU'#3#128#128#128#2#0#0#0#2#0#0#0#1#0#0#0#1#0#0#0#1#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#1#0#0#0#1#128#128#128#2'UUU'#3'UUU'#6'@@@'#8'FFF'#11'III'#14'<<' + +'<'#17'III'#21'EEE'#26'DDD'#30'DDD"EEE%AAA''DDD)AAA+AAA+AAA+DDD)AAA''GGG$FFF' + +'!DDD'#30'==='#25'@@@'#20'@@@'#16';;;'#13'FFF'#11'@@@'#8'333'#5'UUU'#3#128 + +#128#128#2#0#0#0#1#0#0#0#1#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#1#0#0#0 + +#2'UUU'#3'+++'#6'999'#9'NNN'#13'CCC'#19'BBB'#27'GGG$DDD-CCC5DDD'#211'SC6'#219'W@0'#227'[>+'#235']<('#238'^<'''#240 + +'_<%'#243'`<#'#245'a;"'#247'a:!'#248'a;"'#246'`<$'#245'_<%'#242'^='''#240'\=' + +')'#237'Z=,'#233'V@1'#225'RD8'#217'NG?'#210'JHD'#204'IHC'#204'HHD'#204'GEC' + +#203'FEC'#202'EED'#198'EED'#195'DDC'#190'DDC'#183'DDD'#172'DDD'#157'DDD'#138 + +'DDDtCCC\DDDDCCC.@@@'#28'DDD'#15'III'#7'UUU'#3#0#0#0#1#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#1'UUU'#3'@@' + +'@'#8'KKK'#17'HHH CCC5CCCPDDDlCCC'#134'DDC'#156'EED'#172'FEC'#185'GFD'#193'G' + +'FC'#198'HFC'#202'IGD'#203'PE;'#213'VA0'#227']<('#239'a;#'#246'd9'#30#254'g:' + +#29#255'g:'#30#255'i<'#30#255'j='#31#255'j>'#30#255'k>'#30#255'l?'#31#255'l@' + +#31#255'mA'#31#255'nA'#31#255'm@'#31#255'l@'#31#255'l?'#31#255'k>'#30#255'j>' + +#30#255'j='#31#255'i<'#30#255'g:'#30#255'f:'#29#255'd9'#31#252'`<#'#245'[=*' + +#236'UA3'#223'MF?'#210'IHC'#204'HFD'#204'FFC'#203'FFE'#200'DDC'#197'EED'#191 + +'DCC'#182'DDD'#170'CCC'#152'CCC'#129'DDDfDDDKDDD1FFF'#29'@@@'#16'III'#7'UUU' + +#3#0#0#0#1#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#1'UUU'#3'II' + +'I'#7'@@@'#16'@@@ FFF7DDDRCCCoCCC'#140'DDC'#163'EED'#180'EED'#191'FFC'#198'I' + +'GD'#201'ME?'#208'UA2'#224'\<('#238'b9 '#250'f:'#29#255'h;'#30#255'j>'#30#255 + +'m@'#31#255'oB '#255'qD '#255'sF '#255'uH!'#255'|L#'#255#128'O$'#255#133'Q%' + +#255#136'S&'#255#139'V'''#255#143'X('#255#145'Y)'#255#142'W('#255#139'U''' + +#255#135'S&'#255#131'Q%'#255#128'O$'#255'yK"'#255'tG!'#255'rE '#255'pD '#255 + +'nA '#255'l@'#31#255'j='#31#255'g;'#30#255'e9'#29#255'a;!'#247'Z=+'#234'RB5' + +#221'JGC'#207'HFD'#204'FEC'#203'FFE'#200'EED'#196'DDC'#189'DDD'#177'CCC'#159 + +'DDD'#135'CCCjBBBMBBB2FFF'#29'III'#14'UUU'#6#128#128#128#2#0#0#0#1#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#2'333'#5';;;'#13'BBB'#27'AAA3BBBQDDDqDDD'#142'EED'#165 + +'EDB'#183'FEC'#194'HFD'#200'IFB'#205'SA3'#223'^;&'#242'e8'#29#255'g;'#30#255 + +'j>'#31#255'mA'#31#255'pD!'#255'tG!'#255'~M#'#255#141'W('#255#151']*'#255#160 + +'c-'#255#169'i0'#255#178'n1'#255#181'q2'#255#182's3'#255#183't3'#255#184't3' + +#255#184'v3'#255#185'v4'#255#186'w3'#255#185'v3'#255#184'u3'#255#184't3'#255 + +#183't3'#255#182'r3'#255#181'q2'#255#175'l1'#255#166'h/'#255#158'a,'#255#149 + ,'\*'#255#138'U('#255'zK"'#255'sF '#255'pC '#255'l@'#31#255'i='#31#255'g;'#30 + +#255'c8'#31#252'[<*'#237'RC8'#218'IGD'#205'HFD'#204'EED'#201'DDC'#198'EED' + +#191'DDD'#179'CCC'#161'DDD'#136'CCCkEEEJDDD-@@@'#24'FFF'#11'@@@'#4#0#0#0#1#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#1'UUU'#3'999'#9'FFF'#22'CCC*DDDGDDDiCCC'#138'EED'#165'FEC'#184'FEC'#194 + +'HHD'#200'QC9'#216'[<*'#237'c8'#31#253'g;'#30#255'j>'#31#255'nA '#255'sF!' + +#255'|M#'#255#141'W('#255#158'a,'#255#173'k1'#255#181'r3'#255#185'v4'#255#187 + +'y4'#255#189'{4'#255#191'~5'#255#193#129'5'#255#195#131'5'#255#196#132'6'#255 + +#197#134'6'#255#198#134'6'#255#199#136'6'#255#200#136'6'#255#200#137'6'#255 + +#199#136'6'#255#198#135'6'#255#198#134'6'#255#197#133'5'#255#196#132'6'#255 + +#195#131'5'#255#193#128'5'#255#191'~4'#255#188'z4'#255#186'x4'#255#184'u3' + +#255#181'q2'#255#168'i/'#255#153'_+'#255#137'T'''#255'yJ"'#255'rE '#255'm@' + +#31#255'i<'#31#255'f:'#30#255'b9!'#249'X>.'#232'MD>'#212'HFD'#204'EED'#202'E' + +'ED'#198'EED'#192'CCC'#180'CCC'#160'DDD'#132'DDDbCCCACCC&CCC'#19'@@@'#8'UUU' + +#3#0#0#0#1#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#1'333'#5 + +'III'#14'>>>!DDD'#255 + +#232#177'>'#255#234#179'?'#255#236#181'>'#255#236#182'?'#255#237#183'?'#255 + ,#237#183'?'#255#238#183'@'#255#238#184'?'#255#238#185'?'#255#238#184'?'#255 + +#238#183'@'#255#237#182'?'#255#237#183'?'#255#236#182'?'#255#236#181'>'#255 + +#234#179'>'#255#232#176'>'#255#230#175'>'#255#229#172'='#255#227#169'='#255 + +#224#167'='#255#220#161'<'#255#217#157'<'#255#213#153';'#255#209#148':'#255 + +#204#142'9'#255#198#135'8'#255#193#129'7'#255#188'{6'#255#183't5'#255#171'k2' + +#255#142'W)'#255'tH"'#255'nA '#255'h<'#31#255'd7'#30#255'[:('#240'KD?'#211'G' + +'FD'#204'DDC'#201'EDD'#195'CCC'#182'CCC'#159'CCC}EEEUBBB2@@@'#24'999'#9'UUU' + +#3#0#0#0#1#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#1'333'#5'III'#14'BBB#EEECCCCkEEE'#145'DDC'#174'FFE'#192'KE@'#206'Z;)' + +#238'c8'#30#255'i<'#31#255'oB!'#255'|M%'#255#153'_-'#255#178'o4'#255#186'x6' + +#255#192#128'7'#255#198#135'9'#255#204#142':'#255#209#149';'#255#214#155'=' + +#255#219#161'>'#255#223#167'>'#255#227#170'>'#255#230#174'?'#255#232#177'@' + +#255#235#181'A'#255#237#183'A'#255#238#185'A'#255#240#187'A'#255#241#188'A' + +#255#242#189'B'#255#243#190'A'#255#244#191'B'#255#244#192'B'#255#244#191'B' + +#255#244#192'B'#255#244#192'B'#255#245#193'A'#255#244#192'B'#255#244#192'B' + +#255#244#191'B'#255#244#192'B'#255#244#191'B'#255#243#190'A'#255#242#189'B' + +#255#240#187'A'#255#239#186'A'#255#238#184'@'#255#237#183'A'#255#235#179'@' + +#255#232#176'?'#255#229#173'?'#255#226#169'?'#255#223#165'>'#255#218#160'=' + +#255#213#153'<'#255#208#147';'#255#202#140':'#255#196#133'9'#255#190'~7'#255 + +#184'v6'#255#173'l3'#255#145'Y+'#255'uH$'#255'm@ '#255'g;'#31#255'b7'#31#253 + +'U>/'#230'IEC'#206'FFE'#202'EED'#199'CCC'#189'DDD'#170'DDD'#139'BBBdCCC=BBB' + +#31'@@@'#12'UUU'#3#0#0#0#1#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#1'UUU'#6'KKK'#17'DDD)EEENDDDxDCC'#157'DDC'#182'GGC'#197'T=1'#225'a7 ' + +#252'g;'#31#255'l@ '#255'wI$'#255#154'^.'#255#179'o6'#255#186'x7'#255#193#128 + +'9'#255#200#137':'#255#207#146'<'#255#212#153'>'#255#217#159'>'#255#222#166 + +'?'#255#227#170'@'#255#231#175'A'#255#234#180'B'#255#236#182'B'#255#238#185 + +'B'#255#240#187'B'#255#242#190'D'#255#243#191'C'#255#244#192'D'#255#245#193 + +'C'#255#246#194'D'#255#247#194'D'#255#247#196'E'#255#247#196'D'#255#247#196 + +'D'#255#248#197'D'#255#248#197'D'#255#248#197'D'#255#248#197'D'#255#248#197 + +'D'#255#248#197'D'#255#248#196'D'#255#247#196'D'#255#247#196'D'#255#247#195 + +'E'#255#246#195'D'#255#245#193'D'#255#245#193'C'#255#244#192'D'#255#243#191 + +'C'#255#242#189'C'#255#240#186'C'#255#238#184'C'#255#236#182'B'#255#233#179 + +'B'#255#230#174'A'#255#226#169'@'#255#221#164'?'#255#216#157'>'#255#211#151 + +'='#255#205#143'<'#255#198#135':'#255#191#127'8'#255#184'w7'#255#174'l4'#255 + +#144'X+'#255'rE"'#255'j> '#255'e9'#30#255'_8"'#247'O@8'#219'GFD'#204'DDC'#201 + +'CCC'#194'CCC'#178'DDD'#151'DDDqDDDGGGG$III'#14'@@@'#4#0#0#0#1#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#2'III'#7'@@@'#20'CCC.DDDVCCC'#130'EED'#165'DDC'#189 + +'LB='#207']7$'#244'd7'#31#255'j> '#255'qE"'#255#140'W+'#255#174'l5'#255#186 + +'x8'#255#193#129':'#255#200#138'<'#255#207#146'>'#255#213#155'?'#255#220#163 + +'@'#255#225#169'A'#255#229#174'B'#255#233#179'D'#255#236#182'D'#255#239#185 + +'D'#255#241#189'E'#255#242#190'E'#255#244#192'E'#255#245#194'E'#255#246#195 + +'F'#255#247#195'F'#255#247#196'G'#255#247#197'F'#255#248#197'F'#255#248#197 + +'F'#255#249#198'F'#255#249#198'G'#255#249#198'G'#255#249#198'G'#255#249#198 + +'G'#255#249#198'G'#255#249#198'G'#255#249#198'G'#255#249#198'G'#255#249#198 + +'G'#255#249#198'G'#255#249#198'G'#255#249#198'F'#255#248#197'F'#255#248#197 + +'F'#255#247#196'F'#255#247#196'F'#255#247#195'F'#255#246#194'F'#255#244#193 + +'F'#255#243#191'E'#255#242#190'E'#255#240#188'E'#255#238#185'D'#255#235#181 + +'D'#255#232#178'C'#255#228#172'C'#255#223#167'B'#255#218#161'@'#255#212#153 + +'?'#255#205#144'='#255#198#135';'#255#191#127'9'#255#183'u7'#255#167'g3'#255 + +#130'P('#255'oB"'#255'h< '#255'c7'#30#255'X:*'#237'HFB'#207'EEE'#202'DCC'#197 + +'DDD'#184'CCC'#160'CCCzEEENFFF(@@@'#16'333'#5#0#0#0#1#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + ,#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#2 + +'III'#7'FFF'#22'BBB2CCC\DDD'#136'DDC'#171'EED'#192'Q?5'#219'a6'#31#252'f:'#31 + +#255'mA!'#255#127'N'''#255#164'f3'#255#182'u8'#255#190#127':'#255#199#138'=' + +#255#207#147'?'#255#213#155'A'#255#220#163'B'#255#225#170'D'#255#230#177'E' + +#255#234#181'E'#255#237#184'F'#255#240#188'G'#255#242#189'G'#255#243#192'G' + +#255#244#193'H'#255#245#194'H'#255#246#195'H'#255#247#196'H'#255#247#197'H' + +#255#247#197'H'#255#248#198'H'#255#248#198'H'#255#248#197'H'#255#248#198'H' + +#255#248#198'I'#255#249#198'I'#255#249#198'I'#255#249#198'I'#255#249#198'I' + +#255#249#198'I'#255#249#198'I'#255#249#198'I'#255#249#198'I'#255#249#198'I' + +#255#249#198'I'#255#249#198'I'#255#248#198'I'#255#248#198'H'#255#248#198'H' + +#255#248#198'H'#255#248#198'H'#255#247#197'H'#255#247#196'I'#255#247#195'H' + +#255#246#195'H'#255#245#195'H'#255#244#193'H'#255#243#191'G'#255#241#189'G' + +#255#239#186'G'#255#236#183'F'#255#233#180'F'#255#229#175'D'#255#224#168'D' + +#255#218#161'B'#255#211#153'@'#255#205#144'?'#255#196#134'='#255#188'{:'#255 + +#180'r8'#255#155'_/'#255'wJ$'#255'j? '#255'e8'#30#255']8#'#246'LB<'#213'FEE' + +#203'EED'#199'DDD'#188'DDD'#165'DDD'#128'DDDSFFF,GGG'#18'+++'#6#0#0#0#1#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#2'III'#7'CCC'#23'BBB6DDDaCCC'#141'DDC'#174'GDB'#196'V:+'#233'c7'#30#255'h; ' + +#255'pC#'#255#146'Z-'#255#179'p7'#255#187'{;'#255#196#133'='#255#204#144'?' + +#255#212#154'B'#255#219#163'E'#255#225#170'E'#255#230#176'G'#255#234#181'H' + +#255#238#185'I'#255#240#189'I'#255#242#190'J'#255#243#192'J'#255#244#193'J' + +#255#245#195'J'#255#246#195'J'#255#246#196'J'#255#247#196'K'#255#247#196'K' + +#255#247#197'K'#255#247#197'K'#255#247#197'K'#255#247#197'J'#255#247#197'J' + +#255#247#198'J'#255#247#198'J'#255#247#198'J'#255#247#198'J'#255#247#198'J' + +#255#247#198'J'#255#247#198'J'#255#247#198'J'#255#247#198'J'#255#247#198'J' + +#255#247#198'J'#255#247#198'J'#255#247#198'J'#255#247#198'J'#255#247#197'J' + +#255#247#197'J'#255#247#197'J'#255#247#197'K'#255#247#197'K'#255#247#197'K' + +#255#247#196'K'#255#246#196'K'#255#246#196'J'#255#246#195'J'#255#245#195'J' + +#255#244#194'J'#255#243#191'I'#255#241#189'I'#255#239#188'I'#255#236#184'H' + +#255#233#180'H'#255#228#174'G'#255#223#168'E'#255#217#160'C'#255#210#151'B' + +#255#202#141'?'#255#193#130'<'#255#185'x:'#255#174'm6'#255#134'S*'#255'mA"' + +#255'f:'#31#255'a6'#30#253'R>4'#224'FFE'#203'EED'#200'CCC'#190'DDD'#169'CCC' + +#133'CCCXAAA/CCC'#19'+++'#6#0#0#0#1#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#1'III'#7'CCC'#23'BBB6CCCcCCC'#144'EED'#177'JC>'#202 + +'[6"'#244'c8'#31#255'j?!'#255'xI&'#255#162'd2'#255#183'u:'#255#192#129'='#255 + +#200#140'@'#255#209#150'B'#255#217#160'E'#255#223#169'G'#255#229#176'H'#255 + +#233#181'J'#255#236#185'J'#255#239#188'K'#255#241#190'K'#255#242#192'K'#255 + +#243#193'L'#255#244#194'L'#255#245#195'L'#255#245#195'L'#255#245#195'L'#255 + +#246#196'L'#255#246#196'L'#255#246#196'L'#255#246#196'L'#255#246#196'M'#255 + +#246#196'M'#255#246#197'M'#255#246#197'M'#255#246#197'M'#255#246#197'M'#255 + +#246#197'M'#255#246#197'M'#255#246#197'M'#255#246#197'M'#255#246#197'M'#255 + +#246#197'M'#255#246#197'M'#255#246#197'M'#255#246#197'M'#255#246#197'M'#255 + +#246#197'M'#255#246#197'M'#255#246#197'M'#255#246#197'M'#255#246#196'M'#255 + +#246#196'M'#255#246#196'M'#255#246#196'L'#255#246#196'L'#255#246#196'L'#255 + +#246#196'L'#255#245#195'L'#255#245#196'L'#255#244#195'M'#255#244#194'L'#255 + +#243#193'L'#255#242#192'L'#255#241#190'K'#255#238#188'K'#255#236#184'J'#255 + +#232#179'I'#255#228#173'H'#255#222#166'F'#255#215#158'E'#255#207#148'B'#255 + +#198#137'?'#255#190'~<'#255#180'r9'#255#150']/'#255'qE$'#255'h< '#255'b6'#30 + +#255'W9*'#235'GED'#204'DDC'#201'DDD'#192'CCC'#172'CCC'#137'DDDZAAA/GGG'#18'3' + +'33'#5#0#0#0#1#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#1'+++'#6'II' + +'I'#21'CCC5DDDbCCC'#145'DDC'#178'LB;'#206'^6 '#249'd8'#31#255'l@!'#255#131'Q' + +'*'#255#172'k7'#255#186'z;'#255#196#133'?'#255#205#146'C'#255#213#156'E'#255 + +#220#165'G'#255#227#173'I'#255#232#180'K'#255#236#184'L'#255#238#187'L'#255 + ,#240#189'N'#255#241#191'N'#255#242#192'N'#255#243#193'N'#255#244#194'N'#255 + +#244#194'N'#255#244#194'O'#255#244#195'O'#255#244#195'O'#255#244#195'O'#255 + +#244#195'O'#255#244#195'O'#255#244#195'O'#255#244#195'O'#255#244#195'O'#255 + +#244#195'O'#255#244#195'O'#255#244#195'O'#255#244#195'O'#255#244#195'O'#255 + +#244#195'O'#255#244#195'O'#255#244#195'O'#255#244#195'O'#255#244#195'O'#255 + +#244#195'O'#255#244#195'O'#255#244#195'O'#255#244#195'O'#255#244#195'O'#255 + +#244#195'O'#255#244#195'O'#255#244#195'O'#255#244#195'O'#255#244#195'O'#255 + +#244#195'O'#255#244#195'O'#255#244#195'O'#255#244#195'O'#255#244#195'O'#255 + +#244#195'O'#255#244#195'O'#255#244#194'O'#255#244#195'N'#255#244#194'N'#255 + +#243#193'N'#255#242#192'M'#255#241#190'N'#255#240#189'M'#255#237#186'M'#255 + +#235#182'L'#255#230#178'K'#255#225#171'I'#255#219#163'G'#255#211#153'D'#255 + +#202#143'B'#255#192#130'>'#255#183'u:'#255#164'f4'#255'yK&'#255'i=!'#255'c7' + +#30#255'Z8%'#241'GEC'#205'DDC'#201'CCC'#193'DDD'#173'DDD'#136'BBBYDDD-KKK'#17 + +'333'#5#0#0#0#1#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#1'333'#5'CCC'#19'BBB2CCC_DD' + +'D'#143'DDC'#178'M@8'#211'_5'#31#251'e9'#31#255'lA"'#255#144'Y/'#255#179'r9' + +#255#188'}='#255#198#138'B'#255#208#149'D'#255#217#161'H'#255#223#170'K'#255 + +#229#177'L'#255#234#181'M'#255#236#186'N'#255#239#188'O'#255#240#190'P'#255 + +#241#191'P'#255#242#192'P'#255#242#192'P'#255#242#193'P'#255#243#193'P'#255 + +#243#194'P'#255#243#194'P'#255#243#194'P'#255#243#194'P'#255#243#194'P'#255 + +#243#194'P'#255#243#194'P'#255#243#194'P'#255#243#194'P'#255#243#194'P'#255 + +#243#194'P'#255#243#194'P'#255#243#194'P'#255#243#194'P'#255#243#194'P'#255 + +#243#194'P'#255#243#194'P'#255#243#194'P'#255#243#194'P'#255#243#194'P'#255 + +#243#194'P'#255#243#194'P'#255#243#194'P'#255#243#194'P'#255#243#194'P'#255 + +#243#194'P'#255#243#194'P'#255#243#194'P'#255#243#194'P'#255#243#194'P'#255 + +#243#194'P'#255#243#194'P'#255#243#194'P'#255#243#194'P'#255#243#194'P'#255 + +#243#194'P'#255#243#194'P'#255#243#194'P'#255#243#194'P'#255#243#193'P'#255 + +#242#193'P'#255#242#192'O'#255#242#192'P'#255#241#192'P'#255#240#190'P'#255 + +#238#188'O'#255#236#185'N'#255#232#180'M'#255#228#175'L'#255#222#167'I'#255 + +#215#159'H'#255#205#147'D'#255#196#134'@'#255#186'y<'#255#173'm7'#255#130'O*' + +#255'j?!'#255'c8'#31#255'[7#'#245'HDA'#208'DDC'#201'CCC'#193'CCC'#172'CCC' + +#134'AAAVAAA+@@@'#16'@@@'#4#0#0#0#1#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#1'@@@'#4'<<<'#17'CCC.CC' + +'C[CCC'#140'EED'#176'O>5'#213'_5'#30#253'e9'#31#255'nB#'#255#151'\1'#255#181 + +'s:'#255#191#129'@'#255#201#142'C'#255#211#154'G'#255#219#164'K'#255#226#173 + +'M'#255#231#179'O'#255#234#184'P'#255#237#187'Q'#255#239#189'Q'#255#240#190 + +'R'#255#240#191'Q'#255#241#192'R'#255#241#192'R'#255#241#192'R'#255#242#192 + +'R'#255#242#192'R'#255#242#193'R'#255#242#193'R'#255#242#193'R'#255#242#193 + +'R'#255#242#193'R'#255#242#193'R'#255#242#193'R'#255#242#193'R'#255#242#193 + +'R'#255#242#193'R'#255#242#193'R'#255#242#193'R'#255#242#193'R'#255#242#193 + +'R'#255#242#193'R'#255#242#193'R'#255#242#193'R'#255#242#193'R'#255#242#193 + +'R'#255#242#193'R'#255#242#193'R'#255#242#193'R'#255#242#193'R'#255#242#193 + +'R'#255#242#193'R'#255#242#193'R'#255#242#193'R'#255#242#193'R'#255#242#193 + +'R'#255#242#193'R'#255#242#193'R'#255#242#193'R'#255#242#193'R'#255#242#193 + +'R'#255#242#193'R'#255#242#193'R'#255#242#193'R'#255#242#193'R'#255#242#193 + +'R'#255#242#192'R'#255#242#192'R'#255#241#192'R'#255#241#192'R'#255#241#192 + +'R'#255#240#191'Q'#255#240#190'R'#255#238#189'Q'#255#236#186'P'#255#234#182 + +'O'#255#230#177'N'#255#224#171'L'#255#217#162'J'#255#208#150'F'#255#198#138 + +'C'#255#188'}>'#255#177'o:'#255#136'S,'#255'k?"'#255'c8'#31#255'\6!'#248'JC?' + +#211'DCC'#201'CCC'#193'CCC'#171'BBB'#131'DDDRAAA''777'#14'UUU'#3#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +'UUU'#3';;;'#13'AAA''CCCTBBB'#135'DDC'#174'N=5'#213'`4'#29#254'e9'#31#255'oC' + +'$'#255#156'`3'#255#181'u<'#255#193#131'A'#255#204#146'E'#255#213#157'I'#255 + +#221#167'M'#255#227#175'O'#255#232#180'Q'#255#235#184'R'#255#237#187'S'#255 + +#238#189'S'#255#239#190'S'#255#240#191'T'#255#240#191'T'#255#240#191'T'#255 + +#240#191'T'#255#240#191'T'#255#240#191'T'#255#240#191'T'#255#240#191'T'#255 + +#240#191'T'#255#240#191'T'#255#240#191'T'#255#240#191'T'#255#240#191'T'#255 + +#240#191'T'#255#240#191'T'#255#240#191'T'#255#240#191'T'#255#240#191'T'#255 + ,#240#191'T'#255#240#191'T'#255#240#191'T'#255#240#191'T'#255#240#191'T'#255 + +#234#187'R'#255#202#161'G'#255#232#185'R'#255#240#191'T'#255#240#191'T'#255 + +#240#191'T'#255#240#191'T'#255#240#191'T'#255#240#191'T'#255#240#191'T'#255 + +#240#191'T'#255#240#191'T'#255#240#191'T'#255#240#191'T'#255#240#191'T'#255 + +#240#191'T'#255#240#191'T'#255#240#191'T'#255#240#191'T'#255#240#191'T'#255 + +#240#191'T'#255#240#191'T'#255#240#191'T'#255#240#191'T'#255#240#191'T'#255 + +#240#191'T'#255#240#191'T'#255#240#191'T'#255#240#191'T'#255#240#191'T'#255 + +#239#189'S'#255#238#188'R'#255#236#186'R'#255#234#184'Q'#255#231#179'Q'#255 + +#226#173'O'#255#219#165'L'#255#211#154'H'#255#201#142'E'#255#190#128'@'#255 + +#179'q:'#255#140'V.'#255'l@"'#255'c8'#31#255'\4'#31#250'JC>'#211'CCC'#201'DD' + +'D'#192'CCC'#168'CCC~DDDKFFF!MMM'#10#128#128#128#2#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#128#128#128#2'333'#10'@@@ EEE' + +'JCCC~EDD'#169'L?8'#208'^4'#30#253'd8 '#255'pD%'#255#159'b4'#255#182'v='#255 + +#194#132'C'#255#205#147'H'#255#215#160'L'#255#222#169'O'#255#228#176'Q'#255 + +#232#181'S'#255#235#185'T'#255#236#187'T'#255#237#188'U'#255#238#189'U'#255 + +#238#190'U'#255#238#190'U'#255#238#191'U'#255#239#190'U'#255#239#190'U'#255 + +#239#190'U'#255#239#190'U'#255#239#190'U'#255#239#190'U'#255#239#190'U'#255 + +#239#190'U'#255#239#190'U'#255#239#190'U'#255#239#190'U'#255#239#190'U'#255 + +#239#190'U'#255#239#190'U'#255#239#190'U'#255#239#190'U'#255#181#144'@'#255 + +';/'#21#255#21#16#7#255#9#7#3#255#2#2#1#255#0#0#0#255#0#0#0#255#0#0#0#255#1#1 + +#1#255#7#6#3#255#17#14#6#255#31#25#11#255'2'''#18#255'SB'#29#255#157'}8'#255 + +#233#186'S'#255#239#190'U'#255#239#190'U'#255#239#190'U'#255#239#190'U'#255 + +#239#190'U'#255#239#190'U'#255#239#190'U'#255#239#190'U'#255#239#190'U'#255 + +#239#190'U'#255#239#190'U'#255#239#190'U'#255#239#190'U'#255#239#190'U'#255 + +#239#190'U'#255#239#190'U'#255#239#190'U'#255#238#190'U'#255#238#190'U'#255 + +#238#190'U'#255#238#189'U'#255#237#188'U'#255#236#186'T'#255#234#184'T'#255 + +#231#180'S'#255#226#175'Q'#255#220#166'N'#255#212#156'K'#255#202#143'F'#255 + +#190#129'A'#255#179'r<'#255#145'Y0'#255'k?"'#255'c7'#31#255'[4 '#248'IC@'#209 + +'DDD'#200'CCC'#190'CCC'#163'DDDtCCCAEEE'#26'III'#7#0#0#0#1#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#1'III'#7'==='#25'AAA?CCCsBBB' + +#162'K?;'#202'^4'#30#252'c8 '#255'oB%'#255#160'b5'#255#183'v>'#255#194#134'D' + +#255#205#148'J'#255#215#161'M'#255#223#171'Q'#255#228#177'T'#255#232#182'U' + +#255#234#185'V'#255#236#187'V'#255#236#187'V'#255#237#188'W'#255#237#189'W' + +#255#237#188'W'#255#237#188'W'#255#237#188'W'#255#237#188'W'#255#237#188'W' + +#255#237#188'W'#255#237#188'W'#255#237#188'W'#255#237#188'W'#255#237#188'W' + +#255#237#188'W'#255#237#188'W'#255#237#188'W'#255#237#188'W'#255#237#188'W' + +#255#237#188'W'#255#237#188'W'#255#159'~:'#255#16#13#6#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#1#0#0#255#16#13#6 + +#255'9-'#21#255'y`,'#255#208#165'M'#255#237#188'W'#255#237#188'W'#255#237#188 + +'W'#255#237#188'W'#255#237#188'W'#255#237#188'W'#255#237#188'W'#255#237#188 + +'W'#255#237#188'W'#255#237#188'W'#255#237#188'W'#255#237#188'W'#255#237#188 + +'W'#255#237#188'W'#255#237#188'W'#255#237#188'W'#255#237#189'W'#255#237#188 + +'W'#255#236#187'V'#255#235#186'V'#255#234#184'U'#255#231#180'U'#255#227#175 + +'R'#255#221#169'Q'#255#213#157'L'#255#202#144'H'#255#191#129'C'#255#180's=' + +#255#145'X0'#255'j>#'#255'b6'#31#255'Z5#'#245'GDB'#206'DDD'#200'CCC'#186'DDD' + +#154'EEEhBBB6@@@'#20'333'#5#0#0#0#1#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#1'@@@'#4'GGG'#18'AAA3DDDfCCC'#152'IA>'#195'\4 '#250'c7'#31#255'm@#'#255 + +#156'_5'#255#182'v?'#255#194#134'E'#255#206#148'K'#255#215#161'O'#255#223#171 + +'S'#255#228#178'V'#255#232#182'V'#255#233#185'X'#255#234#186'X'#255#235#187 + +'X'#255#236#187'X'#255#236#188'X'#255#236#188'X'#255#236#188'X'#255#236#188 + +'X'#255#236#188'X'#255#236#188'X'#255#236#188'X'#255#236#188'X'#255#236#188 + +'X'#255#236#188'X'#255#236#188'X'#255#236#188'X'#255#236#188'X'#255#236#188 + +'X'#255#236#188'X'#255#236#188'X'#255#236#188'X'#255#236#188'X'#255'9-'#21 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#6 + +#5#2#255'$'#29#14#255'ZH"'#255#169#135'@'#255#234#186'X'#255#236#188'X'#255 + ,#236#188'X'#255#236#188'X'#255#236#188'X'#255#236#188'X'#255#236#188'X'#255 + +#236#188'X'#255#236#188'X'#255#236#188'X'#255#236#188'X'#255#236#188'X'#255 + +#236#188'X'#255#236#187'X'#255#235#187'Y'#255#235#186'X'#255#234#186'X'#255 + +#233#184'W'#255#231#180'W'#255#227#176'T'#255#221#169'R'#255#213#158'N'#255 + +#203#145'J'#255#192#130'D'#255#179's='#255#139'U/'#255'i="'#255'a5'#30#255'X' + +'7%'#242'FDC'#204'CCC'#198'DDD'#180'CCC'#144'CCC[AAA+III'#14'UUU'#3#0#0#0#1#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#128#128#128#2'@@@'#12'AAA''CCCWCCC'#140'GB?' + +#185'Z4!'#247'a6'#30#255'j?"'#255#151']2'#255#181't>'#255#194#133'F'#255#206 + +#149'M'#255#215#161'Q'#255#223#170'T'#255#228#178'W'#255#231#181'Y'#255#232 + +#183'Y'#255#233#185'Z'#255#234#185'Y'#255#234#186'Y'#255#234#186'Y'#255#234 + +#186'Z'#255#234#186'Z'#255#234#186'Z'#255#234#186'Z'#255#234#186'Z'#255#234 + +#186'Z'#255#234#186'Z'#255#234#186'Z'#255#234#186'Z'#255#234#186'Z'#255#234 + +#186'Z'#255#234#186'Z'#255#234#186'Z'#255#234#186'Z'#255#234#186'Z'#255#234 + +#186'Z'#255#234#186'Z'#255'C5'#26#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255 + +#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#1#1#1#255#20#16#8#255'K;'#29#255#189#150'I'#255#234#186'Z'#255#234#186 + +'Z'#255#234#186'Z'#255#234#186'Z'#255#234#186'Z'#255#234#186'Z'#255#234#186 + +'Z'#255#234#186'Z'#255#234#186'Z'#255#234#186'Z'#255#234#186'Y'#255#234#186 + +'Y'#255#234#185'Y'#255#233#185'Z'#255#232#183'Y'#255#230#181'X'#255#226#176 + +'W'#255#221#169'T'#255#213#159'O'#255#203#145'K'#255#190#129'D'#255#178'p=' + +#255#134'Q-'#255'g;"'#255'`4'#29#255'U7('#238'CCC'#202'DDD'#195'DDD'#173'BBB' + +#131'CCCL@@@ 999'#9#0#0#0#2#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#1'III'#7'BBB'#27'CC' + +'CEDDD|DDD'#170'V6%'#238'`5'#30#255'h<"'#255#145'Y1'#255#179's?'#255#192#132 + +'F'#255#205#148'M'#255#215#161'R'#255#222#171'U'#255#227#176'X'#255#230#181 + +'Z'#255#231#183'Z'#255#232#183'['#255#232#184'['#255#233#185'['#255#233#185 + +'['#255#233#185'['#255#233#185'['#255#233#185'['#255#233#185'['#255#233#185 + +'['#255#233#185'['#255#233#185'['#255#233#185'['#255#233#185'['#255#233#185 + +'['#255#233#185'['#255#233#185'['#255#233#185'['#255#233#185'['#255#233#185 + +'['#255#233#185'['#255#233#185'['#255#127'd1'#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#13#11#5 + +#255'N>'#31#255#193#153'L'#255#233#185'['#255#233#185'['#255#233#185'['#255 + +#233#185'['#255#233#185'['#255#233#185'['#255#233#185'['#255#233#185'['#255 + +#233#185'['#255#233#184'['#255#232#184'['#255#232#183'Z'#255#231#182'Z'#255 + +#229#180'Y'#255#226#175'X'#255#220#168'U'#255#213#158'R'#255#201#144'K'#255 + +#189#127'D'#255#175'n<'#255#128'N+'#255'e9 '#255'_3'#29#255'Q;1'#227'CCC'#201 + +'CCC'#191'CCC'#163'CCCrAAA;FFF'#22'333'#5#0#0#0#1#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#1'@@@'#4'<<<' + +#17'AAA3EEEhCCC'#156'R:/'#220'_3'#29#255'e: '#255#134'Q-'#255#178'p>'#255#190 + +#130'F'#255#203#145'M'#255#213#161'S'#255#221#170'W'#255#226#176'Z'#255#229 + +#180'Z'#255#230#182'\'#255#231#182'\'#255#231#183'\'#255#231#183'\'#255#231 + +#183'\'#255#231#183'\'#255#231#183'\'#255#231#183'\'#255#231#183'\'#255#231 + +#183'\'#255#231#183'\'#255#231#183'\'#255#231#183'\'#255#231#183'\'#255#231 + +#183'\'#255#231#183'\'#255#231#183'\'#255#231#183'\'#255#231#183'\'#255#231 + +#183'\'#255#231#183'\'#255#231#183'\'#255#180#142'G'#255#1#1#1#255#0#0#0#255 + +#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#15#12#6#255'VE"'#255#215#171'V'#255 + +#231#183'\'#255#231#183'\'#255#231#183'\'#255#231#183'\'#255#231#183'\'#255 + +#231#183'\'#255#231#183'\'#255#231#183'\'#255#231#183'\'#255#231#182'\'#255 + +#230#181'['#255#228#178'['#255#225#175'Y'#255#219#168'W'#255#211#156'Q'#255 + +#200#142'K'#255#187'|D'#255#172'k<'#255'wF('#255'c7 '#255'^1'#30#254'K@:'#214 + +'DDD'#199'CCC'#184'CCC'#148'AAA^GGG+NNN'#13'UUU'#3#0#0#0#0#0#0#0#0#0#0#0#0#0 + ,#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#2'MMM'#10'@' + +'@@$DDDSDDD'#139'L?8'#197'^1'#29#254'c7 '#255'wG)'#255#173'l<'#255#188#127'E' + +#255#201#144'N'#255#212#158'T'#255#220#169'X'#255#225#175'['#255#228#179'\' + +#255#229#180'\'#255#230#181']'#255#230#181']'#255#230#182']'#255#230#182']' + +#255#230#182']'#255#230#182']'#255#230#182']'#255#230#182']'#255#230#182']' + +#255#230#182']'#255#230#182']'#255#230#182']'#255#230#182']'#255#230#182']' + +#255#230#182']'#255#230#182']'#255#230#182']'#255#230#182']'#255#230#182']' + +#255#230#182']'#255#230#182']'#255#221#175'Y'#255#10#8#4#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#1#1#1#255'4' + +')'#21#255#184#146'J'#255#230#182']'#255#230#182']'#255#230#182']'#255#230 + +#182']'#255#230#182']'#255#230#182']'#255#230#182']'#255#230#181']'#255#229 + +#182']'#255#228#180']'#255#227#178'\'#255#224#174'['#255#218#166'W'#255#209 + +#155'R'#255#198#139'K'#255#184'zC'#255#162'd8'#255'l@$'#255'a5'#30#255'Z3 ' + +#249'FBA'#206'DDD'#196'CCC'#174'CCC'#129'BBBIFFF'#29'@@@'#8#0#0#0#1#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#1'333'#5'FF' + +'F'#22'BBB>CCCvFA?'#174'Z3'#31#248'`5'#30#255'l@$'#255#163'd9'#255#184'{D' + +#255#199#142'N'#255#210#156'T'#255#218#167'Y'#255#223#174'\'#255#226#177'^' + +#255#228#179'^'#255#228#179'^'#255#228#180'_'#255#228#180'_'#255#228#180'_' + +#255#228#180'_'#255#228#180'_'#255#228#180'_'#255#228#180'_'#255#228#180'_' + +#255#228#180'_'#255#228#180'_'#255#228#180'_'#255#228#180'_'#255#228#180'_' + +#255#228#180'_'#255#228#180'_'#255#228#180'_'#255#228#180'_'#255#228#180'_' + +#255#228#180'_'#255#228#180'_'#255#228#180'_'#255'bM)'#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#27#21#11#255#140'o;'#255#228#180'_'#255#228#180 + +'_'#255#228#180'_'#255#228#180'_'#255#228#180'_'#255#228#180'_'#255#228#180 + +'_'#255#228#179'^'#255#227#179'^'#255#226#176']'#255#222#172'['#255#216#164 + +'X'#255#207#152'R'#255#195#137'K'#255#181'tA'#255#149'Z3'#255'g<"'#255'_3'#29 + +#255'V6'''#239'CCC'#201'CCC'#190'CCC'#159'CCCkCCC5GGG'#18'@@@'#4#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#2'@@@'#12'CCC' + +'*DDD^DDD'#150'U6('#230'^2'#28#255'f:!'#255#149'Z3'#255#181'uB'#255#195#137 + +'K'#255#208#154'T'#255#216#165'Y'#255#221#172']'#255#225#176'^'#255#226#178 + +'_'#255#227#178'_'#255#227#178'_'#255#227#179'_'#255#227#179'_'#255#227#179 + +'_'#255#227#179'_'#255#227#179'_'#255#227#179'_'#255#227#179'_'#255#227#179 + +'_'#255#227#179'_'#255#227#179'_'#255#227#179'_'#255#227#179'_'#255#227#179 + +'_'#255#227#179'_'#255#227#179'_'#255#227#179'_'#255#227#179'_'#255#227#179 + +'_'#255#227#179'_'#255#227#179'_'#255#227#179'_'#255#13#10#6#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255'&'#30#16#255#208#164 + +'W'#255#227#179'_'#255#227#179'_'#255#227#179'_'#255#227#179'_'#255#227#178 + +'_'#255#227#178'_'#255#226#179'`'#255#226#177'_'#255#224#176'^'#255#220#170 + +'\'#255#214#162'X'#255#205#149'R'#255#191#131'I'#255#177'p?'#255#131'O.'#255 + +'c7 '#255']1'#29#255'N;3'#222'DDD'#199'DDD'#181'CCC'#140'DDDSDDD"999'#9#0#0#0 + +#1#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#1'+++'#6'@@@'#24 + +'EEECCCC~K=7'#193']0'#28#255'b6'#31#255#129'M,'#255#177'o@'#255#191#131'J' + +#255#204#149'S'#255#214#163'Z'#255#220#171']'#255#223#174'_'#255#225#176'`' + +#255#225#177'`'#255#226#177'`'#255#226#177'`'#255#226#177'`'#255#226#177'`' + +#255#226#177'`'#255#226#177'`'#255#226#177'`'#255#226#177'`'#255#226#177'`' + +#255#226#177'`'#255#226#177'`'#255#226#177'`'#255#226#177'`'#255#226#177'`' + ,#255#226#177'`'#255#226#177'`'#255#226#177'`'#255#226#177'`'#255#226#177'`' + +#255#226#177'`'#255#226#177'`'#255#226#177'`'#255#161'~D'#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#4#3#2 + +#255#134'i9'#255#226#177'`'#255#226#177'`'#255#226#177'`'#255#226#177'`'#255 + +#226#177'`'#255#225#178'`'#255#225#177'`'#255#224#176'_'#255#222#174'^'#255 + +#219#169']'#255#212#159'X'#255#200#144'Q'#255#187'~G'#255#170'j<'#255'qB%' + +#255'`5'#30#255'Z2'#31#250'FBA'#205'CCC'#193'DDD'#166'CCCsCCC9CCC'#19'@@@'#4 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#2'@@@'#12'AAA+BBB' + +'aDBB'#155'Y3!'#244'_3'#29#255'l?$'#255#167'f;'#255#186'}H'#255#200#144'R' + +#255#211#158'Y'#255#218#168']'#255#221#172'`'#255#223#174'a'#255#223#176'a' + +#255#224#176'b'#255#224#176'b'#255#224#176'b'#255#224#176'b'#255#224#176'b' + +#255#224#176'b'#255#224#176'b'#255#224#176'b'#255#224#176'b'#255#224#176'b' + +#255#224#176'b'#255#224#176'b'#255#224#176'b'#255#224#176'b'#255#224#176'b' + +#255#224#176'b'#255#224#176'b'#255#224#176'b'#255#224#176'b'#255#224#176'b' + +#255#224#176'b'#255#224#176'b'#255#224#176'b'#255'hR.'#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255'qY2'#255#224#176'b'#255#224#176'b'#255#224#176'b'#255#224#176 + +'b'#255#224#176'b'#255#224#176'b'#255#223#176'a'#255#223#174'`'#255#221#172 + +'_'#255#217#166']'#255#208#155'W'#255#196#139'O'#255#182'wE'#255#152'\5'#255 + +'e9!'#255'^2'#29#255'S7*'#233'DDD'#200'CCC'#183'DDD'#143'EEEUDDD"UUU'#9#0#0#0 + +#1#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#1'333'#5'@@@'#24'DDDDCCC~P8-' + +#211']0'#29#255'c8!'#255#144'V2'#255#180'uD'#255#196#138'P'#255#207#155'X' + +#255#215#165']'#255#220#171'`'#255#221#173'b'#255#222#174'a'#255#222#175'b' + +#255#222#175'b'#255#222#175'b'#255#222#175'b'#255#222#175'b'#255#222#175'b' + +#255#222#175'b'#255#222#175'b'#255#222#175'b'#255#222#175'b'#255#222#175'b' + +#255#222#175'b'#255#222#175'b'#255#222#175'b'#255#222#175'b'#255#222#175'b' + +#255#222#175'b'#255#222#175'b'#255#222#175'b'#255#222#175'b'#255#222#175'b' + +#255#222#175'b'#255#222#175'b'#255#222#175'b'#255'VD&'#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#1#1#0#255#166#132'J'#255#222#175'b'#255#222#175'b'#255#222#175 + +'b'#255#222#175'b'#255#222#175'b'#255#222#175'b'#255#222#174'a'#255#221#173 + +'a'#255#219#170'`'#255#213#163'\'#255#205#150'V'#255#192#132'M'#255#176'oA' + +#255'}K,'#255'a5'#31#255'\0'#28#254'I?;'#212'CCC'#194'DDD'#166'CCCrDDD8GGG' + +#18'@@@'#4#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#2'FFF'#11'DDD)BBB`G@<' + +#164'[1'#29#252'_3'#29#255'uD)'#255#174'l?'#255#189#130'L'#255#204#150'V'#255 + +#213#162'^'#255#217#168'`'#255#220#172'b'#255#221#173'b'#255#221#173'c'#255 + +#221#173'c'#255#221#173'c'#255#221#173'c'#255#221#173'c'#255#221#173'c'#255 + +#221#173'c'#255#221#173'c'#255#221#173'c'#255#221#173'c'#255#221#173'c'#255 + +#221#173'c'#255#221#173'c'#255#221#173'c'#255#221#173'c'#255#221#173'c'#255 + +#221#173'c'#255#221#173'c'#255#221#173'c'#255#221#173'c'#255#221#173'c'#255 + +#221#173'c'#255#221#173'c'#255#221#173'c'#255#221#173'c'#255'gQ.'#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + ,#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#8#6#4#255#207#163']'#255#221#173'c'#255 + +#221#173'c'#255#221#173'c'#255#221#173'c'#255#221#173'c'#255#221#173'c'#255 + +#221#172'b'#255#219#171'b'#255#217#167'`'#255#211#159'['#255#200#145'T'#255 + +#185'{H'#255#164'd;'#255'h<#'#255'^1'#29#255'X3#'#244'DDD'#200'CCC'#183'DDD' + +#142'DDDSFFF!@@@'#8#0#0#0#1#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'@@@'#4'III'#21'EEE?DD' + +'D|S5'''#222'\1'#28#255'c8!'#255#158'_8'#255#183'yH'#255#198#142'S'#255#209 + +#158'\'#255#215#166'`'#255#218#170'b'#255#219#171'c'#255#219#171'd'#255#219 + +#172'd'#255#219#172'd'#255#219#172'd'#255#219#172'd'#255#219#172'd'#255#219 + +#172'd'#255#219#172'd'#255#219#172'd'#255#219#172'd'#255#219#172'd'#255#219 + +#172'd'#255#219#172'd'#255#219#172'd'#255#219#172'd'#255#219#172'd'#255#219 + +#172'd'#255#219#172'd'#255#219#172'd'#255#219#172'd'#255#219#172'd'#255#219 + +#172'd'#255#219#172'd'#255#219#172'd'#255#219#172'd'#255#219#172'd'#255#213 + +#168'b'#255#3#3#1#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255'M<#'#255#219#172 + +'d'#255#219#172'd'#255#219#172'd'#255#219#172'd'#255#219#172'd'#255#219#172 + +'d'#255#219#171'd'#255#219#170'c'#255#217#168'b'#255#214#164'`'#255#207#153 + +'Z'#255#194#136'P'#255#178'rD'#255#139'R1'#255'a4'#31#255'\0'#28#255'L<5'#219 + +'CCC'#193'DDD'#164'CCCoCCC5@@@'#16'UUU'#3#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#1'@@@'#8 + +'BBB#CCCWHA='#158'\0'#28#253'_3'#29#255'~I+'#255#175'nB'#255#191#133'O'#255 + +#205#151'Z'#255#213#163'a'#255#216#167'c'#255#217#169'c'#255#218#170'd'#255 + +#218#170'd'#255#218#170'd'#255#218#170'd'#255#218#170'd'#255#218#170'd'#255 + +#218#170'd'#255#218#170'd'#255#218#170'd'#255#218#170'd'#255#218#170'd'#255 + +#218#170'd'#255#218#170'd'#255#218#170'd'#255#218#170'd'#255#218#170'd'#255 + +#218#170'd'#255#218#170'd'#255#218#170'd'#255#218#170'd'#255#218#170'd'#255 + +#218#170'd'#255#218#170'd'#255#218#170'd'#255#218#170'd'#255#218#170'd'#255 + +#218#170'd'#255#218#170'd'#255'YF)'#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#15#12#7#255#218#170'd'#255#218#170'd'#255#218#170'd'#255#218#170'd'#255 + +#218#170'd'#255#218#170'd'#255#218#170'd'#255#218#169'c'#255#217#168'c'#255 + +#215#166'b'#255#211#160'_'#255#201#147'W'#255#187#127'L'#255#169'h>'#255'l=$' + +#255'^1'#29#255'W3"'#244'DDD'#199'DDD'#180'DDD'#136'DDDKBBB'#27'UUU'#6#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0'UUU'#3'DDD'#15'EEE4BBBpS6)'#215'\1'#28#255'b7!'#255#158'_9' + +#255#184'{J'#255#199#144'W'#255#209#158'_'#255#214#165'c'#255#216#168'd'#255 + +#217#168'd'#255#217#168'd'#255#217#168'd'#255#217#168'd'#255#217#168'd'#255 + +#217#168'd'#255#217#168'd'#255#217#168'd'#255#217#168'd'#255#217#168'd'#255 + +#217#168'd'#255#217#168'd'#255#217#168'd'#255#217#168'd'#255#217#168'd'#255 + +#217#168'd'#255#217#168'd'#255#217#168'd'#255#217#168'd'#255#217#168'd'#255 + +#217#168'd'#255#217#168'd'#255#217#168'd'#255#217#168'd'#255#217#168'd'#255 + +#217#168'd'#255#217#168'd'#255#217#168'd'#255#217#168'd'#255#217#168'd'#255 + +'YD)'#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#189#147'W'#255#217#168'd' + +#255#217#168'd'#255#217#168'd'#255#217#168'd'#255#217#168'd'#255#217#168'd' + +#255#217#168'd'#255#216#168'd'#255#215#167'c'#255#213#164'a'#255#207#154']' + +#255#195#138'S'#255#179'tF'#255#139'R1'#255'`5'#30#255'\0'#28#255'K=7'#216'D' + +'DD'#191'DDD'#157'CCCcAAA+FFF'#11#0#0#0#1#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + ,#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'+++'#6'EEE'#26'BBBIE?=' + +#144'Z0'#28#252'^2'#29#255'zF*'#255#174'mB'#255#192#135'R'#255#205#152'\'#255 + +#211#161'b'#255#214#165'd'#255#215#166'd'#255#215#166'd'#255#215#166'd'#255 + +#215#166'd'#255#215#166'd'#255#215#166'd'#255#215#166'd'#255#215#166'd'#255 + +#215#166'd'#255#215#166'd'#255#215#166'd'#255#215#166'd'#255#215#166'd'#255 + +#215#166'd'#255#215#166'd'#255#215#166'd'#255#215#166'd'#255#215#166'd'#255 + +#215#166'd'#255#215#166'd'#255#215#166'd'#255#215#166'd'#255#215#166'd'#255 + +#215#166'd'#255#215#166'd'#255#215#166'd'#255#215#166'd'#255#215#166'd'#255 + +#215#166'd'#255#215#166'd'#255#215#166'd'#255#215#166'd'#255'jR1'#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255'fN/'#255#215#166'd'#255#215#166'd'#255#215#166'd' + +#255#215#166'd'#255#215#166'd'#255#215#166'd'#255#215#166'd'#255#215#166'd' + +#255#215#167'e'#255#214#164'c'#255#210#159'a'#255#202#148'Z'#255#187#128'N' + +#255#168'f='#255'i;#'#255'\1'#28#255'V3#'#242'CCC'#197'DDD'#173'BBB{FFF>@@@' + +#20'@@@'#4#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#1'MMM'#10'FFF(CCC_R6*'#206'\0'#28#255'`5'#31#255#154'\8' + +#255#182'yJ'#255#199#144'Y'#255#208#156'`'#255#212#163'd'#255#213#165'd'#255 + +#214#165'e'#255#214#165'e'#255#214#165'e'#255#214#165'e'#255#214#165'e'#255 + +#214#165'e'#255#214#165'e'#255#214#165'e'#255#214#165'e'#255#214#165'e'#255 + +#214#165'e'#255#214#165'e'#255#214#165'e'#255#214#165'e'#255#214#165'e'#255 + +#214#165'e'#255#214#165'e'#255#214#165'e'#255#214#165'e'#255#214#165'e'#255 + +#214#165'e'#255#214#165'e'#255#214#165'e'#255#214#165'e'#255#214#165'e'#255 + +#214#165'e'#255#214#165'e'#255#214#165'e'#255#214#165'e'#255#214#165'e'#255 + +#214#165'e'#255#214#165'e'#255#214#165'e'#255#135'h@'#255#2#1#1#255#0#0#0#255 + +#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255'b' + +'L/'#255#214#165'e'#255#214#165'e'#255#214#165'e'#255#214#165'e'#255#214#165 + +'e'#255#214#165'e'#255#214#165'e'#255#214#165'e'#255#213#165'e'#255#213#164 + +'d'#255#211#161'c'#255#206#154'^'#255#194#139'U'#255#177'sF'#255#135'P/'#255 + +'^3'#29#255'[/'#27#255'J>9'#213'DDD'#185'CCC'#144'DDDSHHH III'#7#0#0#0#1#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'UUU'#3 + +'<<<'#17'DDD8DBAyZ0'#29#248'\1'#28#255'uB'''#255#172'lA'#255#190#132'Q'#255 + +#203#151'^'#255#209#160'c'#255#211#162'e'#255#212#163'e'#255#212#163'e'#255 + +#212#163'e'#255#212#163'e'#255#212#163'e'#255#212#163'e'#255#212#163'e'#255 + +#212#163'e'#255#212#163'e'#255#212#163'e'#255#212#163'e'#255#212#163'e'#255 + +#212#163'e'#255#212#163'e'#255#212#163'e'#255#212#163'e'#255#212#163'e'#255 + +#212#163'e'#255#212#163'e'#255#212#163'e'#255#212#163'e'#255#212#163'e'#255 + +#212#163'e'#255#212#163'e'#255#212#163'e'#255#212#163'e'#255#212#163'e'#255 + +#212#163'e'#255#212#163'e'#255#212#163'e'#255#212#163'e'#255#212#163'e'#255 + +#212#163'e'#255#212#163'e'#255#212#163'e'#255#156'xK'#255#1#0#0#255#0#0#0#255 + +#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255'jQ2'#255#212 + +#163'e'#255#212#163'e'#255#212#163'e'#255#212#163'e'#255#212#163'e'#255#212 + +#163'e'#255#212#163'e'#255#212#163'e'#255#212#163'e'#255#212#162'e'#255#211 + +#162'd'#255#208#158'b'#255#200#147'['#255#186'~M'#255#165'd<'#255'd8!'#255'\' + +'0'#28#255'T5'''#237'CCC'#193'DDD'#162'CCCjCCC.@@@'#12#0#0#0#2#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'333'#5'GGG'#25'BB' + +'BIN:1'#174'[/'#27#255'^2'#29#255#145'T3'#255#180'vI'#255#196#142'Y'#255#206 + +#155'a'#255#209#161'e'#255#211#162'e'#255#211#162'e'#255#211#162'e'#255#211 + +#162'e'#255#211#162'e'#255#211#162'e'#255#211#162'e'#255#211#162'e'#255#211 + +#162'e'#255#211#162'e'#255#211#162'e'#255#211#162'e'#255#211#162'e'#255#211 + ,#162'e'#255#211#162'e'#255#211#162'e'#255#211#162'e'#255#211#162'e'#255#211 + +#162'e'#255#211#162'e'#255#211#162'e'#255#211#162'e'#255#211#162'e'#255#211 + +#162'e'#255#211#162'e'#255#211#162'e'#255#211#162'e'#255#211#162'e'#255#211 + +#162'e'#255#211#162'e'#255#211#162'e'#255#211#162'e'#255#211#162'e'#255#211 + +#162'e'#255#211#162'e'#255#211#162'e'#255#211#162'e'#255'O=&'#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255'sX7'#255#211 + +#162'e'#255#211#162'e'#255#211#162'e'#255#211#162'e'#255#211#162'e'#255#211 + +#162'e'#255#211#162'e'#255#211#162'e'#255#211#162'e'#255#211#162'e'#255#210 + +#161'f'#255#209#159'd'#255#204#153'`'#255#192#135'U'#255#175'pE'#255'~H+'#255 + +']0'#29#255'Z0'#28#253'FBA'#201'DDD'#176'CCC~FFF>CCC'#19'@@@'#4#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#1'999'#9'EEE%CCC[V3' + +'$'#222'\0'#27#255'f7!'#255#167'd>'#255#187#128'Q'#255#200#148'^'#255#207#156 + +'d'#255#209#159'e'#255#209#160'e'#255#209#160'e'#255#209#160'e'#255#209#160 + +'e'#255#209#160'e'#255#209#160'e'#255#209#160'e'#255#209#160'e'#255#209#160 + +'e'#255#209#160'e'#255#209#160'e'#255#209#160'e'#255#209#160'e'#255#209#160 + +'e'#255#209#160'e'#255#209#160'e'#255#151'tI'#255'2&'#25#255#27#21#13#255#15 + +#12#7#255#7#5#3#255#7#5#3#255' '#25#16#255'P='''#255#151'tI'#255#209#160'e' + +#255#209#160'e'#255#209#160'e'#255#209#160'e'#255#209#160'e'#255#209#160'e' + +#255#209#160'e'#255#209#160'e'#255#209#160'e'#255#209#160'e'#255#209#160'e' + +#255#209#160'e'#255#209#160'e'#255#6#5#3#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#146'pF'#255#209#160'e'#255#209#160'e'#255 + +#209#160'e'#255#209#160'e'#255#209#160'e'#255#209#160'e'#255#209#160'e'#255 + +#209#160'e'#255#209#160'e'#255#209#160'e'#255#209#160'e'#255#209#159'e'#255 + +#206#155'c'#255#198#143'['#255#182'zM'#255#151'Y6'#255'^3'#29#255'[/'#27#255 + +'N:1'#222'DDD'#185'DDD'#142'DDDOIII'#28'+++'#6#0#0#0#1#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#2';;;'#13'DDD1F@=x[/'#28#253'\1'#28 + +#255'~G+'#255#174'oE'#255#193#137'X'#255#203#151'b'#255#207#156'e'#255#207 + +#158'f'#255#208#158'f'#255#208#158'f'#255#208#158'f'#255#208#158'f'#255#208 + +#158'f'#255#208#158'f'#255#208#158'f'#255#208#158'f'#255#208#158'f'#255#208 + +#158'f'#255#208#158'f'#255#208#158'f'#255#208#158'f'#255#208#158'f'#255'x[;' + +#255#15#12#8#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255 + +#0#0#0#255#0#0#0#255#0#0#0#255#4#3#2#255'bJ0'#255#208#158'f'#255#208#158'f' + +#255#208#158'f'#255#208#158'f'#255#208#158'f'#255#208#158'f'#255#208#158'f' + +#255#208#158'f'#255#208#158'f'#255#208#158'f'#255#208#158'f'#255'3'''#25#255 + +#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#2#2#1#255#208#158'f' + +#255#208#158'f'#255#208#158'f'#255#208#158'f'#255#208#158'f'#255#208#158'f' + +#255#208#158'f'#255#208#158'f'#255#208#158'f'#255#208#158'f'#255#208#158'f' + +#255#208#158'f'#255#207#158'e'#255#206#156'd'#255#201#149'_'#255#189#131'T' + +#255#169'h@'#255'j:#'#255'\0'#28#255'V3#'#242'DDD'#191'CCC'#156'BBB`AAA''333' + +#10#0#0#0#1#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'@@@'#4'C' + +'CC'#19'EEE?Q7+'#179'[/'#27#255'^1'#29#255#152'X6'#255#181'yM'#255#197#144']' + +#255#204#153'c'#255#206#155'f'#255#206#156'e'#255#206#156'e'#255#206#156'e' + +#255#206#156'e'#255#206#156'e'#255#206#156'e'#255#206#156'e'#255#206#156'e' + +#255#206#156'e'#255#206#156'e'#255#206#156'e'#255#206#156'e'#255#206#156'e' + +#255#202#154'c'#255'6)'#27#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#14#10#7#255#178#135'W'#255#206#156'e'#255#206#156'e'#255#206#156'e' + +#255#206#156'e'#255#206#156'e'#255#206#156'e'#255#206#156'e'#255#206#156'e' + +#255#206#156'e'#255'WB+'#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + ,#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#29#22#14#255#206#156'e'#255#206#156'e'#255#206#156'e'#255#206#156'e' + +#255#206#156'e'#255#206#156'e'#255#206#156'e'#255#206#156'e'#255#206#156'e' + +#255#206#156'e'#255#206#156'e'#255#206#156'e'#255#206#156'e'#255#205#156'e' + +#255#203#151'c'#255#194#139'Z'#255#176'qH'#255#131'K-'#255'\1'#28#255'[/'#27 + +#255'HA='#204'DDD'#169'DDDqEEE4III'#14#128#128#128#2#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#1'+++'#6'BBB'#27'EEENW2!'#228'[/'#27#255'i9!' + +#255#168'e?'#255#187#130'T'#255#200#147'`'#255#203#153'e'#255#205#154'e'#255 + +#205#154'e'#255#205#154'e'#255#205#154'e'#255#205#154'e'#255#205#154'e'#255 + +#205#154'e'#255#205#154'e'#255#205#154'e'#255#205#154'e'#255#205#154'e'#255 + +#205#154'e'#255#205#154'e'#255#199#150'a'#255#19#14#9#255#0#0#0#255#0#0#0#255 + +#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#7#6#4#255#178#133'W' + +#255#205#154'e'#255#205#154'e'#255#205#154'e'#255#205#154'e'#255#205#154'e' + +#255#205#154'e'#255#205#154'e'#255#205#154'e'#255'S>)'#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#128'a?'#255#205#154'e'#255#205#154'e' + +#255#205#154'e'#255#205#154'e'#255#205#154'e'#255#205#154'e'#255#205#154'e' + +#255#205#154'e'#255#205#154'e'#255#205#154'e'#255#205#154'e'#255#205#154'e' + +#255#205#154'e'#255#204#154'e'#255#203#152'd'#255#197#145'^'#255#182'zO'#255 + +#157'Z8'#255']1'#29#255'[/'#27#255'P9.'#226'CCC'#179'CCC'#129'CCCA@@@'#20'@@' + +'@'#4#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#1'999'#9'EEE%EA?' + +'b[/'#27#253'\0'#27#255#127'F*'#255#173'nG'#255#191#136'Z'#255#200#149'c'#255 + +#202#152'e'#255#202#152'e'#255#202#153'e'#255#202#153'e'#255#202#153'e'#255 + +#202#153'e'#255#202#153'e'#255#202#153'e'#255#202#153'e'#255#202#153'e'#255 + +#202#153'e'#255#202#153'e'#255#202#153'e'#255#202#153'e'#255#31#24#16#255#0#0 + +#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255 + +#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#11#8#6#255#200#151'e'#255#202#153'e'#255#202#153'e'#255#202 + +#153'e'#255#202#153'e'#255#202#153'e'#255#202#153'e'#255#202#153'e'#255'O;''' + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255''''#29#19#255#202#153'e'#255 + +#202#153'e'#255#202#153'e'#255#202#153'e'#255#202#153'e'#255#202#153'e'#255 + +#202#153'e'#255#202#153'e'#255#202#153'e'#255#202#153'e'#255#202#153'e'#255 + +#202#153'e'#255#202#153'e'#255#202#153'e'#255#202#152'e'#255#202#151'd'#255 + +#199#147'b'#255#188#130'U'#255#168'e@'#255'k:"'#255'[/'#27#255'V3$'#241'CCC' + +#186'BBB'#142'EEENBBB'#27'+++'#6#0#0#0#1#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#2'@@@'#12'DDD-O:0'#146'[/'#27#255'\0'#28#255#145'R2'#255#179'wM' + +#255#194#141'^'#255#200#148'c'#255#201#150'e'#255#201#150'e'#255#201#150'e' + +#255#201#150'e'#255#201#150'e'#255#201#150'e'#255#201#150'e'#255#201#150'e' + +#255#201#150'e'#255#201#150'e'#255#201#150'e'#255#201#150'e'#255#201#150'e' + +#255';,'#30#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255'S>*'#255#201#150'e' + +#255#201#150'e'#255#201#150'e'#255#201#150'e'#255#201#150'e'#255#201#150'e' + +#255#201#150'e'#255'K8&'#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#29#22#14#255 + +#184#138']'#255#201#150'e'#255#201#150'e'#255#201#150'e'#255#201#150'e'#255 + ,#201#150'e'#255#201#150'e'#255#201#150'e'#255#201#150'e'#255#201#150'e'#255 + +#201#150'e'#255#201#150'e'#255#201#150'e'#255#201#150'e'#255#201#150'e'#255 + +#201#150'e'#255#200#149'd'#255#199#148'c'#255#191#136'['#255#173'mG'#255'}D(' + +#255'\0'#27#255'Z0'#28#253'DBB'#192'CCC'#152'DDDZBBB#@@@'#8#0#0#0#1#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#128#128#128#2'III'#14'CCC5T5'''#190'[/'#27#255 + +'_2'#29#255#162'^:'#255#184'}S'#255#195#142'`'#255#198#147'd'#255#199#148'd' + +#255#199#148'd'#255#199#148'd'#255#199#148'd'#255#199#148'd'#255#199#148'd' + +#255#199#148'd'#255#199#148'd'#255#199#148'd'#255#199#148'd'#255#199#148'd' + +#255#199#148'd'#255#147'mJ'#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#3#2#1#255#195#144'b'#255#199#148'd'#255#199#148'd'#255#199#148'd'#255 + +#199#148'd'#255#199#148'd'#255#199#148'd'#255'H6$'#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#3#2#1#255#23#17#12 + +#255'qT8'#255#199#148'd'#255#199#148'd'#255#199#148'd'#255#199#148'd'#255#199 + +#148'd'#255#199#148'd'#255#199#148'd'#255#199#148'd'#255#199#148'd'#255#199 + +#148'd'#255#199#148'd'#255#199#148'd'#255#199#148'd'#255#199#148'd'#255#199 + +#148'd'#255#199#148'd'#255#199#148'd'#255#199#148'd'#255#198#146'c'#255#193 + +#140'^'#255#178'uN'#255#143'O1'#255'\0'#28#255'[/'#27#255'J=7'#208'CCC'#161 + +'DDDfAAA+FFF'#11#0#0#0#2#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'UUU'#3'<<<' + +#17'CCC=X1 '#227'[/'#27#255'm:"'#255#167'eA'#255#187#130'X'#255#195#143'a' + +#255#196#144'c'#255#197#145'c'#255#197#145'c'#255#197#145'c'#255#197#145'c' + +#255#197#145'c'#255#197#145'c'#255#197#145'c'#255#197#145'c'#255#197#145'c' + +#255#197#145'c'#255#197#145'c'#255#197#145'c'#255#19#14#10#255#0#0#0#255#0#0 + +#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255 + +#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#135'cD'#255#197#145'c'#255#197 + +#145'c'#255#197#145'c'#255#197#145'c'#255#197#145'c'#255#197#145'c'#255'I5$' + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#19#14#10#255'4&'#26#255'cI2'#255 + +#161'vP'#255#197#145'c'#255#197#145'c'#255#197#145'c'#255#197#145'c'#255#197 + +#145'c'#255#197#145'c'#255#197#145'c'#255#197#145'c'#255#197#145'c'#255#197 + +#145'c'#255#197#145'c'#255#197#145'c'#255#197#145'c'#255#197#145'c'#255#197 + +#145'c'#255#197#145'c'#255#197#145'c'#255#197#145'c'#255#197#145'c'#255#197 + +#145'c'#255#197#145'b'#255#196#144'c'#255#194#140'`'#255#182'|S'#255#159'\:' + +#255']2'#28#255'[/'#27#255'Q8-'#226'DDD'#168'DDDqAAA3NNN'#13#128#128#128#2#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'@@@'#4':::'#22'G@/[/'#27 + +#254'[/'#27#255'}A&'#255#167'gD'#255#180'zW'#255#181'|Y'#255#181'|Y'#255#181 + +'|Y'#255#181'|Y'#255#181'|Y'#255#181'|Y'#255#181'|Y'#255#181'|Y'#255#181'|Y' + +#255#181'|Y'#255#181'|Y'#255#181'|Y'#255#136']C'#255#0#0#0#255#0#0#0#255#0#0 + +#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255 + +#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#19#13#9#255#151'gJ'#255#181'|Y'#255#181'|Y'#255#181 + +'|Y'#255#181'|Y'#255#181'|Y'#255#181'|Y'#255#181'|Y'#255#181'|Y'#255#181'|Y' + +#255#181'|Y'#255#181'|Y'#255#181'|Y'#255#181'|Y'#255#171'vU'#255'1"'#24#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#1#0#0#255'}V>'#255 + +#181'|Y'#255#181'|Y'#255#181'|Y'#255#181'|Y'#255#181'|Y'#255#181'|Y'#255#181 + +'|Y'#255#181'|Y'#255#181'|Y'#255#181'|Y'#255#181'|Y'#255#181'|Y'#255#181'|Y' + +#255#181'|Y'#255#181'|Y'#255#181'|Y'#255#181'|Y'#255#181'|Y'#255#181'|Y'#255 + +#181'|Y'#255#181'|Y'#255#181'|Y'#255#181'|Y'#255#181'|Y'#255#181'|Y'#255#181 + +'|Y'#255#181'|Y'#255#181'|Y'#255#181'|Y'#255#181'|Y'#255#181'|Y'#255#181'|Y' + +#255#181'|Y'#255#181'|Y'#255#178'wT'#255#161'];'#255'k8 '#255'[/'#27#255'V3#' + +#238'DDD'#151'CCCWFFF!@@@'#8#0#0#0#1#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#2'FFF'#11 + +'K:3?[/'#27#255'[/'#27#255#131'F*'#255#169'iH'#255#179'xV'#255#180'zW'#255 + +#180'{W'#255#180'{W'#255#180'{W'#255#180'{W'#255#180'{W'#255#180'{W'#255#180 + +'{W'#255#180'{W'#255#180'{W'#255#180'{W'#255#180'{W'#255'<)'#29#255#0#0#0#255 + +#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#1#1#1#255'O6&'#255#180'{W'#255#180'{W'#255#180'{W'#255#180 + +'{W'#255#180'{W'#255#180'{W'#255#180'{W'#255#180'{W'#255#180'{W'#255#180'{W' + +#255#180'{W'#255#180'{W'#255#180'{W'#255#180'{W'#255#180'{W'#255#180'{W'#255 + +#180'{W'#255#142'aE'#255#27#19#13#255#2#1#1#255#0#0#0#255#0#0#0#255#0#0#0#255 + ,#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#8#5#4#255 + +#135']A'#255#180'{W'#255#180'{W'#255#180'{W'#255#180'{W'#255#180'{W'#255#180 + +'{W'#255#180'{W'#255#180'{W'#255#180'{W'#255'pL6'#255'+'#29#20#255'('#28#19 + +#255'*'#28#20#255'+'#29#21#255'-'#30#21#255'fF2'#255#180'{W'#255#180'{W'#255 + +#180'{W'#255#180'{W'#255#180'{W'#255#180'{W'#255#180'{W'#255#180'{W'#255#180 + +'{W'#255#180'{W'#255#180'{W'#255#180'{W'#255#180'{W'#255#180'{W'#255#180'{W' + +#255#180'{W'#255#180'{W'#255#180'{W'#255#180'zX'#255#178'vU'#255#163'_>'#255 + +'r<"'#255'[/'#27#255'X2!'#243'CCC'#152'BBBYDDD"@@@'#8#0#0#0#1#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#2'FFF'#11'N8.J[/'#27#255'[/'#27#255#135'H,'#255#170'kI'#255 + +#178'wV'#255#179'yX'#255#179'yX'#255#179'yX'#255#179'yX'#255#179'yX'#255#179 + +'yX'#255#179'yX'#255#179'yX'#255#179'yX'#255#179'yX'#255#179'yX'#255#179'yX' + +#255#16#11#8#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255 + +#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#19#13#10#255#150'fJ'#255#179'yX'#255#179 + +'yX'#255#179'yX'#255#179'yX'#255#179'yX'#255#179'yX'#255#179'yX'#255#179'yX' + +#255#179'yX'#255#179'yX'#255#179'yX'#255#179'yX'#255#179'yX'#255#179'yX'#255 + +#179'yX'#255#179'yX'#255#179'yX'#255#179'yX'#255#179'yX'#255#179'yX'#255#179 + +'yX'#255'~V>'#255'=)'#30#255#19#13#9#255#1#1#1#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255'$'#24#17#255#172'uT'#255#179'yX'#255#179'yX'#255#179'yX' + +#255#179'yX'#255#179'yX'#255#179'yX'#255#179'yX'#255#158'kN'#255'=)'#30#255#6 + +#4#3#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#6#4#3#255'?+'#31#255#164'oP'#255#179'yX'#255#179'yX'#255#179'yX'#255#179 + +'yX'#255#179'yX'#255#179'yX'#255#179'yX'#255#179'yX'#255#179'yX'#255#179'yX' + +#255#179'yX'#255#179'yX'#255#179'yX'#255#179'yX'#255#179'yX'#255#179'yX'#255 + +#177'uU'#255#164'b@'#255'v?%'#255'[/'#27#255'Y1'#31#246'CCC'#152'BBBYDDD"@@@' + +#8#0#0#0#1#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#1'FFF'#11'Q7+U[/'#27#255'\0'#28#255 + +#139'J-'#255#171'lL'#255#177'wW'#255#178'wV'#255#178'wV'#255#178'wV'#255#178 + +'wV'#255#178'wV'#255#178'wV'#255#178'wV'#255#178'wV'#255#178'wV'#255#178'wV' + +#255#178'wV'#255#172'sT'#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#1#1#1#255'O5&'#255#178'wV'#255#178'wV' + +#255#178'wV'#255#178'wV'#255#178'wV'#255#178'wV'#255#178'wV'#255#178'wV'#255 + +#178'wV'#255#178'wV'#255#178'wV'#255#178'wV'#255#178'wV'#255#178'wV'#255#178 + +'wV'#255#178'wV'#255#178'wV'#255#178'wV'#255#178'wV'#255#178'wV'#255#178'wV' + +#255#178'wV'#255#178'wV'#255#178'wV'#255#178'wV'#255#178'wV'#255#176'wV'#255 + +'vO9'#255'7%'#27#255#16#10#8#255#1#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0 + +#0#255#0#0#0#255#11#8#6#255'9&'#28#255#137'\C'#255#178'wV'#255#178'wV'#255 + +#178'wV'#255#178'wV'#255#178'wV'#255#178'wV'#255#178'wV'#255#178'wV'#255'M3%' + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#1#0#0#255'4"'#25#255#178'wV' + +#255#178'wV'#255#178'wV'#255#178'wV'#255#178'wV'#255#178'wV'#255#178'wV'#255 + +#178'wV'#255#178'wV'#255#178'wV'#255#178'wV'#255#178'wV'#255#178'wV'#255#178 + +'wV'#255#178'wV'#255#176'tT'#255#165'cC'#255'yA'''#255'[/'#27#255'Z0'#29#250 + +'DDD'#150'CCCWFFF!III'#7#0#0#0#1#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#1'MMM'#10'R4' + +'''^[/'#27#255'\0'#28#255#142'M.'#255#171'nN'#255#177'uV'#255#177'wX'#255#177 + +'wX'#255#177'wX'#255#177'wX'#255#177'wX'#255#177'wX'#255#177'wX'#255#177'wX' + +#255#177'wX'#255#177'wX'#255#177'wX'#255'gF3'#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#23#16#12#255#152'fK'#255#177 + +'wX'#255#177'wX'#255#177'wX'#255#177'wX'#255#177'wX'#255#177'wX'#255#177'wX' + +#255#177'wX'#255#177'wX'#255#177'wX'#255#177'wX'#255#177'wX'#255#177'wX'#255 + +#177'wX'#255#177'wX'#255#177'wX'#255#177'wX'#255#177'wX'#255#177'wX'#255#177 + +'wX'#255#177'wX'#255#177'wX'#255#177'wX'#255#177'wX'#255#177'wX'#255#177'wX' + +#255#177'wX'#255#177'wX'#255#177'wX'#255#177'wX'#255#177'wX'#255#173'uV'#255 + +#136'\D'#255#133'YB'#255#131'XA'#255#128'V@'#255#153'gL'#255#177'wX'#255#177 + +'wX'#255#177'wX'#255#177'wX'#255#177'wX'#255#177'wX'#255#177'wX'#255#177'wX' + +#255#177'wX'#255#177'wX'#255'S8)'#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255 + +#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255'"'#23#17#255#175'wX'#255#177'wX'#255#177 + +'wX'#255#177'wX'#255#177'wX'#255#177'wX'#255#177'wX'#255#177'wX'#255#177'wX' + +#255#177'wX'#255#177'wX'#255#177'wX'#255#177'wX'#255#177'wX'#255#175'tU'#255 + +#166'eE'#255'}B)'#255'\0'#28#255'[/'#28#253'CCC'#148'CCCTBBB'#31'III'#7#0#0#0 + ,#1#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#1'999'#9'V4%h[/'#27#255'\0'#28#255#145'O0' + +#255#171'mN'#255#175'sU'#255#175'uW'#255#175'uW'#255#175'uW'#255#175'uW'#255 + +#175'uW'#255#175'uW'#255#175'uW'#255#175'uW'#255#175'uW'#255#175'uW'#255#175 + +'uW'#255'*'#29#21#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#2 + +#1#1#255'X;,'#255#175'uW'#255#175'uW'#255#175'uW'#255#175'uW'#255#175'uW'#255 + +#175'uW'#255#175'uW'#255#175'uW'#255#175'uW'#255#175'uW'#255#175'uW'#255#175 + +'uW'#255#175'uW'#255#175'uW'#255#175'uW'#255#175'uW'#255#175'uW'#255#175'uW' + +#255#175'uW'#255#175'uW'#255#175'uW'#255#175'uW'#255#175'uW'#255#175'uW'#255 + +#175'uW'#255#175'uW'#255#175'uW'#255#175'uW'#255#175'uW'#255#175'uW'#255#175 + +'uW'#255#175'uW'#255#175'uW'#255#175'uW'#255#175'uW'#255#175'uW'#255#175'uW' + +#255#175'uW'#255#175'uW'#255#175'uW'#255#175'uW'#255#175'uW'#255#175'uW'#255 + +#175'uW'#255#175'uW'#255#175'uW'#255#175'uW'#255#175'uW'#255'^?/'#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255'$'#24#18#255#175'uW'#255#175'uW'#255#175'uW'#255#175'uW'#255 + +#175'uW'#255#175'uW'#255#175'uW'#255#175'uW'#255#175'uW'#255#175'uW'#255#175 + +'uW'#255#175'uW'#255#175'uW'#255#175'sT'#255#166'eE'#255#128'D*'#255'\0'#28 + +#255'[/'#27#255'ECB'#149'CCCP@@@'#28'UUU'#6#0#0#0#1#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#1'@@@'#8'W3#q[/'#27#255'\1'#29#255#150'Q1'#255#171'mN'#255#174'sU'#255 + +#175'uV'#255#175'uV'#255#175'uV'#255#175'uV'#255#175'uV'#255#175'uV'#255#175 + +'uV'#255#175'uV'#255#175'uV'#255#175'uV'#255#175'uV'#255#15#10#8#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#4#3#2#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#29#19#14#255#156'iM'#255#175'uV'#255 + +#175'uV'#255#175'uV'#255#175'uV'#255#175'uV'#255#175'uV'#255#175'uV'#255#175 + +'uV'#255#175'uV'#255#175'uV'#255#175'uV'#255#175'uV'#255#175'uV'#255#175'uV' + +#255#175'uV'#255#175'uV'#255#175'uV'#255#175'uV'#255#175'uV'#255#175'uV'#255 + +#175'uV'#255#175'uV'#255#175'uV'#255#175'uV'#255#175'uV'#255#175'uV'#255#175 + +'uV'#255#175'uV'#255#175'uV'#255#175'uV'#255#175'uV'#255#175'uV'#255#175'uV' + +#255#175'uV'#255#175'uV'#255#175'uV'#255#175'uV'#255#175'uV'#255#175'uV'#255 + +#175'uV'#255#175'uV'#255#175'uV'#255#175'uV'#255#175'uV'#255#175'uV'#255#175 + +'uV'#255#175'uV'#255#175'uV'#255#175'uV'#255#11#7#6#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255'sM9'#255#175'uV'#255#175'uV'#255#175'uV'#255#175'uV'#255#175'uV'#255 + +#175'uV'#255#175'uV'#255#175'uV'#255#175'uV'#255#175'uV'#255#175'uV'#255#175 + +'tV'#255#174'rS'#255#167'fG'#255#131'G,'#255'\0'#28#255'[/'#27#255'GA?'#150 + +'CCCLGGG'#25'333'#5#0#0#0#1#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#1'III'#7'W3#k[/'#27 + +#255'\1'#29#255#149'P2'#255#169'lM'#255#174'qT'#255#175'tV'#255#175'tV'#255 + +#175'tV'#255#175'tV'#255#175'tV'#255#175'tV'#255#175'tV'#255#175'tV'#255#175 + +'tV'#255#175'tV'#255#175'tV'#255#9#6#4#255#0#0#0#255#0#0#0#255#0#0#0#255#136 + +'ZC'#255'T8*'#255#1#1#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#7#5#3#255 + +'bA0'#255#175'tV'#255#175'tV'#255#175'tV'#255#175'tV'#255#175'tV'#255#175'tV' + +#255#175'tV'#255#175'tV'#255#175'tV'#255#175'tV'#255#175'tV'#255#175'tV'#255 + +#175'tV'#255#175'tV'#255#175'tV'#255#175'tV'#255#175'tV'#255#175'tV'#255#175 + +'tV'#255#175'tV'#255#175'tV'#255#175'tV'#255#175'tV'#255#175'tV'#255#175'tV' + +#255#175'tV'#255#175'tV'#255#175'tV'#255#175'tV'#255#175'tV'#255#175'tV'#255 + +#175'tV'#255#175'tV'#255#175'tV'#255#175'tV'#255#175'tV'#255#175'tV'#255#175 + +'tV'#255#175'tV'#255#175'tV'#255#175'tV'#255#175'tV'#255#175'tV'#255#175'tV' + +#255#175'tV'#255#175'tV'#255#175'tV'#255#175'tV'#255#175'tV'#255#175'tV'#255 + +#165'nR'#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0 + +#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255 + +#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#10#7#5#255#175'tV'#255#175 + +'tV'#255#175'tV'#255#175'tV'#255#175'tV'#255#175'tV'#255#175'tV'#255#175'tV' + +#255#175'tV'#255#175'tV'#255#175'tV'#255#174'sU'#255#173'qR'#255#166'eG'#255 + +#131'F,'#255'\0'#28#255'[/'#27#255'EA?'#145'DDDGFFF'#22'@@@'#4#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#1'333'#5'W3#\[/'#27#255'\1'#29#255#146'P3'#255#168 + +'jM'#255#173'pT'#255#173'rU'#255#173'rU'#255#173'rU'#255#173'rU'#255#173'rU' + +#255#173'rU'#255#173'rU'#255#173'rU'#255#173'rU'#255#173'rU'#255#173'rU'#255 + +#4#3#2#255#0#0#0#255#0#0#0#255#21#14#10#255#173'rU'#255#173'rU'#255#152'dK' + +#255'dB1'#255'A+ '#255'D-!'#255#141']E'#255#173'rU'#255#173'rU'#255#173'rU' + +#255#173'rU'#255#173'rU'#255#173'rU'#255#173'rU'#255#173'rU'#255#173'rU'#255 + +#173'rU'#255#173'rU'#255#173'rU'#255#173'rU'#255#173'rU'#255#173'rU'#255#173 + +'rU'#255#173'rU'#255#173'rU'#255#173'rU'#255#173'rU'#255#173'rU'#255#173'rU' + ,#255#173'rU'#255#173'rU'#255#173'rU'#255#173'rU'#255#173'rU'#255#173'rU'#255 + +#173'rU'#255#173'rU'#255#173'rU'#255#173'rU'#255#173'rU'#255#173'rU'#255#173 + +'rU'#255#173'rU'#255#173'rU'#255#173'rU'#255#173'rU'#255#173'rU'#255#173'rU' + +#255#173'rU'#255#173'rU'#255#173'rU'#255#173'rU'#255#173'rU'#255#173'rU'#255 + +#173'rU'#255#173'rU'#255#173'rU'#255#173'rU'#255#173'rU'#255#169'pS'#255#0#0 + +#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255 + +#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#139'\D'#255#173'rU'#255#173'rU' + +#255#173'rU'#255#173'rU'#255#173'rU'#255#173'rU'#255#173'rU'#255#173'rU'#255 + +#173'rU'#255#173'rU'#255#173'qT'#255#172'oR'#255#165'cF'#255#128'E+'#255'\0' + +#28#255'[/'#27#255'CBA'#132'DDD@CCC'#19'UUU'#3#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0'@@@'#4'U2"L[/'#27#255'\1'#29#255#143'N3'#255#168'hK'#255#172'oT' + +#255#173'qU'#255#173'rV'#255#173'rV'#255#173'rV'#255#173'rV'#255#173'rV'#255 + +#173'rV'#255#173'rV'#255#173'rV'#255#173'rV'#255#173'rV'#255#1#1#1#255#0#0#0 + +#255#0#0#0#255'nI7'#255#173'rV'#255#173'rV'#255#173'rV'#255#173'rV'#255#173 + +'rV'#255#173'rV'#255#173'rV'#255#173'rV'#255#173'rV'#255#173'rV'#255#173'rV' + +#255#173'rV'#255#173'rV'#255#173'rV'#255#173'rV'#255#173'rV'#255#173'rV'#255 + +#173'rV'#255#173'rV'#255#173'rV'#255#173'rV'#255#173'rV'#255#173'rV'#255#173 + +'rV'#255#173'rV'#255#173'rV'#255#173'rV'#255#173'rV'#255#173'rV'#255#173'rV' + +#255#173'rV'#255#173'rV'#255#173'rV'#255#173'rV'#255#173'rV'#255#173'rV'#255 + +#173'rV'#255#173'rV'#255#173'rV'#255#173'rV'#255#173'rV'#255#173'rV'#255#173 + +'rV'#255#173'rV'#255#173'rV'#255#173'rV'#255#173'rV'#255#173'rV'#255#173'rV' + +#255#173'rV'#255#173'rV'#255#173'rV'#255#173'rV'#255#173'rV'#255#173'rV'#255 + +#173'rV'#255#173'rV'#255#173'rV'#255#173'rV'#255#173'rV'#255#2#1#1#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255'H0$'#255#173'rV'#255#173'rV'#255#173'rV' + +#255#173'rV'#255#173'rV'#255#173'rV'#255#173'rV'#255#173'rV'#255#173'rV'#255 + +#173'rV'#255#173'qU'#255#171'nQ'#255#165'dF'#255'~D+'#255'\1'#29#255'Z0'#28 + +#252'CCCzCCC9@@@'#16#128#128#128#2#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'U' + +'UU'#3'T2#=[/'#27#255'\1'#29#255#140'N1'#255#166'gI'#255#171'oR'#255#173'qU' + +#255#173'qU'#255#173'qU'#255#173'qU'#255#173'qU'#255#173'qU'#255#173'qU'#255 + +#173'qU'#255#173'qU'#255#173'qU'#255#173'qU'#255#1#1#1#255#27#18#13#255'a@0' + +#255#173'qU'#255#173'qU'#255#173'qU'#255#173'qU'#255#173'qU'#255#173'qU'#255 + +#173'qU'#255#173'qU'#255#173'qU'#255#173'qU'#255#173'qU'#255#173'qU'#255#173 + +'qU'#255#173'qU'#255#173'qU'#255#173'qU'#255#173'qU'#255#173'qU'#255#173'qU' + +#255#173'qU'#255#173'qU'#255#173'qU'#255#173'qU'#255#173'qU'#255#173'qU'#255 + +#173'qU'#255#173'qU'#255#173'qU'#255#173'qU'#255#173'qU'#255#173'qU'#255#173 + +'qU'#255#173'qU'#255#173'qU'#255#173'qU'#255#173'qU'#255#173'qU'#255#173'qU' + +#255#173'qU'#255#173'qU'#255#173'qU'#255#173'qU'#255#173'qU'#255#173'qU'#255 + +#173'qU'#255#173'qU'#255#173'qU'#255#173'qU'#255#173'qU'#255#173'qU'#255#173 + +'qU'#255#173'qU'#255#173'qU'#255#173'qU'#255#173'qU'#255#173'qU'#255#173'qU' + +#255#173'qU'#255#173'qU'#255#173'qU'#255#173'qU'#255'$'#24#18#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#31#20#15#255#173'qU'#255#173'qU'#255#173'qU'#255 + +#173'qU'#255#173'qU'#255#173'qU'#255#173'qU'#255#173'qU'#255#173'qU'#255#173 + +'qU'#255#172'pT'#255#169'lP'#255#164'aD'#255'{C*'#255'\1'#29#255'Y0'#30#247 + +'CCCoBBB2;;;'#13#0#0#0#2#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#128#128#128 + +#2'V6''-[/'#27#255'\1'#29#255#137'L0'#255#165'fH'#255#170'mQ'#255#172'pT'#255 + +#172'pU'#255#172'pU'#255#172'pU'#255#172'pU'#255#172'pU'#255#172'pU'#255#172 + +'pU'#255#172'pU'#255#172'pU'#255#172'pU'#255#166'lS'#255#172'pU'#255#172'pU' + +#255#172'pU'#255#172'pU'#255#172'pU'#255#172'pU'#255#172'pU'#255#172'pU'#255 + +#172'pU'#255#172'pU'#255#172'pU'#255#172'pU'#255#172'pU'#255#172'pU'#255#172 + +'pU'#255#172'pU'#255#172'pU'#255#172'pU'#255#172'pU'#255#172'pU'#255#172'pU' + +#255#172'pU'#255#172'pU'#255#172'pU'#255#168'nS'#255#134'WB'#255'b@0'#255'tK' + +'9'#255#166'lS'#255#172'pU'#255#172'pU'#255#172'pU'#255#172'pU'#255#172'pU' + +#255#172'pU'#255#172'pU'#255#172'pU'#255#172'pU'#255#172'pU'#255#172'pU'#255 + +#172'pU'#255#172'pU'#255#172'pU'#255#172'pU'#255#172'pU'#255#172'pU'#255#172 + +'pU'#255#172'pU'#255#172'pU'#255#172'pU'#255#172'pU'#255#172'pU'#255#172'pU' + +#255#172'pU'#255#172'pU'#255#172'pU'#255#172'pU'#255#172'pU'#255#172'pU'#255 + +#172'pU'#255#172'pU'#255#172'pU'#255#172'pU'#255#129'T@'#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + ,#255#0#0#0#255#0#0#0#255#22#14#11#255#172'pU'#255#172'pU'#255#172'pU'#255#172 + +'pU'#255#172'pU'#255#172'pU'#255#172'pU'#255#172'pU'#255#172'pU'#255#172'pU' + +#255#172'oT'#255#170'mP'#255#163'`C'#255'xB*'#255'\1'#29#255'Y1'#31#241'BBBd' + +'CCC*MMM'#10#0#0#0#1#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#2'T7*'#29 + +'[/'#27#255'\1'#29#255#134'J0'#255#165'dG'#255#169'lQ'#255#171'pU'#255#172'q' + +'W'#255#172'qW'#255#172'qW'#255#172'qW'#255#172'qW'#255#172'qW'#255#172'qW' + +#255#172'qW'#255#172'qW'#255#172'qW'#255#172'qW'#255#172'qW'#255#172'qW'#255 + +#172'qW'#255#172'qW'#255#172'qW'#255#172'qW'#255#172'qW'#255#172'qW'#255#172 + +'qW'#255#172'qW'#255#172'qW'#255#172'qW'#255#172'qW'#255#172'qW'#255#172'qW' + +#255#172'qW'#255#172'qW'#255#172'qW'#255#172'qW'#255#172'qW'#255#172'qW'#255 + +#135'YD'#255'$'#24#18#255#3#2#2#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#8#5#4#255#30#20#16#255'xO='#255#172'qW'#255#172'qW'#255#172'qW'#255 + +#172'qW'#255#172'qW'#255#172'qW'#255#172'qW'#255#172'qW'#255#172'qW'#255#172 + +'qW'#255#172'qW'#255#172'qW'#255#172'qW'#255#172'qW'#255#172'qW'#255#172'qW' + +#255#172'qW'#255#172'qW'#255#172'qW'#255#172'qW'#255#172'qW'#255#172'qW'#255 + +#172'qW'#255#172'qW'#255#172'qW'#255#172'qW'#255#172'qW'#255#172'qW'#255#172 + +'qW'#255#172'qW'#255#172'qW'#255#172'qW'#255#14#9#7#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#20#13#10#255#172'qW'#255#172'qW'#255#172'qW'#255#172'qW'#255#172'qW' + +#255#172'qW'#255#172'qW'#255#172'qW'#255#172'qW'#255#172'qW'#255#171'oT'#255 + +#169'jM'#255#162'_A'#255's>'''#255'\1'#29#255'X2 '#234'CCCXDDD"@@@'#8#0#0#0#1 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#1'C><'#9'[/'#27#247'\1'#29#255 + +'}F-'#255#164'bE'#255#169'lO'#255#171'pT'#255#172'qV'#255#172'qV'#255#172'qV' + +#255#172'qV'#255#172'qV'#255#172'qV'#255#172'qV'#255#172'qV'#255#172'qV'#255 + +#172'qV'#255#172'qV'#255#172'qV'#255#172'qV'#255#172'qV'#255#172'qV'#255#172 + +'qV'#255#172'qV'#255#172'qV'#255#172'qV'#255#172'qV'#255#172'qV'#255#172'qV' + +#255#172'qV'#255#172'qV'#255#172'qV'#255#172'qV'#255#172'qV'#255#172'qV'#255 + +#172'qV'#255#172'qV'#255#154'eM'#255#22#15#11#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#25#17#13#255#136'ZE'#255#172'qV'#255#172'qV'#255#172'qV'#255#172'qV' + +#255#172'qV'#255#172'qV'#255#172'qV'#255#172'qV'#255#172'qV'#255#172'qV'#255 + +#172'qV'#255#172'qV'#255#172'qV'#255#172'qV'#255#172'qV'#255#172'qV'#255#172 + +'qV'#255#172'qV'#255#172'qV'#255#172'qV'#255#172'qV'#255#172'qV'#255#172'qV' + +#255#172'qV'#255#172'qV'#255#172'qV'#255#172'qV'#255#172'qV'#255#172'qV'#255 + +#172'qV'#255'U7*'#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#17#11#9#255#172'qV'#255#172 + +'qV'#255#172'qV'#255#172'qV'#255#172'qV'#255#172'qV'#255#172'qV'#255#172'qV' + +#255#172'qV'#255#172'qV'#255#171'oT'#255#168'jM'#255#161'^@'#255'k;%'#255'\0' + +#28#255'V3#'#220'CCCLEEE'#26'333'#5#0#0#0#1#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0'+++'#6'[/'#28#214'\1'#29#255't@)'#255#162'`B'#255#168'jO'#255 + +#172'pV'#255#173'rX'#255#173'rX'#255#173'rX'#255#173'rX'#255#173'rX'#255#173 + +'rX'#255#173'rX'#255#173'rX'#255#173'rX'#255#173'rX'#255#173'rX'#255#173'rX' + +#255#173'rX'#255#173'rX'#255#173'rX'#255#173'rX'#255#173'rX'#255#173'rX'#255 + +#173'rX'#255#173'rX'#255#173'rX'#255#173'rX'#255#173'rX'#255#173'rX'#255#173 + +'rX'#255#173'rX'#255#173'rX'#255#173'rX'#255#173'rX'#255#144'_I'#255#6#4#3 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255'Z;-'#255 + +#173'rX'#255#173'rX'#255#173'rX'#255#173'rX'#255#173'rX'#255#173'rX'#255#173 + +'rX'#255#173'rX'#255#173'rX'#255#173'rX'#255#173'rX'#255#173'rX'#255#173'rX' + +#255#173'rX'#255#173'rX'#255#173'rX'#255#173'rX'#255#173'rX'#255#173'rX'#255 + +#173'rX'#255#173'rX'#255#173'rX'#255#173'rX'#255#173'rX'#255#173'rX'#255#173 + +'rX'#255#173'rX'#255#173'rX'#255#173'rX'#255#171'pV'#255#3#2#1#255#0#0#0#255 + +#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255'!'#22#17#255#173'rX'#255#173'rX'#255#173'rX'#255#173'rX'#255#173'rX' + +#255#173'rX'#255#173'rX'#255#173'rX'#255#173'rX'#255#172'qX'#255#171'oU'#255 + +#167'hM'#255#160'[>'#255'b5!'#255'\0'#28#255'S5'''#196'EEE?CCC'#19'@@@'#4#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'UUU'#3'Z0'#29#176'\1'#29 + +#255'k:%'#255#162'^A'#255#169'jN'#255#173'qV'#255#174'sY'#255#174'sY'#255#174 + +'sY'#255#174'sY'#255#174'sY'#255#174'sY'#255#174'sY'#255#174'sY'#255#174'sY' + +#255#174'sY'#255#174'sY'#255#174'sY'#255#174'sY'#255#174'sY'#255#174'sY'#255 + +#174'sY'#255#174'sY'#255#174'sY'#255#174'sY'#255#174'sY'#255#174'sY'#255#174 + ,'sY'#255#174'sY'#255#174'sY'#255#174'sY'#255#174'sY'#255#174'sY'#255#174'sY' + +#255#151'dM'#255#4#2#2#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255 + +#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#1#1#1#255#136'YF'#255#174'sY'#255#174'sY'#255#174's' + +'Y'#255#174'sY'#255#174'sY'#255#174'sY'#255#174'sY'#255#174'sY'#255#174'sY' + +#255#174'sY'#255#174'sY'#255#174'sY'#255#174'sY'#255#174'sY'#255#174'sY'#255 + +#174'sY'#255#174'sY'#255#174'sY'#255#174'sY'#255#174'sY'#255#174'sY'#255#174 + +'sY'#255#174'sY'#255#174'sY'#255#174'sY'#255#174'sY'#255#174'sY'#255#174'sY' + +#255#174'sY'#255'5#'#27#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255 + +#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255'G.$'#255#174'sY'#255#174'sY'#255 + +#174'sY'#255#174'sY'#255#174'sY'#255#174'sY'#255#174'sY'#255#174'sY'#255#174 + +'sY'#255#174'sY'#255#172'pV'#255#167'gK'#255#153'X:'#255'^3'#31#255'\0'#28 + +#255'Q7+'#166'BBB2777'#14#0#0#0#2#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#2'Z0'#29#137'\0'#28#255'a5!'#255#160']>'#255#168'jN'#255 + +#173'sY'#255#175'v\'#255#175'v\'#255#175'v\'#255#175'v\'#255#175'v\'#255#175 + +'v\'#255#175'v\'#255#175'v\'#255#175'v\'#255#175'v\'#255#175'v\'#255#175'v\' + +#255#175'v\'#255#175'v\'#255#175'v\'#255#175'v\'#255#175'v\'#255#175'v\'#255 + +#175'v\'#255#175'v\'#255#175'v\'#255#175'v\'#255#175'v\'#255#175'v\'#255#175 + +'v\'#255#175'v\'#255#175'v\'#255#175'v\'#255#29#20#15#255#0#0#0#255#0#0#0#255 + +#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#8 + +#5#4#255#169'rX'#255#175'v\'#255#175'v\'#255#175'v\'#255#175'v\'#255#175'v\' + +#255#175'v\'#255#175'v\'#255#175'v\'#255#175'v\'#255#175'v\'#255#175'v\'#255 + +#175'v\'#255#175'v\'#255#175'v\'#255#175'v\'#255#175'v\'#255#175'v\'#255#175 + +'v\'#255#175'v\'#255#175'v\'#255#175'v\'#255#175'v\'#255#175'v\'#255#175'v\' + +#255#175'v\'#255#175'v\'#255#175'v\'#255#175'v\'#255#156'jR'#255#1#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255'yQ?'#255#175'v\'#255#175'v\'#255#175'v\'#255#175'v\'#255#175'v\'#255 + +#175'v\'#255#175'v\'#255#175'v\'#255#175'v\'#255#174'u['#255#172'qV'#255#166 + +'gJ'#255#143'S6'#255'^2'#31#255'[/'#27#255'O;2'#130'CCC&999'#9#0#0#0#1#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#1'Z0'#29'a\0'#28#255 + +'^3'#31#255#153'W;'#255#168'jN'#255#174'tZ'#255#176'x_'#255#176'y_'#255#176 + +'y_'#255#176'y_'#255#176'y_'#255#176'y_'#255#176'y_'#255#176'y_'#255#176'y_' + +#255#176'y_'#255#176'y_'#255#176'y_'#255#176'y_'#255#176'y_'#255#176'y_'#255 + +#176'y_'#255#176'y_'#255#176'y_'#255#176'y_'#255#176'y_'#255#176'y_'#255#176 + +'y_'#255#176'y_'#255#176'y_'#255#176'y_'#255#176'y_'#255#176'y_'#255'oL='#255 + +#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255']@2'#255#176'y_'#255#176'y_'#255#176 + +'y_'#255#176'y_'#255#176'y_'#255#176'y_'#255'Z=1'#255')'#28#22#255#26#18#14 + +#255#14#10#8#255#10#7#5#255#23#16#12#255'+'#30#23#255'E0&'#255#138'_J'#255 + +#176'y_'#255#176'y_'#255#176'y_'#255#176'y_'#255#176'y_'#255#176'y_'#255#176 + +'y_'#255#176'y_'#255#176'y_'#255#176'y_'#255#176'y_'#255#176'y_'#255#176'y_' + +#255#176'y_'#255'#'#24#19#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#172'w]'#255#176'y_'#255#176'y_'#255 + +#176'y_'#255#176'y_'#255#176'y_'#255#176'y_'#255#176'y_'#255#176'y_'#255#176 + +'y_'#255#175'w^'#255#172'rW'#255#165'fI'#255#134'K2'#255']1'#30#255'[/'#27 + +#255'H?:ZBBB'#27'+++'#6#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0'X/'#29'7[/'#27#255'^2'#31#255#141'P5'#255#167'hK'#255#174 + +'sY'#255#177'x_'#255#177'za'#255#177'za'#255#177'za'#255#177'za'#255#177'za' + +#255#177'za'#255#177'za'#255#177'za'#255#177'za'#255#177'za'#255#177'za'#255 + +#177'za'#255#177'za'#255#177'za'#255#177'za'#255#177'za'#255#177'za'#255#177 + +'za'#255#177'za'#255#177'za'#255#177'za'#255#177'za'#255#177'za'#255#177'za' + +#255#177'za'#255#177'za'#255#9#6#5#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255'%'#25#20#255#177'za'#255#177'za'#255#177'za'#255#177'za'#255'bD6'#255#8 + +#6#4#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255'>+"'#255#175'za'#255#177'za'#255#177'za'#255#177'za' + +#255#177'za'#255#177'za'#255#177'za'#255#177'za'#255#177'za'#255#177'za'#255 + +#177'za'#255#177'za'#255#177'za'#255#136'^K'#255#0#0#0#255#0#0#0#255#0#0#0 + ,#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#16#11#9#255#177'za'#255#177 + +'za'#255#177'za'#255#177'za'#255#177'za'#255#177'za'#255#177'za'#255#177'za' + +#255#177'za'#255#177'za'#255#176'x^'#255#172'qV'#255#164'cF'#255'{E,'#255']1' + +#30#255'Z0'#29#245'DDD'#255 + +'`5!'#255'\0'#28#255'T5'''#155'DDD'#30'III'#7#0#0#0#1#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'Z/'#28'w\0'#28#255 + +'`5!'#255#157'\?'#255#172'pU'#255#179'}d'#255#181#129'i'#255#182#129'j'#255 + +#182#129'j'#255#182#129'j'#255#182#129'j'#255#182#129'j'#255#182#129'j'#255 + +#182#129'j'#255#182#129'j'#255#182#129'j'#255#182#129'j'#255#182#129'j'#255 + +#182#129'j'#255#182#129'j'#255#182#129'j'#255#182#129'j'#255#182#129'j'#255 + +#182#129'j'#255#182#129'j'#255#182#129'j'#255#182#129'j'#255#182#129'j'#255 + +#182#129'j'#255#182#129'j'#255#182#129'j'#255'.!'#27#255#0#0#0#255#0#0#0#255 + +#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#2#1#1#255#166'va'#255#182#129'j'#255#182#129'j'#255'A.&' + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#9#6#5#255#170'yd'#255#182#129'j'#255#182#129'j'#255#182#129'j'#255#182 + +#129'j'#255#182#129'j'#255#182#129'j'#255#182#129'j'#255#182#129'j'#255#182 + +#129'j'#255#182#129'j'#255#182#129'j'#255#8#6#5#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#135'`O'#255#182#129'j'#255#182#129'j'#255#182#129'j'#255 + +#182#129'j'#255#182#129'j'#255#182#129'j'#255#182#129'j'#255#182#129'j'#255 + +#182#129'j'#255#182#129'j'#255#181#128'h'#255#177'za'#255#169'kP'#255#139'Q7' + +#255'^3'#31#255'\0'#28#255'N9/\GGG'#18'UUU'#3#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'X.'#26'4\0'#28#255 + ,'^3'#31#255#141'S8'#255#170'mQ'#255#179'|c'#255#182#130'k'#255#184#132'm'#255 + +#184#132'm'#255#184#132'm'#255#184#132'm'#255#184#132'm'#255#184#132'm'#255 + +#184#132'm'#255#184#132'm'#255#184#132'm'#255#184#132'm'#255#184#132'm'#255 + +#184#132'm'#255#184#132'm'#255#184#132'm'#255#184#132'm'#255#184#132'm'#255 + +#184#132'm'#255#184#132'm'#255#184#132'm'#255#184#132'm'#255#184#132'm'#255 + +#184#132'm'#255#184#132'm'#255#184#132'm'#255#20#15#12#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255'N8.'#255#184#132'm'#255#184#132'm'#255#184#132'm' + +#255#22#16#13#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255 + +#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#21#15#13#255#182#130'm'#255#184#132'm'#255#184#132 + +'m'#255#184#132'm'#255#184#132'm'#255#184#132'm'#255#184#132'm'#255#184#132 + +'m'#255#184#132'm'#255#184#132'm'#255#184#132'm'#255'N8.'#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#23#17#13#255#184#132'm'#255#184#132'm'#255#184#132'm'#255 + +#184#132'm'#255#184#132'm'#255#184#132'm'#255#184#132'm'#255#184#132'm'#255 + +#184#132'm'#255#184#132'm'#255#183#131'l'#255#182#129'j'#255#177'x_'#255#167 + +'hK'#255'zG/'#255']1'#30#255'Z0'#28#241'@@@(MMM'#10#0#0#0#1#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'='#31 + +#18#3'[/'#27#238']1'#30#255'{G/'#255#167'hL'#255#177'za'#255#183#131'l'#255 + +#185#134'p'#255#185#134'p'#255#185#134'p'#255#185#134'p'#255#185#134'p'#255 + +#185#134'p'#255#185#134'p'#255#185#134'p'#255#185#134'p'#255#185#134'p'#255 + +#185#134'p'#255#185#134'p'#255#185#134'p'#255#185#134'p'#255#185#134'p'#255 + +#185#134'p'#255#185#134'p'#255#185#134'p'#255#185#134'p'#255#185#134'p'#255 + +#185#134'p'#255#185#134'p'#255#185#134'p'#255#185#134'p'#255#26#19#16#255#0#0 + +#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255 + +#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#12#9#7#255#185#134'p'#255#185#134'p'#255#185#134'p' + +#255#185#134'p'#255#3#2#2#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255'U>4'#255#185#134'p'#255#185 + +#134'p'#255#185#134'p'#255#185#134'p'#255#185#134'p'#255#185#134'p'#255#185 + +#134'p'#255#185#134'p'#255#185#134'p'#255#185#134'p'#255#185#134'p'#255#25#18 + +#15#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255 + +#0#0#0#255#0#0#0#255#0#0#0#255'xWI'#255#185#134'p'#255#185#134'p'#255#185#134 + +'p'#255#185#134'p'#255#185#134'p'#255#185#134'p'#255#185#134'p'#255#185#134 + +'p'#255#185#134'p'#255#185#134'p'#255#184#134'o'#255#182#129'j'#255#175'v\' + +#255#165'dG'#255'h;&'#255'\1'#29#255'X2 '#193'==='#25'+++'#6#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0'[/'#27#170'\1'#29#255'f9%'#255#164'bG'#255#175'v]'#255#183#131 + +'l'#255#186#135'r'#255#186#137's'#255#186#137's'#255#186#137's'#255#186#137 + +'s'#255#186#137's'#255#186#137's'#255#186#137's'#255#186#137's'#255#186#137 + +'s'#255#186#137's'#255#186#137's'#255#186#137's'#255#186#137's'#255#186#137 + +'s'#255#186#137's'#255#186#137's'#255#186#137's'#255#186#137's'#255#186#137 + +'s'#255#186#137's'#255#186#137's'#255#186#137's'#255#186#137's'#255'$'#27#23 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#129'_P'#255#186#137's'#255#186#137's'#255 + +#186#137's'#255#186#137's'#255#1#1#1#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255' '#23#19#255#186 + +#137's'#255#186#137's'#255#186#137's'#255#186#137's'#255#186#137's'#255#186 + +#137's'#255#186#137's'#255#186#137's'#255#186#137's'#255#186#137's'#255#186 + +#137's'#255#172#127'j'#255#7#5#4#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255 + +#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#12#9#7#255#186#137's'#255#186#137's' + +#255#186#137's'#255#186#137's'#255#186#137's'#255#186#137's'#255#186#137's' + +#255#186#137's'#255#186#137's'#255#186#137's'#255#186#137's'#255#185#135'q' + +#255#181#129'i'#255#173'qW'#255#149'X='#255'`5!'#255'\0'#28#255'V4%'#127'333' + +#15#0#0#0#3#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'Z/'#27'O\0'#28#255'_4 '#255#144'U:' + +#255#172'qV'#255#182#130'k'#255#187#137't'#255#188#139'u'#255#188#140'v'#255 + +#188#140'v'#255#188#140'v'#255#188#140'v'#255#188#140'v'#255#188#140'v'#255 + +#188#140'v'#255#188#140'v'#255#188#140'v'#255#188#140'v'#255#188#140'v'#255 + ,#188#140'v'#255#188#140'v'#255#188#140'v'#255#188#140'v'#255#188#140'v'#255 + +#188#140'v'#255#188#140'v'#255#188#140'v'#255#188#140'v'#255#188#140'v'#255 + +#188#140'v'#255'1$'#31#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255 + +#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255':+$'#255#188#140'v'#255#188#140 + +'v'#255#188#140'v'#255#188#140'v'#255#188#140'v'#255#1#1#1#255#0#0#0#255#0#0 + +#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255 + +#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#4#3#3#255#188#140'v'#255#188#140'v'#255#188#140'v'#255#188#140'v'#255 + +#188#140'v'#255#188#140'v'#255#188#140'v'#255#188#140'v'#255#188#140'v'#255 + +#188#140'v'#255#188#140'v'#255#188#140'v'#255#188#140'v'#255'}]N'#255'6("' + +#255#14#11#9#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255'S>5'#255 + +#188#140'v'#255#188#140'v'#255#188#140'v'#255#188#140'v'#255#188#140'v'#255 + +#188#140'v'#255#188#140'v'#255#188#140'v'#255#188#140'v'#255#188#140'v'#255 + +#188#139'u'#255#186#136'r'#255#180'~f'#255#169'kP'#255'|H1'#255'^2'#31#255'[' + +'/'#27#249'L=6+III'#7#0#0#0#1#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'[/'#27#5'[/'#27#235 + +']1'#30#255'wD/'#255#169'jO'#255#180#127'g'#255#187#137'u'#255#189#141'x'#255 + +#189#142'y'#255#189#142'y'#255#189#142'y'#255#189#142'y'#255#189#142'y'#255 + +#189#142'y'#255#189#142'y'#255#189#142'y'#255#189#142'y'#255#189#142'y'#255 + +#189#142'y'#255#189#142'y'#255#189#142'y'#255#189#142'y'#255#189#142'y'#255 + +#189#142'y'#255#189#142'y'#255#189#142'y'#255#189#142'y'#255#189#142'y'#255 + +#189#142'y'#255#189#142'y'#255'J7/'#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#16#12#11#255#187#140'y'#255 + +#189#142'y'#255#189#142'y'#255#189#142'y'#255#189#142'y'#255#189#142'y'#255#1 + +#1#1#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#181#136'u'#255#189#142'y'#255#189#142 + +'y'#255#189#142'y'#255#189#142'y'#255#189#142'y'#255#189#142'y'#255#189#142 + +'y'#255#189#142'y'#255#189#142'y'#255#189#142'y'#255#189#142'y'#255#189#142 + +'y'#255#189#142'y'#255#189#142'y'#255#189#142'y'#255#11#8#7#255#0#0#0#255#0#0 + +#0#255#0#0#0#255#1#1#1#255#181#136's'#255#189#142'y'#255#189#142'y'#255#189 + +#142'y'#255#189#142'y'#255#189#142'y'#255#189#142'y'#255#189#142'y'#255#189 + +#142'y'#255#189#142'y'#255#189#142'y'#255#189#141'x'#255#186#136'q'#255#177 + +'za'#255#164'dG'#255'f:&'#255'\1'#29#255'Y1'#31#186'@@@'#16'UUU'#3#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'Z/'#27#147'\1'#29#255'b8$'#255#160'bF'#255 + +#177'y`'#255#186#137's'#255#190#143'z'#255#191#145'|'#255#191#145'|'#255#191 + +#145'|'#255#191#145'|'#255#191#145'|'#255#191#145'|'#255#191#145'|'#255#191 + +#145'|'#255#191#145'|'#255#191#145'|'#255#191#145'|'#255#191#145'|'#255#191 + +#145'|'#255#191#145'|'#255#191#145'|'#255#191#145'|'#255#191#145'|'#255#191 + +#145'|'#255#191#145'|'#255#191#145'|'#255#191#145'|'#255#191#145'|'#255#162 + +'{i'#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#1#1#1#255#162'{i'#255#191#145'|'#255#191#145'|'#255#191#145'|'#255 + +#191#145'|'#255#191#145'|'#255#191#145'|'#255#2#1#1#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#1 + +#1#1#255#191#145'|'#255#191#145'|'#255#191#145'|'#255#191#145'|'#255#191#145 + +'|'#255#191#145'|'#255#191#145'|'#255#191#145'|'#255#191#145'|'#255#191#145 + +'|'#255#191#145'|'#255#191#145'|'#255#191#145'|'#255#191#145'|'#255#191#145 + +'|'#255#191#145'|'#255#5#4#3#255#0#0#0#255#0#0#0#255#0#0#0#255'&'#29#25#255 + +#191#145'|'#255#191#145'|'#255#191#145'|'#255#191#145'|'#255#191#145'|'#255 + +#191#145'|'#255#191#145'|'#255#191#145'|'#255#191#145'|'#255#191#145'|'#255 + +#191#145'|'#255#189#142'y'#255#184#134'o'#255#174'sY'#255#143'U;'#255'`5!' + +#255'\0'#28#255'U3$`@@@'#8#0#0#0#1#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0'Z.'#27'5\0'#28#255'_4 '#255#137'Q8'#255#173'rX'#255#184#134'o'#255#190#144 + +'{'#255#192#147#127#255#192#147#127#255#192#147#127#255#192#147#127#255#192 + +#147#127#255#192#147#127#255#192#147#127#255#192#147#127#255#192#147#127#255 + +#192#147#127#255#192#147#127#255#192#147#127#255#192#147#127#255#192#147#127 + +#255#192#147#127#255#192#147#127#255#192#147#127#255#192#147#127#255#192#147 + +#127#255#192#147#127#255#192#147#127#255#192#147#127#255#192#147#127#255#14 + ,#11#9#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255' ' + +#24#21#255#192#147#127#255#192#147#127#255#192#147#127#255#192#147#127#255 + +#192#147#127#255#192#147#127#255#192#147#127#255#4#3#3#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#8#6#5#255#192#147#127#255#192#147#127#255#192#147#127#255#192#147#127 + +#255#192#147#127#255#192#147#127#255#192#147#127#255#192#147#127#255#192#147 + +#127#255#192#147#127#255#192#147#127#255#192#147#127#255#192#147#127#255#192 + +#147#127#255#192#147#127#255#192#147#127#255#1#1#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#137'iZ'#255#192#147#127#255#192#147#127#255#192#147#127#255#192#147 + +#127#255#192#147#127#255#192#147#127#255#192#147#127#255#192#147#127#255#192 + +#147#127#255#192#147#127#255#192#146'~'#255#189#142'y'#255#182#129'j'#255#169 + +'lP'#255'uD.'#255'^2'#31#255'[/'#28#237'NFB'#21'UUU'#3#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'[/'#27#211']1'#30#255'l>)'#255#167'iM' + +#255#181#127'g'#255#190#143'z'#255#193#148#128#255#194#149#130#255#194#149 + +#130#255#194#149#130#255#194#149#130#255#194#149#130#255#194#149#130#255#194 + +#149#130#255#194#149#130#255#194#149#130#255#194#149#130#255#194#149#130#255 + +#194#149#130#255#194#149#130#255#194#149#130#255#194#149#130#255#194#149#130 + +#255#194#149#130#255#194#149#130#255#194#149#130#255#194#149#130#255#194#149 + +#130#255#194#149#130#255'G60'#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0 + +#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255 + +#0#0#0#255#0#0#0#255'ZE<'#255#194#149#130#255#194#149#130#255#194#149#130#255 + +#194#149#130#255#194#149#130#255#194#149#130#255#194#149#130#255#7#6#5#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#23#17#15#255#194#149#130#255#194#149#130#255#194#149#130 + +#255#194#149#130#255#194#149#130#255#194#149#130#255#194#149#130#255#194#149 + +#130#255#194#149#130#255#194#149#130#255#194#149#130#255#194#149#130#255#194 + +#149#130#255#194#149#130#255#194#149#130#255#179#137'x'#255#0#0#0#255#0#0#0 + +#255#0#0#0#255'-#'#30#255#194#149#130#255#194#149#130#255#194#149#130#255#194 + +#149#130#255#194#149#130#255#194#149#130#255#194#149#130#255#194#149#130#255 + +#194#149#130#255#194#149#130#255#194#149#130#255#192#147#127#255#188#140'v' + +#255#177'za'#255#156'_D'#255'a6#'#255'\1'#29#255'Y1'#31#153'@@@'#8#0#0#0#1#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'Z/'#27']\0'#28#255 + +'`5!'#255#143'V='#255#175'v]'#255#187#138'u'#255#193#149#129#255#195#152#132 + +#255#195#152#133#255#195#152#133#255#195#152#133#255#195#152#133#255#195#152 + +#133#255#195#152#133#255#195#152#133#255#195#152#133#255#195#152#133#255#195 + +#152#133#255#195#152#133#255#195#152#133#255#195#152#133#255#195#152#133#255 + +#195#152#133#255#195#152#133#255#195#152#133#255#195#152#133#255#195#152#133 + +#255#195#152#133#255#195#152#133#255#170#133't'#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#172#133'u'#255#195#152#133#255#195#152 + +#133#255#195#152#133#255#195#152#133#255#195#152#133#255#195#152#133#255#146 + +'rd'#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255'_JA'#255#195#152#133#255#195#152#133 + +#255#195#152#133#255#195#152#133#255#195#152#133#255#195#152#133#255#195#152 + +#133#255#195#152#133#255#195#152#133#255#195#152#133#255#195#152#133#255#195 + +#152#133#255#195#152#133#255#195#152#133#255#195#152#133#255#140'm`'#255#0#0 + +#0#255#0#0#0#255#6#5#4#255#186#145#127#255#195#152#133#255#195#152#133#255 + +#195#152#133#255#195#152#133#255#195#152#133#255#195#152#133#255#195#152#133 + +#255#195#152#133#255#195#152#133#255#195#152#133#255#195#152#132#255#192#147 + +#127#255#185#134'p'#255#172'pU'#255'|I2'#255'^3'#31#255'\0'#28#250'R5()UUU'#3 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'[/'#27#3 + +'[/'#27#221']1'#30#255'oA,'#255#169'lP'#255#183#131'l'#255#192#147#127#255 + +#196#154#135#255#197#155#136#255#197#155#136#255#197#155#136#255#197#155#136 + +#255#197#155#136#255#197#155#136#255#197#155#136#255#197#155#136#255#197#155 + +#136#255#197#155#136#255#197#155#136#255#197#155#136#255#197#155#136#255#197 + +#155#136#255#197#155#136#255#197#155#136#255#197#155#136#255#197#155#136#255 + +#197#155#136#255#197#155#136#255#197#155#136#255#197#155#136#255#26#20#18#255 + ,#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#8#6#5#255#197#155#136#255#197 + +#155#136#255#197#155#136#255#197#155#136#255#197#155#136#255#197#155#136#255 + +#197#155#136#255#28#22#19#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#4#3#3#255#193#153#134#255 + +#197#155#136#255#197#155#136#255#197#155#136#255#197#155#136#255#197#155#136 + +#255#197#155#136#255#197#155#136#255#197#155#136#255#197#155#136#255#197#155 + +#136#255#197#155#136#255#197#155#136#255#197#155#136#255#197#155#136#255#197 + +#155#136#255#182#143'~'#255'=0*'#255#7#5#5#255#130'fY'#255#197#155#136#255 + +#197#155#136#255#197#155#136#255#197#155#136#255#197#155#136#255#197#155#136 + +#255#197#155#136#255#197#155#136#255#197#155#136#255#197#155#136#255#196#154 + +#136#255#195#152#133#255#190#144'{'#255#180'~f'#255#159'bG'#255'c8%'#255'\1' + +#29#255'Z0'#30#163'III'#7#0#0#0#1#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'[/'#27'g\0'#28#255'a6#'#255#147'Y@'#255#177 + +'za'#255#190#143'z'#255#196#154#135#255#198#157#139#255#198#157#139#255#198 + +#157#139#255#198#157#139#255#198#157#139#255#198#157#139#255#198#157#139#255 + +#198#157#139#255#198#157#139#255#198#157#139#255#198#157#139#255#198#157#139 + +#255#198#157#139#255#198#157#139#255#198#157#139#255#198#157#139#255#198#157 + +#139#255#198#157#139#255#198#157#139#255#198#157#139#255#198#157#139#255#198 + +#157#139#255'<0+'#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255'*!'#29#255 + +#198#157#139#255#198#157#139#255#198#157#139#255#198#157#139#255#198#157#139 + +#255#198#157#139#255#164#130's'#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255'?2,'#255#198 + +#157#139#255#198#157#139#255#198#157#139#255#198#157#139#255#198#157#139#255 + +#198#157#139#255#198#157#139#255#198#157#139#255#198#157#139#255#198#157#139 + +#255#198#157#139#255#198#157#139#255#198#157#139#255#198#157#139#255#198#157 + +#139#255#198#157#139#255#198#157#139#255#198#157#139#255#198#157#139#255#198 + +#157#139#255#198#157#139#255#198#157#139#255#198#157#139#255#198#157#139#255 + +#198#157#139#255#198#157#139#255#198#157#139#255#198#157#139#255#198#157#139 + +#255#198#157#139#255#198#156#138#255#195#152#132#255#187#138't'#255#173'sY' + +#255#127'L5'#255'^3'#31#255'\0'#28#252'U3$,'#128#128#128#2#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'[/'#27#7 + +'[/'#27#229'^2'#31#255'qB.'#255#171'nS'#255#185#134'p'#255#194#151#131#255 + +#198#158#140#255#200#160#142#255#200#160#142#255#200#160#142#255#200#160#142 + +#255#200#160#142#255#200#160#142#255#200#160#142#255#200#160#142#255#200#160 + +#142#255#200#160#142#255#200#160#142#255#200#160#142#255#200#160#142#255#200 + +#160#142#255#200#160#142#255#200#160#142#255#200#160#142#255#200#160#142#255 + +#200#160#142#255#200#160#142#255#200#160#142#255'9.)'#255#0#0#0#255#0#0#0#255 + +#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255'hSJ'#255#200#160#142#255#200#160#142#255#200#160#142 + +#255#200#160#142#255#200#160#142#255#200#160#142#255'6+'''#255#0#0#0#255#0#0 + +#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255 + +#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#6#5#5#255#184#148#131#255#200#160#142#255#200#160#142#255#200#160#142 + +#255#200#160#142#255#200#160#142#255#200#160#142#255#200#160#142#255#200#160 + +#142#255#200#160#142#255#200#160#142#255#200#160#142#255#200#160#142#255#200 + +#160#142#255#200#160#142#255#200#160#142#255#200#160#142#255#200#160#142#255 + +#200#160#142#255#200#160#142#255#200#160#142#255#200#160#142#255#200#160#142 + +#255#200#160#142#255#200#160#142#255#200#160#142#255#200#160#142#255#200#160 + +#142#255#200#160#142#255#200#160#142#255#199#159#141#255#198#157#139#255#192 + +#147#127#255#181#127'g'#255#161'dI'#255'd:&'#255'\1'#29#255'Z0'#29#171'@@@'#4 + +#0#0#0#1#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0'[/'#27'q\1'#29#255'a6#'#255#143'W?'#255#177'za'#255 + +#191#144'|'#255#198#157#139#255#200#161#144#255#201#162#145#255#201#163#145 + +#255#201#163#145#255#201#163#145#255#201#163#145#255#201#163#145#255#201#163 + +#145#255#201#163#145#255#201#163#145#255#201#163#145#255#201#163#145#255#201 + +#163#145#255#201#163#145#255#201#163#145#255#201#163#145#255#201#163#145#255 + +#201#163#145#255#201#163#145#255#201#163#145#255#201#163#145#255'=2,'#255#0#0 + ,#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255 + +#0#0#0#255#0#0#0#255#0#0#0#255'!'#27#24#255#197#161#143#255#201#163#145#255 + +#201#163#145#255#201#163#145#255#201#163#145#255#201#163#145#255#197#161#143 + +#255#3#2#2#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#1#1#1#255#149'zl'#255#201#163#145#255#201#163#145 + +#255#201#163#145#255#201#163#145#255#201#163#145#255#201#163#145#255#201#163 + +#145#255#201#163#145#255#201#163#145#255#201#163#145#255#201#163#145#255#201 + +#163#145#255#201#163#145#255#201#163#145#255#201#163#145#255#201#163#145#255 + +#201#163#145#255#201#163#145#255#201#163#145#255#201#163#145#255#201#163#145 + +#255#201#163#145#255#201#163#145#255#201#163#145#255#201#163#145#255#201#163 + +#145#255#201#163#145#255#201#163#145#255#201#163#145#255#201#162#145#255#200 + +#161#143#255#197#155#136#255#187#138'u'#255#173'rX'#255'|I3'#255'_4 '#255'\0' + +#28#253'W1 2'#0#0#0#1#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'[/'#27#6'\0'#28#216'^2'#31#255 + +'i=)'#255#165'jP'#255#184#133'n'#255#196#152#134#255#201#162#145#255#202#164 + +#148#255#202#165#148#255#202#165#148#255#202#165#148#255#202#165#148#255#202 + +#165#148#255#202#165#148#255#202#165#148#255#202#165#148#255#202#165#148#255 + +#202#165#148#255#202#165#148#255#202#165#148#255#202#165#148#255#202#165#148 + +#255#202#165#148#255#202#165#148#255#202#165#148#255#202#165#148#255#202#165 + +#148#255'E82'#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#2#2#2#255#1#1#1#255 + +#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255'.&"'#255#202#165#148#255#202#165#148 + +#255#202#165#148#255#202#165#148#255#202#165#148#255#202#165#148#255#202#165 + +#148#255#146'wk'#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255'eRI'#255#202#165#148#255#202#165#148 + +#255#202#165#148#255#202#165#148#255#202#165#148#255#202#165#148#255#202#165 + +#148#255#202#165#148#255#202#165#148#255#202#165#148#255#202#165#148#255#202 + +#165#148#255#202#165#148#255#202#165#148#255#202#165#148#255#202#165#148#255 + +#202#165#148#255#202#165#148#255#202#165#148#255#202#165#148#255#202#165#148 + +#255#202#165#148#255#202#165#148#255#202#165#148#255#202#165#148#255#202#165 + +#148#255#202#165#148#255#202#165#148#255#202#165#148#255#202#165#148#255#202 + +#164#147#255#200#160#143#255#193#148#128#255#180'~f'#255#151'^D'#255'a7$'#255 + +'\1'#29#255'Z0'#28#156'UUU'#3#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'[/'#27 + +'D\0'#28#255'`5!'#255#128'N8'#255#175'v]'#255#190#143'{'#255#200#159#142#255 + +#203#165#150#255#204#167#151#255#204#167#151#255#204#167#151#255#204#167#151 + +#255#204#167#151#255#204#167#151#255#204#167#151#255#204#167#151#255#204#167 + +#151#255#204#167#151#255#204#167#151#255#204#167#151#255#204#167#151#255#204 + +#167#151#255#204#167#151#255#204#167#151#255#204#167#151#255#204#167#151#255 + +#204#167#151#255'N?9'#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255'vaW'#255 + +#204#167#151#255#160#131'w'#255'cRI'#255'WG@'#255#168#137'|'#255#204#167#151 + +#255#204#167#151#255#204#167#151#255#204#167#151#255#204#167#151#255#204#167 + +#151#255#204#167#151#255#204#167#151#255#145'wk'#255#0#0#0#255#0#0#0#255#0#0 + +#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255 + +#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255'G:4'#255#204#167 + +#151#255#204#167#151#255#204#167#151#255#204#167#151#255#204#167#151#255#204 + +#167#151#255#204#167#151#255#204#167#151#255#204#167#151#255#204#167#151#255 + +#204#167#151#255#204#167#151#255#204#167#151#255#204#167#151#255#204#167#151 + +#255#204#167#151#255#204#167#151#255#204#167#151#255#204#167#151#255#204#167 + +#151#255#204#167#151#255#204#167#151#255#204#167#151#255#204#167#151#255#204 + +#167#151#255#204#167#151#255#204#167#151#255#204#167#151#255#204#167#151#255 + +#204#167#151#255#204#167#150#255#202#165#148#255#198#155#138#255#186#137's' + +#255#171'nU'#255'oB.'#255'^2'#31#255'\0'#28#235'V2"'#21#0#0#0#1#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'[/'#27#169'\1'#29#255'c9&'#255#155'aH'#255 + +#182#128'j'#255#195#152#133#255#202#164#148#255#205#169#154#255#206#169#155 + +#255#206#169#155#255#206#169#155#255#206#169#155#255#206#169#155#255#206#169 + +#155#255#206#169#155#255#206#169#155#255#206#169#155#255#206#169#155#255#206 + +#169#155#255#206#169#155#255#206#169#155#255#206#169#155#255#206#169#155#255 + +#206#169#155#255#206#169#155#255#206#169#155#255'VGA'#255#0#0#0#255#0#0#0#255 + ,#0#0#0#255#5#4#4#255#206#169#155#255#206#169#155#255#206#169#155#255#206#169 + +#155#255#206#169#155#255#206#169#155#255#206#169#155#255#206#169#155#255#206 + +#169#155#255#206#169#155#255#206#169#155#255#206#169#155#255#206#169#155#255 + +#206#169#155#255#152'}r'#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#2#1#1#255'vaY'#255#206#169#155#255#206#169#155#255#206#169 + +#155#255#206#169#155#255#206#169#155#255#206#169#155#255#206#169#155#255#206 + +#169#155#255#206#169#155#255#206#169#155#255#206#169#155#255#206#169#155#255 + +#206#169#155#255#206#169#155#255#206#169#155#255#206#169#155#255#206#169#155 + +#255#206#169#155#255#206#169#155#255#206#169#155#255#206#169#155#255#206#169 + +#155#255#206#169#155#255#206#169#155#255#206#169#155#255#206#169#155#255#206 + +#169#155#255#206#169#155#255#206#169#155#255#206#169#155#255#206#169#155#255 + +#205#167#152#255#201#162#145#255#192#147#127#255#177'za'#255#138'T='#255'`6"' + +#255'\1'#29#255'[0'#29'e'#0#0#0#1#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0'[/'#27#27'\0'#28#243'^3'#31#255'pC/'#255#171'oU'#255#188#138'u' + +#255#199#158#141#255#205#169#154#255#207#171#157#255#207#172#158#255#207#172 + +#158#255#207#172#158#255#207#172#158#255#207#172#158#255#207#172#158#255#207 + +#172#158#255#207#172#158#255#207#172#158#255#207#172#158#255#207#172#158#255 + +#207#172#158#255#207#172#158#255#207#172#158#255#207#172#158#255#207#172#158 + +#255#207#172#158#255'~i`'#255#0#0#0#255#0#0#0#255#0#0#0#255#22#18#16#255#207 + +#172#158#255#207#172#158#255#207#172#158#255#207#172#158#255#207#172#158#255 + +#207#172#158#255#207#172#158#255#207#172#158#255#207#172#158#255#207#172#158 + +#255#207#172#158#255#207#172#158#255#207#172#158#255#207#172#158#255#207#172 + +#158#255'/''$'#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#9#7#7#255 + +#164#136'~'#255#207#172#158#255#207#172#158#255#207#172#158#255#207#172#158 + +#255#207#172#158#255#207#172#158#255#207#172#158#255#207#172#158#255#207#172 + +#158#255#207#172#158#255#207#172#158#255#207#172#158#255#207#172#158#255#207 + +#172#158#255#207#172#158#255#207#172#158#255#207#172#158#255#207#172#158#255 + +#207#172#158#255#207#172#158#255#207#172#158#255#207#172#158#255#207#172#158 + +#255#207#172#158#255#207#172#158#255#207#172#158#255#207#172#158#255#207#172 + +#158#255#207#172#158#255#207#172#158#255#207#172#158#255#207#171#157#255#204 + +#167#151#255#196#153#136#255#183#131'l'#255#160'fK'#255'f;('#255']1'#30#255 + +'[/'#27#199'te^'#3#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0'[/'#27'q\0'#28#255'`6"'#255#130'P9'#255#177'x`'#255#192#146 + +#127#255#203#164#149#255#208#173#159#255#209#175#161#255#209#175#161#255#209 + +#175#161#255#209#175#161#255#209#175#161#255#209#175#161#255#209#175#161#255 + +#209#175#161#255#209#175#161#255#209#175#161#255#209#175#161#255#209#175#161 + +#255#209#175#161#255#209#175#161#255#209#175#161#255#209#175#161#255#209#175 + +#161#255#199#167#153#255#0#0#0#255#0#0#0#255#0#0#0#255'.&#'#255#209#175#161 + +#255#209#175#161#255#209#175#161#255#209#175#161#255#209#175#161#255#209#175 + +#161#255#209#175#161#255#209#175#161#255#209#175#161#255#209#175#161#255#209 + +#175#161#255#209#175#161#255#209#175#161#255#209#175#161#255#209#175#161#255 + +#209#175#161#255'*$!'#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255'"'#28#26#255#197#165#153#255 + +#209#175#161#255#209#175#161#255#209#175#161#255#209#175#161#255#209#175#161 + +#255#209#175#161#255#209#175#161#255#209#175#161#255#209#175#161#255#209#175 + +#161#255#209#175#161#255#209#175#161#255#209#175#161#255#209#175#161#255#209 + +#175#161#255#209#175#161#255#209#175#161#255#209#175#161#255#209#175#161#255 + +#209#175#161#255#209#175#161#255#209#175#161#255#209#175#161#255#209#175#161 + +#255#209#175#161#255#209#175#161#255#209#175#161#255#209#175#161#255#209#175 + +#161#255#209#175#161#255#209#175#161#255#209#174#160#255#207#171#157#255#200 + +#160#144#255#188#139'w'#255#171'pV'#255'rD0'#255'^3'#31#255'\0'#28#250'\2'#30 + +'1'#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0'[/'#27#1'[/'#27#184']1'#30#255'c9&'#255#148'^E'#255#182#128'j'#255#197 + +#154#136#255#206#170#155#255#210#176#163#255#211#178#164#255#211#178#165#255 + +#211#178#165#255#211#178#165#255#211#178#165#255#211#178#165#255#211#178#165 + +#255#211#178#165#255#211#178#165#255#211#178#165#255#211#178#165#255#211#178 + ,#165#255#211#178#165#255#211#178#165#255#211#178#165#255#211#178#165#255#211 + +#178#165#255#12#10#9#255#0#0#0#255#0#0#0#255'MA<'#255#211#178#165#255#211#178 + +#165#255#211#178#165#255#211#178#165#255#211#178#165#255#211#178#165#255#211 + +#178#165#255#211#178#165#255#211#178#165#255#211#178#165#255#211#178#165#255 + +#211#178#165#255#211#178#165#255#211#178#165#255#211#178#165#255#211#178#165 + +#255#211#178#165#255#178#150#139#255'D95'#255#9#7#7#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255'VIC'#255#211#178#165#255#211#178#165 + +#255#211#178#165#255#211#178#165#255#211#178#165#255#211#178#165#255#211#178 + +#165#255#211#178#165#255#211#178#165#255#211#178#165#255#211#178#165#255#211 + +#178#165#255#211#178#165#255#211#178#165#255#211#178#165#255#211#178#165#255 + +#211#178#165#255#211#178#165#255#211#178#165#255#211#178#165#255#211#178#165 + +#255#211#178#165#255#211#178#165#255#211#178#165#255#211#178#165#255#211#178 + +#165#255#211#178#165#255#211#178#165#255#211#178#165#255#211#178#165#255#211 + +#178#165#255#211#178#165#255#211#178#164#255#209#176#162#255#204#167#151#255 + +#193#148#129#255#177'x`'#255#129'P9'#255'`6"'#255'\0'#28#255'[0'#28't'#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0'[/'#27#21'\0'#28#229'^2'#31#255'i?+'#255#163'jP'#255#186#136 + +'s'#255#200#160#144#255#209#174#160#255#212#180#167#255#213#181#169#255#213 + +#181#169#255#213#181#169#255#213#181#169#255#213#181#169#255#213#181#169#255 + +#213#181#169#255#213#181#169#255#213#181#169#255#213#181#169#255#213#181#169 + +#255#213#181#169#255#213#181#169#255#213#181#169#255#213#181#169#255#213#181 + +#169#255'.''%'#255#0#0#0#255',%#'#255#200#170#159#255#213#181#169#255#213#181 + +#169#255#213#181#169#255#213#181#169#255#213#181#169#255#213#181#169#255#213 + +#181#169#255#213#181#169#255#213#181#169#255#213#181#169#255#213#181#169#255 + +#213#181#169#255#213#181#169#255#213#181#169#255#213#181#169#255#213#181#169 + +#255#213#181#169#255#213#181#169#255#213#181#169#255#139'vo'#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255'.''$'#255#213#181#169#255#213#181#169 + +#255#213#181#169#255#213#181#169#255#213#181#169#255#213#181#169#255#213#181 + +#169#255#213#181#169#255#213#181#169#255#213#181#169#255#213#181#169#255#213 + +#181#169#255#213#181#169#255#213#181#169#255#213#181#169#255#213#181#169#255 + +#213#181#169#255#213#181#169#255#213#181#169#255#213#181#169#255#213#181#169 + +#255#213#181#169#255#213#181#169#255#213#181#169#255#213#181#169#255#213#181 + +#169#255#213#181#169#255#213#181#169#255#213#181#169#255#213#181#169#255#213 + +#181#169#255#213#181#169#255#212#180#168#255#211#178#165#255#207#171#157#255 + +#197#155#137#255#182#128'j'#255#148']E'#255'c9&'#255']1'#30#255'[/'#27#179#0 + +#0#0#1#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'[/'#27'?\0'#28#252'_4 '#255'tF1'#255#172 + +'sY'#255#190#142'z'#255#203#165#150#255#211#178#164#255#213#183#170#255#214 + +#184#172#255#214#184#172#255#214#184#172#255#214#184#172#255#214#184#172#255 + +#214#184#172#255#214#184#172#255#214#184#172#255#214#184#172#255#214#184#172 + +#255#214#184#172#255#214#184#172#255#214#184#172#255#214#184#172#255#214#184 + +#172#255#127'ng'#255'{ib'#255#214#184#172#255#214#184#172#255#214#184#172#255 + +#214#184#172#255#214#184#172#255#214#184#172#255#214#184#172#255#214#184#172 + +#255#214#184#172#255#214#184#172#255#214#184#172#255#214#184#172#255#214#184 + +#172#255#214#184#172#255#214#184#172#255#214#184#172#255#214#184#172#255#214 + +#184#172#255#214#184#172#255#214#184#172#255#214#184#172#255' '#28#26#255#0#0 + +#0#255#0#0#0#255#0#0#0#255#0#0#0#255#14#12#11#255#209#180#168#255#214#184#172 + +#255#214#184#172#255#214#184#172#255#214#184#172#255#214#184#172#255#214#184 + +#172#255#214#184#172#255#214#184#172#255#214#184#172#255#214#184#172#255#214 + +#184#172#255#214#184#172#255#214#184#172#255#214#184#172#255#214#184#172#255 + +#214#184#172#255#214#184#172#255#214#184#172#255#214#184#172#255#214#184#172 + +#255#214#184#172#255#214#184#172#255#214#184#172#255#214#184#172#255#214#184 + +#172#255#214#184#172#255#214#184#172#255#214#184#172#255#214#184#172#255#214 + +#184#172#255#214#184#172#255#214#184#172#255#213#182#169#255#209#176#161#255 + +#200#161#143#255#186#135'q'#255#161'gO'#255'h=*'#255'^2'#31#255'\0'#28#226'W' + +'-'#26#19#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'[/'#27'}\1'#29#255'`6"' + +#255'|M8'#255#175'x^'#255#192#147#127#255#205#170#154#255#213#181#169#255#215 + ,#185#173#255#216#187#175#255#216#187#175#255#216#187#175#255#216#187#175#255 + +#216#187#175#255#216#187#175#255#216#187#175#255#216#187#175#255#216#187#175 + +#255#216#187#175#255#216#187#175#255#216#187#175#255#216#187#175#255#216#187 + +#175#255#216#187#175#255#216#187#175#255#216#187#175#255#216#187#175#255#216 + +#187#175#255#216#187#175#255#216#187#175#255#216#187#175#255#216#187#175#255 + +#216#187#175#255#216#187#175#255#216#187#175#255#216#187#175#255#216#187#175 + +#255#216#187#175#255#216#187#175#255#216#187#175#255#216#187#175#255#216#187 + +#175#255#216#187#175#255#216#187#175#255#216#187#175#255#187#162#151#255#0#0 + +#0#255#0#0#0#255#0#0#0#255#0#0#0#255#2#2#2#255#180#156#146#255#216#187#175 + +#255#216#187#175#255#216#187#175#255#216#187#175#255#216#187#175#255#216#187 + +#175#255#216#187#175#255#216#187#175#255#216#187#175#255#216#187#175#255#216 + +#187#175#255#216#187#175#255#216#187#175#255#216#187#175#255#216#187#175#255 + +#216#187#175#255#216#187#175#255#216#187#175#255#216#187#175#255#216#187#175 + +#255#216#187#175#255#216#187#175#255#216#187#175#255#216#187#175#255#216#187 + +#175#255#216#187#175#255#216#187#175#255#216#187#175#255#216#187#175#255#216 + +#187#175#255#216#187#175#255#216#187#175#255#215#185#173#255#211#179#166#255 + +#202#165#148#255#188#139'w'#255#167'mU'#255'nC/'#255'^3'#31#255'\0'#28#251'Z' + +'.'#27';'#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'[/'#27#2'[/'#27 + +#170'\1'#29#255'a7$'#255#130'Q<'#255#178'{c'#255#195#151#132#255#208#173#159 + +#255#215#185#173#255#217#189#178#255#217#189#178#255#217#189#178#255#217#189 + +#178#255#217#189#178#255#217#189#178#255#217#189#178#255#217#189#178#255#217 + +#189#178#255#217#189#178#255#217#189#178#255#217#189#178#255#217#189#178#255 + +#217#189#178#255#217#189#178#255#217#189#178#255#217#189#178#255#217#189#178 + +#255#217#189#178#255#217#189#178#255#217#189#178#255#217#189#178#255#217#189 + +#178#255#217#189#178#255#217#189#178#255#217#189#178#255#217#189#178#255#217 + +#189#178#255#217#189#178#255#217#189#178#255#217#189#178#255#217#189#178#255 + +#217#189#178#255#217#189#178#255#217#189#178#255#217#189#178#255'.(&'#255#0#0 + +#0#255#0#0#0#255#0#0#0#255#0#0#0#255#128'oi'#255#217#189#178#255#217#189#178 + +#255#217#189#178#255#217#189#178#255#217#189#178#255#217#189#178#255#217#189 + +#178#255#217#189#178#255#217#189#178#255#217#189#178#255#217#189#178#255#217 + +#189#178#255#217#189#178#255#217#189#178#255#217#189#178#255#217#189#178#255 + +#217#189#178#255#217#189#178#255#217#189#178#255#217#189#178#255#217#189#178 + +#255#217#189#178#255#217#189#178#255#217#189#178#255#217#189#178#255#217#189 + +#178#255#217#189#178#255#217#189#178#255#217#189#178#255#217#189#178#255#217 + +#189#178#255#217#189#178#255#217#188#177#255#213#183#170#255#205#168#153#255 + +#191#144'|'#255#170'rZ'#255'sF2'#255'`5!'#255'\0'#28#255'Z/'#27'g'#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'[/'#27#6'[/'#27 + +#188']1'#30#255'c9&'#255#136'V?'#255#180'~g'#255#197#154#136#255#209#176#162 + +#255#216#187#176#255#219#192#181#255#219#192#182#255#219#193#183#255#219#193 + +#183#255#219#193#183#255#219#193#183#255#219#193#183#255#219#193#183#255#219 + +#193#183#255#219#193#183#255#219#193#183#255#219#193#183#255#219#193#183#255 + +#219#193#183#255#219#193#183#255#219#193#183#255#219#193#183#255#219#193#183 + +#255#219#193#183#255#219#193#183#255#219#193#183#255#219#193#183#255#219#193 + +#183#255#219#193#183#255#219#193#183#255#219#193#183#255#219#193#183#255#219 + +#193#183#255#219#193#183#255#219#193#183#255#219#193#183#255#219#193#183#255 + +#219#193#183#255#219#193#183#255#158#138#131#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#1#1#1#255#131'sm'#255#219#193#183#255#219#193#183#255#219#193#183#255 + +#219#193#183#255#219#193#183#255#219#193#183#255#219#193#183#255#219#193#183 + +#255#219#193#183#255#219#193#183#255#219#193#183#255#219#193#183#255#219#193 + +#183#255#219#193#183#255#219#193#183#255#219#193#183#255#219#193#183#255#219 + +#193#183#255#219#193#183#255#219#193#183#255#219#193#183#255#219#193#183#255 + +#219#193#183#255#219#193#183#255#219#193#183#255#219#193#183#255#219#193#183 + +#255#219#193#183#255#219#193#183#255#219#193#183#255#219#193#183#255#219#192 + +#182#255#218#191#180#255#215#185#173#255#207#172#156#255#193#147#128#255#174 + +'v^'#255'wJ6'#255'`6"'#255'\1'#29#255'[/'#27'~'#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + ,#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'[/'#27#12'[/'#27#203 + +']1'#30#255'c:'''#255#141'YC'#255#181#128'h'#255#198#155#138#255#210#177#164 + +#255#217#190#178#255#220#194#184#255#221#195#185#255#221#196#186#255#221#196 + +#186#255#221#196#186#255#221#196#186#255#221#196#186#255#221#196#186#255#221 + +#196#186#255#221#196#186#255#221#196#186#255#221#196#186#255#221#196#186#255 + +#221#196#186#255#221#196#186#255#221#196#186#255#221#196#186#255#221#196#186 + +#255#221#196#186#255#221#196#186#255#221#196#186#255#221#196#186#255#221#196 + +#186#255#221#196#186#255#221#196#186#255#221#196#186#255#221#196#186#255#221 + +#196#186#255#221#196#186#255#221#196#186#255#221#196#186#255#221#196#186#255 + +#221#196#186#255're_'#255#0#0#0#255#0#0#0#255#4#4#4#255#160#142#134#255#221 + +#196#186#255#221#196#186#255#221#196#186#255#221#196#186#255#221#196#186#255 + +#221#196#186#255#221#196#186#255#221#196#186#255#221#196#186#255#221#196#186 + +#255#221#196#186#255#221#196#186#255#221#196#186#255#221#196#186#255#221#196 + +#186#255#221#196#186#255#221#196#186#255#221#196#186#255#221#196#186#255#221 + +#196#186#255#221#196#186#255#221#196#186#255#221#196#186#255#221#196#186#255 + +#221#196#186#255#221#196#186#255#221#196#186#255#221#196#186#255#221#196#186 + +#255#221#196#186#255#221#196#186#255#221#195#185#255#219#193#183#255#216#187 + +#175#255#207#172#158#255#194#148#130#255#176'x_'#255'{M8'#255'a6#'#255'\1'#29 + +#255'[/'#27#148#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'[/'#27#21'\0'#28#217']1'#30#255'c:''' + +#255#138'XB'#255#181#127'h'#255#197#156#137#255#211#178#164#255#218#191#180 + +#255#221#196#187#255#222#198#188#255#223#198#189#255#223#198#189#255#223#198 + +#189#255#223#198#189#255#223#198#189#255#223#198#189#255#223#198#189#255#223 + +#198#189#255#223#198#189#255#223#198#189#255#223#198#189#255#223#198#189#255 + +#223#198#189#255#223#198#189#255#223#198#189#255#223#198#189#255#223#198#189 + +#255#223#198#189#255#223#198#189#255#223#198#189#255#223#198#189#255#223#198 + +#189#255#223#198#189#255#223#198#189#255#223#198#189#255#223#198#189#255#223 + +#198#189#255#223#198#189#255#223#198#189#255#223#198#189#255#221#196#187#255 + +#6#6#5#255#10#9#8#255#188#167#159#255#223#198#189#255#223#198#189#255#223#198 + +#189#255#223#198#189#255#223#198#189#255#223#198#189#255#223#198#189#255#223 + +#198#189#255#223#198#189#255#223#198#189#255#223#198#189#255#223#198#189#255 + +#223#198#189#255#223#198#189#255#223#198#189#255#223#198#189#255#223#198#189 + +#255#223#198#189#255#223#198#189#255#223#198#189#255#223#198#189#255#223#198 + +#189#255#223#198#189#255#223#198#189#255#223#198#189#255#223#198#189#255#223 + +#198#189#255#223#198#189#255#223#198#189#255#223#198#189#255#223#198#189#255 + +#222#198#188#255#221#196#186#255#217#188#177#255#208#173#159#255#193#149#129 + +#255#174'w^'#255'zM8'#255'a7$'#255'\1'#29#255'[/'#27#170'[/'#27#2#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0'[/'#27' \0'#28#223']1'#30#255'c:'''#255#132'T?'#255#180 + +'~g'#255#197#155#136#255#211#178#164#255#219#193#181#255#223#198#189#255#224 + +#201#192#255#224#201#192#255#224#201#192#255#224#201#192#255#224#201#192#255 + +#224#201#192#255#224#201#192#255#224#201#192#255#224#201#192#255#224#201#192 + +#255#224#201#192#255#224#201#192#255#224#201#192#255#224#201#192#255#224#201 + +#192#255#224#201#192#255#224#201#192#255#224#201#192#255#224#201#192#255#224 + +#201#192#255#224#201#192#255#224#201#192#255#224#201#192#255#224#201#192#255 + +#224#201#192#255#224#201#192#255#224#201#192#255#224#201#192#255#224#201#192 + +#255#224#201#192#255#224#201#192#255#134'xr'#255#205#184#176#255#224#201#192 + +#255#224#201#192#255#224#201#192#255#224#201#192#255#224#201#192#255#224#201 + +#192#255#224#201#192#255#224#201#192#255#224#201#192#255#224#201#192#255#224 + +#201#192#255#224#201#192#255#224#201#192#255#224#201#192#255#224#201#192#255 + +#224#201#192#255#224#201#192#255#224#201#192#255#224#201#192#255#224#201#192 + +#255#224#201#192#255#224#201#192#255#224#201#192#255#224#201#192#255#224#201 + +#192#255#224#201#192#255#224#201#192#255#224#201#192#255#224#201#192#255#224 + +#201#192#255#224#201#192#255#223#200#191#255#222#197#187#255#217#189#178#255 + +#207#172#158#255#192#147#127#255#171'u\'#255'vI6'#255'a6#'#255'\1'#29#255'[/' + +#27#179'[/'#27#6#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + ,#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'[/'#27#25'\' + +'0'#28#209']1'#30#255'c9&'#255#128'Q='#255#177'{c'#255#195#151#133#255#209 + +#176#162#255#219#192#181#255#223#200#191#255#225#203#194#255#226#204#196#255 + +#226#204#196#255#226#204#196#255#226#204#196#255#226#204#196#255#226#204#196 + +#255#226#204#196#255#226#204#196#255#226#204#196#255#226#204#196#255#226#204 + +#196#255#226#204#196#255#226#204#196#255#226#204#196#255#226#204#196#255#226 + +#204#196#255#226#204#196#255#226#204#196#255#226#204#196#255#226#204#196#255 + +#226#204#196#255#226#204#196#255#226#204#196#255#226#204#196#255#226#204#196 + +#255#226#204#196#255#226#204#196#255#226#204#196#255#226#204#196#255#226#204 + +#196#255#226#204#196#255#226#204#196#255#226#204#196#255#226#204#196#255#226 + +#204#196#255#226#204#196#255#226#204#196#255#226#204#196#255#226#204#196#255 + +#226#204#196#255#226#204#196#255#226#204#196#255#226#204#196#255#226#204#196 + +#255#226#204#196#255#226#204#196#255#226#204#196#255#226#204#196#255#226#204 + +#196#255#226#204#196#255#226#204#196#255#226#204#196#255#226#204#196#255#226 + +#204#196#255#226#204#196#255#226#204#196#255#226#204#196#255#226#204#196#255 + +#226#204#196#255#226#204#196#255#226#203#195#255#225#202#193#255#222#198#188 + +#255#217#188#177#255#206#169#155#255#191#144'|'#255#168'qY'#255'rG3'#255'`6"' + +#255'\1'#29#255'[/'#27#159'[/'#27#4#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0'[/'#27#15'\0'#28#193']1'#30#255'b8%'#255'yM8'#255#170 + +'u\'#255#192#146'~'#255#207#171#156#255#217#189#178#255#223#200#191#255#226 + +#205#197#255#227#206#198#255#228#207#199#255#228#207#199#255#228#207#199#255 + +#228#207#199#255#228#207#199#255#228#207#199#255#228#207#199#255#228#207#199 + +#255#228#207#199#255#228#207#199#255#228#207#199#255#228#207#199#255#228#207 + +#199#255#228#207#199#255#228#207#199#255#228#207#199#255#228#207#199#255#228 + +#207#199#255#228#207#199#255#228#207#199#255#228#207#199#255#228#207#199#255 + +#228#207#199#255#228#207#199#255#228#207#199#255#228#207#199#255#228#207#199 + +#255#228#207#199#255#228#207#199#255#228#207#199#255#228#207#199#255#228#207 + +#199#255#228#207#199#255#228#207#199#255#228#207#199#255#228#207#199#255#228 + +#207#199#255#228#207#199#255#228#207#199#255#228#207#199#255#228#207#199#255 + +#228#207#199#255#228#207#199#255#228#207#199#255#228#207#199#255#228#207#199 + +#255#228#207#199#255#228#207#199#255#228#207#199#255#228#207#199#255#228#207 + +#199#255#228#207#199#255#228#207#199#255#228#207#199#255#228#207#199#255#228 + +#207#199#255#228#207#199#255#227#206#198#255#226#204#196#255#222#198#188#255 + +#215#185#173#255#202#165#148#255#187#137'u'#255#159'jR'#255'nD0'#255'`6"'#255 + +'\1'#29#255'[/'#27#137#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'[/'#27#8'[/'#27#175'\1'#29#255'`6"'#255'n' + +'D0'#255#158'iR'#255#187#137'u'#255#202#165#148#255#215#186#174#255#223#199 + +#190#255#227#205#198#255#229#208#201#255#229#209#202#255#229#210#202#255#229 + +#210#202#255#229#210#202#255#229#210#202#255#229#210#202#255#229#210#202#255 + +#229#210#202#255#229#210#202#255#229#210#202#255#229#210#202#255#229#210#202 + +#255#229#210#202#255#229#210#202#255#229#210#202#255#229#210#202#255#229#210 + +#202#255#229#210#202#255#229#210#202#255#229#210#202#255#229#210#202#255#229 + +#210#202#255#229#210#202#255#229#210#202#255#229#210#202#255#229#210#202#255 + +#229#210#202#255#229#210#202#255#229#210#202#255#229#210#202#255#229#210#202 + +#255#229#210#202#255#229#210#202#255#229#210#202#255#229#210#202#255#229#210 + +#202#255#229#210#202#255#229#210#202#255#229#210#202#255#229#210#202#255#229 + +#210#202#255#229#210#202#255#229#210#202#255#229#210#202#255#229#210#202#255 + +#229#210#202#255#229#210#202#255#229#210#202#255#229#210#202#255#229#210#202 + +#255#229#210#202#255#229#210#202#255#229#210#202#255#229#210#202#255#229#209 + +#202#255#228#207#201#255#226#204#197#255#221#196#187#255#212#180#168#255#198 + +#157#140#255#183#130'l'#255#143'^G'#255'g>+'#255'_4 '#255'\1'#29#254'[/'#27 + +'q'#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + ,#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'[/'#27#3'[/'#27#132'\1'#29#254'_4 '#255'g>+' + +#255#140'[F'#255#181#129'j'#255#198#155#138#255#211#178#165#255#221#195#185 + +#255#227#204#197#255#230#209#203#255#230#212#205#255#231#212#206#255#231#212 + +#206#255#231#212#206#255#231#212#206#255#231#212#206#255#231#212#206#255#231 + +#212#206#255#231#212#206#255#231#212#206#255#231#212#206#255#231#212#206#255 + +#231#212#206#255#231#212#206#255#231#212#206#255#231#212#206#255#231#212#206 + +#255#231#212#206#255#231#212#206#255#231#212#206#255#231#212#206#255#231#212 + +#206#255#231#212#206#255#231#212#206#255#231#212#206#255#231#212#206#255#231 + +#212#206#255#231#212#206#255#231#212#206#255#231#212#206#255#231#212#206#255 + +#231#212#206#255#231#212#206#255#231#212#206#255#231#212#206#255#231#212#206 + +#255#231#212#206#255#231#212#206#255#231#212#206#255#231#212#206#255#231#212 + +#206#255#231#212#206#255#231#212#206#255#231#212#206#255#231#212#206#255#231 + +#212#206#255#231#212#206#255#231#212#206#255#231#212#206#255#231#212#206#255 + +#231#212#206#255#231#211#206#255#230#211#205#255#229#209#201#255#225#203#194 + +#255#219#191#181#255#208#173#159#255#193#149#129#255#173'w`'#255'~Q='#255'c:' + +''''#255'^2'#31#255'\0'#28#238'[/'#27'O'#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0'[/'#27'F\0'#28#234'^2'#31#255'c:'''#255'zN:'#255#168's['#255 + +#190#143'{'#255#205#167#152#255#217#187#177#255#225#201#193#255#229#209#202 + +#255#232#213#207#255#232#214#209#255#233#215#210#255#233#215#210#255#233#215 + +#210#255#233#215#210#255#233#215#210#255#233#215#210#255#233#215#210#255#233 + +#215#210#255#233#215#210#255#233#215#210#255#233#215#210#255#233#215#210#255 + +#233#215#210#255#233#215#210#255#233#215#210#255#233#215#210#255#233#215#210 + +#255#233#215#210#255#233#215#210#255#233#215#210#255#233#215#210#255#233#215 + +#210#255#233#215#210#255#233#215#210#255#233#215#210#255#233#215#210#255#233 + +#215#210#255#233#215#210#255#233#215#210#255#233#215#210#255#233#215#210#255 + +#233#215#210#255#233#215#210#255#233#215#210#255#233#215#210#255#233#215#210 + +#255#233#215#210#255#233#215#210#255#233#215#210#255#233#215#210#255#233#215 + +#210#255#233#215#210#255#233#215#210#255#233#215#210#255#233#215#210#255#233 + +#215#210#255#232#215#209#255#232#214#208#255#231#212#206#255#228#207#201#255 + +#223#198#189#255#213#182#170#255#200#160#144#255#186#136'r'#255#158'iR'#255 + +'pE2'#255'a7$'#255']1'#30#255'\0'#28#201'[/'#27#31#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'[/'#27#26'\0'#28#193']1'#30#255'`' + +'6"'#255'iA.'#255#142']H'#255#179#128'h'#255#196#153#135#255#210#176#163#255 + +#220#194#184#255#227#205#198#255#231#212#206#255#233#216#211#255#234#217#212 + +#255#234#218#213#255#234#218#213#255#234#218#213#255#234#218#213#255#234#218 + +#213#255#234#218#213#255#234#218#213#255#234#218#213#255#234#218#213#255#234 + +#218#213#255#234#218#213#255#234#218#213#255#234#218#213#255#234#218#213#255 + +#234#218#213#255#234#218#213#255#234#218#213#255#234#218#213#255#234#218#213 + +#255#234#218#213#255#234#218#213#255#234#218#213#255#234#218#213#255#234#218 + +#213#255#234#218#213#255#234#218#213#255#234#218#213#255#234#218#213#255#234 + +#218#213#255#234#218#213#255#234#218#213#255#234#218#213#255#234#218#213#255 + +#234#218#213#255#234#218#213#255#234#218#213#255#234#218#213#255#234#218#213 + +#255#234#218#213#255#234#218#213#255#234#218#213#255#234#218#213#255#234#217 + +#212#255#234#216#211#255#233#215#210#255#230#211#205#255#226#203#195#255#218 + +#190#179#255#206#170#155#255#192#146#127#255#172'v`'#255#129'S?'#255'e<)'#255 + +'_4 '#255'\1'#29#255'[/'#27#143'[/'#27#5#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'[/'#27#3'[/'#27#127'\0'#28 + +#248'^3'#31#255'c:'''#255'sI6'#255#158'kT'#255#186#136's'#255#200#160#143#255 + ,#213#180#169#255#222#197#187#255#229#208#201#255#232#214#209#255#234#218#213 + +#255#235#219#215#255#236#220#215#255#236#220#216#255#236#220#216#255#236#220 + +#216#255#236#220#216#255#236#220#216#255#236#220#216#255#236#220#216#255#236 + +#220#216#255#236#220#216#255#236#220#216#255#236#220#216#255#236#220#216#255 + +#236#220#216#255#236#220#216#255#236#220#216#255#236#220#216#255#236#220#216 + +#255#236#220#216#255#236#220#216#255#236#220#216#255#236#220#216#255#236#220 + +#216#255#236#220#216#255#236#220#216#255#236#220#216#255#236#220#216#255#236 + +#220#216#255#236#220#216#255#236#220#216#255#236#220#216#255#236#220#216#255 + +#236#220#216#255#236#220#216#255#236#220#216#255#236#220#216#255#236#220#216 + +#255#236#220#216#255#236#220#215#255#235#219#215#255#234#217#212#255#232#213 + +#207#255#227#205#198#255#219#193#183#255#209#176#162#255#196#153#136#255#181 + +#129'l'#255#145'`K'#255'lB0'#255'a7$'#255']1'#30#255'\0'#28#231'[/'#27'O'#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'[/'#27'$\0'#28#185'\1'#29#255'`5!'#255 + +'f=*'#255#128'S>'#255#166'r['#255#188#139'v'#255#201#161#145#255#213#181#169 + +#255#223#197#189#255#229#209#202#255#233#216#210#255#235#219#215#255#236#221 + +#217#255#237#222#219#255#238#223#220#255#238#223#220#255#238#223#220#255#238 + +#223#220#255#238#223#220#255#238#223#220#255#238#223#220#255#238#223#220#255 + +#238#223#220#255#238#223#220#255#238#223#220#255#238#223#220#255#238#223#220 + +#255#238#223#220#255#238#223#220#255#238#223#220#255#238#223#220#255#238#223 + +#220#255#238#223#220#255#238#223#220#255#238#223#220#255#238#223#220#255#238 + +#223#220#255#238#223#220#255#238#223#220#255#238#223#220#255#238#223#220#255 + +#238#223#220#255#238#223#220#255#238#223#220#255#238#223#220#255#238#223#220 + +#255#237#222#219#255#237#222#218#255#236#221#217#255#235#218#214#255#232#214 + +#208#255#228#206#199#255#220#193#184#255#210#176#163#255#197#155#137#255#184 + +#134'o'#255#155'iR'#255'uI7'#255'c:'''#255'^3'#31#255'\1'#29#252'[/'#27#144 + +'[/'#27#14#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'[' + +'/'#27'U\0'#28#228']1'#30#255'`6"'#255'g>,'#255#127'R?'#255#164'qZ'#255#188 + +#139'v'#255#200#159#144#255#211#179#166#255#220#194#184#255#228#206#199#255 + +#232#214#209#255#235#219#215#255#237#222#219#255#238#225#221#255#239#225#222 + +#255#239#225#222#255#239#226#223#255#239#226#223#255#239#226#223#255#239#226 + +#223#255#239#226#223#255#239#226#223#255#239#226#223#255#239#226#223#255#239 + +#226#223#255#239#226#223#255#239#226#223#255#239#226#223#255#239#226#223#255 + +#239#226#223#255#239#226#223#255#239#226#223#255#239#226#223#255#239#226#223 + +#255#239#226#223#255#239#226#223#255#239#226#223#255#239#226#223#255#239#226 + +#223#255#239#226#223#255#239#226#223#255#239#225#222#255#238#225#221#255#238 + +#224#220#255#237#222#218#255#235#218#214#255#231#212#206#255#226#203#195#255 + +#218#191#180#255#209#174#160#255#197#154#136#255#184#132'o'#255#154'hR'#255 + +'uK8'#255'e;('#255'_4 '#255'\1'#29#255'\0'#28#197'[/'#27'/'#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'[/'#27 + +#12'[/'#27#134'\0'#28#242'^2'#31#255'a5#'#255'g>+'#255'|Q='#255#160'lV'#255 + +#184#133'p'#255#196#152#134#255#207#170#156#255#216#187#175#255#224#200#192 + +#255#230#210#203#255#234#216#211#255#236#220#216#255#238#224#220#255#239#226 + +#223#255#240#227#225#255#240#228#225#255#240#228#225#255#241#229#226#255#241 + +#229#226#255#241#229#226#255#241#229#226#255#241#229#227#255#241#229#227#255 + +#241#229#227#255#241#229#227#255#241#229#227#255#241#229#227#255#241#229#227 + +#255#241#229#227#255#241#229#227#255#241#229#226#255#241#229#226#255#241#229 + ,#226#255#241#229#226#255#240#228#225#255#240#228#225#255#240#227#224#255#239 + +#225#222#255#238#223#220#255#236#220#215#255#233#215#210#255#228#207#201#255 + +#222#196#187#255#213#183#170#255#204#166#150#255#192#147#127#255#179#127'i' + +#255#150'fO'#255'tI7'#255'e;('#255'`5!'#255']1'#30#255'\0'#28#223'[/'#27'`[/' + +#27#1#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'[/'#27#17'[/'#27#127'\0'#28#238']1' + +#30#255'`6"'#255'e<)'#255'rI6'#255#142'_J'#255#170'wa'#255#188#140'w'#255#199 + +#158#141#255#208#173#159#255#216#186#175#255#222#196#187#255#227#206#198#255 + +#232#213#208#255#235#219#214#255#237#222#218#255#238#224#220#255#239#226#223 + +#255#240#227#225#255#241#229#226#255#242#230#228#255#242#230#228#255#242#231 + +#229#255#242#231#229#255#242#231#229#255#242#231#229#255#242#231#229#255#242 + +#231#229#255#242#231#229#255#242#230#228#255#241#229#227#255#241#229#226#255 + +#240#227#225#255#239#225#222#255#238#224#220#255#236#221#217#255#234#218#213 + +#255#231#211#206#255#226#204#196#255#220#194#184#255#214#183#171#255#206#169 + +#155#255#196#153#135#255#185#135'r'#255#162'q['#255#134'XD'#255'lC1'#255'c:' + +''''#255'_4 '#255']0'#30#255'\0'#28#217'[/'#27'`[/'#27#4#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'[/'#27#13'[/'#27'w\0'#28#233 + +']1'#30#255'_4 '#255'b8%'#255'h?-'#255'zN;'#255#149'dP'#255#170'xa'#255#187 + +#137't'#255#194#150#131#255#202#164#148#255#210#176#163#255#216#187#175#255 + +#220#194#184#255#224#200#192#255#228#207#199#255#231#212#206#255#234#217#211 + +#255#236#220#215#255#236#222#217#255#237#222#219#255#238#223#220#255#238#223 + +#220#255#238#224#220#255#238#223#220#255#237#223#219#255#237#223#218#255#236 + +#221#217#255#235#219#215#255#233#216#210#255#230#211#204#255#227#204#197#255 + +#223#199#190#255#219#192#183#255#215#185#173#255#208#173#159#255#200#160#144 + +#255#192#146#127#255#183#133'o'#255#164's\'#255#142']J'#255'rI7'#255'f=*'#255 + +'a6#'#255'^3'#31#255'\1'#29#255'\0'#28#210'[/'#27'X[/'#27#2#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0'[/'#27#5'[/'#27'P\0'#28#173'\1'#29#249']1'#30#255'`5!'#255'c9&'#255'g' + +'>,'#255'qH6'#255#133'YE'#255#153'iT'#255#172'yd'#255#186#136'q'#255#191#144 + +'}'#255#196#153#136#255#202#162#146#255#207#171#156#255#211#178#165#255#214 + +#183#171#255#216#186#175#255#217#188#177#255#218#190#179#255#219#191#182#255 + +#219#192#182#255#219#192#181#255#218#189#179#255#217#187#177#255#215#185#173 + +#255#213#182#169#255#210#176#163#255#205#169#154#255#200#160#144#255#195#151 + +#133#255#190#142'z'#255#183#132'o'#255#167'u_'#255#148'eP'#255#127'S@'#255'm' + +'E2'#255'f=*'#255'b7%'#255'_4 '#255']1'#30#255'\0'#28#235'[/'#27#147'[/'#27 + +'5'#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'[' + ,'/'#27#18'[/'#27'i\0'#28#199'\1'#29#254']1'#30#255'_4 '#255'a6#'#255'd9('#255 + +'g>,'#255'oF3'#255'}Q>'#255#138'[G'#255#149'fQ'#255#160'oZ'#255#170'xa'#255 + +#176'}h'#255#180#128'l'#255#183#133'p'#255#186#136's'#255#188#138'u'#255#188 + +#139'v'#255#187#138'u'#255#186#135'r'#255#183#132'n'#255#178#128'j'#255#174 + +'|e'#255#168'v`'#255#158'mW'#255#146'bN'#255#133'YE'#255'yM;'#255'mC1'#255'g' + +'>+'#255'c9&'#255'`6"'#255'^3'#31#255']1'#30#255'\0'#28#248'\0'#28#173'[/'#27 + +'O[/'#27#5#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'[/'#27#20'[/'#27'V\0'#28#153 + +'\0'#28#220'\1'#29#255']1'#30#255'^3'#31#255'`5!'#255'a7$'#255'c9&'#255'e;(' + +#255'f=*'#255'g>,'#255'i@.'#255'jB0'#255'mE2'#255'qH5'#255'tJ7'#255'qG5'#255 + +'lC1'#255'jA0'#255'h?-'#255'g>+'#255'e<)'#255'd:('#255'c9&'#255'a6#'#255'`5!' + +#255'^2'#31#255']1'#30#255'\1'#29#252'\0'#28#201'[/'#27#134'[/'#27'C[/'#27#8 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0'[/'#27#31'[/'#27'_[/'#27#138'\0'#28#176'\0'#28#213'\0'#28 + +#248'\1'#29#255'\1'#29#255'\1'#29#255']1'#30#255'^2'#31#255'^2'#31#255'^3'#31 + +#255'^3'#31#255'^3'#31#255'^2'#31#255']1'#30#255']1'#30#255'\1'#29#255'\1'#29 + +#255'\1'#29#255'\0'#28#241'\0'#28#203'\0'#28#165'[/'#27#127'[/'#27'N[/'#27#15 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0'[/'#27#2'[/'#27'![/'#27'E[/'#27'U[/'#27'a[/'#27'm[/'#27'y[/'#27 + +#134'\0'#29#141'[/'#27#130'[/'#27'v[/'#27'j[/'#27'^[/'#27'Q[/'#27'=[/'#27#23 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + ,#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#255#255#255#255#255#255#255#128#0#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#224#0#0#3#255#255#255#255#255 + +#255#255#255#255#255#255#254#0#0#0#0'?'#255#255#255#255#255#255#255#255#255 + +#255#240#0#0#0#0#7#255#255#255#255#255#255#255#255#255#255#128#0#0#0#0#0#255 + +#255#255#255#255#255#255#255#255#254#0#0#0#0#0#0'?'#255#255#255#255#255#255 + +#255#255#248#0#0#0#0#0#0#15#255#255#255#255#255#255#255#255#224#0#0#0#0#0#0#3 + +#255#255#255#255#255#255#255#255#128#0#0#0#0#0#0#0#255#255#255#255#255#255 + +#255#254#0#0#0#0#0#0#0#0'?'#255#255#255#255#255#255#252#0#0#0#0#0#0#0#0#31 + +#255#255#255#255#255#255#240#0#0#0#0#0#0#0#0#7#255#255#255#255#255#255#224#0 + +#0#0#0#0#0#0#0#3#255#255#255#255#255#255#128#0#0#0#0#0#0#0#0#1#255#255#255 + +#255#255#255#0#0#0#0#0#0#0#0#0#0#127#255#255#255#255#254#0#0#0#0#0#0#0#0#0#0 + +'?'#255#255#255#255#252#0#0#0#0#0#0#0#0#0#0#31#255#255#255#255#248#0#0#0#0#0 + +#0#0#0#0#0#15#255#255#255#255#240#0#0#0#0#0#0#0#0#0#0#7#255#255#255#255#224#0 + +#0#0#0#0#0#0#0#0#0#3#255#255#255#255#192#0#0#0#0#0#0#0#0#0#0#1#255#255#255 + +#255#128#0#0#0#0#0#0#0#0#0#0#0#255#255#255#255#0#0#0#0#0#0#0#0#0#0#0#0#127 + +#255#255#254#0#0#0#0#0#0#0#0#0#0#0#0#127#255#255#254#0#0#0#0#0#0#0#0#0#0#0#0 + +'?'#255#255#252#0#0#0#0#0#0#0#0#0#0#0#0#31#255#255#248#0#0#0#0#0#0#0#0#0#0#0 + +#0#15#255#255#240#0#0#0#0#0#0#0#0#0#0#0#0#7#255#255#240#0#0#0#0#0#0#0#0#0#0#0 + +#0#7#255#255#224#0#0#0#0#0#0#0#0#0#0#0#0#3#255#255#192#0#0#0#0#0#0#0#0#0#0#0 + +#0#3#255#255#192#0#0#0#0#0#0#0#0#0#0#0#0#1#255#255#128#0#0#0#0#0#0#0#0#0#0#0 + +#0#1#255#255#128#0#0#0#0#0#0#0#0#0#0#0#0#0#255#255#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#255#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0#127#254#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#127#254#0#0#0#0#0#0#0#0#0#0#0#0#0#0'?'#254#0#0#0#0#0#0#0#0#0#0#0#0#0#0'?' + +#252#0#0#0#0#0#0#0#0#0#0#0#0#0#0'?'#252#0#0#0#0#0#0#0#0#0#0#0#0#0#0#31#252#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#31#248#0#0#0#0#0#0#0#0#0#0#0#0#0#0#15#248#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#15#248#0#0#0#0#0#0#0#0#0#0#0#0#0#0#15#240#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#7#240#0#0#0#0#0#0#0#0#0#0#0#0#0#0#7#240#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#7#224#0#0#0#0#0#0#0#0#0#0#0#0#0#0#7#224#0#0#0#0#0#0#0#0#0#0#0#0#0#0#3 + +#224#0#0#0#0#0#0#0#0#0#0#0#0#0#0#3#224#0#0#0#0#0#0#0#0#0#0#0#0#0#0#3#224#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#3#224#0#0#0#0#0#0#0#0#0#0#0#0#0#0#3#192#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#3#192#0#0#0#0#0#0#0#0#0#0#0#0#0#0#3#192#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#1#192#0#0#0#0#0#0#0#0#0#0#0#0#0#0#1#192#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#1#192#0#0#0#0#0#0#0#0#0#0#0#0#0#0#1#192#0#0#0#0#0#0#0#0#0#0#0#0#0#0#1#192#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#1#192#0#0#0#0#0#0#0#0#0#0#0#0#0#0#1#192#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#1#192#0#0#0#0#0#0#0#0#0#0#0#0#0#0#1#192#0#0#0#0#0#0#0#0#0 + ,#0#0#0#0#0#1#192#0#0#0#0#0#0#0#0#0#0#0#0#0#0#3#192#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#3#224#0#0#0#0#0#0#0#0#0#0#0#0#0#0#3#224#0#0#0#0#0#0#0#0#0#0#0#0#0#0#3#224 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#3#224#0#0#0#0#0#0#0#0#0#0#0#0#0#0#3#224#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#3#240#0#0#0#0#0#0#0#0#0#0#0#0#0#0#7#240#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#7#240#0#0#0#0#0#0#0#0#0#0#0#0#0#0#7#240#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#15#248#0#0#0#0#0#0#0#0#0#0#0#0#0#0#15#248#0#0#0#0#0#0#0#0#0#0#0#0#0#0#15 + +#248#0#0#0#0#0#0#0#0#0#0#0#0#0#0#15#252#0#0#0#0#0#0#0#0#0#0#0#0#0#0#31#252#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#31#252#0#0#0#0#0#0#0#0#0#0#0#0#0#0'?'#254#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0'?'#254#0#0#0#0#0#0#0#0#0#0#0#0#0#0'?'#254#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#127#255#0#0#0#0#0#0#0#0#0#0#0#0#0#0#127#255#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#255#255#128#0#0#0#0#0#0#0#0#0#0#0#0#0#255#255#128#0#0#0#0#0#0#0#0 + +#0#0#0#0#1#255#255#128#0#0#0#0#0#0#0#0#0#0#0#0#1#255#255#192#0#0#0#0#0#0#0#0 + +#0#0#0#0#3#255#255#192#0#0#0#0#0#0#0#0#0#0#0#0#3#255#255#224#0#0#0#0#0#0#0#0 + +#0#0#0#0#7#255#255#224#0#0#0#0#0#0#0#0#0#0#0#0#15#255#255#240#0#0#0#0#0#0#0#0 + +#0#0#0#0#15#255#255#248#0#0#0#0#0#0#0#0#0#0#0#0#31#255#255#248#0#0#0#0#0#0#0 + +#0#0#0#0#0'?'#255#255#252#0#0#0#0#0#0#0#0#0#0#0#0#127#255#255#252#0#0#0#0#0#0 + +#0#0#0#0#0#0#255#255#255#254#0#0#0#0#0#0#0#0#0#0#0#0#255#255#255#255#0#0#0#0 + +#0#0#0#0#0#0#0#1#255#255#255#255#128#0#0#0#0#0#0#0#0#0#0#3#255#255#255#255 + +#128#0#0#0#0#0#0#0#0#0#0#7#255#255#255#255#192#0#0#0#0#0#0#0#0#0#0#15#255#255 + +#255#255#224#0#0#0#0#0#0#0#0#0#0#31#255#255#255#255#240#0#0#0#0#0#0#0#0#0#0 + +#31#255#255#255#255#248#0#0#0#0#0#0#0#0#0#0'?'#255#255#255#255#252#0#0#0#0#0 + +#0#0#0#0#0#127#255#255#255#255#254#0#0#0#0#0#0#0#0#0#1#255#255#255#255#255 + +#255#0#0#0#0#0#0#0#0#0#3#255#255#255#255#255#255#128#0#0#0#0#0#0#0#0#7#255 + +#255#255#255#255#255#224#0#0#0#0#0#0#0#0#15#255#255#255#255#255#255#240#0#0#0 + +#0#0#0#0#0#31#255#255#255#255#255#255#248#0#0#0#0#0#0#0#0#127#255#255#255#255 + +#255#255#254#0#0#0#0#0#0#0#0#255#255#255#255#255#255#255#255#128#0#0#0#0#0#0 + +#3#255#255#255#255#255#255#255#255#192#0#0#0#0#0#0#7#255#255#255#255#255#255 + +#255#255#240#0#0#0#0#0#0#31#255#255#255#255#255#255#255#255#252#0#0#0#0#0#0 + +#127#255#255#255#255#255#255#255#255#255#0#0#0#0#0#3#255#255#255#255#255#255 + +#255#255#255#255#224#0#0#0#0#15#255#255#255#255#255#255#255#255#255#255#252#0 + +#0#0#0#127#255#255#255#255#255#255#255#255#255#255#255#192#0#0#7#255#255#255 + +#255#255#255#255#255#255#255#255#255#254#0#1#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255#255 + +#255#255#255#255#255#255#255#255#255'('#0#0#0'@'#0#0#0#128#0#0#0#1#0' '#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#1'@@@'#4'III'#7'III'#7 + +'333'#5#128#128#128#2#0#0#0#1#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#1'UUU'#6'DDD' + +#15'FFF'#22'EEE'#26'DDD'#30'III#GGG/DDD'#30#255'j>'#31#253'g>#'#249'[>+'#235'PB8'#218'HE' + +'C'#203'FEC'#195'EED'#184'DDD'#166'DDDqEEE4@@@'#20'@@@'#4#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#1 + +'999'#9'BBB'#31'CCCPEDD'#143'FFE'#182'NB:'#211'Z?-'#231'g>#'#249'l?'#31#255 + +'zK$'#253#150']*'#255#165'h.'#255#172'm0'#255#180's2'#255#186'x4'#255#189'{4' + +#255#192#127'5'#255#190'|4'#255#187'x4'#255#182'u3'#255#175'p1'#255#167'j/' + +#255#156'b+'#255#131'R&'#254'oB '#255'i>!'#253'_>)'#238'S@6'#222'FEB'#203'DD' + +'C'#190'DDD'#164'CCCkCCC.PPP'#16'UUU'#3#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#128#128#128#2'CCC'#19'BBBBDDD'#136'EED'#179'LA9' + +#209'`=&'#243'k?'#31#255#127'N&'#254#154'`,'#255#176'q1'#255#191'~5'#255#200 + +#138'7'#255#207#145'8'#255#210#149'9'#255#213#153'9'#255#217#157':'#255#219 + +#160';'#255#221#162';'#255#220#162':'#255#217#158':'#255#215#155':'#255#211 + +#151'9'#255#208#146'8'#255#203#141'8'#255#194#129'6'#255#183'v4'#255#163'f.' + +#255#137'U('#254'qC"'#254'f' + +'>>!+++'#6#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'@@@'#4'BBB'#27'CC' + +'C[CCB'#165'LD='#203']<('#238'j> '#255#135'R('#254#176'p3'#255#193#128'7'#255 + +#202#139'9'#255#211#151';'#255#220#162'<'#255#227#170'>'#255#232#176'?'#255 + +#234#180'?'#255#237#182'?'#255#239#185'@'#255#241#187'@'#255#242#188'A'#255 + +#241#187'@'#255#240#185'A'#255#238#183'@'#255#235#180'@'#255#233#178'?'#255 + +#229#173'>'#255#222#165'='#255#215#156'<'#255#205#144':'#255#196#133'8'#255 + +#185'x5'#255#152'^-'#255'oC"'#254'd<#'#247'QA7'#220'FFE'#200'CCC'#180'CCC}AA' + +'A/UUU'#9#0#0#0#1#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#1'III'#7'CCC&DDDpECC'#180'X<,'#232'i=' + +'!'#254#128'O('#254#170'l3'#255#194#130':'#255#210#150'>'#255#220#163'?'#255 + +#227#171'A'#255#234#180'B'#255#240#187'D'#255#242#190'D'#255#244#193'E'#255 + +#246#194'D'#255#247#195'E'#255#248#197'E'#255#249#197'E'#255#249#198'E'#255 + +#249#197'E'#255#248#196'E'#255#247#195'E'#255#246#195'E'#255#245#194'D'#255 + +#243#191'D'#255#240#188'C'#255#236#183'C'#255#230#174'B'#255#223#165'@'#255 + +#215#156'?'#255#200#137';'#255#182'u6'#255#146'[,'#255'm@!'#254'`:%'#244'KA;' + +#211'CCC'#189'CCC'#144'BBB>PPP'#16#128#128#128#2#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#1'999'#9'@@@4CCC'#133 + +'HD@'#192'_9$'#244'rE%'#254#164'h3'#255#191#127';'#255#206#146'?'#255#219#163 + +'C'#255#232#178'F'#255#238#185'G'#255#241#189'H'#255#244#193'H'#255#246#195 + +'I'#255#247#196'I'#255#247#197'J'#255#247#197'I'#255#247#198'I'#255#248#198 + +'I'#255#248#198'I'#255#248#197'I'#255#248#198'I'#255#248#198'I'#255#248#198 + +'I'#255#247#197'I'#255#247#197'I'#255#247#196'I'#255#246#196'I'#255#245#194 + +'H'#255#242#190'H'#255#239#187'H'#255#235#182'G'#255#224#168'D'#255#211#153 + +'A'#255#196#134'='#255#177'q7'#255#133'Q)'#254'e: '#253'N?7'#218'DDC'#195'CC' + +'C'#160'FFFP@@@'#20#0#0#0#2#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0'III'#7'FFF3CCC'#145'LB;'#204'd:"'#250'|L('#254#180's9'#255 + +#202#143'A'#255#216#159'F'#255#228#174'I'#255#236#184'K'#255#241#191'L'#255 + +#243#193'M'#255#244#194'M'#255#244#195'M'#255#245#196'M'#255#245#195'M'#255 + +#245#195'M'#255#245#195'M'#255#245#195'M'#255#245#195'M'#255#245#195'M'#255 + +#245#195'M'#255#245#195'M'#255#245#195'M'#255#245#195'M'#255#245#195'M'#255 + +#245#195'M'#255#245#195'M'#255#245#196'M'#255#245#195'M'#255#244#194'M'#255 + +#243#194'M'#255#242#192'M'#255#238#186'L'#255#232#179'J'#255#220#165'F'#255 + +#208#150'C'#255#190#127'<'#255#147'[.'#255'h< '#255'S=1'#228'EED'#199'DDD' + +#168'BBBUGGG'#18#0#0#0#1#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +'@@@'#4'FFF(EEE'#134'P?5'#212'e:!'#254#137'U,'#254#186'z='#255#208#150'E'#255 + +#224#171'L'#255#233#181'O'#255#238#187'P'#255#240#191'P'#255#242#192'Q'#255 + +#242#193'Q'#255#242#193'Q'#255#242#193'P'#255#242#193'Q'#255#242#193'Q'#255 + +#242#193'Q'#255#242#193'Q'#255#242#193'Q'#255#242#193'Q'#255#242#193'Q'#255 + ,#242#193'Q'#255#242#193'Q'#255#242#193'Q'#255#242#193'Q'#255#242#193'Q'#255 + +#242#193'Q'#255#242#193'Q'#255#242#193'Q'#255#242#193'Q'#255#242#193'Q'#255 + +#242#193'Q'#255#242#193'Q'#255#241#192'Q'#255#239#189'P'#255#234#184'O'#255 + +#228#175'M'#255#215#159'I'#255#194#132'@'#255#160'd3'#255'k?"'#254'X:*'#236 + +'FDC'#201'CCC'#164'AAAG;;;'#13#0#0#0#1#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'U' + +'UU'#3'BBB'#31'CCCvO=3'#211'f:'#31#255#150']2'#255#190#128'A'#255#211#155'I' + +#255#226#175'Q'#255#234#185'S'#255#237#188'T'#255#238#190'T'#255#239#191'U' + +#255#239#191'U'#255#239#191'U'#255#239#191'U'#255#239#191'U'#255#239#191'U' + +#255#239#191'U'#255#239#191'U'#255#235#189'S'#255'|d,'#255'N>'#28#255'4*'#19 + +#255'=1'#22#255'WE'#31#255'w_*'#255#173#139'='#255#239#191'U'#255#239#191'U' + +#255#239#191'U'#255#239#191'U'#255#239#191'U'#255#239#191'U'#255#239#191'U' + +#255#239#191'U'#255#239#191'U'#255#239#190'T'#255#238#189'U'#255#236#187'S' + +#255#230#179'R'#255#217#162'L'#255#198#138'D'#255#170'l8'#255'pC$'#254'Z8''' + +#240'DBB'#197'CCC'#153'FFF:@@@'#8#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#2'FFF'#22 + +'BBBeJ?9'#195'b8 '#254#150']2'#255#194#133'E'#255#213#158'N'#255#226#176'T' + +#255#233#185'W'#255#236#187'W'#255#236#188'X'#255#236#188'X'#255#236#188'X' + +#255#236#188'X'#255#236#188'X'#255#236#188'X'#255#236#188'X'#255#236#188'X' + +#255#236#188'X'#255'cO%'#255#4#3#1#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#1#1#0#255#18#14#7#255'A4'#24#255#134'k2' + +#255#218#174'R'#255#236#188'X'#255#236#188'X'#255#236#188'X'#255#236#188'X' + +#255#236#188'X'#255#236#188'X'#255#236#187'W'#255#234#186'W'#255#229#180'U' + +#255#218#165'P'#255#201#143'H'#255#173'o<'#255'k>#'#254'S;-'#231'CCC'#193'CC' + +'C'#141'DDD-fff'#5#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'@@@'#12'DDDKFA='#179'`7 '#251#137'S-' + +#255#192#131'E'#255#214#161'Q'#255#226#176'W'#255#231#183'Y'#255#233#185'[' + +#255#233#186'['#255#234#185'Z'#255#234#185'Z'#255#234#185'Z'#255#234#185'Z' + +#255#234#185'Z'#255#234#185'Z'#255#234#185'Z'#255#234#185'Z'#255'L<'#29#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#8#7#3#255'P' + +'?'#31#255#203#161'N'#255#234#185'Z'#255#234#185'Z'#255#234#185'Z'#255#234 + +#185'Z'#255#233#186'['#255#232#183'Z'#255#228#178'Y'#255#219#167'T'#255#201 + +#143'K'#255#163'g8'#255'f: '#255'O=4'#222'DDD'#188'CCCzBBB'#27#0#0#0#1#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'U' + +'UU'#3'GGG$D@@'#147'\6#'#245'{I*'#254#185'{C'#255#211#157'R'#255#225#175'Z' + +#255#229#181'\'#255#230#183']'#255#230#183']'#255#230#183']'#255#230#183']' + +#255#230#183']'#255#230#183']'#255#230#183']'#255#230#183']'#255#230#183']' + +#255#230#183']'#255#138'm8'#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#24#20#10#255'x_0' + +#255#226#181'['#255#230#183']'#255#230#183']'#255#230#183']'#255#230#181'\' + +#255#227#177'['#255#217#165'V'#255#196#136'J'#255#151']4'#255'b8 '#254'K@9' + +#214'CCC'#175'AAAJ...'#11#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0'@@@'#16'CCC\V6'''#228'nA&'#254#178'tA'#255#205 + +#151'R'#255#221#172'\'#255#226#179'_'#255#228#180'_'#255#228#180'_'#255#228 + +#180'_'#255#228#180'_'#255#228#180'_'#255#228#180'_'#255#228#180'_'#255#228 + +#180'_'#255#228#180'_'#255#228#180'_'#255#228#180'_'#255#17#13#7#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#2#1#1#255'H9'#30#255#224#178']' + +#255#228#180'_'#255#228#180'_'#255#227#179'^'#255#224#175']'#255#213#160'W' + +#255#190#129'H'#255#137'T/'#255'^4 '#252'FB?'#201'CCC'#140'DDD"'#0#0#0#3#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'@@@'#4'FFF,J=7' + +#175'`4'#30#255#165'g;'#255#200#144'Q'#255#217#166'\'#255#223#176'`'#255#225 + +#177'`'#255#225#177'a'#255#225#177'a'#255#225#177'a'#255#225#177'a'#255#225 + +#177'a'#255#225#177'a'#255#225#177'a'#255#225#177'a'#255#225#177'a'#255#225 + +#177'a'#255#218#171'^'#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255 + +#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#11#9#5#255#196#154'U'#255#225#177'a'#255#225#177 + +'`'#255#224#177'a'#255#220#171'^'#255#208#154'W'#255#184'{F'#255'nA%'#254'T8' + +'*'#233'DDD'#180'CCCX333'#15#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0'CCC'#19'CCCjY5#'#239'~J,'#254#191#132'M'#255#213#162']'#255 + ,#220#171'a'#255#221#173'c'#255#222#174'b'#255#222#174'b'#255#222#174'b'#255 + +#222#174'b'#255#222#174'b'#255#222#174'b'#255#222#174'b'#255#222#174'b'#255 + +#222#174'b'#255#222#174'b'#255#222#174'b'#255#154'yC'#255#0#0#0#255#0#0#0#255 + +#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#15#11#6 + +#255#218#172'`'#255#222#174'b'#255#222#174'b'#255#221#173'b'#255#217#167'_' + +#255#202#146'T'#255#156'a9'#255'^4'#30#254'G@='#206'DDD'#151'>>>)@@@'#4#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'UUU'#3'AAA+L;4'#188'b6 '#254#170 + +'l@'#255#206#152'Z'#255#217#168'b'#255#219#171'd'#255#219#171'd'#255#219#171 + +'d'#255#219#171'd'#255#219#171'd'#255#219#171'd'#255#219#171'd'#255#219#171 + +'d'#255#219#171'd'#255#219#171'd'#255#219#171'd'#255#219#171'd'#255#219#171 + +'d'#255#219#171'd'#255#26#20#12#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255'oW3'#255#219#171'd'#255#219 + +#171'd'#255#219#171'd'#255#218#169'c'#255#212#161'_'#255#187#127'L'#255'uD)' + +#254'W6('#238'CCC'#182'CCC[III'#14#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0'@@@'#12'EBBS[3'#31#244#134'O/'#255#192#134'Q'#255#212#162'b'#255#215 + +#167'd'#255#216#168'd'#255#216#168'd'#255#216#168'd'#255#216#168'd'#255#216 + +#168'd'#255#216#168'd'#255#216#168'd'#255#216#168'd'#255#216#168'd'#255#216 + +#168'd'#255#216#168'd'#255#216#168'd'#255#216#168'd'#255#216#168'd'#255#198 + +#154'\'#255#5#4#2#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255'!'#25#15#255#216#168'd'#255#216#168'd'#255#216#168 + +'d'#255#216#168'd'#255#214#166'd'#255#202#147'Y'#255#161'e='#255'^2'#29#255 + +'J?:'#208'CCC'#137'EEE'#26#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'C' + +'CC'#23'O9/'#171'`3'#31#254#174'pD'#255#203#150']'#255#212#163'e'#255#213#164 + +'e'#255#213#164'e'#255#213#164'e'#255#213#164'e'#255#213#164'e'#255#213#164 + +'e'#255#213#164'e'#255#213#164'e'#255#213#164'e'#255#213#164'e'#255#213#164 + +'e'#255#213#164'e'#255#213#164'e'#255#213#164'e'#255#213#164'e'#255#213#164 + +'e'#255#173#133'R'#255#3#2#1#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0 + +#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255 + +#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#22#17#11#255#213#164'e'#255#213#164'e'#255#213#164 + +'e'#255#213#164'e'#255#213#164'f'#255#209#158'a'#255#187#128'O'#255'yD)'#254 + +'W4$'#241'BBB'#169'DDD1@@@'#4#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#2'FFF(W4' + +'$'#229'{E)'#255#191#134'T'#255#207#157'c'#255#210#160'f'#255#210#160'f'#255 + +#210#160'f'#255#210#160'f'#255#210#160'f'#255#210#160'f'#255#210#160'f'#255 + +#210#160'f'#255#152'tJ'#255'[E,'#255'K9$'#255'{]<'#255#196#149'_'#255#210#160 + +'f'#255#210#160'f'#255#210#160'f'#255#210#160'f'#255#210#160'f'#255#159'yM' + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255'"' + +#26#17#255#210#160'f'#255#210#160'f'#255#210#160'f'#255#210#160'f'#255#210 + +#160'f'#255#209#160'e'#255#199#146']'#255#156'_;'#255'\1'#28#254'FBA'#188'FF' + +'FXNNN'#13#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'FFF'#11'F@=T\/'#28#253#151'\9'#255 + +#200#147'_'#255#207#156'e'#255#207#156'e'#255#207#156'e'#255#207#156'e'#255 + +#207#156'e'#255#207#156'e'#255#207#156'e'#255#178#135'W'#255'$'#27#17#255#0#0 + +#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255'N:&'#255#207#156'e'#255#207 + +#156'e'#255#207#156'e'#255#207#156'e'#255#207#156'e'#255#3#2#1#255#0#0#0#255 + +#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255'uX9'#255#207#156'e'#255#207 + +#156'e'#255#207#156'e'#255#207#156'e'#255#207#156'e'#255#207#157'e'#255#204 + +#153'b'#255#180'wK'#255'a4'#30#254'M;3'#216'DDD'#132'==='#25#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0'CCC'#19'N9.'#159'^2'#30#254#176'rI'#255#202#150'c'#255#203 + +#153'e'#255#203#153'f'#255#203#153'f'#255#203#153'f'#255#203#153'f'#255#203 + +#153'f'#255#163'zQ'#255#1#1#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0 + +#0#255#0#0#0#255#0#0#0#255#29#22#15#255#203#153'f'#255#203#153'f'#255#203#153 + +'f'#255#203#153'f'#255#14#10#7#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + ,#0#0#255#4#3#2#255#203#153'f'#255#203#153'f'#255#203#153'f'#255#203#153'f' + +#255#203#153'f'#255#203#153'f'#255#203#153'f'#255#203#152'e'#255#190#134'X' + +#255'yC)'#254'V5&'#239'DDD'#165'FFF('#128#128#128#2#0#0#0#0#0#0#0#0#0#0#0#0 + +'GGG'#25'V4%'#212's@&'#254#186#128'U'#255#199#148'd'#255#200#148'd'#255#200 + +#148'd'#255#200#148'd'#255#200#148'd'#255#200#148'd'#255#198#146'd'#255#12#9 + +#6#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255 + +#0#0#0#255#0#0#0#255#138'fE'#255#200#148'd'#255#200#148'd'#255#200#148'd'#255 + +#15#11#7#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0 + +#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255 + +#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#1#0#0#255'&'#28#19#255#145'kH'#255 + +#200#148'd'#255#200#148'd'#255#200#148'd'#255#200#148'd'#255#200#148'd'#255 + +#200#148'd'#255#200#148'd'#255#200#148'd'#255#194#141'^'#255#146'W6'#255'[0' + +#28#254'EBB'#178'CCC9UUU'#6#0#0#0#0#0#0#0#0#0#0#0#0'JAA'#31'\1'#29#249#140'P' + +'2'#255#190#135'\'#255#196#143'c'#255#196#143'c'#255#196#143'c'#255#196#143 + +'c'#255#196#143'c'#255#196#143'c'#255'>-'#31#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255'&' + +#28#19#255#196#143'c'#255#196#143'c'#255#196#143'c'#255#25#18#12#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#2#2#1 + +#255'*'#31#21#255'kM6'#255#187#137'_'#255#196#143'c'#255#196#143'c'#255#196 + +#143'c'#255#196#143'c'#255#196#143'c'#255#196#143'c'#255#196#143'c'#255#196 + +#143'c'#255#196#143'c'#255#196#143'c'#255#194#141'b'#255#170'kF'#255'\0'#28 + +#254'L<5'#203'CCCH333'#10#0#0#0#0#0#0#0#0#0#0#0#1'K3+@[/'#27#255#160'`>'#255 + +#190#136'_'#255#191#137'`'#255#191#137'`'#255#191#137'`'#255#191#137'`'#255 + +#191#137'`'#255#189#135'`'#255#1#1#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#30#21#15#255 + +#191#137'`'#255#191#137'`'#255#191#137'`'#255'aF1'#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#5#3#2#255#165'vS'#255#191#137'`' + +#255#191#137'`'#255#191#137'`'#255#191#137'`'#255#191#137'`'#255#191#137'`' + +#255#191#137'`'#255#191#137'`'#255#191#137'`'#255#191#137'`'#255#191#137'`' + +#255#191#137'`'#255#191#137'`'#255#191#136'`'#255#178'vQ'#255'h7 '#253'Q8,' + +#220'DDDV;;;'#13#0#0#0#0#0#0#0#0'UUU'#3'R4''^[/'#27#255#169'hF'#255#187#131 + +']'#255#187#132'^'#255#187#132'^'#255#187#132'^'#255#187#132'^'#255#187#132 + +'^'#255'uS;'#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255 + +#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255'{W>'#255#187#132'^'#255 + +#187#132'^'#255#187#132'^'#255#185#130'^'#255#19#14#10#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#1#1#1#255#158'oO'#255#187#132'^'#255#187#132'^' + +#255#187#132'^'#255#187#132'^'#255#187#132'^'#255#187#132'^'#255#187#132'^' + +#255#187#132'^'#255#187#132'^'#255#187#132'^'#255#187#132'^'#255#187#132'^' + +#255#187#132'^'#255#187#132'^'#255#187#132'^'#255#181'{V'#255'r<"'#255'T6''' + +#228'BBBd@@@'#16#0#0#0#0#0#0#0#0'UUU'#6'T5''}_2'#30#253#171'kI'#255#183'}Z' + +#255#183'~Z'#255#183'~Z'#255#183'~Z'#255#183'~Z'#255#183'~Z'#255'. '#23#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#1#1#0#255'S9)'#255#183'~Z'#255#183'~Z'#255#183'~Z'#255#183'~Z' + +#255#183'~Z'#255#173'xV'#255#31#21#15#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255'b' + +'C0'#255#183'~Z'#255#183'~Z'#255#183'~Z'#255#183'~Z'#255#183'~Z'#255#183'~Z' + +#255#183'~Z'#255#183'~Z'#255#183'~Z'#255#183'~Z'#255#183'~Z'#255#183'~Z'#255 + +#183'~Z'#255#183'~Z'#255#183'~Z'#255#183'~Z'#255#181'zV'#255'zA%'#255'X4$' + +#237'DDDqCCC'#19#0#0#0#0#0#0#0#0'@@@'#8'U4%'#149'f5'#31#252#172'mK'#255#180 + +'yX'#255#180'yX'#255#180'yX'#255#180'yX'#255#180'yX'#255#180'yX'#255#6#4#3 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#19#13#9#255#153'gK'#255#180'yX'#255#180'yX'#255#180'yX'#255#180'yX' + +#255#180'yX'#255#180'yX'#255#180'yX'#255#180'yX'#255'{S<'#255'+'#29#21#255#7 + +#4#3#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#1#1#1 + +#255'gF3'#255#180'yX'#255#180'yX'#255#180'yX'#255#139']D'#255'+'#29#21#255#8 + +#6#4#255#8#6#4#255#16#11#8#255'W:*'#255#178'wV'#255#180'yX'#255#180'yX'#255 + +#180'yX'#255#180'yX'#255#180'yX'#255#180'yX'#255#180'yX'#255#179'yV'#255#131 + +'F+'#255'[3!'#245'CCCyIII'#21#0#0#0#0#0#0#0#0'UUU'#6'X3"'#165'n:"'#253#172'p' + +'O'#255#177'wW'#255#177'wW'#255#177'wW'#255#177'wW'#255#177'wW'#255#173'uU' + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#1 + +#0#0#255'P6'''#255#177'wW'#255#177'wW'#255#177'wW'#255#177'wW'#255#177'wW' + ,#255#177'wW'#255#177'wW'#255#177'wW'#255#177'wW'#255#177'wW'#255#177'wW'#255 + +#177'wW'#255#177'wW'#255#158'jM'#255'W;+'#255''''#26#19#255'"'#23#17#255'%' + +#25#18#255'W:+'#255#167'qS'#255#177'wW'#255#177'wW'#255#177'wW'#255'@+'#31 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#3#2#1#255 + +#149'dI'#255#177'wW'#255#177'wW'#255#177'wW'#255#177'wW'#255#177'wW'#255#177 + +'wW'#255#177'vV'#255#139'M0'#255'[1'#30#250'DDDpCCC'#19#0#0#0#0#0#0#0#0'UUU' + +#3'Y1'#31#182'v>%'#255#172'oQ'#255#175'tW'#255#175'tW'#255#175'tW'#255#175't' + +'W'#255#175'tW'#255'}S?'#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#26#17#13#255#150'cK'#255#175'tW'#255#175'tW'#255#175'tW'#255 + +#175'tW'#255#175'tW'#255#175'tW'#255#175'tW'#255#175'tW'#255#175'tW'#255#175 + +'tW'#255#175'tW'#255#175'tW'#255#175'tW'#255#175'tW'#255#175'tW'#255#175'tW' + +#255#175'tW'#255#175'tW'#255#175'tW'#255#175'tW'#255#175'tW'#255#175'tW'#255 + +#175'tW'#255'dC2'#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#9#6#4#255#169'pU'#255#175'tW'#255#175'tW'#255#175't' + +'W'#255#175'tW'#255#175'tW'#255#174'sU'#255#145'S6'#255']0'#28#254'DBBd@@@' + +#16#0#0#0#0#0#0#0#0#0#0#0#0'Z0'#30#175'v=%'#255#171'nP'#255#174'rV'#255#174 + +'rV'#255#174'rV'#255#174'rV'#255#174'rV'#255'L2&'#255#0#0#0#255'/'#31#23#255 + +'}R>'#255' '#21#16#255'!'#22#17#255#139'[E'#255#174'rV'#255#174'rV'#255#174 + +'rV'#255#174'rV'#255#174'rV'#255#174'rV'#255#174'rV'#255#174'rV'#255#174'rV' + +#255#174'rV'#255#174'rV'#255#174'rV'#255#174'rV'#255#174'rV'#255#174'rV'#255 + +#174'rV'#255#174'rV'#255#174'rV'#255#174'rV'#255#174'rV'#255#174'rV'#255#174 + +'rV'#255#174'rV'#255#174'rV'#255#174'rV'#255'?*'#31#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255'6#'#27 + +#255#174'rV'#255#174'rV'#255#174'rV'#255#174'rV'#255#174'rV'#255#173'qT'#255 + +#145'S7'#255'\1'#29#254'AAAV;;;'#13#0#0#0#0#0#0#0#0#0#0#0#0'Z1'#30#150'n;$' + +#252#169'jM'#255#172'qU'#255#172'qU'#255#172'qU'#255#172'qU'#255#172'qU'#255 + +#149'bI'#255'@* '#255#170'qU'#255#172'qU'#255#172'qU'#255#172'qU'#255#172'qU' + +#255#172'qU'#255#172'qU'#255#172'qU'#255#172'qU'#255#172'qU'#255#172'qU'#255 + +#172'qU'#255#172'qU'#255#172'qU'#255#172'qU'#255#172'qU'#255#172'qU'#255#172 + +'qU'#255#172'qU'#255#172'qU'#255#172'qU'#255#172'qU'#255#172'qU'#255#172'qU' + +#255#172'qU'#255#172'qU'#255#172'qU'#255#172'qU'#255#172'qU'#255#172'qU'#255 + +'G/#'#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#24#16#12#255#172'qU'#255#172'qU'#255#172'qU'#255#172 + +'qU'#255#172'qU'#255#171'oS'#255#138'N3'#255'\2'#31#249'DDDG999'#9#0#0#0#0#0 + +#0#0#0#0#0#0#0'X1!|g7#'#250#167'gI'#255#172'pT'#255#172'qU'#255#172'qU'#255 + +#172'qU'#255#172'qU'#255#172'qU'#255#172'qU'#255#172'qU'#255#172'qU'#255#172 + +'qU'#255#172'qU'#255#172'qU'#255#172'qU'#255#172'qU'#255#172'qU'#255#172'qU' + +#255#172'qU'#255'P5('#255')'#27#20#255#27#18#13#255'5#'#26#255'pJ8'#255#172 + +'qU'#255#172'qU'#255#172'qU'#255#172'qU'#255#172'qU'#255#172'qU'#255#172'qU' + +#255#172'qU'#255#172'qU'#255#172'qU'#255#172'qU'#255#172'qU'#255#172'qU'#255 + +#172'qU'#255#172'qU'#255#162'jO'#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255 + +#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#9#6#4#255#172'qU'#255#172 + +'qU'#255#172'qU'#255#172'qU'#255#172'qU'#255#170'mR'#255#131'I.'#255'[4"'#241 + +'FFF7UUU'#6#0#0#0#0#0#0#0#0#0#0#0#0'Y1!`b5 '#251#164'cG'#255#172'pU'#255#173 + +'rW'#255#173'rW'#255#173'rW'#255#173'rW'#255#173'rW'#255#173'rW'#255#173'rW' + +#255#173'rW'#255#173'rW'#255#173'rW'#255#173'rW'#255#173'rW'#255#173'rW'#255 + +#173'rW'#255'}S?'#255#9#6#5#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#16#11#8#255#152'dM'#255#173'rW'#255#173'rW'#255#173'rW'#255#173'rW'#255 + +#173'rW'#255#173'rW'#255#173'rW'#255#173'rW'#255#173'rW'#255#173'rW'#255#173 + +'rW'#255#173'rW'#255#173'rW'#255#173'rW'#255'$'#24#18#255#0#0#0#255#0#0#0#255 + +#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#4#3#2#255#173'r' + +'W'#255#173'rW'#255#173'rW'#255#173'rW'#255#173'rW'#255#170'mQ'#255'|C*'#255 + +'W4$'#229'CCC&'#0#0#0#2#0#0#0#0#0#0#0#0#0#0#0#0'X5!A^2'#31#254#162'bE'#255 + +#173'rV'#255#175'tY'#255#175'tY'#255#175'tY'#255#175'tY'#255#175'tY'#255#175 + +'tY'#255#175'tY'#255#175'tY'#255#175'tY'#255#175'tY'#255#175'tY'#255#175'tY' + +#255#175'tY'#255'{Q?'#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#14#9#7#255#173'tY'#255#175'tY'#255#175'tY'#255 + +#175'tY'#255#175'tY'#255#175'tY'#255#175'tY'#255#175'tY'#255#175'tY'#255#175 + +'tY'#255#175'tY'#255#175'tY'#255#175'tY'#255#175'tY'#255#132'XC'#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#21 + +#14#11#255#175'tY'#255#175'tY'#255#175'tY'#255#175'tY'#255#174'tY'#255#170'm' + +'P'#255't?('#254'U5&'#203'@@@'#24#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'X0'#24' ^2' + +#31#255#156'\A'#255#175'v\'#255#177'y`'#255#177'y`'#255#177'y`'#255#177'y`' + +#255#177'y`'#255#177'y`'#255#177'y`'#255#177'y`'#255#177'y`'#255#177'y`'#255 + ,#177'y`'#255#177'y`'#255#177'y`'#255#11#8#6#255#0#0#0#255#0#0#0#255#0#0#0#255 + +#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#136']J'#255#177 + +'y`'#255#177'y`'#255'7%'#30#255#9#6#5#255#13#9#7#255#16#11#9#255#26#18#14#255 + +#139'_K'#255#177'y`'#255#177'y`'#255#177'y`'#255#177'y`'#255#177'y`'#255#177 + +'y`'#255#18#12#9#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255'<)!'#255#177'y`'#255#177'y`'#255#177'y`'#255#177'y`'#255#176 + +'x^'#255#169'kP'#255'j<&'#253'U4%'#168';;;'#13#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0'^2'#29#234#136'O4'#255#176'x^'#255#180'~f'#255#180'~f'#255#180'~f' + +#255#180'~f'#255#180'~f'#255#180'~f'#255#180'~f'#255#180'~f'#255#180'~f'#255 + +#180'~f'#255#180'~f'#255#180'~f'#255#146'gS'#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255 + +#139'bO'#255#170'x`'#255#20#14#11#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255 + +#0#0#0#255#0#0#0#255']A4'#255#180'~f'#255#180'~f'#255#180'~f'#255#180'~f'#255 + +#180'~f'#255'qO@'#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#1#1#0#255#165't^'#255#180'~f'#255#180'~f'#255#180'~f'#255#180'~f'#255 + +#178'zb'#255#162'dH'#255'_3'#31#254'R6)c@@@'#4#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0'[/'#29#153'r?)'#252#174'sZ'#255#182#129'j'#255#183#131'l'#255#183 + +#131'l'#255#183#131'l'#255#183#131'l'#255#183#131'l'#255#183#131'l'#255#183 + +#131'l'#255#183#131'l'#255#183#131'l'#255#183#131'l'#255#183#131'l'#255'ZA5' + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#5#3#3#255#179#127'j'#255'uTE'#255#0#0#0#255#0#0#0#255#0#0 + +#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255'{XI'#255#183#131'l' + +#255#183#131'l'#255#183#131'l'#255#183#131'l'#255#183#131'l'#255#20#15#12#255 + +#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255':)"'#255#183#131'l'#255 + +#183#131'l'#255#183#131'l'#255#183#131'l'#255#183#131'l'#255#179'|c'#255#140 + +'R9'#255'\2'#31#248'@@6'#28#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +'[/'#29'E`5 '#252#166'iO'#255#183#131'l'#255#186#136'q'#255#186#136'q'#255 + +#186#136'q'#255#186#136'q'#255#186#136'q'#255#186#136'q'#255#186#136'q'#255 + +#186#136'q'#255#186#136'q'#255#186#136'q'#255#186#136'q'#255'\D8'#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255'oQC'#255#186#136'q'#255'X@6'#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#12#9#7#255#186#136'q'#255#186 + +#136'q'#255#186#136'q'#255#186#136'q'#255#186#136'q'#255#148'lZ'#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#169'|g'#255#186#136'q'#255#186 + +#136'q'#255#186#136'q'#255#186#136'q'#255#185#134'q'#255#177'y`'#255'tB+'#254 + +'W2!'#194'III'#14#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'@@'#0#4'^3' + +#30#245#144'W='#255#184#134'o'#255#189#141'x'#255#189#141'x'#255#189#141'x' + +#255#189#141'x'#255#189#141'x'#255#189#141'x'#255#189#141'x'#255#189#141'x' + +#255#189#141'x'#255#189#141'x'#255#189#141'x'#255'tWJ'#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255'('#30#26#255 + +#189#141'x'#255#189#141'x'#255'?/('#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#187#139'v'#255#189#141 + +'x'#255#189#141'x'#255#189#141'x'#255#189#141'x'#255#189#141'x'#255#172#128 + +'m'#255'_G<'#255#1#0#0#255#0#0#0#255'-"'#28#255#189#141'x'#255#189#141'x'#255 + +#189#141'x'#255#189#141'x'#255#189#141'x'#255#186#137's'#255#171'oU'#255'a6"' + +#253'T5$jUUU'#3#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'\/' + +#27#170'vD,'#252#181#128'h'#255#190#144'{'#255#192#146'~'#255#192#146'~'#255 + +#192#146'~'#255#192#146'~'#255#192#146'~'#255#192#146'~'#255#192#146'~'#255 + +#192#146'~'#255#192#146'~'#255#192#146'~'#255#186#142'z'#255#1#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#2#1#1#255#186#142'z' + +#255#192#146'~'#255#192#146'~'#255'=.('#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0 + +#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#192#146'~'#255#192 + +#146'~'#255#192#146'~'#255#192#146'~'#255#192#146'~'#255#192#146'~'#255#192 + +#146'~'#255#192#146'~'#255#0#0#0#255#0#0#0#255#167#127'n'#255#192#146'~'#255 + +#192#146'~'#255#192#146'~'#255#192#146'~'#255#191#145'}'#255#186#137's'#255 + +#149'[A'#255'^1'#31#250'F:.'#22#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0'\.'#28'H`5 '#252#164'jP'#255#190#143'z'#255#194#151#131 + +#255#194#151#131#255#194#151#131#255#194#151#131#255#194#151#131#255#194#151 + +#131#255#194#151#131#255#194#151#131#255#194#151#131#255#194#151#131#255#194 + +#151#131#255#27#21#18#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255' '#25#21#255#194#151#131#255#194#151#131#255#194#151#131#255'7*%' + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#12#9#8#255#194#151#131#255#194#151#131#255#194#151#131#255#194#151 + +#131#255#194#151#131#255#194#151#131#255#194#151#131#255#190#149#129#255#0#0 + ,#0#255'0% '#255#194#151#131#255#194#151#131#255#194#151#131#255#194#151#131 + +#255#194#151#131#255#192#147#127#255#180'~f'#255'q@+'#252'Z0'#29#180#0#0#0#2 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0']0' + +#28#199'{H2'#252#184#134'o'#255#196#153#134#255#197#156#137#255#197#156#137 + +#255#197#156#137#255#197#156#137#255#197#156#137#255#197#156#137#255#197#156 + +#137#255#197#156#137#255#197#156#137#255#197#156#137#255'G81'#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255'WE='#255#197#156#137#255#197 + +#156#137#255#191#152#133#255#1#1#1#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#135'k^'#255#197#156#137#255#197 + +#156#137#255#197#156#137#255#197#156#137#255#197#156#137#255#197#156#137#255 + +#197#156#137#255#197#156#137#255#16#12#11#255#174#138'y'#255#197#156#137#255 + +#197#156#137#255#197#156#137#255#197#156#137#255#197#155#136#255#191#145'|' + +#255#151'_F'#255'^3'#31#253'T2!-'#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'[0'#29'5_4 '#254#161'hP'#255#195#152#132 + +#255#200#161#143#255#200#161#144#255#200#161#144#255#200#161#144#255#200#161 + +#144#255#200#161#144#255#200#161#144#255#200#161#144#255#200#161#144#255#200 + +#161#144#255'xaW'#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#1#1#1 + +#255#171#138'{'#255#200#161#144#255#200#161#144#255#127'f\'#255#0#0#0#255#0#0 + +#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255')!'#30#255 + +#200#161#144#255#200#161#144#255#200#161#144#255#200#161#144#255#200#161#144 + +#255#200#161#144#255#200#161#144#255#200#161#144#255#200#161#144#255#153'{n' + +#255#200#161#144#255#200#161#144#255#200#161#144#255#200#161#144#255#200#161 + +#144#255#198#156#138#255#181#128'h'#255'l>*'#252'Z1'#30#159#0#0#0#1#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0'^0'#27#173'uE/'#249#186#136'r'#255#201#162#145#255#203#165#150#255#203#165 + +#150#255#203#165#150#255#203#165#150#255#203#165#150#255#203#165#150#255#203 + +#165#150#255#203#165#150#255#203#165#150#255#163#132'x'#255#0#0#0#255#0#0#0 + +#255#26#21#19#255',$!'#255'-%!'#255#156'~s'#255#203#165#150#255#203#165#150 + +#255#203#165#150#255'@4/'#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#4#3#3#255#186#151#138#255#203#165#150#255#203#165 + +#150#255#203#165#150#255#203#165#150#255#203#165#150#255#203#165#150#255#203 + +#165#150#255#203#165#150#255#203#165#150#255#203#165#150#255#203#165#150#255 + +#203#165#150#255#203#165#150#255#203#165#150#255#203#164#149#255#195#152#132 + +#255#146'\D'#255'_3'#31#247'R3'#30#25#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'Z-'#30'"^4 '#252#155 + +'cK'#255#196#153#136#255#206#169#155#255#207#171#156#255#207#171#156#255#207 + +#171#156#255#207#171#156#255#207#171#156#255#207#171#156#255#207#171#156#255 + +#207#171#156#255#203#167#152#255#0#0#0#255#0#0#0#255#193#159#145#255#207#171 + +#156#255#207#171#156#255#207#171#156#255#207#171#156#255#207#171#156#255#207 + +#171#156#255'E94'#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#15#12#11#255#182#150#137#255#207#171#156#255#207#171#156#255#207#171#156 + +#255#207#171#156#255#207#171#156#255#207#171#156#255#207#171#156#255#207#171 + +#156#255#207#171#156#255#207#171#156#255#207#171#156#255#207#171#156#255#207 + +#171#156#255#207#171#156#255#206#170#155#255#201#162#145#255#178'}f'#255'h<(' + +#250'[0'#28#129#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0']1'#29#130'f:&'#250#171'u' + +'^'#255#202#164#148#255#210#176#163#255#210#177#164#255#210#177#164#255#210 + +#177#164#255#210#177#164#255#210#177#164#255#210#177#164#255#210#177#164#255 + +#210#177#164#255#2#1#1#255#27#22#21#255#210#177#164#255#210#177#164#255#210 + +#177#164#255#210#177#164#255#210#177#164#255#210#177#164#255#210#177#164#255 + +#210#177#164#255'I=8'#255#6#5#4#255#0#0#0#255#0#0#0#255#0#0#0#255'''!'#31#255 + +#206#175#162#255#210#177#164#255#210#177#164#255#210#177#164#255#210#177#164 + +#255#210#177#164#255#210#177#164#255#210#177#164#255#210#177#164#255#210#177 + +#164#255#210#177#164#255#210#177#164#255#210#177#164#255#210#177#164#255#210 + +#177#164#255#210#176#163#255#206#170#155#255#188#139'w'#255'zI4'#252'^2'#29 + +#222']/'#23#11#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#1'^1'#29#181'oA-' + +#249#182#132'n'#255#208#173#159#255#213#182#169#255#213#183#170#255#213#183 + +#170#255#213#183#170#255#213#183#170#255#213#183#170#255#213#183#170#255#213 + +#183#170#255#12#10#9#255#159#136#127#255#213#183#170#255#213#183#170#255#213 + +#183#170#255#213#183#170#255#213#183#170#255#213#183#170#255#213#183#170#255 + +#213#183#170#255#213#183#170#255#139'xo'#255#0#0#0#255#0#0#0#255'% '#30#255 + +#213#183#170#255#213#183#170#255#213#183#170#255#213#183#170#255#213#183#170 + +#255#213#183#170#255#213#183#170#255#213#183#170#255#213#183#170#255#213#183 + ,#170#255#213#183#170#255#213#183#170#255#213#183#170#255#213#183#170#255#213 + +#183#170#255#213#183#170#255#211#178#165#255#196#152#134#255#136'T?'#254'`1 ' + +#243'U+'#28'$'#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'U+'#21#12 + +']2'#30#218'zK5'#251#192#146#127#255#212#180#168#255#216#187#176#255#217#188 + +#177#255#217#188#177#255#217#188#177#255#217#188#177#255#217#188#177#255#217 + +#188#177#255'o`Z'#255#217#188#177#255#217#188#177#255#217#188#177#255#217#188 + +#177#255#217#188#177#255#217#188#177#255#217#188#177#255#217#188#177#255#217 + +#188#177#255#217#188#177#255#27#24#22#255#0#0#0#255#9#8#7#255#209#180#171#255 + +#217#188#177#255#217#188#177#255#217#188#177#255#217#188#177#255#217#188#177 + +#255#217#188#177#255#217#188#177#255#217#188#177#255#217#188#177#255#217#188 + +#177#255#217#188#177#255#217#188#177#255#217#188#177#255#217#188#177#255#217 + +#188#177#255#215#185#173#255#202#163#147#255#152'cM'#255'`5 '#252'X.'#27'B'#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'].'#23'!_' + +'3 '#241#135'V@'#254#197#155#137#255#215#185#173#255#219#193#183#255#220#194 + +#184#255#220#194#184#255#220#194#184#255#220#194#184#255#220#194#184#255#220 + +#194#184#255#220#194#184#255#220#194#184#255#220#194#184#255#220#194#184#255 + +#220#194#184#255#220#194#184#255#220#194#184#255#220#194#184#255#220#194#184 + +#255#220#194#184#255#4#4#4#255#13#11#11#255#197#173#164#255#220#194#184#255 + +#220#194#184#255#220#194#184#255#220#194#184#255#220#194#184#255#220#194#184 + +#255#220#194#184#255#220#194#184#255#220#194#184#255#220#194#184#255#220#194 + +#184#255#220#194#184#255#220#194#184#255#220#194#184#255#220#194#183#255#218 + +#190#179#255#205#169#154#255#165'pY'#255'b8$'#252'[/'#27'h'#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'Y1'#28'?_' + +'3!'#249#132'T?'#252#193#148#130#255#215#186#174#255#223#198#189#255#223#200 + +#191#255#223#200#191#255#223#200#191#255#223#200#191#255#223#200#191#255#223 + +#200#191#255#223#200#191#255#223#200#191#255#223#200#191#255#223#200#191#255 + +#223#200#191#255#223#200#191#255#223#200#191#255#223#200#191#255#223#200#191 + +#255#199#179#171#255#215#192#183#255#223#200#191#255#223#200#191#255#223#200 + +#191#255#223#200#191#255#223#200#191#255#223#200#191#255#223#200#191#255#223 + +#200#191#255#223#200#191#255#223#200#191#255#223#200#191#255#223#200#191#255 + +#223#200#191#255#223#200#191#255#223#199#190#255#219#192#183#255#203#165#150 + +#255#158'kS'#255'c9%'#251']0'#30#147#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'Z-'#25'3_3'#30 + +#234'wI5'#250#185#138'v'#255#215#186#174#255#225#203#194#255#227#205#197#255 + +#227#205#197#255#227#205#197#255#227#205#197#255#227#205#197#255#227#205#197 + +#255#227#205#197#255#227#205#197#255#227#205#197#255#227#205#197#255#227#205 + +#197#255#227#205#197#255#227#205#197#255#227#205#197#255#227#205#197#255#227 + +#205#197#255#227#205#197#255#227#205#197#255#227#205#197#255#227#205#197#255 + +#227#205#197#255#227#205#197#255#227#205#197#255#227#205#197#255#227#205#197 + +#255#227#205#197#255#227#205#197#255#227#205#197#255#227#205#197#255#226#204 + +#196#255#220#194#183#255#200#159#143#255#144'_H'#254'a6"'#253'\1'#30'y'#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'\3'#31#25'^2'#29#207'nB.'#249#175'~i'#255 + +#213#182#169#255#225#202#193#255#230#209#203#255#230#211#205#255#230#211#205 + +#255#230#211#205#255#230#211#205#255#230#211#205#255#230#211#205#255#230#211 + +#205#255#230#211#205#255#230#211#205#255#230#211#205#255#230#211#205#255#230 + +#211#205#255#230#211#205#255#230#211#205#255#230#211#205#255#230#211#205#255 + +#230#211#205#255#230#211#205#255#230#211#205#255#230#211#205#255#230#211#205 + +#255#230#211#205#255#230#211#205#255#230#211#205#255#230#211#205#255#230#210 + +#204#255#227#205#198#255#219#191#181#255#193#149#131#255#131'R='#251'_4 '#247 + +'Z0'#26'O'#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'` '#8']0' + +#28#169'e:'''#250#148'aL'#255#196#153#136#255#220#193#183#255#229#209#202#255 + +#233#216#210#255#234#216#211#255#234#216#211#255#234#216#211#255#234#216#211 + +#255#234#216#211#255#234#216#211#255#234#216#211#255#234#216#211#255#234#216 + +#211#255#234#216#211#255#234#216#211#255#234#216#211#255#234#216#211#255#234 + +#216#211#255#234#216#211#255#234#216#211#255#234#216#211#255#234#216#211#255 + +#234#216#211#255#234#216#211#255#234#216#211#255#233#216#211#255#231#212#206 + ,#255#224#200#192#255#207#171#156#255#168'va'#255'rE1'#249'^3'#31#230'Y,'#28 + +'.'#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0'^1'#29'h`3'#31#237'nA/'#249#158'mW'#255#203#165#150#255#224#201#192 + +#255#232#213#208#255#235#219#215#255#237#222#218#255#237#222#218#255#237#222 + +#218#255#237#222#218#255#237#222#218#255#237#222#218#255#237#222#218#255#237 + +#222#218#255#237#222#218#255#237#222#218#255#237#222#218#255#237#222#218#255 + +#237#222#218#255#237#222#218#255#237#222#218#255#237#222#218#255#237#222#218 + +#255#236#220#216#255#233#216#211#255#228#206#200#255#213#182#170#255#177#131 + +'n'#255'}M:'#250'a6"'#253']1'#29#155'U1'#24#21#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'].'#23#11 + +']1'#29'~`5!'#246'tF5'#249#166'u`'#255#202#164#148#255#221#195#186#255#230 + +#210#203#255#234#218#213#255#238#224#220#255#240#227#224#255#240#227#225#255 + +#240#227#225#255#240#227#225#255#240#227#225#255#240#227#225#255#240#227#225 + +#255#240#227#225#255#240#227#225#255#240#227#225#255#240#227#225#255#239#225 + +#222#255#236#220#215#255#232#213#207#255#225#203#194#255#210#176#164#255#183 + +#138'u'#255#133'UA'#252'c9&'#254'^2'#30#178'\.'#26''''#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'U1'#24#21']0'#30#147'`7"'#251'jA-'#249#133'UA' + +#253#169'zf'#255#201#162#146#255#220#194#184#255#230#211#205#255#233#215#210 + +#255#234#217#212#255#236#220#215#255#237#222#218#255#238#223#220#255#237#222 + +#219#255#236#220#216#255#234#219#213#255#233#216#211#255#231#213#206#255#225 + +#203#194#255#209#174#160#255#181#136'u'#255#145'`L'#255'sG4'#249'c9&'#255'_2' + +#30#198'].'#28'7'#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0'U+'#28#18'\.'#27'^_1'#30#179'c7$'#248'h?,'#251#127 + +'Q;'#251#148'dN'#255#163't_'#255#175#129'n'#255#186#143'~'#255#198#157#141 + +#255#204#167#151#255#201#161#145#255#191#149#132#255#179#135'u'#255#167'ye' + +#255#153'iT'#255#136'WC'#254'pE2'#249'c9&'#255'_3'#31#212'Z/'#27'|].'#29','#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'U9'#28#9'\.'#26'N^0'#29#157'`' + +'4 '#203'c6#'#230'c7%'#249'd:('#255'f=*'#255'i?-'#252'g>+'#255'e;('#255'd9&' + +#253'b7$'#237'a5!'#214'_1'#30#180'\/'#26'lX,'#26#29#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0'`0 '#16'[1'#24'*].'#27'B]1'#29'4\3'#31#25'UU'#0#3#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#255#255#255#248#15#255 + +#255#255#255#255#254#0#0#127#255#255#255#255#240#0#0#7#255#255#255#255#192#0 + +#0#1#255#255#255#255#0#0#0#0#255#255#255#252#0#0#0#0'?'#255#255#248#0#0#0#0 + +#31#255#255#240#0#0#0#0#7#255#255#192#0#0#0#0#3#255#255#128#0#0#0#0#1#255#255 + +#128#0#0#0#0#0#255#255#0#0#0#0#0#0#127#254#0#0#0#0#0#0#127#252#0#0#0#0#0#0'?' + +#252#0#0#0#0#0#0#31#248#0#0#0#0#0#0#31#248#0#0#0#0#0#0#15#240#0#0#0#0#0#0#15 + ,#240#0#0#0#0#0#0#7#224#0#0#0#0#0#0#7#224#0#0#0#0#0#0#7#224#0#0#0#0#0#0#3#192 + +#0#0#0#0#0#0#3#192#0#0#0#0#0#0#3#192#0#0#0#0#0#0#1#192#0#0#0#0#0#0#1#192#0#0 + +#0#0#0#0#1#128#0#0#0#0#0#0#1#128#0#0#0#0#0#0#1#128#0#0#0#0#0#0#1#128#0#0#0#0 + +#0#0#1#128#0#0#0#0#0#0#1#128#0#0#0#0#0#0#1#192#0#0#0#0#0#0#1#192#0#0#0#0#0#0 + +#1#192#0#0#0#0#0#0#1#192#0#0#0#0#0#0#1#192#0#0#0#0#0#0#3#192#0#0#0#0#0#0#3 + +#224#0#0#0#0#0#0#3#224#0#0#0#0#0#0#7#224#0#0#0#0#0#0#7#224#0#0#0#0#0#0#7#240 + +#0#0#0#0#0#0#15#240#0#0#0#0#0#0#15#248#0#0#0#0#0#0#31#248#0#0#0#0#0#0#31#252 + +#0#0#0#0#0#0'?'#252#0#0#0#0#0#0#127#254#0#0#0#0#0#0#127#254#0#0#0#0#0#0#255 + +#255#0#0#0#0#0#1#255#255#128#0#0#0#0#3#255#255#192#0#0#0#0#7#255#255#224#0#0 + +#0#0#15#255#255#240#0#0#0#0#31#255#255#248#0#0#0#0'?'#255#255#254#0#0#0#0#127 + +#255#255#255#0#0#0#1#255#255#255#255#192#0#0#7#255#255#255#255#240#0#0#31#255 + +#255#255#255#254#0#0#255#255#255#255#255#255#248#31#255#255#255#255#255#255 + +#255#255#255#255#255'('#0#0#0'0'#0#0#0'`'#0#0#0#1#0' '#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0'UUU'#3'333'#5'UUU'#6'III'#7'@@@'#8'@@@'#8'III'#7 + +'UUU'#6'333'#5'UUU'#3#0#0#0#1#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#1'@@@' + +#4'@@@'#8'@@@'#16'DDD1BBBMCCC_FCCrDBB'#129'FDD'#133'CCCvCCCcDDDRDDD('#240'l@!'#252'qE!' + +#253'yJ$'#252#129'R&'#252#138'X)'#253#134'T('#253'}N%'#252'uG#'#252'oC"'#253 + +'h=#'#248'Z>.'#230'OC;'#211'FEC'#198'DDC'#187'BBB|CCC&999'#9#0#0#0#1#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#2'<<<'#17'CCCWEED'#170'OB9'#211'd=&'#244'qE"'#253#137'V)'#253 + +#164'h.'#255#186'y3'#255#194#130'5'#255#198#135'6'#255#203#140'7'#255#207#145 + +'8'#255#205#143'7'#255#201#137'7'#255#196#132'6'#255#192#127'5'#255#177'r1' + +#255#152'_+'#254'{L%'#252'k?"'#251'[>-'#233'IEA'#203'EDD'#184'DDDq<<<'#30'@@' + +'@'#4#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0'@@@'#4'BBB#EDD'#146'KB<'#205'a='''#242'yK&'#252#166'i/'#255#192#128'6' + +#255#205#143'9'#255#217#159'<'#255#226#169'>'#255#230#173'>'#255#232#176'>' + +#255#235#180'?'#255#237#182'@'#255#236#181'?'#255#234#178'>'#255#231#175'>' + +#255#228#171'>'#255#223#165'<'#255#211#150':'#255#199#136'8'#255#182'v5'#255 + +#146'\,'#253'k@"'#252'W?1'#227'GFE'#199'CCC'#171'???=@@@'#8#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'III'#7'DDD8ECB'#170'[>,'#234'sF$' + +#252#160'e0'#255#196#133';'#255#216#158'@'#255#227#170'A'#255#234#180'C'#255 + +#241#189'D'#255#245#193'E'#255#246#195'F'#255#247#195'F'#255#247#196'E'#255 + +#248#197'F'#255#248#197'E'#255#247#195'F'#255#247#194'F'#255#246#194'E'#255 + +#244#192'E'#255#238#184'C'#255#230#176'C'#255#223#166'A'#255#207#147'='#255 + +#182'w7'#255#138'V+'#253'h>#'#250'NA9'#215'CCC'#186'@@@[;;;'#13#0#0#0#1#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'@@@'#8'EEENGC?'#189'b;%'#245#139'W-'#253#190 + +#127';'#255#212#153'B'#255#227#172'F'#255#239#186'I'#255#242#191'J'#255#244 + +#193'K'#255#246#195'K'#255#247#196'K'#255#247#196'K'#255#247#196'L'#255#247 + +#196'L'#255#247#196'L'#255#247#196'L'#255#247#196'L'#255#247#196'K'#255#247 + +#196'K'#255#246#196'K'#255#245#195'J'#255#243#193'J'#255#242#190'J'#255#234 + +#180'H'#255#221#165'E'#255#202#142'@'#255#173'o5'#255'oC$'#252'T?3'#225'CCC' + +#193'AAAy@@@'#16#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'+++'#6'DDD@K@<'#198'g<"'#250#154 + +'a2'#254#200#141'B'#255#222#168'J'#255#234#183'N'#255#239#189'P'#255#242#192 + +'P'#255#242#193'P'#255#243#193'P'#255#243#193'P'#255#243#193'P'#255#243#193 + +'P'#255#243#193'P'#255#243#193'P'#255#243#193'P'#255#243#193'P'#255#243#193 + ,'P'#255#243#193'P'#255#243#193'P'#255#243#193'P'#255#243#193'P'#255#242#193 + +'P'#255#242#193'P'#255#241#191'P'#255#238#187'N'#255#229#176'L'#255#214#158 + +'G'#255#183'y;'#255'yJ)'#252'[=,'#236'CCB'#195'EEEoFFF'#11#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'UUU'#3 + +'CCC.J?;'#190'g=#'#252#167'k7'#255#205#147'H'#255#226#173'P'#255#235#186'T' + +#255#238#189'T'#255#239#190'U'#255#239#190'U'#255#239#190'U'#255#239#190'U' + +#255#239#190'U'#255#239#190'U'#255#191#152'D'#255'A4'#23#255'>1'#22#255'D6' + +#24#255'H9'#26#255'RA'#29#255#146's4'#255#228#182'Q'#255#239#190'U'#255#239 + +#190'U'#255#239#190'U'#255#239#190'U'#255#239#190'U'#255#238#190'U'#255#237 + +#187'T'#255#232#182'S'#255#217#162'M'#255#191#129'B'#255#132'R-'#253'[9('#240 + +'DDD'#191'CCCW@@@'#8#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#1'>>>'#29'F@='#169'd9#'#250#165'i8'#255#208#151'L'#255 + +#226#174'U'#255#233#184'Y'#255#235#186'Y'#255#235#187'Y'#255#235#187'Y'#255 + +#235#187'Y'#255#235#187'Y'#255#235#187'Y'#255#235#187'Y'#255'<0'#23#255#1#1#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#1#1#0#255#0#0#0#255#6 + +#5#2#255'*!'#16#255'w^-'#255#227#181'W'#255#235#187'Y'#255#235#187'Y'#255#235 + +#186'Y'#255#234#186'Y'#255#231#181'X'#255#218#164'Q'#255#194#133'E'#255'{J*' + +#252'U=/'#230'CCC'#186'EEE?@@@'#4#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0'333'#10'DAAw_9%'#244#150'^4'#254#204#148'N'#255#225#175 + +'Y'#255#230#181'\'#255#231#183'\'#255#231#183'\'#255#231#183'\'#255#231#183 + +'\'#255#231#183'\'#255#231#183'\'#255#231#183'\'#255'hR*'#255#1#1#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#1#1#0#255#1#1#0#255'*!'#17#255#164#130'B'#255#231#183'\' + +#255#231#183'\'#255#231#182']'#255#228#179'['#255#217#165'V'#255#185'|C'#255 + +'nA'''#252'N>5'#219'CCC'#163'@@@'#20#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#128#128#128#2'@@@,W8*'#227#132'P/'#253#196#139'M'#255#220 + +#170'['#255#226#179'_'#255#227#179'_'#255#227#179'_'#255#227#179'_'#255#227 + +#179'_'#255#227#179'_'#255#227#179'_'#255#227#179'_'#255#227#179'_'#255#4#3#2 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#1#1#0 + +#255#7#6#3#255#178#141'J'#255#227#179'_'#255#227#179'_'#255#225#176'^'#255 + +#211#158'U'#255#174'q?'#255'c9"'#252'GA>'#203'BBB]III'#7#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0'FFF'#11'H>:'#150'e:#'#252#186'~H'#255#214#164'\' + +#255#222#174'a'#255#223#175'b'#255#223#175'b'#255#223#175'b'#255#223#175'b' + +#255#223#175'b'#255#223#175'b'#255#223#175'b'#255#223#175'b'#255#188#148'S' + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#1#1#1#255#154'yC'#255#223#175'b'#255#223#175'a'#255 + +#220#171'`'#255#204#150'U'#255#145'Y5'#254'Y8('#238'CCC'#175'FFF'#29#0#0#0#1 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'UUU'#3'AAA3Z7'''#236#148'\6'#255#207#154'Z' + +#255#218#170'b'#255#219#171'd'#255#219#171'd'#255#219#171'd'#255#219#171'd' + +#255#219#171'd'#255#219#171'd'#255#219#171'd'#255#219#171'd'#255#219#171'd' + +#255#211#165'`'#255#6#5#3#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#2#2#1#255#219#171'd'#255#219 + +#171'd'#255#219#171'd'#255#215#166'`'#255#189#129'M'#255'h=$'#252'H>;'#207'E' + +'EEhIII'#7#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'III'#7'K<5'#137'h;$'#252#188#130 + +'O'#255#213#164'b'#255#215#167'd'#255#215#167'd'#255#215#167'd'#255#215#167 + +'d'#255#215#167'd'#255#215#167'd'#255#215#167'd'#255#215#167'd'#255#215#167 + +'d'#255#215#167'd'#255#215#167'd'#255#168#130'N'#255#1#1#1#255#0#0#0#255#0#0 + +#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255 + +#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#200#155']'#255#215#167'd'#255#215#167'd'#255#215#166'd'#255#205#153']' + +#255#153'`:'#255'[6$'#243'CCC'#164';;;'#13#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'7' + +'77'#14'Z5%'#229#150'[8'#255#203#150'^'#255#211#162'e'#255#211#162'e'#255#211 + +#162'e'#255#211#162'e'#255#211#162'e'#255#211#162'e'#255#211#162'e'#255#211 + +#162'e'#255#211#162'e'#255#211#162'e'#255#211#162'e'#255#211#162'e'#255#211 + +#162'e'#255#142'mD'#255#1#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0 + +#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255 + +#0#0#0#255#0#0#0#255#0#0#0#255#1#1#0#255#145'pF'#255#211#162'e'#255#211#162 + +'e'#255#211#162'e'#255#210#159'd'#255#189#131'R'#255'f9#'#252'I@;'#202'===.' + +#128#128#128#2#0#0#0#0#0#0#0#0#128#128#128#2'D??4]3'#30#252#181'yM'#255#206 + +#155'd'#255#207#157'f'#255#207#157'f'#255#207#157'f'#255#207#157'f'#255#205 + +#155'f'#255'S?('#255#1#1#1#255#1#0#0#255#3#2#1#255#15#11#7#255#169#128'S'#255 + ,#207#157'f'#255#207#157'f'#255#207#157'f'#255#16#12#8#255#0#0#0#255#0#0#0#255 + +#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#1#0#0#255#186#141'\' + +#255#207#157'f'#255#207#157'f'#255#207#157'f'#255#207#157'e'#255#201#148'`' + +#255#135'O0'#254'R9-'#226'BBBeIII'#7#0#0#0#0#0#0#0#0'UUU'#6'O8/'#141'o>''' + +#251#193#139'['#255#203#151'e'#255#203#152'e'#255#203#152'e'#255#203#152'e' + +#255#203#152'e'#255#23#17#11#255#1#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0 + +#0#255#1#1#1#255#153'rL'#255#203#152'e'#255#203#152'e'#255',!'#22#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#1#0#0#255' '#24#16 + +#255#203#152'e'#255#203#152'e'#255#203#152'e'#255#203#152'e'#255#203#152'e' + +#255#202#150'd'#255#165'jC'#255'\3!'#247'DDD'#151'MMM'#10#0#0#0#0#0#0#0#0'@@' + +'@'#8'Z6%'#206#142'T5'#255#195#142'a'#255#198#145'c'#255#198#145'c'#255#198 + +#145'c'#255#198#145'c'#255'W@,'#255#1#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255'%'#27#19#255#198#145'c'#255#198#145'c'#255'U>+' + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#1#0#0#255#1#1#1#255#27#20#13#255'vW;' + +#255#198#145'c'#255#198#145'c'#255#198#145'c'#255#198#145'c'#255#198#145'c' + +#255#198#145'c'#255#198#145'c'#255#184'}S'#255'`4 '#252'FA>'#183'@@@'#12#0#0 + +#0#0#0#0#0#0'999'#9']2'#30#243#166'gD'#255#192#138'`'#255#192#139'a'#255#192 + +#139'a'#255#192#139'a'#255#190#137'a'#255#1#1#1#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#8#6#4#255#192#139'a'#255#192#139 + +'a'#255#129']B'#255#1#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#1#0#0#255'Q;)'#255#192#139'a' + +#255#192#139'a'#255#192#139'a'#255#192#139'a'#255#192#139'a'#255#192#139'a' + +#255#192#139'a'#255#192#139'a'#255#192#139'a'#255#192#139'a'#255#188#132'[' + +#255'u@'''#252'M;3'#212'999'#18#0#0#0#0#0#0#0#0'FFF'#11'^1'#29#250#174'oK' + +#255#186#131'\'#255#186#131'\'#255#186#131'\'#255#186#131'\'#255'vS:'#255#1#1 + +#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#1#0#0#255 + +'S:)'#255#186#131'\'#255#186#131'\'#255#184#129'\'#255'('#28#20#255#1#0#0#255 + +#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255'Q9('#255#186#131'\'#255#186#131'\'#255#186#131'\'#255#186#131'\'#255#186 + +#131'\'#255#186#131'\'#255#186#131'\'#255#186#131'\'#255#186#131'\'#255#186 + +#131'\'#255#186#131'\'#255#186#130'['#255#131'I-'#255'Q9-'#221'FFF!'#0#0#0#1 + +#0#0#0#0'M33'#20'_2'#30#251#173'pN'#255#180'{X'#255#180'{X'#255#180'{X'#255 + +#180'{X'#255'-'#30#22#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#2#1#1#255'dE1'#255#180'{X'#255#180'{X'#255#180'{X'#255#180'{X'#255 + +#180'{X'#255'O6&'#255#2#1#1#255#1#1#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255'G0#'#255#180'{X'#255#180'{X'#255#178'{X'#255'hH3'#255'U:)'#255 + +'mK5'#255#180'{X'#255#180'{X'#255#180'{X'#255#180'{X'#255#180'{X'#255#180'{X' + +#255#180'{X'#255#139'P3'#255'U7)'#231'BBB2UUU'#3#0#0#0#0'T1&,c5 '#249#174'rQ' + +#255#178'wW'#255#178'wW'#255#178'wW'#255#178'wW'#255#8#5#4#255#0#0#0#255#0#0 + +#0#255#0#0#0#255#0#0#0#255#1#0#0#255#27#18#13#255#164'nQ'#255#178'wW'#255#178 + +'wW'#255#178'wW'#255#178'wW'#255#178'wW'#255#178'wW'#255#178'wW'#255#178'wW' + +#255#142'_F'#255'H0#'#255#20#13#10#255#25#16#12#255'9'''#28#255'lI5'#255#178 + +'wW'#255#178'wW'#255'kG4'#255#1#1#1#255#1#1#0#255#1#0#0#255#1#0#0#255#3#2#1 + +#255'zQ<'#255#178'wW'#255#178'wW'#255#178'wW'#255#178'wW'#255#178'wW'#255#149 + +'W9'#255'Z5%'#238'DDD-'#128#128#128#2#0#0#0#0'Y3 Bj8#'#248#173'qS'#255#175't' + +'W'#255#175'tW'#255#175'tW'#255#175'tW'#255#1#0#0#255#1#1#1#255#0#0#0#255#0#0 + +#0#255#5#3#3#255'cB2'#255#175'tW'#255#175'tW'#255#175'tW'#255#175'tW'#255#175 + +'tW'#255#175'tW'#255#175'tW'#255#175'tW'#255#175'tW'#255#175'tW'#255#175'tW' + +#255#175'tW'#255#175'tW'#255#175'tW'#255#175'tW'#255#175'tW'#255#175'tW'#255 + +#173'rU'#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#2#1 + +#1#255#152'eL'#255#175'tW'#255#175'tW'#255#175'tW'#255#175'tW'#255#155'[>' + +#255'\4"'#244'@@@'#28#0#0#0#1#0#0#0#0'X0!3g7"'#246#172'oR'#255#174'rV'#255 + +#174'rV'#255#174'rV'#255#166'lR'#255#7#5#3#255#131'VA'#255#155'fM'#255'oI7' + +#255#174'rV'#255#174'rV'#255#174'rV'#255#174'rV'#255#174'rV'#255#174'rV'#255 + +#174'rV'#255#174'rV'#255#174'rV'#255#174'rV'#255#174'rV'#255#174'rV'#255#174 + +'rV'#255#174'rV'#255#174'rV'#255#174'rV'#255#174'rV'#255#174'rV'#255#174'rV' + +#255#153'dL'#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255 + +#0#0#0#255'<'''#29#255#174'rV'#255#174'rV'#255#174'rV'#255#173'qU'#255#151'Y' + +'='#255']6%'#239'333'#15#0#0#0#0#0#0#0#0'O1'''#25'b3'#31#247#168'jN'#255#172 + +'oU'#255#172'oU'#255#172'oU'#255#172'oU'#255#172'oU'#255#172'oU'#255#172'oU' + +#255#172'oU'#255#172'oU'#255#172'oU'#255#172'oU'#255#172'oU'#255#136'XD'#255 + ,'U7*'#255'^=/'#255'kE5'#255#170'oU'#255#172'oU'#255#172'oU'#255#172'oU'#255 + +#172'oU'#255#172'oU'#255#172'oU'#255#172'oU'#255#172'oU'#255#172'oU'#255#172 + +'oU'#255#172'oU'#255#5#3#2#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255'!'#21#16#255#172'oU'#255#172'oU'#255#172'oU'#255#172'oT'#255 + +#143'R7'#255'Y6('#225'@@@'#12#0#0#0#0#0#0#0#0'333'#5'_2'#31#248#167'hL'#255 + +#172'qW'#255#172'qX'#255#172'qX'#255#172'qX'#255#172'qX'#255#172'qX'#255#172 + +'qX'#255#172'qX'#255#172'qX'#255#172'qX'#255#172'qX'#255':&'#30#255#1#0#0#255 + +#1#1#0#255#1#1#1#255#1#1#0#255#4#2#2#255#133'WD'#255#172'qX'#255#172'qX'#255 + +#172'qX'#255#172'qX'#255#172'qX'#255#172'qX'#255#172'qX'#255#172'qX'#255#172 + +'qX'#255#172'qX'#255'E.$'#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#30#20#15#255#172'qX'#255#172'qX'#255#172'qX'#255#172'pV'#255 + +#134'K2'#255'V8)'#199'999'#9#0#0#0#0#0#0#0#0#0#0#0#1'_3'#30#239#164'fJ'#255 + +#175'w]'#255#175'w^'#255#175'w^'#255#175'w^'#255#175'w^'#255#175'w^'#255#175 + +'w^'#255#175'w^'#255#175'w^'#255#175'w^'#255'hF7'#255#1#0#0#255#0#0#0#255#0#0 + +#0#255#0#0#0#255#0#0#0#255#0#0#0#255#7#5#4#255#175'w^'#255#175'w^'#255'{TB' + +#255'X;/'#255']?2'#255#127'VD'#255#175'w^'#255#175'w^'#255#175'w^'#255#175'w' + +'^'#255#165'qY'#255#1#1#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#1#1#1 + +#255'fF7'#255#175'w^'#255#175'w^'#255#175'w^'#255#175'v\'#255'{D-'#253'S5(' + +#154'333'#5#0#0#0#0#0#0#0#0#0#0#0#0'a3'#30#200#149'Z?'#255#179'|c'#255#179'}' + +'e'#255#179'}e'#255#179'}e'#255#179'}e'#255#179'}e'#255#179'}e'#255#179'}e' + +#255#179'}e'#255#179'}e'#255#19#13#11#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#2#1#1#255#179'}e'#255'E0'''#255#1#0#0#255#1#1#0#255 + +#1#1#0#255#0#0#0#255'R:/'#255#179'}e'#255#179'}e'#255#179'}e'#255#179'}e'#255 + +'.!'#26#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#1#1#1#255#177'}e'#255#179 + +'}e'#255#179'}e'#255#179'}e'#255#175'v\'#255'g8$'#251'W7*O'#0#0#0#1#0#0#0#0#0 + +#0#0#0#0#0#0#0'[0'#29'lyD-'#249#181#128'i'#255#183#131'l'#255#183#131'l'#255 + +#183#131'l'#255#183#131'l'#255#183#131'l'#255#183#131'l'#255#183#131'l'#255 + +#183#131'l'#255#183#131'l'#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255'"'#25#20#255#183#131'l'#255#0#0#0#255#0#0#0#255#0#0 + +#0#255#0#0#0#255#0#0#0#255#0#0#0#255'B/'''#255#183#131'l'#255#183#131'l'#255 + +#183#131'l'#255#169'yd'#255#1#1#1#255#0#0#0#255#0#0#0#255#0#0#0#255'#'#25#21 + +#255#183#131'l'#255#183#131'l'#255#183#131'l'#255#183#131'l'#255#167'lQ'#255 + +'^3'#31#248'@@@'#12#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'Y1'#30#26'b5 '#244#178'z' + +'c'#255#187#138't'#255#187#138'u'#255#187#138'u'#255#187#138'u'#255#187#138 + +'u'#255#187#138'u'#255#187#138'u'#255#187#138'u'#255#187#138'u'#255#2#2#1#255 + +#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#1#1#0#255#170'~j'#255#177 + +#130'o'#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#4#3#3 + +#255#187#138'u'#255#187#138'u'#255#187#138'u'#255#187#138'u'#255'jNB'#255#11 + +#8#7#255#0#0#0#255#0#0#0#255#152'p`'#255#187#138'u'#255#187#138'u'#255#187 + +#138'u'#255#186#136'r'#255#144'W?'#255']6#'#193'333'#5#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0'`4'#31#217#160'gN'#255#190#143'{'#255#191#145'}'#255#191 + +#145'}'#255#191#145'}'#255#191#145'}'#255#191#145'}'#255#191#145'}'#255#191 + +#145'}'#255#191#145'}'#255#19#14#12#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255'7*$'#255#191#145'}'#255#164'|k'#255#1#1#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#2#2#1#255#191#145'}'#255#191#145'}'#255 + +#191#145'}'#255#191#145'}'#255#191#145'}'#255#191#145'}'#255#0#0#0#255#30#23 + +#20#255#191#145'}'#255#191#145'}'#255#191#145'}'#255#191#145'}'#255#187#138 + +'t'#255'p>('#249'Y2#U'#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'[/'#27 + +'huB+'#244#190#142'z'#255#195#152#132#255#195#152#132#255#195#152#132#255#195 + +#152#132#255#195#152#132#255#195#152#132#255#195#152#132#255#195#152#132#255 + +'A3,'#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#1#0#0#255#183#142'|'#255 + +#195#152#132#255#138'k]'#255#1#1#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#9#7#6#255#195#152#132#255#195#152#132#255#195#152#132#255#195 + +#152#132#255#195#152#132#255#195#152#132#255#1#1#1#255#160'}m'#255#195#152 + +#132#255#195#152#132#255#195#152#132#255#194#150#131#255#167'pW'#255'`4 '#240 + +'M33'#10#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'@@'#0#4'`3'#30#229 + +#164'nU'#255#197#156#137#255#199#159#141#255#199#159#141#255#199#159#141#255 + +#199#159#141#255#199#159#141#255#199#159#141#255#199#159#141#255'x`U'#255#1#1 + +#1#255#0#0#0#255#0#0#0#255#0#0#0#255#18#14#13#255#199#159#141#255#199#159#141 + +#255' '#26#23#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#1#1#0#255 + +#139'oc'#255#199#159#141#255#199#159#141#255#199#159#141#255#199#159#141#255 + +#199#159#141#255#199#159#141#255'^KC'#255#199#159#141#255#199#159#141#255#199 + +#159#141#255#199#159#141#255#192#147#127#255'rB-'#249'\1 k'#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'\.'#28'Sn>('#243#194#149#131 + ,#255#202#165#148#255#203#165#149#255#203#165#149#255#203#165#149#255#203#165 + +#149#255#203#165#149#255#203#165#149#255#169#138'|'#255#0#0#0#255#1#1#1#255 + +#16#13#11#255#23#19#17#255#171#139'~'#255#203#165#149#255#203#165#149#255#3#3 + +#2#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#1#0#0#255'*"'#31#255#203#165 + +#149#255#203#165#149#255#203#165#149#255#203#165#149#255#203#165#149#255#203 + +#165#149#255#203#165#149#255#203#165#149#255#203#165#149#255#203#165#149#255 + +#203#165#149#255#201#162#145#255#163'mU'#255'_3'#31#227'U'#0#0#3#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'a3'#30#213#153 + +'eM'#254#204#167#151#255#207#172#158#255#207#172#158#255#207#172#158#255#207 + +#172#158#255#207#172#158#255#207#172#158#255#205#170#156#255#0#0#0#255'<1.' + +#255#207#172#158#255#207#172#158#255#207#172#158#255#207#172#158#255#207#172 + +#158#255#20#16#15#255#1#0#0#255#0#0#0#255#0#0#0#255#1#0#0#255'?40'#255#207 + +#172#158#255#207#172#158#255#207#172#158#255#207#172#158#255#207#172#158#255 + +#207#172#158#255#207#172#158#255#207#172#158#255#207#172#158#255#207#172#158 + +#255#207#172#158#255#207#171#156#255#192#147#127#255'k<'''#244'Z.'#29'L'#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +'^/'#27'&b5!'#240#174'{f'#255#209#176#162#255#212#180#167#255#212#180#167#255 + +#212#180#167#255#212#180#167#255#212#180#167#255#212#180#167#255#6#5#5#255 + +#179#151#140#255#212#180#167#255#212#180#167#255#212#180#167#255#212#180#167 + +#255#212#180#167#255#212#180#167#255'gXR'#255#0#0#0#255#0#0#0#255'gXR'#255 + +#212#180#167#255#212#180#167#255#212#180#167#255#212#180#167#255#212#180#167 + +#255#212#180#167#255#212#180#167#255#212#180#167#255#212#180#167#255#212#180 + +#167#255#212#180#167#255#211#179#166#255#202#162#146#255#127'M7'#248'`2'#31 + +#169#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0'[/'#26'Fg:#'#242#190#145#127#255#214#184#172#255#216 + +#187#176#255#216#187#176#255#216#187#176#255#216#187#176#255#216#187#176#255 + +'k]X'#255#216#187#176#255#216#187#176#255#216#187#176#255#216#187#176#255#216 + +#187#176#255#216#187#176#255#216#187#176#255'E<8'#255#0#0#0#255'>63'#255#216 + +#187#176#255#216#187#176#255#216#187#176#255#216#187#176#255#216#187#176#255 + +#216#187#176#255#216#187#176#255#216#187#176#255#216#187#176#255#216#187#176 + +#255#216#187#176#255#216#187#175#255#210#176#163#255#147'_H'#252'`4'#31#210 + +'U++'#6#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'\0'#29'trB-'#242#198#157#140#255#218#191 + +#180#255#221#195#185#255#221#195#185#255#221#195#185#255#221#195#185#255#221 + +#195#185#255#221#195#185#255#221#195#185#255#221#195#185#255#221#195#185#255 + +#221#195#185#255#221#195#185#255#221#195#185#255',''%'#255'920'#255#221#195 + +#185#255#221#195#185#255#221#195#185#255#221#195#185#255#221#195#185#255#221 + +#195#185#255#221#195#185#255#221#195#185#255#221#195#185#255#221#195#185#255 + +#221#195#185#255#220#194#184#255#213#183#170#255#162'oW'#255'b5 '#232'].'#23 + +#22#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'_1'#30#138'l>)'#242#187#143'|' + +#255#221#196#186#255#225#202#193#255#225#203#194#255#225#203#194#255#225#203 + +#194#255#225#203#194#255#225#203#194#255#225#203#194#255#225#203#194#255#225 + +#203#194#255#225#203#194#255#225#203#194#255#225#203#194#255#225#203#194#255 + +#225#203#194#255#225#203#194#255#225#203#194#255#225#203#194#255#225#203#194 + +#255#225#203#194#255#225#203#194#255#225#203#194#255#225#203#194#255#225#203 + +#194#255#224#201#192#255#212#180#168#255#149'aK'#252'a5!'#230']2'#25')'#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'[/'#28'\d9$'#241#172 + +'|h'#255#222#197#187#255#228#206#200#255#230#209#203#255#230#209#203#255#230 + +#209#203#255#230#209#203#255#230#209#203#255#230#209#203#255#230#209#203#255 + +#230#209#203#255#230#209#203#255#230#209#203#255#230#209#203#255#230#209#203 + +#255#230#209#203#255#230#209#203#255#230#209#203#255#230#209#203#255#230#209 + +#203#255#230#209#203#255#230#209#203#255#229#209#202#255#226#204#197#255#208 + +#173#159#255#131'R;'#245'a3'#31#207'Y3'#26#20#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'].'#28'7a5!'#236#137'WB'#248#201 + +#163#148#255#229#210#202#255#233#215#210#255#234#217#212#255#234#217#212#255 + +#234#217#212#255#234#217#212#255#234#217#212#255#234#217#212#255#234#217#212 + +#255#234#217#212#255#234#217#212#255#234#217#212#255#234#217#212#255#234#217 + +#212#255#234#217#212#255#234#217#212#255#234#217#212#255#234#216#211#255#231 + +#212#206#255#221#195#185#255#174#128'm'#255'm>*'#242'`1'#29#163'f33'#5#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + ,#0#0#0#0#0'b'''#20#13'`2'#29#140'd8$'#241#151'hR'#251#211#179#167#255#233#215 + +#210#255#236#220#215#255#237#222#219#255#238#225#221#255#238#225#221#255#238 + +#225#221#255#238#225#221#255#238#225#221#255#238#225#221#255#238#225#221#255 + +#238#225#221#255#238#225#221#255#238#223#220#255#236#221#217#255#234#219#213 + +#255#227#205#198#255#188#146#128#255'wH2'#242'b5 '#219'].'#27'B'#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'X1'#29#26'a3'#30#168'f:$'#242#134'T?' + +#246#179#136'v'#255#214#183#172#255#235#218#214#255#238#225#221#255#239#226 + +#223#255#240#227#224#255#240#227#225#255#240#227#225#255#239#226#223#255#239 + +#225#222#255#238#224#220#255#226#204#196#255#199#161#145#255#158'o['#254'rD-' + +#239'b4"'#232'^2'#30'\'#0#0#0#1#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0'`+ '#24']/'#30'fd6#'#197'c8#'#243'vE0'#240#140'ZF' + +#247#156'mY'#255#171#127'm'#255#184#143#127#255#178#136'v'#255#164'wd'#255 + +#148'dP'#252#130'Q;'#243'l<('#239'b6"'#234'b5!'#151'Z-'#29'>UU'#0#3#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0'].'#23#11'Z/'#29'G^4 fa4!'#130'd6!'#166'd7#'#194 + +'d7"'#182'c6"'#150'_3'#31's\0'#29'YY/'#30'+'#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#255#255#224#3#255#255#255 + +#255#255#254#0#0#127#255#255#255#255#248#0#0#31#255#255#255#255#224#0#0#7#255 + +#255#255#255#192#0#0#3#255#255#255#255#128#0#0#1#255#255#255#255#0#0#0#0#127 + +#255#255#254#0#0#0#0#127#255#255#252#0#0#0#0'?'#255#255#248#0#0#0#0#31#255 + +#255#240#0#0#0#0#15#255#255#240#0#0#0#0#15#255#255#224#0#0#0#0#7#255#255#224 + +#0#0#0#0#3#255#255#192#0#0#0#0#3#255#255#192#0#0#0#0#3#255#255#192#0#0#0#0#1 + +#255#255#128#0#0#0#0#1#255#255#128#0#0#0#0#1#255#255#128#0#0#0#0#1#255#255 + +#128#0#0#0#0#1#255#255#128#0#0#0#0#0#255#255#128#0#0#0#0#0#255#255#128#0#0#0 + +#0#0#255#255#128#0#0#0#0#0#255#255#128#0#0#0#0#1#255#255#128#0#0#0#0#1#255 + +#255#128#0#0#0#0#1#255#255#128#0#0#0#0#1#255#255#192#0#0#0#0#1#255#255#192#0 + +#0#0#0#3#255#255#192#0#0#0#0#3#255#255#224#0#0#0#0#7#255#255#224#0#0#0#0#7 + +#255#255#224#0#0#0#0#15#255#255#240#0#0#0#0#15#255#255#248#0#0#0#0#31#255#255 + +#248#0#0#0#0'?'#255#255#252#0#0#0#0'?'#255#255#254#0#0#0#0#127#255#255#255#0 + +#0#0#0#255#255#255#255#128#0#0#1#255#255#255#255#192#0#0#3#255#255#255#255 + +#224#0#0#15#255#255#255#255#248#0#0#31#255#255#255#255#254#0#0#127#255#255 + +#255#255#255#192#7#255#255#255#255#255#255#255#255#255#255#255#255'('#0#0#0 + +' '#0#0#0'@'#0#0#0#1#0' '#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#2'CCC'#19'FFF'#22'UUU'#3#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0'@@@'#12'EAAGDDB'#133'DDC'#181'HC?'#205'LA;'#213 + +'JB='#212'FC@'#204'EED'#185'DDC'#145'DDDSFFF'#22#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'III'#14'EEBoLA;'#208'eE-'#235'xK(' + +#246#131'R)'#250#139'W*'#251#149'_,'#252#145'\+'#252#136'V*'#250#128'Q('#249 + +'rI)'#244'\D2'#227'FB?'#207'CCC'#134'DDD'#30#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0'EEENMA9'#206'oF)'#245#147']-'#252#187'}4'#255#211#150'9'#255#224 + +#167';'#255#230#174'='#255#234#179'>'#255#233#178'>'#255#228#171'='#255#221 + +#163'<'#255#205#143'8'#255#175'r2'#255#131'R*'#250'eC,'#238'FB?'#205'CCCoUUU' + +#3#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0'@@@'#4'GEA|dB+'#239#142'[.'#252#198#137'<'#255#227#172'C'#255 + +#236#183'E'#255#242#190'F'#255#246#195'G'#255#248#198'G'#255#249#199'H'#255 + +#249#198'H'#255#247#196'G'#255#245#193'G'#255#240#188'F'#255#234#180'D'#255 + +#220#163'A'#255#183'y8'#255'}O*'#250'WA4'#225'CCC'#152'<<<'#17#0#0#0#0#0#0#0 + ,#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#1'G@='#148 + +'lD*'#245#175'u8'#254#221#166'I'#255#234#182'M'#255#242#193'P'#255#243#194'O' + +#255#244#195'O'#255#244#195'P'#255#244#195'P'#255#244#195'P'#255#244#195'P' + +#255#244#195'P'#255#244#195'P'#255#243#194'O'#255#243#194'O'#255#240#190'O' + +#255#230#179'L'#255#212#155'F'#255#148'^1'#252'`A.'#234'CCC'#171'@@@'#12#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'FA>vmB)'#247#189 + +#130'A'#255#224#172'P'#255#236#187'U'#255#238#189'W'#255#238#190'V'#255#238 + +#190'V'#255#238#190'V'#255'fQ%'#255#17#14#6#255#17#13#6#255#16#13#6#255',#' + +#16#255#155'|8'#255#238#190'V'#255#238#190'V'#255#238#189'V'#255#238#189'W' + +#255#233#184'U'#255#217#163'M'#255#164'l8'#254'_>+'#238'DDD'#147#128#128#128 + +#2#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'FDD=e?*'#243#183'}B'#255 + +#223#171'W'#255#232#183'['#255#232#183'\'#255#232#183'\'#255#232#183'\'#255 + +#232#183'\'#255'>1'#25#255#1#1#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255 + +#1#1#1#255#5#4#2#255#22#17#9#255'pX,'#255#218#171'V'#255#232#183'\'#255#230 + +#182'['#255#217#164'T'#255#152'a7'#252'V=1'#228'DDDb'#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#128#128#128#2'Z<-'#215#163'k='#254#217#166'['#255#226#178'`' + +#255#226#179'a'#255#226#179'a'#255#226#179'a'#255#226#179'a'#255#226#179'a' + +#255#5#4#2#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#3#3#1#255',#'#19#255#226#179'a'#255#225#177'_' + +#255#208#154'T'#255#129'O1'#251'H?;'#205'@@@'#20#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0'J@<[vF,'#249#206#153'Y'#255#220#172'b'#255#220#172'c'#255#220#172'c'#255 + +#220#172'c'#255#220#172'c'#255#220#172'c'#255#205#160']'#255#4#3#2#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#1#0#0#255'.$'#21#255#220#172'c'#255#218#170'a'#255#190#132 + +'N'#255'c=)'#242'CCCz'#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'\9('#218#177'vG'#255 + +#213#164'c'#255#214#166'e'#255#214#166'e'#255#214#166'e'#255#214#166'e'#255 + +#214#166'e'#255#214#166'e'#255#214#166'e'#255'v\8'#255#2#2#1#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#11#9#5#255#214#166'e'#255#214#166'e'#255#209#159'a'#255#139'Y' + +'6'#252'K>7'#206'333'#5#0#0#0#0#0#0#0#0'?;9'#19'mA+'#247#201#148'^'#255#209 + +#159'e'#255#209#159'e'#255#209#159'e'#255#146'oF'#255#18#14#9#255#21#16#10 + +#255'O<&'#255#209#159'e'#255#209#159'e'#255'$'#27#17#255#0#0#0#255#0#0#0#255 + +#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#11#8#5#255#209#159'e'#255#209#159'e'#255#208#158'e'#255#185#128'Q'#255 + +'^9)'#240'BBB6'#0#0#0#0#0#0#0#0'P8-q'#144'Z:'#252#201#150'd'#255#202#151'd' + +#255#202#151'd'#255'uW:'#255#2#1#1#255#0#0#0#255#0#0#0#255#1#0#0#255'-!'#22 + +#255#202#151'd'#255'ZC-'#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#1#1#0#255#5#4#3#255'gM3'#255#202#151'd' + +#255#202#151'd'#255#202#151'd'#255#197#145'`'#255'l@*'#248'CCBo'#0#0#0#0#0#0 + +#0#0'^7$'#194#171'pK'#255#194#140'a'#255#194#140'a'#255#194#140'a'#255#6#4#3 + +#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#7#5#4#255#194#140'a'#255#139'eE' + +#255#1#1#1#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#13 + +#9#6#255'wV<'#255#192#138'a'#255#194#140'a'#255#194#140'a'#255#194#140'a'#255 + +#194#140'a'#255#193#140'a'#255#137'T7'#252'K=6'#158#0#0#0#0#0#0#0#0'a6#'#220 + +#177'uQ'#255#185#129'['#255#185#129'['#255#127'Y>'#255#1#1#0#255#0#0#0#255#0 + +#0#0#255#0#0#0#255#2#1#1#255'8'''#27#255#185#129'['#255#185#129'['#255'+'#30 + +#21#255#2#1#1#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0#0#255#13#9#6#255#179'}Y' + +#255#185#129'['#255#185#129'['#255#185#129'['#255#185#129'['#255#185#129'[' + +#255#185#129'['#255#185#129'['#255#152'^>'#255'P:1'#190#0#0#0#0#0#0#0#0'c7#' + +#227#175'sS'#255#178'xW'#255#178'xW'#255','#30#21#255#0#0#0#255#0#0#0#255#0#0 + +#0#255#5#4#3#255'uO:'#255#178'xW'#255#178'xW'#255#178'xW'#255#178'xW'#255'xP' + +':'#255'('#26#19#255#10#7#5#255#10#7#5#255#28#19#13#255#168'rS'#255#163'nO' + +#255#25#17#12#255#6#4#3#255#17#11#8#255'bB/'#255#178'xW'#255#178'xW'#255#178 + +'xW'#255#158'aB'#255'V9,'#210#0#0#0#0#0#0#0#0'f7"'#227#173'sT'#255#175'tW' + +#255#175'tW'#255#15#10#7#255#13#8#6#255#5#4#3#255'+'#29#21#255#169'pU'#255 + +#175'tW'#255#175'tW'#255#175'tW'#255#175'tW'#255#175'tW'#255#175'tW'#255#175 + +'tW'#255#175'tW'#255#175'tW'#255#175'tW'#255#175'tW'#255#17#11#8#255#0#0#0 + +#255#0#0#0#255#0#0#0#255#2#2#1#255#136'ZD'#255#175'tW'#255#175'tW'#255#161'd' + +'G'#255'[8('#211#0#0#0#0#0#0#0#0'e6"'#218#171'nR'#255#173'qV'#255#173'qV'#255 + +#136'YC'#255#173'qV'#255#173'qV'#255#173'qV'#255#173'qV'#255#173'qV'#255'sK9' + +#255'uM:'#255#159'gN'#255#173'qV'#255#173'qV'#255#173'qV'#255#173'qV'#255#173 + +'qV'#255#173'qV'#255#173'qV'#255'5"'#27#255#0#0#0#255#0#0#0#255#0#0#0#255#0#0 + +#0#255'H/$'#255#173'qV'#255#173'qV'#255#153'^D'#255'Y8*'#188#0#0#0#0#0#0#0#0 + +'c5 '#203#170'kQ'#255#174'sY'#255#174'sY'#255#174'sY'#255#174'sY'#255#174'sY' + ,#255#174'sY'#255#164'mU'#255#11#7#6#255#1#1#1#255#1#1#1#255#5#3#2#255#127'TA' + +#255#174'sY'#255#174'sY'#255#174'sY'#255#174'sY'#255#174'sY'#255#174'sY'#255 + +#128'UA'#255#2#1#1#255#0#0#0#255#0#0#0#255#0#0#0#255'J1&'#255#174'sY'#255#174 + +'sY'#255#147'X?'#255'S8,'#140#0#0#0#0#0#0#0#0'd4'#30#153#162'gM'#255#178'{c' + +#255#178'{c'#255#178'{c'#255#178'{c'#255#178'{c'#255#178'{c'#255'A-$'#255#0#0 + +#0#255#0#0#0#255#0#0#0#255#0#0#0#255#20#14#11#255'xSB'#255#6#4#3#255#5#4#3 + +#255#18#12#10#255#170'u_'#255#178'{c'#255#178'{c'#255#9#6#5#255#0#0#0#255#0#0 + +#0#255#3#2#2#255#166's]'#255#178'{c'#255#178'{c'#255#131'P8'#252'S3$>'#0#0#0 + +#0#0#0#0#0'[/'#27'3'#137'T='#247#184#134'o'#255#184#134'o'#255#184#134'o'#255 + +#184#134'o'#255#184#134'o'#255#184#134'o'#255#14#10#9#255#0#0#0#255#0#0#0#255 + +#0#0#0#255#1#1#1#255'\C7'#255#14#10#8#255#0#0#0#255#0#0#0#255#0#0#0#255#14#10 + +#8#255#184#134'o'#255#184#134'o'#255'xWI'#255#2#1#1#255#0#0#0#255#18#14#11 + +#255#184#134'o'#255#184#134'o'#255#183#131'l'#255'h:&'#240#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0'n<%'#218#189#140'x'#255#190#143'z'#255#190#143'z'#255#190#143 + +'z'#255#190#143'z'#255#190#143'z'#255',!'#28#255#0#0#0#255#0#0#0#255#0#0#0 + +#255#9#7#6#255#190#143'z'#255#9#7#6#255#0#0#0#255#0#0#0#255#0#0#0#255#5#4#3 + +#255#190#143'z'#255#190#143'z'#255#190#143'z'#255#159'xe'#255#0#0#0#255#140 + +'jZ'#255#190#143'z'#255#190#143'z'#255#175'yc'#255'b6"'#193#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0'd4'#30#151#167's\'#254#196#154#135#255#196#154#135#255#196#154 + +#135#255#196#154#135#255#196#154#135#255'qYN'#255#0#0#0#255#0#0#0#255#1#1#1 + +#255'v]R'#255#194#152#133#255#5#4#4#255#0#0#0#255#0#0#0#255#0#0#0#255#10#8#7 + +#255#196#154#135#255#196#154#135#255#196#154#135#255#196#154#135#255'"'#27#24 + +#255#196#154#135#255#196#154#135#255#196#154#135#255#131'R<'#248'^1'#28'1'#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'[/'#27#14'o>('#224#198#157#140#255#202#163#146 + +#255#202#163#146#255#202#163#146#255#202#163#146#255#170#138'{'#255#0#0#0#255 + +#8#6#6#255#26#21#19#255#202#163#146#255#143'th'#255#1#1#1#255#0#0#0#255#0#0#0 + +#255#2#2#2#255#143'sg'#255#202#163#146#255#202#163#146#255#202#163#146#255 + +#202#163#146#255#191#155#138#255#202#163#146#255#202#163#146#255#183#135'r' + +#255'd5 '#193#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'd3'#30'{'#156 + +'jS'#248#209#174#160#255#209#174#160#255#209#174#160#255#209#174#160#255#209 + +#174#160#255#2#2#2#255#205#172#158#255#209#174#160#255#209#174#160#255#169 + +#140#129#255#11#9#9#255#1#1#0#255#4#3#3#255#132'oe'#255#209#174#160#255#209 + +#174#160#255#209#174#160#255#209#174#160#255#209#174#160#255#209#174#160#255 + +#209#174#160#255#205#167#152#255'yG3'#235'[/'#27'"'#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'd4'#30#181#179#134'r'#254#215#185#173#255#215 + +#185#173#255#215#185#173#255#215#185#173#255'm^X'#255#215#185#173#255#215#185 + +#173#255#215#185#173#255#215#185#173#255#133'sk'#255#0#0#0#255#156#134'}'#255 + +#215#185#173#255#215#185#173#255#215#185#173#255#215#185#173#255#215#185#173 + +#255#215#185#173#255#215#185#173#255#214#183#172#255#143'^I'#243'b3'#29'`'#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'[/'#27#8'f6 ' + +#205#189#148#131#254#222#197#187#255#222#197#187#255#222#197#187#255#222#197 + +#187#255#222#197#187#255#222#197#187#255#222#197#187#255#222#197#187#255#127 + +'qk'#255#134'wq'#255#222#197#187#255#222#197#187#255#222#197#187#255#222#197 + +#187#255#222#197#187#255#222#197#187#255#222#197#187#255#220#193#183#255#159 + +'o['#247'd3'#30#147#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0'[/'#27#15'c3'#30#193#176#132'q'#248#228#206#199#255 + +#228#208#201#255#228#208#201#255#228#208#201#255#228#208#201#255#228#208#201 + +#255#228#208#201#255#228#208#201#255#228#208#201#255#228#208#201#255#228#208 + +#201#255#228#208#201#255#228#208#201#255#228#208#201#255#228#208#201#255#221 + +#196#186#255#141']I'#237'c3'#29#129#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'[/'#27#2'c3'#29#150 + +#135'XD'#231#208#176#164#255#235#219#215#255#235#219#215#255#235#219#215#255 + +#235#219#215#255#235#219#215#255#235#219#215#255#235#219#215#255#235#219#215 + +#255#235#219#215#255#235#219#215#255#235#219#215#255#232#214#209#255#189#149 + +#133#253'qA+'#220'a2'#29'O'#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'[/'#27 + +'"e4'#30#185#144'cO'#235#195#158#144#254#230#209#203#255#242#231#229#255#242 + +#231#229#255#242#231#229#255#242#231#229#255#242#231#229#255#241#230#226#255 + +#220#193#184#255#180#141'|'#251'zK6'#226'd3'#30#142'[/'#27#10#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'[/'#27#28'b3'#29'{g5'#30 + +#198'xH2'#218#137']J'#229#156'r`'#236#151'mZ'#234#132'VB'#227'q?)'#213'f4'#30 + +#182'_1'#28'W[/'#27#11#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + ,#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'[/'#27#5'[/' + +#27#30'[/'#27#22'[/'#27#1#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#255#252'?'#255 + +#255#192#3#255#255#0#0#255#254#0#0'?'#248#0#0#31#240#0#0#15#240#0#0#7#224#0#0 + +#7#192#0#0#3#192#0#0#3#192#0#0#1#128#0#0#1#128#0#0#1#128#0#0#1#128#0#0#1#128 + +#0#0#1#128#0#0#1#128#0#0#1#128#0#0#1#128#0#0#1#128#0#0#3#192#0#0#3#192#0#0#3 + +#192#0#0#7#224#0#0#7#240#0#0#15#240#0#0#31#248#0#0'?'#252#0#0#127#255#0#0#255 + +#255#192#3#255#255#252'?'#255'('#0#0#0#16#0#0#0' '#0#0#0#1#0' '#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +';;;'#13'ICB7M=4zL>6xFBA;@@@'#16#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0'III'#7'W;,'#171'nC('#245#145'`+'#250#181#127'2'#253#175 + +'z1'#253#139'\*'#250'h?&'#244'P=3'#159'@@@'#12#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0'K921d;'''#235#191#137'7'#254#249#198'E'#255#251#199'F'#255#251#200 + +'F'#255#251#200'F'#255#251#199'F'#255#246#194'E'#255#173'y3'#253'\9)'#229'E>' + +';2'#0#0#0#0#0#0#0#0#0#0#0#0'>2,'#7'nC'''#238#223#171'N'#255#239#191'U'#255 + +#240#192'U'#255#164#131':'#255'@3'#23#255'J;'#26#255'~e-'#255#196#157'E'#255 + +#239#191'U'#255#212#159'J'#255'a<('#231'MMM'#10#0#0#0#0#0#0#0#0'[7('#183#195 + +#145'N'#254#228#180'_'#255#228#180'_'#255#228#180'_'#255'40'#255#210#176#163#255 + +#148'|s'#255'RD?'#255#210#176#163#255#140'fW'#243'[/'#27#2#0#0#0#0'tI6'#209 + +#216#188#178#255#221#195#185#255#213#188#178#255'$'#31#30#255#131'sn'#255'sf' + +'`'#255#0#0#0#255'eYU'#255#221#195#185#255#221#195#185#255#204#180#170#255 + +#207#178#166#255'k>+'#182#0#0#0#0#0#0#0#0'[/'#27#31#156'xi'#240#232#213#207 + +#255#232#213#207#255#180#165#161#255#232#213#207#255#182#167#162#255'ICA'#255 + +#226#207#201#255#232#213#207#255#232#213#207#255#231#213#206#255#134'_O'#233 + +'[/'#27#12#0#0#0#0#0#0#0#0#0#0#0#0'd3'#30'e'#171#139'~'#240#239#226#224#255 + +#242#231#229#255#242#231#229#255#240#229#227#255#242#231#229#255#242#231#229 + +#255#242#231#229#255#235#221#216#255#153'uh'#236'a2'#29'?'#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#0#0#0#0'\0'#27'*'#131'\I'#215#212#191#183#252#239#229#226#255 + +#253#250#252#255#253#249#250#255#236#223#220#255#204#180#172#250'yM;'#196'[/' + +#27#23#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0'[/'#27#3'[/' + +#27'>c3'#29#131'uI4'#190'oA-'#183'b2'#29'v[/'#27'4'#0#0#0#0#0#0#0#0#0#0#0#0#0 + +#0#0#0#0#0#0#0#248#31#172'A'#224#7#172'A'#192#3#172'A'#128#1#172'A'#128#1#172 + +'A'#0#0#172'A'#0#0#172'A'#0#0#172'A'#0#0#172'A'#0#0#172'A'#0#0#172'A'#128#1 + +#172'A'#128#1#172'A'#192#3#172'A'#224#7#172'A'#240#31#172'A' +]); + diff --git a/Sources/CentOS/Demos/Hello/project3.rc b/Sources/CentOS/Demos/Hello/project3.rc new file mode 100644 index 0000000..d4592be --- /dev/null +++ b/Sources/CentOS/Demos/Hello/project3.rc @@ -0,0 +1,7 @@ +#define RT_MANIFEST 24 +#define CREATEPROCESS_MANIFEST_RESOURCE_ID 1 +#define ISOLATIONAWARE_MANIFEST_RESOURCE_ID 2 +#define ISOLATIONAWARE_NOSTATICIMPORT_MANIFEST_RESOURCE_ID 3 + +CREATEPROCESS_MANIFEST_RESOURCE_ID RT_MANIFEST "project3.manifest" +MAINICON ICON "project3.ico" diff --git a/Sources/CentOS/Demos/Hello/unit3.lfm b/Sources/CentOS/Demos/Hello/unit3.lfm new file mode 100644 index 0000000..3c09a0c --- /dev/null +++ b/Sources/CentOS/Demos/Hello/unit3.lfm @@ -0,0 +1,32 @@ +object Form1: TForm1 + Left = 288 + Height = 300 + Top = 174 + Width = 400 + Caption = 'Form1' + ClientHeight = 300 + ClientWidth = 400 + LCLVersion = '0.9.28.2' + object Button1: TButton + Left = 64 + Height = 25 + Top = 200 + Width = 154 + Caption = 'Say "Hello"' + OnClick = Button1Click + TabOrder = 0 + end + object Memo1: TMemo + Left = 36 + Height = 127 + Top = 41 + Width = 324 + Lines.Strings = ( + 'begin' + ' Button1.Caption := ''Hello'';' + ' Button1.Width := Button1.Width + 100;' + 'end.' + ) + TabOrder = 1 + end +end diff --git a/Sources/CentOS/Demos/Hello/unit3.lrs b/Sources/CentOS/Demos/Hello/unit3.lrs new file mode 100644 index 0000000..842dc06 --- /dev/null +++ b/Sources/CentOS/Demos/Hello/unit3.lrs @@ -0,0 +1,12 @@ +{ This is an automatically generated lazarus resource file } + +LazarusResources.Add('TForm1','FORMDATA',[ + 'TPF0'#6'TForm1'#5'Form1'#4'Left'#3' '#1#6'Height'#3','#1#3'Top'#3#174#0#5'Wi' + +'dth'#3#144#1#7'Caption'#6#5'Form1'#12'ClientHeight'#3','#1#11'ClientWidth'#3 + +#144#1#10'LCLVersion'#6#8'0.9.28.2'#0#7'TButton'#7'Button1'#4'Left'#2'@'#6'H' + +'eight'#2#25#3'Top'#3#200#0#5'Width'#3#154#0#7'Caption'#6#11'Say "Hello"'#7 + +'OnClick'#7#12'Button1Click'#8'TabOrder'#2#0#0#0#5'TMemo'#5'Memo1'#4'Left'#2 + +'$'#6'Height'#2#127#3'Top'#2')'#5'Width'#3'D'#1#13'Lines.Strings'#1#6#5'begi' + +'n'#6#31' Button1.Caption := ''Hello'';'#6') Button1.Width := Button1.' + +'Width + 100;'#6#4'end.'#0#8'TabOrder'#2#1#0#0#0 +]); diff --git a/Sources/CentOS/Demos/Hello/unit3.pas b/Sources/CentOS/Demos/Hello/unit3.pas new file mode 100644 index 0000000..5d03c96 --- /dev/null +++ b/Sources/CentOS/Demos/Hello/unit3.pas @@ -0,0 +1,70 @@ +unit Unit3; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, FileUtil, LResources, Forms, Controls, Graphics, Dialogs, + StdCtrls, + PaxCompilerRegister, + PaxCompiler, PaxInterpreter, PaxRegister, IMPORT_COMMON; + + +type + + { TForm1 } + + TForm1 = class(TForm) + Button1: TButton; + Memo1: TMemo; + procedure Button1Click(Sender: TObject); + private + { private declarations } + public + { public declarations } + end; + +var + Form1: TForm1; + +implementation + +{ TForm1 } + +procedure TForm1.Button1Click(Sender: TObject); +var + PaxCompiler1: TPaxCompiler; + PaxInterpreter1: TPaxInterpreter; + PaxPascalLanguage1: TPaxPascalLanguage; + I: Integer; +begin + PaxCompiler1 := TPaxCompiler.Create(nil); + PaxInterpreter1 := TPaxInterpreter.Create(nil); + PaxPascalLanguage1 := TPaxPascalLanguage.Create(nil); + + try + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + + PaxCompiler1.RegisterVariable(0, 'Button1: TButton', @Button1); + + PaxCompiler1.AddModule('1', PaxPascalLanguage1.LanguageName); + PaxCompiler1.AddCode('1', Memo1.Lines.Text); + + if PaxCompiler1.Compile(PaxInterpreter1) then + PaxInterpreter1.Run + else + for I:=0 to PaxCompiler1.ErrorCount - 1 do + ShowMessage(PaxCompiler1.ErrorMessage[I]); + finally + PaxCompiler1.Free; + PaxInterpreter1.Free; + PaxPascalLanguage1.Free; + end; +end; + +initialization + {$I unit3.lrs} + +end. + diff --git a/Sources/CentOS/Demos/ImportAbstractClass/project1.ico b/Sources/CentOS/Demos/ImportAbstractClass/project1.ico new file mode 100644 index 0000000..0341321 Binary files /dev/null and b/Sources/CentOS/Demos/ImportAbstractClass/project1.ico differ diff --git a/Sources/CentOS/Demos/ImportAbstractClass/project1.lpi b/Sources/CentOS/Demos/ImportAbstractClass/project1.lpi new file mode 100644 index 0000000..082ed7d --- /dev/null +++ b/Sources/CentOS/Demos/ImportAbstractClass/project1.lpi @@ -0,0 +1,112 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/Sources/CentOS/Demos/ImportAbstractClass/project1.lpr b/Sources/CentOS/Demos/ImportAbstractClass/project1.lpr new file mode 100644 index 0000000..6bd7322 --- /dev/null +++ b/Sources/CentOS/Demos/ImportAbstractClass/project1.lpr @@ -0,0 +1,21 @@ +program project1; + +{$mode objfpc}{$H+} + +uses + {$IFDEF UNIX}{$IFDEF UseCThreads} + cthreads, + {$ENDIF}{$ENDIF} + Interfaces, // this includes the LCL widgetset + Forms, Unit1, LResources + { you can add units after this }; + +{$IFDEF WINDOWS}{$R project1.rc}{$ENDIF} + +begin + {$I project1.lrs} + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. + diff --git a/Sources/CentOS/Demos/ImportAbstractClass/project1.lps b/Sources/CentOS/Demos/ImportAbstractClass/project1.lps new file mode 100644 index 0000000..45dd738 --- /dev/null +++ b/Sources/CentOS/Demos/ImportAbstractClass/project1.lps @@ -0,0 +1,29 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/Sources/CentOS/Demos/ImportAbstractClass/project1.rc b/Sources/CentOS/Demos/ImportAbstractClass/project1.rc new file mode 100644 index 0000000..cd8e7b0 --- /dev/null +++ b/Sources/CentOS/Demos/ImportAbstractClass/project1.rc @@ -0,0 +1,7 @@ +#define RT_MANIFEST 24 +#define CREATEPROCESS_MANIFEST_RESOURCE_ID 1 +#define ISOLATIONAWARE_MANIFEST_RESOURCE_ID 2 +#define ISOLATIONAWARE_NOSTATICIMPORT_MANIFEST_RESOURCE_ID 3 + +CREATEPROCESS_MANIFEST_RESOURCE_ID RT_MANIFEST "project1.manifest" +MAINICON ICON "project1.ico" diff --git a/Sources/CentOS/Demos/ImportAbstractClass/unit1.lfm b/Sources/CentOS/Demos/ImportAbstractClass/unit1.lfm new file mode 100644 index 0000000..44ffc1e --- /dev/null +++ b/Sources/CentOS/Demos/ImportAbstractClass/unit1.lfm @@ -0,0 +1,46 @@ +object Form1: TForm1 + Left = 286 + Height = 395 + Top = 169 + Width = 400 + ActiveControl = Memo1 + Caption = 'Form1' + ClientHeight = 395 + ClientWidth = 400 + LCLVersion = '0.9.28.2' + object Button1: TButton + Left = 24 + Height = 25 + Top = 352 + Width = 75 + Caption = 'Run script' + OnClick = Button1Click + TabOrder = 0 + end + object Memo1: TMemo + Left = 18 + Height = 288 + Top = 16 + Width = 358 + Lines.Strings = ( + 'type' + ' TMyScriptClass = class(TMyHostClass)' + ' procedure P; override;' + ' end;' + 'procedure TMyScriptClass.P;' + 'begin' + ' print(''Hello from script!'');' + 'end;' + 'var X: TMyScriptClass;' + 'begin' + ' X := TMyScriptClass.Create;' + ' try ' + ' PassToHost(X);' + ' finally' + ' X.Free;' + ' end;' + 'end.' + ) + TabOrder = 1 + end +end diff --git a/Sources/CentOS/Demos/ImportAbstractClass/unit1.lrs b/Sources/CentOS/Demos/ImportAbstractClass/unit1.lrs new file mode 100644 index 0000000..6fba70f --- /dev/null +++ b/Sources/CentOS/Demos/ImportAbstractClass/unit1.lrs @@ -0,0 +1,16 @@ +{ This is an automatically generated lazarus resource file } + +LazarusResources.Add('TForm1','FORMDATA',[ + 'TPF0'#6'TForm1'#5'Form1'#4'Left'#3#30#1#6'Height'#3#139#1#3'Top'#3#169#0#5'W' + +'idth'#3#144#1#13'ActiveControl'#7#5'Memo1'#7'Caption'#6#5'Form1'#12'ClientH' + +'eight'#3#139#1#11'ClientWidth'#3#144#1#10'LCLVersion'#6#8'0.9.28.2'#0#7'TBu' + +'tton'#7'Button1'#4'Left'#2#24#6'Height'#2#25#3'Top'#3'`'#1#5'Width'#2'K'#7 + +'Caption'#6#10'Run script'#7'OnClick'#7#12'Button1Click'#8'TabOrder'#2#0#0#0 + +#5'TMemo'#5'Memo1'#4'Left'#2#18#6'Height'#3' '#1#3'Top'#2#16#5'Width'#3'f'#1 + +#13'Lines.Strings'#1#6#4'type'#6'& TMyScriptClass = class(TMyHostClass)'#6 + +#26' procedure P; override;'#6#5' end;'#6#27'procedure TMyScriptClass.P;' + +#6#5'begin'#6#30' print(''Hello from script!'');'#6#4'end;'#6#23'var X: TM' + +'yScriptClass;'#6#5'begin'#6#30' X := TMyScriptClass.Create;'#6#9' try ' + +' '#6#19' PassToHost(X);'#6#10' finally'#6#12' X.Free;'#6#6' end;' + +#6#4'end.'#0#8'TabOrder'#2#1#0#0#0 +]); diff --git a/Sources/CentOS/Demos/ImportAbstractClass/unit1.pas b/Sources/CentOS/Demos/ImportAbstractClass/unit1.pas new file mode 100644 index 0000000..0ebd6d8 --- /dev/null +++ b/Sources/CentOS/Demos/ImportAbstractClass/unit1.pas @@ -0,0 +1,90 @@ +unit Unit1; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, FileUtil, LResources, Forms, Controls, Graphics, Dialogs, + StdCtrls, + PaxCompilerRegister, + PaxCompiler, PaxInterpreter, PaxRegister; + + +type + + { TForm1 } + + TForm1 = class(TForm) + Button1: TButton; + Memo1: TMemo; + procedure Button1Click(Sender: TObject); + private + { private declarations } + public + { public declarations } + end; + + TMyHostClass = class + public + procedure P; virtual; abstract; + end; + +var + Form1: TForm1; + +implementation + +{ TForm1 } + +procedure PassToHost(X: TMyHostClass); +begin + ShowMessage('At host side: ' + X.ClassName); + X.P; +end; + +procedure TForm1.Button1Click(Sender: TObject); +var + PaxCompiler1: TPaxCompiler; + PaxInterpreter1: TPaxInterpreter; + PaxPascalLanguage1: TPaxPascalLanguage; + I: Integer; +begin + I := RegisterClassType(0, TMyHostClass); + RegisterHeader(I, + 'procedure P; virtual; abstract;', + nil); + + RegisterHeader(0, + 'procedure PassToHost(X: TMyHostClass);', + @ PassToHost); + + PaxCompiler1 := TPaxCompiler.Create(nil); + PaxInterpreter1 := TPaxInterpreter.Create(nil); + PaxPascalLanguage1 := TPaxPascalLanguage.Create(nil); + + try + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + PaxCompiler1.AddModule('1', 'Pascal'); + PaxCompiler1.AddCode('1', Memo1.Lines.Text); + if PaxCompiler1.Compile(PaxInterpreter1) then + begin + PaxInterpreter1.Run; + end + else + begin + ShowMessage(PaxCompiler1.ErrorMessage[0]); + end; + finally + PaxCompiler1.Free; + PaxInterpreter1.Free; + PaxPascalLanguage1.Free; + end; +end; + +initialization + + {$I unit1.lrs} + +end. + diff --git a/Sources/Mac OS/Demos/Hello/Project1.deployproj b/Sources/Mac OS/Demos/Hello/Project1.deployproj new file mode 100644 index 0000000..80f228e --- /dev/null +++ b/Sources/Mac OS/Demos/Hello/Project1.deployproj @@ -0,0 +1,64 @@ + + + + 12 + + + + + + + + Project1.app\Contents\ + Info.plist + 1 + + + + + Project1.app\Contents\MacOS\ + libcgunwind.1.0.dylib + 1 + + + + + Project1.app\Contents\MacOS\ + Project1 + 1 + + + True + + + Project1.app\Contents\ + Entitlements.plist + 1 + + + + + Project1.app\Contents\Resources\ + Project1.icns + 1 + + + + + Project1.app\Contents\MacOS\ + Project1.rsm + 1 + + + + + + + Project1.app\ + libcgunwind.1.0.dylib + 1 + + + + + diff --git a/Sources/Mac OS/Demos/Hello/Project1.dpr b/Sources/Mac OS/Demos/Hello/Project1.dpr new file mode 100644 index 0000000..0e8a4b4 --- /dev/null +++ b/Sources/Mac OS/Demos/Hello/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + FMX.Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Sources/Mac OS/Demos/Hello/Project1.dproj b/Sources/Mac OS/Demos/Hello/Project1.dproj new file mode 100644 index 0000000..4eb09f1 --- /dev/null +++ b/Sources/Mac OS/Demos/Hello/Project1.dproj @@ -0,0 +1,182 @@ + + + {C6763FB4-C646-494F-837F-0AA58A204166} + 15.1 + FMX + Project1.dpr + True + Debug + OSX32 + 5 + Application + + + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Cfg_1 + true + true + + + true + Base + true + + + $(BDS)\bin\delphi_PROJECTICON.ico + System;Xml;Data;Datasnap;Web;Soap;$(DCC_Namespace) + $(BDS)\bin\delphi_PROJECTICNS.icns + .\$(Platform)\$(Config) + .\$(Platform)\$(Config) + false + false + false + false + false + + + FireDACASADriver;FireDACSqliteDriver;bindcompfmx;DBXSqliteDriver;FireDACPgDriver;FireDACODBCDriver;fmx;rtl;dbrtl;DbxClientDriver;IndySystem;FireDACCommon;bindcomp;DBXInterBaseDriver;DataSnapCommon;xmlrtl;ibxpress;DbxCommonDriver;IndyProtocols;dbxcds;DBXMySQLDriver;FireDACCommonDriver;soaprtl;bindengine;bindcompdbx;FMXTee;fmxFireDAC;FireDACADSDriver;CustomIPTransport;FireDAC;dsnap;IndyIPServer;fmxase;IndyCore;IndyIPCommon;CloudService;FireDACIBDriver;FmxTeeUI;inet;fmxobj;FireDACMySQLDriver;inetdbxpress;fmxdae;RESTComponents;FireDACMSAccDriver;dbexpress;IndyIPClient;$(DCC_UsePackage) + true + CFBundleName=$(MSBuildProjectName);CFBundleDisplayName=$(MSBuildProjectName);CFBundleIdentifier=$(MSBuildProjectName);CFBundleVersion=1.0.0;CFBundlePackageType=APPL;CFBundleSignature=????;CFBundleAllowMixedLocalizations=YES;CFBundleExecutable=$(MSBuildProjectName);NSHighResolutionCapable=true;LSApplicationCategoryType=public.app-category.utilities + + + FireDACASADriver;FireDACSqliteDriver;bindcompfmx;DBXSqliteDriver;vcldbx;FireDACPgDriver;FireDACODBCDriver;fmx;rtl;dbrtl;DbxClientDriver;IndySystem;FireDACCommon;bindcomp;TeeDB;vclib;inetdbbde;DBXInterBaseDriver;Tee;DataSnapCommon;vclFireDAC;xmlrtl;svnui;ibxpress;DbxCommonDriver;vclimg;IndyProtocols;dbxcds;DBXMySQLDriver;FireDACCommonDriver;MetropolisUILiveTile;DPFiOSPackagesRXE5;soaprtl;bindengine;vclactnband;vcldb;bindcompdbx;vcldsnap;bindcompvcl;FMXTee;TeeUI;vclie;fmxFireDAC;FireDACADSDriver;vcltouch;CustomIPTransport;vclribbon;VclSmp;FireDAC;dsnap;IndyIPServer;Intraweb;fmxase;vcl;IndyCore;VCLRESTComponents;IndyIPCommon;CloudService;CodeSiteExpressPkg;dsnapcon;FireDACIBDriver;FmxTeeUI;inet;fmxobj;FireDACMySQLDriver;vclx;inetdbxpress;svn;fmxdae;RESTComponents;bdertl;FireDACMSAccDriver;adortl;dbexpress;IndyIPClient;$(DCC_UsePackage) + $(BDS)\bin\default_app.manifest + Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) + 1033 + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments= + true + + + FireDACASADriver;FireDACSqliteDriver;bindcompfmx;DBXSqliteDriver;FireDACPgDriver;FireDACODBCDriver;fmx;rtl;dbrtl;DbxClientDriver;IndySystem;FireDACCommon;bindcomp;TeeDB;vclib;DBXInterBaseDriver;Tee;DataSnapCommon;vclFireDAC;xmlrtl;ibxpress;DbxCommonDriver;vclimg;IndyProtocols;dbxcds;DBXMySQLDriver;FireDACCommonDriver;MetropolisUILiveTile;soaprtl;bindengine;vclactnband;vcldb;bindcompdbx;vcldsnap;bindcompvcl;FMXTee;TeeUI;vclie;fmxFireDAC;FireDACADSDriver;vcltouch;CustomIPTransport;vclribbon;VclSmp;FireDAC;dsnap;IndyIPServer;Intraweb;fmxase;vcl;IndyCore;VCLRESTComponents;IndyIPCommon;CloudService;dsnapcon;FireDACIBDriver;FmxTeeUI;inet;fmxobj;FireDACMySQLDriver;vclx;inetdbxpress;fmxdae;RESTComponents;FireDACMSAccDriver;adortl;dbexpress;IndyIPClient;$(DCC_UsePackage) + + + DEBUG;$(DCC_Define) + true + false + true + true + true + + + false + + + false + RELEASE;$(DCC_Define) + 0 + 0 + + + + MainSource + + +
Form1
+ fmx + + + Cfg_2 + Base + + + Base + + + Cfg_1 + Base + + + + Delphi.Personality.12 + + + + + False + False + 1 + 0 + 0 + 0 + False + False + False + False + False + 1033 + 1252 + + + + + 1.0.0.0 + + + + + + 1.0.0.0 + + + + + + + + + + + + + + + + + + + + + + + + + + + Project1.dpr + + + + + True + True + False + + + 12 + + + + diff --git a/Sources/Mac OS/Demos/Hello/Project1.res b/Sources/Mac OS/Demos/Hello/Project1.res new file mode 100644 index 0000000..36f26e2 Binary files /dev/null and b/Sources/Mac OS/Demos/Hello/Project1.res differ diff --git a/Sources/Mac OS/Demos/Hello/Unit1.fmx b/Sources/Mac OS/Demos/Hello/Unit1.fmx new file mode 100644 index 0000000..47dcce5 --- /dev/null +++ b/Sources/Mac OS/Demos/Hello/Unit1.fmx @@ -0,0 +1,39 @@ +object Form1: TForm1 + Left = 0 + Top = 0 + Caption = 'Hello' + ClientHeight = 480 + ClientWidth = 640 + FormFactor.Width = 320 + FormFactor.Height = 480 + FormFactor.Devices = [dkDesktop, dkiPhone, dkiPad] + DesignerMobile = False + DesignerWidth = 0 + DesignerHeight = 0 + DesignerDeviceName = '' + DesignerOrientation = 0 + DesignerOSVersion = '' + object Button1: TButton + Height = 22.000000000000000000 + Position.X = 480.000000000000000000 + Position.Y = 112.000000000000000000 + TabOrder = 0 + Text = 'Say "Hello"' + Width = 80.000000000000000000 + OnClick = Button1Click + end + object Memo1: TMemo + Touch.InteractiveGestures = [igPan, igLongTap, igDoubleTap] + Height = 153.000000000000000000 + Position.X = 16.000000000000000000 + Position.Y = 32.000000000000000000 + TabOrder = 1 + Width = 385.000000000000000000 + Lines.Strings = ( + 'uses Unit1;' + 'begin' + ' Form1.Button1.Text := '#39'Hello'#39';' + 'end.' + '') + end +end diff --git a/Sources/Mac OS/Demos/Hello/Unit1.pas b/Sources/Mac OS/Demos/Hello/Unit1.pas new file mode 100644 index 0000000..df0caeb --- /dev/null +++ b/Sources/Mac OS/Demos/Hello/Unit1.pas @@ -0,0 +1,68 @@ +unit Unit1; + +interface + +uses + System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants, + FMX.Types, FMX.Graphics, FMX.Controls, FMX.Forms, FMX.Dialogs, FMX.StdCtrls, + FMX.Layouts, FMX.Memo, PaxCompiler, PaxRunner, PaxInterpreter; + +type + TForm1 = class(TForm) + Button1: TButton; + Memo1: TMemo; + procedure Button1Click(Sender: TObject); + private + { Private declarations } + procedure DoOnImportUnit(Sender: TPaxCompiler; Id: Integer; + const AFullName: string); + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.fmx} + +procedure TForm1.DoOnImportUnit(Sender: TPaxCompiler; Id: Integer; + const AFullName: string); +begin +// Global members must be imported explicitly. + + Sender.RegisterVariable(Id, 'Form1: TForm1', @Form1); +end; + +procedure TForm1.Button1Click(Sender: TObject); +var + PaxCompiler1: TPaxCompiler; + PaxInterpreter1: TPaxInterpreter; + PaxPascalLanguage1: TPaxPascalLanguage; +begin + PaxCompiler1 := TPaxCompiler.Create(nil); + PaxInterpreter1 := TPaxInterpreter.Create(nil); + PaxPascalLanguage1 := TPaxPascalLanguage.Create(nil); + try + PaxCompiler1.OnImportUnit := DoOnImportUnit; + + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + PaxCompiler1.AddModule('1', 'Pascal'); + PaxCompiler1.AddCode('1', Memo1.Lines.Text); + if PaxCompiler1.Compile(PaxInterpreter1) then + begin + PaxInterpreter1.Run; + end + else + begin + ShowMessage(PaxCompiler1.ErrorMessage[0]); + end; + finally + PaxCompiler1.Free; + PaxInterpreter1.Free; + PaxPascalLanguage1.Free; + end; +end; + +end. diff --git a/Sources/Mac OS/Demos/ImportAbstractClasses/Project1.deployproj b/Sources/Mac OS/Demos/ImportAbstractClasses/Project1.deployproj new file mode 100644 index 0000000..80f228e --- /dev/null +++ b/Sources/Mac OS/Demos/ImportAbstractClasses/Project1.deployproj @@ -0,0 +1,64 @@ + + + + 12 + + + + + + + + Project1.app\Contents\ + Info.plist + 1 + + + + + Project1.app\Contents\MacOS\ + libcgunwind.1.0.dylib + 1 + + + + + Project1.app\Contents\MacOS\ + Project1 + 1 + + + True + + + Project1.app\Contents\ + Entitlements.plist + 1 + + + + + Project1.app\Contents\Resources\ + Project1.icns + 1 + + + + + Project1.app\Contents\MacOS\ + Project1.rsm + 1 + + + + + + + Project1.app\ + libcgunwind.1.0.dylib + 1 + + + + + diff --git a/Sources/Mac OS/Demos/ImportAbstractClasses/Project1.dpr b/Sources/Mac OS/Demos/ImportAbstractClasses/Project1.dpr new file mode 100644 index 0000000..0e8a4b4 --- /dev/null +++ b/Sources/Mac OS/Demos/ImportAbstractClasses/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + FMX.Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Sources/Mac OS/Demos/ImportAbstractClasses/Project1.dproj b/Sources/Mac OS/Demos/ImportAbstractClasses/Project1.dproj new file mode 100644 index 0000000..158be41 --- /dev/null +++ b/Sources/Mac OS/Demos/ImportAbstractClasses/Project1.dproj @@ -0,0 +1,182 @@ + + + {D3B10800-E864-47AB-9EDF-146BBC5E7C8A} + 15.1 + FMX + Project1.dpr + True + Debug + OSX32 + 5 + Application + + + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Cfg_1 + true + true + + + true + Base + true + + + $(BDS)\bin\delphi_PROJECTICON.ico + System;Xml;Data;Datasnap;Web;Soap;$(DCC_Namespace) + $(BDS)\bin\delphi_PROJECTICNS.icns + .\$(Platform)\$(Config) + .\$(Platform)\$(Config) + false + false + false + false + false + + + FireDACASADriver;FireDACSqliteDriver;bindcompfmx;DBXSqliteDriver;FireDACPgDriver;FireDACODBCDriver;fmx;rtl;dbrtl;DbxClientDriver;IndySystem;FireDACCommon;bindcomp;DBXInterBaseDriver;DataSnapCommon;xmlrtl;ibxpress;DbxCommonDriver;IndyProtocols;dbxcds;DBXMySQLDriver;FireDACCommonDriver;soaprtl;bindengine;bindcompdbx;FMXTee;fmxFireDAC;FireDACADSDriver;CustomIPTransport;FireDAC;dsnap;IndyIPServer;fmxase;IndyCore;IndyIPCommon;CloudService;FireDACIBDriver;FmxTeeUI;inet;fmxobj;FireDACMySQLDriver;inetdbxpress;fmxdae;RESTComponents;FireDACMSAccDriver;dbexpress;IndyIPClient;$(DCC_UsePackage) + true + CFBundleName=$(MSBuildProjectName);CFBundleDisplayName=$(MSBuildProjectName);CFBundleIdentifier=$(MSBuildProjectName);CFBundleVersion=1.0.0;CFBundlePackageType=APPL;CFBundleSignature=????;CFBundleAllowMixedLocalizations=YES;CFBundleExecutable=$(MSBuildProjectName);NSHighResolutionCapable=true;LSApplicationCategoryType=public.app-category.utilities + + + FireDACASADriver;FireDACSqliteDriver;bindcompfmx;DBXSqliteDriver;vcldbx;FireDACPgDriver;FireDACODBCDriver;fmx;rtl;dbrtl;DbxClientDriver;IndySystem;FireDACCommon;bindcomp;TeeDB;vclib;inetdbbde;DBXInterBaseDriver;Tee;DataSnapCommon;vclFireDAC;xmlrtl;svnui;ibxpress;DbxCommonDriver;vclimg;IndyProtocols;dbxcds;DBXMySQLDriver;FireDACCommonDriver;MetropolisUILiveTile;DPFiOSPackagesRXE5;soaprtl;bindengine;vclactnband;vcldb;bindcompdbx;vcldsnap;bindcompvcl;FMXTee;TeeUI;vclie;fmxFireDAC;FireDACADSDriver;vcltouch;CustomIPTransport;vclribbon;VclSmp;FireDAC;dsnap;IndyIPServer;Intraweb;fmxase;vcl;IndyCore;VCLRESTComponents;IndyIPCommon;CloudService;CodeSiteExpressPkg;dsnapcon;FireDACIBDriver;FmxTeeUI;inet;fmxobj;FireDACMySQLDriver;vclx;inetdbxpress;svn;fmxdae;RESTComponents;bdertl;FireDACMSAccDriver;adortl;dbexpress;IndyIPClient;$(DCC_UsePackage) + $(BDS)\bin\default_app.manifest + Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) + 1033 + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments= + true + + + FireDACASADriver;FireDACSqliteDriver;bindcompfmx;DBXSqliteDriver;FireDACPgDriver;FireDACODBCDriver;fmx;rtl;dbrtl;DbxClientDriver;IndySystem;FireDACCommon;bindcomp;TeeDB;vclib;DBXInterBaseDriver;Tee;DataSnapCommon;vclFireDAC;xmlrtl;ibxpress;DbxCommonDriver;vclimg;IndyProtocols;dbxcds;DBXMySQLDriver;FireDACCommonDriver;MetropolisUILiveTile;soaprtl;bindengine;vclactnband;vcldb;bindcompdbx;vcldsnap;bindcompvcl;FMXTee;TeeUI;vclie;fmxFireDAC;FireDACADSDriver;vcltouch;CustomIPTransport;vclribbon;VclSmp;FireDAC;dsnap;IndyIPServer;Intraweb;fmxase;vcl;IndyCore;VCLRESTComponents;IndyIPCommon;CloudService;dsnapcon;FireDACIBDriver;FmxTeeUI;inet;fmxobj;FireDACMySQLDriver;vclx;inetdbxpress;fmxdae;RESTComponents;FireDACMSAccDriver;adortl;dbexpress;IndyIPClient;$(DCC_UsePackage) + + + DEBUG;$(DCC_Define) + true + false + true + true + true + + + false + + + false + RELEASE;$(DCC_Define) + 0 + 0 + + + + MainSource + + +
Form1
+ fmx + + + Cfg_2 + Base + + + Base + + + Cfg_1 + Base + + + + Delphi.Personality.12 + + + + + False + False + 1 + 0 + 0 + 0 + False + False + False + False + False + 1033 + 1252 + + + + + 1.0.0.0 + + + + + + 1.0.0.0 + + + + + + + + + + + + + + + + + + + + + + + + + + + Project1.dpr + + + + + True + True + False + + + 12 + + + + diff --git a/Sources/Mac OS/Demos/ImportAbstractClasses/Project1.res b/Sources/Mac OS/Demos/ImportAbstractClasses/Project1.res new file mode 100644 index 0000000..36f26e2 Binary files /dev/null and b/Sources/Mac OS/Demos/ImportAbstractClasses/Project1.res differ diff --git a/Sources/Mac OS/Demos/ImportAbstractClasses/Unit1.fmx b/Sources/Mac OS/Demos/ImportAbstractClasses/Unit1.fmx new file mode 100644 index 0000000..f650ae5 --- /dev/null +++ b/Sources/Mac OS/Demos/ImportAbstractClasses/Unit1.fmx @@ -0,0 +1,56 @@ +object Form1: TForm1 + Left = 0 + Top = 0 + Caption = 'Form1' + ClientHeight = 480 + ClientWidth = 640 + FormFactor.Width = 320 + FormFactor.Height = 480 + FormFactor.Devices = [dkDesktop, dkiPhone, dkiPad] + DesignerMobile = False + DesignerWidth = 0 + DesignerHeight = 0 + DesignerDeviceName = '' + DesignerOrientation = 0 + DesignerOSVersion = '' + object Memo1: TMemo + Touch.InteractiveGestures = [igPan, igLongTap, igDoubleTap] + Height = 450.000000000000000000 + Position.X = 16.000000000000000000 + Position.Y = 16.000000000000000000 + TabOrder = 0 + Width = 500.000000000000000000 + Lines.Strings = ( + 'uses' + ' Unit1;' + '' + 'type' + ' TMyScriptClass = class(TMyHostClass)' + ' constructor Create; override;' + ' procedure P; override;' + ' end;' + '' + 'constructor TMyScriptClass.Create;' + 'begin' + ' print '#39'Script object of '#39' + ClassName + '#39' is created.'#39';' + 'end;' + '' + 'procedure TMyScriptClass.P;' + 'begin' + ' print '#39'Hello from script!'#39';' + 'end;' + '' + 'begin' + 'end.' + '') + end + object Button1: TButton + Height = 22.000000000000000000 + Position.X = 536.000000000000000000 + Position.Y = 416.000000000000000000 + TabOrder = 1 + Text = 'Run' + Width = 80.000000000000000000 + OnClick = Button1Click + end +end diff --git a/Sources/Mac OS/Demos/ImportAbstractClasses/Unit1.pas b/Sources/Mac OS/Demos/ImportAbstractClasses/Unit1.pas new file mode 100644 index 0000000..f222e27 --- /dev/null +++ b/Sources/Mac OS/Demos/ImportAbstractClasses/Unit1.pas @@ -0,0 +1,79 @@ +unit Unit1; + +interface + +uses + System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants, + FMX.Types, FMX.Graphics, FMX.Controls, FMX.Forms, FMX.Dialogs, FMX.StdCtrls, + FMX.Layouts, FMX.Memo, PaxCompiler, PaxRunner, PaxInterpreter; + +type + TForm1 = class(TForm) + Memo1: TMemo; + Button1: TButton; + procedure Button1Click(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + end; + + TMyHostClass = class + public + constructor Create; virtual; abstract; + procedure P; virtual; abstract; + end; + TMyHostClassClass = class of TMyHostClass; + + +var + Form1: TForm1; + +implementation + +{$R *.fmx} + +procedure Dummy(P: Pointer); begin end; + +procedure TForm1.Button1Click(Sender: TObject); +var + PaxCompiler1: TPaxCompiler; + PaxInterpreter1: TPaxInterpreter; + PaxPascalLanguage1: TPaxPascalLanguage; + + C: TMyHostClassClass; + X: TMyHostClass; +begin + Dummy(TMyHostClass); // just to punish Delphi to create rtti for this class + + PaxCompiler1 := TPaxCompiler.Create(nil); + PaxInterpreter1 := TPaxInterpreter.Create(nil); + PaxPascalLanguage1 := TPaxPascalLanguage.Create(nil); + try + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + PaxCompiler1.AddModule('1', 'Pascal'); + PaxCompiler1.AddCode('1', Memo1.Lines.Text); + if PaxCompiler1.Compile(PaxInterpreter1) then + begin + PaxInterpreter1.RunInitialization; + + C := TMyHostClassClass(PaxInterpreter1.GetAddress('TMyScriptClass')^); + X := C.Create; + try + X.P; + finally + X.Free; + end; + end + else + begin + ShowMessage(PaxCompiler1.ErrorMessage[0]); + end; + finally + PaxCompiler1.Free; + PaxInterpreter1.Free; + PaxPascalLanguage1.Free; + end; +end; + +end. diff --git a/Sources/Mac OS/Demos/OperatorOverloading/Project1.deployproj b/Sources/Mac OS/Demos/OperatorOverloading/Project1.deployproj new file mode 100644 index 0000000..80f228e --- /dev/null +++ b/Sources/Mac OS/Demos/OperatorOverloading/Project1.deployproj @@ -0,0 +1,64 @@ + + + + 12 + + + + + + + + Project1.app\Contents\ + Info.plist + 1 + + + + + Project1.app\Contents\MacOS\ + libcgunwind.1.0.dylib + 1 + + + + + Project1.app\Contents\MacOS\ + Project1 + 1 + + + True + + + Project1.app\Contents\ + Entitlements.plist + 1 + + + + + Project1.app\Contents\Resources\ + Project1.icns + 1 + + + + + Project1.app\Contents\MacOS\ + Project1.rsm + 1 + + + + + + + Project1.app\ + libcgunwind.1.0.dylib + 1 + + + + + diff --git a/Sources/Mac OS/Demos/OperatorOverloading/Project1.dpr b/Sources/Mac OS/Demos/OperatorOverloading/Project1.dpr new file mode 100644 index 0000000..0e8a4b4 --- /dev/null +++ b/Sources/Mac OS/Demos/OperatorOverloading/Project1.dpr @@ -0,0 +1,13 @@ +program Project1; + +uses + FMX.Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Sources/Mac OS/Demos/OperatorOverloading/Project1.dproj b/Sources/Mac OS/Demos/OperatorOverloading/Project1.dproj new file mode 100644 index 0000000..eb49316 --- /dev/null +++ b/Sources/Mac OS/Demos/OperatorOverloading/Project1.dproj @@ -0,0 +1,182 @@ + + + {AAD2D9AA-BFB1-479A-9B06-027663834885} + 15.1 + FMX + Project1.dpr + True + Debug + OSX32 + 5 + Application + + + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Cfg_1 + true + true + + + true + Base + true + + + $(BDS)\bin\delphi_PROJECTICON.ico + System;Xml;Data;Datasnap;Web;Soap;$(DCC_Namespace) + $(BDS)\bin\delphi_PROJECTICNS.icns + .\$(Platform)\$(Config) + .\$(Platform)\$(Config) + false + false + false + false + false + + + FireDACASADriver;FireDACSqliteDriver;bindcompfmx;DBXSqliteDriver;FireDACPgDriver;FireDACODBCDriver;fmx;rtl;dbrtl;DbxClientDriver;IndySystem;FireDACCommon;bindcomp;DBXInterBaseDriver;DataSnapCommon;xmlrtl;ibxpress;DbxCommonDriver;IndyProtocols;dbxcds;DBXMySQLDriver;FireDACCommonDriver;soaprtl;bindengine;bindcompdbx;FMXTee;fmxFireDAC;FireDACADSDriver;CustomIPTransport;FireDAC;dsnap;IndyIPServer;fmxase;IndyCore;IndyIPCommon;CloudService;FireDACIBDriver;FmxTeeUI;inet;fmxobj;FireDACMySQLDriver;inetdbxpress;fmxdae;RESTComponents;FireDACMSAccDriver;dbexpress;IndyIPClient;$(DCC_UsePackage) + true + CFBundleName=$(MSBuildProjectName);CFBundleDisplayName=$(MSBuildProjectName);CFBundleIdentifier=$(MSBuildProjectName);CFBundleVersion=1.0.0;CFBundlePackageType=APPL;CFBundleSignature=????;CFBundleAllowMixedLocalizations=YES;CFBundleExecutable=$(MSBuildProjectName);NSHighResolutionCapable=true;LSApplicationCategoryType=public.app-category.utilities + + + FireDACASADriver;FireDACSqliteDriver;bindcompfmx;DBXSqliteDriver;vcldbx;FireDACPgDriver;FireDACODBCDriver;fmx;rtl;dbrtl;DbxClientDriver;IndySystem;FireDACCommon;bindcomp;TeeDB;vclib;inetdbbde;DBXInterBaseDriver;Tee;DataSnapCommon;vclFireDAC;xmlrtl;svnui;ibxpress;DbxCommonDriver;vclimg;IndyProtocols;dbxcds;DBXMySQLDriver;FireDACCommonDriver;MetropolisUILiveTile;DPFiOSPackagesRXE5;soaprtl;bindengine;vclactnband;vcldb;bindcompdbx;vcldsnap;bindcompvcl;FMXTee;TeeUI;vclie;fmxFireDAC;FireDACADSDriver;vcltouch;CustomIPTransport;vclribbon;VclSmp;FireDAC;dsnap;IndyIPServer;Intraweb;fmxase;vcl;IndyCore;VCLRESTComponents;IndyIPCommon;CloudService;CodeSiteExpressPkg;dsnapcon;FireDACIBDriver;FmxTeeUI;inet;fmxobj;FireDACMySQLDriver;vclx;inetdbxpress;svn;fmxdae;RESTComponents;bdertl;FireDACMSAccDriver;adortl;dbexpress;IndyIPClient;$(DCC_UsePackage) + $(BDS)\bin\default_app.manifest + Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) + 1033 + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments= + true + + + FireDACASADriver;FireDACSqliteDriver;bindcompfmx;DBXSqliteDriver;FireDACPgDriver;FireDACODBCDriver;fmx;rtl;dbrtl;DbxClientDriver;IndySystem;FireDACCommon;bindcomp;TeeDB;vclib;DBXInterBaseDriver;Tee;DataSnapCommon;vclFireDAC;xmlrtl;ibxpress;DbxCommonDriver;vclimg;IndyProtocols;dbxcds;DBXMySQLDriver;FireDACCommonDriver;MetropolisUILiveTile;soaprtl;bindengine;vclactnband;vcldb;bindcompdbx;vcldsnap;bindcompvcl;FMXTee;TeeUI;vclie;fmxFireDAC;FireDACADSDriver;vcltouch;CustomIPTransport;vclribbon;VclSmp;FireDAC;dsnap;IndyIPServer;Intraweb;fmxase;vcl;IndyCore;VCLRESTComponents;IndyIPCommon;CloudService;dsnapcon;FireDACIBDriver;FmxTeeUI;inet;fmxobj;FireDACMySQLDriver;vclx;inetdbxpress;fmxdae;RESTComponents;FireDACMSAccDriver;adortl;dbexpress;IndyIPClient;$(DCC_UsePackage) + + + DEBUG;$(DCC_Define) + true + false + true + true + true + + + false + + + false + RELEASE;$(DCC_Define) + 0 + 0 + + + + MainSource + + +
Form1
+ fmx + + + Cfg_2 + Base + + + Base + + + Cfg_1 + Base + + + + Delphi.Personality.12 + + + + + False + False + 1 + 0 + 0 + 0 + False + False + False + False + False + 1033 + 1252 + + + + + 1.0.0.0 + + + + + + 1.0.0.0 + + + + + + + + + + + + + + + + + + + + + + + + + + + Project1.dpr + + + + + True + True + False + + + 12 + + + + diff --git a/Sources/Mac OS/Demos/OperatorOverloading/Project1.res b/Sources/Mac OS/Demos/OperatorOverloading/Project1.res new file mode 100644 index 0000000..36f26e2 Binary files /dev/null and b/Sources/Mac OS/Demos/OperatorOverloading/Project1.res differ diff --git a/Sources/Mac OS/Demos/OperatorOverloading/Unit1.fmx b/Sources/Mac OS/Demos/OperatorOverloading/Unit1.fmx new file mode 100644 index 0000000..199373f --- /dev/null +++ b/Sources/Mac OS/Demos/OperatorOverloading/Unit1.fmx @@ -0,0 +1,53 @@ +object Form1: TForm1 + Left = 0 + Top = 0 + Caption = 'Operator Overloading' + ClientHeight = 480 + ClientWidth = 640 + FormFactor.Width = 320 + FormFactor.Height = 480 + FormFactor.Devices = [dkDesktop, dkiPhone, dkiPad] + DesignerMobile = False + DesignerWidth = 0 + DesignerHeight = 0 + DesignerDeviceName = '' + DesignerOrientation = 0 + DesignerOSVersion = '' + object Button1: TButton + Height = 22.000000000000000000 + Position.X = 544.000000000000000000 + Position.Y = 392.000000000000000000 + TabOrder = 0 + Text = 'Run' + Width = 80.000000000000000000 + OnClick = Button1Click + end + object Memo1: TMemo + Touch.InteractiveGestures = [igPan, igLongTap, igDoubleTap] + Height = 450.000000000000000000 + Position.X = 16.000000000000000000 + Position.Y = 8.000000000000000000 + TabOrder = 1 + Width = 500.000000000000000000 + Lines.Strings = ( + 'uses' + ' Unit1;' + 'var' + ' U, V: TMyRecord;' + ' I: Integer;' + 'begin' + ' V := TMyRecord(4); // explicit type cast' + ' I := Integer(V); // explicit type cast' + ' print I;' + ' U := 3; // implicit type cast' + ' V.x := 1;' + ' V.y := 2;' + ' U := U + V; // operation of addition' + ' print U.X;' + ' print U.Y;' + ' I := V;' + ' print I;' + 'end.' + '') + end +end diff --git a/Sources/Mac OS/Demos/OperatorOverloading/Unit1.pas b/Sources/Mac OS/Demos/OperatorOverloading/Unit1.pas new file mode 100644 index 0000000..b84c441 --- /dev/null +++ b/Sources/Mac OS/Demos/OperatorOverloading/Unit1.pas @@ -0,0 +1,112 @@ +unit Unit1; + +interface + +uses + System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants, + FMX.Types, FMX.Graphics, FMX.Controls, FMX.Forms, FMX.Dialogs, FMX.StdCtrls, + PaxCompiler, PaxRunner, PaxInterpreter, FMX.Layouts, FMX.Memo; + +type + TForm1 = class(TForm) + Button1: TButton; + Memo1: TMemo; + procedure Button1Click(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + end; + +type + TMyRecord = record + x, y: Integer; + class operator Add(a, b: TMyRecord): TMyRecord; + class operator Subtract(a, b: TMyRecord): TMyRecord; + class operator Implicit(a: Integer): TMyRecord; + class operator Implicit(a: TMyRecord): Integer; + class operator Explicit(a: Integer): TMyRecord; + class operator Explicit(a: TMyRecord): Integer; + class operator Explicit(a: TMyRecord): Double; + end; + +var + Form1: TForm1; + +implementation + +{$R *.fmx} + +class operator TMyRecord.Add(a, b: TMyRecord): TMyRecord; +begin + result.x := a.x + b.x; + result.y := a.y + b.y; +end; + +class operator TMyRecord.Subtract(a, b: TMyRecord): TMyRecord; +begin + result.x := a.x - b.x; + result.y := a.y - b.y; +end; + +class operator TMyRecord.Implicit(a: Integer): TMyRecord; +begin + result.x := a; + result.y := 0; +end; + +class operator TMyRecord.Implicit(a: TMyRecord): Integer; +begin + result := a.x; +end; + +class operator TMyRecord.Explicit(a: Integer): TMyRecord; +begin + result.x := a; + result.y := 0; +end; + +class operator TMyRecord.Explicit(a: TMyRecord): Integer; +begin + result := a.x; +end; + +class operator TMyRecord.Explicit(a: TMyRecord): Double; +begin + result := a.x; +end; + +procedure Dummy(P: Pointer); begin end; + + +procedure TForm1.Button1Click(Sender: TObject); +var + PaxCompiler1: TPaxCompiler; + PaxInterpreter1: TPaxInterpreter; + PaxPascalLanguage1: TPaxPascalLanguage; +begin + Dummy(TypeInfo(TMyRecord)); // just to punish Delphi to create RTTI for TMyRecord + + PaxCompiler1 := TPaxCompiler.Create(nil); + PaxInterpreter1 := TPaxInterpreter.Create(nil); + PaxPascalLanguage1 := TPaxPascalLanguage.Create(nil); + try + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + PaxCompiler1.AddModule('1', 'Pascal'); + PaxCompiler1.AddCode('1', Memo1.Lines.Text); + if PaxCompiler1.Compile(PaxInterpreter1) then + begin + PaxInterpreter1.Run; + end + else + begin + ShowMessage(PaxCompiler1.ErrorMessage[0]); + end; + finally + PaxCompiler1.Free; + PaxInterpreter1.Free; + PaxPascalLanguage1.Free; + end; +end; + +end. diff --git a/Sources/Mac OS/packages/xe4/PaxCompiler.def b/Sources/Mac OS/packages/xe4/PaxCompiler.def new file mode 100644 index 0000000..a8dc519 --- /dev/null +++ b/Sources/Mac OS/packages/xe4/PaxCompiler.def @@ -0,0 +1,94 @@ +// {$define TRIAL} +{$O-} + +// {$define NO_PARENT_CLASS} + +// {$define FPC} +{$ifdef FPC} + {$ASMMODE intel} + {$DEFINE VARIANTS} + {$MODE DELPHI} + {$DEFINE CPUASM} + {$H+} + {$M+} +{$endif} + +{$M+} + +{$define PCU_EX} +{$define GENERICS} +//{$define HTML} + +{$define DUMP} +{$ifdef Ver140} + {$define VARIANTS} +{$endif} +{$ifdef Ver150} + {$define VARIANTS} +{$endif} +{$ifdef Ver160} + {$define VARIANTS} +{$endif} +{$ifdef Ver170} + {$define VARIANTS} +{$endif} +{$ifdef Ver180} + {$define VARIANTS} +{$endif} +{$ifdef Ver190} + {$define VARIANTS} +{$endif} +{$ifdef Ver200} + {$define VARIANTS} + {$define UNIC} +{$endif} +{$ifdef Ver210} + {$define VARIANTS} + {$define UNIC} + {$define DRTTI} +{$endif} +{$ifdef Ver220} + {$define VARIANTS} + {$define UNIC} + {$define DRTTI} +{$endif} +{$ifdef Ver230} + {$define VARIANTS} + {$define UNIC} + {$define DRTTI} + {$define DPULSAR} + {$IFDEF CPUX64} + {$DEFINE PAX64} + {$ENDIF} +{$endif} +{$ifdef Ver240} + {$define VARIANTS} + {$define UNIC} + {$define DRTTI} + {$define DPULSAR} + {$define DXE3} + {$IFDEF CPUX64} + {$DEFINE PAX64} + {$ENDIF} +{$endif} +{$ifdef Ver250} + {$define VARIANTS} + {$define UNIC} + {$define DRTTI} + {$define DPULSAR} + {$define DXE3} + {$IFDEF CPUX64} + {$DEFINE PAX64} + {$ENDIF} +{$endif} +{$ifdef Ver260} + {$define VARIANTS} + {$define UNIC} + {$define DRTTI} + {$define DPULSAR} + {$define DXE3} + {$IFDEF CPUX64} + {$DEFINE PAX64} + {$ENDIF} +{$endif} + diff --git a/Sources/Mac OS/packages/xe4/paxcomp_osx32_xe4.dpk b/Sources/Mac OS/packages/xe4/paxcomp_osx32_xe4.dpk new file mode 100644 index 0000000..bcee3da --- /dev/null +++ b/Sources/Mac OS/packages/xe4/paxcomp_osx32_xe4.dpk @@ -0,0 +1,37 @@ +package paxcomp_osx32_xe4; + +{$R *.res} +{$R 'PaxCompiler.dcr'} +{$IFDEF IMPLICITBUILDING This IFDEF should not be used by users} +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION OFF} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES ON} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$DEFINE DEBUG} +{$ENDIF IMPLICITBUILDING} +{$IMPLICITBUILD ON} + +requires + rtl; + +contains + PaxCompilerRegister in 'PaxCompilerRegister.pas'; + +end. diff --git a/Sources/Mac OS/packages/xe4/paxcomp_osx32_xe4.dproj b/Sources/Mac OS/packages/xe4/paxcomp_osx32_xe4.dproj new file mode 100644 index 0000000..13f5abc --- /dev/null +++ b/Sources/Mac OS/packages/xe4/paxcomp_osx32_xe4.dproj @@ -0,0 +1,197 @@ + + + {A1D6BC5C-0E7F-42C2-AC4E-2E554CDDDCB3} + paxcomp_osx32_xe4.dpk + 15.1 + None + True + Debug + OSX32 + 4 + Package + + + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Cfg_1 + true + true + + + true + Base + true + + + true + true + All + System;Xml;Data;Datasnap;Web;Soap;$(DCC_Namespace) + .\$(Platform)\$(Config) + .\$(Platform)\$(Config) + false + false + false + false + false + + + None + + + None + + + None + + + CFBundleName=$(MSBuildProjectName);CFBundleDisplayName=$(MSBuildProjectName);CFBundleIdentifier=$(MSBuildProjectName);CFBundleVersion=1.0.0;CFBundlePackageType=APPL;CFBundleSignature=????;CFBundleAllowMixedLocalizations=YES;CFBundleExecutable=$(MSBuildProjectName);NSHighResolutionCapable=true;LSApplicationCategoryType=public.app-category.utilities + + + true + Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) + 1033 + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments= + + + DEBUG;$(DCC_Define) + true + false + true + true + true + + + false + + + false + RELEASE;$(DCC_Define) + 0 + 0 + + + + MainSource + + + + + + Cfg_2 + Base + + + Base + + + Cfg_1 + Base + + + + Delphi.Personality.12 + Package + + + + paxcomp_osx32_xe4.dpk + + + True + False + 1 + 0 + 0 + 0 + False + False + False + False + False + 1033 + 1252 + + + + + 1.0.0.0 + + + + + + 1.0.0.0 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + False + False + False + True + False + False + + + 12 + + + + diff --git a/Sources/Mac OS/packages/xe4/paxcomp_osx32_xe4.res b/Sources/Mac OS/packages/xe4/paxcomp_osx32_xe4.res new file mode 100644 index 0000000..36f26e2 Binary files /dev/null and b/Sources/Mac OS/packages/xe4/paxcomp_osx32_xe4.res differ diff --git a/Sources/Mac OS/packages/xe4/paxcompiler.dcr b/Sources/Mac OS/packages/xe4/paxcompiler.dcr new file mode 100644 index 0000000..4bcc339 Binary files /dev/null and b/Sources/Mac OS/packages/xe4/paxcompiler.dcr differ diff --git a/Sources/Mac OS/packages/xe5/PaxCompiler.def b/Sources/Mac OS/packages/xe5/PaxCompiler.def new file mode 100644 index 0000000..a8dc519 --- /dev/null +++ b/Sources/Mac OS/packages/xe5/PaxCompiler.def @@ -0,0 +1,94 @@ +// {$define TRIAL} +{$O-} + +// {$define NO_PARENT_CLASS} + +// {$define FPC} +{$ifdef FPC} + {$ASMMODE intel} + {$DEFINE VARIANTS} + {$MODE DELPHI} + {$DEFINE CPUASM} + {$H+} + {$M+} +{$endif} + +{$M+} + +{$define PCU_EX} +{$define GENERICS} +//{$define HTML} + +{$define DUMP} +{$ifdef Ver140} + {$define VARIANTS} +{$endif} +{$ifdef Ver150} + {$define VARIANTS} +{$endif} +{$ifdef Ver160} + {$define VARIANTS} +{$endif} +{$ifdef Ver170} + {$define VARIANTS} +{$endif} +{$ifdef Ver180} + {$define VARIANTS} +{$endif} +{$ifdef Ver190} + {$define VARIANTS} +{$endif} +{$ifdef Ver200} + {$define VARIANTS} + {$define UNIC} +{$endif} +{$ifdef Ver210} + {$define VARIANTS} + {$define UNIC} + {$define DRTTI} +{$endif} +{$ifdef Ver220} + {$define VARIANTS} + {$define UNIC} + {$define DRTTI} +{$endif} +{$ifdef Ver230} + {$define VARIANTS} + {$define UNIC} + {$define DRTTI} + {$define DPULSAR} + {$IFDEF CPUX64} + {$DEFINE PAX64} + {$ENDIF} +{$endif} +{$ifdef Ver240} + {$define VARIANTS} + {$define UNIC} + {$define DRTTI} + {$define DPULSAR} + {$define DXE3} + {$IFDEF CPUX64} + {$DEFINE PAX64} + {$ENDIF} +{$endif} +{$ifdef Ver250} + {$define VARIANTS} + {$define UNIC} + {$define DRTTI} + {$define DPULSAR} + {$define DXE3} + {$IFDEF CPUX64} + {$DEFINE PAX64} + {$ENDIF} +{$endif} +{$ifdef Ver260} + {$define VARIANTS} + {$define UNIC} + {$define DRTTI} + {$define DPULSAR} + {$define DXE3} + {$IFDEF CPUX64} + {$DEFINE PAX64} + {$ENDIF} +{$endif} + diff --git a/Sources/Mac OS/packages/xe5/paxcomp_osx32.dpk b/Sources/Mac OS/packages/xe5/paxcomp_osx32.dpk new file mode 100644 index 0000000..d254802 --- /dev/null +++ b/Sources/Mac OS/packages/xe5/paxcomp_osx32.dpk @@ -0,0 +1,37 @@ +package paxcomp_osx32; + +{$R *.res} +{$R 'PaxCompiler.dcr'} +{$IFDEF IMPLICITBUILDING This IFDEF should not be used by users} +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION OFF} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES ON} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$DEFINE DEBUG} +{$ENDIF IMPLICITBUILDING} +{$IMPLICITBUILD ON} + +requires + rtl; + +contains + PaxCompilerRegister in 'PaxCompilerRegister.pas'; + +end. diff --git a/Sources/Mac OS/packages/xe5/paxcomp_osx32.dproj b/Sources/Mac OS/packages/xe5/paxcomp_osx32.dproj new file mode 100644 index 0000000..77e1e40 --- /dev/null +++ b/Sources/Mac OS/packages/xe5/paxcomp_osx32.dproj @@ -0,0 +1,197 @@ + + + {A1D6BC5C-0E7F-42C2-AC4E-2E554CDDDCB3} + paxcomp_osx32.dpk + 15.1 + None + True + Debug + OSX32 + 4 + Package + + + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Cfg_1 + true + true + + + true + Base + true + + + true + true + All + System;Xml;Data;Datasnap;Web;Soap;$(DCC_Namespace) + .\$(Platform)\$(Config) + .\$(Platform)\$(Config) + false + false + false + false + false + + + None + + + None + + + None + + + CFBundleName=$(MSBuildProjectName);CFBundleDisplayName=$(MSBuildProjectName);CFBundleIdentifier=$(MSBuildProjectName);CFBundleVersion=1.0.0;CFBundlePackageType=APPL;CFBundleSignature=????;CFBundleAllowMixedLocalizations=YES;CFBundleExecutable=$(MSBuildProjectName);NSHighResolutionCapable=true;LSApplicationCategoryType=public.app-category.utilities + + + true + Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) + 1033 + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments= + + + DEBUG;$(DCC_Define) + true + false + true + true + true + + + false + + + false + RELEASE;$(DCC_Define) + 0 + 0 + + + + MainSource + + + + + + Cfg_2 + Base + + + Base + + + Cfg_1 + Base + + + + Delphi.Personality.12 + Package + + + + paxcomp_osx32.dpk + + + True + False + 1 + 0 + 0 + 0 + False + False + False + False + False + 1033 + 1252 + + + + + 1.0.0.0 + + + + + + 1.0.0.0 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + False + False + False + True + False + False + + + 12 + + + + diff --git a/Sources/Mac OS/packages/xe5/paxcomp_osx32.res b/Sources/Mac OS/packages/xe5/paxcomp_osx32.res new file mode 100644 index 0000000..36f26e2 Binary files /dev/null and b/Sources/Mac OS/packages/xe5/paxcomp_osx32.res differ diff --git a/Sources/Mac OS/packages/xe5/paxcompiler.dcr b/Sources/Mac OS/packages/xe5/paxcompiler.dcr new file mode 100644 index 0000000..4bcc339 Binary files /dev/null and b/Sources/Mac OS/packages/xe5/paxcompiler.dcr differ diff --git a/Sources/Mac OS/packages/xe6/paxcomp_osx32_xe6.dpk b/Sources/Mac OS/packages/xe6/paxcomp_osx32_xe6.dpk new file mode 100644 index 0000000..f2ad747 --- /dev/null +++ b/Sources/Mac OS/packages/xe6/paxcomp_osx32_xe6.dpk @@ -0,0 +1,37 @@ +package paxcomp_osx32_xe6; + +{$R *.res} +{$R 'PaxCompiler.dcr'} +{$IFDEF IMPLICITBUILDING This IFDEF should not be used by users} +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION OFF} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES ON} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$DEFINE DEBUG} +{$ENDIF IMPLICITBUILDING} +{$IMPLICITBUILD ON} + +requires + rtl; + +contains + PaxCompilerRegister in 'PaxCompilerRegister.pas'; + +end. diff --git a/Sources/Mac OS/packages/xe6/paxcomp_osx32_xe6.dproj b/Sources/Mac OS/packages/xe6/paxcomp_osx32_xe6.dproj new file mode 100644 index 0000000..6c3baf5 --- /dev/null +++ b/Sources/Mac OS/packages/xe6/paxcomp_osx32_xe6.dproj @@ -0,0 +1,129 @@ + + + {71330EC1-10A9-457E-B893-D6B799049F26} + paxcomp_osx32_xe6.dpk + True + Debug + 5 + Package + None + 15.4 + OSX32 + + + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Cfg_2 + true + true + + + false + false + true + 00400000 + System;Xml;Data;Datasnap;Web;Soap;$(DCC_Namespace) + false + false + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=;CFBundleName= + paxcomp_osx32_xe6 + true + false + 1033 + + + Debug + package=com.embarcadero.$(MSBuildProjectName);label=$(MSBuildProjectName);versionCode=1;versionName=1.0.0;persistent=False;restoreAnyVersion=False;installLocation=preferExternal;largeHeap=False;theme=TitleBar;hardwareAccelerated=true + + + CFBundleName=$(MSBuildProjectName);CFBundleDisplayName=$(MSBuildProjectName);CFBundleIdentifier=$(MSBuildProjectName);CFBundleVersion=1.0.0;CFBundlePackageType=APPL;CFBundleSignature=????;CFBundleAllowMixedLocalizations=YES;CFBundleExecutable=$(MSBuildProjectName);NSHighResolutionCapable=true;LSApplicationCategoryType=public.app-category.utilities + + + true + Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments= + 1033 + + + 0 + false + 0 + RELEASE;$(DCC_Define) + + + true + false + DEBUG;$(DCC_Define) + + + true + + + + MainSource + + + + + + Cfg_2 + Base + + + Base + + + Cfg_1 + Base + + + + Delphi.Personality.12 + Package + + + + paxcomp_osx32_xe6.dpk + + + + False + False + False + True + True + False + + + 12 + + + + diff --git a/Sources/Mac OS/packages/xe6/paxcomp_osx32_xe6.res b/Sources/Mac OS/packages/xe6/paxcomp_osx32_xe6.res new file mode 100644 index 0000000..36f26e2 Binary files /dev/null and b/Sources/Mac OS/packages/xe6/paxcomp_osx32_xe6.res differ diff --git a/Sources/Mac OS/packages/xe7/paxcomp_osx32_xe7.dpk b/Sources/Mac OS/packages/xe7/paxcomp_osx32_xe7.dpk new file mode 100644 index 0000000..5425e48 --- /dev/null +++ b/Sources/Mac OS/packages/xe7/paxcomp_osx32_xe7.dpk @@ -0,0 +1,37 @@ +package paxcomp_osx32_xe7; + +{$R *.res} +{$R 'PaxCompiler.dcr'} +{$IFDEF IMPLICITBUILDING This IFDEF should not be used by users} +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO OFF} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION OFF} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES ON} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$DEFINE DEBUG} +{$ENDIF IMPLICITBUILDING} +{$IMPLICITBUILD ON} + +requires + rtl; + +contains + PaxCompilerRegister in 'PaxCompilerRegister.pas'; + +end. diff --git a/Sources/Mac OS/packages/xe7/paxcomp_osx32_xe7.dproj b/Sources/Mac OS/packages/xe7/paxcomp_osx32_xe7.dproj new file mode 100644 index 0000000..1214a96 --- /dev/null +++ b/Sources/Mac OS/packages/xe7/paxcomp_osx32_xe7.dproj @@ -0,0 +1,129 @@ + + + {0647024A-9949-4153-9CF9-859DFD4D9493} + paxcomp_osx32_xe7.dpk + True + Debug + 5 + Package + None + 16.0 + OSX32 + + + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Cfg_2 + true + true + + + false + paxcomp_osx32_xe7 + true + false + false + true + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=;CFBundleName= + System;Xml;Data;Datasnap;Web;Soap;$(DCC_Namespace) + false + 1033 + false + 00400000 + + + Debug + package=com.embarcadero.$(MSBuildProjectName);label=$(MSBuildProjectName);versionCode=1;versionName=1.0.0;persistent=False;restoreAnyVersion=False;installLocation=preferExternal;largeHeap=False;theme=TitleBar;hardwareAccelerated=true + + + CFBundleName=$(MSBuildProjectName);CFBundleDisplayName=$(MSBuildProjectName);CFBundleIdentifier=$(MSBuildProjectName);CFBundleVersion=1.0.0;CFBundlePackageType=APPL;CFBundleSignature=????;CFBundleAllowMixedLocalizations=YES;CFBundleExecutable=$(MSBuildProjectName);NSHighResolutionCapable=true;LSApplicationCategoryType=public.app-category.utilities + + + 1033 + true + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments= + Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) + + + 0 + false + RELEASE;$(DCC_Define) + 0 + + + true + DEBUG;$(DCC_Define) + false + + + true + + + + MainSource + + + + + + Cfg_2 + Base + + + Base + + + Cfg_1 + Base + + + + Delphi.Personality.12 + Package + + + + paxcomp_osx32_xe7.dpk + + + + False + False + False + True + True + False + + + 12 + + + + diff --git a/Sources/Mac OS/packages/xe7/paxcomp_osx32_xe7.res b/Sources/Mac OS/packages/xe7/paxcomp_osx32_xe7.res new file mode 100644 index 0000000..36f26e2 Binary files /dev/null and b/Sources/Mac OS/packages/xe7/paxcomp_osx32_xe7.res differ diff --git a/Sources/Mac OS/packages/xe7/paxcompiler.dcr b/Sources/Mac OS/packages/xe7/paxcompiler.dcr new file mode 100644 index 0000000..4bcc339 Binary files /dev/null and b/Sources/Mac OS/packages/xe7/paxcompiler.dcr differ diff --git a/Sources/Opcije.optset b/Sources/Opcije.optset new file mode 100644 index 0000000..27825a3 --- /dev/null +++ b/Sources/Opcije.optset @@ -0,0 +1,20 @@ + + + 00400000 + PaxCompiler_D12 + 1 + Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;System;Xml;Data;Datasnap;Web;Soap;DUnitX.Loggers.GUI;$(DCC_Namespace) + 9242 + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=;CFBundleName= + .\$(Platform)\$(Config) + .\$(Platform)\$(Config) + + + Delphi.Personality.12 + OptionSet + + + + 12 + + diff --git a/Sources/PAXCOMP_2010.pas b/Sources/PAXCOMP_2010.pas new file mode 100644 index 0000000..bf39d89 --- /dev/null +++ b/Sources/PAXCOMP_2010.pas @@ -0,0 +1,754 @@ +//////////////////////////////////////////////////////////////////////////// +// PaxCompiler +// Site: http://www.paxcompiler.com +// Author: Alexander Baranovsky (paxscript@gmail.com) +// ======================================================================== +// Copyright (c) Alexander Baranovsky, 2006-2014. All rights reserved. +// Code Version: 4.2 +// ======================================================================== +// Unit: PAXCOMP_2010.pas +// ======================================================================== +//////////////////////////////////////////////////////////////////////////// + +{$I PaxCompiler.def} +{$O-} +unit PAXCOMP_2010; +interface +{$ifdef DRTTI} +uses {$I uses.def} + Classes, + SysUtils, + TypInfo, + RTTI, + PAXCOMP_CONSTANTS, + PAXCOMP_TYPES, + PAXCOMP_SYS; +type + TUnitList = class; + TUnit = class; + + TType = class + private + // Added to reuse code for methods and property getters and setters. + procedure DispatchMethod(aMethod: TRttiMethod); + procedure DispatchType(AType: TRTTIType; Recursive: Boolean = true); + public + Owner: TUnit; + +{$IFDEF ARC} + UsedTypes: TList; +{$ELSE} + UsedTypes: TList; +{$ENDIF} + + T: TRTTIType; + constructor Create(AOwner: TUnit); + destructor Destroy; override; + procedure Expand; + end; + + TUnit = class(TTypedList) + private + Z: Integer; + Owner: TUnitList; + function GetRecord(I: Integer): TType; + public + Level: Integer; + Name: String; + UsedUnits: TUpStringList; +{$IFDEF ARC} + UsedTypes: TList; +{$ELSE} + UsedTypes: TList; +{$ENDIF} + constructor Create(AOwner: TUnitList; const AName: String); + destructor Destroy; override; + function IndexOf(t: TRTTIType): Integer; + procedure AddType(t: TRTTIType; Recursive: Boolean = true); + procedure Sort; + property Records[I: Integer]: TType read GetRecord; default; + end; + + TUnitList = class(TTypedList) + private + function GetRecord(I: Integer): TUnit; + public +{$IFDEF ARC} + ForbiddenClasses: TList; +{$ELSE} + ForbiddenClasses: TList; +{$ENDIF} + AcceptList: TStrings; + constructor Create; + destructor Destroy; override; + function AddUnit(const UnitName: String; ALevel: Integer = 0): TUnit; + function IndexOf(const AUnitName: String): Integer; + procedure ForbidClass(C: TClass); + function AddClass(C: TClass): TUnit; + function AddType(t: TRTTIType): TUnit; + procedure AddAvailableTypes; + procedure FindMembers(L: TStringList); + procedure Sort; + procedure Dump(const FileName: String); + property Records[I: Integer]: TUnit read GetRecord; default; + end; + +function CheckType(t: TRTTIType): Boolean; +var + PaxContext: TRTTIContext; + +// Changed event from function to procedure to allow accepting of types as well. +// Added event to do additional checking on types (to exclude certain types). +type + TCheckTypeEvent = procedure(aType: TRTTIType; var aAccept: Boolean) of object; +var + OnCheckType: TCheckTypeEvent; + +procedure CreateAvailTypes; + +procedure Dump_Types(const FileName: String); +procedure Dump_Units(const FileName: String); +procedure Dump_Units1(const FileName: String); + +function ExtractUnitName(t: TRTTIType): String; +procedure Initialize_paxcomp_2010; +procedure Finalize_paxcomp_2010; + +implementation + +uses PAXCOMP_STDLIB; + +function ExtractUnitName(t: TRTTIType): String; +var + I: Integer; +begin + result := t.QualifiedName; + I := Pos(t.Name, result); + if I > 0 then + Delete(result, I - 1, Length(t.Name) + 1); +end; + +function CheckType(t: TRTTIType): Boolean; + + function CheckArray(t: TRTTIType): Boolean; + var + K: Integer; + ta: TRTTIArrayType; + begin + result := true; + if t is TRTTIArrayType then + begin + ta := t as TRTTIArrayType; + K := ta.DimensionCount; + if K > 1 then + result := false + else if ta.Dimensions[0] = nil then + result := false; + end; + end; + +var + S: String; +begin + result := false; + if t = nil then + Exit; + + result := true; + if not t.IsPublicType then + result := false +// else if PosCh('.', t.Name) > 0 then +// result := false + else if t.Handle = TypeInfo(Comp) then + result := false + else if not CheckArray(t) then + result := false + else + begin + S := UpperCase(t.QualifiedName); + if Pos('GENERICS.', S) > 0 then + result := false; + end; + + if Assigned(OnCheckType) then + OnCheckType(t, result); +end; + +// TType ------------------------------------------------------------------- + +constructor TType.Create(AOwner: TUnit); +begin + inherited Create; + Owner := AOwner; +{$IFDEF ARC} + UsedTypes := TList.Create; +{$ELSE} + UsedTypes := TList.Create; +{$ENDIF} +end; + +destructor TType.Destroy; +begin + FreeAndNil(UsedTypes); + inherited; +end; + +// Added DispatchMethod. +procedure TType.DispatchMethod(aMethod: TRttiMethod); +var + Param: TRTTIParameter; + t: TRTTIType; +begin + for Param in aMethod.GetParameters do + begin + t := Param.ParamType; + DispatchType(t, false); + end; + + if aMethod.HasExtendedInfo then + begin + t := aMethod.ReturnType; + DispatchType(t, false); + end; +end; + +procedure TType.DispatchType(AType: TRTTIType; Recursive: Boolean = true); +var + UnitName: String; + I: Integer; + UnitList: TUnitList; + U: TUnit; +begin + if AType = T then + Exit; + if not CheckType(AType) then + Exit; + + UnitList := Owner.Owner; + UnitName := ExtractUnitName(AType); + + if StrEql(UnitName, Owner.Name) then + if UsedTypes.IndexOf(AType) = -1 then + UsedTypes.Add(AType); + + I := UnitList.IndexOf(UnitName); + if I = -1 then + U := UnitList.AddUnit(UnitName) + else + U := UnitList[I]; + + if not StrEql(UnitName, Owner.Name) and (not StrEql(UnitName, 'System')) then + begin + I := Owner.UsedUnits.IndexOf(UnitName); + if I = -1 then + Owner.UsedUnits.Add(UnitName); + end; + + U.AddType(AType, Recursive); +end; + +procedure TType.Expand; +var + method: TRttiMethod; + field: TRTTIField; + prop: TRTTIProperty; +{$IFDEF DPULSAR} + IndexedProp: TRTTIIndexedProperty; + it: TRttiInterfaceType; +{$ENDIF} + AType: TRTTIType; +{$IFDEF DPULSAR} + InstType: TRTTIInstanceType; +{$ENDIF} +begin + AType := T.BaseType; + while AType <> nil do + begin + DispatchType(AType, false); + AType := AType.BaseType; + end; + +{$IFDEF DPULSAR} + if T is TRTTIInstanceType then + begin + InstType := t as TRTTIInstanceType; + for it in InstType.GetDeclaredImplementedInterfaces do + DispatchType(it, false); + end; +{$ENDIF} + + // Exclude record methods for two reasons: + // 1. There is a bug in TRttiRecordMethod.GetReturnType. It uses the handle immediately but should use FSig.Handle. + // 2. Record methods are not supported by the PAX compiler. + if T.TypeKind <> tkRecord then + begin + // Replace GetMethods by GetDeclaredMethods. + for method in T.GetDeclaredMethods do + begin + // Only dispatch public and published methods. + if method.Visibility in [mvPublic, mvPublished] then + begin + if Owner.Owner.AcceptList = nil then + DispatchMethod(method) + else + if Owner.Owner.AcceptList.IndexOf(method.Name) >= 0 then + DispatchMethod(method); + end; + end; + end; + + // Replace GetFields by GetDeclaredFields. + for field in T.GetDeclaredFields do + begin + // Only dispatch public and published fields. + if field.Visibility in [mvPublic, mvPublished] then + begin + AType := field.FieldType; + DispatchType(AType, false); + end; + end; + + // Replace GetProperties by GetDeclaredProperties. + for prop in T.GetDeclaredProperties do + begin + // Only dispatch public and published properties. + if prop.Visibility in [mvPublic, mvPublished] then + begin + AType := prop.PropertyType; + DispatchType(AType, false); + AType := prop.Parent; + DispatchType(AType, false); + end; + end; + +{$IFDEF DPULSAR} + // Added enumeration of indexed properties. + for IndexedProp in T.GetDeclaredIndexedProperties do + begin + if IndexedProp.Visibility in [mvPublic, mvPublished] then + begin + AType := IndexedProp.PropertyType; + DispatchType(AType, false); + AType := IndexedProp.Parent; + DispatchType(AType, false); + if IndexedProp.IsReadable then + DispatchMethod(IndexedProp.ReadMethod); + if IndexedProp.IsWritable then + DispatchMethod(IndexedProp.WriteMethod); + end; + end; +{$ENDIF} +end; + +// TUnit ------------------------------------------------------------------- + +constructor TUnit.Create(AOwner: TUnitList; const AName: String); +begin + inherited Create; + Owner := AOwner; + Name := AName; + UsedUnits := TUpStringList.Create; +{$IFDEF ARC} + UsedTypes := TList.Create; +{$ELSE} + UsedTypes := TList.Create; +{$ENDIF} +end; + +destructor TUnit.Destroy; +begin + FreeAndNil(UsedUnits); + FreeAndNil(UsedTypes); + inherited; +end; + +function TUnit.GetRecord(I: Integer): TType; +begin + result := TType(L[I]); +end; + +function TUnit.IndexOf(t: TRTTIType): Integer; +var + I: Integer; +begin + result := -1; + for I := 0 to Count - 1 do + if Records[I].T = t then + begin + result := I; + Exit; + end; +end; + +procedure TUnit.AddType(t: TRTTIType; Recursive: Boolean = true); +var + R: TType; + I: Integer; + b: TRTTIType; +begin + if not CheckType(t) then + Exit; + + I := IndexOf(t); + if I = -1 then + R := TType.Create(Self) + else + Exit; + + R.T := t; + L.Add(R); + + if t is TRttiDynamicArrayType then + begin + b := (t as TRttiDynamicArrayType).ElementType; + if b <> nil then + R.UsedTypes.Add(b); + end + else if t is TRttiArrayType then + begin + b := (t as TRttiArrayType).ElementType; + if b <> nil then + R.UsedTypes.Add(b); + end + else if t is TRttiPointerType then + begin + b := (t as TRttiPointerType).ReferredType; + if b <> nil then + R.UsedTypes.Add(b); + end + else + begin + b := t.BaseType; + if b <> nil then + if t.UnitName = b.UnitName then + R.UsedTypes.Add(b); + end; + + if Recursive then + R.Expand; +end; + +procedure TUnit.Sort; +var + A: array of TType; + I, J, K, InitCount: Integer; + anc: TRTTIType; + found: Boolean; +begin + SetLength(A, Count); + K := -1; + for I := L.Count - 1 downto 0 do + if Records[I].UsedTypes.Count = 0 then + begin + Inc(K); + A[K] := Records[I]; + L.Delete(I); + end; + + repeat + InitCount := L.Count; + for I := L.Count - 1 downto 0 do + begin + anc := Records[I].UsedTypes[0]; + found := false; + for J := 0 to L.Count - 1 do + if I <> J then + if Records[J].T = anc then + begin + found := true; + break; + end; + if not Found then + begin + Inc(K); + A[K] := Records[I]; + L.Delete(I); + break; + end; + end; + until L.Count = InitCount; + + for I := L.Count - 1 downto 0 do + begin + Inc(K); + A[K] := Records[I]; + L.Delete(I); + end; + + for I := 0 to K do + L.Add(A[I]); +end; + +// TUnitList ------------------------------------------------------------------- + +constructor TUnitList.Create; +begin + inherited; +{$IFDEF ARC} + ForbiddenClasses := TList.Create; +{$ELSE} + ForbiddenClasses := TList.Create; +{$ENDIF} +end; + +destructor TUnitList.Destroy; +begin + FreeAndNil(ForbiddenClasses); + inherited; +end; + +function TUnitList.GetRecord(I: Integer): TUnit; +begin + result := TUnit(L[I]); +end; + +function TUnitList.IndexOf(const AUnitName: String): Integer; +var + I: Integer; +begin + result := -1; + for I := 0 to Count - 1 do + if StrEql(Records[I].Name, AUnitName) then + begin + result := I; + Exit; + end; +end; + +function TUnitList.AddUnit(const UnitName: String; ALevel: Integer = 0): TUnit; +begin + result := TUnit.Create(Self, UnitName); + result.Level := ALevel; + L.Add(result); +end; + +procedure TUnitList.ForbidClass(C: TClass); +begin + ForbiddenClasses.Add(C); +end; + +function TUnitList.AddClass(C: TClass): TUnit; +var + UnitName: String; + I: Integer; +begin + UnitName := C.UnitName; + I := IndexOf(UnitName); + if I = -1 then + result := AddUnit(UnitName) + else + result := Records[I]; + result.AddType(PaxContext.GetType(C)); +end; + +function TUnitList.AddType(t: TRTTIType): TUnit; +var + UnitName: String; + I: Integer; +begin + if not CheckType(t) then + begin + result := nil; + Exit; + end; + + UnitName := ExtractUnitName(t); + I := IndexOf(UnitName); + if I = -1 then + result := AddUnit(UnitName) + else + result := Records[I]; + result.AddType(t); +end; + +procedure TUnitList.AddAvailableTypes; +var + t: TRTTIType; +begin + for t in PaxContext.GetTypes do + begin + if t.IsPublicType then + begin + AddType(t); + end; + end; +end; + +procedure TUnitList.FindMembers(L: TStringList); +var + t: TRTTIType; + u: TUnit; + I, J: Integer; +begin + AcceptList := L; + for I := 0 to Count - 1 do + begin + u := Records[I]; + for J := u.UsedTypes.Count - 1 downto 0 do + begin + t := u.UsedTypes[J]; + AddType(t); + end; + end; +end; + +procedure TUnitList.Sort; +var + I, J, K: Integer; + A: array of TUnit; + UnitName: String; + found: Boolean; +begin + for I := 0 to Count - 1 do + begin + Records[I].Sort; + Records[I].Z := Records[I].UsedUnits.Count; + end; + SetLength(A, Count); + + K := -1; + + repeat + found := false; + + for I := 0 to Count - 1 do + if Records[I].Z = 0 then + begin + found := true; + + Records[I].Z := -1; + Inc(K); + A[K] := Records[I]; + + UnitName := Records[I].Name; + + for J := 0 to Count - 1 do + if I <> J then + if Records[J].Z > 0 then + if Records[J].UsedUnits.IndexOf(UnitName) >= 0 then + Dec(Records[J].Z); + end; + + until not found; + + Assert(K + 1 = Count, errInternalError); + + L.Clear; + + for I := 0 to K do + L.Add(A[I]); +end; + +procedure TUnitList.Dump(const FileName: String); +var + L: TStringList; + I, J, K: Integer; + U: TUnit; + S: String; + t: TRTTIType; +begin + if not IsDump then + Exit; + + L := TStringList.Create; + try + for I := 0 to Count - 1 do + begin + U := Records[I]; + + L.Add('Unit: ' + U.Name); + L.Add('----'); + for J := 0 to U.UsedUnits.Count - 1 do + L.Add(' ' + U.UsedUnits[J]); + L.Add('----'); + + for J := 0 to U.Count - 1 do + begin + + S := ''; + for K := 0 to U[J].UsedTypes.Count - 1 do + begin + t := TRTTIType(U[J].UsedTypes[K]); + S := S + t.Name; + if K < U[J].UsedTypes.Count - 1 then + S := S + ','; + end; + + L.Add(U[J].T.Name + '(' + S + ')'); + end; + + L.Add('--------------------------------'); + L.Add(''); + L.Add(''); + L.Add(''); + end; + L.SaveToFile(DUMP_PATH + FileName); + finally + FreeAndNil(L); + end; +end; + +procedure Dump_Types(const FileName: String); +var + t: TRTTIType; + L: TStringList; + c: TRTTIContext; +begin + L := TStringList.Create; + c := TRTTIContext.Create; + for t in c.GetTypes do + begin + if t.IsPublicType then + L.Add(t.QualifiedName); + end; + L.SaveToFile(DUMP_PATH + FileName); + FreeAndNil(L); +end; + +procedure CreateAvailTypes; +var + t: TRTTIType; + S, UnitName: String; +begin + AvailTypeList.Clear; + for t in PaxContext.GetTypes do + if t.IsPublicType then + begin + AvailTypeList.AddObject(t.QualifiedName, Pointer(t)); + UnitName := ExtractUnitName(t); + if UnitName <> '' then + begin + AvailUnitList.Add(UnitName); + S := ExtractOwner(UnitName); + if S <> '' then + AvailUnitList1.Add(S); + end; + end; +end; + +procedure Dump_Units(const FileName: String); +begin + AvailUnitList.SaveToFile(DUMP_PATH + FileName); +end; + +procedure Dump_Units1(const FileName: String); +begin + AvailUnitList1.SaveToFile(DUMP_PATH + FileName); +end; + +procedure Initialize_paxcomp_2010; +begin + PaxContext := TRTTIContext.Create; +end; + +procedure Finalize_paxcomp_2010; +begin + PaxContext.Free; +end; + +{$else} // Delphi version < 210 + + +implementation +{$endif} +end. diff --git a/Sources/PAXCOMP_2010REG.pas b/Sources/PAXCOMP_2010REG.pas new file mode 100644 index 0000000..a2546d7 --- /dev/null +++ b/Sources/PAXCOMP_2010REG.pas @@ -0,0 +1,1516 @@ +//////////////////////////////////////////////////////////////////////////// +// PaxCompiler +// Site: http://www.paxcompiler.com +// Author: Alexander Baranovsky (paxscript@gmail.com) +// ======================================================================== +// Copyright (c) Alexander Baranovsky, 2006-2014. All rights reserved. +// Code Version: 4.2 +// ======================================================================== +// Unit: PAXCOMP_2010REG.pas +// ======================================================================== +//////////////////////////////////////////////////////////////////////////// + +{$I PaxCompiler.def} +{$O-} +unit PAXCOMP_2010REG; +interface +{$ifdef DRTTI} +uses {$I uses.def} + Classes, + SysUtils, + TypInfo, + RTTI, + PAXCOMP_CONSTANTS, + PAXCOMP_TYPES, + PAXCOMP_SYS, + PAXCOMP_2010, + PAXCOMP_SYMBOL_REC, + PAXCOMP_BASESYMBOL_TABLE, + PAXCOMP_CLASSLST, + PAXCOMP_STDLIB; + +function RegisterType(Level: Integer; t: TRTTIType; + SymbolTable: TBaseSymbolTable; + AcceptList: TStrings = nil): Integer; +function RegisterField(Level: Integer; f: TRTTIField; + SymbolTable: TBaseSymbolTable): Integer; +function RegisterProperty(ALevel: Integer; + p: TRTTIProperty; + Index: Integer; + SymbolTable: TBaseSymbolTable): Integer; +function RegisterMethod(Level: Integer; m: TRTTIMethod; + SymbolTable: TBaseSymbolTable): Integer; +function RegisterRecordType(Level: Integer; t: TRTTIRecordType; + SymbolTable: TBaseSymbolTable): Integer; +function RegisterClassType(Level: Integer; t: TRTTIInstanceType; + SymbolTable: TBaseSymbolTable; + AcceptList: TStrings = nil): Integer; +function RegisterInterfaceType(Level: Integer; t: TRTTIInterfaceType; + SymbolTable: TBaseSymbolTable): Integer; +function RegisterArrayType(Level: Integer; t: TRTTIArrayType; + SymbolTable: TBaseSymbolTable): Integer; +function RegisterDynamicArrayType(Level: Integer; t: TRTTIDynamicArrayType; + SymbolTable: TBaseSymbolTable): Integer; +function RegisterPointerType(Level: Integer; t: TRTTIPointerType; + SymbolTable: TBaseSymbolTable): Integer; +function RegisterClassRefType(Level: Integer; t: TRTTIClassRefType; + SymbolTable: TBaseSymbolTable): Integer; +function RegisterProceduralType(Level: Integer; t: TRTTIProcedureType; + SymbolTable: TBaseSymbolTable): Integer; +function RegisterEventType(Level: Integer; t: TRTTIMethodType; + SymbolTable: TBaseSymbolTable): Integer; +function RegisterUnit(AUnit: TUnit; + SymbolTable: TBaseSymbolTable; + AcceptList: TStrings = nil; + kernel: Pointer = nil): Integer; +procedure RegisterUnits(UnitList: TUnitList; SymbolTable: TBaseSymbolTable); overload; +procedure RegisterUnits(UnitList: TUnitList); overload; + +// Added event to provide a header for known methods that have no RTTI extended info +// It is necessary to register some functions with 'array of const' parameters. +type + TGetMethodHeaderEvent = procedure(var aHeader: string; aMethod: TRttiMethod) of object; + PTValue = ^TValue; +var + OnMethodHasNoExtendedInfo: TGetMethodHeaderEvent; + +procedure InitializePAXCOMP_2010Reg; +procedure _VarFromTValue(V: PTValue; T: Integer; Dest: Pointer); +stdcall; + +procedure _GetDRTTIProperty(p: TRTTIProperty; + X: TObject; + var Result: TValue); stdcall; +procedure _GetDRTTIIntegerProperty(p: TRTTIProperty; + X: TObject; + var Result: Integer); stdcall; +procedure _GetDRTTIStringProperty(p: TRTTIProperty; + X: TObject; + var Result: String); stdcall; +procedure _GetDRTTIExtendedProperty(p: TRTTIProperty; + X: TObject; + var Result: Extended); stdcall; +procedure _GetDRTTIVariantProperty(p: TRTTIProperty; + X: TObject; + var Result: Variant); stdcall; +procedure _GetDRTTIInt64Property(p: TRTTIProperty; + X: TObject; + var Result: Int64); stdcall; +procedure _SetDRTTIProperty(p: TRTTIProperty; + X: TObject; + Value: PTValue); stdcall; +function CheckMethod(t: TRTTIType; m: TRTTIMethod): Boolean; +{$IFDEF DPULSAR} +// Added function to support indexed properties. +function CheckIndexedProperty(aRttiType: TRTTIType; aIndexedProperty: TRTTIIndexedProperty): Boolean; +{$ENDIF} + +implementation + +uses + PAXCOMP_KERNEL; + +function CheckField(t: TRTTIType; f: TRTTIField): Boolean; +begin + result := false; + + if not CheckType(f.FieldType) then + Exit; + + if not (f.Visibility in [mvPublic, mvPublished]) then + Exit; + + if f.Parent <> t then + Exit; + + result := true; +end; + +function CheckMethod(t: TRTTIType; m: TRTTIMethod): Boolean; +var + param: TRttiParameter; +begin + result := false; + + if not (m.Visibility in [mvPublic, mvPublished]) then + Exit; + + if not m.HasExtendedInfo then + Exit; + + // Class constructors and class destructor should not be registered. + // They are called by the application. + if m.MethodKind in [mkClassConstructor, mkClassDestructor] then + Exit; + + if assigned(m.ReturnType) then + if not CheckType(m.ReturnType) then + Exit; + + for param in m.GetParameters() do + if not CheckType(param.ParamType) then + Exit; + + if m.Parent <> t then + if not (m.DispatchKind in [dkVtable, dkDynamic]) then + Exit; + + result := true; +end; + +function CheckProperty(t: TRTTIType; p: TRTTIProperty): Boolean; +begin + result := false; + + if not CheckType(p.PropertyType) then + Exit; + + if not (p.Visibility in [mvPublic, mvPublished]) then + Exit; + + if not p.Parent.InheritsFrom(t.ClassType) then + Exit; + + result := true; +end; + +// Added function to support indexed properties. +function CheckIndexedPropertyMethod(aRttiType: TRTTIType; aMethod: TRTTIMethod): Boolean; +var + param: TRttiParameter; +begin + Result := False; + if not aMethod.HasExtendedInfo then + Exit; + + if Assigned(aMethod.ReturnType) then + if not CheckType(aMethod.ReturnType) then + Exit; + + if aMethod.IsClassMethod and aMethod.IsStatic then + Exit; + + for Param in aMethod.GetParameters() do + if not CheckType(param.ParamType) then + Exit; + + if aMethod.Parent <> aRttiType then + if not (aMethod.DispatchKind in [dkVtable, dkDynamic]) then + Exit; + + Result := True; +end; + +{$IFDEF DPULSAR} +// Added function to support indexed properties. +function CheckIndexedProperty(aRttiType: TRTTIType; aIndexedProperty: TRTTIIndexedProperty): Boolean; +begin + Result := False; + if not CheckType(aIndexedProperty.PropertyType) then + Exit; + if not (aIndexedProperty.Visibility in [mvPublic]) then + Exit; + if not aIndexedProperty.Parent.InheritsFrom(aRttiType.ClassType) then + Exit; + if aIndexedProperty.IsReadable then + if not CheckIndexedPropertyMethod(aRttiType, aIndexedProperty.ReadMethod) then + Exit; + if aIndexedProperty.IsWritable then + if not CheckIndexedPropertyMethod(aRttiType, aIndexedProperty.WriteMethod) then + Exit; + Result := True; +end; + +// Added function to support indexed properties. +function GetIndexedPropertyDecl(aProperty: TRttiIndexedProperty): string; +var + Method: TRTTIMethod; + Param: TRttiParameter; + ParamCount, I: Integer; +begin + if aProperty.IsReadable then begin + Method := aProperty.ReadMethod; + ParamCount := System.Length(Method.GetParameters); + end else if aProperty.IsWritable then begin + Method := aProperty.WriteMethod; + ParamCount := System.Length(Method.GetParameters) - 1; + end else begin + Method := nil; + ParamCount := 0; + end; + + Result := 'property ' + aProperty.Name + '['; + for I := 0 to ParamCount - 1 do begin + Param := Method.GetParameters[I]; + if I > 0 then + Result := Result + '; '; + Result := Result + Param.Name + ': ' + Param.ParamType.Name; + end; + Result := Result + ']: ' + aProperty.PropertyType.Name; + if aProperty.IsReadable then + Result := Result + ' read ' + aProperty.ReadMethod.Name; + if aProperty.IsWritable then + Result := Result + ' write ' + aProperty.WriteMethod.Name; + Result := Result + ';'; + if aProperty.IsDefault then + Result := Result + ' default;'; +end; +{$ENDIF} + +function RegisterField(Level: Integer; f: TRTTIField; + SymbolTable: TBaseSymbolTable): Integer; +var + S: String; + TypeId: Integer; + t: TRTTIType; +begin + with SymbolTable do + begin + t := f.FieldType; + S := t.Name; + TypeId := LookUpType(S, true); + if TypeId = 0 then + ExternList.Add(Card + 1, S, erTypeId); + result := RegisterTypeField(Level, f.Name, TypeId, f.Offset); + end; +end; + +function RegisterMethod(Level: Integer; m: TRTTIMethod; + SymbolTable: TBaseSymbolTable): Integer; +var + S: String; + cc: Integer; + CallMode: Integer; + MethodIndex: Integer; + TypeId: Integer; + C: TClass; + SubId: Integer; + K: Integer; + param: TRttiParameter; + CodeAddress: Pointer; + R: TSymbolRec; + OverCount: Integer; + t: TRttiType; + mm: TRTTIMethod; +begin + t := m.Parent; + + if t is TRttiInstanceType then + C := (t as TRttiInstanceType).MetaClassType + else + C := nil; + + OverCount := 0; + K := 0; + S := m.ToString; + for mm in t.GetDeclaredMethods do + begin + if CheckMethod(t, mm) then + if mm.Name = m.Name then + Inc(K); + if mm.ToString = S then + OverCount := K; + end; + if K = 1 then + OverCount := 0; + + if m.ReturnType = nil then + typeId := typeVOID + else + begin + S := m.ReturnType.Name; + typeId := SymbolTable.LookUpType(S, true); + // Moved test inside if-statement. + if TypeId = 0 then + SymbolTable.ExternList.Add(SymbolTable.Card + 1, S, erTypeId); + end; + + cc := ccREGISTER; + case m.CallingConvention of + TypInfo.ccReg: cc := ccREGISTER; + TypInfo.ccCdecl: cc := ccCDECL; + TypInfo.ccPascal: cc := ccPASCAL; + TypInfo.ccStdCall: cc := ccSTDCALL; + TypInfo.ccSafeCall: cc := ccSAFECALL; + end; + + // Set CallMode, MethodIndex and CodeAddress all at once. + // Note that for cases dkVTable and dkDynamic m.CodeAddress returns an + // incorrect value. Therefore the code address + // is read from the virtual / dynamic method table + // using m.VirtualIndex. + CallMode := cmNONE; + MethodIndex := 0; + CodeAddress := m.CodeAddress; + case m.DispatchKind of + dkStatic: + begin + if C = nil then + CallMode := cmSTATIC; + end; + dkVtable: + begin + CallMode := cmVIRTUAL; + MethodIndex := m.VirtualIndex + 1; + end; + dkDynamic: CallMode := cmDYNAMIC; + dkMessage: CallMode := cmDYNAMIC; + dkInterface: MethodIndex := m.VirtualIndex + 1; + end; + + // Use CodeAddress instead of m.CodeAddress. + if m.IsConstructor then + begin + result := SymbolTable.RegisterConstructor(Level, m.Name, CodeAddress, m.IsClassMethod, CallMode); + R := SymbolTable.Records[SymbolTable.LastSubId]; + end + else if m.IsDestructor then + begin + result := SymbolTable.RegisterMethod(Level, m.Name, TypeId, cc, CodeAddress, false, CallMode, MethodIndex); + R := SymbolTable.Records[SymbolTable.LastSubId]; + R.Kind := kindDESTRUCTOR; + end + else + begin + result := SymbolTable.RegisterMethod(Level, m.Name, TypeId, cc, CodeAddress, m.IsClassMethod, CallMode, MethodIndex); + R := SymbolTable.Records[SymbolTable.LastSubId]; + end; + R.MethodIndex := MethodIndex; + R.OverCount := OverCount; + + case m.Visibility of + mvPrivate: R.Vis := cvPrivate; + mvProtected: R.Vis := cvProtected; + mvPublic: R.Vis := cvPublic; + mvPublished: R.Vis := cvPublished; + end; + + if C <> nil then + if CallMode = cmDYNAMIC then + R.DynamicMethodIndex := + GetDynamicMethodIndexByAddress(C, CodeAddress); + + SubId := SymbolTable.LastSubId; + K := 0; + for param in m.GetParameters() do + begin + if param.ParamType = nil then + typeID := typeVOID + else + begin + S := param.ParamType.Name; + typeId := SymbolTable.LookUpType(S, true); + if TypeId = 0 then + begin + SymbolTable.ExternList.Add(SymbolTable.Card + 1, S, erTypeId); + end; + end; + + SymbolTable.RegisterParameter(result, TypeId, Unassigned, false, param.Name, 0); + R := SymbolTable.Records[SymbolTable.Card]; + + if [pfVar, pfReference, pfOut] * Param.Flags <> [] then + R.ByRef := true; + if pfConst in param.Flags then + R.IsConst := true; + if pfArray in param.Flags then + R.IsOpenArray := true; + + Inc(K); + end; + + SymbolTable.Records[SubId].Count := K; +end; + +function RegisterRecordType(Level: Integer; t: TRTTIRecordType; + SymbolTable: TBaseSymbolTable): Integer; +var + m: TRTTIMethod; + f: TRTTIField; +begin + result := SymbolTable.RegisterRecordType(Level, + t.Name, GlobalAlignment); + for f in t.GetFields do + if CheckField(t, f) then + RegisterField(result, f, SymbolTable); + for m in t.GetDeclaredMethods do + if CheckMethod(t, m) then + RegisterMethod(Result, m, SymbolTable); +end; + +function RegisterClassType(Level: Integer; t: TRTTIInstanceType; + SymbolTable: TBaseSymbolTable; + AcceptList: TStrings = nil): Integer; +var + m: TRTTIMethod; + f: TRTTIField; + C: TClass; +{$IFDEF DPULSAR} + IndexedProp: TRTTIIndexedProperty; +{$ENDIF} +{$IFDEF ARC} + RegisteredMethods: TList; +{$ELSE} + RegisteredMethods: TList; +{$ENDIF} +{$IFDEF DPULSAR} + Index, id: Integer; + Decl: string; + it: TRttiInterfaceType; +{$ENDIF} + MethodIndex: Integer; + Header: String; +begin + C := t.MetaclassType; + + result := SymbolTable.RegisterClassType(Level, C); + + for f in t.GetDeclaredFields do + if CheckField(t, f) then + RegisterField(result, f, SymbolTable); + + // Store registered methods in a local list to be used during registration of indexed properties. +{$IFDEF ARC} + RegisteredMethods := TList.Create; +{$ELSE} + RegisteredMethods := TList.Create; +{$ENDIF} + try + for m in t.GetDeclaredMethods do + begin + if AcceptList <> nil then + if AcceptList.IndexOf(m.Name) = -1 then + continue; + + if m.HasExtendedInfo then + begin + if CheckMethod(t, m) then + begin + RegisterMethod(Result, m, SymbolTable); + // Add method to list. + RegisteredMethods.Add(m); + end; + end + else + begin + // Call an event to provide a header for known methods that have no RTTI extended info. + if (m.Visibility in [mvPublic, mvPublished]) and Assigned(OnMethodHasNoExtendedInfo) then begin + Header := ''; + OnMethodHasNoExtendedInfo(Header, m); + if Header <> '' then begin + MethodIndex := 0; + if m.DispatchKind = dkVtable then + MethodIndex := m.VirtualIndex; + SymbolTable.RegisterHeader(Result, Header, m.CodeAddress, MethodIndex); + end; + end; + end; + end; +{$IFDEF DPULSAR} + // Added support for indexed properties. + for IndexedProp in t.GetDeclaredIndexedProperties do + begin + if CheckIndexedProperty(t, IndexedProp) then + begin + if IndexedProp.IsReadable then begin + Index := RegisteredMethods.IndexOf(IndexedProp.ReadMethod); + if Index = -1 then + begin + RegisterMethod(Result, IndexedProp.ReadMethod, SymbolTable); + RegisteredMethods.Add(IndexedProp.ReadMethod); + end; + end; + if IndexedProp.IsWritable then + begin + Index := RegisteredMethods.IndexOf(IndexedProp.WriteMethod); + if Index = -1 then begin + RegisterMethod(Result, IndexedProp.WriteMethod, SymbolTable); + RegisteredMethods.Add(IndexedProp.WriteMethod); + end; + end; + Decl := GetIndexedPropertyDecl(IndexedProp); + SymbolTable.RegisterHeader(Result, Decl, nil); + end; + end; +{$ENDIF} + finally + FreeAndNil(RegisteredMethods); + end; + +{$IFDEF DPULSAR} + for it in t.GetDeclaredImplementedInterfaces do + begin + id := SymbolTable.LookUpFullName(it.QualifiedName, true); + if id = 0 then + begin + if not CheckType(it) then + continue; + RegisterInterfaceType(Level, it, SymbolTable); + end; + + SymbolTable.RegisterSupportedInterface(result, it.Name, it.GUID); + end; +{$ENDIF} +end; + +function RegisterInterfaceType(Level: Integer; t: TRTTIInterfaceType; + SymbolTable: TBaseSymbolTable): Integer; +var + m: TRTTIMethod; + f: TRTTIField; + p: TRTTIProperty; + S: String; +begin + S := t.Name; + + result := SymbolTable.RegisterInterfaceType(Level, S, t.guid); + for f in t.GetDeclaredFields do + if CheckField(t, f) then + RegisterField(result, f, SymbolTable); + for m in t.GetDeclaredMethods do + if CheckMethod(t, m) then + begin + RegisterMethod(result, m, SymbolTable); + end; + for p in t.GetProperties do + if CheckProperty(t, p) then + RegisterProperty(result, p, 0, SymbolTable); +end; + +function RegisterArrayType(Level: Integer; t: TRTTIArrayType; + SymbolTable: TBaseSymbolTable): Integer; +var + I, K, HR, HE, Align: Integer; + S: String; +begin + Align := GlobalAlignment; + K := t.DimensionCount; + result := 0; + for I := 0 to K - 1 do + begin + if t.Dimensions[I] = nil then + begin + result := 0; + Exit; + end; + + HR := RegisterType(Level, t.Dimensions[I], SymbolTable); + if I = 0 then + HE := RegisterType(Level, t.ElementType, SymbolTable) + else + HE := result; + if I = K - 1 then + S := t.Name + else + S := 'Array_' + IntToStr(SymbolTable.Card + 1); + result := SymbolTable.RegisterArrayType(Level, S, HR, HE, Align); + end; +end; + +function RegisterDynamicArrayType(Level: Integer; t: TRTTIDynamicArrayType; + SymbolTable: TBaseSymbolTable): Integer; +begin + result := SymbolTable.RegisterRTTIType(Level, t.Handle) +end; + +function RegisterPointerType(Level: Integer; t: TRTTIPointerType; + SymbolTable: TBaseSymbolTable): Integer; +var + H: Integer; + S: String; +begin + if t.ReferredType = nil then + H := typeVOID + else + begin + S := t.ReferredType.Name; + H := SymbolTable.LookUpType(S, true); + if H = 0 then + SymbolTable.ExternList.Add(SymbolTable.Card + 1, S, erPatternId); + end; + result := SymbolTable.RegisterPointerType(Level, t.Name, H); +end; + +function RegisterClassRefType(Level: Integer; t: TRTTIClassRefType; + SymbolTable: TBaseSymbolTable): Integer; +var + H: Integer; + S: String; +begin + S := t.InstanceType.Name; + H := SymbolTable.LookUpType(S, true); + if H = 0 then + SymbolTable.ExternList.Add(SymbolTable.Card + 1, S, erPatternId); + result := SymbolTable.RegisterClassReferenceType(Level, t.Name, H); +end; + +{$IFNDEF GE_DXE2} +function RegisterProceduralType(Level: Integer; t: TRTTIProcedureType; + SymbolTable: TBaseSymbolTable): Integer; +var + cc, ResultTypeId, TypeId, SubId, I, K, H: Integer; + rt: PPTypeInfo; + S: String; + R: TSymbolRec; + ProcSig: PProcedureSignature; + P: PProcedureParam; + pti: PTypeInfo; + ptd: PTypeData; +begin + result := 0; + pti := t.Handle; + ptd := GetTypeData(pti); + ProcSig := ptd^.ProcSig; + if not NativeAddress(ProcSig) then + Exit; + rt := ProcSig.ResultType; + if rt = nil then + ResultTypeId := typeVOID + else + ResultTypeId := SymbolTable.LookUpType(String(rt^.Name), true); + + cc := ccREGISTER; + case ProcSig.CC of + TypInfo.ccReg: cc := ccREGISTER; + TypInfo.ccCdecl: cc := ccCDECL; + TypInfo.ccPascal: cc := ccPASCAL; + TypInfo.ccStdCall: cc := ccSTDCALL; + TypInfo.ccSafeCall: cc := ccSAFECALL; + end; + + H := SymbolTable.RegisterRoutine(Level, '', ResultTypeId, cc, nil); + SubId := SymbolTable.LastSubId; + + K := ProcSig.ParamCount; + P := ShiftPointer(ProcSig, SizeOf(TProcedureSignature)); + + for I := 0 to K - 1 do + begin + if P.ParamType = nil then + typeID := typeVOID + else + begin + S := String(p.ParamType^.Name); + typeId := SymbolTable.LookUpType(S, true); + if TypeId = 0 then + SymbolTable.ExternList.Add(SymbolTable.Card + 1, S, erTypeId); + end; + + SymbolTable.RegisterParameter(H, TypeId, Unassigned, false, String(P.Name), 0); + R := SymbolTable.Records[SymbolTable.Card]; + + if [pfVar, pfReference, pfOut] * TParamFlags(P.Flags) <> [] then + R.ByRef := true; + if pfConst in TParamFlags(P.Flags) then + R.IsConst := true; + if pfArray in TParamFlags(P.Flags) then + R.IsOpenArray := true; + + P := ShiftPointer(P, SizeOf(TProcedureParam)); + end; + + SymbolTable.Records[SubId].Count := K; + + result := SymbolTable.RegisterProceduralType(Level, t.Name, H); +end; +{$ELSE} +function RegisterProceduralType(Level: Integer; t: TRTTIProcedureType; + SymbolTable: TBaseSymbolTable): Integer; +var + cc, ResultTypeId, TypeId, SubId, K, H: Integer; + rt: TRTTIType; + param: TRTTIParameter; + S: String; + R: TSymbolRec; +begin + rt := t.ReturnType; + if rt = nil then + ResultTypeId := typeVOID + else + ResultTypeId := SymbolTable.LookUpType(rt.Name, true); + + cc := ccREGISTER; + case t.CallingConvention of + TypInfo.ccReg: cc := ccREGISTER; + TypInfo.ccCdecl: cc := ccCDECL; + TypInfo.ccPascal: cc := ccPASCAL; + TypInfo.ccStdCall: cc := ccSTDCALL; + TypInfo.ccSafeCall: cc := ccSAFECALL; + end; + + H := SymbolTable.RegisterRoutine(Level, '', ResultTypeId, cc, nil); + + SubId := SymbolTable.LastSubId; + K := 0; + for param in t.GetParameters() do + begin + if param.ParamType = nil then + TypeId := typeVOID + else + begin + S := param.ParamType.Name; + typeId := SymbolTable.LookUpType(S, true); + if TypeId = 0 then + SymbolTable.ExternList.Add(SymbolTable.Card + 1, S, erTypeId); + end; + + SymbolTable.RegisterParameter(H, TypeId, Unassigned, false, param.Name, 0); + R := SymbolTable.Records[SymbolTable.Card]; + + if [pfVar, pfReference, pfOut] * Param.Flags <> [] then + R.ByRef := true; + if pfConst in param.Flags then + R.IsConst := true; + if pfArray in param.Flags then + R.IsOpenArray := true; + + Inc(K); + end; + + SymbolTable.Records[SubId].Count := K; + + result := SymbolTable.RegisterProceduralType(Level, t.Name, H); +end; +{$ENDIF} + +{$IFNDEF GE_DXE2} +function RegisterEventType(Level: Integer; t: TRTTIMethodType; + SymbolTable: TBaseSymbolTable): Integer; +var + cc, TypeId, SubId, I, K, H, L: Integer; + R: TSymbolRec; + ProcSig: PProcedureSignature; + P: Pointer; + pti: PTypeInfo; + ptd: PTypeData; + Flags: TParamFlags; + ParamName: ShortString; + TypeName: ShortString; + ResultType: ShortString; + CallConv: TCallConv; +begin + pti := t.Handle; + ptd := GetTypeData(pti); + K := ptd^.ParamCount; + H := SymbolTable.RegisterRoutine(Level, '', 0, ccREGISTER, nil); + SubId := SymbolTable.LastSubId; + P := @ ptd^.ParamCount; + P := ShiftPointer(P, 1); + for I := 0 to K - 1 do + begin + Flags := TParamFlags(P^); + P := ShiftPointer(P, SizeOf(TParamFlags)); + L := Byte(P^); + Move(P^, ParamName, L + 1); + P := ShiftPointer(P, L + 1); + L := Byte(P^); + Move(P^, TypeName, L + 1); + P := ShiftPointer(P, L + 1); + TypeId := SymbolTable.LookUpType(String(TypeName), true); + if TypeId = 0 then + SymbolTable.ExternList.Add(SymbolTable.Card + 1, String(TypeName), erTypeId); + SymbolTable.RegisterParameter(H, TypeId, Unassigned, false, String(ParamName), 0); + R := SymbolTable.Records[SymbolTable.Card]; + + if [pfVar, pfReference, pfOut] * TParamFlags(Flags) <> [] then + R.ByRef := true; + if pfConst in TParamFlags(Flags) then + R.IsConst := true; + if pfArray in TParamFlags(Flags) then + R.IsOpenArray := true; + end; + + if ptd^.MethodKind = mkFunction then + begin + L := Byte(P^); + Move(P^, ResultType, L + 1); + TypeId := SymbolTable.LookUpType(String(ResultType), true); + SymbolTable.Records[SubId].TypeId := TypeId; + I := SymbolTable.GetResultId(SubId); + SymbolTable.Records[I].TypeId := TypeId; + + P := ShiftPointer(P, L + 1); + P := ShiftPointer(P, SizeOf(Pointer)); + end; + + CallConv := TCallConv(P^); + cc := ccREGISTER; + case CallConv of + TypInfo.ccReg: cc := ccREGISTER; + TypInfo.ccCdecl: cc := ccCDECL; + TypInfo.ccPascal: cc := ccPASCAL; + TypInfo.ccStdCall: cc := ccSTDCALL; + TypInfo.ccSafeCall: cc := ccSAFECALL; + end; + SymbolTable.Records[SubId].CallConv := cc; + + SymbolTable.Records[SubId].Count := K; + result := SymbolTable.RegisterEventType(Level, t.Name, H); +end; +{$ELSE} +function RegisterEventType(Level: Integer; t: TRTTIMethodType; + SymbolTable: TBaseSymbolTable): Integer; +var + cc, ResultTypeId, TypeId, SubId, K, H: Integer; + rt: TRTTIType; + param: TRTTIParameter; + S: String; + R: TSymbolRec; +begin + rt := t.ReturnType; + if rt = nil then + ResultTypeId := typeVOID + else + ResultTypeId := SymbolTable.LookUpType(rt.Name, true); + + cc := ccREGISTER; + case t.CallingConvention of + TypInfo.ccReg: cc := ccREGISTER; + TypInfo.ccCdecl: cc := ccCDECL; + TypInfo.ccPascal: cc := ccPASCAL; + TypInfo.ccStdCall: cc := ccSTDCALL; + TypInfo.ccSafeCall: cc := ccSAFECALL; + end; + + H := SymbolTable.RegisterRoutine(Level, '', ResultTypeId, cc, nil); + + SubId := SymbolTable.LastSubId; + K := 0; + for param in t.GetParameters() do + begin + if param.ParamType = nil then + TypeId := typeVOID + else + begin + S := param.ParamType.Name; + typeId := SymbolTable.LookUpType(S, true); + if TypeId = 0 then + SymbolTable.ExternList.Add(SymbolTable.Card + 1, S, erTypeId); + end; + + SymbolTable.RegisterParameter(H, TypeId, Unassigned, false, param.Name, 0); + R := SymbolTable.Records[SymbolTable.Card]; + + if [pfVar, pfReference, pfOut] * Param.Flags <> [] then + R.ByRef := true; + if pfConst in param.Flags then + R.IsConst := true; + if pfArray in param.Flags then + R.IsOpenArray := true; + + Inc(K); + end; + + SymbolTable.Records[SubId].Count := K; + + result := SymbolTable.RegisterEventType(Level, t.Name, H); +end; +{$ENDIF} + +function RegisterType(Level: Integer; t: TRTTIType; + SymbolTable: TBaseSymbolTable; + AcceptList: TStrings = nil): Integer; +var + S: String; +begin + result := 0; + if t = nil then + Exit; + S := t.Name; + + result := SymbolTable.LookUpType(S, true); + if result > 0 then + Exit; + + case t.TypeKind of + tkRecord: + result := RegisterRecordType(Level, t as TRTTIRecordType, SymbolTable); + tkClass: + result := RegisterClassType(Level, t as TRTTIInstanceType, + SymbolTable, AcceptList); + tkInterface: + result := RegisterInterfaceType(Level, t as TRTTIInterfaceType, SymbolTable); + tkArray: + result := RegisterArrayType(Level, t as TRTTIArrayType, SymbolTable); + tkDynArray: + result := RegisterDynamicArrayType(Level, t as TRTTIDynamicArrayType, SymbolTable); + tkPointer: + result := RegisterPointerType(Level, t as TRTTIPointerType, SymbolTable); + tkProcedure: + result := RegisterProceduralType(Level, t as TRTTIProcedureType, SymbolTable); + tkMethod: + result := RegisterEventType(Level, t as TRTTIMethodType, SymbolTable); + tkClassRef: + result := RegisterClassRefType(Level, t as TRTTIClassRefType, SymbolTable); + else + result := SymbolTable.RegisterRTTIType(Level, t.Handle); + end; +end; + +function RegisterUnit(AUnit: TUnit; + SymbolTable: TBaseSymbolTable; + AcceptList: TStrings = nil; + kernel: Pointer = nil): Integer; +var + I, Id: Integer; + Q: TStringList; + S: String; +begin + result := 0; + Q := ExtractNames(AUnit.Name); + try + + for I := 0 to Q.Count - 1 do + begin + S := Q[I]; + if StrEql(S, 'System') then + result := 0 + else + result := SymbolTable.RegisterNamespace(result, S); + end; + + for I := 0 to AUnit.Count - 1 do + begin + Id := RegisterType(result, AUnit[I].T, SymbolTable, AcceptList); + if kernel <> nil then + if Assigned(TKernel(kernel).OnImportType) then + TKernel(kernel).OnImportType(TKernel(kernel).Owner, + Id, + AUnit[I].T.QualifiedName); + end; + + finally + FreeAndNil(Q); + end; +end; + +procedure RegisterUnits(UnitList: TUnitList; SymbolTable: TBaseSymbolTable); +var + I: Integer; +begin + for I := 0 to UnitList.Count - 1 do + RegisterUnit(UnitList[I], SymbolTable); + for I := 0 to UnitList.ForbiddenClasses.Count - 1 do + SymbolTable.HideClass(TClass(UnitList.ForbiddenClasses[I])); +end; + +procedure RegisterUnits(UnitList: TUnitList); +var + I: Integer; +begin + for I := 0 to UnitList.Count - 1 do + RegisterUnit(UnitList[I], GlobalImportTable); +end; + +// TValue --------- + +function TValue_Implicit_String(const Value: string): TValue; +begin + result := Value; +end; + +function TValue_Implicit_Integer(Value: Integer): TValue; +begin + result := Value; +end; + +function TValue_Implicit_Extended(Value: Extended): TValue; +begin + result := Value; +end; + +function TValue_Implicit_Int64(Value: Int64): TValue; +begin + result := Value; +end; + +function TValue_Implicit_TObject(Value: TObject): TValue; +begin + result := Value; +end; + +function TValue_Implicit_TClass(Value: TClass): TValue; +begin + result := Value; +end; + +function TValue_Implicit_Boolean(Value: Boolean): TValue; +begin + result := Value; +end; + +function TValue_GetDataSize(Self: TValue): Integer; +begin + result := Self.DataSize; +end; + +procedure _VarFromTValue(V: PTValue; T: Integer; Dest: Pointer); +stdcall; +begin + case T of + 0, typeVOID: Exit; + typeINTEGER: Integer(Dest^) := V.AsInteger; + typeSMALLINT: SmallInt(Dest^) := V.AsInteger; + typeSHORTINT: ShortInt(Dest^) := V.AsInteger; + typeINT64: Int64(Dest^) := V.AsInt64; +{$IFDEF GE_DXE4} + typeUINT64: UInt64(Dest^) := V.AsUInt64; + typeBYTE: Byte(Dest^) := V.AsUInt64; + typeWORD: Word(Dest^) := V.AsUInt64; + typeCARDINAL: Cardinal(Dest^) := V.AsUInt64; +{$ELSE} + typeUINT64: UInt64(Dest^) := V.AsInt64; + typeBYTE: Byte(Dest^) := V.AsOrdinal; + typeWORD: Word(Dest^) := V.AsOrdinal; + typeCARDINAL: Cardinal(Dest^) := V.AsOrdinal; +{$ENDIF} +{$IFNDEF PAXARM} + typeANSICHAR: Byte(Dest^) := V.AsOrdinal; + typeSHORTSTRING: PShortStringFromString(Dest, V.AsString); + typeANSISTRING: AnsiString(Dest^) := AnsiString(V.AsString); + typeWIDESTRING: WideString(Dest^) := V.AsString; +{$ENDIF} + typeWIDECHAR: Word(Dest^) := V.AsOrdinal; + typeENUM: Byte(Dest^) := V.AsOrdinal; + typeBOOLEAN: Boolean(Dest^) := V.AsBoolean; + typeBYTEBOOL: ByteBool(Dest^) := ByteBool(V.AsOrdinal); + typeWORDBOOL: WordBool(Dest^) := WordBool(V.AsOrdinal); + typeLONGBOOL: LongBool(Dest^) := LongBool(V.AsOrdinal); + typeDOUBLE: Double(Dest^) := V.AsExtended; + typeSINGLE: Single(Dest^) := V.AsExtended; + typeEXTENDED: Extended(Dest^) := V.AsExtended; + typeCURRENCY: Currency(Dest^) := V.AsCurrency; + typeUNICSTRING: UnicString(Dest^) := V.AsString; + typeCLASS: TObject(Dest^) := V.AsObject; + typeCLASSREF: Pointer(Dest^) := V.AsClass; + typePOINTER: V.ExtractRawData(Dest); + typePROC: Pointer(Dest^) := V.AsType; + typeVARIANT: Variant(Dest^) := V.AsVariant; + typeOLEVARIANT: OleVariant(Dest^) := V.AsVariant; + typeINTERFACE: IUnknown(Dest^) := V.AsType; + else + V.ExtractRawDataNoCopy(Dest); + end; +end; + +procedure _TValueToObject(var V: TValue; var result: TObject); stdcall; +begin + result := V.AsObject; +end; + +procedure _GetDRTTIProperty(p: TRTTIProperty; + X: TObject; + var Result: TValue); stdcall; +begin + result := p.GetValue(X); +end; + +procedure _GetDRTTIIntegerProperty(p: TRTTIProperty; + X: TObject; + var Result: Integer); stdcall; +begin + result := p.GetValue(X).AsInteger; +end; + +procedure _GetDRTTIStringProperty(p: TRTTIProperty; + X: TObject; + var Result: String); stdcall; +begin + result := p.GetValue(X).AsString; +end; + +procedure _GetDRTTIExtendedProperty(p: TRTTIProperty; + X: TObject; + var Result: Extended); stdcall; +begin + result := p.GetValue(X).AsExtended; +end; + +procedure _GetDRTTIVariantProperty(p: TRTTIProperty; + X: TObject; + var Result: Variant); stdcall; +begin + result := p.GetValue(X).AsVariant; +end; + +procedure _GetDRTTIInt64Property(p: TRTTIProperty; + X: TObject; + var Result: Int64); stdcall; +begin + result := p.GetValue(X).AsOrdinal; +end; + +procedure _SetDRTTIProperty(p: TRTTIProperty; + X: TObject; + Value: PTValue); stdcall; +var + i: Int64; +begin + if p.PropertyType.Handle.Kind = tkEnumeration then + begin + if Value^.IsType then + i := Integer(Value.AsBoolean) + else + i := Value.AsInteger; + Value^ := TValue.FromOrdinal(p.PropertyType.Handle, i); + p.SetValue(X, Value^); + end + else + p.SetValue(X, Value^); +end; + +function RegisterProperty(ALevel: Integer; + p: TRTTIProperty; + Index: Integer; + SymbolTable: TBaseSymbolTable): Integer; +var + S: String; + T: Integer; + typ: TRTTIType; +begin + with SymbolTable do + begin + if p = nil then + begin + with AddRecord do + begin + Name := ''; + Kind := KindPROP; + TypeID := 0; + Host := true; + Shift := 0; + Level := ALevel; + IsPublished := false; + IsDRTTI := true; + PropIndex := Index; + + result := Card; + end; + Exit; + end; + + typ := p.PropertyType; + S := typ.Name; + T := LookUpType(S, true); + if T = 0 then + ExternList.Add(Card + 1, S, erTypeId); + + with AddRecord do + begin + Name := p.Name; + Kind := KindPROP; + TypeID := T; + Host := true; + Shift := 0; + Level := ALevel; + IsPublished := false; + IsDRTTI := true; + PropIndex := Index; + + result := Card; + end; + end; +end; + +procedure RegisterDRTTIPropertiesImpl(Level: Integer; + C: TClass; + SymbolTable: TBaseSymbolTable); + + function PublishedPropertyCount: Integer; + var + pti: PTypeInfo; + ptd: PTypeData; + begin + result := 0; + pti := C.ClassInfo; + if pti = nil then Exit; + ptd := GetTypeData(pti); + result := ptd^.PropCount; + end; + +var + I, K, LastPropertyIndex: Integer; + p: TRTTIProperty; + t: TRTTIType; +begin + if IsPaxClass(C) then + begin + SymbolTable.RegisterClassTypeInfos(Level,C); + Exit; + end; + + LastPropertyIndex := PublishedPropertyCount; + K := 0; + + repeat + t := PaxContext.GetType(C); + for p in t.GetDeclaredProperties do + begin + if CheckProperty(t, p) then + begin + if SymbolTable.Lookup(p.Name, Level, true, MaxInt, false) = 0 then + begin + RegisterProperty(Level, p, K + LastPropertyIndex, SymbolTable); + end + else + begin + RegisterProperty(Level, nil, K + LastPropertyIndex, SymbolTable); + end; + Inc(K); + end; + end; + C := C.ClassParent; + if C = nil then + break; + until false; + + for I:=1 to K do + SymbolTable.AddPointerVar(0); +end; + +// Added this function to get the namespace of a type. +function GetNamespaceOfTypeImpl(aSymbolTable: TBaseSymbolTable; aTypeInfo: PTypeInfo): Integer; +var + T: TRttiType; + Namespace: string; +begin + Result := 0; + T := PaxContext.GetType(aTypeInfo); + if Assigned(T) then + begin + Namespace := ExtractUnitName(T); + Result := aSymbolTable.LookupNamespace(Namespace, 0, True); + end; +end; + +procedure AddPropInfosDRTTIImpl(C:TClass; PropInfos: TPropList); +var + p: TRTTIProperty; + t: TRTTIType; + LastOffset: Integer; +begin + if isPaxClass(C) then + exit; + if PropInfos.Count = 0 then + LastOffset := 0 + else + LastOffset := PropInfos.Top.PropOffset + SizeOf(Pointer); + + repeat + t := PaxContext.GetType(C.ClassInfo); + + for p in t.GetDeclaredProperties do + if CheckProperty(t, p) then + begin + PropInfos.Add(p, LastOffset); + Inc(LastOffset, SizeOf(Pointer)); + end; + + C := C.ClassParent; + if C = nil then + break; + + until false; +end; + +procedure Import_TValueImpl(Level: Integer; SymbolTable: TBaseSymbolTable); +var + H, H_Sub: Integer; +begin + with SymbolTable do + begin + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_VarFromTValue); + Id_VarFromTValue := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_GetDRTTIProperty); + Id_GetDRTTIProperty := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_GetDRTTIIntegerProperty); + Id_GetDRTTIIntegerProperty := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_GetDRTTIStringProperty); + Id_GetDRTTIStringProperty := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_GetDRTTIExtendedProperty); + Id_GetDRTTIExtendedProperty := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_GetDRTTIVariantProperty); + Id_GetDRTTIVariantProperty := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_GetDRTTIInt64Property); + Id_GetDRTTIInt64Property := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_SetDRTTIProperty); + Id_SetDRTTIProperty := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + H := RegisterRecordType(Level, 'TValue', 1); + H_TValue := H; + RegisterTypeField(H, 'dummy1', typeINT64); + RegisterTypeField(H, 'dummy2', typeINT64); + RegisterTypeField(H, 'dummy3', typeINT64); + + RegisterHeader(H, 'function GetDataSize: Integer;', + @ TValue_GetDataSize); + + RegisterHeader(H, 'class operator Implicit(const Value: string): TValue;', + @ TValue_Implicit_String); + + RegisterHeader(H, 'class operator Implicit(Value: Extended): TValue;', + @ TValue_Implicit_Extended); + + RegisterHeader(H, 'class operator Implicit(Value: Int64): TValue;', + @ TValue_Implicit_Int64); + + RegisterHeader(H, 'class operator Implicit(Value: TObject): TValue;', + @ TValue_Implicit_TObject); + + RegisterHeader(H, 'class operator Implicit(Value: TClass): TValue;', + @ TValue_Implicit_TClass); + + RegisterHeader(H, 'class operator Implicit(Value: Boolean): TValue;', + @ TValue_Implicit_Boolean); + + RegisterHeader(H, 'class operator Implicit(Value: Integer): TValue;', + @ TValue_Implicit_Integer); + Id_ImplicitInt := LastSubId; + + RegisterHeader(H, 'class function FromVariant(const Value: Variant): TValue; static;', + @TValue.FromVariant); + +// class function From(const Value: T): TValue; static; + RegisterHeader(H, 'class function FromOrdinal(ATypeInfo: Pointer; AValue: Int64): TValue; static;', + @TValue.FromOrdinal); + + RegisterHeader(H, 'class function FromArray(ArrayTypeInfo: Pointer; const Values: array of TValue): TValue; static;', + @TValue.FromArray); + + // Easy out + //property Kind: TTypeKind read GetTypeKind; + //property TypeInfo: PTypeInfo read GetTypeInfo; + //property TypeData: PTypeData read GetTypeDataProp; + //property IsEmpty: Boolean read GetIsEmpty; + + RegisterHeader(H, 'function IsObject: Boolean;', + @TValue.IsObject); + RegisterHeader(H, 'function AsObject: TObject;', + @TValue.AsObject); + RegisterHeader(H, 'function IsInstanceOf(AClass: TClass): Boolean;', + @TValue.IsInstanceOf); + RegisterHeader(H, 'function IsClass: Boolean;', + @TValue.IsClass); + RegisterHeader(H, 'function AsClass: TClass;', + @TValue.AsClass); + RegisterHeader(H, 'function IsOrdinal: Boolean;', + @ TValue.IsOrdinal); + RegisterHeader(H, 'function AsOrdinal: Int64;', + @TValue.AsOrdinal); + RegisterHeader(H, 'function TryAsOrdinal(out AResult: Int64): Boolean;', + @TValue.TryAsOrdinal); + + // TValue -> concrete type + // IsType returns true if AsType or Cast would succeed + // AsType / Cast are only for what would normally be implicit conversions in Delphi. + + // function IsType: Boolean; overload; + // function IsType(ATypeInfo: PTypeInfo): Boolean; overload; + // function AsType: T; + // function TryAsType(out AResult: T): Boolean; + + // TValue -> TValue conversions + // function Cast: TValue; overload; + // function Cast(ATypeInfo: PTypeInfo): TValue; overload; + // function TryCast(ATypeInfo: PTypeInfo; out AResult: TValue): Boolean; + + RegisterHeader(H, 'function AsInteger: Integer;', + @TValue.AsInteger); + RegisterHeader(H, 'function AsBoolean: Boolean;', + @TValue.AsBoolean); + RegisterHeader(H, 'function AsExtended: Extended;', + @TValue.AsExtended); + RegisterHeader(H, 'function AsInt64: Int64;', + @TValue.AsInt64); + RegisterHeader(H, 'function AsInterface: IInterface;', + @TValue.AsInterface); + RegisterHeader(H, 'function AsInt64: Int64;', + @TValue.AsInt64); + RegisterHeader(H, 'function AsString: String;', + @TValue.AsString); + RegisterHeader(H, 'function AsVariant: Variant;', + @TValue.AsVariant); + RegisterHeader(H, 'function AsCurrency: Currency;', + @TValue.AsCurrency); + RegisterHeader(H, 'function IsArray: Boolean;', + @TValue.IsArray); + + RegisterHeader(H, 'function GetArrayLength: Integer;', + @TValue.GetArrayLength); + RegisterHeader(H, 'function GetArrayElement(Index: Integer): TValue;', + @TValue.GetArrayElement); + RegisterHeader(H, 'procedure SetArrayElement(Index: Integer; const AValue: TValue);', + @TValue.SetArrayElement); + + // Low-level in + //class procedure Make(ABuffer: Pointer; ATypeInfo: PTypeInfo; out Result: TValue); overload; static; + //class procedure MakeWithoutCopy(ABuffer: Pointer; ATypeInfo: PTypeInfo; out Result: TValue); overload; static; + //class procedure Make(AValue: NativeInt; ATypeInfo: PTypeInfo; out Result: TValue); overload; static; + + // Low-level out + RegisterHeader(H, 'property DataSize: Integer read GetDataSize;', nil); + + RegisterHeader(H, 'procedure ExtractRawData(ABuffer: Pointer);', + @TValue.ExtractRawData); + // If internal data is something with lifetime management, this copies a + // reference out *without* updating the reference count. + RegisterHeader(H, 'procedure ExtractRawDataNoCopy(ABuffer: Pointer);', + @TValue.ExtractRawDataNoCopy); + + RegisterHeader(H, 'function GetReferenceToRawData: Pointer;', + @TValue.GetReferenceToRawData); + RegisterHeader(H, 'function GetReferenceToRawArrayElement(Index: Integer): Pointer;', + @TValue.GetReferenceToRawArrayElement); + + RegisterHeader(H, 'function ToString: string;', + @TValue.ToString); + end; +end; + +procedure InitializePAXCOMP_2010Reg; +begin + RegisterDRTTIProperties := RegisterDRTTIPropertiesImpl; + // Set event to get the namespace of a type. + GetNamespaceOfType := GetNamespaceOfTypeImpl; + AddPropInfosDRTTI := AddPropInfosDRTTIImpl; + Import_TValue := Import_TValueImpl; +end; + +initialization + InitializePAXCOMP_2010Reg; +{$else} +implementation +{$endif} +end. + diff --git a/Sources/PAXCOMP_ARM.pas b/Sources/PAXCOMP_ARM.pas new file mode 100644 index 0000000..4ef2e4a --- /dev/null +++ b/Sources/PAXCOMP_ARM.pas @@ -0,0 +1,465 @@ +// The code below is based on RTTI.pas Delphi XE5. +// Added extra parameter ByRefs. + +unit PAXCOMP_ARM; +interface +uses + TypInfo, RTTI; + +function Invoke(CodeAddress: Pointer; + const Args: TArray; + const ByRefs: TArray; + CallingConvention: TCallConv; + AResultType: PTypeInfo; + IsStatic: Boolean; + IsConstructor: Boolean): TValue; + +implementation + +function UseResultPointer(TypeInfo: PTypeInfo; IsConstructor: Boolean): Boolean; +begin + if TypeInfo = nil then + Exit(False); + + case TypeInfo^.Kind of +{$IFDEF AUTOREFCOUNT} + tkClass: + Result := not IsConstructor; +{$ENDIF AUTOREFCOUNT} + tkInterface, tkMethod, tkDynArray, tkUString, tkLString, tkWString, + tkString, tkVariant: + Exit(True); + + tkRecord: + case GetTypeData(TypeInfo)^.RecSize of +{$IF Defined(CPUX64)} + 1, 2, 4: Result := False; + 8: Result := IsManaged(TypeInfo); +{$ELSEIF Defined(CPUX86)} + + 1, 2: Result := False; + 4: Result := IsManaged(TypeInfo); +{$ELSEIF Defined(CPUARM)} + + + 1: Result := False; +{$ENDIF CPU} + else + Result := True; + end; + tkArray: +{$IF Defined(CPUX64)} + Result := not (GetTypeData(TypeInfo)^.ArrayData.Size in [1, 2, 4, 8]); +{$ELSEIF Defined(CPUX86) or Defined(CPUARM)} + + Result := not (GetTypeData(TypeInfo)^.ArrayData.Size in [1, 2, 4]); +{$ENDIF CPU} + else + Result := False; + end; +end; + +function AllocReg(var Regs: UInt32): UInt32; +var + newRegs: UInt32; +begin + if Regs = 0 then + Exit(0); + newRegs := Regs and (Regs - 1); // clear lowest bit + Result := Regs and not newRegs; // reveal bit cleared + Regs := newRegs; +end; + +function Align4(Value: Integer): Integer; +begin + Result := (Value + 3) and not 3; +end; + +function PassByRef(TypeInfo: PTypeInfo; CC: TCallConv; IsConst: Boolean = False): Boolean; +begin + if TypeInfo = nil then + Exit(False); + case TypeInfo^.Kind of + tkArray: + Result := GetTypeData(TypeInfo)^.ArrayData.Size > SizeOf(Pointer); +{$IF Defined(CPUX86)} + tkRecord: + if (CC in [ccCdecl, ccStdCall, ccSafeCall]) and not IsConst then + Result := False + else + Result := GetTypeData(TypeInfo)^.RecSize > SizeOf(Pointer); + tkVariant: // like tkRecord, but hard-coded size + Result := IsConst or not (CC in [ccCdecl, ccStdCall, ccSafeCall]); +{$ELSEIF Defined(CPUX64)} + tkRecord: + Result := not (GetTypeData(TypeInfo)^.RecSize in [1,2,4,8]); + tkMethod, + tkVariant: + Result := True; +{$ELSEIF Defined(CPUARM)} + tkRecord: + Result := (CC = ccReg); + tkMethod, + tkVariant: + Result := True; +{$ENDIF CPUTYPE} +{$IFNDEF NEXTGEN} + tkString: + Result := GetTypeData(TypeInfo)^.MaxLength > SizeOf(Pointer); +{$ENDIF !NEXTGEN} + else + Result := False; + end; +end; + + +type + PParamBlock = ^TParamBlock; + TParamBlock = record + RegCR : array[0..3] of Int32; + + StackData: PByte; + StackDataSize: Integer; + + case Integer of + 0: ( RegD: array[0..7] of Double ); + 1: ( RegS: array[0..15] of Single ); + end; + +procedure RawInvoke(CodeAddress: Pointer; ParamBlock: PParamBlock); + external 'librtlhelper.a' name 'rtti_raw_invoke'; + +function Invoke(CodeAddress: Pointer; + const Args: TArray; + const ByRefs: TArray; + CallingConvention: TCallConv; + AResultType: PTypeInfo; + IsStatic: Boolean; + IsConstructor: Boolean): TValue; + + function CalcStackSize: Integer; + var + i: Integer; + FreeCR, + FreeVFP: Integer; + begin + // Estimate maximum stack usage, assuming everything goes + // on the stack with 4-byte alignment. + Result := SizeOf(Pointer); // for potential managed return-value +// FreeCR := 4; // Number of core registers. R0 - R3 + FreeCR := 0; // Number of core registers. R0 - R3 + FreeVFP := 0; // Number of VFP(FP) registers. Default is 0 +{$IFDEF ANDROID} + if CallingConvention in [ccReg] then + FreeVFP := 8; // D0-D7 +{$ENDIF ANDROID} + + for i := 0 to Length(Args) - 1 do + if PassByRef(Args[i].TypeInfo, CallingConvention) or ByRefs[i] then + begin + if FreeCR > 0 then + Dec(FreeCR) // use core register. + else + Inc(Result, SizeOf(Pointer)) + end + else + begin + if Args[i].Kind = tkFloat then + begin + if FreeVFP > 0 then // use VFP register. + Dec(FreeVFP) + else + Inc(Result, SizeOf(Double)); + end + else if Args[i].Kind = tkInt64 then + begin + if FreeCR >= 2 then // use 2 core registers. + Dec(FreeCR, 2) + else if FreeCR = 1 then // use last register and stack + begin + FreeCR := 0; + Inc(Result, SizeOf(Int32)); + end + else + Inc(Result, SizeOf(Int64)); + end + else + begin + if (Args[i].DataSize <= 4) and (FreeCR > 0) then + Dec(FreeCR) + else + Inc(Result, Align4(Args[i].DataSize)); + end; + end; + end; + +const + regNone = $00; + regCRAll = $0F; + regFPRAll = $FFFF; + +var + stackData: array of byte; + block: TParamBlock; + top: PByte; + freeCRegs: UInt32; // 4-core registers (32bit) + freeFPRegs: UInt32; // 16-Single VFP registers (32bit) + // 8-Double VFP registers (64bit) + src: PByte; + + // If RegFlag doesn't have any bit, -1 is returned. + function RegFlagToIndex(RegFlag: UInt32): Integer; + begin + Result := -1; + while (RegFlag <> 0) do + begin + inc(Result); + RegFlag := RegFlag shr 1; + end; + end; + + function RegDoubleFlagToIndex(RegFlag: UInt32): Integer; + begin + Result := -1; + while (RegFlag <> 0) do + begin + inc(Result); + RegFlag := RegFlag shr 2; + end; + end; + + function AllocDoubleReg: UInt32; + var + freeDoubleReg: Uint32; + begin + Result := 0; + freeDoubleReg := freeFPRegs and $55555555; // remove odd FP registers. + // no free Double register. + if freeDoubleReg = 0 then Exit; + // get a free single register at even index. + Result := not(freeDoubleReg and (freeDoubleReg - 1)) and freeDoubleReg; + // Remove two Single registers from FreeFPRegs; + freeFPRegs := freeFPRegs and not( Result or Result shl 1); + end; + +{$IF not defined(IOS)} + function AllocEvenReg(var Regs: UInt32): UInt32; + begin + Result := AllocReg(Regs); + // If get a odd reg, alloc a reg again + // 0002 - R1 + // 0008 - R3 + if (Result and ($2 + $8) <> 0) then + Result := AllocReg(Regs); + end; +{$ENDIF !IOS} + + procedure PutArg(const Arg: TValue); + var + dataSize: Integer; + reg, + regL, regH: UInt32; + L32, H32: UInt32; + U64: UInt64; + begin + dataSize := Arg.DataSize; + if (Arg.Kind = tkFloat) and (Arg.TypeData.FloatType in [ftSingle, ftDouble, ftExtended]) then + begin + if dataSize = 4 then // Single + begin + // First, allocate one single VFP register. + reg := AllocReg(freeFPRegs); + if reg <> 0 then + begin + Arg.ExtractRawData(@block.RegS[RegFlagToIndex(reg)]); + Exit; + end; + end + else if Arg.DataSize = 8 then // Double and Extended + begin + // First, allocate one Double VFP register. + reg := AllocDoubleReg; + if reg <> 0 then + begin + Arg.ExtractRawData(@block.RegD[RegDoubleFlagToIndex(reg)]); + Exit; + end; + end; + end + else if (Arg.Kind = tkRecord) then + begin + src := Arg.GetReferenceToRawData; + while datasize > 0 do + begin + reg := AllocReg(freeCRegs); + if reg <> regNone then + begin + Move(src^, block.RegCR[RegFlagToIndex(reg)], 4); + end + else + begin + Move(src^, top^, 4); + //Inc(top, Align4(dataSize)); + Inc(top, 4); + end; + Dec(dataSize, 4); + Inc(Src, 4); + end; + Exit; + end; + + if (dataSize in [1, 2, 4]) then + begin + reg := AllocReg(freeCRegs); + if reg <> regNone then + begin + Arg.ExtractRawDataNoCopy(@block.RegCR[RegFlagToIndex(reg)]); + Exit; + end; + Arg.ExtractRawDataNoCopy(top); + Inc(top, Align4(dataSize)); + end + else if (dataSize in [8]) then // 64bit data + begin + // Next, allocate two core register + {$IFDEF IOS} + regL := AllocReg(freeCRegs); + {$ELSE} + regL := AllocEvenReg(freeCRegs); + {$ENDIF} + regH := AllocReg(freeCRegs); + if (Arg.Kind = tkFloat) then + begin + case Arg.TypeData.FloatType of + ftSingle, + ftDouble, + ftExtended: + PDouble(@U64)^ := Arg.AsExtended; + ftComp, + ftCurr: + Arg.ExtractRawDataNoCopy(@U64); + end; + end + else + U64 := Arg.AsUInt64; + L32 := U64 and $FFFFFFFF; + H32 := (U64 shr 32) and $FFFFFFFF; + if regL <> 0 then + begin + block.RegCR[ RegFlagToIndex(regL)] := L32; + if regH <> 0 then + block.RegCR[ RegFlagToIndex(regH)] := H32 + else // regH = 0; + begin + PCardinal(top)^ := H32; + Inc(top, SizeOf(H32)); // 4 + end; + end + else // if regL = 0, regH also 0. + begin +{$IF not defined(IOS)} + if ((NativeInt(top) - NativeInt(@stackData[0])) mod 8) <> 0 then + Inc(top, 4); // Set 8 byte align +{$ENDIF !IOS} + PCardinal(top)^ := L32; + Inc(top, SizeOf(L32)); // 4 + PCardinal(top)^ := H32; + Inc(top, SizeOf(H32)); // 4 + end; + end + else + Assert(False, 'somethig wrong'); + end; + + procedure PutRefArg(const Loc: Pointer); + var + reg: UInt32; + begin + reg := AllocReg(freeCRegs); + if reg <> regNone then + begin + block.RegCR[ RegFlagToIndex(reg)] := UInt32(Loc); + Exit; + end; + PPointer(top)^ := Loc; + Inc(top, SizeOf(Pointer)); + end; + +var + i : integer; +begin + FillChar(block, SizeOf(block), 0); + SetLength(stackData, CalcStackSize); + top := @stackData[0]; + + freeCRegs := regCRAll; + freeFPRegs := regNone; +{$IFDEF ANDROID} + if CallingConvention in [ccReg] then + freeFPRegs := regFPRAll; +{$ENDIF ANDROID} + + if IsStatic then + begin + if (CallingConvention <> ccSafeCall) and UseResultPointer(AResultType, IsConstructor) then + begin + TValue.Make(nil, AResultType, Result); + PutRefArg(Result.GetReferenceToRawData); + end; + + if Length(Args) > 0 then + if PassByRef(Args[0].TypeInfo, CallingConvention) or ByRefs[0] then + PutRefArg(Args[0].GetReferenceToRawData) + else + PutArg(Args[0]); + end + else + begin // not IsStatic / It class method + + // Put result first. + if (CallingConvention <> ccSafeCall) and UseResultPointer(AResultType, IsConstructor) then + begin + TValue.Make(nil, AResultType, Result); + PutRefArg(Result.GetReferenceToRawData); + end; + + // First arg is "self". place to 2nd. + if Length(Args) > 0 then + if PassByRef(Args[0].TypeInfo, CallingConvention) or ByRefs[0] then + PutRefArg(Args[0].GetReferenceToRawData) + else + PutArg(Args[0]); + end; + + for i := 1 to Length(Args) - 1 do + if PassByRef(Args[i].TypeInfo, CallingConvention) or ByRefs[i] then + PutRefArg(Args[i].GetReferenceToRawData) + else + PutArg(Args[i]); + + if CallingConvention = ccSafeCall then + begin + TValue.Make(nil, AResultType, Result); + PutRefArg(Result.GetReferenceToRawData); + end; + + block.StackData := @stackData[0]; + block.StackDataSize := top - PByte(@stackData[0]); + + RawInvoke(CodeAddress, @block); + + if AResultType = nil then + Result := TValue.Empty + else if UseResultPointer(AResultType, IsConstructor) then + // do nothing +{$IFDEF ANDROID} + else if (CallingConvention = ccReg) and + (AResultType^.Kind = tkFloat) and + (AResultType.TypeData.FloatType in [ftSingle, ftDouble, ftExtended]) then + TValue.MakeWithoutCopy(@block.RegD[0], AResultType, Result) +{$ENDIF ANDROID} + else + TValue.Make(@block.RegCR[0], AResultType, Result); +end; + +end. diff --git a/Sources/PAXCOMP_BASERUNNER.pas b/Sources/PAXCOMP_BASERUNNER.pas new file mode 100644 index 0000000..1a409b5 --- /dev/null +++ b/Sources/PAXCOMP_BASERUNNER.pas @@ -0,0 +1,2295 @@ +//////////////////////////////////////////////////////////////////////////// +// PaxCompiler +// Site: http://www.paxcompiler.com +// Author: Alexander Baranovsky (paxscript@gmail.com) +// ======================================================================== +// Copyright (c) Alexander Baranovsky, 2006-2014. All rights reserved. +// Code Version: 4.2 +// ======================================================================== +// Unit: PAXCOMP_BASERUNNER.pas +// ======================================================================== +//////////////////////////////////////////////////////////////////////////// + +{$I PaxCompiler.def} +unit PAXCOMP_BASERUNNER; +interface +uses {$I uses.def} + +{$ifdef DRTTI} + RTTI, + PAXCOMP_2010, + PAXCOMP_2010REG, +{$endif} + + SysUtils, + Classes, + TypInfo, + PAXCOMP_CONSTANTS, + PAXCOMP_TYPES, + PAXCOMP_SYS, + PAXCOMP_CLASSLST, + PAXCOMP_CLASSFACT, + PAXCOMP_TYPEINFO, + PAXCOMP_OFFSET, + PAXCOMP_RTI, + PAXCOMP_PROGLIST, + PAXCOMP_MAP, + PAXCOMP_STDLIB, + PAXCOMP_SYMBOL_REC, + PAXCOMP_BASESYMBOL_TABLE, + PAXCOMP_LOCALSYMBOL_TABLE, + PAXCOMP_INVOKE, + PAXCOMP_GC, + PAXCOMP_BRIDGE, + PaxInvoke; +type + TBaseRunner = class + private + fClassList: TClassList; + fSearchPathList: TStringList; + fRunMode: Integer; + fIsEvent: Boolean; + fInitCallStackCount: Integer; + fIsRunning: Boolean; + fProcessingExceptBlock: Boolean; + fExceptionIsAvailableForHostApplication: Boolean; + fHasError: Boolean; + fInitializationProcessed: Boolean; + + function GetRootOwner: TObject; + function GetDataPtr: PBytes; + function GetRootSearchPathList: TStringList; + function GetRunMode: Integer; + procedure SetRunMode(value: Integer); + function GetIsEvent: Boolean; + procedure SetIsEvent(value: Boolean); + function GetInitCallStackCount: Integer; + procedure SetInitCallStackCount(value: Integer); + function GetIsRunning: Boolean; + procedure SetIsRunning(value: Boolean); + function GetProcessingExceptBlock: Boolean; + procedure SetProcessingExceptBlock(value: Boolean); + function GetExceptionIsAvailableForHostApplication: Boolean; + procedure SetExceptionIsAvailableForHostApplication(value: Boolean); + function GetHasError: Boolean; + procedure SetHasError(value: Boolean); + protected + gInstance: TObject; + function GetCodePtr: PBytes; virtual; + function GetProgramSize: Integer; virtual; abstract; + function _VirtualAlloc(Address: Pointer; + Size, flAllocType, flProtect: Cardinal): Pointer; virtual; + procedure _VirtualFree(Address: Pointer; Size: Cardinal); virtual; + procedure Protect; virtual; + procedure UnProtect; virtual; + procedure RunInternal; virtual; + procedure RunExceptInitialization; virtual; + function FireAddressEvent(MR: TMapRec): Pointer; virtual; + public + Owner: TObject; + PCUOwner: TBaseRunner; + + Data: Pointer; + Prog: Pointer; + fDataSize: Integer; + fCodeSize: Integer; + fCurrException: Exception; + fPrevException: Exception; + fImageDataPtr: Integer; + + CurrExpr: String; + IsHalted: Boolean; + + JS_Record: TJS_Record; + PCULang: Byte; + ExitCode: Integer; + SuspendFinalization: Boolean; + ExceptionRec: Pointer; + PausedPCU: TBaseRunner; + UseMapping: Boolean; + Console: Boolean; + ModeSEH: Boolean; + PAX64: Boolean; + InitializationIsProcessed: Boolean; +{$IFNDEF PAXARM_DEVICE} + EPoint: TInvoke; +{$ENDIF} + JS_Object: TObject; + JS_Boolean: TObject; + JS_String: TObject; + JS_Number: TObject; + JS_Date: TObject; + JS_Function: TObject; + JS_Array: TObject; + JS_RegExp: TObject; + JS_Math: TObject; + JS_Error: TObject; +{$IFDEF ARC} + ContextList: TList; +{$ELSE} + ContextList: TList; +{$ENDIF} + ProgTag: Integer; + fGC: TGC; + + PassedClassRef: TClass; + SavedClass: TClass; + + OnMapTableNamespace: TMapTableNamespaceEvent; + OnMapTableVarAddress: TMapTableVarAddressEvent; + OnMapTableProcAddress: TMapTableProcAddressEvent; + OnMapTableClassRef: TMapTableClassRefEvent; + OnLoadPCU: TLoadPCUEvent; + OnException: TErrNotifyEvent; + OnUnhandledException: TErrNotifyEvent; + OnPause: TPauseNotifyEvent; + OnPauseUpdated: TPauseNotifyEvent; + OnHalt: THaltNotifyEvent; + OnLoadProc: TLoadProcEvent; + OnBeforeCallHost: TIdNotifyEvent; + OnAfterCallHost: TIdNotifyEvent; + OnCreateObject: TObjectNotifyEvent; + OnAfterObjectCreation: TObjectNotifyEvent; + OnDestroyObject: TObjectNotifyEvent; + OnAfterObjectDestruction: TClassNotifyEvent; + OnCreateHostObject: TObjectNotifyEvent; + OnDestroyHostObject: TObjectNotifyEvent; + OnPrint: TPrintEvent; + OnPrintEx: TPrintExEvent; + OnPrintClassTypeField: TPrintClassTypeFieldEvent; + OnPrintClassTypeProp: TPrintClassTypePropEvent; + OnCustomExceptionHelper: TCustomExceptionHelperEvent; + OnSaveToStream: TStreamEvent; + OnLoadFromStream: TStreamEvent; + OnBeginProcNotifyEvent: TProcNotifyEvent; + OnEndProcNotifyEvent: TProcNotifyEvent; + OnVirtualObjectMethodCall: TVirtualObjectMethodCallEvent; + OnVirtualObjectPutProperty: TVirtualObjectPutPropertyEvent; + + HostMapTable: TMapTable; + ScriptMapTable: TMapTable; + ProgClassFactory: TPaxClassFactory; + MessageList: TMessageList; + ExportList: TExportList; + ProgTypeInfoList: TPaxTypeInfoList; + OffsetList: TOffsetList; + RunTimeModuleList: TRuntimeModuleList; + DllList: TStringList; + ProgList: TProgList; + LocalSymbolTable: TProgSymbolTable; + GlobalSym: TBaseSymbolTable; + + FinallyCount: Integer; + ByteCodeGlobalEntryList: TIntegerDynArray; + ByteCodeInterfaceSetupList: TIntegerList; + + constructor Create; virtual; + destructor Destroy; override; + procedure ClearCurrException; + function GetRootGC: TGC; + function GetDestructorAddress: Pointer; virtual; abstract; + function NeedAllocAll: Boolean; virtual; + function GetRootProg: TBaseRunner; + procedure CreateClassFactory; + procedure CreateGlobalJSObjects; + procedure Deallocate; + procedure Allocate(InitCodeSize, InitDataSize: Integer); + procedure AllocateSimple(InitCodeSize, InitDataSize: Integer); + procedure RegisterDefinitions(SymbolTable: TBaseSymbolTable); + procedure ForceMappingEvents; + procedure ForceMapping(SymbolTable: TBaseSymbolTable; + Reassign: Boolean); + procedure MapGlobal; + procedure MapLocal; + function HasAvailUnit(const FullName: String): Boolean; virtual; + function LookUpAvailClass(const FullName: String): TClass; virtual; + function LookUpAvailAddress(const FullName: String; + OverCount: Integer): Pointer; virtual; +{$IFDEF DRTTI} + function LookUpAvailMethod(const FullName: String; + OverCount: Integer): TRTTIMethod; +{$ENDIF} + procedure RegisterMember(LevelId: Integer; const Name: String; + Address: Pointer); + function RegisterNamespace(LevelId: Integer; const Name: String): Integer; + function RegisterClassType(LevelId: Integer; C: TClass): Integer; +{$IFNDEF PAXARM_DEVICE} + procedure SetEntryPoint(EntryPoint: TPaxInvoke); virtual; abstract; + procedure ResetEntryPoint(EntryPoint: TPaxInvoke); virtual; abstract; +{$ENDIF} + procedure SaveToStream(S: TStream); virtual; abstract; + procedure LoadFromStream(S: TStream); virtual; abstract; + procedure SaveToBuff(var Buff); + procedure LoadFromBuff(var Buff); + procedure SaveToFile(const Path: String); + procedure LoadFromFile(const Path: String); + procedure RebindEvents(AnInstance: TObject); virtual; + procedure LoadDFMStream(Instance: TObject; S: TStream; + const OnFindMethod: TFindMethodEvent = nil; const OnError: TReaderError = nil); + procedure LoadDFMFile(Instance: TObject; const FileName: String; + const OnFindMethod: TFindMethodEvent = nil; const OnError: TReaderError = nil); + function CallFunc(const FullName: String; + This: Pointer; + const ParamList: array of OleVariant; + OverCount: Integer = 0): OleVariant; virtual; abstract; + function CallByteCode(InitN: Integer; + This: Pointer; + R_AX, R_CX, R_DX, R_8, R_9: IntPax; + StackPtr: Pointer; + ResultPtr: Pointer; + var FT: Integer): Integer; virtual; + procedure Run; virtual; abstract; + procedure RunExtended; + procedure Pause; virtual; abstract; + procedure DiscardPause; virtual; abstract; + procedure RemovePause; virtual; abstract; + procedure ResetRun; virtual; abstract; + function IsPaused: Boolean; virtual; abstract; + function GetCallStackCount: Integer; virtual; abstract; + function GetCallStackItem(I: Integer): Integer; virtual; abstract; + function GetCallStackLineNumber(I: Integer): Integer; virtual; abstract; + function GetCallStackModuleName(I: Integer): String; virtual; abstract; + function GetCallStackModuleIndex(I: Integer): Integer; virtual; abstract; + function GetCurrentSub: TMapRec; + function GetCurrentFunctionFullName: String; + procedure GetCurrentLocalVars(result: TStrings); + procedure GetCurrentParams(result: TStrings); + + function Valid: Boolean; virtual; + function GetIsRootProg: Boolean; + procedure RunInitialization; virtual; + procedure RunFinalization; virtual; + procedure DiscardDebugMode; virtual; abstract; + procedure RaiseError(const Message: string; params: array of Const); + procedure SetGlobalSym(AGlobalSym: Pointer); virtual; + function RegisterClass(C: TClass; + const FullName: String; + Offset: Integer = -1): TClassRec; + function RegisterClassEx(C: TClass; + const FullName: String; + Offset: Integer; ClassIndex: Integer): TClassRec; + procedure AssignEventHandlerRunner(MethodAddress: Pointer; + Instance: TObject); virtual; abstract; + procedure Reset; virtual; + function CreateScriptObject(const ScriptClassName: String; + const ParamList: array of const): TObject; virtual; abstract; + procedure DestroyScriptObject(var X: TObject); + function GetImageSize: Integer; + function GetImageDataPtr: Integer; + procedure CopyRootEvents; + function GetResultPtr: Pointer; + function GetByteCodeLine: Integer; virtual; + procedure SetByteCodeLine(N: Integer); + function GetSourceLine: Integer; + function GetModuleName: String; + function GetModuleIndex: Integer; + function GetParamAddress(Offset: Integer): Pointer; overload; virtual; abstract; + function GetLocalAddress(Offset: Integer): Pointer; overload; virtual; abstract; + function GetParamAddress(StackFrameNumber, Offset: Integer): Pointer; overload; virtual; abstract; + function GetLocalAddress(StackFrameNumber, Offset: Integer): Pointer; overload; virtual; abstract; + procedure WrapMethodAddress(var Address: Pointer); + function WrapGlobalAddress(var Address: Pointer): Integer; + function GetAddress(Handle: Integer): Pointer; overload; + function GetAddress(const FullName: String; var MR: TMapRec): Pointer; overload; + function GetFieldAddress(X: TObject; const FieldName: String): Pointer; + function LoadAddressEx(const FileName, ProcName: String; + RunInit: Boolean; + OverCount: Integer; + var MR: TMapRec; + var DestProg: Pointer): Pointer; virtual; + function GetAddressEx(const FullName: String; OverCount: Integer; + var MR: TMapRec): Pointer; + function GetAddressExtended(const FullName: String; var MR: TMapRec): Pointer; overload; + function GetAddressExtended(const FullName: String; OverCount: Integer; var MR: TMapRec): Pointer; overload; + procedure SetAddress(Offset: Integer; P: Pointer); + function SetHostAddress(const FullName: String; Address: Pointer): Boolean; + procedure CopyRootBreakpoints(const UnitName: String); + procedure InitMessageList; + procedure CreateMapOffsets; + function GetOffset(Shift: Integer): Integer; + procedure SetupInterfaces(P: Pointer); + function GetTypeInfo(const FullTypeName: String): PTypeInfo; + function GetCallConv(const FullName: String): Integer; + function GetRetSize(const FullName: String): Integer; + function FileExists(const FileName: String; out FullPath: String): Boolean; + procedure UnloadDlls; + procedure UnloadPCU(const FullPath: String); + procedure LoadPCU(const FileName: String; + var DestProg: Pointer); + function AddBreakpoint(const ModuleName: String; + SourceLineNumber: Integer): TBreakpoint; + function AddTempBreakpoint(const ModuleName: String; + SourceLineNumber: Integer): TBreakpoint; + function RemoveBreakpoint(const ModuleName: String; + SourceLineNumber: Integer): Boolean; overload; + function RemoveBreakpoint(const ModuleName: String): Boolean; overload; + function HasBreakpoint(const ModuleName: String; + SourceLineNumber: Integer): Boolean; + procedure RemoveAllBreakpoints; + function IsExecutableLine(const ModuleName: String; + SourceLineNumber: Integer): Boolean; + procedure SaveState(S: TStream); virtual; + procedure LoadState(S: TStream); virtual; + function GetInterfaceToObjectOffset(JumpN: Integer): Integer; virtual; + function GetReturnFinalTypeId(InitSubN: Integer): Integer; virtual; + + property ClassList: TClassList read fClassList; + property ResultPtr: Pointer read GetResultPtr; + property DataPtr: PBytes read GetDataPtr; + property DataSize: Integer read fDataSize write fDataSize; + property CodePtr: PBytes read GetCodePtr; + property IsRootProg: Boolean read GetIsRootProg; + property RootSearchPathList: TStringList read GetRootSearchPathList; + property RunMode: Integer read GetRunMode write SetRunMode; + property IsRunning: Boolean read GetIsRunning write SetIsRunning; + property CodeSize: Integer read fCodeSize write fCodeSize; + property ProgramSize: Integer read GetProgramSize; + property RootIsEvent: Boolean read GetIsEvent write SetIsEvent; + property CurrException: Exception read fCurrException write fCurrException; + property RootInitCallStackCount: Integer read GetInitCallStackCount write SetInitCallStackCount; + property CurrN: Integer read GetByteCodeLine; + property CurrS: Integer read GetSourceLine; + property RootGC: TGC read GetRootGC; + property RootOwner: TObject read GetRootOwner; + property RootExceptionIsAvailableForHostApplication: Boolean read + GetExceptionIsAvailableForHostApplication write + SetExceptionIsAvailableForHostApplication; + property ProcessingExceptBlock: Boolean read GetProcessingExceptBlock + write SetProcessingExceptBlock; + property HasError: Boolean read GetHasError write SetHasError; + property InitializationProcessed: Boolean read fInitializationProcessed; + end; + + TBaseRunnerClass = class of TBaseRunner; + +type + TCreate_JSObjects = procedure(Prog: Pointer; R: TJS_Record); + TEmitProc = procedure (kernel, prog: Pointer; context: Pointer = nil); + TRegisterProc = procedure (st: TBaseSymbolTable); + TAssignRunnerLib = procedure; +var + CrtJSObjects: TCreate_JSObjects = nil; + CurrProg: TBaseRunner = nil; + AssignRunnerLibProc: TAssignRunnerLib = nil; + DefaultRunnerClass: TBaseRunnerClass; + RegisterSEH: TRegisterProc = nil; + dmp_procedure: procedure (sprog: Pointer = nil) = nil; + dump_all_procedure: procedure(path: String; kernel, prog, sprog: Pointer); + + Address_Exit: Pointer = nil; + Address_CondRaise: Pointer = nil; + Address_LoadSeg: Pointer = nil; + Address_CreateObject: Pointer = nil; + Address_DestroyObject: Pointer = nil; + Address_TryOn: Pointer = nil; + Address_TryOff: Pointer = nil; + Address_Raise: Pointer = nil; + Address_Pause: Pointer = nil; + Address_InitSub: Pointer = nil; + Address_EndSub: Pointer = nil; + Address_SetEventProp: Pointer = nil; + Address_SetEventProp2: Pointer = nil; + +procedure dmp(sprog: Pointer = nil); +procedure Dump_All(path: String; kernel, prog, sprog: Pointer); + +var CurrRunner: TBaseRunner; + +implementation + +procedure dmp(sprog: Pointer = nil); +begin + if Assigned(dmp_procedure) then + dmp_procedure(sprog); +end; + +procedure Dump_All(path: String; kernel, prog, sprog: Pointer); +begin + if Assigned(dump_all_procedure) then + dump_all_procedure(path, kernel, prog, sprog); +end; + +constructor TBaseRunner.Create; +begin + inherited; + + FindAvailTypes; + + GlobalSym := GlobalSymbolTable; + + fClassList := TClassList.Create; + fSearchPathList := TStringList.Create; + HostMapTable := TMapTable.Create; + ScriptMapTable := TMapTable.Create; + ProgClassFactory := TPaxClassFactory.Create; + MessageList := TMessageList.Create; + ExportList := TExportList.Create; + ProgTypeInfoList := TPaxTypeInfoList.Create; + OffsetList := TOffsetList.Create; + RuntimeModuleList := TRuntimeModuleList.Create(Self); + DllList := TStringList.Create; + ProgList := TProgList.Create(Self); + LocalSymbolTable := TProgSymbolTable.Create(GlobalSym); +{$IFDEF ARC} + ContextList := TList.Create; +{$ELSE} + ContextList := TList.Create; +{$ENDIF} + fGC := TGC.Create; + + Data := nil; + fDataSize := 0; + fExceptionIsAvailableForHostApplication := true; + + ByteCodeInterfaceSetupList := TIntegerList.Create; +end; + +destructor TBaseRunner.Destroy; +begin + FreeAndNil(fClassList); + FreeAndNil(fSearchPathList); + FreeAndNil(HostMapTable); + FreeAndNil(ScriptMapTable); + if ProgClassFactory <> nil then + FreeAndNil(ProgClassFactory); + FreeAndNil(MessageList); + FreeAndNil(ExportList); + FreeAndNil(ProgTypeInfoList); + FreeAndNil(OffsetList); + FreeAndNil(RuntimeModuleList); + FreeAndNil(DllList); + if ProgList <> nil then + FreeAndNil(ProgList); + FreeAndNil(LocalSymbolTable); + FreeAndNil(ContextList); + FreeAndNil(fGC); + FreeAndNil(ByteCodeInterfaceSetupList); + inherited; +end; + +procedure TBaseRunner.Reset; +begin + fClassList.Clear; + HostMapTable.Clear; + ScriptMapTable.Clear; + ProgClassFactory.Clear; + MessageList.Clear; + ExportList.Clear; + ProgTypeInfoList.Clear; + OffsetList.Clear; + LocalSymbolTable.Reset; + ContextList.Clear; + if ProgList <> nil then + ProgList.Clear; + fGC.Clear; + ByteCodeInterfaceSetupList.Clear; + + fInitializationProcessed := false; +end; + +function TBaseRunner.RegisterClass(C: TClass; + const FullName: String; + Offset: Integer = -1): TClassRec; +var + P: Pointer; + I: Integer; + S: String; +begin + if (Offset = -1) or (Offset = 0) then + begin + S := C.ClassName; + for I:=0 to fClassList.Count - 1 do + if StrEql(fClassList.Names[I], S) then + begin + Offset := fClassList[I].Offset; + break; + end; + if Offset = -1 then + RaiseError(errCannotRegisterClass, [S]); + end; + + P := ShiftPointer(DataPtr, Offset); + Pointer(P^) := C; + + result := fClassList.AddClass(C, FullName, true, Offset); + + for I:=0 to result.PropInfos.Count - 1 do + begin + P := ShiftPointer(P, SizeOf(Pointer)); + Pointer(P^) := result.PropInfos[I]; + end; +end; + +function TBaseRunner.RegisterClassEx(C: TClass; + const FullName: String; + Offset: Integer; ClassIndex: Integer): TClassRec; +var + P: Pointer; + I: Integer; +begin + P := ShiftPointer(DataPtr, Offset); + Pointer(P^) := C; + + result := fClassList.AddClassEx(C, FullName, true, Offset, ClassIndex); + + for I:=0 to result.PropInfos.Count - 1 do + begin + P := ShiftPointer(P, SizeOf(Pointer)); + Pointer(P^) := result.PropInfos[I]; + end; +end; + +procedure TBaseRunner.RaiseError(const Message: string; params: array of Const); +begin + raise Exception.Create(Format(Message, params)); +end; + +function TBaseRunner.GetDataPtr: PBytes; +begin + result := Data; +end; + +procedure TBaseRunner.InitMessageList; +var + I: Integer; + R: TMessageRec; + MR: TMapRec; +begin + for I := 0 to MessageList.Count - 1 do + begin + R := MessageList[I]; + R.Address := GetAddress(R.FullName, MR); + R.Class_Name := ExtractClassName(R.FullName); + R.Class_Name := ExtractName(R.Class_Name); + end; + + for I := 0 to ProgClassFactory.Count - 1 do + begin + VmtDynamicTableSlot(ProgClassFactory[I].VMTPtr)^ := + MessageList.CreateDmtTable(ExtractName(ProgClassFactory[I].FullClassName), + ProgClassFactory[I].DmtTableSize); + end; + for I := 0 to ProgList.Count - 1 do + TBaseRunner(ProgList[I].Prog).InitMessageList; +end; + +procedure TBaseRunner.CreateMapOffsets; +begin + HostMapTable.CreateOffsets(OffsetList, true); + ScriptMapTable.CreateOffsets(OffsetList, false); +end; + +function TBaseRunner.GetOffset(Shift: Integer): Integer; +begin + if OffsetList.Count > 0 then + begin + + if Shift <= 0 then + begin + result := Shift; + Exit; + end; + + result := OffsetList.GetOffset(Shift); + end + else + result := Shift; +end; + +function TBaseRunner.GetInterfaceToObjectOffset(JumpN: Integer): Integer; +begin + result := 0; +end; + +function TBaseRunner.GetReturnFinalTypeId(InitSubN: Integer): Integer; +begin + result := 0; +end; + +procedure TBaseRunner.SetupInterfaces(P: Pointer); +var + I, J, K, Index: Integer; + ClassRec: TClassRec; + IntfRec: TIntfRec; + IntfMethodRec: TIntfMethodRec; + A: Pointer; +begin + ByteCodeInterfaceSetupList.Clear; + + if P = nil then + begin + for I := 0 to ClassList.Count - 1 do + begin + ClassRec := ClassList[I]; + for J := 0 to ClassRec.IntfList.Count - 1 do + begin + IntfRec := ClassRec.IntfList[J]; + for K := 0 to IntfRec.IntfMethods.Count - 1 do + begin + IntfMethodRec := IntfRec.IntfMethods[K]; + A := Pointer(IntfMethodRec.MethodOffset); + + Index := 0; + if not NativeAddress(A) then + begin + WrapGlobalAddress(A); + case K of + 0: + begin + Index := ByteCodeInterfaceSetupList.Count; + ByteCodeInterfaceSetupList.Add(IntfMethodRec.MethodOffset); + end; + 1: A := GetFakeAddRefAddress(Index); + 2: A := GetFakeReleaseAddress(Index); + end; + end; + + IntfMethodRec.MethodOffset := IntPax(A); + end; + end; + end; + end; + + ClassList.SetupInterfaces(P); +end; + +function TBaseRunner.GetTypeInfo(const FullTypeName: String): PTypeInfo; +var + R: TTypeInfoContainer; +begin + R := ProgTypeInfoList.LookupFullName(FullTypeName); + if R = nil then + result := nil + else + result := R.TypeInfoPtr; +end; + +function TBaseRunner.GetCallConv(const FullName: String): Integer; +var + MapRec: TMapRec; +begin + result := ccREGISTER; + MapRec := ScriptMapTable.Lookup(FullName); + + if MapRec <> nil then + if MapRec.Kind in KindSUBS then + begin + result := MapRec.SubDesc.CallConv; + Exit; + end; + + MapRec := HostMapTable.Lookup(FullName); + if MapRec <> nil then + if MapRec.Kind in KindSUBS then + result := MapRec.SubDesc.CallConv; +end; + +function TBaseRunner.GetRetSize(const FullName: String): Integer; +var + MapRec: TMapRec; +begin + result := 0; + MapRec := ScriptMapTable.Lookup(FullName); + + if MapRec <> nil then + if MapRec.Kind in KindSUBS then + begin + result := MapRec.SubDesc.RetSize; + Exit; + end; + + MapRec := HostMapTable.Lookup(FullName); + if MapRec <> nil then + if MapRec.Kind in KindSUBS then + result := MapRec.SubDesc.RetSize; +end; + +procedure TBaseRunner.SaveToBuff(var Buff); +var + P: Pointer; + S: TMemoryStream; +begin + P := @Buff; + S := TMemoryStream.Create; + try + SaveToStream(S); + S.Position := 0; + S.Read(P^, S.Size); + finally + FreeAndNil(S); + end; +end; + +procedure TBaseRunner.LoadFromBuff(var Buff); +var + P: Pointer; + temp: TMemoryStream; + SZ: Integer; +begin + P := @Buff; + temp := TMemoryStream.Create; + try + temp.Write(P^, SizeOf(Integer)); + SZ := LongInt(P^); + temp.Position := 0; + temp.Write(P^, SZ); + temp.Position := 0; + LoadFromStream(temp); + finally + FreeAndNil(temp); + end; +end; + +procedure TBaseRunner.SaveToFile(const Path: String); +var + M: TMemoryStream; +begin + M := TMemoryStream.Create; + try + SaveToStream(M); + M.Position := 0; + M.SaveToFile(Path); + finally + FreeAndNil(M); + end; +end; + +procedure TBaseRunner.LoadFromFile(const Path: String); +var + M: TMemoryStream; +begin + M := TMemoryStream.Create; + try + M.LoadFromFile(Path); + M.Position := 0; + LoadFromStream(M); + finally + FreeAndNil(M); + end; +end; + +procedure TBaseRunner.RunInitialization; +begin + fInitializationProcessed := true; + + CurrRunner := Self; + if fGC = RootGC then + fGC.Clear; +end; + +procedure TBaseRunner.RunFinalization; +begin + +end; + +function TBaseRunner.GetRootProg: TBaseRunner; +begin + result := Self; + while result.PCUOwner <> nil do + result := result.PCUOwner; +end; + +function TBaseRunner.GetIsRootProg: Boolean; +begin + result := PCUOwner = nil; +end; + +function TBaseRunner.GetRootSearchPathList: TStringList; +begin + result := GetRootProg.fSearchPathList; +end; + +function TBaseRunner.FileExists(const FileName: String; out FullPath: String): Boolean; +var + I: Integer; + S: String; +begin + if SysUtils.FileExists(FileName) then + begin + result := true; + FullPath := FileName; + end + else + begin + result := false; + + for I := 0 to RootSearchPathList.Count - 1 do + begin + S := RootSearchPathList[I] + FileName; + if SysUtils.FileExists(S) then + begin + result := true; + FullPath := S; + Exit; + end; + end; + + FullPath := FileName; + end; +end; + +procedure TBaseRunner.CopyRootBreakpoints(const UnitName: String); +var + RP: TBaseRunner; + I, L: Integer; +begin + RP := GetRootProg; + for I := 0 to RP.RuntimeModuleList.BreakpointList.Count - 1 do + if StrEql(UnitName, RP.RuntimeModuleList.BreakpointList[I].ModuleName) then + begin + L := RP.RuntimeModuleList.BreakpointList[I].SourceLine; + AddBreakpoint(UnitName, L); + end; +end; + +procedure TBaseRunner.UnloadDlls; +var + H: Cardinal; +begin + while DllList.Count > 0 do + begin + H := Cardinal(DllList.Objects[0]); + FreeLibrary(H); + DllList.Delete(0); + end; +end; + +procedure TBaseRunner.CopyRootEvents; +var + RP: TBaseRunner; +begin + RP := GetRootProg; + if Self <> RP then + begin + Owner := RP.Owner; + + OnException := RP.OnException; + OnUnhandledException := RP.OnUnhandledException; + OnPause := RP.OnPause; + OnPauseUpdated := RP.OnPauseUpdated; + OnHalt := RP.OnHalt; + OnLoadProc := RP.OnLoadProc; + OnCreateObject := RP.OnCreateObject; + OnAfterObjectCreation := RP.OnAfterObjectCreation; + OnDestroyObject := RP.OnDestroyObject; + OnAfterObjectDestruction := RP.OnAfterObjectDestruction; + + OnMapTableNamespace := RP.OnMapTableNamespace; + OnMapTableVarAddress := RP.OnMapTableVarAddress; + OnMapTableProcAddress := RP.OnMapTableProcAddress; + OnMapTableClassRef := RP.OnMapTableClassRef; + OnLoadPCU := RP.OnLoadPCU; + + OnPrint := RP.OnPrint; + OnCustomExceptionHelper := RP.OnCustomExceptionHelper; + + OnBeginProcNotifyEvent := RP.OnBeginProcNotifyEvent; + OnEndProcNotifyEvent := RP.OnEndProcNotifyEvent; + end; +end; + +procedure TBaseRunner.SetAddress(Offset: Integer; P: Pointer); +begin + Move(P, DataPtr^[Offset], SizeOf(Pointer)); +end; + +function TBaseRunner.SetHostAddress(const FullName: String; Address: Pointer): Boolean; +var + MR: TMapRec; + P: Pointer; + I: Integer; +begin + result := false; + MR := HostMapTable.Lookup(FullName); + if MR <> nil then + if MR.Kind in KindSUBS + [KindVAR] then + begin + P := ShiftPointer(DataPtr, MR.Offset); + Pointer(P^) := Address; + result := true; + end; + for I:=0 to ProgList.Count - 1 do + TBaseRunner(ProgList[I].Prog).SetHostAddress(FullName, Address); +end; + +procedure TBaseRunner.UnloadPCU(const FullPath: String); +var + I: Integer; +begin + ProgList.RemoveProg(FullPath); + for I := 0 to ProgList.Count - 1 do + TBaseRunner(ProgList[I].Prog).UnloadPCU(FullPath); +end; + +procedure TBaseRunner.LoadPCU(const FileName: String; + var DestProg: Pointer); +var + P: TBaseRunner; + UnitName, FullPath: String; + ProgRec: TProgRec; + InputStream: TStream; + C: TBaseRunnerClass; +begin + DestProg := nil; + + FullPath := ''; + UnitName := ExtractFullOwner(FileName); + + InputStream := nil; + + if Assigned(OnLoadPCU) then + OnLoadPCU(Owner, UnitName, InputStream); + + if InputStream = nil then + if not FileExists(FileName, FullPath) then + begin + RaiseError(errFileNotFound, [FileName]); + end; + + C := TBaseRunnerClass(ClassType); + P := C.Create; + + P.PCUOwner := Self; + if InputStream <> nil then + P.LoadFromStream(InputStream) + else + P.LoadFromFile(FullPath); + ProgRec := TProgRec.Create; + ProgRec.FullPath := FullPath; + ProgRec.Prog := P; + ProgList.Add(ProgRec); + P.CopyRootEvents; +end; + +function TBaseRunner.GetAddressExtended(const FullName: String; + var MR: TMapRec): Pointer; +var + I: Integer; +begin + result := GetAddress(FullName, MR); + if result <> nil then + Exit; + for I := 0 to ProgList.Count - 1 do + begin + result := TBaseRunner(ProgList[I].Prog).GetAddressExtended(FullName, MR); + if result <> nil then + Exit; + end; +end; + +function TBaseRunner.GetAddressExtended(const FullName: String; OverCount: Integer; + var MR: TMapRec): Pointer; +var + I: Integer; +begin + result := GetAddressEx(FullName, OverCount, MR); + if result <> nil then + Exit; + for I := 0 to ProgList.Count - 1 do + begin + result := TBaseRunner(ProgList[I].Prog).GetAddressExtended(FullName, OverCount, MR); + if result <> nil then + Exit; + end; +end; + +function TBaseRunner.AddBreakpoint(const ModuleName: String; + SourceLineNumber: Integer): TBreakpoint; +var + I: Integer; + P: TBaseRunner; +begin + for I := 0 to ProgList.Count - 1 do + begin + P := TBaseRunner(ProgList[I].Prog); + result := P.AddBreakpoint(ModuleName, SourceLineNumber); + if result <> nil then + Exit; + end; + + result := RunTimeModuleList.AddBreakpoint(ModuleName, SourceLineNumber); +end; + +function TBaseRunner.AddTempBreakpoint(const ModuleName: String; + SourceLineNumber: Integer): TBreakpoint; +var + I: Integer; + P: TBaseRunner; +begin + for I := 0 to ProgList.Count - 1 do + begin + P := TBaseRunner(ProgList[I].Prog); + result := P.AddTempBreakpoint(ModuleName, SourceLineNumber); + if result <> nil then + Exit; + end; + + result := RunTimeModuleList.AddTempBreakpoint(ModuleName, SourceLineNumber); +end; + +function TBaseRunner.RemoveBreakpoint(const ModuleName: String; + SourceLineNumber: Integer): Boolean; +var + I: Integer; + P: TBaseRunner; +begin + for I := 0 to ProgList.Count - 1 do + begin + P := TBaseRunner(ProgList[I].Prog); + result := P.RemoveBreakpoint(ModuleName, SourceLineNumber); + if result then + Exit; + end; + + result := RunTimeModuleList.RemoveBreakpoint(ModuleName, SourceLineNumber); +end; + +function TBaseRunner.RemoveBreakpoint(const ModuleName: String): Boolean; +var + I: Integer; + P: TBaseRunner; +begin + for I := 0 to ProgList.Count - 1 do + begin + P := TBaseRunner(ProgList[I].Prog); + result := P.RemoveBreakpoint(ModuleName); + if result then + Exit; + end; + + result := RunTimeModuleList.RemoveBreakpoint(ModuleName); +end; + +function TBaseRunner.HasBreakpoint(const ModuleName: String; + SourceLineNumber: Integer): Boolean; +var + I: Integer; + P: TBaseRunner; +begin + for I := 0 to ProgList.Count - 1 do + begin + P := TBaseRunner(ProgList[I].Prog); + result := P.HasBreakpoint(ModuleName, SourceLineNumber); + if result then + Exit; + end; + + result := RunTimeModuleList.HasBreakpoint(ModuleName, SourceLineNumber); +end; + +procedure TBaseRunner.RemoveAllBreakpoints; +var + I: Integer; + P: TBaseRunner; +begin + for I := 0 to ProgList.Count - 1 do + begin + P := TBaseRunner(ProgList[I].Prog); + P.RemoveAllBreakpoints; + end; + + RunTimeModuleList.RemoveAllBreakpoints; +end; + +function TBaseRunner.IsExecutableLine(const ModuleName: String; + SourceLineNumber: Integer): Boolean; +var + I: Integer; + P: TBaseRunner; +begin + for I := 0 to ProgList.Count - 1 do + begin + P := TBaseRunner(ProgList[I].Prog); + result := P.IsExecutableLine(ModuleName, SourceLineNumber); + if result then + Exit; + end; + + result := RunTimeModuleList.IsExecutableLine(ModuleName, SourceLineNumber); +end; + +function TBaseRunner.GetByteCodeLine: Integer; +var + P: Pointer; +begin + P := ShiftPointer(Data, H_ByteCodePtr); + result := LongInt(P^); +end; + +procedure TBaseRunner.SetByteCodeLine(N: Integer); +var + P: Pointer; +begin + P := ShiftPointer(Data, H_ByteCodePtr); + LongInt(P^) := N; +end; + +function TBaseRunner.GetSourceLine: Integer; +begin + result := GetByteCodeLine; + + if result = - 1 then + Exit; + + result := RunTimeModuleList.GetSourceLine(result); +end; + +function TBaseRunner.GetModuleName: String; +var + ByteCodeLine: Integer; +begin + result := ''; + ByteCodeLine := GetByteCodeLine; + + if ByteCodeLine = - 1 then + Exit; + + result := RunTimeModuleList.GetModuleName(ByteCodeLine); +end; + +function TBaseRunner.GetModuleIndex: Integer; +var + ByteCodeLine: Integer; +begin + result := -1; + ByteCodeLine := GetByteCodeLine; + + if ByteCodeLine = - 1 then + Exit; + + result := RunTimeModuleList.GetModuleIndex(ByteCodeLine); +end; + +function TBaseRunner.GetRunMode: Integer; +begin + result := GetRootProg.fRunMode; +end; + +procedure TBaseRunner.SetRunMode(value: Integer); +begin + GetRootProg.fRunMode := value; +end; + +function TBaseRunner.GetCodePtr: PBytes; +begin + result := nil; +end; + +function TBaseRunner.Valid: Boolean; +begin + result := (Data <> nil); +end; + +function TBaseRunner.GetResultPtr: Pointer; +begin + result := Data; +end; + +procedure TBaseRunner.CreateGlobalJSObjects; +begin + if Assigned(CrtJSObjects) then + CrtJSObjects(Self, JS_Record); +end; + +function TBaseRunner.GetImageSize: Integer; +var + S: TMemoryStream; +begin + S := TMemoryStream.Create; + try + SaveToStream(S); + result := S.Size; + finally + FreeAndNil(S); + end; +end; + +function TBaseRunner.GetImageDataPtr: Integer; +begin + if fImageDataPtr = 0 then + GetImageSize; + result := fImageDataPtr; +end; + +procedure TBaseRunner.DestroyScriptObject(var X: TObject); +begin + FreeAndNil(X); +end; + +function TBaseRunner.GetFieldAddress(X: TObject; const FieldName: String): Pointer; +var + MapRec: TMapRec; + MapFieldRec: TMapFieldRec; +begin + if IsPaxObject(X) then + begin + MapRec := ScriptMapTable.LookupType(X.ClassName); + if MapRec <> nil then + begin + if MapRec.FieldList = nil then + RaiseError(errInternalError, []); + MapFieldRec := MapRec.FieldList.Lookup(FieldName); + if MapFieldRec = nil then + result := nil + else + result := ShiftPointer(X, MapFieldRec.FieldOffset); + end + else + result := X.FieldAddress(FieldName); + end + else + result := X.FieldAddress(FieldName); +end; + +function TBaseRunner.GetIsEvent: Boolean; +begin + result := GetRootProg.fIsEvent; +end; + +procedure TBaseRunner.SetIsEvent(value: Boolean); +begin + GetRootProg.fIsEvent := value; +end; + +function TBaseRunner.GetCurrentSub: TMapRec; +var + N: Integer; +begin + N := GetByteCodeLine; + result := ScriptMapTable.GetSub(N); +end; + +function TBaseRunner.GetCurrentFunctionFullName: String; +var + MR: TMapRec; +begin + result := ''; + MR := GetCurrentSub; + if MR = nil then + Exit; + result := MR.FullName; +end; + +procedure TBaseRunner.GetCurrentLocalVars(result: TStrings); +var + MR: TMapRec; + I: Integer; +begin + MR := GetCurrentSub; + if MR = nil then + Exit; + if MR.SubDesc.LocalVarList.Count = 0 then + Exit; + for I := 0 to MR.SubDesc.LocalVarList.Count - 1 do + result.Add(MR.SubDesc.LocalVarList[I].LocalVarName); +end; + +procedure TBaseRunner.GetCurrentParams(result: TStrings); +var + MR: TMapRec; + I: Integer; +begin + MR := GetCurrentSub; + if MR = nil then + Exit; + if MR.SubDesc.ParamList.Count = 0 then + Exit; + for I := 0 to MR.SubDesc.ParamList.Count - 1 do + result.Add(MR.SubDesc.ParamList[I].ParamName); +end; + +procedure TBaseRunner.SetGlobalSym(AGlobalSym: Pointer); +begin + GlobalSym := TBaseSymbolTable(AGlobalSym); + if LocalSymbolTable <> nil then + FreeAndNil(LocalSymbolTable); + LocalSymbolTable := TProgSymbolTable.Create(GlobalSym); +end; + +procedure TBaseRunner.RegisterMember(LevelId: Integer; const Name: String; + Address: Pointer); +begin + if LocalSymbolTable.Card = -1 then + LocalSymbolTable.Reset; + LocalSymbolTable.RegisterMember(LevelId, Name, Address); +end; + +function TBaseRunner.RegisterNamespace(LevelId: Integer; const Name: String): Integer; +begin + if LocalSymbolTable.Card = -1 then + LocalSymbolTable.Reset; + result := LocalSymbolTable.RegisterNamespace(LevelId, Name); +end; + +function TBaseRunner.RegisterClassType(LevelId: Integer; C: TClass): Integer; +begin + if LocalSymbolTable.Card = -1 then + LocalSymbolTable.Reset; + result := LocalSymbolTable.RegisterClassType(LevelId, C); +end; + +procedure TBaseRunner.MapGlobal; +begin + ForceMapping(GlobalSym, true); +end; + +procedure TBaseRunner.MapLocal; +begin + ForceMapping(LocalSymbolTable, true); +end; + +procedure TBaseRunner.ForceMapping(SymbolTable: TBaseSymbolTable; + Reassign: Boolean); +var + IsGlobal: Boolean; + I, J: Integer; + MapRec: TMapRec; + FullName: String; + P: Pointer; + ClsRef: TClass; +begin + IsGlobal := SymbolTable = GlobalSym; + + if HostMapTable.Count > 0 then + begin + for I:=0 to HostMapTable.Count - 1 do + begin + MapRec := HostMapTable[I]; + + if MapRec.Global <> IsGlobal then + continue; + + if MapRec.TypedConst then + continue; + + FullName := MapRec.FullName; + + J := SymbolTable.LookupFullNameEx(FullName, true, MapRec.SubDesc.OverCount); + if J > 0 then + begin + if MapRec.Kind = KindVAR then + begin + P := SymbolTable[J].Address; + if P <> nil then + begin + if Reassign then + begin + if Assigned(OnMapTableVarAddress) then + OnMapTableVarAddress(Owner, + FullName, + MapRec.Global, + P); + + if P = nil then + RaiseError(errUnresolvedAddress, [FullName]); + + SymbolTable[J].Address := P; + end; + + SetAddress(MapRec.Offset, P); + end + else + begin + P := nil; + if Assigned(OnMapTableVarAddress) then + OnMapTableVarAddress(Owner, + FullName, + MapRec.Global, + P); + if P = nil then + RaiseError(errUnresolvedAddress, [FullName]); + SetAddress(MapRec.Offset, P); + end; + end + else if MapRec.Kind in KindSUBS then + begin + P := nil; + if Assigned(OnMapTableProcAddress) then + OnMapTableProcAddress(Owner, + FullName, + MapRec.SubDesc.OverCount, + MapRec.Global, + P) + else + P := SymbolTable[J].Address; + + if P = nil then + P := LookupAvailAddress(FullName, MapRec.SubDesc.OverCount); + if P = nil then + RaiseError(errUnresolvedAddress, [FullName]); + SetAddress(MapRec.Offset, P); + end + else if MapRec.Kind = KindTYPE then + begin + ClsRef := nil; + if Assigned(OnMapTableClassRef) then + OnMapTableClassRef(Owner, + FullName, + MapRec.Global, + ClsRef) + else + ClsRef := TClass(IntPax(SymbolTable[J + 1].Value)); + if ClsRef = nil then + ClsRef := LookupAvailClass(FullName); + if ClsRef = nil then + RaiseError(errUnresolvedClassReference, [FullName]) + else + RegisterClassEx(ClsRef, MapRec.FullName, MapRec.Offset, MapRec.ClassIndex); + end; + end + else + begin + if MapRec.Kind = KindVAR then + begin + if Assigned(OnMapTableVarAddress) then + begin + P := nil; + OnMapTableVarAddress(Owner, + FullName, + MapRec.Global, + P); + if P = nil then + RaiseError(errUnresolvedAddress, [FullName]); + SetAddress(MapRec.Offset, P); + end + else + RaiseError(errHostMemberIsNotDefined, [FullName]); + end + else if MapRec.Kind in KindSUBS then + begin + P := nil; + if Assigned(OnMapTableProcAddress) then + OnMapTableProcAddress(Owner, + FullName, + MapRec.SubDesc.OverCount, + MapRec.Global, + P); + if P = nil then + P := LookupAvailAddress(FullName, MapRec.SubDesc.OverCount); + if P = nil then + RaiseError(errUnresolvedAddress, [FullName]); + SetAddress(MapRec.Offset, P); + end + else if MapRec.Kind = KindTYPE then + begin + ClsRef := nil; + if Assigned(OnMapTableClassRef) then + OnMapTableClassRef(Owner, + FullName, + MapRec.Global, + ClsRef); + if ClsRef = nil then + ClsRef := LookupAvailClass(FullName); + if ClsRef = nil then + begin + RaiseError(errUnresolvedClassReference, [FullName]); + end + else + RegisterClassEx(ClsRef, MapRec.FullName, MapRec.Offset, MapRec.ClassIndex); + end; + end; + end; + end; + + for I:=0 to ProgList.Count - 1 do + TBaseRunner(ProgList[I].Prog).ForceMapping(SymbolTable, Reassign); +end; + +procedure TBaseRunner.ForceMappingEvents; +var + I, J, TypeId: Integer; + MapRec: TMapRec; + P: Pointer; + ClsRef: TClass; + L: TIntegerList; + C: TClass; + ClassRec: TClassRec; +begin + if not Assigned(OnMapTableProcAddress) then + Exit; + if not Assigned(OnMapTableClassRef) then + Exit; + + L := TIntegerList.Create; + + try + + for I:=0 to HostMapTable.Count - 1 do + begin + MapRec := HostMapTable[I]; + if MapRec.Kind in KindSUBS then + begin + P := nil; + OnMapTableProcAddress(Owner, + MapRec.FullName, + MapRec.SubDesc.OverCount, + MapRec.Global, + P); + if P = nil then + P := LookupAvailAddress(MapRec.FullName, MapRec.SubDesc.OverCount); + if P <> nil then + begin + J := GlobalSym.LookupFullNameEx(MapRec.FullName, true, MapRec.SubDesc.OverCount); + if J > 0 then + begin + GlobalSym[J].Address := P; + if GlobalSym[J].IsVirtual then + if GlobalSym[J].MethodIndex = 0 then + L.Add(J); + end; + SetAddress(MapRec.Offset, P); + end; + end + else if MapRec.Kind = KindTYPE then + begin + ClsRef := nil; + if Assigned(OnMapTableClassRef) then + OnMapTableClassRef(Owner, + MapRec.FullName, + MapRec.Global, + ClsRef); + if ClsRef = nil then + ClsRef := LookupAvailClass(MapRec.FullName); + if ClsRef <> nil then + begin + J := GlobalSym.LookupFullName(MapRec.FullName, true); + if J > 0 then + begin + GlobalSym[J].PClass := ClsRef; + GlobalSym[J+1].Value := LongInt(ClsRef); + end; + ClassRec := ClassList.Lookup(MapRec.FullName); + if ClassRec <> nil then + ClassRec.PClass := ClsRef; + end; + end; + end; + + for I:=0 to L.Count - 1 do + begin + J := L[I]; + TypeId := GlobalSym[J].Level; + C := GlobalSym[TypeId].PClass; + if C = nil then + RaiseError(errInternalErrorMethodIndex, []); + GlobalSym[J].MethodIndex := VirtualMethodIndex(C, + GlobalSym[J].Address) + 1; + end; + finally + FreeAndNil(L); + end; +end; + +procedure TBaseRunner.RegisterDefinitions(SymbolTable: TBaseSymbolTable); +var + I, I1, Offset: Integer; + J: IntPax; + R, R1: TSymbolRec; + FullName: String; + IsGlobal: Boolean; + MapRec: TMapRec; +begin + IsGlobal := SymbolTable = GlobalSym; + + TOffsetList_Sort(OffsetList); + + if UseMapping then + begin + if HostMapTable.Count > 0 then + begin + for I:=0 to HostMapTable.Count - 1 do + begin + MapRec := HostMapTable[I]; + if MapRec.Kind <> kindNAMESPACE then + continue; + if MapRec.Global <> IsGlobal then + continue; + FullName := MapRec.FullName; + J := SymbolTable.LookupFullName(FullName, true); + if J = 0 then + if Assigned(OnMapTableNamespace) then + OnMapTableNamespace(Owner, + FullName, + MapRec.Global); + end; + end; + end; + + if IsGlobal then + I1 := 1 + else + I1 := FirstLocalId + 1; + + for I:=I1 to SymbolTable.Card do + begin + R := SymbolTable[I]; + + if R.Address <> nil then + begin + Offset := GetOffset(R.Shift); + if Offset = -1 then + continue; + + SetAddress(Offset, R.Address); + end + else if R.ClassIndex <> -1 then + begin + R1 := SymbolTable[I + 1]; // cls ref + J := R1.Value; + if J = 0 then + ClassList.Add(R.FullName, R. Host) + else + begin + Offset := GetOffset(R1.Shift); + if Offset = -1 then + continue; + + RegisterClass(TClass(J), R.FullName, Offset); + end; + end; + end; +end; + +function TBaseRunner._VirtualAlloc(Address: Pointer; + Size, flAllocType, flProtect: Cardinal): Pointer; +begin + result := AllocMem(Size); +end; + +procedure TBaseRunner._VirtualFree(Address: Pointer; Size: Cardinal); +begin + FreeMem(Address, Size); +end; + +procedure TBaseRunner.Deallocate; +begin + if Data <> nil then + begin + FreeMem(Data, DataSize); + Data := nil; + end; + + if Prog <> nil then + begin +{$IFDEF PAXARM} + FreeMem(Prog, fCodeSize); +{$ELSE} + _VirtualFree(Prog, fCodeSize); +{$ENDIF} + Prog := nil; + end; + + ClearCurrException; + fPrevException := nil; + + UnProtect; + InitializationIsProcessed := false; +end; + +procedure TBaseRunner.Allocate(InitCodeSize, InitDataSize: Integer); +begin + Deallocate; + + DataSize := InitDataSize; + Data := AllocMem(DataSize); + + fCodeSize := InitCodeSize; +{$IFDEF PAXARM} + Prog := AllocMem(fCodeSize); +{$ELSE} + Prog := _VirtualAlloc(nil, fCodeSize, MEM_COMMIT, PAGE_EXECUTE_READWRITE); +{$ENDIF} + + Protect; + + SetAddress(H_SelfPtr, Self); + SetAddress(H_ExceptionPtr, @ fCurrException); + + RegisterDefinitions(GlobalSym); +end; + +procedure TBaseRunner.AllocateSimple(InitCodeSize, InitDataSize: Integer); +begin + Deallocate; + + DataSize := InitDataSize; + Data := AllocMem(DataSize); + + fCodeSize := InitCodeSize; +{$IFDEF PAXARM} + Prog := AllocMem(fCodeSize); +{$ELSE} + Prog := _VirtualAlloc(nil, fCodeSize, MEM_COMMIT, PAGE_EXECUTE_READWRITE); +{$ENDIF} +end; + +procedure TBaseRunner.Protect; +begin +end; + +procedure TBaseRunner.UnProtect; +begin +end; + +procedure TBaseRunner.ClearCurrException; +begin + if Assigned(CurrException) then + begin +{$IFNDEF ARC} + CurrException.Free; +{$ENDIF} + CurrException := nil; + end; +end; + +procedure TBaseRunner.RunExtended; +begin +{$IFDEF PAXARM} + if IsPaused then +{$ELSE} + if IsPaused or (EPoint <> nil) then +{$ENDIF} + begin + RunInternal; + Exit; + end + else + begin + RunInitialization; + if Assigned(CrtJSObjects) then + CrtJSObjects(Self, Self.JS_Record); + end; + if IsPaused then + Exit; + RunExceptInitialization; + if not IsPaused then + begin + if not SuspendFinalization then + begin + InitializationIsProcessed := false; + ProgList.RunFinalization; + end; + end; +end; + +procedure TBaseRunner.RunInternal; +begin + Run; +end; + +procedure TBaseRunner.RunExceptInitialization; +begin + Run; +end; + +function TBaseRunner.FireAddressEvent(MR: TMapRec): Pointer; +begin + result := @TBaseRunner.FireAddressEvent; +end; + +function TBaseRunner.GetAddress(Handle: Integer): Pointer; +begin + if Handle < 0 then + begin + result := ShiftPointer(CodePtr, - Handle); + end + else + begin + result := ShiftPointer(DataPtr, GetOffset(Handle)); + end; +end; + +function TBaseRunner.GetAddress(const FullName: String; var MR: TMapRec): Pointer; +begin + result := nil; + MR := ScriptMapTable.Lookup(FullName); + if MR <> nil then + begin + case MR.Kind of + KindVAR, kindTYPE: result := ShiftPointer(DataPtr, MR.Offset); + KindSUB, KindCONSTRUCTOR, KindDESTRUCTOR: + begin + if MR.IsExternal then + result := nil + else + begin + result := ShiftPointer(CodePtr, MR.Offset); + end; + end; + end; + Exit; + end; + + MR := HostMapTable.Lookup(FullName); + if MR <> nil then + if MR.Kind in KindSUBS + [KindVAR] then + begin + result := ShiftPointer(DataPtr, MR.Offset); + result := Pointer(result^); + end; +end; + +function TBaseRunner.GetAddressEx(const FullName: String; OverCount: Integer; + var MR: TMapRec): Pointer; +begin + result := nil; + + if OverCount = 0 then + begin + result := GetAddress(FullName, MR); + Exit; + end; + + MR := ScriptMapTable.LookupEx(FullName, OverCount); + if MR <> nil then + begin + case MR.Kind of + KindVAR, kindTYPE: result := ShiftPointer(DataPtr, MR.Offset); + KindSUB, KindCONSTRUCTOR, KindDESTRUCTOR: + begin + if MR.IsExternal then + result := nil + else + begin + result := ShiftPointer(CodePtr, MR.Offset); + end; + end; + end; + Exit; + end; + + MR := HostMapTable.LookupEx(FullName, OverCount); + if MR <> nil then + if MR.Kind in KindSUBS + [KindVAR] then + begin + result := ShiftPointer(DataPtr, MR.Offset); + result := Pointer(result^); + Exit; + end; +end; + +function TBaseRunner.LoadAddressEx(const FileName, ProcName: String; + RunInit: Boolean; + OverCount: Integer; + var MR: TMapRec; + var DestProg: Pointer): Pointer; +begin + result := GetRootProg.ProgList.LoadAddress(FileName, ProcName, + RunInit, + OverCount, + MR, + DestProg); +end; + +procedure TBaseRunner.CreateClassFactory; +var + I: Integer; + ClassRec: TClassRec; + C: TClass; + S: String; + P: Pointer; + PaxInfo: PPaxInfo; + MR: TMapRec; +begin + ProgClassFactory.Clear; + + for I:=0 to ClassList.Count - 1 do + begin + ClassRec := ClassList[I]; + if ClassRec.Host then + continue; + S := ExtractName(ClassRec.FullName); + C := ProgClassFactory.CreatePaxClass(ClassRec.FullName, ClassRec.InstSize, TObject, + GetDestructorAddress); + ClassRec.PClass := C; + + P := GetAddress(ClassRec.FullName, MR); + if P <> nil then + Pointer(P^) := C; + + PaxInfo := GetPaxInfo(ClassRec.PClass); + if PaxInfo = nil then + RaiseError(errInternalError, []); + PaxInfo^.Prog := Self; + PaxInfo^.ClassIndex := I; + end; + + ProgClassFactory.SetupParents(Self, ClassList); + ProgClassFactory.AddInheritedMethods; + ProgClassFactory.AddOverridenMethods(Self, ScriptMapTable); + ProgClassFactory.SetupStdVirtuals(ClassList, CodePtr); + + ProgTypeInfoList.AddToProgram(Self); +end; + +function TBaseRunner.GetInitCallStackCount: Integer; +begin + result := GetRootProg.fInitCallStackCount; +end; + +procedure TBaseRunner.SetInitCallStackCount(value: Integer); +begin + GetRootProg.fInitCallStackCount := value; +end; + +function TBaseRunner.GetIsRunning: Boolean; +begin + result := fIsRunning; +end; + +procedure TBaseRunner.SetIsRunning(value: Boolean); +begin + fIsRunning := value; +end; + +function TBaseRunner.NeedAllocAll: Boolean; +begin + result := false; +end; + +function TBaseRunner.GetRootGC: TGC; +begin + result := GetRootProg.fGC; +end; + +function TBaseRunner.GetRootOwner: TObject; +begin + result := GetRootProg.Owner; +end; + +procedure TBaseRunner.SaveState(S: TStream); +begin +end; + +procedure TBaseRunner.LoadState(S: TStream); +begin +end; + +function TBaseRunner.GetProcessingExceptBlock: Boolean; +begin + result := fProcessingExceptBlock; +end; + +procedure TBaseRunner.SetProcessingExceptBlock(value: Boolean); +begin + fProcessingExceptBlock := value; +end; + +function TBaseRunner.GetExceptionIsAvailableForHostApplication: Boolean; +begin + result := GetRootProg.fExceptionIsAvailableForHostApplication; +end; + +procedure TBaseRunner.SetExceptionIsAvailableForHostApplication(value: Boolean); +begin + GetRootProg.fExceptionIsAvailableForHostApplication := value; +end; + +function TBaseRunner.GetHasError: Boolean; +begin + result := GetRootProg.fHasError; +end; + +procedure TBaseRunner.SetHasError(value: Boolean); +begin + GetRootProg.fHasError := value; +end; + +{$IFDEF FPC} +type + TStreamOriginalFormat = (sofUnknown, sofBinary, sofText, sofUTF8Text); + +function TestStreamFormat(Stream: TStream): TStreamOriginalFormat; +var + Pos: Integer; + Signature: Integer; +begin + Pos := Stream.Position; + Signature := 0; + Stream.Read(Signature, SizeOf(Signature)); + Stream.Position := Pos; + if (Byte(Signature) = $FF) or (Signature = Integer(FilerSignature)) or (Signature = 0) then + Result := sofBinary + // text format may begin with "object", "inherited", or whitespace + else if AnsiChar(Signature) in ['o','O','i','I',' ',#13,#11,#9] then + Result := sofText + else if (Signature and $00FFFFFF) = $00BFBBEF then + Result := sofUTF8Text + else + Result := sofUnknown; +end; +{$ENDIF} + +procedure TBaseRunner.LoadDFMFile(Instance: TObject; const FileName: String; const OnFindMethod: TFindMethodEvent = nil; const OnError: TReaderError = nil); +var + fs: TFileStream; + ms: TMemoryStream; + Reader: TReader; + ptd: PTypeData; + P: Pointer; + MR: TMapRec; +begin + fs := TFileStream.Create(FileName, fmOpenRead); + ms := TMemoryStream.Create; + try + Reader := nil; + case TestStreamFormat(fs) of +{$IFDEF UNIC} + sofText, + sofUTF8Text: +{$ELSE} + sofText: +{$ENDIF} + begin + ObjectTextToBinary(fs, ms); + ms.Position := 0; + Reader := TReader.Create(ms, 4096 * 10); + end; + sofBinary: + begin + fs.ReadResHeader; + Reader := TReader.Create(fs, 4096 * 10); + end; + else + RaiseError(errUnknownStreamFormat, []); + end; + + try + gInstance := Instance; + Reader.OnFindMethod := OnFindMethod; + Reader.OnError := OnError; + + Reader.ReadRootComponent(Instance as TComponent); + finally + FreeAndNil(Reader); + end; + finally + FreeAndNil(ms); + FreeAndNil(fs); + end; + if not ModeSEH then + RebindEvents(Instance); + ptd := GetTypeData(Instance.ClassInfo); + P := GetAddress(StringFromPShortString(@ptd^.UnitName) + '.' + + Copy(Instance.ClassName, 2, Length(Instance.ClassName)), MR); + if P <> nil then + Pointer(P^) := Instance; +end; + +procedure TBaseRunner.LoadDFMStream(Instance: TObject; S: TStream; const OnFindMethod: TFindMethodEvent = nil; const OnError: TReaderError = nil); +var + ms: TMemoryStream; + Reader: TReader; + ptd: PTypeData; + P: Pointer; + MR: TMapRec; +begin + ms := TMemoryStream.Create; + try + Reader := nil; + case TestStreamFormat(s) of +{$IFDEF UNIC} + sofText, + sofUTF8Text: +{$ELSE} + sofText: +{$ENDIF} + begin + ObjectTextToBinary(s, ms); + ms.Position := 0; + Reader := TReader.Create(ms, 4096 * 10); + end; + sofBinary: + begin + s.ReadResHeader; + Reader := TReader.Create(s, 4096 * 10); + end; + else + RaiseError(errUnknownStreamFormat, []); + end; + + try + gInstance := Instance; + Reader.OnFindMethod := OnFindMethod; + Reader.OnError := OnError; + + Reader.ReadRootComponent(Instance as TComponent); + finally + FreeAndNil(Reader); + end; + finally + FreeAndNil(ms); + end; + if not ModeSEH then + RebindEvents(Instance); + ptd := GetTypeData(Instance.ClassInfo); + P := GetAddress(StringFromPShortString(@ptd^.UnitName) + '.' + + Copy(Instance.ClassName, 2, Length(Instance.ClassName)), MR); + if P <> nil then + Pointer(P^) := Instance; +end; + +procedure TBaseRunner.RebindEvents(AnInstance: TObject); +begin + +end; + +function TBaseRunner.CallByteCode(InitN: Integer; + This: Pointer; + R_AX, R_CX, R_DX, R_8, R_9: IntPax; + StackPtr: Pointer; + ResultPtr: Pointer; var FT: Integer): Integer; +begin + result := 0; +end; + +procedure TBaseRunner.WrapMethodAddress(var Address: Pointer); +var + I, N: integer; +begin + if Address <> nil then + if not NativeAddress(Address) then + begin + N := IntPax(Address); + I := ClassList.GetByteCodeMethodEntryIndex(N); + if I = -1 then + RaiseError(errInternalError, []); + Address := GetFakeHandlerAddress(I); + end; +end; + +function TBaseRunner.WrapGlobalAddress(var Address: Pointer): Integer; +var + I, N: integer; +begin + result := -1; + if Address <> nil then + if not NativeAddress(Address) then + begin + N := IntPax(Address); + for I := 0 to System.Length(ByteCodeGlobalEntryList) - 1 do + if ByteCodeGlobalEntryList[I] = N then + begin + Address := GetFakeGlobalAddress(I); + result := I; + Exit; + end; + RaiseError(errInternalError, []); + end; +end; + +{$ifdef DRTTI} +function TBaseRunner.HasAvailUnit(const FullName: String): Boolean; +begin + result := AvailUnitList.IndexOf(FullName) >= 0; +end; + +function TBaseRunner.LookUpAvailClass(const FullName: String): TClass; +var + t: TRTTIType; + I: Integer; +begin + result := nil; + I := AvailTypeList.IndexOf(FullName); + if I >= 0 then + begin + t := TRTTIType(AvailTypeList.Objects[I]); + if t is TRttiInstanceType then + result := (t as TRttiInstanceType).MetaclassType; + end; +end; + +function TBaseRunner.LookUpAvailAddress(const FullName: String; + OverCount: Integer): Pointer; +var + m: TRTTIMethod; +begin + m := LookUpAvailMethod(FullName, OverCount); + if m = nil then + result := nil + else + result := m.CodeAddress; +end; + +function TBaseRunner.LookUpAvailMethod(const FullName: String; + OverCount: Integer): TRTTIMethod; +var + t: TRTTIType; + I, K: Integer; + TypeName, MethName: String; +{$IFDEF DPULSAR} + IndexedProp: TRTTIIndexedProperty; +{$ENDIF} + m: TRTTIMethod; +begin + result := nil; + TypeName := ExtractFullOwner(FullName); + MethName := ExtractName(FullName); + I := AvailTypeList.IndexOf(TypeName); + if I = -1 then + I := AvailTypeList.IndexOf('System.' + TypeName); + if I = -1 then + Exit; + + t := TRTTIType(AvailTypeList.Objects[I]); + + K := 0; + for m in t.GetDeclaredMethods do + if CheckMethod(t, m) then + if StrEql(m.Name, MethName) then + begin + if OverCount = 0 then + begin + result := m; + Exit; + end + else + begin + Inc(K); + if K = OverCount then + Exit; + end; + end; + +{$IFDEF DPULSAR} + for IndexedProp in t.GetDeclaredIndexedProperties do + if CheckIndexedProperty(t, IndexedProp) then + begin + if IndexedProp.IsReadable then + begin + result := IndexedProp.ReadMethod; + if StrEql(result.Name, MethName) then + Exit; + end; + if IndexedProp.IsWritable then + begin + result := IndexedProp.WriteMethod; + if StrEql(result.Name, MethName) then + Exit; + end; + end; +{$ENDIF} + + result := nil; +end; + +{$else} + +function TBaseRunner.HasAvailUnit(const FullName: String): Boolean; +begin + result := false; +end; + +function TBaseRunner.LookUpAvailClass(const FullName: String): TClass; +begin + result := nil; +end; + +function TBaseRunner.LookUpAvailAddress(const FullName: String; + OverCount: Integer): Pointer; +begin + result := nil; +end; +{$endif} + +end. diff --git a/Sources/PAXCOMP_BASESYMBOL_TABLE.pas b/Sources/PAXCOMP_BASESYMBOL_TABLE.pas new file mode 100644 index 0000000..d4ddafb --- /dev/null +++ b/Sources/PAXCOMP_BASESYMBOL_TABLE.pas @@ -0,0 +1,11906 @@ +//////////////////////////////////////////////////////////////////////////// +// PaxCompiler +// Site: http://www.paxcompiler.com +// Author: Alexander Baranovsky (paxscript@gmail.com) +// ======================================================================== +// Copyright (c) Alexander Baranovsky, 2006-2014. All rights reserved. +// Code Version: 4.2 +// ======================================================================== +// Unit: PAXCOMP_BASESYMBOL_TABLE.pas +// ======================================================================== +//////////////////////////////////////////////////////////////////////////// + +{$I PaxCompiler.def} +{$O-} +{$R-} +unit PAXCOMP_BASESYMBOL_TABLE; +interface +uses {$I uses.def} + TypInfo, + SysUtils, + Classes, + PAXCOMP_CONSTANTS, + PAXCOMP_TYPES, + PAXCOMP_SYS, + PAXCOMP_VAROBJECT, + PAXCOMP_HEADER_PARSER, + PAXCOMP_MAP, + PAXCOMP_CLASSFACT, + PAXCOMP_SYMBOL_REC; +type + TSaveStateRec = class + public + Id: Integer; + LastShiftValue: Integer; + LastClassIndex: Integer; + LastSubId: Integer; + LastVarId: Integer; + end; + + TSaveStateList = class(TTypedList) + private + function GetRecord(I: Integer): TSaveStateRec; + public + function Add: TSaveStateRec; + function Find(Id: Integer): TSaveStateRec; + property Records[I: Integer]: TSaveStateRec read GetRecord; + end; + + TBaseSymbolTable = class + private + LastCard: Integer; + SaveStateList: TSaveStateList; + function GetSizeOfPointer: Integer; + function GetSizeOfTMethod: Integer; + procedure CheckMemory(p: Pointer; Size: Cardinal); + procedure UpdateSomeTypeList(const TypeName: String; TypeId: Integer); + procedure CheckError(B: Boolean); + procedure BindDummyType(TypeId, OriginTypeId: Integer); + protected + function GetRecord(I: Integer): TSymbolRec; virtual; + public + st_tag: Integer; +{$IFDEF ARC} + A: TList; +{$ELSE} + A: TList; +{$ENDIF} + Card: Integer; + + ResultId: Integer; + TrueId: Integer; + FalseId: Integer; + NilId: Integer; + EventNilId: Integer; + EmptySetId: Integer; + EmptyStringId: Integer; + CurrExceptionObjectId: Integer; + + VarObjects: TVarObjectList; + HashArray: THashArray; + HeaderParser: THeaderParser; + GuidList: TGuidList; + SomeTypeList: TSomeTypeList; + ExternList: TExternList; + + LastShiftValue: Integer; + LastClassIndex: Integer; + LastSubId: Integer; + LastVarId: Integer; + + SR0: TSymbolRec; + + TypeHelpers: TAssocIntegers; + + constructor Create(NeedHash: Boolean = True); + destructor Destroy; override; + function AddRecord: TSymbolRec; virtual; + procedure RemoveLastRecord; + procedure Reset; virtual; + procedure Discard(OldCard: Integer); + procedure SetPAX64(value: Boolean); + function LookupAnonymousInterface(ClassId: Integer): Integer; + function LookupAnonymousMethod(IntfId: Integer): Integer; +{$IFDEF PAXARM} + function AddPWideCharConst(const Value: String): TSymbolRec; +{$ELSE} + function AddPWideCharConst(const Value: WideString): TSymbolRec; + function AddAnsiCharConst(Value: AnsiChar): TSymbolRec; + function AddPAnsiCharConst(const Value: AnsiString): TSymbolRec; + function AddShortStringConst(const Value: String): TSymbolRec; +{$ENDIF} + function AddWideCharConst(Value: Integer): TSymbolRec; + function AddByteConst(Value: Byte): TSymbolRec; + function AddWordConst(Value: Word): TSymbolRec; + function AddIntegerConst(Value: Integer): TSymbolRec; + function AddInt64Const(Value: Int64): TSymbolRec; + function AddUInt64Const(Value: UInt64): TSymbolRec; + function AddCardinalConst(Value: Cardinal): TSymbolRec; + function AddSmallIntConst(Value: SmallInt): TSymbolRec; + function AddShortIntConst(Value: ShortInt): TSymbolRec; + function AddEnumConst(TypeId, Value: Integer): TSymbolRec; + function AddPointerConst(TypeId: Integer; Value: Pointer): TSymbolRec; + function AddRecordConst(TypeId: Integer; const Value: Variant): TSymbolRec; + function AddArrayConst(TypeId: Integer; const Value: Variant): TSymbolRec; + function AddSetConst(TypeId: Integer; const Value: Variant): TSymbolRec; + function AddClassConst(TypeId: Integer; Value: TObject): TSymbolRec; + function AddClassRefConst(TypeId: Integer; Value: TClass): TSymbolRec; + function AddSetVar(TypeId: Integer; const Value: Variant): TSymbolRec; + function AddDoubleConst(Value: Double): TSymbolRec; + function AddCurrencyConst(Value: Double): TSymbolRec; + function AddSingleConst(Value: Single): TSymbolRec; + function AddExtendedConst(Value: Extended): TSymbolRec; + function AddBooleanConst(Value: Boolean): TSymbolRec; + function AddByteBoolConst(Value: ByteBool): TSymbolRec; + function AddWordBoolConst(Value: WordBool): TSymbolRec; + function AddLongBoolConst(Value: LongBool): TSymbolRec; + function AddVariantConst(const Value: Variant): TSymbolRec; + function AddOleVariantConst(const Value: OleVariant): TSymbolRec; + + function AddTMethodVar(Level: Integer): TSymbolRec; + function AddCurrencyVar(Level: Integer): TSymbolRec; + function AddDoubleVar(Level: Integer): TSymbolRec; + function AddSingleVar(Level: Integer): TSymbolRec; + function AddExtendedVar(Level: Integer): TSymbolRec; + function AddInt64Var(Level: Integer): TSymbolRec; + function AddUInt64Var(Level: Integer): TSymbolRec; +{$IFNDEF PAXARM} + function AddStringVar(Level: Integer): TSymbolRec; + function AddWideStringVar(Level: Integer): TSymbolRec; + function AddShortStringVar(Level, TypeId: Integer): TSymbolRec; + function AddAnsiCharVar(Level: Integer): TSymbolRec; +{$ENDIF} + function AddInterfaceVar(Level: Integer): TSymbolRec; + function AddClassVar(Level: Integer): TSymbolRec; + function AddUnicStringVar(Level: Integer): TSymbolRec; + function AddVariantVar(Level: Integer): TSymbolRec; + function AddOleVariantVar(Level: Integer): TSymbolRec; + function AddDynarrayVar(Level, TypeId: Integer): TSymbolRec; + function AddRecordVar(Level, TypeId: Integer): TSymbolRec; + function AddBooleanVar(Level: Integer): TSymbolRec; + function AddByteBoolVar(Level: Integer): TSymbolRec; + function AddWordBoolVar(Level: Integer): TSymbolRec; + function AddLongBoolVar(Level: Integer): TSymbolRec; + function AddIntegerVar(Level: Integer): TSymbolRec; + function AddCardinalVar(Level: Integer): TSymbolRec; + function AddSmallIntVar(Level: Integer): TSymbolRec; + function AddShortIntVar(Level: Integer): TSymbolRec; + function AddByteVar(Level: Integer): TSymbolRec; + function AddWordVar(Level: Integer): TSymbolRec; + function AddPointerVar(Level: Integer): TSymbolRec; + function AddWideCharVar(Level: Integer): TSymbolRec; + function AddVoidVar(Level: Integer; SZ: Integer): TSymbolRec; + function AddClassRefVar(Level: Integer): TSymbolRec; + function AddLabel: TSymbolRec; + function AddPointerType(SourceTypeId: Integer): TSymbolRec; + + function AddEndOfClassHeader(ClassId: Integer): TSymbolRec; + + function GetDataSize(UpperId: Integer = MaxInt - 1): Integer; + + function LookUpEnumItem(const S: String; EnumTypeId: Integer; + UpCase: Boolean): Integer; + + function LookupNamespace(const S: String; + i_Level: Integer; UpCase: Boolean): Integer; + function LookupFullName(const S: String; UpCase: Boolean): Integer; + function LookupFullNameEx(const S: String; UpCase: Boolean; + OverCount: Integer): Integer; + function LookUpType(const S: String; i_Level: Integer; UpCase: Boolean): Integer; overload; + function LookUpType(const S: String; UpCase: Boolean): Integer; overload; + function LookupParentMethodBase(SubId: Integer; + UpCase: Boolean; + var BestId: Integer): Integer; + function LookupParentMethod(SubId: Integer; + UpCase: Boolean; HasMethodIndex: Boolean = false): Integer; + function LookupParentMethods(SubId: Integer; Upcase: Boolean): TIntegerList; + + function LookupParentConstructor(SubId: Integer): Integer; + function LookupParentConstructors(SubId: Integer): TIntegerList; + + function LookUpTypeEx(const S: String; + i_Level: Integer; UpCase: Boolean; LowBound: Integer): Integer; + function LookUp(const S: String; Level: Integer; UpCase: Boolean; + UpperBoundId: Integer = MaxInt; recursive: Boolean = true): Integer; + function LookUpEx(var HelperTypeId: Integer; const S: String; Level: Integer; UpCase: Boolean; + UpperBoundId: Integer = MaxInt; recursive: Boolean = true): Integer; + function LookUps(const S: String; LevelStack: TIntegerStack; + UpCase: Boolean; + UpperBoundId: Integer = MaxInt; + Recursive: Boolean = true): Integer; + function LookUpsEx(const S: String; LevelStack: TIntegerStack; var LevelId: Integer; UpCase: Boolean): Integer; + function LookUpsExcept(const S: String; LevelStack: TIntegerStack; LevelId: Integer; UpCase: Boolean): Integer; + function LookUpAll(const S: String; Level: Integer; UpCase: Boolean): TIntegerList; + function LookUpSub(const S: String; Level: Integer; UpCase: Boolean): TIntegerList; + function LookUpSubs(const S: String; Level: Integer; UsingList: TIntegerList; UpCase: Boolean): TIntegerList; + function LookupAnotherDeclaration(Id: Integer; UpCase: Boolean; + var BestID: Integer): Integer; + function LookupForwardDeclaration(Id: Integer; UpCase: Boolean; + var BestID: Integer): Integer; + function LookupForwardDeclarations(Id: Integer; + UpCase: Boolean): TIntegerList; + function RegisterNamespace(LevelId: Integer; + const NamespaceName: String): Integer; + function RegisterArrayType(LevelId: Integer; + const TypeName: String; + RangeTypeId, ElemTypeId: Integer; + Align: Integer): Integer; + function RegisterDynamicArrayType(LevelId: Integer; + const TypeName: String; + ElemTypeId: Integer): Integer; + function RegisterOpenArrayType(LevelId: Integer; + const TypeName: String; + ElemTypeId: Integer): Integer; + function FindInterfaceTypeId(const GUID: TGUID): Integer; + function RegisterInterfaceType(LevelId: Integer; + const TypeName: String; + const GUID: TGUID): Integer; overload; + function RegisterInterfaceType(LevelId: Integer; + pti: PTypeInfo): Integer; overload; + procedure RegisterSupportedInterface(TypeId: Integer; + const SupportedInterfaceName: String; + const i_GUID: TGUID); overload; + procedure RegisterSupportedInterface(TypeId, + InterfaceTypeId: Integer); overload; + + function RegisterClassType(LevelId: Integer; + const TypeName: String; i_AncestorID: Integer): Integer; overload; + function RegisterClassType(LevelId: Integer; + C: TClass; + Reserved: Integer = 0): Integer; overload; + function RegisterClassTypeForImporter(LevelId: Integer; + C: TClass): Integer; overload; + function RegisterClassTypeForImporter(LevelId: Integer; + const TypeName: String): Integer; overload; + procedure RegisterClassTypeInfos(ClassId: Integer; + C: TClass); + function RegisterClassReferenceType(LevelId: Integer; + const TypeName: String; + OriginClassId: Integer): Integer; + function RegisterHelperType(LevelId: Integer; + const TypeName: String; + OriginTypeId: Integer): Integer; + function RegisterProperty(LevelId: Integer; const PropName: String; + PropTypeID, i_ReadId, i_WriteId: Integer; + i_IsDefault: Boolean): Integer; + function RegisterInterfaceProperty(LevelId: Integer; + const PropName: String; + PropTypeID, + ReadIndex, + WriteIndex: Integer): Integer; + function RegisterRecordType(LevelId: Integer; + const TypeName: String; + Align: Integer): Integer; + function RegisterRTTIType(LevelId: Integer; + pti: PTypeInfo): Integer; + function RegisterTypeAlias(LevelId:Integer; + const TypeName: String; + OriginTypeId: Integer; + const OriginTypeName: String = ''): Integer; overload; + function RegisterTypeAlias(LevelId:Integer; + const TypeName, OriginTypeName: String): Integer; overload; + function RegisterTypeAlias(LevelId:Integer; + const Declaration: String): Integer; overload; + function RegisterTypeField(LevelId: Integer; const FieldName: String; + FieldTypeID: Integer; + FieldOffset: Integer = -1; + ACompIndex: Integer = -1): Integer; + function RegisterTypeFieldEx(LevelId: Integer; + const Declaration: String; + FieldOffset: Integer = -1): Integer; + function RegisterVariantRecordTypeField(LevelId: Integer; + const Declaration: String; + VarCnt: Int64): Integer; overload; + function RegisterVariantRecordTypeField(LevelId: Integer; + const FieldName: String; + FieldTypeID: Integer; + VarCnt: Int64): Integer; overload; + + function RegisterSubrangeType(LevelId: Integer; + const TypeName: String; + TypeBaseId: Integer; + B1, B2: Integer): Integer; + + function RegisterEnumType(LevelId: Integer; + const TypeName: String; + TypeBaseId: Integer): Integer; + function RegisterEnumValue(EnumTypeId: Integer; + const FieldName: String; + const i_Value: Integer): Integer; + function RegisterPointerType(LevelId: Integer; + const TypeName: String; + OriginTypeId: Integer; + const OriginTypeName: String = ''): Integer; +{$IFNDEF PAXARM} + function RegisterShortStringType(LevelId: Integer; + const TypeName: String; + L: Integer): Integer; +{$ENDIF} + function RegisterSetType(LevelId: Integer; + const TypeName: String; + OriginTypeId: Integer): Integer; + + function CreateEmptySet: TSymbolRec; + + function RegisterProceduralType(LevelId: Integer; + const TypeName: String; + HSub: Integer): Integer; + function RegisterMethodReferenceType(LevelId: Integer; + const TypeName: String; + HSub: Integer): Integer; + function RegisterEventType(LevelId: Integer; + const TypeName: String; + HSub: Integer): Integer; + function RegisterVariable(LevelId: Integer; + const Declaration: String; Address: Pointer): Integer; overload; + function RegisterVariable(LevelId: Integer; const VarName: String; + VarTypeID: Integer; i_Address: Pointer): Integer; overload; + function RegisterObject(LevelId: Integer; + const ObjectName: String; + TypeId: Integer; + i_Address: Pointer): Integer; + function RegisterVirtualObject(LevelId: Integer; + const ObjectName: String): Integer; + function RegisterConstant(LevelId: Integer; + const Declaration: String): Integer; overload; + function RegisterConstant(LevelId: Integer; const i_Name: String; i_TypeID: Integer; + const i_Value: Variant): Integer; overload; + function RegisterConstant(LevelId: Integer; const i_Name: String; + const i_Value: Variant): Integer; overload; + function RegisterPointerConstant(LevelId: Integer; const i_Name: String; + const i_Value: Pointer): Integer; overload; + function RegisterExtendedConstant(LevelId: Integer; const i_Name: String; + const i_Value: Extended): Integer; overload; + function RegisterInt64Constant(LevelId: Integer; + const i_Name: String; const i_Value: Int64): Integer; + function RegisterRoutine(LevelId: Integer; + const SubName: String; ResultTypeID: Integer; + CallConvention: Integer; + i_Address: Pointer; + i_OverCount: Integer = 0; + i_IsDeprecated: Boolean = false): Integer; overload; + function RegisterRoutine(LevelId: Integer; + const SubName, ResultType: String; + CallConvention: Integer; + i_Address: Pointer; + i_OverCount: Integer = 0; + i_IsDeprecated: Boolean = false): Integer; overload; + function RegisterMethod(LevelId: Integer; + const SubName: String; ResultTypeID: Integer; + CallConvention: Integer; + i_Address: Pointer; + IsShared: Boolean = false; + i_CallMode: Integer = cmNONE; + i_MethodIndex: Integer = 0; + i_OverCount: Integer = 0; + i_IsAbstract: Boolean = false; + i_AbstractMethodCount: Integer = 0; + i_IsDeprecated: Boolean = false): Integer; overload; + function RegisterMethod(LevelId: Integer; + const SubName, ResultType: String; + CallConvention: Integer; + i_Address: Pointer; + IsShared: Boolean = false; + i_CallMode: Integer = cmNONE; + i_MethodIndex: Integer = 0; + i_OverCount: Integer = 0; + i_IsAbstract: Boolean = false; + i_AbstractMethodCount: Integer = 0; + i_IsDeprecated: Boolean = false): Integer; overload; + function RegisterConstructor(LevelId: Integer; + const SubName: String; + i_Address: Pointer; + IsShared: Boolean = false; + i_CallMode: Integer = cmNONE; + i_MethodIndex: Integer = 0; + i_OverCount: Integer = 0; + i_IsAbstract: Boolean = false; + i_AbstractMethodCount: Integer = 0; + i_IsDeprecated: Boolean = false): Integer; + function RegisterDestructor(LevelId: Integer; + const SubName: String; i_Address: Pointer; + i_CallMode: Integer = cmVIRTUAL): Integer; + function RegisterParameter(HSub: Integer; + const ParameterName: String; + ParamTypeID: Integer; + ParamMod: Integer = 0; + Optional: Boolean = false; + const DefaultValue: String = ''): Integer; overload; + function RegisterParameter(HSub: Integer; + const ParameterName: String; + const ParameterType: String; + ParamMod: Integer = 0; + Optional: Boolean = false; + const DefaultValue: String = ''): Integer; overload; + function RegisterParameter(HSub: Integer; ParamTypeID: Integer; + const DefaultValue: Variant; + InitByRef: Boolean = false; + ParameterName: String = ''; + Tag: Integer = 0): Integer; overload; + procedure RegisterRunnerParameter(HSub: Integer); + function RegisterHeader(LevelId: Integer; + const Header: String; Address: Pointer; + AMethodIndex: Integer = 0): Integer; + function RegisterFakeHeader(LevelId: Integer; + const Header: String; Address: Pointer): Integer; + procedure RegisterMember(LevelId: Integer; const MemberName: String; + i_Address: Pointer); + function RegisterTypeDeclaration(LevelId: Integer; + const Declaration: String): Integer; + function RegisterSpace(K: Integer): Integer; + + function RestorePositiveIndex(L: Integer): Integer; + function FindMaxMethodIndex(IntfId: Integer): Integer; + procedure SetAncestorEx(ClassId: Integer); + + function IsResultId(Id: Integer): Boolean; + function GetResultId(SubId: Integer): Integer; + function GetSelfId(SubId: Integer): Integer; + function GetParamId(SubId, ParamNumber: Integer): Integer; + function GetDL_Id(SubId: Integer): Integer; + function GetRBP_Id(SubId: Integer): Integer; + function GetRBX_Id(SubId: Integer): Integer; + function GetRDI_Id(SubId: Integer): Integer; + function GetSizeOfLocals(SubId: Integer): Integer; + function GetSizeOfLocalsEx(SubId: Integer): Integer; + function GetSubRSPSize(SubId: Integer): Integer; + function GetSizeOfSetType(SetTypeId: Integer): Integer; + function CheckSetTypes(T1, T2: Integer): Boolean; + function GetLowBoundRec(TypeID: Integer): TSymbolRec; + function GetHighBoundRec(TypeID: Integer): TSymbolRec; + procedure GetArrayTypeInfo(ArrayTypeId: Integer; var RangeTypeId: Integer; var ElemTypeId: Integer); +{$IFNDEF PAXARM} + function IsZeroBasedAnsiCharArray(Id: Integer): Boolean; +{$ENDIF} + function IsZeroBasedWideCharArray(Id: Integer): Boolean; + function GetTypeBase(TypeId: Integer): Integer; + function GetPatternSubId(ProcTypeID: Integer): Integer; + function EqualHeaders(SubId1, SubId2: Integer): Boolean; + function GetShiftsOfDynamicFields(ATypeId: Integer): TIntegerList; + function GetTypesOfDynamicFields(ATypeId: Integer): TIntegerList; + function HasDynamicFields(ATypeId: Integer): Boolean; + function TerminalTypeOf(TypeID: Integer): Integer; + function FindDefaultPropertyId(i_TypeId: Integer): Integer; + function FindConstructorId(i_TypeId: Integer): Integer; + function FindConstructorIdEx(i_TypeId: Integer): Integer; + function FindConstructorIds(i_TypeId: Integer): TIntegerList; + + function FindDestructorId(i_TypeId: Integer): Integer; + function FindDestructorIdEx(i_TypeId: Integer): Integer; + function Inherits(T1, T2: Integer): Boolean; + function Supports(T1, T2: Integer): Boolean; + + function GetFinalAddress(P: Pointer; StackFrameNumber: Integer; + Id: Integer): Pointer; + + function GetStrVal(Address: Pointer; + TypeId: Integer; + TypeMapRec: TTypeMapRec = nil; + BriefCls: Boolean = false): String; + + function GetVariantVal(Address: Pointer; + TypeId: Integer; + TypeMapRec: TTypeMapRec = nil): Variant; + + function GetValueAsString(P: Pointer; + StackFrameNumber: Integer; + Id: Integer; + TypeMapRec: TTypeMapRec = nil; + BriefCls: Boolean = false): String; virtual; + + procedure CheckVariantData (const V); + function GetVal(Address: Pointer; + TypeId: Integer): Variant; + function GetValue(P: Pointer; StackFrameNumber: Integer; + Id: Integer): Variant; + + procedure PutVal(Address: Pointer; + TypeId: Integer; const Value: Variant); + procedure PutValue(P: Pointer; StackFrameNumber: Integer; + Id: Integer; const Value: Variant); + + function GetLocalCount(SubId: Integer): Integer; + function GetLocalId(SubId, LocalVarNumber: Integer): Integer; + function IsLocalOf(Id, SubId: Integer): Boolean; + + function GetGlobalCount(NamespaceId: Integer): Integer; + function GetGlobalId(NamespaceId, GlobalVarNumber: Integer): Integer; + + function GetFieldCount(Id: Integer; TypeMapRec: TTypeMapRec = nil): Integer; + + function GetFieldDescriptorId(Id, + FieldNumber: Integer; + TypeMapRec: TTypeMapRec = nil): Integer; + + function GetFieldDescriptorIdByName(Id: Integer; const FieldName: String): Integer; + function GetFieldName(Id, FieldNumber: Integer): String; + function GetFieldAddress(P: Pointer; + StackFrameNumber, + Id, + FieldNumber: Integer; + TypeMapRec: TTypeMapRec = nil + ): Pointer; + function GetFieldValueAsString(P: Pointer; + StackFrameNumber: Integer; + Id: Integer; + FieldNumber: Integer; + TypeMapRec: TTypeMapRec = nil; + BriefCls: Boolean = false): String; + + function GetPublishedPropCount(Id: Integer): Integer; + function GetPublishedPropDescriptorId(Id, PropNumber: Integer): Integer; + function GetPublishedPropName(Id, PropNumber: Integer): String; + function GetPublishedPropValueAsString(P: Pointer; StackFrameNumber: Integer; + Id, PropNumber: Integer): String; + + function GetArrayItemAddress(P: Pointer; StackFrameNumber, Id, + Index: Integer): Pointer; + function GetArrayItemValueAsString(P: Pointer; StackFrameNumber: Integer; + Id, Index: Integer): String; + function GetDynArrayItemAddress(P: Pointer; + StackFrameNumber: Integer; + Id, Index: Integer): Pointer; + function GetDynArrayItemValueAsString(P: Pointer; StackFrameNumber: Integer; + Id, Index: Integer): String; + + function IsParam(SubId, Id: Integer): Boolean; + function IsVar(LevelId, Id: Integer): Boolean; + function IsConst(LevelId, Id: Integer): Boolean; + function IsType(LevelId, Id: Integer): Boolean; + function IsProcedure(LevelId, Id: Integer): Boolean; + function IsFunction(LevelId, Id: Integer): Boolean; + function IsConstructor(ClassId, Id: Integer): Boolean; + function IsDestructor(ClassId, Id: Integer): Boolean; + function IsTypeField(LevelId, Id: Integer): Boolean; + function IsEnumMember(LevelId, Id: Integer): Boolean; + function IsProperty(ClassId, Id: Integer): Boolean; + function IsNamespace(LevelId, Id: Integer): Boolean; + + function HasAbstractAncestor(ClassId: Integer): Boolean; +{$IFNDEF PAXARM} + function FindPAnsiCharConst(const S: String; LimitId: Integer): Integer; +{$ENDIF} + function FindPWideCharConst(const S: String; LimitId: Integer): Integer; + + function RegisterDummyType(LevelId: Integer; + const TypeName: String): Integer; + function RegisterSomeType(LevelId: Integer; + const TypeName: String): Integer; + + function GetAlignmentSize(TypeId, DefAlign: Integer): Integer; + procedure SetVisibility(ClassId: integer; + const MemberName: String; value: Integer); overload; + procedure SetVisibility(C: TClass; const MemberName: String; value: Integer); overload; + function FindClassTypeId(Cls: TClass): Integer; + function FindClassTypeIdByPti(Pti: PTypeInfo): Integer; + + procedure SaveNamespaceToStream(LevelId: Integer; S: TStream); overload; + procedure SaveNamespaceToStream(const NamespaceName: String; S: TStream); overload; + + procedure SaveNamespaceToFile(LevelId: Integer; const FileName: String); overload; + procedure SaveNamespaceToFile(const NamespaceName, FileName: String); overload; + + procedure LoadNamespaceFromStream(S: TStream); + procedure LoadNamespaceFromFile(const FileName: String); + + procedure ResolveExternList(CheckProc: TCheckProc; Data: Pointer); + procedure AddScriptFields(ClassId: Integer; FieldList: TMapFieldList); + + procedure ExtractNamespaces(const Level: Integer; L: TStrings); + + procedure ExtractMembers(const Id: Integer; L: TStrings; + Lang: TPaxLang = lngPascal; + SharedOnly: Boolean = false; + VisSet: TMemberVisibilitySet = [cvPublic, cvPublished]); + + procedure ExtractParameters(Id: Integer; L: TStrings; + Lang: TPaxLang = lngPascal; + SkipParameters: Integer = 0); + + procedure ExtractParametersEx(Id: Integer; + L: TStrings; + Upcase: Boolean; + SkipParameters: Integer = 0); + + function ValueStr(I: Integer): String; + procedure AddTypes(const TypeName: String; L: TStrings; + ErrorIndex: Integer; Upcase: Boolean); + procedure AddUndeclaredIdent(const IdentName: String; L: TStrings; + ErrorIndex: Integer; Upcase: Boolean); + + procedure CreateInterfaceMethodList(IntfId: Integer; + L: TIntegerList); overload; + procedure CreateInterfaceMethodList(ClassId, IntfId: Integer; + InterfaceMethodIds, + ClassMethodIds: TIntegerList); overload; + + procedure ProcessClassFactory(AClassFactory: Pointer; + AProg: Pointer); + procedure HideClass(C: TClass); + + function ImportFromTable(st: TBaseSymbolTable; + const FullName: String; + UpCase: Boolean; + DoRaiseError: Boolean = true): Integer; + + procedure LoadGlobalSymbolTableFromStream(Stream: TStream); + procedure LoadGlobalSymbolTableFromFile(const FileName: String); + procedure SaveGlobalSymbolTableToStream(Stream: TStream); + procedure SaveGlobalSymbolTableToFile(const FileName: String); + procedure SaveState; + procedure RestoreState(Id: Integer); + function GetOpenArrayHighId(Id: Integer): Integer; + function GetOuterThisId(TypeId: Integer): Integer; + function GetTypeParameters(Id: Integer): TIntegerList; + function ExtractEnumNames(EnumTypeId: Integer): TStringList; + function GetTypeHelpers(TypeId: Integer): TIntegerList; + + procedure RaiseError(const Message: string; params: array of const); + property Records[I: Integer]: TSymbolRec read GetRecord; default; + property SizeOfPointer: Integer read GetSizeOfPointer; + property SizeOfTMethod: Integer read GetSizeOfTMethod; + end; +var + RegisterDRTTIProperties: procedure (Level: Integer; + c: TClass; + s: TBaseSymbolTable) = nil; + // Added callback to get namespace of type. + GetNamespaceOfType: function (aSymbolTable: TBaseSymbolTable; aTypeInfo: PTypeInfo): Integer = nil; + + GlobalAlignment: Integer = 8; + + RaiseE: Boolean = true; + REG_OK: Boolean = true; + REG_ERROR: String; + DllDefined: Boolean = false; + + H_TByteSet: Integer = -1; + + GlobalCurrExceptionObjectId: Integer = -1; + + JS_JavaScriptNamespace: Integer = 1; + JS_GetPropertyId: Integer = 0; + JS_PutPropertyId: Integer = 0; + JS_GetArrPropertyId: Integer = 0; + JS_PutArrPropertyId: Integer = 0; + + JS_GetPropertyAsObjectId: Integer = 0; + + JS_ObjectClassId: Integer = 0; + JS_BooleanClassId: Integer = 0; + JS_FunctionClassId: Integer = 0; + JS_StringClassId: Integer = 0; + JS_NumberClassId: Integer = 0; + JS_DateClassId: Integer = 0; + JS_ArrayClassId: Integer = 0; + JS_MathClassId: Integer = 0; + JS_RegExpClassId: Integer = 0; + JS_ErrorClassId: Integer = 0; + + JS_FunctionCallId: Integer = 0; + JS_TempNamespaceId: Integer = 0; + + JS_GetGenericPropertyId: Integer = 0; + JS_PutGenericPropertyId: Integer = 0; + + JS_ToObjectId: Integer = 0; + JS_GetNextPropId: Integer = 0; + JS_TypeOfId: Integer = 0; + JS_VoidId: Integer = 0; + JS_FindFuncId: Integer = 0; + JS_AssignProgId: Integer = 0; + JS_ClearReferencesId: Integer = 0; + JS_AlertId: Integer = 0; + JS_Delete: Integer = 0; + +type + TGetOleProp = + procedure (const D: Variant; PropName: PChar; + var Result: Variant; + ParamCount: Integer); stdcall; + + TPutOleProp = + procedure (const D: Variant; PropName: PChar; + const Value: Variant; + ParamCount: Integer); stdcall; + +var + GetOlePropProc: TGetOleProp = nil; + PutOlePropProc: TPutOleProp = nil; +function IsFrameworkTypeId(Id: Integer): Boolean; + +implementation + +uses + PAXCOMP_BASERUNNER, + PAXCOMP_LOCALSYMBOL_TABLE, + PAXCOMP_GC, + PAXCOMP_STDLIB; + +{$IFNDEF UNIX} +{$IFNDEF PAXARM} +{$IFNDEF LINUX} +{$IFNDEF MACOS32} +function GetReadableSize(Address, Size: DWord): DWord; +const + ReadAttributes = [PAGE_READONLY, PAGE_READWRITE, PAGE_WRITECOPY, PAGE_EXECUTE, + PAGE_EXECUTE_READ, PAGE_EXECUTE_READWRITE, PAGE_EXECUTE_WRITECOPY]; +var + MemInfo: TMemoryBasicInformation; + Tmp: DWord; +begin + Result := 0; + if (VirtualQuery(Pointer(Address), MemInfo, SizeOf(MemInfo)) = SizeOf(MemInfo)) and + (MemInfo.State = MEM_COMMIT) and (MemInfo.Protect in ReadAttributes) then + begin + Result := (MemInfo.RegionSize - (Address - DWord(MemInfo.BaseAddress))); + if (Result < Size) then + begin + repeat + Tmp := GetReadableSize((DWord(MemInfo.BaseAddress) + MemInfo.RegionSize), (Size - Result)); + if (Tmp > 0) then Inc(Result, Tmp) + else Result := 0; + until (Result >= Size) or (Tmp = 0); + end; + end; +end; + +function IsValidBlockAddr(Address, Size: DWord): Boolean; +begin + try + Result := (GetReadableSize(Address, Size) >= Size); + except + Result := false; + end; +end; +{$ENDIF} +{$ENDIF} +{$ENDIF} +{$ENDIF} + +function TSaveStateList.GetRecord(I: Integer): TSaveStateRec; +begin + result := TSaveStateRec(L[I]); +end; + +function TSaveStateList.Add: TSaveStateRec; +begin + result := TSaveStateRec.Create; + L.Add(result); +end; + +function TSaveStateList.Find(Id: Integer): TSaveStateRec; +var + I: Integer; +begin + result := nil; + for I := 0 to L.Count - 1 do + if Records[I].Id = Id then + begin + result := Records[I]; + Exit; + end; +end; + +procedure TBaseSymbolTable.CheckMemory(p: Pointer; Size: Cardinal); +begin +{$IFNDEF UNIX} +{$IFNDEF PAXARM} +{$IFNDEF LINUX} +{$IFNDEF MACOS32} + if not IsValidBlockAddr(Cardinal(p), Size) then + raise EAbort.Create(errMemoryNotInitialized); +{$ENDIF} +{$ENDIF} +{$ENDIF} +{$ENDIF} +end; + +constructor TBaseSymbolTable.Create(NeedHash: Boolean = True); +begin + inherited Create; +{$IFDEF ARC} + A := TList.Create; +{$ELSE} + A := TList.Create; +{$ENDIF} + HeaderParser := THeaderParser.Create; + Card := -1; + VarObjects := TVarObjectList.Create(Self); + if NeedHash then + HashArray := THashArray.Create + else + HashArray := nil; + GuidList := TGuidList.Create; + SomeTypeList := TSomeTypeList.Create; + ExternList := TExternList.Create; + SaveStateList := TSaveStateList.Create; + + TypeHelpers := TAssocIntegers.Create; + + LastCard := 0; +end; + +destructor TBaseSymbolTable.Destroy; +var + I: Integer; +begin + FreeAndNil(VarObjects); + for I := A.Count - 1 downto 0 do +{$IFDEF ARC} + A[I] := nil; +{$ELSE} + TSymbolRec(A[I]).Free; +{$ENDIF} + FreeAndNil(A); + FreeAndNil(HeaderParser); + if HashArray <> nil then + FreeAndNil(HashArray); + FreeAndNil(GuidList); + FreeAndNil(SomeTypeList); + FreeAndNil(ExternList); + FreeAndNil(SaveStateList); + FreeAndNil(TypeHelpers); + inherited; +end; + +procedure TBaseSymbolTable.SaveState; +var + R: TSaveStateRec; +begin + R := SaveStateList.Add; + R.Id := Card; + R.LastShiftValue := LastShiftValue; + R.LastClassIndex := LastClassIndex; + R.LastSubId := LastSubId; + R.LastVarId := LastVarId; +end; + +procedure TBaseSymbolTable.RestoreState(Id: Integer); +var + R: TSaveStateRec; +begin + R := SaveStateList.Find(Id); + if R <> nil then + begin + Card := Id; + LastShiftValue := R.LastShiftValue; + LastClassIndex := R.LastClassIndex; + LastSubId := R.LastSubId; + LastVarId := R.LastVarId; + end; +end; + +procedure TBaseSymbolTable.Reset; +var + I: Integer; + R: TSymbolRec; +begin + VarObjects.Clear; + ExternList.Clear; + SomeTypeList.Clear; + SaveStateList.Clear; + TypeHelpers.Clear; + + for I:=0 to A.Count - 1 do +{$IFDEF ARC} + A[I] := nil; +{$ELSE} + Records[I].Free; +{$ENDIF} + A.Clear; + Card := -1; + + for I:=0 to Types.Count - 1 do + begin + R := AddRecord; + R.Name := Types[I].Name; + R.Kind := KindTYPE; + R.Completed := true; + end; + + SR0 := Records[0]; + +{$IFDEF PAXARM} + while Card < typePVOID - 1 do + AddRecord; +{$ELSE} + while Card < typePANSICHAR - 1 do + AddRecord; +{$ENDIF} + +{$IFNDEF PAXARM} + RegisterPointerType(0, 'PCHAR', typeANSICHAR); +{$ENDIF} + RegisterPointerType(0, 'PVOID', typeVOID); + RegisterPointerType(0, 'PWIDECHAR', typeWIDECHAR); + + with AddRecord do + begin + NilId := Id; + Kind := KindCONST; + TypeId := typePOINTER; + Level := 0; + Value := 0; + end; + + with AddBooleanConst(false) do + begin + FalseId := Id; + Name := 'false'; + Level := typeBOOLEAN; + end; + + with AddBooleanConst(true) do + begin + TrueId := Id; + Name := 'true'; + Level := typeBOOLEAN; + end; + + with AddByteBoolConst(Low(ByteBool)) do + Level := typeBYTEBOOL; + with AddByteBoolConst(High(ByteBool)) do + Level := typeBYTEBOOL; + + with AddWordBoolConst(Low(WordBool)) do + Level := typeWORDBOOL; + with AddWordBoolConst(High(WordBool)) do + Level := typeWORDBOOL; + + with AddLongBoolConst(Low(LongBool)) do + Level := typeLONGBOOL; + with AddLongBoolConst(High(LongBool)) do + Level := typeLONGBOOL; + +{$IFNDEF PAXARM} + with AddAnsiCharConst(Low(AnsiChar)) do + Level := typeANSICHAR; + with AddAnsiCharConst(High(AnsiChar)) do + Level := typeANSICHAR; +{$ENDIF} + + with AddByteConst(Low(Byte)) do + Level := typeBYTE; + with AddByteConst(High(Byte)) do + Level := typeBYTE; + + with AddWordConst(Low(Word)) do + Level := typeWORD; + with AddWordConst(High(Word)) do + Level := typeWORD; + + with AddIntegerConst(Low(Integer)) do + Level := typeINTEGER; + with AddIntegerConst(High(Integer)) do + Level := typeINTEGER; + + with AddInt64Const(Low(Int64)) do + Level := typeINT64; + with AddInt64Const(High(Int64)) do + Level := typeINT64; + + with AddUInt64Const(Low(UInt64)) do + Level := typeUINT64; + with AddUInt64Const(High(Int64)) do + Level := typeUINT64; + + with AddCardinalConst(Low(Cardinal)) do + Level := typeCARDINAL; + with AddCardinalConst(High(Cardinal)) do + Level := typeCARDINAL; + + with AddSmallIntConst(Low(SmallInt)) do + Level := typeSMALLINT; + with AddSmallIntConst(High(SmallInt)) do + Level := typeSMALLINT; + + with AddShortIntConst(Low(ShortInt)) do + Level := typeSHORTINT; + with AddShortIntConst(High(ShortInt)) do + Level := typeSHORTINT; + + Records[typePOINTER].PatternId := typeVOID; + + R := AddRecord; + R.Kind := KindVAR; + ResultID := R.Id; + + R := AddRecord; + R.Kind := KindNONE; + R.TypeId := typePOINTER; + R.Shift := H_SelfPtr; + + R := AddRecord; + R.Kind := KindVAR; + R.TypeId := typePOINTER; + R.Shift := H_ExceptionPtr; + R.Host := true; + CurrExceptionObjectId := R.Id; + GlobalCurrExceptionObjectId := CurrExceptionObjectId; + + R := AddRecord; + R.Kind := KindNONE; + R.TypeId := typeINTEGER; + R.Shift := H_ByteCodePtr; + + R := AddRecord; + R.Kind := KindNONE; + R.TypeId := typeINTEGER; + R.Shift := H_Flag; + + R := AddRecord; + R.Kind := KindNONE; + R.TypeId := typeINTEGER; + R.Shift := H_SkipPop; + + LastShiftValue := H_SkipPop + SizeOf(Integer); + + R := CreateEmptySet; + EmptySetId := R.Id; + + H_TByteSet := RegisterSetType(0, '$$', typeBYTE); + +{$IFDEF PAXARM} + EmptyStringId := AddPWideCharConst('').Id; +{$ELSE} + EmptyStringId := AddPAnsiCharConst('').Id; +{$ENDIF} + + with AddRecord do + begin + EventNilId := Id; + Kind := KindVAR; + TypeId := typeEVENT; + Level := 0; + Value := 0; + Shift := LastShiftValue; + Inc(LastShiftValue, SizeOfTMethod); + end; + + if LastShiftValue <> FirstShiftValue then + RaiseError(errInternalError, []); + + LastClassIndex := -1; +end; + +procedure TBaseSymbolTable.Discard(OldCard: Integer); +var + I, Id: Integer; + S: String; +begin + while Card > OldCard do + begin + S := Records[Card].Name; + Id := Records[Card].Id; + HashArray.DeleteName(S, Id); + + I := Card - FirstLocalId - 1; +{$IFDEF ARC} + A[I] := nil; +{$ELSE} + TSymbolRec(A[I]).Free; +{$ENDIF} + A.Delete(I); + + Dec(Card); + end; +end; + +function TBaseSymbolTable.RegisterNamespace(LevelId: Integer; + const NamespaceName: String): Integer; +var + Q: TStringList; + S: String; + I: Integer; +begin + result := LookupNamespace(NamespaceName, LevelId, true); + + if result > 0 then + begin + HeaderParser.NamespaceId := result; + Exit; + end; + + if PosCh('.', NamespaceName) > 0 then + begin + Q := ExtractNames(NamespaceName); + try + for I := 0 to Q.Count - 1 do + begin + S := Q[I]; + if StrEql(S, 'System') then + result := 0 + else + result := RegisterNamespace(result, S); + end; + finally + FreeAndNil(Q); + end; + Exit; + end + else + S := NamespaceName; + + LastCard := Card; + + with AddRecord do + begin + Name := S; + Kind := KindNAMESPACE; + Host := true; + Level := LevelId; + result := Id; + end; + HeaderParser.NamespaceId := result; +end; + +function TBaseSymbolTable.RegisterTypeDeclaration(LevelId: Integer; + const Declaration: String): Integer; +begin + HeaderParser.Init(Declaration, Self, LevelId); + HeaderParser.Call_SCANNER; + result := HeaderParser.Register_TypeDeclaration; +end; + +procedure TBaseSymbolTable.UpdateSomeTypeList(const TypeName: String; TypeId: Integer); +var + I, Id: Integer; + R: TSymbolRec; +begin + I := SomeTypeList.IndexOf(TypeName); + if I = -1 then + Exit; + + Id := SomeTypeList[I].Id; + SomeTypeList.RemoveAt(I); + + for I := Card downto StdCard do + begin + R := Records[I]; + if R.PatternId = Id then + R.PatternId := TypeId; + end; + + Records[Id].Kind := KindNONE; + Records[Id].Name := ''; +end; + +function TBaseSymbolTable.RegisterSubrangeType(LevelId: Integer; + const TypeName: String; + TypeBaseId: Integer; + B1, B2: Integer): Integer; +begin + if SomeTypeList.Count > 0 then + UpdateSomeTypeList(TypeName, Card + 1); + + LastCard := Card; + + if not TypeBaseId in OrdinalTypes then + begin + result := 0; + RaiseError(errInternalError, []); + Exit; + end; + + with AddRecord do + begin + Name := TypeName; + Kind := KindTYPE; + TypeID := TypeBaseId; + Host := true; + Shift := 0; + Level := LevelId; + result := Id; + + Completed := true; + end; + + with AddRecord do + begin + Kind := KindCONST; + TypeID := TypeBaseId; + Host := true; + Shift := 0; + Level := result; + Value := B1; + end; + + with AddRecord do + begin + Kind := KindCONST; + TypeID := TypeBaseId; + Host := true; + Shift := 0; + Level := result; + Value := B2; + end; +end; + +function TBaseSymbolTable.RegisterEnumType(LevelId: Integer; + const TypeName: String; + TypeBaseId: Integer): Integer; +begin + LastCard := Card; + + if TypeName <> '' then + begin + result := LookUpType(TypeName, LevelId, true); + if (result > 0) and (Records [Result].Level = LevelID) then + Exit; + end; + + if SomeTypeList.Count > 0 then + UpdateSomeTypeList(TypeName, Card + 1); + + with AddRecord do + begin + Name := TypeName; + Kind := KindTYPE; + TypeID := typeENUM; + Host := true; + Shift := 0; + Level := LevelId; + PatternId := TypeBaseId; + result := Id; + end; + + BindDummyType(result, TypeBaseId); +end; + +function TBaseSymbolTable.RegisterEnumValue(EnumTypeId: Integer; + const FieldName: String; + const i_Value: Integer): Integer; +begin + with AddRecord do + begin + Name := FieldName; + Kind := KindCONST; + TypeID := EnumTypeId; + Host := true; + Shift := 0; + Level := Records[EnumTypeId].Level; + OwnerId := TypeId; + + Value := i_Value; + + result := Id; + end; + + if EnumTypeId > 0 then + Records[EnumTypeId].Count := Records[EnumTypeId].Count + 1; +end; + +function TBaseSymbolTable.RegisterArrayType(LevelId: Integer; + const TypeName: String; + RangeTypeId, ElemTypeId: Integer; + Align: Integer): Integer; +begin + LastCard := Card; + + if SomeTypeList.Count > 0 then + UpdateSomeTypeList(TypeName, Card + 1); + + with AddRecord do + begin + Name := TypeName; + Kind := KindTYPE; + TypeID := typeARRAY; + Host := true; + Shift := 0; + Level := LevelId; + + DefaultAlignment := Align; + + result := Id; + + Completed := true; + end; + + with AddRecord do + begin + Kind := KindTYPE; + TypeID := typeALIAS; + Host := true; + Shift := 0; + Level := result; + PatternId := RangeTypeId; + end; + + with AddRecord do + begin + Kind := KindTYPE; + TypeID := typeALIAS; + Host := true; + Shift := 0; + Level := result; + PatternId := ElemTypeId; + end; +end; + +function TBaseSymbolTable.RegisterTypeAlias(LevelId:Integer; + const TypeName: String; + OriginTypeId: Integer; + const OriginTypeName: String = ''): Integer; +begin + LastCard := Card; + + result := LookupType(TypeName, LevelId, true); + if result > 0 then + begin + if Records[result].Level = LevelId then + if result > OriginTypeId then + Exit; + end; + + if SomeTypeList.Count > 0 then + UpdateSomeTypeList(TypeName, Card + 1); + + with AddRecord do + begin + Name := TypeName; + Kind := KindTYPE; + TypeID := typeALIAS; + Host := true; + Shift := 0; + Level := LevelId; + PatternId := OriginTypeId; + result := Id; + end; + + if OriginTypeId = 0 then + if OriginTypeName <> '' then + begin + ExternList.Add(Card, + OriginTypeName, + erPatternId); + end; + + BindDummyType(result, OriginTypeId); +end; + +function TBaseSymbolTable.RegisterTypeAlias(LevelId:Integer; + const TypeName, OriginTypeName: String): Integer; +var + TypeId: Integer; +begin + TypeId := LookupType(OriginTypeName, true); + result := RegisterTypeAlias(LevelId, TypeName, TypeId, OriginTypeName); +end; + +function TBaseSymbolTable.RegisterTypeAlias(LevelId:Integer; + const Declaration: String): Integer; +var + TypeName: String; +begin + HeaderParser.Init(Declaration, Self, LevelId); + HeaderParser.Call_SCANNER; + TypeName := HeaderParser.Parse_Ident; + result := HeaderParser.Register_TypeAlias(TypeName); +end; + +function TBaseSymbolTable.RegisterPointerType(LevelId: Integer; + const TypeName: String; + OriginTypeId: Integer; + const OriginTypeName: String = ''): Integer; +begin + LastCard := Card; + + if SomeTypeList.Count > 0 then + UpdateSomeTypeList(TypeName, Card + 1); + + with AddRecord do + begin + Name := TypeName; + Kind := KindTYPE; + TypeID := typePOINTER; + Host := true; + Shift := 0; + Level := LevelId; + + PatternId := OriginTypeId; + + result := Id; + + Completed := true; + end; + + if OriginTypeId = 0 then + if OriginTypeName <> '' then + begin + ExternList.Add(Card, + OriginTypeName, + erPatternId); + end; +end; + +function TBaseSymbolTable.RegisterDynamicArrayType(LevelId: Integer; + const TypeName: String; + ElemTypeId: Integer): Integer; +begin + LastCard := Card; + + if SomeTypeList.Count > 0 then + UpdateSomeTypeList(TypeName, Card + 1); + + with AddRecord do + begin + Name := TypeName; + Kind := KindTYPE; + TypeID := typeDYNARRAY; + Host := true; + Shift := 0; + Level := LevelId; + PatternId := ElemTypeId; + result := Id; + + Completed := true; + end; + + BindDummyType(result, ElemTypeId); +end; + +function TBaseSymbolTable.RegisterOpenArrayType(LevelId: Integer; + const TypeName: String; + ElemTypeId: Integer): Integer; +begin + LastCard := Card; + + if SomeTypeList.Count > 0 then + UpdateSomeTypeList(TypeName, Card + 1); + + with AddRecord do + begin + Name := TypeName; + Kind := KindTYPE; + TypeID := typeOPENARRAY; + Host := true; + Shift := 0; + Level := LevelId; + PatternId := ElemTypeId; + result := Id; + + Completed := true; + end; + + BindDummyType(result, ElemTypeId); +end; + +{$IFNDEF PAXARM} +function TBaseSymbolTable.RegisterShortStringType(LevelId: Integer; + const TypeName: String; + L: Integer): Integer; +begin + LastCard := Card; + + if SomeTypeList.Count > 0 then + UpdateSomeTypeList(TypeName, Card + 1); + + with AddRecord do + begin + Name := TypeName; + Kind := KindTYPE; + TypeID := typeSHORTSTRING; + Host := true; + Shift := 0; + Level := LevelId; + Count := L; + result := Id; + + Completed := true; + end; +end; +{$ENDIF} + +function TBaseSymbolTable.RegisterSetType(LevelId: Integer; + const TypeName: String; + OriginTypeId: Integer): Integer; +begin + LastCard := Card; + + if SomeTypeList.Count > 0 then + UpdateSomeTypeList(TypeName, Card + 1); + + with AddRecord do + begin + Name := TypeName; + Kind := KindTYPE; + TypeID := typeSET; + Host := true; + Shift := 0; + Level := LevelId; + + PatternId := OriginTypeId; + + result := Id; + + Completed := true; + end; + + BindDummyType(result, OriginTypeId); +end; + +function TBaseSymbolTable.RegisterProceduralType(LevelId: Integer; + const TypeName: String; + HSub: Integer): Integer; +var + I, SubId: Integer; +begin + LastCard := Card; + + if HSub < 0 then + SubId := -HSub + else + begin + SubId := -1; + for I:=Card downto 1 do + if Records[I].Shift = HSub then + begin + SubId := I; + Break; + end; + + if SubId = -1 then + begin + result := 0; + RaiseError(errInternalError, []); + Exit; + end; + end; + + if SomeTypeList.Count > 0 then + UpdateSomeTypeList(TypeName, Card + 1); + + with AddRecord do + begin + Name := TypeName; + Kind := KindTYPE; + TypeID := typePROC; + Host := true; + Shift := 0; + Level := LevelId; + + PatternId := SubId; + + result := Id; + + Completed := true; + end; +end; + +function TBaseSymbolTable.RegisterMethodReferenceType(LevelId: Integer; + const TypeName: String; + HSub: Integer): Integer; +var + I, SubId: Integer; +begin + LastCard := Card; + + SubId := -1; + for I:=Card downto 1 do + if Records[I].Shift = HSub then + begin + SubId := I; + Break; + end; + + if SubId = -1 then + begin + result := 0; + RaiseError(errInternalError, []); + Exit; + end; + + if SomeTypeList.Count > 0 then + UpdateSomeTypeList(TypeName, Card + 1); + + result := RegisterInterfaceType(LevelId, TypeName, IUnknown); + Records[SubId].Level := result; + Records[SubId].Name := ANONYMOUS_METHOD_NAME; + Records[SubId].MethodIndex := 4; +end; + +function TBaseSymbolTable.RegisterEventType(LevelId: Integer; + const TypeName: String; + HSub: Integer): Integer; +var + I, SubId: Integer; +begin + LastCard := Card; + + SubId := -1; + for I:=Card downto 1 do + if Records[I].Shift = HSub then + begin + SubId := I; + Break; + end; + + if SubId = -1 then + begin + result := 0; + RaiseError(errInternalError, []); + Exit; + end; + + if SomeTypeList.Count > 0 then + UpdateSomeTypeList(TypeName, Card + 1); + + with AddRecord do + begin + Name := TypeName; + Kind := KindTYPE; + TypeID := typeEVENT; + Host := true; + Shift := 0; + Level := LevelId; + + PatternId := SubId; + + result := Id; + + Completed := true; + end; +end; + +function TBaseSymbolTable.FindInterfaceTypeId(const GUID: TGUID): Integer; +var + I: Integer; +begin + I := GuidList.IndexOf(GUID); + if I = -1 then + result := 0 + else + result := GuidList[I].Id; +end; + +function TBaseSymbolTable.RegisterInterfaceType(LevelId: Integer; + const TypeName: String; + const GUID: TGUID): Integer; +var + D: packed record + D1, D2: Double; + end; +begin + LastCard := Card; + +// result := FindInterfaceTypeId(GUID); + result := LookUpType(TypeName, LevelId, true); + + if result > 0 then + Exit; + + if SomeTypeList.Count > 0 then + UpdateSomeTypeList(TypeName, Card + 1); + + with AddRecord do + begin + Name := TypeName; + Kind := KindTYPE; + TypeID := typeINTERFACE; + Host := true; + Shift := 0; + Level := LevelId; + AncestorId := 0; + result := Id; + + GuidList.Add(GUID, result, TypeName); + end; + + Move(GUID, D, SizeOf(TGUID)); + AddDoubleConst(D.D1); + AddDoubleConst(D.D2); + + if not GuidsAreEqual(IUnknown, GUID) then +{$IFDEF VARIANTS} + if not GuidsAreEqual(IInterface, GUID) then +{$ENDIF} + RegisterSupportedInterface(result, 'IUnknown', IUnknown); +end; + +function TBaseSymbolTable.RegisterInterfaceType(LevelId: Integer; + pti: PTypeInfo): Integer; +var + TypeData: PTypeData; + L: TPtrList; + p: PTypeInfo; + d: PTypeData; + I: Integer; +begin + LastCard := Card; + + result := 0; + TypeData := GetTypeData(pti); + if TypeData <> nil then + if ifHasGuid in TypeData^.IntfFlags then + begin + L := TPtrList.Create; + try + p := nil; +{$IFDEF FPC} + p := TypeData^.IntfParent; +{$ELSE} + if TypeData^.IntfParent <> nil then + p := TypeData^.IntfParent^; +{$ENDIF} + while p <> nil do + begin + L.Insert(0, p); + d := GetTypeData(p); + if d <> nil then + begin +{$IFDEF FPC} + p := d^.IntfParent +{$ELSE} + if d^.IntfParent <> nil then + p := d^.IntfParent^ + else + p := nil; +{$ENDIF} + end + else + p := nil; + end; + for I := 0 to L.Count - 1 do + RegisterInterfaceType(LevelId, L[I]); + finally + FreeAndNil(L); + end; + + result := RegisterInterfaceType(LevelId, PTIName(pti), TypeData^.Guid); + end; +end; + +procedure TBaseSymbolTable.RegisterSupportedInterface(TypeId: Integer; + const SupportedInterfaceName: String; + const i_GUID: TGUID); +var + InterfaceTypeId: Integer; +begin + LastCard := Card; + + InterfaceTypeId := LookupType(SupportedInterfaceName, true); + + if InterfaceTypeId = 0 then + begin + ExternList.Add(TypeId, SupportedInterfaceName, erGUID); + Exit; + end; + + with Records[TypeId] do + begin + if SupportedInterfaces = nil then + SupportedInterfaces := TGuidList.Create; + SupportedInterfaces.Add(i_GUID, InterfaceTypeId, SupportedInterfaceName); + end; +end; + +procedure TBaseSymbolTable.RegisterSupportedInterface(TypeId, + InterfaceTypeId: Integer); +var + SupportedInterfaceName: String; + GUID: TGUID; + D: record + D1, D2: Double; + end; +begin + if Records[InterfaceTypeId].FinalTypeId <> typeINTERFACE then + Exit; + + LastCard := Card; + + SupportedInterfaceName := Records[InterfaceTypeId].Name; + D.D1 := Records[InterfaceTypeId + 1].Value; + D.D2 := Records[InterfaceTypeId + 2].Value; + Move(D, GUID, SizeOf(TGUID)); + + with Records[TypeId] do + begin + if SupportedInterfaces = nil then + SupportedInterfaces := TGuidList.Create; + SupportedInterfaces.Add(GUID, InterfaceTypeId, SupportedInterfaceName); + end; +end; + +procedure TBaseSymbolTable.RegisterClassTypeInfos(ClassId: Integer; + C: TClass); + procedure SetAncestor; + var + I: Integer; + S: String; + ParentClass: TClass; + begin + ParentClass := C.ClassParent; + + if DllDefined then + S := ParentClass.ClassName + else + S := ''; + + for I:=ClassId - 1 downto H_TObject do + with Records[I] do + if PClass <> nil then + begin + if DllDefined then + begin + if Kind = KindTYPE then if Name = S then + begin + Records[ClassId].AncestorId := I; + Exit; + end + end + else + if PClass = ParentClass then + begin + Records[ClassId].AncestorId := I; + Exit; + end; + end; + + Records[ClassId].AncestorId := H_TObject; + end; + +var + UnresolvedPropIds: TIntegerList; + UnresolvedTypes: TPtrList; + + procedure RegisterPublishedProperty(Index: Integer; ppi: PPropInfo); + var + TypeData: PTypeData; + pti: PTypeInfo; + T: Integer; + begin + if ppi = nil then + Exit; + + {$ifdef fpc} + pti := ppi^.PropType; + {$else} + pti := ppi.PropType^; + {$endif} + + T := 0; + + case pti^.Kind of + tkInteger: T := typeINTEGER; + tkFloat: + begin + TypeData := GetTypeData(pti); + case TypeData^.FloatType of + ftSingle: T := typeSINGLE; + ftDouble: T := typeDOUBLE; + ftExtended: T := typeEXTENDED; + end; + end; +{$IFNDEF PAXARM} + tkChar: T := typeANSICHAR; + tkString: T := typeSHORTSTRING; + tkLString: T := typeANSISTRING; +{$ENDIF} +{$IFDEF UNIC} + tkUString: T := typeUNICSTRING; +{$ENDIF} + tkVariant: T := typeVARIANT; + else + T := LookupType(PTIName(pti), 0, true); + end; + + with AddRecord do + begin + Name := StringFromPShortString(@ppi^.Name); + Kind := KindPROP; + TypeID := T; + Host := true; + Shift := 0; + Level := ClassId; + IsPublished := true; + PropIndex := Index; + end; + + if T = 0 then + begin +{ + if pti^.Kind = tkClass then + begin + ExternList.Add(Card, pti^.Name, erTypeId); + end + else } + begin + UnresolvedPropIds.Add(Card); + UnresolvedTypes.Add(pti); + end; + end; + end; + + function RegisterPublishedProperties: Integer; + var + pti: PTypeInfo; + ptd: PTypeData; + I, nProps: Integer; + pProps: PPropList; + ppi: PPropInfo; + begin + result := 0; + pti := C.ClassInfo; + if pti = nil then Exit; + ptd := GetTypeData(pti); + nProps := ptd^.PropCount; + if nProps > 0 then begin + GetMem(pProps, SizeOf(PPropInfo) * nProps); + GetPropInfos(pti, pProps); + end + else + pProps := nil; + for I:=0 to nProps - 1 do + begin + {$ifdef fpc} + ppi := pProps^[I]; + {$else} + ppi := pProps[I]; + {$endif} + RegisterPublishedProperty(I, ppi); + end; + if pProps <> nil then + FreeMem(pProps, SizeOf(PPropInfo) * nProps); + result := nProps; + end; + +var + I, K, T, LevelId: Integer; + pti: PTypeInfo; +begin + Records[ClassId].PClass := C; + Records[ClassId + 1].Value := Integer(C); // classref var + + if C <> TObject then + SetAncestor; + + UnresolvedPropIds := TIntegerList.Create; + UnresolvedTypes := TPtrList.Create; + + try + RegisterPublishedProperties; + AddEndOfClassHeader(ClassId); + + for I:=0 to UnresolvedTypes.Count - 1 do + begin + pti := UnresolvedTypes[I]; + K := UnresolvedPropIds[I]; + + // Call event to get namespace of type. + if Assigned(GetNamespaceOfType) then + LevelId := GetNamespaceOfType(Self, pti) + else + LevelId := 0; + + T := RegisterRTTIType(LevelId, pti); + if T = 0 then + begin + Records[K].Name := ''; + Records[K].Kind := KindNONE; + end + else + Records[K].TypeID := T; + end; + + finally + FreeAndNil(UnresolvedPropIds); + FreeAndNil(UnresolvedTypes); + end; +end; + +function TBaseSymbolTable.RegisterClassTypeForImporter(LevelId: Integer; + C: TClass): Integer; +begin + result := RegisterClassType(LevelId, C.ClassName, H_TObject); + AddVoidVar(0, MaxPublishedProps * SizeOfPointer); +end; + +function TBaseSymbolTable.RegisterClassTypeForImporter(LevelId: Integer; + const TypeName: String): Integer; +begin + result := RegisterClassType(LevelId, TypeName, H_TObject); + AddVoidVar(0, MaxPublishedProps * SizeOfPointer); +end; + +function TBaseSymbolTable.RegisterClassType(LevelId: Integer; + const TypeName: String; + i_AncestorId: Integer): Integer; +var + ClassRefTypeId: Integer; +begin + if SomeTypeList.Count > 0 then + UpdateSomeTypeList(TypeName, Card + 1); + + LastCard := Card; + + Inc(LastClassIndex); + with AddRecord do + begin + Name := TypeName; + Kind := KindTYPE; + TypeID := typeCLASS; + Host := true; + Shift := 0; + Level := LevelId; + ClassIndex := LastClassIndex; + AncestorId := i_AncestorId; + + result := Id; + end; + + AddClassRefVar(0); + ClassRefTypeId := RegisterClassReferenceType(0, '', result); + Records[result + 1].TypeId := ClassRefTypeId; +end; + +procedure TBaseSymbolTable.SetAncestorEx(ClassId: Integer); +var + I: Integer; + S: String; + ParentClass: TClass; + C: TClass; +begin + C := Records[ClassId].PClass; + if C = nil then + Exit; +{$IFDEF FPC} +// ParentClass := PVMT(C).Parent; +ParentClass := C.ClassParent; +{$ELSE} + ParentClass := C.ClassParent; +{$ENDIF} + S := ParentClass.ClassName; + I := LookupType(S, true); + if I > 0 then + Records[ClassId].AncestorId := I; +end; + +function TBaseSymbolTable.RegisterClassType(LevelId: Integer; + C: TClass; + Reserved: Integer = 0): Integer; + +var + UnresolvedPropIds: TIntegerList; + UnresolvedTypes: TPtrList; + + procedure RegisterPublishedProperty(Index: Integer; ppi: PPropInfo); + var + TypeData: PTypeData; + pti: PTypeInfo; + T: Integer; + begin + if ppi = nil then + Exit; + + {$ifdef fpc} + pti := ppi^.PropType; + {$else} + pti := ppi.PropType^; + {$endif} + + T := 0; + + case pti^.Kind of + tkInteger: T := typeINTEGER; + tkFloat: + begin + TypeData := GetTypeData(pti); + case TypeData^.FloatType of + ftSingle: T := typeSINGLE; + ftDouble: T := typeDOUBLE; + ftExtended: T := typeEXTENDED; + end; + end; +{$IFDEF UNIC} + tkUString: T := typeUNICSTRING; +{$ENDIF} +{$IFNDEF PAXARM} + tkChar: T := typeANSICHAR; + tkString: T := typeSHORTSTRING; + tkLString: T := typeANSISTRING; +{$ENDIF} + tkVariant: T := typeVARIANT; + else + T := LookupType(PTIName(pti), 0, true); + end; + + with AddRecord do + begin + Name := StringFromPShortString(@ppi^.Name); + Kind := KindPROP; + TypeID := T; + Host := true; + Shift := 0; + Level := result; + IsPublished := true; + PropIndex := Index; + end; + + if T = 0 then + begin +{ + if pti^.Kind = tkClass then + begin + ExternList.Add(Card, pti^.Name, erTypeId); + end + else } + begin + UnresolvedPropIds.Add(Card); + UnresolvedTypes.Add(pti); + end; + end; + end; + + function RegisterPublishedProperties: Integer; + var + pti: PTypeInfo; + ptd: PTypeData; + I, nProps: Integer; + pProps: PPropList; + ppi: PPropInfo; + begin + result := 0; + pti := C.ClassInfo; + if pti = nil then Exit; + ptd := GetTypeData(pti); + nProps := ptd^.PropCount; + if nProps > 0 then begin + GetMem(pProps, SizeOf(PPropInfo) * nProps); + GetPropInfos(pti, pProps); + end + else + pProps := nil; + for I:=0 to nProps - 1 do + begin + {$ifdef fpc} + ppi := pProps^[I]; + {$else} + ppi := pProps[I]; + {$endif} + RegisterPublishedProperty(I, ppi); + end; + if pProps <> nil then + FreeMem(pProps, SizeOf(PPropInfo) * nProps); + result := nProps; + end; + + procedure SetAncestor; + var + I: Integer; + S: String; + ParentClass: TClass; + begin + ParentClass := C.ClassParent; + + if DllDefined then + S := ParentClass.ClassName + else + S := ''; + + for I:=result - 1 downto H_TObject do + with Records[I] do + if PClass <> nil then + begin + if DllDefined then + begin + if Kind = KindTYPE then if Name = S then + begin + Records[result].AncestorId := I; + Exit; + end + end + else if PClass = ParentClass then + begin + Records[result].AncestorId := I; + Exit; + end; + end; +{ + if AncestorRequired then + ExternList.Add(result, ParentClass.ClassName, erAncestorId) + else +} + Records[result].AncestorId := H_TObject; + end; + + procedure RegisterAncestors(Cls: TClass); + var + ParentClass: TClass; + Id: Integer; + begin + ParentClass := Cls.ClassParent; + if ParentClass = nil then + Exit; + Id := FindClassTypeId(ParentClass); + if Id > 0 then + Exit; +{ + if (LevelId > 0) and (ParentClass.ClassInfo <> nil) then + begin + ptd := GetTypeData(ParentClass.ClassInfo); + if ptd = nil then + RegisterClassType(LevelId, ParentClass) + else if StrEql(ptd^.UnitName, Records[LevelId].Name) then + RegisterClassType(LevelId, ParentClass) + else + begin + Exit; + end; + end + else } + RegisterClassType(LevelId, ParentClass); + RegisterAncestors(ParentClass); + end; + +var + I, K, T: Integer; + pti: PTypeInfo; + S: String; + R: TSymbolRec; + AlreadyExists: Boolean; + K1, K2, KK: Integer; +begin + HeaderParser.AbstractMethodCount := 0; + + LastCard := Card; + + AlreadyExists := false; + result := FindClassTypeId(C); + T := result; + + if result > 0 then + begin + if result < FirstLocalId then + if Card >= FirstLocalId then + begin + Records[result].Level := LevelId; + Exit; + end; + + AlreadyExists := true; + end; + + if not AlreadyExists then + begin + if not C.InheritsFrom(TGC_Object) then + RegisterAncestors(C); + end; + + S := C.ClassName; + + result := RegisterClassType(LevelId, S, 0); + + if AlreadyExists then + begin + Records[T].Name := '@@'; + Records[T].PClass := nil; + Records[T].ClassIndex := -1; + Records[T + 1].Value := 0; + + for KK := 1 to 2 do + begin + if KK = 1 then + begin + K1 := 1; + if Self.st_tag = 0 then + K2 := Card + else + K2 := TLocalSymbolTable(Self).GlobalST.Card; + end + else + begin + K1 := FirstLocalId + 1; + K2 := Card; + end; + + for I := K1 to K2 do + begin + R := Records[I]; + + if R.TypeID = T then + R.TypeID := result; + if R.PatternID = T then + R.PatternID := result; + if R.AncestorID = T then + R.AncestorID := result; + end; + end; + end; + + Records[result].PClass := C; + if S <> TObject.ClassName then + SetAncestor; + + Records[Result + 1].Value := Integer(C); // classref var + + UnresolvedPropIds := TIntegerList.Create; + UnresolvedTypes := TPtrList.Create; + + try + + K := RegisterPublishedProperties; + + for I:=1 to Reserved do // reserve extra space + AddRecord; + + for I:=1 to K do // reserve place for ppi + AddPointerVar(0); + + for I:=1 to Reserved do // reserve extra space + AddPointerVar(0); + + if Assigned(RegisterDRTTIProperties) then + RegisterDRTTIProperties(result, C, Self); + + AddEndOfClassHeader(result); + + for I:=0 to UnresolvedTypes.Count - 1 do + begin + pti := UnresolvedTypes[I]; + K := UnresolvedPropIds[I]; + + // Call event to get namespace of type. + if Assigned(GetNamespaceOfType) then + LevelId := GetNamespaceOfType(Self, pti) + else + LevelId := 0; + + if pti^.Kind = tkClass then + begin + ExternList.Add(K, PTIName(pti), erTypeId); + continue; + end; + + T := RegisterRTTIType(LevelId, pti); + + if T = 0 then + begin + Records[K].Name := ''; + Records[K].Kind := KindNONE; + end + else + Records[K].TypeID := T; + end; + + finally + FreeAndNil(UnresolvedPropIds); + FreeAndNil(UnresolvedTypes); + end; +end; + +function TBaseSymbolTable.RegisterClassReferenceType(LevelId: Integer; + const TypeName: String; + OriginClassId: Integer): Integer; +begin + if SomeTypeList.Count > 0 then + UpdateSomeTypeList(TypeName, Card + 1); + + LastCard := Card; + + with AddRecord do + begin + Name := TypeName; + Kind := KindTYPE; + TypeID := typeCLASSREF; + Host := true; + Shift := 0; + Level := LevelId; + PatternId := OriginClassId; + result := Id; + + Completed := true; + end; + + BindDummyType(result, OriginClassId); +end; + +function TBaseSymbolTable.RegisterHelperType(LevelId: Integer; + const TypeName: String; + OriginTypeId: Integer): Integer; +begin + if SomeTypeList.Count > 0 then + UpdateSomeTypeList(TypeName, Card + 1); + + LastCard := Card; + + with AddRecord do + begin + Name := TypeName; + Kind := KindTYPE; + TypeID := typeHELPER; + Host := true; + Shift := 0; + Level := LevelId; + PatternId := OriginTypeId; + result := Id; + + Completed := true; + end; + + BindDummyType(result, OriginTypeId); + + TypeHelpers.Add(result, OriginTypeId); +end; + +procedure TBaseSymbolTable.BindDummyType(TypeId, OriginTypeId: Integer); +begin + if Records[OriginTypeId].IsDummyType then + begin + ExternList.Add(TypeId, + Records[OriginTypeId].FullName, + erPatternId); + Records[OriginTypeId].Name := ''; + Records[OriginTypeId].Kind := KindNONE; + end; +end; + +function TBaseSymbolTable.RegisterRecordType(LevelId: Integer; + const TypeName: String; + Align: Integer): Integer; +begin + if SomeTypeList.Count > 0 then + UpdateSomeTypeList(TypeName, Card + 1); + + LastCard := Card; + + with AddRecord do + begin + Name := TypeName; + Kind := KindTYPE; + TypeID := typeRECORD; + Host := true; + Shift := 0; + Level := LevelId; + DefaultAlignment := Align; + + result := Id; + end; +end; + +function TBaseSymbolTable.RegisterRTTIType(LevelId: Integer; + pti: PTypeInfo): Integer; +var + TypeData, td, ptd: PTypeData; + S, SParamType: String; + I, T, K1, K2: Integer; + + pParam: PParamData; + pNameString, pTypeString: ^ShortString; + + ParamIds: array[0..20] of Integer; + ParamRef: array[0..20] of Boolean; + ParamNames: array[0..20] of string; + H_Sub: Integer; +begin + LastCard := Card; + + S := PTIName(pti); + result := LookupType(S, LevelId, true); + if result > 0 then + Exit; + + case pti^.Kind of +{$IFDEF VARIANTS} + tkDynArray: + begin + ptd := GetTypeData(pti); + I := LookupType(StringFromPShortString(@ptd.elType2^.Name), true); + if I > 0 then + result := RegisterDynamicArrayType(LevelId, S, I); + end; +{$ENDIF} + tkInteger: + begin + ptd := GetTypeData(pti); + T := typeINTEGER; + case ptd^.OrdType of + otSByte: T := typeSMALLINT; + otUByte: T := typeBYTE; + otSWord: T := typeSHORTINT; + otUWord: T := typeWORD; + otSLong: T := typeINTEGER; + otULong: T := typeCARDINAL; + end; + result := RegisterSubrangeType(LevelId, S, T, ptd^.MinValue, ptd^.MaxValue); + end; + tkInt64: + begin + result := RegisterTypeAlias(LevelId, PTIName(pti), typeINT64); + end; + tkFloat: + begin + TypeData := GetTypeData(pti); + with TypeData^ do + case FloatType of + ftSingle: result := RegisterTypeAlias(LevelId, PTIName(pti), typeSINGLE); + ftDouble: result := RegisterTypeAlias(LevelId, PTIName(pti), typeDOUBLE); + ftExtended: result := RegisterTypeAlias(LevelId, PTIName(pti), typeEXTENDED); + end + end; + tkEnumeration: + begin + S := PTIName(pti); + K1 := Card; + T := RegisterEnumType(LevelId, S, typeINTEGER); + K2 := Card; + if K1 <> K2 then + begin + TypeData := GetTypeData(pti); + with TypeData^ do + begin +// if (MinValue < 256) and (MaxValue < 256) then + for I:= MinValue to MaxValue do + begin + S := GetEnumName(pti, I); + RegisterEnumValue(T, S, I); + end; + end; + end; + result := T; + end; + tkSet: + begin + TypeData := GetTypeData(pti); + if TypeData = nil then + Exit; + if TypeData^.CompType = nil then + Exit; + S := StringFromPShortString(@TypeData^.CompType^.Name); + case TypeData^.CompType^.Kind of + tkInteger: + begin + result := RegisterSetType(LevelId, PTIName(pti), typeINTEGER); + end; +{$IFNDEF PAXARM} + tkChar: + begin + result := RegisterSetType(LevelId, PTIName(pti), typeANSICHAR); + end; +{$ENDIF} + tkWChar: + begin + result := RegisterSetType(LevelId, PTIName(pti), typeWIDECHAR); + end; + tkEnumeration: + begin + K1 := Card; + if IsValidName(S) then + T := RegisterEnumType(LevelId, S, typeINTEGER) + else + T := RegisterEnumType(LevelId, PTIName(pti) + '_Comp', typeINTEGER); + + K2 := Card; + if K1 <> K2 then + begin +{$ifdef fpc} + td := GetTypeData(TypeData^.CompType); +{$else} + td := GetTypeData(TypeData^.CompType^); +{$endif} + with td^ do + if (MinValue < 256) and (MaxValue < 256) then + for I:= MinValue to MaxValue do + begin +{$ifdef fpc} + S := GetEnumName(TypeData^.CompType, I); +{$else} + S := GetEnumName(TypeData^.CompType^, I); +{$endif} + RegisterEnumValue(T, S, I); + end; + end; + result := RegisterSetType(LevelId, PTIName(pti), T); + end; + end; + end; + tkClass: + begin + TypeData := GetTypeData(pti); + if LevelId > 0 then + begin + if StrEql(StringFromPShortString(@TypeData^.UnitName), Records[LevelId].Name) then + result := RegisterClassType(LevelId, TypeData^.ClassType) + else + result := FindClassTypeIdByPti(pti); + end + else + begin + result := FindClassTypeIdByPti(pti); + if result = 0 then + result := RegisterClassType(LevelId, TypeData^.ClassType); + end; + end; + tkInterface: + begin + TypeData := GetTypeData(pti); + if TypeData <> nil then + if ifHasGuid in TypeData^.IntfFlags then + result := RegisterInterfaceType(LevelId, pti); + end; +{$IFNDEF PAXARM} + tkChar: + begin + ptd := GetTypeData(pti); + T := typeANSICHAR; + result := RegisterSubrangeType(LevelId, S, T, ptd^.MinValue, ptd^.MaxValue); + end; + tkString: + begin + result := RegisterTypeAlias(LevelId, PTIName(pti), typeSHORTSTRING); + end; + tkLString: + begin + result := RegisterTypeAlias(LevelId, PTIName(pti), typeANSISTRING); + end; + tkWString: + begin + result := RegisterTypeAlias(LevelId, PTIName(pti), typeWIDESTRING); + end; +{$ENDIF} + tkWChar: + begin + ptd := GetTypeData(pti); + T := typeWIDECHAR; + result := RegisterSubrangeType(LevelId, S, T, ptd^.MinValue, ptd^.MaxValue); + end; +{$IFDEF UNIC} + tkUString: + begin + result := RegisterTypeAlias(LevelId, PTIName(pti), typeUNICSTRING); + end; +{$ENDIF} + tkVariant: + begin + result := RegisterTypeAlias(LevelId, PTIName(pti), typeVARIANT); + end; + tkMethod: + begin + S := PTIName(pti); + + result := LookUpType(S, 0, true); + if result > 0 then + Exit; + + ptd := GetTypeData(pti); + + pParam := PParamData(@(ptd^.ParamList)); + I := 0; + while I <= ptd^.ParamCount - 1 do + begin + ParamRef[I] := false; + if pfVar in pParam^.Flags then + begin + ParamRef[I] := true; + end + else if pfConst in pParam^.Flags then + begin + end + else if pfOut in pParam^.Flags then + begin + ParamRef[I] := true; + end; + + if pfArray in pParam^.Flags then + begin + result := H_TMethod; + Exit; + end; + + pNameString := ShiftPointer(pParam, SizeOf(TParamFlags)); + ParamNames[I] := StringFromPShortString(PShortString(pNameString)); + + pTypeString := ShiftPointer(pParam, SizeOf(TParamFlags) + + Length(pParam^.ParamName) + 1); + + SParamType := StringFromPShortString(PShortString(pTypeString)); + T := LookUpType(SParamType, 0, true); + + if T = 0 then + begin + result := H_TMethod; + Exit; + end; + ParamIds[I] := T; + + if Records[T].FinalTypeId in [typeRECORD, typeARRAY] then + ParamRef[I] := true; + + pParam := ShiftPointer(pTypeString, Length(pTypeString^) + 1); + Inc(I); + end; + + T := typeVOID; + if ptd^.MethodKind = mkFunction then + begin + pTypeString := Pointer(pParam); + T := LookUpType(StringFromPShortString(PShortString(pTypeString)), 0, true); + if T = 0 then + begin + result := H_TMethod; + Exit; + end; + end; + + H_Sub := RegisterRoutine(LevelId, '', T, ccREGISTER, nil); + + K1 := I; + for I:=0 to K1 - 1 do + RegisterParameter(H_Sub, ParamIds[I], Unassigned, ParamRef[I], ParamNames[I]); + result := RegisterEventType(LevelId, S, H_Sub); + end; + else + begin + Exit; + end; + end; +end; + +function TBaseSymbolTable.RegisterProperty(LevelId: Integer; const PropName: String; + PropTypeID, i_ReadId, i_WriteId: Integer; + i_IsDefault: Boolean): Integer; +var + I: Integer; +begin + with AddRecord do + begin + Name := PropName; + Count := 0; + Kind := KindPROP; + TypeID := PropTypeID; + Host := true; + Shift := 0; + Level := LevelId; + + if i_ReadId <= 0 then + ReadId := - i_ReadId + else + begin + ReadId := -1; + for I:=Card downto 1 do + if Records[I].Shift = i_ReadId then + begin + ReadId := I; + Break; + end; + + if ReadId = -1 then + begin + result := 0; + RaiseError(errInternalError, []); + Exit; + end; + end; + + if i_WriteId <= 0 then + WriteId := - i_WriteId + else + begin + WriteId := -1; + for I:=Card downto 1 do + if Records[I].Shift = i_WriteId then + begin + WriteId := I; + Break; + end; + + if WriteId = -1 then + begin + result := 0; + RaiseError(errInternalError, []); + Exit; + end; + end; + + IsDefault := i_IsDefault; + + result := Id; + end; + + with AddRecord do + begin + Kind := KindVAR; + TypeID := PropTypeID; + Host := true; + Shift := 0; + Level := result; + end; +end; + +function TBaseSymbolTable.RegisterInterfaceProperty(LevelId: Integer; + const PropName: String; + PropTypeID, + ReadIndex, + WriteIndex: Integer): Integer; +var + I: Integer; + R: TSymbolRec; + exists: Boolean; +begin + with AddRecord do + begin + Name := PropName; + Count := 0; + Kind := KindPROP; + TypeID := PropTypeID; + Host := true; + Shift := 0; + Level := LevelId; + + result := Id; + + if ReadIndex <= 0 then + ReadId := 0 + else + begin + exists := false; + for I:=Card downto 1 do + begin + R := Records[I]; + if R.Level = LevelId then + if R.MethodIndex = ReadIndex then + begin + ReadId := I; + exists := true; + Break; + end; + end; + + if not exists then + begin + result := 0; + RaiseError(errInternalError, []); + Exit; + end; + end; + + if WriteIndex <= 0 then + WriteId := 0 + else + begin + exists := false; + for I:=Card downto 1 do + begin + R := Records[I]; + if R.Level = LevelId then + if R.MethodIndex = WriteIndex then + begin + WriteId := I; + exists := true; + Break; + end; + end; + + if not exists then + begin + result := 0; + RaiseError(errInternalError, []); + Exit; + end; + end; + end; + + with AddRecord do + begin + Kind := KindVAR; + TypeID := PropTypeID; + Host := true; + Shift := 0; + Level := result; + end; +end; + +function TBaseSymbolTable.RegisterTypeFieldEx(LevelId: Integer; + const Declaration: String; + FieldOffset: Integer = -1): Integer; +var + FieldName, FieldTypeName: String; + FieldTypeId: Integer; +begin + HeaderParser.Init(Declaration, Self, LevelId); + HeaderParser.Call_SCANNER; + FieldName := HeaderParser.Parse_Ident; + HeaderParser.Match(':'); + FieldTypeName := HeaderParser.CurrToken; + FieldTypeId := HeaderParser.LookupId(FieldTypeName); + result := RegisterTypeField(LevelId, FieldName, FieldTypeId, FieldOffset); +end; + +function TBaseSymbolTable.RegisterTypeField(LevelId: Integer; + const FieldName: String; + FieldTypeID: Integer; + FieldOffset: Integer = -1; + ACompIndex: Integer = -1): Integer; +var + J, S: Integer; + DefAlign, CurrAlign, J1, FT, FT1: Integer; + R: TSymbolRec; +begin + with AddRecord do + begin + Name := FieldName; + Kind := KindTYPE_FIELD; + TypeID := FieldTypeId; + Host := true; + Shift := FieldOffset; + Level := LevelId; + + result := - Id; + + CompIndex := ACompIndex; + end; + + Records[FieldTypeId].Completed := true; + + if (FieldOffset = -1) and (ACompIndex = -1) then + begin + S := 0; + if Records[LevelId].IsPacked then + begin + for J:=LevelId + 1 to Card do + begin + R := Records[J]; + + if R = SR0 then + break; + + if (R.Kind = KindTYPE_FIELD) and (R.Level = LevelId) then + begin + R.Shift := S; + Inc(S, R.Size); + end; + end; + end + else + begin + DefAlign := Records[LevelId].DefaultAlignment; + J1 := -1; + + for J:=LevelId + 1 to Card do + begin + R := Records[J]; + + if R = SR0 then + break; + + if (R.Kind = KindTYPE_FIELD) and (R.Level = LevelId) then + begin + CurrAlign := GetAlignmentSize(R.TypeId, DefAlign); + + if J1 > 0 then + begin + FT1 := Records[J-1].FinalTypeId; + FT := R.FinalTypeId; + if FT = FT1 then + begin + CurrAlign := 1; + J1 := -1; + end + else + J1 := J; + end + else + J1 := J; + + if CurrAlign > 1 then + while S mod CurrAlign <> 0 do + Inc(S); + + R.Shift := S; + Inc(S, R.Size); + end; + end; // for-loop + end; + end; +end; + +function TBaseSymbolTable.RegisterVariantRecordTypeField(LevelId: Integer; + const Declaration: String; + VarCnt: Int64): Integer; +var + FieldName: String; +begin + HeaderParser.Init(Declaration, Self, LevelId); + HeaderParser.Call_SCANNER; + FieldName := HeaderParser.Parse_Ident; + result := HeaderParser.Register_VariantRecordTypeField(FieldName, VarCnt); +end; + +function TBaseSymbolTable.RegisterVariantRecordTypeField(LevelId: Integer; + const FieldName: String; + FieldTypeID: Integer; + VarCnt: Int64): Integer; +var + J, S: Integer; + DefAlign, CurrAlign, J1, FT, FT1, VJ, VK, VS: Integer; + VarPathList: TVarPathList; + Path: TVarPath; + R: TSymbolRec; +begin + with AddRecord do + begin + Name := FieldName; + Kind := KindTYPE_FIELD; + TypeID := FieldTypeId; + Host := true; + Level := LevelId; + VarCount := VarCnt; + + result := - Id; + end; + + VarPathList := TVarPathList.Create; + try + for J:=LevelId + 1 to Card do + begin + R := Records[J]; + if R = SR0 then + break; + + if (R.Kind = KindTYPE_FIELD) and (R.Level = LevelId) then + if R.VarCount > 0 then + VarPathList.Add(J, R.VarCount); + end; + + S := 0; + if Records[LevelId].IsPacked then + begin + for J:=LevelId + 1 to Card do + begin + R := Records[J]; + if R = SR0 then + break; + + if (R.Kind = KindTYPE_FIELD) and (R.Level = LevelId) then + begin + if R.VarCount > 0 then + break; + + R.Shift := S; + Inc(S, R.Size); + end; + end; + + // process variant part + + VS := S; + for VK :=0 to VarPathList.Count - 1 do + begin + Path := VarPathList[VK]; + S := VS; + + for VJ := 0 to Path.Count - 1 do + begin + J := Path[VJ].Id; + Records[J].Shift := S; + Inc(S, Records[J].Size); + end; + end; + end + else + begin + DefAlign := Records[LevelId].DefaultAlignment; + J1 := -1; + + for J:=LevelId + 1 to Card do + begin + R := Records[J]; + if R = SR0 then + break; + + if (R.Kind = KindTYPE_FIELD) and (R.Level = LevelId) then + begin + if R.VarCount > 0 then + break; + + CurrAlign := GetAlignmentSize(R.TypeId, DefAlign); + + if J1 > 0 then + begin + FT1 := Records[J-1].FinalTypeId; + FT := R.FinalTypeId; + if FT = FT1 then + begin + CurrAlign := 1; + J1 := -1; + end + else + J1 := J; + end + else + J1 := J; + + if CurrAlign > 1 then + while S mod CurrAlign <> 0 do + Inc(S); + + R.Shift := S; + Inc(S, R.Size); + end; + end; // for-loop + + // process variant part + + VS := S; + for VK :=0 to VarPathList.Count - 1 do + begin + S := VS; + Path := VarPathList[VK]; + + for VJ := 0 to Path.Count - 1 do + begin + J := Path[VJ].Id; + CurrAlign := GetAlignmentSize(Records[J].TypeId, DefAlign); + + if J1 > 0 then + begin + FT1 := Records[J-1].FinalTypeId; + FT := Records[J].FinalTypeId; + if FT = FT1 then + begin + CurrAlign := 1; + J1 := -1; + end + else + J1 := J; + end + else + J1 := J; + + if CurrAlign > 1 then + while S mod CurrAlign <> 0 do + Inc(S); + + Records[J].Shift := S; + Inc(S, Records[J].Size); + end; + end; + end; + + finally + FreeAndNil(VarPathList); + end; +end; + +function TBaseSymbolTable.RegisterVariable(LevelId: Integer; + const Declaration: String; Address: Pointer): Integer; +var + VarName: String; +begin + HeaderParser.Init(Declaration, Self, LevelId); + HeaderParser.Call_SCANNER; + VarName := HeaderParser.Parse_Ident; + result := HeaderParser.Register_Variable(VarName, Address); +end; + +function TBaseSymbolTable.RegisterVariable(LevelId: Integer; const VarName: String; + VarTypeID: Integer; i_Address: Pointer): Integer; +begin + LastCard := Card; + + result := LastShiftValue; + with AddRecord do + begin + Name := VarName; + Kind := KindVAR; + TypeID := VarTypeID; + + Host := true; + Shift := LastShiftValue; + Level := LevelId; + + Address := i_Address; + end; + Inc(LastShiftValue, SizeOfPointer); + + LastVarId := Card; +end; + +function TBaseSymbolTable.RegisterObject(LevelId: Integer; + const ObjectName: String; + TypeId: Integer; + i_Address: Pointer): Integer; +var + X: TObject; + C: TComponent; + I, Offset: Integer; + S, FieldTypeName: String; + FAddress: Pointer; + FieldTypeId: Integer; +begin + if ObjectName = '' then + begin + result := 0; + if i_Address <> nil then + begin + X := TObject(i_Address^); + if X is TComponent then + begin + C := X as TComponent; + for I := 0 to C.ComponentCount - 1 do + begin + S := C.Components[I].Name; + FieldTypeName := C.Components[I].ClassName; + FieldTypeId := LookupType(FieldTypeName, true); + FAddress := C.FieldAddress(S); + if FieldTypeId > 0 then + RegisterObject(LevelId, S, FieldTypeId, FAddress); + end; + end; + end; + Exit; + end; + + result := RegisterVariable(LevelId, ObjectName, TypeId, i_Address); + if i_Address <> nil then + begin + X := TObject(i_Address^); + if X is TComponent then + begin + C := X as TComponent; + for I := 0 to C.ComponentCount - 1 do + begin + S := C.Components[I].Name; + FieldTypeName := C.Components[I].ClassName; + FieldTypeId := LookupType(FieldTypeName, true); + if FieldTypeId > 0 then + begin + FAddress := C.FieldAddress(S); + if FAddress <> nil then + begin + Offset := Integer(FAddress) - Integer(C); + RegisterTypeField(TypeId, S, FieldTypeId, Offset); + end + else + begin + RegisterTypeField(TypeId, S, FieldTypeId, -1, I); + end; + end; + end; + end; + end; +end; + +function TBaseSymbolTable.RegisterVirtualObject(LevelId: Integer; + const ObjectName: String): Integer; +begin + result := RegisterVariable(LevelId, ObjectName, typeVOBJECT, nil); +end; + +procedure TBaseSymbolTable.RegisterMember(LevelId: Integer; const MemberName: String; + i_Address: Pointer); +begin + RegisterVariable(LevelId, MemberName, typeINTEGER, i_Address); +end; + +function TBaseSymbolTable.RegisterConstant(LevelId: Integer; + const Declaration: String): Integer; +var + ConstName: String; +begin + HeaderParser.Init(Declaration, Self, LevelId); + HeaderParser.Call_SCANNER; + ConstName := HeaderParser.Parse_Ident; + result := HeaderParser.Register_Constant(ConstName); +end; + +function TBaseSymbolTable.RegisterConstant(LevelId: Integer; + const i_Name: String; i_TypeID: Integer; const i_Value: Variant): Integer; +var + R: TSymbolRec; + FT: Integer; +{$IFDEF PAX64} + VCardinal: UInt64; +{$ELSE} + VCardinal: Cardinal; +{$ENDIF} + VWideChar: WideChar; +{$IFDEF PAXARM} + VWideString: String; +{$ELSE} + VWideString: WideString; +{$ENDIF} +begin + LastCard := Card; + R := nil; + +{$IFNDEF PAXARM} + if Records[i_TypeID].HasPAnsiCharType then + FT := typePANSICHAR + else +{$ENDIF} + if Records[i_TypeID].HasPWideCharType then + FT := typePWIDECHAR + else + FT := Records[i_TypeID].FinalTypeId; + +{$IFNDEF PAXARM} + if FT = typeANSICHAR then + if Integer(i_Value) > 255 then + begin + FT := -1; + R := AddWideCharConst(Integer(i_Value)); + end; +{$ENDIF} + + if FT <> - 1 then + case FT of + typeENUM: R := AddEnumConst(i_TypeId, Integer(i_Value)); +{$IFNDEF PAXARM} + typeANSICHAR: R := AddAnsiCharConst(AnsiChar(Integer(i_Value))); + typePANSICHAR: R := AddPAnsiCharConst(AnsiString(i_Value)); + typeANSISTRING: R := AddPAnsiCharConst(AnsiString(i_Value)); + typeSHORTSTRING: R := AddShortStringConst(i_Value); +{$ENDIF} + typeWIDECHAR: + begin + VWideString := i_Value; + VWideChar := VWideString[1]; + R := AddWideCharConst(Integer(VWideChar)); + end; + typePWIDECHAR: R := AddPWideCharConst(i_Value); + typeUNICSTRING: R := AddPWideCharConst(i_Value); + typeBYTE: R := AddByteConst(i_Value); + typeWORD: R := AddWordConst(i_Value); + typeINTEGER: + begin + if Abs(i_Value) > MaxInt then + begin + R := AddInt64Const({$IfNDef VARIANTS} integer (i_Value) {$Else} i_Value {$EndIf}); + R.TypeID := typeINTEGER; + end + else + R := AddIntegerConst(i_Value); + end; +{$IFDEF VARIANTS} + typeINT64: R := AddInt64Const(i_Value); +{$ELSE} + typeINT64: R := AddInt64Const(Integer(i_Value)); +{$ENDIF} + + typeCARDINAL: R := AddCardinalConst(i_Value); + typeSMALLINT: R := AddSmallIntConst(i_Value); + typeSHORTINT: R := AddShortIntConst(i_Value); + typeDOUBLE: R := AddDoubleConst(i_Value); + typeSINGLE: R := AddSingleConst(i_Value); + typeEXTENDED: R := AddExtendedConst(i_Value); + typeCURRENCY: R := AddCurrencyConst(i_Value); + typeBOOLEAN: R := AddBooleanConst(i_Value); +{$IFDEF UNIX} + typeBYTEBOOL: R := AddBooleanConst(i_Value); +{$ELSE} + typeBYTEBOOL: R := AddByteBoolConst(ByteBool(Byte(i_Value))); +{$ENDIF} + typeWORDBOOL: R := AddWordBoolConst(i_Value); + typeLONGBOOL: R := AddLongBoolConst(i_Value); + typeVARIANT: R := AddVariantConst(i_Value); + typeOLEVARIANT: R := AddOleVariantConst(i_Value); + typeRECORD: R := AddRecordConst(i_TypeId, i_Value); + typeARRAY: R := AddArrayConst(i_TypeId, i_Value); + typeSET: R := AddSetConst(I_TypeId, i_Value); + typeCLASS: + begin + VCardinal := i_Value; + R := AddClassConst(I_TypeId, TObject(VCardinal)); + end; + typeCLASSREF: + begin + VCardinal := i_Value; + R := AddClassRefConst(I_TypeId, TClass(VCardinal)); + end; + typePOINTER, typeVOID: + begin + VCardinal := i_Value; + R := AddPointerConst(i_TypeId, Pointer(VCardinal)); + end; + else + begin + result := 0; + RaiseError(errIncompatibleTypesNoArgs, []); + Exit; + end; + end; + + R.Level := LevelId; + R.Name := i_Name; +// R.Host := true; + result := R.Id; +end; + +function TBaseSymbolTable.RegisterConstant(LevelId: Integer; + const i_Name: String; const i_Value: Variant): Integer; +var + TypeID: Integer; + VT: Integer; +begin + LastCard := Card; + + VT := VarType(i_Value); + + case VT of + varEmpty: typeId := typeVARIANT; + varBoolean: TypeId := typeBOOLEAN; + varInteger, varByte, varSmallInt: TypeId := typeINTEGER; +{$IFDEF VARIANTS} + varShortInt, varWord, varLongWord: TypeId := typeINTEGER; +{$ENDIF} +{$IFDEF UNIC} + varUString: typeId := typeUNICSTRING; +{$ENDIF} +{$IFNDEF PAXARM} + varString: TypeId := typeANSISTRING; +{$ENDIF} + varDouble: TypeId := typeDOUBLE; + varCurrency: TypeId := typeCURRENCY; + else + begin + result := 0; + RaiseError(errIncompatibleTypesNoArgs, []); + Exit; + end; + end; + result := RegisterConstant(LevelId, i_Name, TypeId, i_Value); +end; + +function TBaseSymbolTable.RegisterPointerConstant(LevelId: Integer; + const i_Name: String; const i_Value: Pointer): Integer; +var + I: IntPax; +begin + I := IntPax(i_Value); + result := RegisterConstant(LevelId, i_Name, typePOINTER, I); +end; + +function TBaseSymbolTable.RegisterExtendedConstant(LevelId: Integer; + const i_Name: String; const i_Value: Extended): Integer; +var + D: Double; +begin + if i_Value > MaxDouble then + D := MaxDouble + else if (i_Value > 0) and (i_Value < MinDouble) then + D := MinDouble + else + D := i_Value; + + result := RegisterConstant(LevelId, i_Name, typeEXTENDED, D); +end; + +function TBaseSymbolTable.RegisterInt64Constant(LevelId: Integer; + const i_Name: String; const i_Value: Int64): Integer; +begin +{$IFDEF VARIANTS} + if Abs(i_Value) >= Abs(MaxInt) then + result := RegisterConstant(LevelId, i_Name, typeINT64, i_Value) + else + result := RegisterConstant(LevelId, i_Name, typeINTEGER, i_Value); +{$ELSE} + result := RegisterConstant(LevelId, i_Name, typeINTEGER, Integer(i_Value)); +{$ENDIF} +end; + +function TBaseSymbolTable.RegisterRoutine(LevelId: Integer; + const SubName: String; ResultTypeID: Integer; + CallConvention: Integer; + i_Address: Pointer; + i_OverCount: Integer = 0; + i_IsDeprecated: Boolean = false): Integer; + +var + SubID: Integer; +begin +{$IFDEF PAX64} + CallConvention := cc64; +{$ENDIF} + result := LastShiftValue; + with AddRecord do + begin + Name := SubName; + Count := 0; + Kind := KindSUB; + TypeID := ResultTypeID; + Host := true; + Shift := LastShiftValue; + Level := LevelId; + CallConv := CallConvention; + IsDeprecated := i_IsDeprecated; + + if not (CallConvention in [ccSTDCALL, ccREGISTER, cc64, + ccCDECL, ccPASCAL, + ccSAFECALL, ccMSFASTCALL]) then + begin + RaiseError(errInternalError, []); + Exit; + end; + + SubId := Id; + + Address := i_Address; + OverCount := i_OverCount; + end; + Inc(LastShiftValue, SizeOfPointer); + + with AddRecord do + begin + Kind := KindVAR; + TypeID := ResultTypeID; + + Host := true; + + Shift := 0; + Level := SubId; + end; + + with AddRecord do + begin + Kind := KindNONE; + Host := true; + Shift := 0; + Level := SubId; + end; + + LastSubId := SubId; +end; + +function TBaseSymbolTable.RegisterRoutine(LevelId: Integer; + const SubName, ResultType: String; + CallConvention: Integer; + i_Address: Pointer; + i_OverCount: Integer = 0; + i_IsDeprecated: Boolean = false): Integer; +var + TypeId: Integer; +begin + TypeId := LookupType(ResultType, true); + if TypeId = 0 then + begin + ExternList.Add(Card + 1, + ResultType, + erTypeId); + end; + result := RegisterRoutine(LevelId, SubName, TypeId, + CallConvention, i_Address, i_OverCount, i_IsDeprecated); +end; + +function TBaseSymbolTable.RestorePositiveIndex(L: Integer): Integer; +var + R: TSymbolRec; + SupportedInterfaces: TGuidList; + I, IntfId, temp: Integer; +begin + R := Records[L]; + SupportedInterfaces := R.SupportedInterfaces; + + result := -1; + + if SupportedInterfaces <> nil then + begin + for I:=0 to SupportedInterfaces.Count - 1 do + begin +// Idx := GuidList.IndexOf(SupportedInterfaces[I].GUID); +// if Idx >= 0 then + begin + IntfId := SupportedInterfaces[I].Id; + temp := FindMaxMethodIndex(IntfId); + if temp > result then + result := temp; + end; + end + end + else + result := 3; +end; + +function TBaseSymbolTable.FindMaxMethodIndex(IntfId: Integer): Integer; +var + I, temp: Integer; + R: TSymbolRec; +begin + result := -1; + for I:= IntfId + 1 to Card do + begin + R := Records[I]; + + if R = SR0 then + break; + if R.Kind = KindNAMESPACE then + break; + + if R.Level = IntfId then + if R.MethodIndex > 0 then + begin + temp := R.MethodIndex; + if temp > result then + result := temp + end; + end; + + if result = -1 then + result := RestorePositiveIndex(IntfId); +end; + +function TBaseSymbolTable.RegisterMethod(LevelId: Integer; + const SubName: String; ResultTypeID: Integer; + CallConvention: Integer; + i_Address: Pointer; + IsShared: Boolean = false; + i_CallMode: Integer = cmNONE; + i_MethodIndex: Integer = 0; + i_OverCount: Integer = 0; + i_IsAbstract: Boolean = false; + i_AbstractMethodCount: Integer = 0; + i_IsDeprecated: Boolean = false): Integer; +var + SubID: Integer; + PositiveIndex: Integer; + NegativeIndex: Integer; + MethodIndex: Integer; + C: TClass; +begin + NegativeIndex := 0; + + if i_MethodIndex < 0 then + begin + NegativeIndex := i_MethodIndex; + + PositiveIndex := RestorePositiveIndex(LevelId); + if PositiveIndex = -1 then + RaiseError(errInternalError, []); + i_MethodIndex := Abs(i_MethodIndex) + PositiveIndex; + end; + + result := LastShiftValue; + with AddRecord do + begin + Name := SubName; + Count := 0; + Kind := KindSUB; + TypeID := ResultTypeID; + Host := true; + Shift := LastShiftValue; + Level := LevelId; + CallConv := CallConvention; +{$IFDEF PAX64} + CallConv := cc64; +{$ENDIF} + IsSharedMethod := IsShared; + + if not (CallConvention in [ccSTDCALL, ccREGISTER, ccCDECL, cc64, + ccPASCAL, ccSAFECALL, ccMSFASTCALL]) then + begin + RaiseError(errInternalError, []); + Exit; + end; + + SubId := Id; + + Address := i_Address; + CallMode := i_CallMode; + MethodIndex := i_MethodIndex; + NegativeMethodIndex := NegativeIndex; + OverCount := i_OverCount; + IsDeprecated := i_IsDeprecated; + end; + + Inc(LastShiftValue, SizeOfPointer); + + with AddRecord do + begin + Kind := KindVAR; + TypeID := ResultTypeID; + + Host := true; + + Shift := 0; + Level := SubId; + end; + + with AddRecord do + begin + Kind := KindNONE; + Host := true; + Shift := 0; + Level := SubId; + end; + + LastSubId := SubId; + + if i_CallMode = cmNONE then + Exit; + + C := Records[LevelId].PClass; + if C <> nil then + begin + MethodIndex := VirtualMethodIndex(C, i_Address) + 1; + if MethodIndex > 0 then + begin + Records[LastSubId].MethodIndex := MethodIndex; + end; + + if i_IsAbstract then + begin + Records[LastSubId].CallMode := cmVIRTUAL; + if i_MethodIndex > 0 then + HeaderParser.AbstractMethodCount := i_MethodIndex; + Records[LastSubId].MethodIndex := + GetAbstractMethodIndex(C, i_AbstractMethodCount, i_Address) + 1; + end; + + if i_CallMode in [cmDYNAMIC, cmOVERRIDE] then + Records[LastSubId].DynamicMethodIndex := + GetDynamicMethodIndexByAddress(C, i_Address); + end; + +end; + +function TBaseSymbolTable.RegisterMethod(LevelId: Integer; + const SubName, ResultType: String; + CallConvention: Integer; + i_Address: Pointer; + IsShared: Boolean = false; + i_CallMode: Integer = cmNONE; + i_MethodIndex: Integer = 0; + i_OverCount: Integer = 0; + i_IsAbstract: Boolean = false; + i_AbstractMethodCount: Integer = 0; + i_IsDeprecated: Boolean = false): Integer; +var + TypeId: Integer; +begin + TypeId := LookupType(ResultType, true); + if TypeId = 0 then + begin + ExternList.Add(Card + 1, + ResultType, + erTypeId); + end; + + result := RegisterMethod(LevelId, SubName, TypeId, CallConvention, i_Address, + IsShared, i_CallMode, i_MethodIndex, i_OverCount, + i_IsAbstract, i_AbstractMethodCount, i_IsDeprecated); +end; + +function TBaseSymbolTable.RegisterConstructor(LevelId: Integer; + const SubName: String; + i_Address: Pointer; + IsShared: Boolean = false; + i_CallMode: Integer = cmNONE; + i_MethodIndex: Integer = 0; + i_OverCount: Integer = 0; + i_IsAbstract: Boolean = false; + i_AbstractMethodCount: Integer = 0; + i_IsDeprecated: Boolean = false): Integer; +var + SubID, MethodIndex: Integer; + C: TClass; +begin + result := LastShiftValue; + with AddRecord do + begin + Name := SubName; + Count := 0; + Kind := KindCONSTRUCTOR; + TypeID := LevelID; + Host := true; + Shift := LastShiftValue; + Level := LevelId; + CallConv := ccREGISTER; + IsSharedMethod := IsShared; + +{$IFDEF PAX64} + CallConv := cc64; +{$ENDIF} + + SubId := Id; + + Address := i_Address; + CallMode := i_CallMode; + OverCount := i_OverCount; + IsDeprecated := i_IsDeprecated; + end; + Inc(LastShiftValue, SizeOfPointer); + + with AddRecord do + begin + Kind := KindVAR; + TypeID := LevelID; + Host := true; + Shift := 0; + Level := SubId; + end; + + with AddRecord do + begin + Kind := KindNONE; + Host := true; + Shift := 0; + Level := SubId; + end; + + LastSubId := SubId; + + if i_CallMode = cmNONE then + Exit; + + C := Records[LevelId].PClass; + if C <> nil then + begin + MethodIndex := VirtualMethodIndex(C, i_Address) + 1; + if MethodIndex > 0 then + Records[LastSubId].MethodIndex := MethodIndex; + + if HeaderParser.IsAbstract then + begin + Records[LastSubId].CallMode := cmVIRTUAL; + if i_MethodIndex > 0 then + HeaderParser.AbstractMethodCount := i_MethodIndex; + Records[LastSubId].MethodIndex := + GetAbstractMethodIndex(C, i_AbstractMethodCount) + 1; + end; + end; +end; + +function TBaseSymbolTable.RegisterDestructor(LevelId: Integer; + const SubName: String; + i_Address: Pointer; + i_CallMode: Integer = cmVIRTUAL): Integer; +var + SubID: Integer; +begin + result := LastShiftValue; + with AddRecord do + begin + Name := SubName; + Count := 0; + Kind := KindDESTRUCTOR; + TypeID := typeVOID; + Host := true; + Shift := LastShiftValue; + Level := LevelId; + CallConv := ccREGISTER; +{$IFDEF PAX64} + CallConv := cc64; +{$ENDIF} + + SubId := Id; + + Address := i_Address; + CallMode := i_CallMode; + end; + + Inc(LastShiftValue, SizeOfPointer); + + with AddRecord do + begin + Kind := KindVAR; + TypeID := LevelID; + Host := true; + Shift := 0; + Level := SubId; + end; + + with AddRecord do + begin + Kind := KindNONE; + Host := true; + Shift := 0; + Level := SubId; + end; + + LastSubId := SubId; +end; + +function TBaseSymbolTable.RegisterFakeHeader(LevelId: Integer; + const Header: String; Address: Pointer): Integer; +begin + result := RegisterHeader(LevelId, Header, Address); + Records[LastSubId].IsFakeMethod := true; +end; + +function TBaseSymbolTable.RegisterHeader(LevelId: Integer; + const Header: String; Address: Pointer; + AMethodIndex: Integer = 0): Integer; +var + TypeId, I, J, L, P, ElemTypeId, SubId, ReadId, WriteId, PropId: Integer; + IsMethod: Boolean; + ParamMod: TParamMod; + S: String; + Tag: Integer; + OverList: TIntegerList; + OpenArray: Boolean; + AncestorId: Integer; + OverCount: Integer; +label + label_params; +begin + LastCard := Card; + + result := 0; + + HeaderParser.Init(Header, Self, LevelId); + if not HeaderParser.Parse then + begin + if RaiseE then + raise Exception.Create(errSyntaxError); + + REG_OK := false; + Exit; + end; +{$IFDEF PAX64} + HeaderParser.CC := cc64; +{$ENDIF} + + IsMethod := (LevelId > 0) and (Records[LevelId].Kind = KindTYPE); + + if IsMethod then + begin + L := Records[LevelId].Level; + end + else + L := LevelId; + + if HeaderParser.IsProperty then + begin + if (HeaderParser.ReadIdent = '') and (HeaderParser.ReadIdent = '') then + if LevelId > 0 then + if Records[LevelId].FinalTypeId = typeCLASS then + begin + AncestorId := Records[LevelId].AncestorId; + while AncestorId > 0 do + begin + PropId := Lookup(HeaderParser.Name, AncestorId, true); + if PropId = 0 then + break; + if Records[PropId].Kind <> KindPROP then + break; + if (Records[PropId].ReadId <> 0) or (Records[PropId].WriteId <> 0) then + begin + HeaderParser.ReadIdent := Records[Records[PropId].ReadId].Name; + HeaderParser.WriteIdent := Records[Records[PropId].WriteId].Name; + break; + end + else + AncestorId := Records[AncestorId].AncestorId; + end; + end; + + if HeaderParser.ReadIdent <> '' then + begin + ReadId := Lookup(HeaderParser.ReadIdent, LevelId, true); + if ReadId > 0 then + begin + if Records[ReadId].Kind = KindTYPE_FIELD then + ReadId := - ReadId + else + ReadId := Records[ReadId].Shift; + end + else + RaiseError(errUndeclaredIdentifier, [HeaderParser.ReadIdent]); + end + else + ReadId := 0; + + if HeaderParser.WriteIdent <> '' then + begin + WriteId := Lookup(HeaderParser.WriteIdent, LevelId, true); + if WriteId > 0 then + begin + if Records[WriteId].Kind = KindTYPE_FIELD then + WriteId := - WriteId + else + WriteId := Records[WriteId].Shift; + end + else + RaiseError(errUndeclaredIdentifier, [HeaderParser.WriteIdent]); + end + else + WriteId := 0; + +{ + if HeaderParser.ResType = '' then + begin + PropId := Lookup(HeaderParser.Name, LevelId, true); + + if PropId = 0 then + ExternList.Add(0, + Records[LevelId].FullName + '.' + HeaderParser.ResType, + ePropertyInBaseClassId); + Exit; + end; +} + TypeId := LookupType(HeaderParser.ResType, L, true); + + if TypeId = 0 then + ExternList.Add(Card + 1, + HeaderParser.ResType, + erTypeId); + + if (HeaderParser.ReadIdent <> '') and (ReadId = 0) then + ExternList.Add(Card + 1, + Records[LevelId].FullName + '.' + HeaderParser.ReadIdent, + erReadId); + + if (HeaderParser.WriteIdent <> '') and (WriteId = 0) then + ExternList.Add(Card + 1, + Records[LevelId].FullName + '.' + HeaderParser.WriteIdent, + erWriteId); + + result := RegisterProperty(LevelId, HeaderParser.Name, + TypeId, ReadId, WriteId, HeaderParser.IsDefault); +{$IFDEF DRTTI} + goto label_Params; +{$ENDIF} + + Exit; + end; + + if HeaderParser.IsOverloaded then + begin + OverList := LookupAll(HeaderParser.Name, LevelId, true); + OverCount := OverList.Count; + FreeAndNil(OverList); + end + else + OverCount := 0; + + case HeaderParser.KS of + ksPROCEDURE: + begin + if IsMethod then + result := RegisterMethod(LevelId, + HeaderParser.Name, + TypeVOID, + HeaderParser.CC, + Address, + HeaderParser.IsShared, + HeaderParser.CallMode, + AMethodIndex, + OverCount, + HeaderParser.IsAbstract, + HeaderParser.AbstractMethodCount, + HeaderParser.IsDeprecated) + else + result := RegisterRoutine(LevelId, HeaderParser.Name, TypeVOID, HeaderParser.CC, + Address, OverCount, HeaderParser.IsDeprecated); + end; + ksFUNCTION: + begin + TypeId := LookupType(HeaderParser.ResType, L, true); + if TypeId = 0 then + begin + ExternList.Add(Card + 1, + HeaderParser.ResType, + erTypeId); + end; + if IsMethod then + result := RegisterMethod(LevelId, + HeaderParser.Name, + TypeId, + HeaderParser.CC, + Address, + HeaderParser.IsShared, + HeaderParser.CallMode, + AMethodIndex, + OverCount, + HeaderParser.IsAbstract, + HeaderParser.AbstractMethodCount, + HeaderParser.IsDeprecated) + else + result := RegisterRoutine(LevelId, HeaderParser.Name, TypeId, HeaderParser.CC, + Address, OverCount, HeaderParser.IsDeprecated); + end; + ksCONSTRUCTOR: + begin + result := RegisterConstructor(LevelId, + HeaderParser.Name, + Address, + HeaderParser.IsShared, + HeaderParser.CallMode, + AMethodIndex, + OverCount, + HeaderParser.IsAbstract, + HeaderParser.AbstractMethodCount, + HeaderParser.IsDeprecated); + end; + ksDESTRUCTOR: + begin + result := RegisterMethod(LevelId, + HeaderParser.Name, + TypeVOID, + HeaderParser.CC, + Address, + false, + HeaderParser.CallMode, + 0); + Records[LastSubId].Kind := kindDESTRUCTOR; + end; + end; + +Label_Params: + + for I:=1 to HeaderParser.NP do + begin + OpenArray := false; + S := HeaderParser.Types[I]; + TypeId := LookupType(S, L, true); + if TypeId = 0 then + begin + P := Pos('ARRAY OF ', S); + if P = 1 then + begin + OpenArray := true; + + Delete(S, 1, 9); + if StrEql(S, 'CONST') then + ElemTypeId := H_TVarRec + else + ElemTypeId := LookupType(S, L, true); + + if ElemTypeId = 0 then + begin + ExternList.Add(Card + 1, + S, + erPatternId); + end; + + SubId := -1; + for J:=Card downto 1 do + if Records[J].Shift = result then + begin + SubId := J; + Break; + end; + + if SubId = -1 then + begin + RaiseError(errInternalError, []); + Exit; + end; + + TypeId := RegisterOpenArrayType(SubId, 'T' + S + 'Array', ElemTypeId); + end + else + begin + ExternList.Add(Card + 1, + S, + erTypeId); + end; + end; + + ParamMod := HeaderParser.Mods[I]; + + Tag := 0; + if HeaderParser.Optionals[I] then + Tag := 1; + + if ParamMod in [pmByRef, pmOut] then + begin + RegisterParameter(result, TypeId, HeaderParser.Values[I], true, HeaderParser.Params[I], Tag); + if ParamMod = pmOut then + Records[Card].IsOut := true; + end + else if ParamMod = pmConst then + begin + RegisterParameter(result, TypeId, HeaderParser.Values[I], false, HeaderParser.Params[I], Tag); + Records[Card].IsConst := true; + end + else + begin + RegisterParameter(result, TypeId, HeaderParser.Values[I], false, HeaderParser.Params[I], Tag); + end; + + if OpenArray then + Records[Card].IsOpenArray := true; + + if HeaderParser.Optionals[I] then + Records[Card].DefVal := HeaderParser.DefVals[I]; + end; +end; + +procedure TBaseSymbolTable.RegisterRunnerParameter(HSub: Integer); +var + I, SubId: Integer; + R: TSymbolRec; +begin + SubId := -1; + for I:=Card downto 1 do + begin + R := Records[I]; + + if R.Kind = KindPROP then + begin + SubId := I; + Break; + end; + + if R.Kind in KindSUBS then + if R.Shift = HSub then + begin + SubId := I; + Break; + end; + end; + + if SubId = -1 then + begin + RaiseError(errInternalError, []); + Exit; + end; + + Records[SubId].RunnerParameter := true; +end; + +function TBaseSymbolTable.RegisterParameter(HSub: Integer; + const ParameterName: String; + ParamTypeID: Integer; + ParamMod: Integer = 0; + Optional: Boolean = false; + const DefaultValue: String = ''): Integer; +var + pm: TParamMod; + Value: Variant; + Tag: Integer; + OpenArray: Boolean; + ParamTypeName: String; + FT, IntVal, DoubleVal, Code1: Integer; +begin + Tag := 0; + + pm := TParamMod(ParamMod); + ParamTypeName := Records[ParamTypeId].Name; + OpenArray := Pos('DYNARRAY_', ParamTypeName) = 1; + + if Optional then + begin + Tag := 1; + FT := Records[ParamTypeId].FinalTypeId; + if FT in IntegerTypes then + begin + Val(DefaultValue, IntVal, Code1); + Value := IntVal; + end + else if FT in RealTypes then + begin + Val(DefaultValue, DoubleVal, Code1); + Value := DoubleVal; + end + else + Value := DefaultValue; + end; + + if pm in [pmByRef, pmOut] then + begin + result := RegisterParameter(HSub, ParamTypeId, Value, true, ParameterName); + if pm = pmOut then + Records[Card].IsOut := true; + end + else if pm = pmConst then + begin + result := RegisterParameter(HSub, ParamTypeId, Value, false, ParameterName, Tag); + Records[Card].IsConst := true; + end + else + begin + result := RegisterParameter(HSub, ParamTypeId, Value, false, ParameterName, Tag); + end; + + if OpenArray then + Records[Card].IsOpenArray := true; +end; + +function TBaseSymbolTable.RegisterParameter(HSub: Integer; + const ParameterName: String; + const ParameterType: String; + ParamMod: Integer = 0; + Optional: Boolean = false; + const DefaultValue: String = ''): Integer; +var + ParamTypeId: Integer; +begin + ParamTypeId := LookupType(ParameterType, true); + result := RegisterParameter(Hsub, ParameterName, ParamTypeId, ParamMod, Optional, + DefaultValue); + if ParamTypeId = 0 then + ExternList.Add(Card, + ParameterType, + erTypeId); +end; + +function TBaseSymbolTable.RegisterParameter(HSub: Integer; ParamTypeID: Integer; + const DefaultValue: Variant; + InitByRef: Boolean = false; + ParameterName: String = ''; + Tag: Integer = 0): Integer; +var + I, SubId: Integer; + R: TSymbolRec; +begin + result := LastShiftValue; + + SubId := -1; + for I:=Card downto 1 do + begin + R := Records[I]; + + if R.Kind = KindPROP then + begin + SubId := I; + Break; + end; + + if R.Kind in KindSUBS then + if R.Shift = HSub then + begin + SubId := I; + Break; + end; + end; + + if SubId = -1 then + begin + RaiseError(errInternalError, []); + Exit; + end; + + Records[SubId].Count := Records[SubId].Count + 1; + + with AddRecord do + begin + Kind := KindVAR; + TypeID := ParamTypeId; + + Host := true; + Param := true; + Shift := 0; + Level := SubId; + ByRef := InitByRef; + Value := DefaultValue; + Optional := VarType(Value) <> varEmpty; + + Name := ParameterName; + + if Tag = 1 then + Optional := true; + + if InitByRef and Optional then + RaiseError(errDefaultParameterMustBeByValueOrConst, [Name]); + end; +end; + +function TBaseSymbolTable.IsResultId(Id: Integer): Boolean; +var + L: Integer; +begin + result := false; + if Id = 0 then + Exit; + L := Records[Id].Level; + if L = 0 then + Exit; + if Records[L].Kind in KindSUBS then + result := GetResultId(L) = Id; +end; + +function TBaseSymbolTable.GetResultId(SubId: Integer): Integer; +begin + result := SubId + 1; +end; + +function TBaseSymbolTable.GetSelfId(SubId: Integer): Integer; +begin + result := SubId + 2; +end; + +function TBaseSymbolTable.GetDl_Id(SubId: Integer): Integer; +var + I: Integer; +begin + result := 0; + for I:=SubId + 3 to Card do + if Records[I].Level = SubId then + if Records[I].Name = '%DL' then + begin + result := I; + Exit; + end; + RaiseError(errInternalError, []); +end; + +function TBaseSymbolTable.GetRBP_Id(SubId: Integer): Integer; +var + I: Integer; +begin + result := 0; + for I:=SubId + 3 to Card do + if Records[I].Level = SubId then + if Records[I].Name = '%RBP' then + begin + result := I; + Exit; + end; + RaiseError(errInternalError, []); +end; + +function TBaseSymbolTable.GetRBX_Id(SubId: Integer): Integer; +var + I: Integer; +begin + result := 0; + for I:=SubId + 3 to Card do + if Records[I].Level = SubId then + if Records[I].Name = '%RBX' then + begin + result := I; + Exit; + end; + RaiseError(errInternalError, []); +end; + +function TBaseSymbolTable.GetRDI_Id(SubId: Integer): Integer; +var + I: Integer; +begin + result := 0; + for I:=SubId + 3 to Card do + if Records[I].Level = SubId then + if Records[I].Name = '%RDI' then + begin + result := I; + Exit; + end; + RaiseError(errInternalError, []); +end; + +function TBaseSymbolTable.GetParamId(SubId, ParamNumber: Integer): Integer; +var + I, K, D: Integer; + RI: TSymbolRec; +begin + result := -1; + K := -1; + D := 3; + if Records[SubId].Kind = kindPROP then + D := 1; + for I:=SubId + D to Card do + begin + RI := Records[I]; + if RI.Param and (RI.Level = SubId) then + begin + Inc(K); + if K = ParamNumber then + begin + result := I; + Exit; + end; + end; + end; + RaiseError(errInvalidIndex, [ParamNumber]); +end; + +function TBaseSymbolTable.GetRecord(I: Integer): TSymbolRec; +begin + result := TSymbolRec(A[I]); +end; + +function TBaseSymbolTable.AddRecord: TSymbolRec; +var + AK: Integer; +begin + AK := A.Count; + + if (Card = AK - 1) or (Card >= FirstLocalId) then + begin + Inc(Card); + result := TSymbolRec.Create(Self); + result.Id := Card; + A.Add(result); + end + else + begin + Inc(Card); + result := Records[Card]; + end; +end; + +procedure TBaseSymbolTable.RemoveLastRecord; +var + AK: Integer; + R: TSymbolRec; + S: String; +begin + R := Records[Card]; + S := R.Name; + if S <> '' then + HashArray.DeleteName(S, R.Id); + + AK := A.Count; + if (Card = AK - 1) or (Card >= FirstLocalId) then + begin +{$IFDEF ARC} + A[AK - 1] := nil; +{$ELSE} + TObject(A[AK - 1]).Free; +{$ENDIF} + A.Delete(AK - 1); + end; + Dec(Card); +end; + +function TBaseSymbolTable.CreateEmptySet: TSymbolRec; +var + T: Integer; +begin + T := RegisterSetType(0, '$$', typeVOID); + + result := AddRecord; + result.Kind := kindCONST; + result.TypeId := T; + result.Value := 0; + result.Level := 0; + + result.Shift := LastShiftValue; + result.FinSize := 32; + Inc(LastShiftValue, result.FinSize); +end; + +function TBaseSymbolTable.AddIntegerConst(Value: Integer): TSymbolRec; +begin + result := AddRecord; + result.Kind := kindCONST; + result.TypeId := typeINTEGER; + result.Value := Value; + result.Level := 0; +end; + +function TBaseSymbolTable.AddCardinalConst(Value: Cardinal): TSymbolRec; +begin + result := AddRecord; + result.Kind := kindCONST; + result.TypeId := typeCARDINAL; +{$IFDEF VARIANTS} + result.Value := Value; +{$ELSE} + result.Value := Integer(Value); +{$ENDIF} + result.Level := 0; +end; + +function TBaseSymbolTable.AddSmallIntConst(Value: SmallInt): TSymbolRec; +begin + result := AddRecord; + result.Kind := kindCONST; + result.TypeId := typeSMALLINT; + result.Value := Value; + result.Level := 0; +end; + +function TBaseSymbolTable.AddShortIntConst(Value: ShortInt): TSymbolRec; +begin + result := AddRecord; + result.Kind := kindCONST; + result.TypeId := typeSHORTINT; + result.Value := Value; + result.Level := 0; +end; + +{$IFDEF VARIANTS} +function TBaseSymbolTable.AddInt64Const(Value: Int64): TSymbolRec; +begin + result := AddRecord; + result.Kind := kindCONST; + result.TypeId := typeINT64; + result.Value := Value; + result.Level := 0; + + result.Shift := LastShiftValue; + result.FinSize := SizeOf(Int64); + Inc(LastShiftValue, result.FinSize); +end; +function TBaseSymbolTable.AddUInt64Const(Value: UInt64): TSymbolRec; +begin + result := AddRecord; + result.Kind := kindCONST; + result.TypeId := typeUINT64; + result.Value := Value; + result.Level := 0; + + result.Shift := LastShiftValue; + result.FinSize := SizeOf(UInt64); + Inc(LastShiftValue, result.FinSize); +end; +{$ELSE} +function TBaseSymbolTable.AddInt64Const(Value: Int64): TSymbolRec; +begin + result := AddRecord; + result.Kind := kindCONST; + result.TypeId := typeINT64; + result.Value := Integer(Value); + result.Level := 0; + + result.Shift := LastShiftValue; + result.FinSize := SizeOf(Int64); + Inc(LastShiftValue, result.FinSize); +end; +function TBaseSymbolTable.AddUInt64Const(Value: UInt64): TSymbolRec; +begin + result := AddRecord; + result.Kind := kindCONST; + result.TypeId := typeUINT64; + result.Value := Integer(Value); + result.Level := 0; + + result.Shift := LastShiftValue; + result.FinSize := SizeOf(UInt64); + Inc(LastShiftValue, result.FinSize); +end; +{$ENDIF} + +function TBaseSymbolTable.AddEnumConst(TypeId, Value: Integer): TSymbolRec; +begin + result := AddRecord; + result.Kind := kindCONST; + result.TypeId := TypeId; + result.Value := Value; + result.Level := 0; +end; + +function TBaseSymbolTable.AddPointerConst(TypeId: Integer; Value: Pointer): TSymbolRec; +begin + result := AddRecord; + result.Kind := kindCONST; + result.TypeId := TypeId; +{$IFDEF VARIANTS} + result.Value := Cardinal(Value); +{$ELSE} + result.Value := Integer(Value); +{$ENDIF} + result.Level := 0; +end; + +function TBaseSymbolTable.AddRecordConst(TypeId: Integer; const Value: Variant): TSymbolRec; +begin + result := AddRecord; + result.Kind := kindCONST; + result.TypeId := TypeId; + result.Value := Value; + result.Level := 0; +end; + +function TBaseSymbolTable.AddArrayConst(TypeId: Integer; const Value: Variant): TSymbolRec; +begin + result := AddRecord; + result.Kind := kindCONST; + result.TypeId := TypeId; + result.Value := Value; + result.Level := 0; +end; + +function TBaseSymbolTable.AddSetConst(TypeId: Integer; const Value: Variant): TSymbolRec; +begin + result := AddRecord; + result.Kind := kindCONST; + result.TypeId := TypeId; + result.Value := Value; + result.Level := 0; + +// result.Shift := LastShiftValue; +// Records[TypeId].Completed := true; +// Inc(LastShiftValue, Records[result.Id].Size); +end; + +function TBaseSymbolTable.AddClassConst(TypeId: Integer; Value: TObject): TSymbolRec; +begin + result := AddRecord; + result.Kind := kindCONST; + result.TypeId := TypeId; + result.Value := Integer(Value); + result.Level := 0; + result.MustBeAllocated := true; +end; + +function TBaseSymbolTable.AddClassRefConst(TypeId: Integer; Value: TClass): TSymbolRec; +begin + result := AddRecord; + result.Kind := kindCONST; + result.TypeId := TypeId; + result.Value := Integer(Value); + result.Level := 0; + result.MustBeAllocated := true; +end; + +function TBaseSymbolTable.AddSetVar(TypeId: Integer; const Value: Variant): TSymbolRec; +begin + result := AddRecord; + result.Kind := kindVAR; + result.TypeId := TypeId; + result.Value := Value; + result.Level := 0; + +// result.Shift := LastShiftValue; +// Records[TypeId].Completed := true; +// Inc(LastShiftValue, Records[result.Id].Size); +end; + +{$IFNDEF PAXARM} +function TBaseSymbolTable.AddAnsiCharConst(Value: AnsiChar): TSymbolRec; +begin + result := AddRecord; + result.Kind := kindCONST; + result.TypeId := typeANSICHAR; + result.Value := Ord(Value); + result.Level := 0; +end; +{$ENDIF} + +function TBaseSymbolTable.AddWideCharConst(Value: Integer): TSymbolRec; +begin + result := AddRecord; + result.Kind := kindCONST; + result.TypeId := typeWIDECHAR; + result.Value := Value; + result.Level := 0; +end; + +{$IFNDEF PAXARM} +function TBaseSymbolTable.AddPAnsiCharConst(const Value: AnsiString): TSymbolRec; +var + SZ: Integer; +begin + result := AddRecord; + result.Kind := kindCONST; + result.TypeId := typePANSICHAR; + result.Value := Value; + result.Level := 0; + + SZ := 0; + Inc(SZ, SizeOfPointer); // pointer to string literal + Inc(SZ, SizeOfPointer); // ref counter + Inc(SZ, SizeOfPointer); // length + // reserve place for literal + Inc(SZ, Length(Value) + 1); + + result.Shift := LastShiftValue; + Inc(LastShiftValue, SZ); +end; + +function TBaseSymbolTable.AddShortStringConst(const Value: String): TSymbolRec; +begin + result := AddRecord; + result.Kind := kindCONST; + result.TypeId := typeSHORTSTRING; + result.Value := Value; + result.Level := 0; +end; +{$ENDIF} + +{$IFDEF PAXARM} +function TBaseSymbolTable.AddPWideCharConst(const Value: String): TSymbolRec; +{$ELSE} +function TBaseSymbolTable.AddPWideCharConst(const Value: WideString): TSymbolRec; +{$ENDIF} +var + SZ: Integer; +begin + result := AddRecord; + result.Kind := kindCONST; + result.TypeId := typePWIDECHAR; + result.Value := Value; + result.Level := 0; + + SZ := 0; + Inc(SZ, SizeOfPointer); // pointer to string literal + Inc(SZ, SizeOfPointer); // length + + // reserve place for literal + Inc(SZ, Length(Value) * 2 + 2); + + result.Shift := LastShiftValue; + Inc(LastShiftValue, SZ); +end; + +function TBaseSymbolTable.AddByteConst(Value: Byte): TSymbolRec; +begin + result := AddRecord; + result.Kind := kindCONST; + result.TypeId := typeBYTE; + result.Value := Ord(Value); + result.Level := 0; +end; + +function TBaseSymbolTable.AddWordConst(Value: Word): TSymbolRec; +begin + result := AddRecord; + result.Kind := kindCONST; + result.TypeId := typeWORD; + result.Value := Ord(Value); + result.Level := 0; +end; + +function TBaseSymbolTable.AddBooleanConst(Value: Boolean): TSymbolRec; +begin + result := AddRecord; + result.Kind := kindCONST; + result.TypeId := typeBOOLEAN; + result.Value := Value; + result.Level := 0; +end; + +function TBaseSymbolTable.AddByteBoolConst(Value: ByteBool): TSymbolRec; +begin + result := AddRecord; + result.Kind := kindCONST; + result.TypeId := typeBYTEBOOL; + if Value then + result.Value := $ff + else + result.Value := 0; + result.Level := 0; +end; + +function TBaseSymbolTable.AddWordBoolConst(Value: WordBool): TSymbolRec; +begin + result := AddRecord; + result.Kind := kindCONST; + result.TypeId := typeWORDBOOL; + if Value then + result.Value := $ffff + else + result.Value := 0; + result.Level := 0; +end; + +function TBaseSymbolTable.AddLongBoolConst(Value: LongBool): TSymbolRec; +begin + result := AddRecord; + result.Kind := kindCONST; + result.TypeId := typeLONGBOOL; + if Value then + result.Value := $ffffffff + else + result.Value := 0; + result.Level := 0; +end; + +function TBaseSymbolTable.AddDoubleConst(Value: Double): TSymbolRec; +begin + result := AddRecord; + result.Kind := kindCONST; + result.TypeId := typeDOUBLE; + result.Value := Value; + result.Level := 0; + + result.Shift := LastShiftValue; + result.FinSize := SizeOf(Double); + Inc(LastShiftValue, result.FinSize); +end; + +function TBaseSymbolTable.AddCurrencyConst(Value: Double): TSymbolRec; +begin + result := AddRecord; + result.Kind := kindCONST; + result.TypeId := typeCURRENCY; + result.Value := Value; + result.Level := 0; + + result.Shift := LastShiftValue; + result.FinSize := SizeOf(Currency); + Inc(LastShiftValue, result.FinSize); +end; + +function TBaseSymbolTable.AddSingleConst(Value: Single): TSymbolRec; +begin + result := AddRecord; + result.Kind := kindCONST; + result.TypeId := typeSINGLE; + result.Value := Value; + result.Level := 0; + + result.Shift := LastShiftValue; + result.FinSize := SizeOf(Single); + Inc(LastShiftValue, result.FinSize); +end; + +function TBaseSymbolTable.AddExtendedConst(Value: Extended): TSymbolRec; +begin + result := AddRecord; + result.Kind := kindCONST; + result.TypeId := typeEXTENDED; + result.Value := Value; + result.Level := 0; + + result.Shift := LastShiftValue; + result.FinSize := SizeOf(Extended); + Inc(LastShiftValue, result.FinSize); +end; + +function TBaseSymbolTable.AddVariantConst(const Value: Variant): TSymbolRec; +begin + result := AddRecord; + result.Kind := kindCONST; + result.TypeId := typeVARIANT; + result.SetVariantValue(Value); + result.Level := 0; + + result.Shift := LastShiftValue; + result.FinSize := SizeOf(Variant); + Inc(LastShiftValue, result.FinSize); +end; + +function TBaseSymbolTable.AddOleVariantConst(const Value: OleVariant): TSymbolRec; +begin + result := AddRecord; + result.Kind := kindCONST; + result.TypeId := typeOLEVARIANT; + result.SetVariantValue(Value); + result.Level := 0; + + result.Shift := LastShiftValue; + result.FinSize := SizeOf(OleVariant); + Inc(LastShiftValue, result.FinSize); +end; + +function TBaseSymbolTable.AddTMethodVar(Level: Integer): TSymbolRec; +begin + result := AddRecord; + result.Kind := kindVAR; + result.TypeId := H_TMethod; + result.Value := 0.0; + result.Level := Level; + + result.Shift := LastShiftValue; + result.FinSize := SizeOfTMethod; + Inc(LastShiftValue, result.FinSize); +end; + +function TBaseSymbolTable.AddDoubleVar(Level: Integer): TSymbolRec; +begin + result := AddRecord; + result.Kind := kindVAR; + result.TypeId := typeDOUBLE; + result.Value := 0.0; + result.Level := Level; + + result.Shift := LastShiftValue; + result.FinSize := SizeOf(Double); + Inc(LastShiftValue, result.FinSize); +end; + +function TBaseSymbolTable.AddCurrencyVar(Level: Integer): TSymbolRec; +begin + result := AddRecord; + result.Kind := kindVAR; + result.TypeId := typeCURRENCY; + result.Value := 0.0; + result.Level := Level; + + result.Shift := LastShiftValue; + result.FinSize := SizeOf(Currency); + Inc(LastShiftValue, result.FinSize); +end; + +function TBaseSymbolTable.AddSingleVar(Level: Integer): TSymbolRec; +begin + result := AddRecord; + result.Kind := kindVAR; + result.TypeId := typeSINGLE; + result.Value := 0.0; + result.Level := Level; + + result.Shift := LastShiftValue; + result.FinSize := SizeOf(Single); + Inc(LastShiftValue, result.FinSize); +end; + +function TBaseSymbolTable.AddExtendedVar(Level: Integer): TSymbolRec; +begin + result := AddRecord; + result.Kind := kindVAR; + result.TypeId := typeEXTENDED; + result.Value := 0.0; + result.Level := Level; + + result.Shift := LastShiftValue; + result.FinSize := SizeOf(Extended); + Inc(LastShiftValue, result.FinSize); +end; + +function TBaseSymbolTable.AddInt64Var(Level: Integer): TSymbolRec; +begin + result := AddRecord; + result.Kind := kindVAR; + result.TypeId := typeINT64; + result.Value := 0; + result.Level := Level; + + result.Shift := LastShiftValue; + result.FinSize := SizeOf(Int64); + Inc(LastShiftValue, result.FinSize); +end; + +function TBaseSymbolTable.AddUInt64Var(Level: Integer): TSymbolRec; +begin + result := AddRecord; + result.Kind := kindVAR; + result.TypeId := typeUINT64; + result.Value := 0; + result.Level := Level; + + result.Shift := LastShiftValue; + result.FinSize := SizeOf(UInt64); + Inc(LastShiftValue, result.FinSize); +end; + +{$IFNDEF PAXARM} +function TBaseSymbolTable.AddStringVar(Level: Integer): TSymbolRec; +begin + result := AddRecord; + result.Kind := kindVAR; + result.TypeId := typeANSISTRING; + result.Value := ''; + result.Level := Level; + result.Name := '@'; + + result.Shift := LastShiftValue; + result.FinSize := SizeOf(String); + Inc(LastShiftValue, result.FinSize); +end; +{$ENDIF} + +function TBaseSymbolTable.AddInterfaceVar(Level: Integer): TSymbolRec; +begin + result := AddRecord; + result.Kind := kindVAR; + result.TypeId := H_IUnknown; + result.Level := Level; + result.Name := '@'; + + result.Shift := LastShiftValue; + result.FinSize := SizeOf(IUnknown); + Inc(LastShiftValue, result.FinSize); +end; + +function TBaseSymbolTable.AddClassVar(Level: Integer): TSymbolRec; +begin + result := AddRecord; + result.Kind := kindVAR; + result.TypeId := typeCLASS; + result.Level := Level; + result.Name := '@'; + + result.Shift := LastShiftValue; + result.FinSize := SizeOfPointer; + Inc(LastShiftValue, result.FinSize); +end; + +{$IFNDEF PAXARM} +function TBaseSymbolTable.AddWideStringVar(Level: Integer): TSymbolRec; +begin + result := AddRecord; + result.Kind := kindVAR; + result.TypeId := typeWIDESTRING; + result.Value := ''; + result.Level := Level; + result.Name := '@'; + + result.Shift := LastShiftValue; + result.FinSize := SizeOf(WideString); + Inc(LastShiftValue, result.FinSize); +end; +{$ENDIF} + +function TBaseSymbolTable.AddUnicStringVar(Level: Integer): TSymbolRec; +begin + result := AddRecord; + result.Kind := kindVAR; + result.TypeId := typeUNICSTRING; + result.Value := ''; + result.Level := Level; + result.Name := '@'; + + result.Shift := LastShiftValue; + result.FinSize := SizeOf(UnicString); + Inc(LastShiftValue, result.FinSize); +end; + +function TBaseSymbolTable.AddVariantVar(Level: Integer): TSymbolRec; +begin + result := AddRecord; + result.Kind := kindVAR; + result.TypeId := typeVARIANT; +// result.Value := ''; + result.Level := Level; + result.Name := '@'; + + result.Shift := LastShiftValue; + result.FinSize := SizeOf(Variant); + Inc(LastShiftValue, result.FinSize); +end; + +function TBaseSymbolTable.AddOleVariantVar(Level: Integer): TSymbolRec; +begin + result := AddRecord; + result.Kind := kindVAR; + result.TypeId := typeOLEVARIANT; +// result.Value := ''; + result.Level := Level; + result.Name := '@'; + + result.Shift := LastShiftValue; + result.FinSize := SizeOf(OleVariant); + Inc(LastShiftValue, result.FinSize); +end; + +{$IFNDEF PAXARM} +function TBaseSymbolTable.AddShortStringVar(Level, TypeId: Integer): TSymbolRec; +begin + result := AddRecord; + result.Kind := kindVAR; + result.TypeId := TypeId; + result.Value := ''; + result.Level := Level; +end; +{$ENDIF} + +function TBaseSymbolTable.AddDynarrayVar(Level, TypeId: Integer): TSymbolRec; +begin + result := AddRecord; + result.Kind := kindVAR; + result.TypeId := TypeId; + result.Level := Level; + + result.Shift := LastShiftValue; + result.FinSize := SizeOfPointer; + Inc(LastShiftValue, result.FinSize); +end; + +function TBaseSymbolTable.AddRecordVar(Level, TypeId: Integer): TSymbolRec; +begin + result := AddRecord; + result.Kind := kindVAR; + result.TypeId := TypeId; + result.Level := Level; +end; + +function TBaseSymbolTable.AddIntegerVar(Level: Integer): TSymbolRec; +begin + result := AddRecord; + result.Kind := kindVAR; + result.TypeId := typeINTEGER; + result.Value := 0; + result.Level := Level; + + result.Shift := LastShiftValue; + result.FinSize := SizeOf(LongInt); + Inc(LastShiftValue, result.FinSize); +end; + +function TBaseSymbolTable.AddCardinalVar(Level: Integer): TSymbolRec; +begin + result := AddRecord; + result.Kind := kindVAR; + result.TypeId := typeCARDINAL; + result.Value := 0; + result.Level := Level; + + result.Shift := LastShiftValue; + result.FinSize := SizeOf(Cardinal); + Inc(LastShiftValue, result.FinSize); +end; + +function TBaseSymbolTable.AddSmallIntVar(Level: Integer): TSymbolRec; +begin + result := AddRecord; + result.Kind := kindVAR; + result.TypeId := typeSMALLINT; + result.Value := 0; + result.Level := Level; + + result.Shift := LastShiftValue; + result.FinSize := SizeOf(SmallInt); + Inc(LastShiftValue, result.FinSize); +end; + +function TBaseSymbolTable.AddShortIntVar(Level: Integer): TSymbolRec; +begin + result := AddRecord; + result.Kind := kindVAR; + result.TypeId := typeSHORTINT; + result.Value := 0; + result.Level := Level; + + result.Shift := LastShiftValue; + result.FinSize := SizeOf(ShortInt); + Inc(LastShiftValue, result.FinSize); +end; + +function TBaseSymbolTable.AddByteVar(Level: Integer): TSymbolRec; +begin + result := AddRecord; + result.Kind := kindVAR; + result.TypeId := typeBYTE; + result.Value := 0; + result.Level := Level; + + result.Shift := LastShiftValue; + result.FinSize := SizeOf(Byte); + Inc(LastShiftValue, result.FinSize); +end; + +function TBaseSymbolTable.AddWordVar(Level: Integer): TSymbolRec; +begin + result := AddRecord; + result.Kind := kindVAR; + result.TypeId := typeWORD; + result.Value := 0; + result.Level := Level; + + result.Shift := LastShiftValue; + result.FinSize := SizeOf(Word); + Inc(LastShiftValue, result.FinSize); +end; + +function TBaseSymbolTable.AddBooleanVar(Level: Integer): TSymbolRec; +begin + result := AddRecord; + result.Kind := kindVAR; + result.TypeId := typeBOOLEAN; + result.Value := 0; + result.Level := Level; + + result.Shift := LastShiftValue; + result.FinSize := SizeOf(Boolean); + Inc(LastShiftValue, result.FinSize); +end; + +function TBaseSymbolTable.AddByteBoolVar(Level: Integer): TSymbolRec; +begin + result := AddRecord; + result.Kind := kindVAR; + result.TypeId := typeBYTEBOOL; + result.Value := 0; + result.Level := Level; + + result.Shift := LastShiftValue; + result.FinSize := SizeOf(ByteBool); + Inc(LastShiftValue, result.FinSize); +end; + +function TBaseSymbolTable.AddWordBoolVar(Level: Integer): TSymbolRec; +begin + result := AddRecord; + result.Kind := kindVAR; + result.TypeId := typeWORDBOOL; + result.Value := 0; + result.Level := Level; + + result.Shift := LastShiftValue; + result.FinSize := SizeOf(WordBool); + Inc(LastShiftValue, result.FinSize); +end; + +function TBaseSymbolTable.AddLongBoolVar(Level: Integer): TSymbolRec; +begin + result := AddRecord; + result.Kind := kindVAR; + result.TypeId := typeLONGBOOL; + result.Value := 0; + result.Level := Level; + + result.Shift := LastShiftValue; + result.FinSize := SizeOf(LongBool); + Inc(LastShiftValue, result.FinSize); +end; + +function TBaseSymbolTable.AddPointerVar(Level: Integer): TSymbolRec; +begin + result := AddRecord; + result.Kind := kindVAR; + result.TypeId := typePOINTER; + result.Level := Level; + + result.Shift := LastShiftValue; + result.FinSize := SizeOfPointer; + Inc(LastShiftValue, result.FinSize); +end; + +{$IFNDEF PAXARM} +function TBaseSymbolTable.AddAnsiCharVar(Level: Integer): TSymbolRec; +begin + result := AddRecord; + result.Kind := kindVAR; + result.TypeId := typeANSICHAR; + result.Level := Level; + + result.Shift := LastShiftValue; + result.FinSize := SizeOf(AnsiChar); + Inc(LastShiftValue, result.FinSize); +end; +{$ENDIF} + +function TBaseSymbolTable.AddWideCharVar(Level: Integer): TSymbolRec; +begin + result := AddRecord; + result.Kind := kindVAR; + result.TypeId := typeWIDECHAR; + result.Level := Level; + + result.Shift := LastShiftValue; + result.FinSize := SizeOf(WideChar); + Inc(LastShiftValue, result.FinSize); +end; + +function TBaseSymbolTable.AddVoidVar(Level: Integer; SZ: Integer): TSymbolRec; +begin + result := AddRecord; + result.Kind := kindVAR; + result.TypeId := typeVOID; + result.Level := Level; + + result.Shift := LastShiftValue; + result.FinSize := SZ; + Inc(LastShiftValue, result.FinSize); +end; + +function TBaseSymbolTable.AddClassRefVar(Level: Integer): TSymbolRec; +begin + result := AddRecord; + result.Kind := kindVAR; + result.TypeId := typeCLASSREF; + result.Value := 0; + result.Level := Level; + + result.Shift := LastShiftValue; + result.FinSize := SizeOfPointer; + Inc(LastShiftValue, result.FinSize); +end; + +function TBaseSymbolTable.AddLabel: TSymbolRec; +begin + result := AddRecord; + result.Kind := kindLABEL; + result.Level := 0; +end; + +function TBaseSymbolTable.AddPointerType(SourceTypeId: Integer): TSymbolRec; +begin + result := AddRecord; + result.Kind := kindTYPE; + result.TypeId := typePOINTER; + result.Level := Records[SourceTypeId].Level; + result.PatternId := SourceTypeId; +end; + +function TBaseSymbolTable.AddEndOfClassHeader(ClassId: Integer): TSymbolRec; +begin + result := AddRecord; + result.Name := '*' + Records[ClassId].Name; + result.Kind := kindEND_CLASS_HEADER; + result.Level := ClassId; +end; + +function TBaseSymbolTable.LookupNamespace(const S: String; + i_Level: Integer; UpCase: Boolean): Integer; +var + I, J: Integer; + ok: Boolean; + List: TIntegerList; + Q: TStringList; + S2: String; +begin + if PosCh('.', S) > 0 then + begin + Q := ExtractNames(S); + try + result := i_Level; + for I := 0 to Q.Count - 1 do + begin + S2 := Q[I]; + if StrEql(S, 'System') then + result := 0 + else + result := LookupNamespace(S2, result, Upcase); + end; + finally + FreeAndNil(Q); + end; + Exit; + end; + + List := HashArray.GetList(S); + + result := 0; + for J := List.Count - 1 downto 0 do + begin + I := List[J]; + with Records[I] do + if (Kind = KindNAMESPACE) and (Level = i_Level) then + begin + if UpCase then + ok := StrEql(Name, S) + else + ok := Name = S; + if ok then + begin + result := I; + Exit; + end; + end; + end; +end; + +function TBaseSymbolTable.LookupFullName(const S: String; UpCase: Boolean): Integer; +var + I, J: Integer; + ok: Boolean; + RI: TSymbolRec; + List: TIntegerList; +begin + result := 0; + + if HashArray = nil then + begin + for I := Card downto FirstLocalId + 1 do + begin + RI := Records[I]; + begin + if UpCase then + ok := StrEql(RI.FullName, S) + else + ok := RI.FullName = S; + if ok then + begin + result := I; + Exit; + end; + end; + end; + Exit; + end; + + List := HashArray.GetList(ExtractName(S)); + + for J := List.Count - 1 downto 0 do + begin + I := List[J]; + RI := Records[I]; + begin + if UpCase then + ok := StrEql(RI.FullName, S) + else + ok := RI.FullName = S; + if ok then + begin + result := I; + Exit; + end; + end; + end; +end; + +function TBaseSymbolTable.LookupFullNameEx(const S: String; UpCase: Boolean; + OverCount: Integer): Integer; +var + I, J: Integer; + ok: Boolean; + RI: TSymbolRec; + List: TIntegerList; +begin + if OverCount = 0 then + begin + result := LookupFullName(S, Upcase); + Exit; + end; + + result := 0; + + if HashArray = nil then + begin + for I:= Card downto FirstLocalId + 1 do + begin + RI := Records[I]; + begin + if UpCase then + ok := StrEql(RI.FullName, S) + else + ok := RI.FullName = S; + if ok then + if RI.OverCount = OverCount then + begin + result := I; + Exit; + end; + end; + end; + Exit; + end; + + List := HashArray.GetList(ExtractName(S)); + + for J := List.Count - 1 downto 0 do + begin + I := List[J]; + RI := Records[I]; + begin + if UpCase then + ok := StrEql(RI.FullName, S) + else + ok := RI.FullName = S; + if ok then + if RI.OverCount = OverCount then + begin + result := I; + Exit; + end; + end; + end; +end; + +function TBaseSymbolTable.LookUpType(const S: String; + i_Level: Integer; UpCase: Boolean): Integer; +var + I, J: Integer; + ok: Boolean; + List: TIntegerList; +begin + if S = '' then + begin + result := 0; + Exit; + end; + +{$IFDEF UNIC} + if StrEql(S, 'Char') then + result := typeWIDECHAR + else if StrEql(S, 'String') then + result := typeUNICSTRING + else if StrEql(S, 'PChar') then + result := typePWIDECHAR + else + result := Types.IndexOf(S); +{$ELSE} + result := Types.IndexOf(S); +{$ENDIF} + + if result > 0 then + Exit; + + List := HashArray.GetList(S); + + result := 0; + + for J := List.Count - 1 downto 0 do + begin + I := List[J]; + with Records[I] do + if (Kind = KindTYPE) and (Level = i_Level) then + begin + if UpCase then + ok := StrEql(Name, S) + else + ok := Name = S; + if ok then + begin + result := I; + Exit; + end; + end; + end; + + for J := List.Count - 1 downto 0 do + begin + I := List[J]; + with Records[I] do + if Kind = KindTYPE then + begin + if UpCase then + ok := StrEql(Name, S) + else + ok := Name = S; + if ok then + begin + result := I; + Exit; + end; + end; + end; +end; + +function TBaseSymbolTable.LookUpType(const S: String; UpCase: Boolean): Integer; +var + I, J: Integer; + ok: Boolean; + List: TIntegerList; +begin + if S = '' then + begin + result := 0; + Exit; + end; + +{$IFDEF UNIC} + if StrEql(S, 'Char') then + result := typeWideCHAR + else if StrEql(S, 'String') then + result := typeUNICSTRING + else if StrEql(S, 'PChar') then + result := typePWIDECHAR + else + result := Types.IndexOf(S); +{$ELSE} + result := Types.IndexOf(S); +{$ENDIF} + + if result > 0 then + Exit; + + List := HashArray.GetList(S); + + result := 0; + + for J := List.Count - 1 downto 0 do + begin + I := List[J]; + with Records[I] do + if Kind = KindTYPE then + begin + if UpCase then + ok := StrEql(Name, S) + else + ok := Name = S; + if ok then + begin + result := I; + Exit; + end; + end; + end; +end; + +function TBaseSymbolTable.LookUpTypeEx(const S: String; + i_Level: Integer; UpCase: Boolean; LowBound: Integer): Integer; +var + I, J: Integer; + ok: Boolean; + List: TIntegerList; +begin + if S = '' then + begin + result := 0; + Exit; + end; + + result := Types.IndexOf(S); + if result > 0 then + if result >= LowBound then + Exit; + + List := HashArray.GetList(S); + + result := 0; + + for J := List.Count - 1 downto 0 do + begin + I := List[J]; + if I < LowBound then + continue; + + with Records[I] do + if (Kind = KindTYPE) and (Level = i_Level) then + begin + if UpCase then + ok := StrEql(Name, S) + else + ok := Name = S; + if ok then + begin + result := I; + Exit; + end; + end; + end; + + for J:=List.Count - 1 downto 0 do + begin + I := List[J]; + + if I < LowBound then + continue; + + with Records[I] do + if Kind = KindTYPE then + begin + if UpCase then + ok := StrEql(Name, S) + else + ok := Name = S; + if ok then + begin + result := I; + Exit; + end; + end; + end; +end; + +function TBaseSymbolTable.LookupParentMethodBase(SubId: Integer; + UpCase: Boolean; + var BestId: Integer): Integer; +var + I, J, Level, TempLevel: Integer; + ok: Boolean; + List: TIntegerList; + R: TSymbolRec; + Name, Signature: String; +begin + Name := Records[SubId].Name; + Signature := Records[SubId].SignatureBrief; + Level := Records[SubId].Level; + + List := HashArray.GetList(Name); + + result := 0; + BestId := 0; + + for J:=List.Count - 1 downto 0 do + begin + I := List[J]; + + R := Records[I]; + if R.Kind in KindSUBS then + begin + TempLevel := R.Level; + + if TempLevel = 0 then + continue; + if Level = TempLevel then + continue; + if Records[TempLevel].ClassIndex = -1 then + continue; + if not Inherits(Level, TempLevel) then + continue; + + if UpCase then + ok := StrEql(R.Name, Name) + else + ok := R.Name = Name; + if ok then + begin + BestId := I; + + if UpCase then + ok := StrEql(R.SignatureBrief, Signature) + else + ok := R.SignatureBrief = Signature; + + if ok then + begin + result := I; + Exit; + end; + end; + end; + end; +end; + +function TBaseSymbolTable.LookupParentMethod(SubId: Integer; + UpCase: Boolean; + HasMethodIndex: Boolean = false): Integer; +var + I, J, Level: Integer; + ok: Boolean; + List: TIntegerList; + R: TSymbolRec; + Name, Signature: String; + C, CA: TClass; +label + Again; +begin + Name := Records[SubId].Name; + Signature := Records[SubId].SignatureBrief; + + List := HashArray.GetList(Name); + C := Records[Records[SubId].Level].PClass; + + result := 0; + Level := Records[SubId].Level; + +Again: + + if C = nil then + Exit; + + for J:=List.Count - 1 downto 0 do + begin + I := List[J]; + R := Records[I]; + if R.Kind in KindSUBS then + begin + CA := Records[Records[I].Level].PClass; + + if CA = nil then + continue; + + if C = CA then + continue; + + if not C.InheritsFrom(CA) then + begin + if Records[Records[SubId].Level].AncestorId <> + Records[I].Level then + continue; + end; + + if UpCase then + ok := StrEql(R.Name, Name) + else + ok := R.Name = Name; + if ok then + begin + + if UpCase then + ok := StrEql(R.SignatureBrief, Signature) + else + ok := R.SignatureBrief = Signature; + + if ok then + begin + if HasMethodIndex = false then + begin + result := I; + Exit; + end + else + if R.MethodIndex <> 0 then + begin + result := I; + Exit; + end; + end; + end; + end; + end; + + if Level > 0 then + if Records[Level].AncestorId > 0 then + begin + Level := Records[Level].AncestorId; + C := Records[Level].PClass; + goto Again; + end; +end; + +function TBaseSymbolTable.LookupParentMethods(SubId: Integer; Upcase: Boolean): TIntegerList; +var + Name, Signature: String; + List: TIntegerList; + I, J, L: Integer; + R: TSymbolRec; + b: Boolean; +begin + Name := Records[SubId].Name; + Signature := Records[SubId].SignatureBrief; + L := Records[SubId].Level; + + result := TIntegerList.Create; + + List := HashArray.GetList(Name); + for J:=List.Count - 1 downto 0 do + begin + I := List[J]; + R := Records[I]; + if R.Kind in KindSUBS then + begin + if I = SubId then + continue; + if R.Level > 0 then + if Records[R.Level].Kind = KindTYPE then + if Inherits(L, R.Level) then + begin + if Upcase then + b := StrEql(R.Name, Name) + else + b := R.Name = Name; + + if not b then + continue; + + if Upcase then + b := StrEql(R.SignatureBrief, Signature) + else + b := R.SignatureBrief = Signature; + + if b then + begin + result.Add(I); + end; + end; + end; + end; +end; + +function TBaseSymbolTable.LookupParentConstructor(SubId: Integer): Integer; +var + I, L, KK, K1, K2, AncestorId: Integer; + R: TSymbolRec; + Signature: String; +begin + result := 0; + + Signature := Records[SubId].Signature; + + L := Records[SubId].Level; + AncestorId := Records[L].AncestorId; + + for KK := 2 downto 1 do + begin + if KK = 1 then + begin + K1 := 1; + if Self.st_tag = 0 then + K2 := Card + else + K2 := TLocalSymbolTable(Self).GlobalST.Card; + end + else + begin + K1 := FirstLocalId + 1; + K2 := Card; + end; + + for I := K2 downto K1 do + begin + R := Records[I]; + if R.Kind = KindCONSTRUCTOR then + begin + if I = SubId then + continue; + + if R.Level > 0 then + if Records[R.Level].Kind = KindTYPE then + if AncestorId = R.Level then + if StrEql(Records[I].Signature, Signature) then + begin + result := I; + end; + end; + end; + end; +end; + +function TBaseSymbolTable.LookupParentConstructors(SubId: Integer): TIntegerList; +var + I, L, KK, K1, K2: Integer; + R: TSymbolRec; + Signature: String; +begin + L := Records[SubId].Level; + result := TIntegerList.Create; + Signature := Records[SubId].Signature; + + for KK := 2 downto 1 do + begin + if KK = 1 then + begin + K1 := 1; + if Self.st_tag = 0 then + K2 := Card + else + K2 := TLocalSymbolTable(Self).GlobalST.Card; + end + else + begin + K1 := FirstLocalId + 1; + K2 := Card; + end; + + for I := K2 downto K1 do + begin + R := Records[I]; + if R.Kind = KindCONSTRUCTOR then + begin + if I = SubId then + continue; + + if R.Level > 0 then + if Records[R.Level].Kind = KindTYPE then + if Inherits(L, R.Level) then + if StrEql(Records[I].Signature, Signature) then + begin + result.Add(I); + if Records[I].Host then + break; + end; + end; + end; + end; +end; + +function TBaseSymbolTable.LookUpEnumItem(const S: String; EnumTypeId: Integer; + UpCase: Boolean): Integer; +var + I: Integer; + R: TSymbolRec; + ok: Boolean; +begin + result := 0; + + for I:=EnumTypeId + 1 to Card do + begin + R := Records[I]; + + if R = SR0 then + Exit; + + if R.Kind = KindCONST then + if R.OwnerId = EnumTypeId then + begin + if UpCase then + ok := StrEql(R.Name, S) + else + ok := R.Name = S; + if ok then + begin + result := I; + Exit; + end; + end; + end; +end; + +function TBaseSymbolTable.LookUp(const S: String; Level: Integer; UpCase: Boolean; + UpperBoundId: Integer = MaxInt; recursive: Boolean = true): Integer; +var + I, J: Integer; + Ok: Boolean; + InterfaceTypeId: Integer; + R: TSymbolRec; + List: TIntegerList; +begin + List := HashArray.GetList(S); + + result := 0; + + for J:=List.Count - 1 downto 0 do + begin + I := List[J]; + R := Records[I]; + + if I < UpperBoundId then + if (R.Level = Level) and (not R.InternalField) then + if R.Kind <> KindNONE then + begin + if R.OwnerId > 0 then + if Records[R.OwnerId].Kind <> KindTYPE then + continue; + + if UpCase then + ok := StrEql(R.Name, S) + else + ok := R.Name = S; + if ok then + begin + result := I; + Exit; + end; + end; + end; + + if Recursive then + if Level > 0 then + begin + if Records[Level].AncestorId > 0 then + begin + result := LookUp(S, Records[Level].AncestorId, Upcase); + if result > 0 then + Exit; + end; + end; + + if Assigned(Records[Level].SupportedInterfaces) then + begin + for I := 0 to Records[Level].SupportedInterfaces.Count - 1 do + begin + InterfaceTypeId := Records[Level].SupportedInterfaces[I].Id; + result := LookUp(S, InterfaceTypeId, Upcase); + if result > 0 then + Exit; + end; + end; +end; + +function TBaseSymbolTable.LookUpEx(var HelperTypeId: Integer; const S: String; Level: Integer; UpCase: Boolean; + UpperBoundId: Integer = MaxInt; recursive: Boolean = true): Integer; +var + L: TIntegerList; + I: Integer; +begin + HelperTypeId := 0; + result := LookUp(S, Level, UpCase, UpperBoundId, recursive); + if result > 0 then + Exit; + if Level = 0 then + Exit; + if Records[Level].Kind <> KindTYPE then + Exit; + if Records[Level].FinalTypeId = typeHELPER then + begin + I := Records[Level].PatternId; + if I = 0 then + Exit; + result := LookUp(S, I, UpCase, UpperBoundId, recursive); + if result > 0 then + HelperTypeId := Level; + Exit; + end; + L := GetTypeHelpers(Level); + try + for I := 0 to L.Count - 1 do + begin + result := LookUp(S, L[I], UpCase, UpperBoundId, recursive); + if result > 0 then + begin + HelperTypeId := L[I]; + Exit; + end; + end; + finally + L.Free; + end; +end; + +function TBaseSymbolTable.LookUpAll(const S: String; Level: Integer; UpCase: Boolean): TIntegerList; +var + I, J: Integer; + Ok: Boolean; + R: TSymbolRec; + List: TIntegerList; +begin + List := HashArray.GetList(S); + + result := TIntegerList.Create; + for J:=List.Count - 1 downto 0 do + begin + I := List[J]; + + R := Records[I]; + + if (R.Level = Level) and (not R.InternalField) then + if R.Kind <> KindNONE then + if R.OwnerId = 0 then + begin + if UpCase then + ok := StrEql(R.Name, S) + else + ok := R.Name = S; + if ok then + result.Insert(0, I); + end; + end; +end; + +function TBaseSymbolTable.LookUpSub(const S: String; Level: Integer; UpCase: Boolean): TIntegerList; + + function HasAtLevel(const S: String; Level: Integer; UpCase: Boolean): Boolean; + var + I, J: Integer; + Ok: Boolean; + R: TSymbolRec; + List: TIntegerList; + begin + List := HashArray.GetList(S); + + result := false; + + for J:=List.Count - 1 downto 0 do + begin + I := List[J]; + R := Records[I]; + if (R.Level = Level) and (R.Kind in kindSUBS) then + begin + if UpCase then + ok := StrEql(R.Name, S) + else + ok := R.Name = S; + if ok then + begin + result := true; + Exit; + end; + end; + end; + end; + + procedure DoIt(const S: String; Level: Integer; UpCase: Boolean; Fin: Boolean = false); + var + I, J, I1, K1: Integer; + Ok: Boolean; + R: TSymbolRec; + List: TIntegerList; + Sig: String; + begin + List := HashArray.GetList(S); + + K1 := result.Count; + + for J:=List.Count - 1 downto 0 do + begin + I := List[J]; + + R := Records[I]; + + if (R.Level = Level) and (R.Kind in KindSUBS) then + begin + if UpCase then + ok := StrEql(R.Name, S) + else + ok := R.Name = S; + if ok then + begin + Sig := Records[I].Signature; + for I1 := 0 to K1 - 1 do + if Records[result[I1]].Signature = Sig then + begin + ok := false; + break; + end; + if not ok then + continue; + + result.Insert(0, I); + end; + end; + end; + + if Fin then + Exit; + + Level := Records[Level].AncestorId; + while not ((Level = 0) or (Level = H_TObject) or (Level = JS_ObjectClassId)) do + begin + if HasAtLevel(S, Level, Upcase) then + begin + DoIt(S, Level, upcase, true); + Exit; + end; + Level := Records[Level].AncestorId; + end; + end; + +begin + result := TIntegerList.Create; + DoIt(S, Level, Upcase); +end; + +function TBaseSymbolTable.LookUpSubs(const S: String; Level: Integer; UsingList: TIntegerList; UpCase: Boolean): TIntegerList; +var + I, J, LevelId, SubId: Integer; + temp: TIntegerList; +begin + result := LookupSub(S, Level, Upcase); + + for I := 0 to UsingList.Count - 1 do + begin + LevelId := UsingList[I]; + temp := LookupSub(S, LevelId, upcase); + for J := 0 to temp.Count - 1 do + begin + SubId := temp[J]; + if result.IndexOf(SubId) = -1 then + result.Add(SubId); + end; + FreeAndNil(temp); + end; +end; + +function TBaseSymbolTable.LookUps(const S: String; LevelStack: TIntegerStack; + UpCase: Boolean; + UpperBoundId: Integer = MaxInt; + Recursive: Boolean = true): Integer; +var + I, R: Integer; +begin + for I:=LevelStack.Count - 1 downto 0 do + begin + R := LookUp(S, LevelStack[I], upcase, UpperBoundId, Recursive); + if R > 0 then + begin + result := R; + Exit; + end; + end; + result := 0; +end; + +function TBaseSymbolTable.LookUpsEx(const S: String; LevelStack: TIntegerStack; var LevelId: Integer; UpCase: Boolean): Integer; +var + I, R: Integer; +begin + for I:=LevelStack.Count - 1 downto 0 do + begin + R := LookUp(S, LevelStack[I], upcase, MaxInt); + if R > 0 then + begin + result := R; + LevelId := LevelStack[I]; + Exit; + end; + end; + result := 0; +end; + +function TBaseSymbolTable.LookUpsExcept(const S: String; LevelStack: TIntegerStack; LevelId: Integer; UpCase: Boolean): Integer; +var + I, R: Integer; +begin + for I:=LevelStack.Count - 1 downto 0 do + begin + if LevelId = LevelStack[I] then + continue; + + R := LookUp(S, LevelStack[I], upcase, MaxInt); + if R > 0 then + begin + result := R; + Exit; + end; + end; + result := 0; +end; + +function TBaseSymbolTable.LookupAnotherDeclaration(Id: Integer; UpCase: Boolean; + var BestID: Integer): Integer; +var + I, J, Level: Integer; + Name, SignatureEx: String; + Ok: Boolean; + RI: TSymbolRec; + List: TIntegerList; +begin + Level := Records[Id].Level; + Name := Records[Id].Name; + SignatureEx := Records[Id].SignatureEx; + + BestId := 0; + + List := HashArray.GetList(Name); + + for J := List.Count - 1 downto 0 do + begin + I := List[J]; + + if I = Id then + continue; + + RI := Records[I]; + if (RI.Level = Level) and + (RI.Kind in kindSUBS) then + begin + if UpCase then + ok := StrEql(RI.Name, Name) + else + ok := (RI.Name = Name); + + if ok then + begin + BestId := I; + + if UpCase then + ok := StrEql(RI.SignatureEx, SignatureEx) + else + ok := RI.SignatureEx = SignatureEx; + end; + + if ok then + begin + result := I; + Exit; + end; + end; + end; + + result := 0; +end; + +function TBaseSymbolTable.LookupForwardDeclaration(Id: Integer; UpCase: Boolean; + var BestID: Integer): Integer; +var + I, J, Level: Integer; + Name, Sig: String; + Ok: Boolean; + RI: TSymbolRec; + List: TIntegerList; +begin + Level := Records[Id].Level; + Name := Records[Id].Name; + Sig := Records[Id].Sig; + + BestId := 0; + + List := HashArray.GetList(Name); + + for J := List.Count - 1 downto 0 do + begin + I := List[J]; + RI := Records[I]; + if RI.IsForward and (RI.Level = Level) and + (RI.Kind in kindSUBS) then + begin + if UpCase then + ok := StrEql(RI.Name, Name) + else + ok := (RI.Name = Name); + + if ok then + begin + BestId := I; + + if UpCase then + ok := StrEql(RI.Sig, Sig) + else + ok := RI.Sig = Sig; + end; + + if ok then + begin + result := I; + Exit; + end; + end; + end; + + result := 0; +end; + +function TBaseSymbolTable.LookupForwardDeclarations(Id: Integer; + UpCase: Boolean): TIntegerList; +var + I, J, Level: Integer; + Ok: Boolean; + Name: String; + R: TSymbolRec; + List: TIntegerList; +begin + result := nil; + + Level := Records[Id].Level; + Name := Records[Id].Name; + + List := HashArray.GetList(Name); + + for J := List.Count - 1 downto 0 do + begin + I := List[J]; + + R := Records[I]; + if R.IsForward and (R.Level = Level) and + (R.Kind in KindSUBS) then + begin + if UpCase then + ok := StrEql(R.Name, Name) + else + ok := (R.Name = Name); + if ok then + begin + if result = nil then + result := TIntegerList.Create; + + result.Add(I); + end; + end; + end; +end; + +function TBaseSymbolTable.GetDataSize(UpperId: Integer = MaxInt - 1): Integer; +var + I: Integer; + R: TSymbolRec; + K1, K2, KK: Integer; +begin + result := FirstShiftValue; + + Inc(UpperId); + + for KK := 1 to 2 do + begin + if KK = 1 then + begin + K1 := Types.Count; + + if Self.st_tag = 0 then + K2 := Card + else + K2 := TLocalSymbolTable(Self).GlobalST.Card; + end + else + begin + K1 := FirstLocalId + 1; + K2 := Card; + end; + + for I := K1 to K2 do + begin + + if I = UpperId then + break; + + R := Records[I]; + + if R.UnionId <> 0 then + Continue; + + if R.Kind in [KindTYPE, KindTYPE_FIELD, KindLABEL] then + Continue; + + if R.OverScript then + begin + Inc(result, SizeOfPointer); + continue; + end; + + if (R.Shift > 0) and + (not R.Param) and (not R.Local) and (not R.InternalField) then + begin + if R.Kind = kindSUB then + Inc(result, SizeOfPointer) + else if R.Host then + Inc(result, SizeOfPointer) +{$IFNDEF PAXARM} + else if (R.Kind = KindCONST) and R.HasPAnsiCharType then // literal + begin + Inc(result, SizeOfPointer); + Inc(result, SizeOfPointer); + Inc(result, SizeOfPointer); + Inc(result, Length(R.Value) + 1); + end +{$ENDIF} + else if (R.Kind = KindCONST) and R.HasPWideCharType then // literal + begin + Inc(result, SizeOfPointer); + Inc(result, SizeOfPointer); + Inc(result, Length(R.Value) * 2 + 2); + end + else + Inc(result, R.Size); + end; + end; + end; +end; + +function TBaseSymbolTable.GetSizeOfLocals(SubId: Integer): Integer; +var + I: Integer; + R: TSymbolRec; +begin + result := 0; + for I := SubId + 1 to Card do + begin + R := Records[I]; + + if R.UnionId <> 0 then + Continue; + + if (R.Kind = KindVAR) and (R.Level = SubId) and R.Local then + begin + if R.FinalTypeId = typeSET then + Inc(result, SizeOf(TByteSet)) + else + Inc(result, MPtr(R.Size)); + end; + end; + + result := Abs(result); + + if Records[SubId].ExtraParamNeeded then + begin + if Records[SubId].CallConv in [ccREGISTER, ccMSFASTCALL] then + begin + if Records[GetResultId(SubId)].Register = 0 then + Dec(result, SizeOfPointer); + end + else + Dec(result, SizeOfPointer); + end; + +end; + +function TBaseSymbolTable.GetSizeOfLocalsEx(SubId: Integer): Integer; +begin + result := GetSizeOfLocals(SubId); + + while (result mod 32 <> 0) do + Inc(result); +end; + +function TBaseSymbolTable.GetSubRSPSize(SubId: Integer): Integer; +begin + result := GetSizeOfLocalsEx(SubId); + Inc(result, $150); + while result mod 32 <> 0 do + Inc(result); + Inc(result, 8); +end; + +function TBaseSymbolTable.GetSizeOfSetType(SetTypeId: Integer): Integer; +var + FT, OriginTypeId: Integer; + B2: TSymbolRec; + I: Cardinal; +begin + OriginTypeId := Records[SetTypeId].PatternId; + if OriginTypeId <= 1 then + begin + result := 32; + Exit; + end; + + FT := Records[OriginTypeId].FinalTypeId; +{ + if FT = typeENUM then + begin + result := 1; + Exit; + end; +} + if not (FT in OrdinalTypes) then + begin + result := 32; + Exit; + end; + + B2 := GetHighBoundRec(OriginTypeId); + I := B2.Value; + if I < 8 then + result := 1 + else if I < 16 then + result := 2 + else if I < 32 then + result := 4 + else if I < 64 then + result := 8 + else if I < 128 then + result := 16 + else + result := 32; +end; + +function TBaseSymbolTable.CheckSetTypes(T1, T2: Integer): Boolean; +var + P1, P2, F1, F2: Integer; +begin + result := true; + + if T2 = H_TByteSet then + Exit; + + P1 := Records[T1].PatternId; + P2 := Records[T2].PatternId; + + if (P1 > 1) and (P2 > 1) then + begin + F1 := Records[P1].FinalTypeId; + F2 := Records[P2].FinalTypeId; + + if F1 <> F2 then + begin + if (F1 in IntegerTypes) and (F2 in IntegerTypes) then + begin + // ok + end + else + result := false; + end + else if (F1 = typeENUM) and (F2 = typeENUM)then + begin + if P1 <> P2 then + if Records[T2].Name <> '$$' then + result := false; + end; + end; +end; + +function TBaseSymbolTable.GetLowBoundRec(TypeID: Integer): TSymbolRec; +var + I: Integer; + RI: TSymbolRec; +begin + result := nil; + + if Records[TypeID].Kind <> kindTYPE then + begin + RaiseError(errInternalError, []); + Exit; + end; + + if Records[TypeID].TypeID = typeALIAS then + TypeID := Records[TypeID].TerminalTypeId; + + case Records[TypeID].FinalTypeId of + typeBOOLEAN, typeBYTEBOOL, typeWORDBOOL, typeLONGBOOL: + begin + result := Records[FalseId]; + Exit; + end; + typeINTEGER, +{$IFNDEF PAXARM} + typeANSICHAR, +{$ENDIF} + typeBYTE, typeWORD, typeCARDINAL, + typeSMALLINT, typeSHORTINT, typeWIDECHAR, + typeINT64: + begin + for I:=TypeID + 1 to Card do + begin + RI := Records[I]; + + if RI = SR0 then + break; + + if RI.Level = TypeID then + begin + result := RI; + Exit; + end; + end; + end; + typeENUM: + begin + if Records[TypeID].IsSubrangeEnumType then + begin + result := Records[TypeID + 1]; + Exit; + end; + + for I:=TypeID + 1 to Card do + begin + RI := Records[I]; + + if RI = SR0 then + break; + + if RI.OwnerId = TypeID then + begin + result := RI; + Exit; + end; + end; + end; + else + begin + RaiseError(errInternalError, []); + Exit; + end; + end; + + RaiseError(errInternalError, []); +end; + +function TBaseSymbolTable.GetHighBoundRec(TypeID: Integer): TSymbolRec; +var + I, J: Integer; + RI: TSymbolRec; +begin + result := nil; + + if Records[TypeID].TypeID = typeALIAS then + TypeID := Records[TypeID].TerminalTypeId; + + case Records[TypeID].FinalTypeId of + typeBOOLEAN, typeBYTEBOOL, typeWORDBOOL, typeLONGBOOL: + begin + result := Records[TrueId]; + Exit; + end; + typeINTEGER, +{$IFNDEF PAXARM} + typeANSICHAR, +{$ENDIF} + typeBYTE, typeWORD, typeCARDINAL, + typeSMALLINT, typeSHORTINT, typeWIDECHAR, + typeINT64: + begin + for I:=GetLowBoundRec(TypeID).Id + 1 to Card do + begin + RI := Records[I]; + if RI = SR0 then + break; + + if RI.Level = TypeID then + begin + result := RI; + Exit; + end; + end; + end; + typeENUM: + begin + if Records[TypeID].IsSubrangeEnumType then + begin + result := Records[TypeID + 2]; + Exit; + end; + + J := Records[TypeID].Count; + for I:=TypeID + 1 to Card do + begin + RI := Records[I]; + + if RI = SR0 then + break; + + if RI.Kind = KindCONST then + if RI.OwnerId = TypeID then + begin + result := RI; + Dec(J); + if J = 0 then Break; + end; + end; + Exit; + end; + else + begin + RaiseError(errInternalError, []); + Exit; + end; + end; + + RaiseError(errInternalError, []); +end; + +{$IFNDEF PAXARM} +function TBaseSymbolTable.IsZeroBasedAnsiCharArray(Id: Integer): Boolean; +var + ArrayTypeId, RangeTypeId, ElemTypeId: Integer; +begin + if Records[Id].FinalTypeId <> typeARRAY then + begin + result := false; + Exit; + end; + + ArrayTypeId := Records[Id].TerminalTypeId; + + GetArrayTypeInfo(ArrayTypeId, RangeTypeId, ElemTypeId); + result := (Records[ElemTypeId].FinalTypeId = typeANSICHAR) and + (GetLowBoundRec(RangeTypeId).Value = 0); +end; +{$ENDIF} + +function TBaseSymbolTable.IsZeroBasedWideCharArray(Id: Integer): Boolean; +var + ArrayTypeId, RangeTypeId, ElemTypeId: Integer; +begin + if Records[Id].FinalTypeId <> typeARRAY then + begin + result := false; + Exit; + end; + + ArrayTypeId := Records[Id].TerminalTypeId; + + GetArrayTypeInfo(ArrayTypeId, RangeTypeId, ElemTypeId); + result := (Records[ElemTypeId].FinalTypeId = typeWIDECHAR) and + (GetLowBoundRec(RangeTypeId).Value = 0); +end; + +procedure TBaseSymbolTable.GetArrayTypeInfo(ArrayTypeId: Integer; var RangeTypeId: Integer; + var ElemTypeId: Integer); +var + I, K: Integer; +begin + if Records[ArrayTypeID].TypeID = typeALIAS then + ArrayTypeID := Records[ArrayTypeID].TerminalTypeId; + + if Records[ArrayTypeID].ReadId <> 0 then + begin + RangeTypeId := Records[ArrayTypeID].ReadId; + ElemTypeId := Records[ArrayTypeID].WriteId; + Exit; + end; + + ElemTypeId := 0; + RangeTypeId := 0; + + K := Card; + + if Self.st_tag > 0 then + if ArrayTypeId < TLocalSymbolTable(Self).GlobalST.Card then + begin + K := TLocalSymbolTable(Self).GlobalST.Card; + end; + + for I:=ArrayTypeId + 1 to K do + if Records[I].Level = ArrayTypeId then + if Records[I].Kind = KindTYPE then + begin + RangeTypeId := I; + break; + end; + + for I:=K downto ArrayTypeId + 1 do + if Records[I].Level = ArrayTypeId then + if Records[I].Kind = KindTYPE then + begin + ElemTypeId := I; + break; + end; + + if (RangeTypeId = 0) or (ElemTypeId = 0) then + Begin + RaiseError(errInternalError, []); + Exit; + end; + + if Records[RangeTypeId].TypeID = typeALIAS then + RangeTypeId := Records[RangeTypeId].TerminalTypeId; + + if Records[ElemTypeId].TypeID = typeALIAS then + ElemTypeId := Records[ElemTypeId].TerminalTypeId; + + Records[ArrayTypeID].ReadId := RangeTypeId; + Records[ArrayTypeID].WriteId := ElemTypeId; +end; + +function TBaseSymbolTable.GetTypeBase(TypeId: Integer): Integer; +begin + result := Records[TypeId].PatternId; +end; + +function TBaseSymbolTable.GetPatternSubId(ProcTypeID: Integer): Integer; +begin + result := Records[ProcTypeID].PatternId; +end; + +function TBaseSymbolTable.EqualHeaders(SubId1, SubId2: Integer): Boolean; + + function CompareTypes(T1, T2: Integer): Boolean; + var + F1, F2: Integer; + begin + result := false; + F1 := Records[T1].FinalTypeId; + F2 := Records[T2].FinalTypeId; + if F1 <> F2 then + Exit; + if F1 = typeDYNARRAY then + begin + T1 := Records[T1].TerminalTypeId; + T2 := Records[T2].TerminalTypeId; + T1 := Records[T1].PatternId; + T2 := Records[T2].PatternId; + result := CompareTypes(T1, T2); + Exit; + end; + result := true; + end; + +var + I: Integer; +begin + result := false; + if not CompareTypes(Records[SubId1].TypeId, Records[SubId2].TypeId) then + Exit; + if Records[SubId1].Count <> Records[SubId2].Count then + Exit; + for I:=0 to Records[SubId1].Count - 1 do + if not CompareTypes(Records[GetParamId(SubId1, I)].TypeID, Records[GetParamId(SubId2, I)].TypeID) then + Exit; + result := true; +end; + +procedure TBaseSymbolTable.CheckError(B: Boolean); +begin + if B then + RaiseError(errInternalError, []); +end; + +procedure TBaseSymbolTable.RaiseError(const Message: string; params: array of Const); +var + I: Integer; +begin + if RaiseE then + begin + raise Exception.Create(Format(Message, params)); + end + else + begin + if LastCard > 0 then + for I:= LastCard + 1 to Card do + Records[I].Name := ''; + + REG_ERROR := Format(Message, params); + REG_OK := false; + + if Message = errUndeclaredIdentifier then + REG_ERROR := ''; + end; +end; + +function TBaseSymbolTable.GetShiftsOfDynamicFields(ATypeId: Integer): TIntegerList; + +procedure GetArrayShifts(TypeID: Integer; S: Integer); forward; + +procedure GetRecordShifts(TypeID: Integer; S: Integer); +var + I, T, T1: Integer; + RI: TSymbolRec; +begin + for I:=TypeId + 1 to Card do + begin + RI := Records[I]; + + if RI = SR0 then + break; + + if (RI.Kind = KindTYPE_FIELD) and (RI.Level = TypeId) then + begin + T := RI.FinalTypeId; + case T of +{$IFNDEF PAXARM} + typeANSISTRING, typeWIDESTRING, +{$ENDIF} + typeUNICSTRING, typeDYNARRAY, typeVARIANT, typeOLEVARIANT: + result.Add(RI.Shift + S); + typeCLASS: + result.Add(RI.Shift + S); + typeRECORD: + begin + T1 := TerminalTypeOf(RI.TypeID); + GetRecordShifts(T1, RI.Shift); + end; + typeARRAY: + begin + T1 := TerminalTypeOf(RI.TypeID); + GetArrayShifts(T1, RI.Shift); + end; + end; + end; + end; +end; + +procedure GetArrayShifts(TypeID: Integer; S: Integer); +var + RangeTypeId, ElemTypeId, H1, H2, T, I, ElemSize, P: Integer; +begin + GetArrayTypeInfo(TypeId, RangeTypeId, ElemTypeId); + H1 := GetLowBoundRec(RangeTypeId).Value; + H2 := GetHighBoundRec(RangeTypeId).Value; + + ElemSize := Records[ElemTypeId].Size; + + T := Records[ElemTypeId].FinalTypeId; + + case T of +{$IFNDEF PAXARM} + typeANSISTRING, typeWIDESTRING, +{$ENDIF} + typeUNICSTRING, typeDYNARRAY, typeVARIANT, typeOLEVARIANT: + begin + P := S; + for I:=0 to H2 - H1 do + begin + result.Add(P); + Inc(P, SizeOfPointer); + end; + end; + typeCLASS: + begin + P := S; + for I:=0 to H2 - H1 do + begin + result.Add(P); + Inc(P, SizeOfPointer); + end; + end; + typeRECORD: + begin + P := S; + for I:=0 to H2 - H1 do + begin + TypeID := TerminalTypeOf(ElemTypeId); + GetRecordShifts(TypeId, P); + Inc(P, ElemSize); + end; + end; + typeARRAY: + begin + P := S; + for I:=0 to H2 - H1 do + begin + TypeID := TerminalTypeOf(ElemTypeId); + GetArrayShifts(TypeId, P); + Inc(P, ElemSize); + end; + end; + end; +end; + +var + T: Integer; +begin + result := TIntegerList.Create; + T := Records[ATypeId].FinalTypeId; + case T of + typeRECORD: GetRecordShifts(ATypeId, 0); + typeARRAY: GetArrayShifts(ATypeId, 0); + end; +end; + +function TBaseSymbolTable.GetTypesOfDynamicFields(ATypeId: Integer): TIntegerList; + + procedure GetArrayTypes(TypeID: Integer); forward; + + procedure GetRecordTypes(TypeID: Integer); + var + I, T, T1: Integer; + RI: TSymbolRec; + begin + for I:=TypeId + 1 to Card do + begin + RI := Records[I]; + + if RI = SR0 then + break; + + if (RI.Kind = KindTYPE_FIELD) and (RI.Level = TypeId) then + begin + T := RI.FinalTypeId; + case T of +{$IFNDEF PAXARM} + typeANSISTRING, typeWIDESTRING, +{$ENDIF} + typeUNICSTRING, typeDYNARRAY, typeVARIANT, typeOLEVARIANT: + result.Add(RI.TerminalTypeId); + typeCLASS: + result.Add(RI.TerminalTypeId); + typeRECORD: + begin + T1 := TerminalTypeOf(RI.TypeID); + GetRecordTypes(T1); + end; + typeARRAY: + begin + T1 := TerminalTypeOf(RI.TypeID); + GetArrayTypes(T1); + end; + end; + end; + end; + end; + + procedure GetArrayTypes(TypeID: Integer); + var + RangeTypeId, ElemTypeId, H1, H2, T, I: Integer; + begin + GetArrayTypeInfo(TypeId, RangeTypeId, ElemTypeId); + H1 := GetLowBoundRec(RangeTypeId).Value; + H2 := GetHighBoundRec(RangeTypeId).Value; + + T := Records[ElemTypeId].FinalTypeId; + + case T of +{$IFNDEF PAXARM} + typeANSISTRING, typeWIDESTRING, +{$ENDIF} + typeUNICSTRING, typeDYNARRAY, typeVARIANT, typeOLEVARIANT: + for I:=0 to H2 - H1 do + result.Add(Records[ElemTypeId].TerminalTypeId); + typeRECORD: + begin + for I:=0 to H2 - H1 do + begin + TypeID := TerminalTypeOf(ElemTypeId); + GetRecordTypes(TypeId); + end; + end; + typeCLASS: + begin + for I:=0 to H2 - H1 do + result.Add(Records[ElemTypeId].TerminalTypeId); + end; + typeARRAY: + for I:=0 to H2 - H1 do + begin + TypeID := TerminalTypeOf(ElemTypeId); + GetArrayTypes(TypeId); + end; + end; + end; +begin + result := TIntegerList.Create; + case Records[ATypeId].FinalTypeId of + typeRECORD: GetRecordTypes(ATypeId); + typeARRAY: GetArrayTypes(ATypeId); + end; +end; + +function TBaseSymbolTable.HasDynamicFields(ATypeId: Integer): Boolean; +var + L: TIntegerList; +begin + L := GetShiftsOfDynamicFields(ATypeID); + result := L.Count > 0; + FreeAndNil(L); +end; + +function TBaseSymbolTable.TerminalTypeOf(TypeID: Integer): Integer; +begin + result := TypeID; + if Records[result].TypeID = typeALIAS then + result := Records[result].TerminalTypeId; +end; + +function TBaseSymbolTable.FindDefaultPropertyId(i_TypeId: Integer): Integer; +var + I: Integer; + RI: TSymbolRec; +begin + for I:=i_TypeId + 1 to Card do + begin + RI := Records[I]; + + if RI = SR0 then + break; + + if RI.Kind = KindNAMESPACE then + break; + + with RI do + if (Kind = kindPROP) and (Level = i_TypeId) and IsDefault then + begin + result := I; + Exit; + end; + end; + + if Records[i_TypeId].AncestorId > 0 then + result := FindDefaultPropertyId(Records[i_TypeId].AncestorId) + else + result := 0; +end; + +function TBaseSymbolTable.FindConstructorId(i_TypeId: Integer): Integer; +var + I, temp: Integer; + RI: TSymbolRec; +begin + temp := 0; + + for I:=i_TypeId + 1 to Card do + begin + RI := Records[I]; + + if RI = SR0 then + break; + if RI.Kind = KindNAMESPACE then + break; + + with RI do + if (Kind = kindCONSTRUCTOR) and (Level = i_TypeId) then + begin + if StrEql(RI.Name, 'Create') then + begin + result := I; + Exit; + end + else + temp := I; + end; + end; + + result := temp; + + if result = 0 then + if Records[i_TypeId].Host then + begin + if i_TypeId = H_TObject then + Exit; + + i_TypeId := Records[i_TypeId].AncestorId; + + if I_typeId = 0 then + Exit; + + result := FindConstructorId(i_TypeId); + end; +end; + +function TBaseSymbolTable.FindConstructorIdEx(i_TypeId: Integer): Integer; +begin + result := FindConstructorId(I_TypeId); + + if result = 0 then + if Records[i_TypeId].AncestorId <> 0 then + result := FindConstructorIdEx(Records[i_TypeId].AncestorId); +end; + +function TBaseSymbolTable.FindConstructorIds(i_TypeId: Integer): TIntegerList; +var + I: Integer; + RI: TSymbolRec; +begin + result := TIntegerList.Create; + + for I:=i_TypeId + 1 to Card do + begin + RI := Records[I]; + + if RI = SR0 then + break; + if RI.Kind = KindNAMESPACE then + break; + + with RI do + if (Kind = kindCONSTRUCTOR) and (Level = i_TypeId) then + begin + result.Add(I); + end; + end; +end; + +function TBaseSymbolTable.FindDestructorId(i_TypeId: Integer): Integer; +var + I: Integer; + RI: TSymbolRec; +begin + for I:=i_TypeId + 1 to Card do + begin + RI := Records[I]; + + if RI = SR0 then + break; + + with RI do + if (Kind = kindDESTRUCTOR) and (Level = i_TypeId) then + begin + result := I; + Exit; + end; + end; + result := 0; +end; + +function TBaseSymbolTable.FindDestructorIdEx(i_TypeId: Integer): Integer; +begin + + result := FindDestructorId(i_TypeId); + if result = 0 then + if Records[i_TypeId].AncestorId <> 0 then + result := FindDestructorIdEx(Records[i_TypeId].AncestorId); +end; + +function TBaseSymbolTable.Inherits(T1, T2: Integer): Boolean; +begin + T1 := Records[T1].TerminalTypeId; + T2 := Records[T2].TerminalTypeId; + + result := (T1 = T2); + if not result then + result := Records[T1].Inherits(T2); +end; + +function TBaseSymbolTable.Supports(T1, T2: Integer): Boolean; +var + I: Integer; + GuidList: TGuidList; +begin + T1 := Records[T1].TerminalTypeId; + T2 := Records[T2].TerminalTypeId; + + result := (T1 = T2); + + if result then + Exit; + + if T2 = H_IUnknown then + begin + result := true; + Exit; + end; + + GuidList := Records[T1].SupportedInterfaces; + + if GuidList = nil then + begin + result := false; + Exit; + end; + + if GuidList.HasId(T2) then + begin + result := true; + Exit; + end; + + for I:=0 to GuidList.Count - 1 do + if Supports(GuidList[I].Id, T2) then + begin + result := true; + Exit; + end; +end; + +function TBaseSymbolTable.RegisterDummyType(LevelId: Integer; + const TypeName: String): Integer; +begin + result := LookupType(TypeName, LevelId, true); + if result > 0 then + Exit; + + with AddRecord do + begin + Name := TypeName; + Kind := KindTYPE; + TypeID := typeVOID; + Host := true; + Shift := 0; + Level := LevelId; + IsDummyType := true; + + result := Id; + end; +end; + +function TBaseSymbolTable.RegisterSomeType(LevelId: Integer; + const TypeName: String): Integer; +begin + with AddRecord do + begin + Name := TypeName; + Kind := KindTYPE; + TypeID := typeVOID; + Host := true; + Shift := 0; + Level := LevelId; + + result := Id; + end; + + SomeTypeList.Add(TypeName, result); +end; + +function TBaseSymbolTable.GetLocalCount(SubId: Integer): Integer; +var + I, SelfId: Integer; + RI: TSymbolRec; +begin + result := 0; + SelfId := GetSelfId(SubId); + for I:=SubId + 1 to Card do + begin + RI := Self[I]; + if RI.Level = SubId then + if RI.Kind = KindVAR then + if RI.OwnerId = 0 then + if RI.PatternId = 0 then + if RI.Local then + begin + if RI.Name <> '' then + if RI.Name <> '@' then + Inc(result); + end + else if I = SelfId then + begin + if RI.Name <> '' then + Inc(result); + end; + if RI.Kind = kindNAMESPACE then + break; + end; +end; + +function TBaseSymbolTable.IsLocalOf(Id, SubId: Integer): Boolean; +var + RI: TSymbolRec; +begin + result := false; + RI := Records[Id]; + + if RI.Param then + Exit; + + if RI.Level = SubId then + if RI.Kind = KindVAR then + if RI.OwnerId = 0 then + if RI.PatternId = 0 then + if RI.Local then + begin + if RI.Name <> '' then + if RI.Name <> '@' then + result := true; + end + else if Id = GetSelfId(SubId) then + begin + if RI.Name <> '' then + result := true; + end; +end; + +function TBaseSymbolTable.GetLocalId(SubId, LocalVarNumber: Integer): Integer; +var + I, K, SelfId: Integer; + RI: TSymbolRec; +begin + K := -1; + SelfId := GetSelfId(SubId); + for I:=SubId + 1 to Card do + begin + RI := Self[I]; + if RI.Level = SubId then + if RI.Kind = KindVAR then + if RI.OwnerId = 0 then + if RI.PatternId = 0 then + if RI.Local then + begin + if RI.Name <> '' then + if RI.Name <> '@' then + begin + Inc(K); + if K = LocalVarNumber then + begin + result := I; + Exit; + end; + end; + end + else if I = SelfId then + begin + if RI.Name <> '' then + begin + Inc(K); + if K = LocalVarNumber then + begin + result := I; + Exit; + end; + end; + end; + end; + + result := 0; + RaiseError(errInvalidIndex, [LocalVarNumber]); +end; + +function TBaseSymbolTable.IsParam(SubId, Id: Integer): Boolean; +var + R: TSymbolRec; +begin + R := Self[Id]; + result := (R.Level = SubId) and + R.Param and + (GetSelfId(SubId) <> Id); +end; + +function TBaseSymbolTable.IsVar(LevelId, Id: Integer): Boolean; +var + R: TSymbolRec; +begin + if Self[LevelId].Kind = KindSUB then + if GetSelfId(LevelId) = Id then + begin + result := (Self[Id].Name <> '') and (not Self[Id].Param); + Exit; + end; + + result := false; + + R := Self[Id]; + if R.Param then + Exit; + if R.TypedConst then + Exit; + + if R.Level = LevelId then + if R.Kind = KindVAR then + if R.OwnerId = 0 then + if R.Name <> '' then + if R.Name <> '@' then + result := true; +end; + +function TBaseSymbolTable.IsConst(LevelId, Id: Integer): Boolean; +var + R: TSymbolRec; +begin + R := Self[Id]; + result := ((R.Kind = KindCONST) and (R.Level = LevelId) and + (R.Name <> '')) + or + R.TypedConst; +end; + +function TBaseSymbolTable.IsType(LevelId, Id: Integer): Boolean; +var + R: TSymbolRec; +begin + R := Self[Id]; + result := (R.Kind = KindTYPE) and (R.Level = LevelId) and + (R.Name <> ''); +end; + +function TBaseSymbolTable.IsNamespace(LevelId, Id: Integer): Boolean; +var + R: TSymbolRec; +begin + R := Self[Id]; + result := (R.Kind = KindNAMESPACE) and (R.Level = LevelId); +end; + +function TBaseSymbolTable.IsTypeField(LevelId, Id: Integer): Boolean; +var + R: TSymbolRec; +begin + R := Self[Id]; + result := (R.Kind = KindTYPE_FIELD) and (R.Level = LevelId); +end; + +function TBaseSymbolTable.IsEnumMember(LevelId, Id: Integer): Boolean; +var + R: TSymbolRec; +begin + R := Self[Id]; + result := (R.Kind = KindCONST) and (R.OwnerId = LevelId); +end; + +function TBaseSymbolTable.IsProperty(ClassId, Id: Integer): Boolean; +var + R: TSymbolRec; +begin + R := Self[Id]; + result := (R.Kind = KindPROP) and (R.Level = ClassId); +end; + +function TBaseSymbolTable.IsProcedure(LevelId, Id: Integer): Boolean; +var + R: TSymbolRec; +begin + R := Self[Id]; + result := (R.Kind = KindSUB) and (R.Level = LevelId) and + (R.FinalTypeId = typeVOID); + if result then + result := Self[Id].Name <> ''; +end; + +function TBaseSymbolTable.IsFunction(LevelId, Id: Integer): Boolean; +var + R: TSymbolRec; +begin + R := Self[Id]; + result := (R.Kind = KindSUB) and (R.Level = LevelId) and + (R.FinalTypeId <> typeVOID); + if result then + result := Self[Id].Name <> ''; +end; + +function TBaseSymbolTable.IsConstructor(ClassId, Id: Integer): Boolean; +var + R: TSymbolRec; +begin + R := Self[Id]; + result := (R.Kind = KindCONSTRUCTOR) and + (R.Level = ClassId); +end; + +function TBaseSymbolTable.IsDestructor(ClassId, Id: Integer): Boolean; +var + R: TSymbolRec; +begin + R := Self[Id]; + result := (R.Kind = KindDESTRUCTOR) and + (R.Level = ClassId); +end; + +function TBaseSymbolTable.GetGlobalCount(NamespaceId: Integer): Integer; +var + I: Integer; + RI: TSymbolRec; +begin + result := 0; + for I:=NamespaceId + 1 to Card do + begin + RI := Self[I]; + if RI.Host then + continue; + if RI.Level = NamespaceId then + if RI.OwnerId = 0 then + if RI.IsGlobalVar then + if RI.Name <> '' then + if RI.Name <> '@' then + Inc(result); + end; +end; + +function TBaseSymbolTable.GetGlobalId(NamespaceId, GlobalVarNumber: Integer): Integer; +var + I, K: Integer; + RI: TSymbolRec; +begin + K := -1; + for I:=NamespaceId + 1 to Card do + begin + RI := Self[I]; + if RI.Host then + continue; + if RI.Level = NamespaceId then + if RI.OwnerId = 0 then + if RI.IsGlobalVar then + if RI.Name <> '' then + if RI.Name <> '@' then + begin + Inc(K); + if K = GlobalVarNumber then + begin + result := I; + Exit; + end; + end; + end; + result := 0; + RaiseError(errInvalidIndex, [GlobalVarNumber]); +end; + +function TBaseSymbolTable.GetFieldCount(Id: Integer; TypeMapRec: TTypeMapRec = nil): Integer; +var + T, FinTypeId, I: Integer; + R: TSymbolRec; +begin + result := 0; + if Id = 0 then + Exit; + FinTypeId := Self[Id].FinalTypeId; + if FinTypeId = typeCLASS then + begin + if TypeMapRec <> nil then + if TypeMapRec.Completed then + begin + result := TypeMapRec.Fields.Count; + Exit; + end; + + T := Self[Id].TerminalTypeId; + for I:=T + 1 to Card do + begin + R := Self[I]; + if (R.Level = T) and (R.Kind = KindTYPE_FIELD) then + begin + Inc(result); + if TypeMapRec <> nil then + TypeMapRec.Fields.Add(I); + end + else if R.Kind = kindNAMESPACE then + break; + end; + Inc(result, GetFieldCount(Self[T].AncestorId, TypeMapRec)); + end + else if FinTypeId = typeRECORD then + begin + // Added by Oberon + if TypeMapRec <> nil then + if TypeMapRec.Completed then + begin + result := TypeMapRec.Fields.Count; + Exit; + end; + // end oberon + + T := Self[Id].TerminalTypeId; + for I:=T + 1 to Card do + begin + R := Self[I]; + if (R.Level = T) and (R.Kind = KindTYPE_FIELD) then + begin + Inc(result); + if TypeMapRec <> nil then + TypeMapRec.Fields.Add(I); + end + else if R.Kind = kindNAMESPACE then + break; + end; + end; +end; + +function TBaseSymbolTable.GetPublishedPropCount(Id: Integer): Integer; +var + T, FinTypeId, I: Integer; + R: TSymbolRec; +begin + result := 0; + if Id = 0 then + Exit; + FinTypeId := Self[Id].FinalTypeId; + if FinTypeId = typeCLASS then + begin + T := Self[Id].TerminalTypeId; + while not Self[T].Host do + T := Self[T].AncestorId; + + for I:=T + 1 to Card do + begin + R := Self[I]; + if (R.Level = T) and (R.Kind = KindPROP) and + R.IsPublished and + (not (R.FinalTypeId in [typeEVENT, typeRECORD])) then + Inc(result) + else if R.Kind = kindNAMESPACE then + break; + end; + end + else + Exit; +end; + +function TBaseSymbolTable.GetPublishedPropDescriptorId(Id, PropNumber: Integer): Integer; +var + T, FinTypeId, I: Integer; + R: TSymbolRec; +begin + result := 0; + if Id = 0 then + Exit; + FinTypeId := Self[Id].FinalTypeId; + if FinTypeId = typeCLASS then + begin + T := Self[Id].TerminalTypeId; + + while not Self[T].Host do + T := Self[T].AncestorId; + + result := -1; + for I:=T + 1 to Card do + begin + R := Self[I]; + if (R.Level = T) and (R.Kind = KindPROP) and + R.IsPublished and + (not (R.FinalTypeId in [typeEVENT, typeRECORD])) then + begin + Inc(result); + if result = PropNumber then + begin + result := I; + Exit; + end; + end + else if R.Kind = kindNAMESPACE then + break; + end; + end + else + RaiseError(errClassTypeRequired, []); +end; + +function TBaseSymbolTable.GetPublishedPropName(Id, PropNumber: Integer): String; +var + PropDescriptorId: Integer; +begin + PropDescriptorId := GetPublishedPropDescriptorId(Id, PropNumber); + result := Self[PropDescriptorId].Name; +end; + +function TBaseSymbolTable.GetPublishedPropValueAsString(P: Pointer; StackFrameNumber: Integer; + Id, PropNumber: Integer): String; +var + OwnerAddress: Pointer; + TypeId, PropDescriptorId: Integer; + X: TObject; + PropName: String; + V: Variant; +begin + try + TypeId := Self[Id].TerminalTypeId; + PropDescriptorId := GetPublishedPropDescriptorId(TypeId, PropNumber); + + OwnerAddress := GetFinalAddress(P, StackFrameNumber, Id); + if OwnerAddress = nil then + result := errError + else + begin + X := TObject(OwnerAddress^); + if X = nil then + result := errError + else + begin + if X = nil then + result := errError + else + begin + PropName := Records[PropDescriptorId].Name; + if GetPropInfo(X, PropName) = nil then + result := errError + else + begin + V := GetPropValue(X, PropName, true); + result := VarToStr(V); + end; + end; + end; + end; + except + result := errError; + end; +end; + +function TBaseSymbolTable.GetFieldDescriptorId(Id, + FieldNumber: Integer; + TypeMapRec: TTypeMapRec = nil + ): Integer; +var + T, FinTypeId, I, J, K: Integer; + R: TSymbolRec; + L: TIntegerList; +begin + result := 0; + FinTypeId := Self[Id].FinalTypeId; + + if FinTypeId = typeCLASS then + begin + T := Self[Id].TerminalTypeId; + + if TypeMapRec <> nil then + if TypeMapRec.TypeId = T then + if TypeMapRec.Completed then + begin + result := TypeMapRec.Fields[FieldNumber]; + Exit; + end; + + L := TIntegerList.Create; + + try + L.Add(T); + + T := Self[T].AncestorId; + while T <> 0 do + begin + L.Insert(0, T); + T := Self[T].AncestorId; + end; + + K := -1; + for I:=0 to L.Count - 1 do + begin + T := L[I]; + for J:=T + 1 to Card do + begin + R := Self[J]; + if (R.Level = T) and (R.Kind = KindTYPE_FIELD) then + begin + Inc(K); + if K = FieldNumber then + begin + result := J; + Exit; + end; + end; + end; + end; + + finally + FreeAndNil(L); + end; + end + else if FinTypeId = typeRECORD then + begin + T := Self[Id].TerminalTypeId; + + if TypeMapRec <> nil then + if TypeMapRec.TypeId = T then + if TypeMapRec.Completed then + begin + result := TypeMapRec.Fields[FieldNumber]; + Exit; + end; + + K := -1; + for J:=T + 1 to Card do + begin + R := Self[J]; + if (R.Level = T) and (R.Kind = KindTYPE_FIELD) then + begin + Inc(K); + if K = FieldNumber then + begin + result := J; + Exit; + end; + end; + end; + end; +end; + +function TBaseSymbolTable.GetFieldDescriptorIdByName(Id: Integer; const FieldName: String): Integer; +var + T, FinTypeId, I, J: Integer; + R: TSymbolRec; + L: TIntegerList; +begin + result := 0; + FinTypeId := Self[Id].FinalTypeId; + + if FinTypeId = typeCLASS then + begin + T := Self[Id].TerminalTypeId; + L := TIntegerList.Create; + + try + L.Add(T); + + T := Self[T].AncestorId; + while T <> 0 do + begin + L.Insert(0, T); + T := Self[T].AncestorId; + end; + + for I:=0 to L.Count - 1 do + begin + T := L[I]; + for J:=T + 1 to Card do + begin + R := Self[J]; + if (R.Level = T) and (R.Kind = KindTYPE_FIELD) then + begin + if StrEql(R.Name, FieldName) then + begin + result := J; + Exit; + end; + end; + end; + end; + + finally + FreeAndNil(L); + end; + end + else if FinTypeId = typeRECORD then + begin + T := Self[Id].TerminalTypeId; + for J:=T + 1 to Card do + begin + R := Self[J]; + if (R.Level = T) and (R.Kind = KindTYPE_FIELD) then + begin + if StrEql(R.Name, FieldName) then + begin + result := J; + Exit; + end; + end; + end; + end; +end; + +function TBaseSymbolTable.GetFieldName(Id, FieldNumber: Integer): String; +var + FieldDescriptorId: Integer; +begin + FieldDescriptorId := GetFieldDescriptorId(Id, FieldNumber); + result := Self[FieldDescriptorId].Name; +end; + +function TBaseSymbolTable.GetFieldAddress(P: Pointer; + StackFrameNumber, + Id, + FieldNumber: Integer; + TypeMapRec: TTypeMapRec = nil + ): Pointer; +var + FieldDescriptorId, Shift: Integer; + X: TObject; +begin + result := GetFinalAddress(P, StackFrameNumber, Id); + + try + CheckMemory(Result, sizeof (TObject)); + if Self[Id].FinalTypeId = typeCLASS then + begin + X := TObject(result^); + if X = nil then + begin + result := nil; + Exit; + end; + +{$IFNDEF FPC} + CheckMemory (pointer (integer (pointer (X)^) + vmtSelfPtr), - vmtSelfPtr); + if pointer (pointer (integer (pointer (X)^) + vmtSelfPtr)^) <> pointer(pointer (X)^) then + raise EAbort.Create (errNotValidObject); +{$ENDIF} + result := Pointer(X); + end; + except + result := nil; + end; + + if result = nil then + Exit; + + FieldDescriptorId := GetFieldDescriptorId(Id, FieldNumber, TypeMapRec); + Shift := Self[FieldDescriptorId].Shift; + + result := ShiftPointer(result, Shift); +end; + +function TBaseSymbolTable.GetStrVal(Address: Pointer; + TypeId: Integer; + TypeMapRec: TTypeMapRec = nil; + BriefCls: Boolean = false): String; +var + B: Byte; + W: Word; + X: TObject; + C: TClass; + P: Pointer; + V: Variant; + FinTypeId: Integer; + I, K: Integer; + FieldAddress: Pointer; + FieldDescriptorId, FieldTypeId, FieldShift: Integer; + RangeTypeId, ElemTypeId, K1, K2: Integer; + ByteSet: TByteSet; + EnumNames: TStringList; +begin + FinTypeId := Self[TypeId].FinalTypeId; + + if TypeMapRec <> nil then + if TypeMapRec.TypeId <> TypeId then + TypeMapRec := nil; + + try + + case FinTypeId of + typeBOOLEAN, typeBYTEBOOL, typeWORDBOOL, typeLONGBOOL: + begin + CheckMemory(Address, sizeof(Byte)); + B := Byte(Address^); + if B <> 0 then + result := 'true' + else + result := 'false'; + end; + typeBYTE, typeENUM: + begin + CheckMemory(Address, SizeOf(Byte)); + B := Byte(Address^); + result := IntToStr(B); + end; +{$IFNDEF PAXARM} + typeANSICHAR: + begin + CheckMemory(Address, SizeOf(Byte)); + B := Byte(Address^); + result := String(AnsiChar(B)); + end; + typeWIDESTRING: + begin + CheckMemory (Address, sizeof (WideString)); + if pointer (Address^) <> nil then + begin + // First check to be able to length if WideString in bytes + CheckMemory(pointer(integer(Address^) - SizeOf(LongInt)), SizeOf(LongInt)); + + // Let's check if contents are accesible + I := Integer(pointer(integer(Address^) - SizeOf(LongInt))^); + // I contains length of string in bytes + if I = 0 then + begin + result := ''; + Exit; + end; + CheckMemory (pointer(Address^), I + SizeOf (WideChar)); // One extra WideChar for #0 + result := WideString(Address^); + end + else Result := ''; + end; + typeANSISTRING: + begin + // Check pointer to string + CheckMemory (Address, sizeof (AnsiString)); + if pointer (Address^) <> nil then + begin + // First check to be able to access length of string and the ref count integer + CheckMemory(pointer(integer(Address^) - SizeOf(LongInt) * 2), SizeOf(LongInt) * 2); + + // Let's check if contents are accesible + I := Integer(pointer(integer(Address^) - SizeOf(LongInt))^); + // I contains length of string + if I = 0 then + begin + result := ''; + Exit; + end; + CheckMemory (pointer(Address^), I + 1); + result := String(AnsiString(Address^)); + end + else + begin + result := ''; + Exit; + end; + end; + typeSHORTSTRING: + begin + CheckMemory (Address, sizeof (ShortString)); + result := String(ShortString(Address^)); + end; +{$ENDIF} + typeSET: + begin + CheckMemory(Address, SizeOf(TByteSet)); + TypeId := Self[TypeId].PatternId; + FinTypeId := Self[TypeId].FinalTypeId; + if FinTypeId = typeENUM then + EnumNames := ExtractEnumNames(TypeId) + else + EnumNames := nil; + ByteSet := UpdateSet(TByteSet(Address^), Self[TypeId].Size); + result := ByteSetToString(ByteSet, FinTypeId, EnumNames); + if EnumNames <> nil then + FreeAndNil(EnumNames); + end; + typeINTEGER: + begin + CheckMemory(Address, SizeOf(LongInt)); + result := IntToStr(Integer(Address^)); + end; + typeCARDINAL: + begin + CheckMemory(Address, SizeOf(Cardinal)); + result := IntToStr(Cardinal(Address^)); + end; + typeSMALLINT: + begin + CheckMemory (Address, sizeof(SmallInt)); + result := IntToStr(SmallInt(Address^)); + end; + typeSHORTINT: + begin + CheckMemory (Address, sizeof (ShortInt)); + result := IntToStr(ShortInt(Address^)); + end; + typeEVENT: + begin + FieldTypeId := typePOINTER; + FieldShift := SizeOfPointer; + FieldAddress := Address; + + result := Self[TypeId].Name + '('; + result := result + GetStrVal(FieldAddress, FieldTypeId); + + result := result + ','; + + FieldAddress := ShiftPointer(Address, FieldShift); + result := result + GetStrVal(FieldAddress, FieldTypeId); + + result := result + ')'; + end; + typeRECORD: + begin + result := Self[TypeId].Name + '('; + K := GetFieldCount(TypeId, TypeMapRec); + for I:=0 to K - 1 do + begin + FieldDescriptorId := GetFieldDescriptorId(TypeId, I, TypeMapRec); + + FieldTypeId := Self[FieldDescriptorId].TypeId; + FieldShift := Self[FieldDescriptorId].Shift; + + FieldAddress := ShiftPointer(Address, FieldShift); + + result := result + GetStrVal(FieldAddress, FieldTypeId); + if I < K - 1 then + result := result + ','; + end; + result := result + ')'; + end; + typeCLASS: + begin + // Check pointer to object + CheckMemory (Address, sizeof (TObject)); + X := TObject(Address^); + if Assigned(X) then + begin + if X is TGC_Object then + begin + result := TGC_Object(X).__toString; + Exit; + end; + + if BriefCls then + begin + result := Self[TypeId].Name + + '(' + Format('0x%x', [Cardinal(Address^)]) + ')'; + Exit; + end; + + result := Self[TypeId].Name + '('; + K := GetFieldCount(TypeId, TypeMapRec); + for I:=0 to K - 1 do + begin + FieldDescriptorId := GetFieldDescriptorId(TypeId, I, TypeMapRec); + + FieldTypeId := Self[FieldDescriptorId].TypeId; + FieldShift := Self[FieldDescriptorId].Shift; + +{$IFNDEF FPC} + // Check VMT for readability and to see if it's a true VMT + CheckMemory (pointer (integer (pointer (X)^) + vmtSelfPtr), - vmtSelfPtr); + if pointer (pointer (integer (pointer (X)^) + vmtSelfPtr)^) <> pointer(pointer (X)^) then + raise EAbort.Create (errNotValidObject); +{$ENDIF} + + FieldAddress := ShiftPointer(Pointer(X), FieldShift); + + if FieldTypeId = TypeId then + result := result + GetStrVal(FieldAddress, FieldTypeId, nil, true) + else + result := result + GetStrVal(FieldAddress, FieldTypeId); + if I < K - 1 then + result := result + ','; + end; + result := result + ')'; + end + else + result := 'nil'; + end; + typeCLASSREF: + begin + CheckMemory (Address, sizeof (TClass)); + C := TClass(Address^); + if Assigned(C) then + result := Self[TypeId].Name + else + result := 'nil'; + end; + typePOINTER: + begin + CheckMemory (Address, sizeof (Cardinal)); + result := Format('0x%x', [Cardinal(Address^)]); + end; + typeINTERFACE: + begin + CheckMemory (Address, sizeof (Cardinal)); + if Cardinal(Address^) = 0 then + result := 'nil' + else + result := Self[TypeId].Name + '(' + + Format('0x%x', [Cardinal(Address^)]) + ')'; + end; + typePROC: + begin + CheckMemory (Address, sizeof (Cardinal)); + result := Format('0x%x', [Cardinal(Address^)]); + end; + typeARRAY: + begin + result := Self[TypeId].Name + '('; + + GetArrayTypeInfo(TypeId, RangeTypeId, ElemTypeId); + FieldShift := Self[ElemTypeId].Size; + + K1 := GetLowBoundRec(RangeTypeId).Value; + K2 := GetHighBoundRec(RangeTypeId).Value; + + for I:=K1 to K2 do + begin + FieldAddress := ShiftPointer(Address, (I - K1) * FieldShift); + result := result + GetStrVal(FieldAddress, ElemTypeId); + if I < K2 then + result := result + ','; + end; + + result := result + ')'; + end; + typeDYNARRAY: + begin + CheckMemory (Address, sizeof (Pointer)); + Address := Pointer(Address^); + + if Address = nil then + begin + result := 'nil'; + Exit; + end; + + result := Self[TypeId].Name + '('; + + ElemTypeId := Self[TypeId].PatternId; + FieldShift := Self[ElemTypeId].Size; + + P := ShiftPointer(Address, - SizeOf(LongInt)); + + K1 := 0; + K2 := Integer(P^); + + for I:=K1 to K2 - 1 do + begin + FieldAddress := ShiftPointer(Address, (I - K1) * FieldShift); + result := result + GetStrVal(FieldAddress, ElemTypeId); + if I < K2 - 1 then + result := result + ','; + end; + + result := result + ')'; + end; + typeUNICSTRING: + begin + CheckMemory (Address, sizeof (UnicString)); + if pointer (Address^) <> nil then + begin + // First check to be able to length if WideString in bytes + CheckMemory(pointer(integer(Address^) - SizeOf(LongInt)), SizeOf(LongInt)); + + // Let's check if contents are accesible + I := Integer(pointer(integer(Address^) - SizeOf(LongInt))^); + // I contains length of string in bytes + if I = 0 then + begin + result := ''; + Exit; + end; + CheckMemory (pointer(Address^), I + SizeOf (WideChar)); // One extra WideChar for #0 + result := UnicString(Address^); + end + else Result := ''; + end; + typeWIDECHAR: + begin + CheckMemory(Address, sizeof(WideChar)); + W := Word(Address^); + result := WideChar(W); + end; + typeWORD: + begin + CheckMemory(Address, sizeof(Word)); + W := Word(Address^); + result := IntToStr(W); + end; + typeINT64: + begin + CheckMemory (Address, sizeof (Int64)); + result := IntToStr(Int64(Address^)); + end; + typeSINGLE: + begin + CheckMemory (Address, sizeof (Single)); + result := FloatToStr(Single(Address^)); + end; + typeDOUBLE: + begin + CheckMemory (Address, sizeof (Double)); + result := FloatToStr(Double(Address^)); + end; + typeEXTENDED: + begin + CheckMemory (Address, sizeof (Extended)); + result := FloatToStr(Extended(Address^)); + end; + typeCURRENCY: + begin + CheckMemory (Address, sizeof (Extended)); + result := CurrToStr(Currency(Address^)); + end; + typeVARIANT, typeOLEVARIANT: + begin + try + begin + CheckMemory (Address, sizeof (Variant)); + CheckVariantData (Address^); + if VarType(Variant(Address^)) = varError then + result := '' + else + result := VarToStr(Variant(Address^)); + end + finally + { Variant is residing within the context of script, + if we don't clean the TVarData before leaving the scope + Delphi code will add cleanup code that will either free + memory it shouldn't or even try to cleanup garbage, causing trouble regardless. + The variant we evaluated was done so for temporary reasons anc copied for memory + residing on the stack, as such, not cleanup is fine. Script should cleanup + when the variant leaves its own scope } + FillChar (V, Sizeof (V), 0); + end; + end + else + result := ''; + end; + except + result := errInvalidValue; + end; +end; + +function TBaseSymbolTable.GetVariantVal(Address: Pointer; + TypeId: Integer; + TypeMapRec: TTypeMapRec = nil): Variant; +var + B: Byte; + W: Word; + X: TObject; + C: TClass; + P: Pointer; + V: Variant; + FinTypeId: Integer; + I, K: Integer; + FieldAddress: Pointer; + FieldDescriptorId, FieldTypeId, FieldShift: Integer; + RangeTypeId, ElemTypeId, K1, K2: Integer; +begin + FinTypeId := Self[TypeId].FinalTypeId; + + if TypeMapRec <> nil then + if TypeMapRec.TypeId <> TypeId then + TypeMapRec := nil; + + try + + case FinTypeId of + typeBOOLEAN, typeBYTEBOOL, typeWORDBOOL, typeLONGBOOL: + begin + CheckMemory(Address, sizeof(Byte)); + B := Byte(Address^); + if B <> 0 then + result := true + else + result := false; + end; + typeBYTE, typeENUM: + begin + CheckMemory(Address, SizeOf(Byte)); + B := Byte(Address^); + result := B; + end; +{$IFNDEF PAXARM} + typeANSICHAR: + begin + CheckMemory(Address, SizeOf(Byte)); + B := Byte(Address^); + result := String(AnsiChar(B)); + end; +{$ENDIF} + typeSET: + begin + CheckMemory(Address, SizeOf(TByteSet)); + TypeId := Self[TypeId].PatternId; + FinTypeId := Self[TypeId].FinalTypeId; + result := ByteSetToString(TByteSet(Address^), FinTypeId); + end; + typeINTEGER: + begin + CheckMemory(Address, SizeOf(LongInt)); + result := Integer(Address^); + end; + typeCARDINAL: + begin + CheckMemory(Address, SizeOf(Cardinal)); + result := Cardinal(Address^); + end; + typeSMALLINT: + begin + CheckMemory (Address, sizeof(SmallInt)); + result := SmallInt(Address^); + end; + typeSHORTINT: + begin + CheckMemory (Address, sizeof (ShortInt)); + result := ShortInt(Address^); + end; + typeEVENT: + begin + FieldTypeId := typePOINTER; + FieldShift := SizeOfPointer; + FieldAddress := Address; + + result := Self[TypeId].Name + '('; + result := result + GetStrVal(FieldAddress, FieldTypeId); + + result := result + ','; + + FieldAddress := ShiftPointer(Address, FieldShift); + result := result + GetStrVal(FieldAddress, FieldTypeId); + + result := result + ')'; + end; + typeRECORD: + begin + result := Self[TypeId].Name + '('; + K := GetFieldCount(TypeId, TypeMapRec); + for I:=0 to K - 1 do + begin + FieldDescriptorId := GetFieldDescriptorId(TypeId, I, TypeMapRec); + + FieldTypeId := Self[FieldDescriptorId].TypeId; + FieldShift := Self[FieldDescriptorId].Shift; + + FieldAddress := ShiftPointer(Address, FieldShift); + + result := result + GetStrVal(FieldAddress, FieldTypeId); + if I < K - 1 then + result := result + ','; + end; + result := result + ')'; + end; + typeCLASS: + begin + // Check pointer to object + CheckMemory (Address, sizeof (TObject)); + X := TObject(Address^); + if Assigned(X) then + begin + result := Self[TypeId].Name + '('; + K := GetFieldCount(TypeId, TypeMapRec); + for I:=0 to K - 1 do + begin + FieldDescriptorId := GetFieldDescriptorId(TypeId, I, TypeMapRec); + + FieldTypeId := Self[FieldDescriptorId].TypeId; + FieldShift := Self[FieldDescriptorId].Shift; + +{$IFNDEF FPC} + // Check VMT for readability and to see if it's a true VMT + CheckMemory (pointer (integer (pointer (X)^) + vmtSelfPtr), - vmtSelfPtr); + if pointer (pointer (integer (pointer (X)^) + vmtSelfPtr)^) <> pointer(pointer (X)^) then + raise EAbort.Create (errNotValidObject); +{$ENDIF} + + FieldAddress := ShiftPointer(Pointer(X), FieldShift); + + result := result + GetStrVal(FieldAddress, FieldTypeId); + if I < K - 1 then + result := result + ','; + end; + result := result + ')'; + end + else + result := 0; + end; + typeCLASSREF: + begin + CheckMemory (Address, sizeof (TClass)); + C := TClass(Address^); + if Assigned(C) then + result := Self[TypeId].Name + else + result := 0; + end; + typePOINTER: + begin + CheckMemory (Address, sizeof (Cardinal)); + result := Integer(Address^); + end; + typeINTERFACE: + begin + CheckMemory (Address, sizeof (Cardinal)); + if Cardinal(Address^) = 0 then + result := 0 + else + result := Self[TypeId].Name + '(' + + Format('0x%x', [Cardinal(Address^)]) + ')'; + end; + typePROC: + begin + CheckMemory (Address, sizeof (Cardinal)); + result := Integer(Address^); + end; + typeARRAY: + begin + result := Self[TypeId].Name + '('; + + GetArrayTypeInfo(TypeId, RangeTypeId, ElemTypeId); + FieldShift := Self[ElemTypeId].Size; + + K1 := GetLowBoundRec(RangeTypeId).Value; + K2 := GetHighBoundRec(RangeTypeId).Value; + + for I:=K1 to K2 do + begin + FieldAddress := ShiftPointer(Address, (I - K1) * FieldShift); + result := result + GetStrVal(FieldAddress, ElemTypeId); + if I < K2 then + result := result + ','; + end; + + result := result + ')'; + end; + typeDYNARRAY: + begin + CheckMemory (Address, sizeof (Pointer)); + Address := Pointer(Address^); + + if Address = nil then + begin + result := 0; + Exit; + end; + + result := Self[TypeId].Name + '('; + + ElemTypeId := Self[TypeId].PatternId; + FieldShift := Self[ElemTypeId].Size; + + P := ShiftPointer(Address, - SizeOf(LongInt)); + + K1 := 0; + K2 := Integer(P^); + + for I:=K1 to K2 - 1 do + begin + FieldAddress := ShiftPointer(Address, (I - K1) * FieldShift); + result := result + GetStrVal(FieldAddress, ElemTypeId); + if I < K2 - 1 then + result := result + ','; + end; + + result := result + ')'; + end; +{$IFNDEF PAXARM} + typeANSISTRING: + begin + // Check pointer to string + CheckMemory (Address, sizeof (AnsiString)); + if pointer (Address^) <> nil then + begin + // First check to be able to access length of string and the ref count integer + CheckMemory(pointer(integer(Address^) - SizeOf(LongInt) * 2), SizeOf(LongInt) * 2); + + // Let's check if contents are accesible + I := Integer(pointer(integer(Address^) - SizeOf(LongInt))^); + // I contains length of string + if I = 0 then + begin + result := ''; + Exit; + end; + CheckMemory (pointer(Address^), I + 1); + result := String(AnsiString(Address^)); + end + else + begin + result := ''; + Exit; + end; + end; + typeWIDESTRING: + begin + CheckMemory (Address, sizeof (WideString)); + if pointer (Address^) <> nil then + begin + // First check to be able to length if WideString in bytes + CheckMemory(pointer(integer(Address^) - SizeOf(LongInt)), SizeOf(LongInt)); + + // Let's check if contents are accesible + I := Integer(pointer(integer(Address^) - SizeOf(LongInt))^); + // I contains length of string in bytes + if I = 0 then + begin + result := ''; + Exit; + end; + CheckMemory (pointer(Address^), I + SizeOf (WideChar)); // One extra WideChar for #0 + result := WideString(Address^); + end + else Result := ''; + end; + typeSHORTSTRING: + begin + CheckMemory (Address, sizeof (ShortString)); + result := String(ShortString(Address^)); + end; +{$ENDIF} + typeUNICSTRING: + begin + CheckMemory (Address, sizeof (UnicString)); + if pointer (Address^) <> nil then + begin + // First check to be able to length if WideString in bytes + CheckMemory(pointer(integer(Address^) - SizeOf(LongInt)), SizeOf(LongInt)); + + // Let's check if contents are accesible + I := Integer(pointer(integer(Address^) - SizeOf(LongInt))^); + // I contains length of string in bytes + if I = 0 then + begin + result := ''; + Exit; + end; + CheckMemory (pointer(Address^), I + SizeOf (WideChar)); // One extra WideChar for #0 + result := UnicString(Address^); + end + else Result := ''; + end; + typeWIDECHAR: + begin + CheckMemory(Address, sizeof(WideChar)); + W := Word(Address^); + result := WideChar(W); + end; + typeWORD: + begin + CheckMemory(Address, sizeof(Word)); + W := Word(Address^); + result := W; + end; + typeINT64: + begin + CheckMemory (Address, sizeof (Int64)); +{$IFDEF VARIANTS} + result := Int64(Address^); +{$ELSE} + result := Integer(Address^); +{$ENDIF} + end; + typeSINGLE: + begin + CheckMemory (Address, sizeof (Single)); + result := Single(Address^); + end; + typeDOUBLE: + begin + CheckMemory (Address, sizeof (Double)); + result := Double(Address^); + end; + typeEXTENDED: + begin + CheckMemory (Address, sizeof (Extended)); + result := Extended(Address^); + end; + typeCURRENCY: + begin + CheckMemory (Address, sizeof (Extended)); + result := Currency(Address^); + end; + typeVARIANT, typeOLEVARIANT: + begin + try + begin + CheckMemory (Address, sizeof (Variant)); + CheckVariantData (Address^); + result := Variant(Address^); + end + finally + { Variant is residing within the context of script, + if we don't clean the TVarData before leaving the scope + Delphi code will add cleanup code that will either free + memory it shouldn't or even try to cleanup garbage, causing trouble regardless. + The variant we evaluated was done so for temporary reasons anc copied for memory + residing on the stack, as such, not cleanup is fine. Script should cleanup + when the variant leaves its own scope } + FillChar (V, Sizeof (V), 0); + end; + end + else + result := 0; + end; + except + result := errInvalidValue; + end; +end; + +procedure TBaseSymbolTable.CheckVariantData (const V); +var + I: Integer; +begin + if (TVarData (V).VType and varByRef <> 0) or + (TVarData (V).VType and varArray <> 0) + then raise EAbort.Create('varArray of varByRef not supported in debugger'); + case TVarData (V).VType and varTypeMask of + varEmpty, varNull, + varSmallInt, varInteger, varSingle, + varDouble, varCurrency, varDate, + varError, varBoolean, + {$IFDEF VARIANTS} + varShortInt, varWord, varLongWord, varInt64, + {$ENDIF} + varByte : { Everything all right, this types won't cause trouble }; + varOleStr: + begin + with TVarData (V) do + begin + CheckMemory (pointer (integer (VOleStr) - sizeof (integer)), sizeof (integer)); + I := integer (pointer (integer (VOleStr) - sizeof (integer))^); + CheckMemory (VOleStr, I + sizeof (WideChar)); + end; + end; + varString, varUString: + begin + with TVarData (V) do + begin + if Assigned(VString) then + begin + CheckMemory (pointer (integer (VString) - sizeof (integer) * 2), sizeof (integer) * 2); + I := integer (pointer (integer (VString) - sizeof (integer))^); + CheckMemory (VString, I + sizeof (Char)); + end; + end; + end; + else + RaiseError(errInvalidVariantType, []); + end; +end; + +function TBaseSymbolTable.GetVal(Address: Pointer; + TypeId: Integer): Variant; +var + FinTypeId, SZ: Integer; +begin + FinTypeId := Self[TypeId].FinalTypeId; + + try + + SZ := Types.GetSize(TypeId); + if SZ > 0 then + CheckMemory(Address, SZ); + + case FinTypeId of + typeBOOLEAN: result := Boolean(Address^); + typeBYTEBOOL: result := ByteBool(Address^); +{$IFNDEF PAXARM} + typeANSISTRING: result := AnsiString(Address^); + typeWIDESTRING: result := WideString(Address^); + typeSHORTSTRING: result := ShortString(Address^); + typeANSICHAR, +{$ENDIF} + typeBYTE, typeENUM: result := Byte(Address^); + typeINTEGER, typeLONGBOOL: result := Integer(Address^); +{$IFDEF VARIANTS} + typeCARDINAL: result := Cardinal(Address^); +{$ELSE} + typeCARDINAL: result := Integer(Address^); +{$ENDIF} + typeSMALLINT: result := SmallInt(Address^); + typeSHORTINT: result := ShortInt(Address^); +{$IFDEF VARIANTS} + typePOINTER, typeINTERFACE, typeCLASS, typeCLASSREF: result := Cardinal(Address^); +{$ELSE} + typePOINTER, typeINTERFACE, typeCLASS, typeCLASSREF: result := Integer(Address^); +{$ENDIF} + typeUNICSTRING: result := UnicString(Address^); + typeWORD, typeWIDECHAR, typeWORDBOOL: result := Word(Address^); + {$IFDEF VARIANTS} + typeINT64: result := Int64(Address^); + {$ELSE} + typeINT64: result := Integer(Address^); + {$ENDIF} + typeSINGLE: result := Single(Address^); + typeDOUBLE: result := Double(Address^); + typeEXTENDED: result := Extended(Address^); + typeVARIANT, typeOLEVARIANT: + begin + CheckVariantData (Address^); + result := Variant(Address^); + end; + else + RaiseError(errIncompatibleTypesNoArgs, []); + end; + + except + result := Unassigned; + end; +end; + +procedure TBaseSymbolTable.PutVal(Address: Pointer; + TypeId: Integer; const Value: Variant); +var + B: Byte; + FinTypeId: Integer; + W: Word; +begin + FinTypeId := Self[TypeId].FinalTypeId; + + case FinTypeId of + typeBOOLEAN, typeBYTEBOOL: + begin + CheckMemory(Address, SizeOf(Byte)); + if Value then + B := 1 + else + B := 0; + Byte(Address^) := B; + end; + typeBYTE, typeENUM: + begin + CheckMemory(Address, SizeOf(Byte)); + Byte(Address^) := Value; + end; +{$IFNDEF PAXARM} + typeANSICHAR: + begin + CheckMemory(Address, SizeOf(Byte)); + Byte(Address^) := Byte(Value); + end; + typeANSISTRING: + begin + // Check pointer to string + CheckMemory (Address, sizeof (AnsiString)); + AnsiString(Address^) := AnsiString(Value); + end; + typeWIDESTRING: + begin + CheckMemory (Address, sizeof (WideString)); + WideString(Address^) := Value; + end; + typeSHORTSTRING: + begin + CheckMemory (Address, sizeof (ShortString)); + ShortString(Address^) := ShortString(Value); + end; +{$ENDIF} + typeINTEGER, typeLONGBOOL: + begin + CheckMemory (Address, sizeof (integer)); + Integer(Address^) := Integer(Value); + end; + typeCARDINAL: + begin + CheckMemory (Address, sizeof (Cardinal)); + Cardinal(Address^) := Value; + end; + typeSMALLINT: + begin + CheckMemory (Address, sizeof (SmallInt)); + SmallInt(Address^) := Value; + end; + typeSHORTINT: + begin + CheckMemory (Address, sizeof (ShortInt)); + ShortInt(Address^) := Value; + end; + typePOINTER, typeINTERFACE, typeCLASS, typeCLASSREF: + begin + CheckMemory (Address, sizeof (Cardinal)); + Cardinal(Address^) := Value; + end; + typeUNICSTRING: + begin + CheckMemory (Address, sizeof (UnicString)); + UnicString(Address^) := Value; + end; + typeWORD, typeWIDECHAR, typeWORDBOOL: + begin + CheckMemory(Address, SizeOf(Word)); + W := Word(Value); + Word(Address^) := W; + end; + typeINT64: + begin + CheckMemory (Address, sizeof (Int64)); + {$IFDEF VARIANTS} + Int64(Address^) := Value; + {$ELSE} + Int64(Address^) := Integer(Value); + {$ENDIF} + end; + typeSINGLE: + begin + CheckMemory (Address, sizeof (Single)); + Single(Address^) := Value; + end; + typeDOUBLE: + begin + CheckMemory (Address, sizeof (Double)); + Double(Address^) := Value; + end; + typeEXTENDED: + begin + CheckMemory (Address, sizeof (Extended)); + Extended(Address^) := Value; + end; + typeVARIANT, typeOLEVARIANT: + begin + CheckMemory (Address, sizeof (Variant)); + CheckVariantData (Address^); + Variant(Address^) := Value; + end; + else + RaiseError(errIncompatibleTypesNoArgs, []); + end; +end; + +procedure TBaseSymbolTable.PutValue(P: Pointer; StackFrameNumber: Integer; + Id: Integer; const Value: Variant); +var + Address: Pointer; + TypeId: Integer; +begin + Address := GetFinalAddress(P, StackFrameNumber, Id); + TypeId := Self[Id].TerminalTypeId; + + if Address = nil then + Exit; + + PutVal(Address, TypeId, Value); +end; + +function TBaseSymbolTable.GetValue(P: Pointer; StackFrameNumber: Integer; + Id: Integer): Variant; +var + Address: Pointer; + TypeId: Integer; +begin + Address := GetFinalAddress(P, StackFrameNumber, Id); + TypeId := Self[Id].TerminalTypeId; + + if Address = nil then + Exit; + + result := GetVal(Address, TypeId); +end; + +function TBaseSymbolTable.GetValueAsString(P: Pointer; + StackFrameNumber: Integer; + Id: Integer; + TypeMapRec: TTypeMapRec = nil; + BriefCls: Boolean = false): String; +var + Address: Pointer; + TypeId: Integer; +begin + result := '???'; + + Address := GetFinalAddress(P, StackFrameNumber, Id); + TypeId := Self[Id].TerminalTypeId; + + if Address = nil then + Exit; + + result := GetStrVal(Address, TypeId, TypeMapRec); +end; + +function TBaseSymbolTable.GetFieldValueAsString(P: Pointer; + StackFrameNumber: Integer; + Id: Integer; + FieldNumber: Integer; + TypeMapRec: TTypeMapRec = nil; + BriefCls: Boolean = false): String; +var + FieldAddress: Pointer; + TypeId, FieldDescriptorId, FieldTypeId: Integer; +begin + TypeId := Self[Id].TerminalTypeId; + FieldDescriptorId := GetFieldDescriptorId(TypeId, FieldNumber, TypeMapRec); + FieldTypeId := Self[FieldDescriptorId].TypeID; + + FieldAddress := GetFieldAddress(P, StackFrameNumber, Id, FieldNumber, TypeMapRec); + + if FieldAddress = nil then + result := errInvalidValue + else + result := GetStrVal(FieldAddress, FieldTypeId, TypeMapRec, BriefCls); +end; + +function TBaseSymbolTable.GetArrayItemAddress(P: Pointer; StackFrameNumber, Id, + Index: Integer): Pointer; +var + TypeId, RangeTypeId, ElemTypeId, Shift, K1: Integer; +begin + result := GetFinalAddress(P, StackFrameNumber, Id); + TypeId := Self[Id].TerminalTypeId; + GetArrayTypeInfo(TypeId, RangeTypeId, ElemTypeId); + Shift := Self[ElemTypeId].Size; + K1 := GetLowBoundRec(RangeTypeId).Value; + result := ShiftPointer(result, (Index - K1) * Shift); +end; + + +function TBaseSymbolTable.GetArrayItemValueAsString(P: Pointer; StackFrameNumber: Integer; + Id, Index: Integer): String; +var + Address: Pointer; + TypeId, RangeTypeId, ElemTypeId: Integer; +begin + Address := GetArrayItemAddress(P, StackFrameNumber, Id, Index); + TypeId := Self[Id].TerminalTypeId; + GetArrayTypeInfo(TypeId, RangeTypeId, ElemTypeId); + result := GetStrVal(Address, ElemTypeId); +end; + + +function TBaseSymbolTable.GetDynArrayItemAddress(P: Pointer; + StackFrameNumber: Integer; + Id, Index: Integer): Pointer; +var + TypeId, ElemTypeId, Shift: Integer; +begin + result := GetFinalAddress(P, StackFrameNumber, Id); + result := Pointer(result^); + if result = nil then + Exit; + + TypeId := Self[Id].TerminalTypeId; + ElemTypeId := Self[TypeId].PatternId; + Shift := Self[ElemTypeId].Size; + + result := ShiftPointer(result, Index * Shift); +end; + +function TBaseSymbolTable.GetDynArrayItemValueAsString(P: Pointer; StackFrameNumber: Integer; + Id, Index: Integer): String; +var + Address: Pointer; + TypeId, ElemTypeId: Integer; +begin + Address := GetDynArrayItemAddress(P, StackFrameNumber, Id, Index); + TypeId := Self[Id].TerminalTypeId; + ElemTypeId := Self[TypeId].PatternId; + result := GetStrVal(Address, ElemTypeId); +end; + +function TBaseSymbolTable.GetFinalAddress(P: Pointer; StackFrameNumber: Integer; + Id: Integer): Pointer; + +var + Shift: Integer; +begin + result := nil; + + Shift := Self[Id].Shift; + + if Self[Id].Param then + begin + result := TBaseRunner(P).GetParamAddress(StackFrameNumber, Shift); + if Self[Id].ByRef or Self[Id].ByRefEx then + result := Pointer(result^); + end + else if Self[Id].Local then + begin + result := TBaseRunner(P).GetLocalAddress(StackFrameNumber, Shift); + if Self[Id].ByRef or Self[Id].ByRefEx then + result := Pointer(result^); + end + else if Self[Id].IsGlobalVar then + begin + result := TBaseRunner(P).GetAddress(Shift); + if Self[Id].ByRef or Self[Id].ByRefEx or Self[Id].Host then + result := Pointer(result^); + end; +end; + +{$IFNDEF PAXARM} +function TBaseSymbolTable.FindPAnsiCharConst(const S: String; LimitId: Integer): Integer; +var + I: Integer; + R: TSymbolRec; +begin + for I:=Types.Count to LimitId do + begin + R := Records[I]; + if R.Kind = KindCONST then + if R.HasPAnsiCharType then + if R.Value = S then + begin + result := I; + Exit; + end; + end; + result := 0; +end; +{$ENDIF} + +function TBaseSymbolTable.FindPWideCharConst(const S: String; LimitId: Integer): Integer; +var + I: Integer; + R: TSymbolRec; +begin + for I:=Types.Count to LimitId do + begin + R := Records[I]; + if R.Kind = KindCONST then + if R.HasPWideCharType then + if R.Value = S then + begin + result := I; + Exit; + end; + end; + result := 0; +end; + +function TBaseSymbolTable.GetAlignmentSize(TypeId, DefAlign: Integer): Integer; +var + FT, J, temp, + RangeTypeId, ElemTypeId: Integer; + R: TSymbolRec; + K: Integer; +begin + if DefAlign = 1 then + begin + result := DefAlign; + Exit; + end; + + FT := Records[TypeId].FinalTypeId; + if FT in (OrdinalTypes + + [typeCLASS, typeCLASSREF, typePOINTER, +{$IFNDEF PAXARM} + typeANSISTRING, typeWIDESTRING, +{$ENDIF} + typeUNICSTRING, typeDYNARRAY, typeINTERFACE]) then + begin + result := Types.GetSize(FT); + if result > DefAlign then + result := DefAlign; + end + else if FT = typeSET then + begin + result := GetSizeOfSetType(TypeId); + if result > 4 then + result := 1; + end + else if FT = typeSINGLE then + begin + result := 4; + if result > DefAlign then + result := DefAlign; + end + else if FT in [typeDOUBLE, typeCURRENCY, typeEXTENDED] then + begin + result := 8; + if result > DefAlign then + result := DefAlign; + end +{$IFNDEF PAXARM} + else if FT = typeSHORTSTRING then + result := 1 +{$ENDIF} + else if FT = typeARRAY then + begin + TypeId := Records[TypeId].TerminalTypeId; + if Records[TypeId].IsPacked then + begin + result := 1; + Exit; + end; + + GetArrayTypeInfo(TypeId, RangeTypeId, ElemTypeId); + result := GetAlignmentSize(ElemTypeId, DefAlign); + end + else if FT = typeRECORD then + begin + TypeId := Records[TypeId].TerminalTypeId; + if Records[TypeId].IsPacked then + begin + result := 1; + Exit; + end; + + K := Card; + + result := 0; + for J:= TypeId + 1 to K do + begin + R := Records[J]; + + if R = SR0 then + break; + + if (R.Kind = KindTYPE_FIELD) and (R.Level = TypeId) then + begin + temp := GetAlignmentSize(R.TypeId, DefAlign); + if temp > result then + result := temp; + end; + end; + end + else + result := DefAlign; +end; + +function TBaseSymbolTable.FindClassTypeId(Cls: TClass): Integer; +var + I, J: Integer; + S: String; + R: TSymbolRec; + ok: Boolean; + List: TIntegerList; +begin + if StdCard = 0 then + begin + if DllDefined then + S := Cls.ClassName + else + S := ''; + + for I:= Card downto 1 do + with Records[I] do + if DllDefined then + begin + if Kind = KindTYPE then if Name = S then + begin + result := I; + Exit; + end; + end + else if PClass = Cls then + begin + result := I; + Exit; + end; + + result := 0; + Exit; + end; + + S := Cls.ClassName; + + List := HashArray.GetList(S); + + for J:=List.Count - 1 downto 0 do + begin + I := List[J]; + R := Records[I]; + if DllDefined then + ok := StrEql(R.Name, S) and (R.Kind = KindTYPE) + else + ok := R.PClass = Cls; + if ok then + begin + result := I; + Exit; + end; + end; + + result := 0; +end; + +function TBaseSymbolTable.FindClassTypeIdByPti(Pti: PTypeInfo): Integer; +var + I, J: Integer; + S: String; + R: TSymbolRec; + ok: Boolean; + List: TIntegerList; +begin + if StdCard = 0 then + begin + if DllDefined then + S := PTIName(pti) + else + S := ''; + + for I:= Card downto 1 do + with Records[I] do + if DllDefined then + begin + if Kind = KindTYPE then if Name = S then + begin + result := I; + Exit; + end; + end + else if PClass.ClassInfo = Pti then + begin + result := I; + Exit; + end; + + result := 0; + Exit; + end; + + S := PTIName(pti); + + List := HashArray.GetList(S); + + for J:=List.Count - 1 downto 0 do + begin + I := List[J]; + R := Records[I]; + if DllDefined then + ok := StrEql(R.Name, S) and (R.Kind = KindTYPE) + else if R.PClass <> nil then + ok := R.PClass.ClassInfo = Pti + else + ok := false; + if ok then + begin + result := I; + Exit; + end; + end; + + result := 0; +end; + +procedure TBaseSymbolTable.SetVisibility(ClassId: integer; + const MemberName: String; value: Integer); +var + Id: Integer; + Vis: TClassVisibility; +begin + Vis := cvNone; + + if Value = 0 then + Vis := cvPublic + else if Value = 1 then + Vis := cvProtected + else if Value = 2 then + Vis := cvPrivate + else if Value = 3 then + Vis := cvPublished + else + RaiseError(errIncorrectValue, []); + + if ClassId > 0 then + begin + id := Lookup(MemberName, ClassId, true); + if Id > 0 then + Records[Id].Vis := Vis; + end; + +end; + +procedure TBaseSymbolTable.SetVisibility(C: TClass; const MemberName: String; value: Integer); +begin + SetVisibility(FindClassTypeId(C), MemberName, value); +end; + +procedure TBaseSymbolTable.LoadGlobalSymbolTableFromStream(Stream: TStream); +var + Reader: TReader; + I, K: Integer; + R: TSymbolRec; + ClearNextVal: Boolean; + C: TClass; +begin + Reader := TReader.Create(Stream, 4096 * 4); + try + K := Reader.ReadInteger(); + + ClearNextVal := false; + + C := nil; + + for I := StdCard + 1 to StdCard + K do + begin + R := AddRecord; + R.LoadFromStream(Reader); + + if ClearNextVal then + begin + R.Value := Integer(C); + ClearNextVal := false; + end; + + if R.ClassIndex <> -1 then + begin + Inc(LastClassIndex); + R.ClassIndex := LastClassIndex; + + C := Classes.GetClass(R.Name); + + R.PClass := C; + ClearNextVal := true; + end; + end; + + LastShiftValue := Reader.ReadInteger(); + LastClassIndex := Reader.ReadInteger(); + LastSubId := Reader.ReadInteger(); + LastVarId := Reader.ReadInteger(); + + HashArray.Clear; + HashArray.LoadFromStream(Reader); + + SomeTypeList.Clear; + SomeTypeList.LoadFromStream(Reader); + + GuidList.Clear; + GuidList.LoadFromStream(Reader); + + ExternList.Clear; + ExternList.LoadFromStream(Reader); + + finally + FreeAndNil(Reader); + end; +end; + +procedure TBaseSymbolTable.LoadGlobalSymbolTableFromFile(const FileName: String); +var + F: TFileStream; +begin + if not FileExists(FileName) then + RaiseError(errFileNotFound, [FileName]); + F := TFileStream.Create(FileName, fmOpenRead); + try + LoadGlobalSymbolTableFromStream(F); + finally + FreeAndNil(F); + end; +end; + +procedure TBaseSymbolTable.SaveGlobalSymbolTableToStream(Stream: TStream); +var + Writer: TWriter; + I, K: Integer; +begin + Writer := TWriter.Create(Stream, 4096 * 4); + try + K := Card - StdCard; + Writer.WriteInteger(K); + + for I := StdCard + 1 to StdCard + K do + begin + Records[I].SaveToStream(Writer); + end; + + Writer.WriteInteger(LastShiftValue); + Writer.WriteInteger(LastClassIndex); + Writer.WriteInteger(LastSubId); + Writer.WriteInteger(LastVarId); + + HashArray.SaveToStream(Writer); + SomeTypeList.SaveToStream(Writer); + GuidList.SaveToStream(Writer); + ExternList.SaveToStream(Writer); + + finally + FreeAndNil(Writer); + end; +end; + +procedure TBaseSymbolTable.SaveGlobalSymbolTableToFile(const FileName: String); +var + F: TFileStream; +begin + F := TFileStream.Create(FileName, fmCreate); + try + SaveGlobalSymbolTableToStream(F); + finally + FreeAndNil(F); + end; +end; + +procedure TBaseSymbolTable.SaveNamespaceToStream(LevelId: Integer; S: TStream); + +var + BeginId, EndId: Integer; + +function IsExternalId(Id: Integer): Boolean; +begin + if Id > EndId then + result := true + else if Id < BeginId then + begin + if Id < StdCard then + result := false + else + result := true; + end + else + result := false; +end; + +var + Writer: TWriter; + ExternRec: TExternRec; + R: TSymbolRec; + I: Integer; + CurrOffset: Integer; + GUID: TGUID; +begin + CurrOffset := GetDataSize(LevelId); + + Writer := TWriter.Create(S, 4096 * 4); + ExternRec := TExternRec.Create; + + try + + BeginId := LevelId; + EndId := Card; + + for I := LevelId + 1 to Card do + if Records[I].Kind = KindNAMESPACE then + begin + EndId := I - 1; + break; + end; + + Writer.Write(StreamVersion, SizeOf(StreamVersion)); + Writer.Write(BeginId, SizeOf(LongInt)); + Writer.Write(EndId, SizeOf(LongInt)); + Writer.Write(CurrOffset, SizeOf(LongInt)); + + for I := LevelId to EndId do + begin + R := Records[I]; + R.SaveToStream(Writer); + + if (R.Kind = KindTYPE) and (R.TypeId = typeINTERFACE) then + begin + GUID := GuidList.GetGuidByID(I); + Writer.Write(GUID, SizeOf(GUID)); + end; + + if IsExternalId(R.TypeId) then + begin + ExternRec.Id := R.Id; + ExternRec.FullName := Records[R.TypeId].FullName; + ExternRec.RecKind := erTypeId; + + ExternRec.SaveToStream(Writer); + end; + + if IsExternalId(R.PatternId) then + begin + ExternRec.Id := R.Id; + ExternRec.FullName := Records[R.PatternId].FullName; + ExternRec.RecKind := erPatternId; + + ExternRec.SaveToStream(Writer); + end; + + if IsExternalId(R.AncestorId) then + begin + ExternRec.Id := R.Id; + ExternRec.FullName := Records[R.AncestorId].FullName; + ExternRec.RecKind := erAncestorId; + + ExternRec.SaveToStream(Writer); + end; + + if IsExternalId(R.ReadId) then + begin + ExternRec.Id := R.Id; + ExternRec.FullName := Records[R.ReadId].FullName; + ExternRec.RecKind := erReadId; + ExternRec.SaveToStream(Writer); + end; + + if IsExternalId(R.WriteId) then + begin + ExternRec.Id := R.Id; + ExternRec.FullName := Records[R.WriteId].FullName; + ExternRec.RecKind := erWriteId; + ExternRec.SaveToStream(Writer); + end; + + end; + + finally + + FreeAndNil(Writer); + FreeAndNil(ExternRec); + + end; +end; + +procedure TBaseSymbolTable.LoadNamespaceFromStream(S: TStream); + +var + OldNamespaceId, OldEndId: Integer; + +function IsExternalId(Id: Integer): Boolean; +begin + if Id > OldEndId then + result := true + else if Id < OldNamespaceId then + begin + if Id > StdCard then + result := true + else + result := false; + end + else + result := false; +end; + +function IsInternalId(Id: Integer): Boolean; +begin + result := (Id >= OldNamespaceId) and (Id <= OldEndId); +end; + +var + I, J, NamespaceId, K, Delta: Integer; + R: TSymbolRec; + ClearNextVal: Boolean; + Reader: TReader; + ExternRec: TExternRec; + CurrOffset, OldOffset, DeltaOffset: Integer; + First: Boolean; + CurrStreamVersion: Integer; + GUID: TGUID; + GuidRec: TGuidRec; + C: TClass; +begin + C := nil; + + First := true; + + CurrOffset := GetDataSize; + + Reader := TReader.Create(S, 4096 * 4); + ExternRec := TExternRec.Create; + + try + Reader.Read(CurrStreamVersion, SizeOf(StreamVersion)); + if CurrStreamVersion <> StreamVersion then + RaiseError(errIncorrectStreamVersion, []); + + Reader.Read(OldNamespaceId, SizeOf(LongInt)); + Reader.Read(OldEndId, SizeOf(LongInt)); + Reader.Read(OldOffset, SizeOf(LongInt)); + + K := OldEndId - OldNamespaceId + 1; + + R := AddRecord; + NamespaceId := R.Id; + + Delta := NamespaceId - OldNamespaceId; + DeltaOffset := CurrOffset - OldOffset; + + R.LoadFromStream(Reader); + R.Update; + + ClearNextVal := false; + + for I := 2 to K do + begin + R := AddRecord; + + R.LoadFromStream(Reader); + R.Update; + + if (R.Kind = KindTYPE) and (R.TypeId = typeINTERFACE) then + begin + Reader.Read(GUID, SizeOf(GUID)); + GuidList.Add(GUID, R.Id, R.Name); + + if R.SupportedInterfaces <> nil then + for J := R.SupportedInterfaces.Count - 1 downto 0 do + begin + GuidRec := R.SupportedInterfaces[J]; + + if IsExternalId(GuidRec.Id) then + begin + ExternList.Add(R.Id, GuidRec.Name, erGUID); + R.SupportedInterfaces.RemoveAt(J); + end + else if IsInternalId(GuidRec.Id) then + GuidRec.Id := GuidRec.Id + Delta; + end; + end; + + if IsInternalId(R.Level) then + R.Level := R.Level + Delta; + + if R.Shift > 0 then + if R.Kind <> kindTYPE_FIELD then + begin + R.Shift := R.Shift + DeltaOffset; + + if First then + begin + while R.Shift < CurrOffset do + begin + R.Shift := R.Shift + 1; + Inc(DeltaOffset); + end; + + First := false; + end; + end; + + if IsInternalId(R.OwnerId) then + R.OwnerId := R.OwnerId + Delta; + + if IsExternalId(R.TypeId) then + begin + ExternRec.LoadFromStream(Reader); + J := LookupFullName(ExternRec.FullName, true); + if J > 0 then + R.TypeID := J + else + begin + ExternRec.Id := R.Id; + ExternList.Add(ExternRec.Id, ExternRec.FullName, ExternRec.RecKind); + end; + end + else if IsInternalId(R.TypeID) then + R.TypeId := R.TypeId + Delta; + + if IsExternalId(R.PatternId) then + begin + ExternRec.LoadFromStream(Reader); + J := LookupFullName(ExternRec.FullName, true); + if J > 0 then + R.PatternID := J + else + begin + ExternRec.Id := R.Id; + ExternList.Add(ExternRec.Id, ExternRec.FullName, ExternRec.RecKind); + end; + end + else if IsInternalId(R.PatternID) then + R.PatternId := R.PatternId + Delta; + + if IsExternalId(R.AncestorId) then + begin + ExternRec.LoadFromStream(Reader); + J := LookupFullName(ExternRec.FullName, true); + if J > 0 then + R.AncestorID := J + else + begin + ExternRec.Id := R.Id; + ExternList.Add(ExternRec.Id, ExternRec.FullName, ExternRec.RecKind); + end; + end + else if IsInternalId(R.AncestorID) then + R.AncestorId := R.AncestorId + Delta; + + if IsExternalId(R.ReadId) then + begin + ExternRec.LoadFromStream(Reader); + J := LookupFullName(ExternRec.FullName, true); + if J > 0 then + R.ReadId := J + else + begin + ExternRec.Id := R.Id; + ExternList.Add(ExternRec.Id, ExternRec.FullName, ExternRec.RecKind); + end; + end + else if IsInternalId(R.ReadId) then + R.ReadId := R.ReadId + Delta; + + if IsExternalId(R.WriteId) then + begin + ExternRec.LoadFromStream(Reader); + J := LookupFullName(ExternRec.FullName, true); + if J > 0 then + R.WriteId := J + else + begin + ExternRec.Id := R.Id; + ExternList.Add(ExternRec.Id, ExternRec.FullName, ExternRec.RecKind); + end; + end + else if IsInternalId(R.WriteId) then + R.WriteId := R.WriteId + Delta; + + if ClearNextVal then + begin + R.Value := Integer(C); + ClearNextVal := false; + end; + + if R.ClassIndex <> -1 then + begin + Inc(LastClassIndex); + R.ClassIndex := LastClassIndex; + + C := Classes.GetClass(R.Name); + + R.PClass := C; + ClearNextVal := true; + end; + end; + + finally + + FreeAndNil(Reader); + FreeAndNil(ExternRec); + + end; + + LastShiftValue := GetDataSize; + +end; + +procedure TBaseSymbolTable.ResolveExternList(CheckProc: TCheckProc; Data: Pointer); +var + I, J, PositiveIndex: Integer; + GD: TGUID; + RJ: TSymbolRec; +begin + for I := 0 to ExternList.Count - 1 do + with ExternList[I] do + begin + if RecKind = erGUID then + begin + J := LookupType(FullName, true); + + if J = 0 then + begin + if Assigned(CheckProc) then + if not CheckProc(FullName, Data, erNone) then + continue; + + RaiseError(errUndeclaredInterface, [FullName]); + end; + + if Records[Id].SupportedInterfaces = nil then + Records[Id].SupportedInterfaces := TGuidList.Create; + + GD := GuidList.GetGuidByID(J); + + Records[Id].SupportedInterfaces.Add(GD, J, FullName); + + // recreate positive method indexes + + PositiveIndex := -1; + + for J := Id to Card do + begin + RJ := Records[J]; + + if RJ = SR0 then + break; + + if RJ.Kind = kindNAMESPACE then + break; + + if (RJ.Level = Id) and (RJ.Kind = kindSUB) and + (RJ.NegativeMethodIndex < 0) then + begin + if PositiveIndex = -1 then + PositiveIndex := RestorePositiveIndex(Id); + + if PositiveIndex = -1 then + RaiseError(errInternalError, []); + RJ.MethodIndex := Abs(RJ.NegativeMethodIndex) + PositiveIndex; + end; + end; + + continue; + end; + + if RecKind = erTypeId then + begin + if PosCh('.', FullName) > 0 then + begin + J := LookupFullName(FullName, true); + if J = 0 then + J := LookupType(FullName, 0, true); + end + else + J := LookupType(FullName, 0, true) + end + else + begin + J := LookupFullName(FullName, true); + if J = 0 then + J := LookupType(FullName, 0, true); + end; + + if J > 0 then + begin + case RecKind of + erTypeId: Records[Id].TypeID := J; + erPatternId: Records[Id].PatternID := J; + erAncestorId: Records[Id].AncestorID := J; + erReadId: Records[Id].ReadID := J; + erWriteId: Records[Id].WriteID := J; + end; + end + else + begin + case RecKind of + ePropertyInBaseClassId: + begin + if Assigned(CheckProc) then + if not CheckProc(FullName, Data, RecKind) then + continue; + + RaiseError(errPropertyDoesNotExistsInTheBaseClass, [FullName]); + end; + erTypeId: + begin + if Assigned(CheckProc) then + if not CheckProc(FullName, Data, RecKind) then + continue; + +// RaiseError(errTypeNotFound, [FullName]); + end + else + begin + if Assigned(CheckProc) then + if not CheckProc(FullName, Data, RecKind) then + continue; + + RaiseError(errUndeclaredIdentifier, [FullName]); + end; + end; + end; + end; + + if Self.St_Tag > 0 then + TLocalSymbolTable(Self).GlobalST.ResolveExternList(CheckProc, Data); +end; + +procedure TBaseSymbolTable.SaveNamespaceToFile(LevelId: Integer; const FileName: String); +var + F: TFileStream; +begin + F := TFileStream.Create(FileName, fmCreate); + try + SaveNamespaceToStream(LevelId, F); + finally + FreeAndNil(F); + end; +end; + +procedure TBaseSymbolTable.SaveNamespaceToStream(const NamespaceName: String; S: TStream); +var + Id: Integer; +begin + Id := LookupNamespace(NamespaceName, 0, true); + if Id = 0 then + RaiseError(errUndeclaredIdentifier, [NamespaceName]); + SaveNamespaceToStream(Id, S); +end; + +procedure TBaseSymbolTable.SaveNamespaceToFile(const NamespaceName, FileName: String); +var + Id: Integer; +begin + Id := LookupNamespace(NamespaceName, 0, true); + if Id = 0 then + RaiseError(errUndeclaredIdentifier, [NamespaceName]); + SaveNamespaceToFile(Id, FileName); +end; + +procedure TBaseSymbolTable.LoadNamespaceFromFile(const FileName: String); +var + F: TFileStream; +begin + if not FileExists(FileName) then + RaiseError(errFileNotFound, [FileName]); + F := TFileStream.Create(FileName, fmOpenRead); + try + LoadNamespaceFromStream(F); + finally + FreeAndNil(F); + end; +end; + +procedure TBaseSymbolTable.AddScriptFields(ClassId: Integer; FieldList: TMapFieldList); +var + I, TypeId: Integer; + RI: TSymbolRec; + FieldTypeName: String; +begin + for I := ClassId + 1 to Card do + begin + RI := Records[I]; + if RI.Level = ClassId then + if RI.Kind = kindTYPE_FIELD then + begin + TypeId := RI.TypeID; + FieldTypeName := Records[TypeId].Name; + FieldList.Add(RI.Name, RI.Shift, FieldTypeName); + end; + end; + ClassId := Records[ClassId].AncestorId; + if ClassId > 0 then + if not Records[ClassId].Host then + AddScriptFields(ClassId, FieldList); +end; + +procedure TBaseSymbolTable.ExtractNamespaces(const Level: Integer; L: TStrings); +var + I, KK, K1, K2: Integer; + RI: TSymbolRec; + S: String; +begin + for KK := 1 to 2 do + begin + if KK = 1 then + begin + K1 := 1; + if Self.st_tag = 0 then + K2 := Card + else + K2 := TLocalSymbolTable(Self).GlobalST.Card; + end + else + begin + K1 := FirstLocalId + 1; + K2 := Card; + end; + + for I := K1 to K2 do + begin + RI := Records[I]; + if RI.Kind = KindNAMESPACE then + begin + if I = H_PascalNamespace then + continue; + if I = H_BasicNamespace then + continue; + if I = JS_JavaScriptNamespace then + continue; + if I = JS_TempNamespaceId then + continue; + if I = H_PaxCompilerFramework then + continue; + if I = H_PaxCompilerSEH then + continue; + + S := RI.Name; + L.AddObject(S, TObject(I)); + end; + end; + end; +end; + +procedure TBaseSymbolTable.ExtractMembers(const Id: Integer; L: TStrings; + Lang: TPaxLang = lngPascal; + SharedOnly: Boolean = false; + VisSet: TMemberVisibilitySet = [cvPublic, cvPublished]); + + function ExtractParams(R: TSymbolRec): String; + var + LP: TStringList; + J: Integer; + begin + if R.Kind = KindPROP then + if R.ReadId <> 0 then + R := Records[R.ReadId]; + + result := ''; + if R.Count > 0 then + begin + LP := TStringList.Create; + try + ExtractParameters(R.Id, LP, Lang); + for J := 0 to LP.Count - 1 do + begin + result := result + LP[J]; + if J <> LP.Count - 1 then + case Lang of + lngBasic: + result := result + ', '; + else + result := result + '; '; + end; + end; + finally + FreeAndNil(LP); + end; + end; + end; + + function IndexOfEx(List: TStrings; + S: String; + P: Integer): Integer; + var + I: Integer; + begin + result := -1; + S := Copy(S, 1, P); + for I := 0 to List.Count - 1 do + if StrEql(Copy(L[I], 1, P), S) then + begin + result := I; + Exit; + end; + end; + +var + T, I, K, K0: Integer; + R: TSymbolRec; + S, P: String; + IsNamespace: Boolean; + PP: Integer; +begin + IsNamespace := false; + + if Id = 0 then + begin + T := 0; + IsNamespace := true; + end + else if Records[Id].Kind = kindNAMESPACE then + begin + T := Id; + IsNamespace := true; + end + else + begin + T := Records[Id].TerminalTypeId; + if T in [0, typeVOID] then + Exit; + end; + + if T > FirstLocalId then + K := Card + else + K := TLocalSymbolTable(Self).GlobalST.Card; + + if Id > 0 then + if Records[T].FinalTypeId = typeCLASSREF then + begin + T := Records[T].PatternId; + SharedOnly := true; + end; + + K0 := T; + if Id = 0 then + begin + K0 := FirstLocalId; + K := Card; + end; + + for I:= K0 + 1 to K do + begin + R := Records[I]; + + if R.Kind = KindNAMESPACE then + if not IsNamespace then + break; + + if R.Level = T then + begin + if IsNamespace then + if R.InImplementation then + continue; + + if not (R.Vis in VisSet) then +// if not (R.Host and (R.Vis = cvNone)) then // backward compatibility only + if R.Vis <> cvNone then // backward compatibility only + continue; + + if SharedOnly then + if not R.IsSharedMethod then + continue; + + PP := -1; + S := R.Name; + if IsValidName(S) then + case R.Kind of + kindCONSTRUCTOR: + begin + P := ExtractParams(R); + case Lang of + lngBasic: + begin + S := 'Sub ' + R.Name + '(' + P + ')'; + end + else + begin + if P = '' then + S := 'constructor ' + R.Name + ';' + else + S := 'constructor ' + R.Name + '(' + P + ');'; + end; + end; + if L.IndexOf(S) = -1 then + L.AddObject(S, TObject(R.Id)); + end; + kindDESTRUCTOR: + begin + case Lang of + lngBasic: + begin + S := 'Sub ' + R.Name + '()'; + end; + else + begin + S := 'destructor ' + R.Name + ';'; + end; + end; + if L.IndexOf(S) = -1 then + L.AddObject(S, TObject(R.Id)); + end; + kindSUB: + begin + P := ExtractParams(R); + + case Lang of + lngBasic: + begin + if R.TypeId in [0, typeVOID] then + S := 'Sub ' + R.Name + '(' + P + ')' + else + S := 'Function ' + R.Name + '(' + P + ') As ' + + Records[R.TypeId].NativeName; + end; + else + begin + if R.TypeId in [0, typeVOID] then + begin + if P = '' then + S := 'procedure ' + R.Name + ';' + else + S := 'procedure ' + R.Name + '(' + P + ');'; + end + else + begin + if P = '' then + S := 'function ' + R.Name + ': ' + + Records[R.TypeId].NativeName + ';' + else + S := 'function ' + R.Name + '(' + P + '): ' + + Records[R.TypeId].NativeName + ';'; + end; + end; + end; + + if L.IndexOf(S) = -1 then + L.AddObject(S, TObject(R.Id)); + end; + kindTYPE_FIELD: + begin + case Lang of + lngBasic: + S := 'Dim ' + R.Name + ' As ' + Records[R.TypeId].NativeName; + else + S := 'field ' + R.Name + ': ' + Records[R.TypeId].NativeName + ';'; + end; + if L.IndexOf(S) = -1 then + L.AddObject(S, TObject(R.Id)); + end; + kindPROP: + begin + P := ExtractParams(R); + case Lang of + lngBasic: + begin + if P = '' then + S := 'Property ' + R.Name + + ' As ' + Records[R.TypeId].NativeName + else + begin + S := 'Property ' + R.Name + + '(' + P + ')' + + ' As ' + Records[R.TypeId].NativeName; + PP := PosCh('(', S); + end; + end + else + begin + if P = '' then + S := 'property ' + R.Name + + ': ' + Records[R.TypeId].NativeName + ';' + else + begin + S := 'property ' + R.Name + + '[' + P + ']' + + ': ' + Records[R.TypeId].NativeName + ';'; + PP := PosCh('[', S); + end; + end; + end; + + if PP = -1 then + begin + if L.IndexOf(S) = -1 then + L.AddObject(S, TObject(R.Id)); + end + else + begin + if IndexOfEx(L, S, PP) = -1 then + L.AddObject(S, TObject(R.Id)); + end; + + end; + kindVAR: + begin + case Lang of + lngBasic: + S := 'Dim ' + R.Name + ' As ' + Records[R.TypeId].NativeName; + else + S := 'var ' + R.Name + ': ' + Records[R.TypeId].NativeName + ';'; + end; + if L.IndexOf(S) = -1 then + L.AddObject(S, TObject(R.Id)); + end; + kindCONST: + begin + case Lang of + lngBasic: + S := 'Const ' + R.Name + ' As ' + + Records[R.TypeId].NativeName + '= ' + + ValueStr(R.Id); + else + S := 'const ' + R.Name + ': ' + + Records[R.TypeId].NativeName + '= ' + + ValueStr(R.Id) + + ';'; + end; + if L.IndexOf(S) = -1 then + L.AddObject(S, TObject(R.Id)); + end; + kindTYPE: + begin + case Lang of + lngBasic: + S := 'Type ' + R.Name; + else + S := 'type ' + R.Name + ';'; + end; + if L.IndexOf(S) = -1 then + L.AddObject(S, TObject(R.Id)); + end; + end; + end; + end; + + if IsFrameworkTypeId(T) then + Exit; + + if Records[T].AncestorId > 0 then + ExtractMembers(Records[T].AncestorId, L, lang, SharedOnly, VisSet); + +// if Records[T].FinalTypeId <> typeINTERFACE then +// Exit; + + if Records[T].SupportedInterfaces = nil then + Exit; + + for I:=0 to Records[T].SupportedInterfaces.Count - 1 do + ExtractMembers(Records[T].SupportedInterfaces[I].Id, L, Lang, SharedOnly, VisSet); +end; + +function TBaseSymbolTable.ValueStr(I: Integer): String; +var + VarObject: TVarObject; + B: Integer; +begin + if Records[I].DefVal <> '' then + begin + result := Records[I].DefVal; + if Records[I].FinalTypeId in (CharTypes + StringTypes) then + result := '''' + result + ''''; + Exit; + end; + + if VarType(Records[I].Value) = varEmpty then + result := '' + else if IsVarObject(Records[I].Value) then + begin + VarObject := VariantToVarObject(Records[I].Value); + if VarObject = nil then + result := 'nil' + else + result := VarObject.ToStr; + end + else if Records[I].FinalTypeId in CharTypes then + begin + B := Records[I].Value; + result := '''' + chr(B) + ''''; + end + else + result := VarToStr(Records[I].Value); + result := ReplaceCh(#0, '_', result); + + if result = '' then + result := '''' + '''' + else if Records[I].FinalTypeId in [typePOINTER, + typeCLASS, + typeCLASSREF, + typeINTERFACE] then + if result = '0' then + result := 'nil'; +end; + +procedure TBaseSymbolTable.ExtractParameters(Id: Integer; L: TStrings; + Lang: TPaxLang = lngPascal; + SkipParameters: Integer = 0); +var + I, J, K, Skp: Integer; + R: TSymbolRec; + S: String; +begin + K := Records[Id].Count; + J := 0; + Skp := 0; + for I := Id + 1 to Card do + if IsParam(Id, I) then + begin + Inc(Skp); + if Skp <= SkipParameters then + continue + else + begin + Inc(J); + + R := Records[I]; + S := R.Name; + if not IsValidName(S) then + begin + S := Copy(Records[R.TypeId].Name, 1, 1); + if L.IndexOf(S) >= 0 then + S := S + Chr(J); + end; + + case Lang of + lngBasic: + begin + S := S + ' As ' + + Records[R.TypeId].NativeName; + if R.ByRef then + S := 'ByRef ' + S + else if R.IsConst then + S := 'Const ' + S; + end; + else + begin + S := S + ': ' + + Records[R.TypeId].NativeName; + if R.ByRef then + S := 'var ' + S + else if R.IsConst then + S := 'const ' + S; + end; + end; + + if R.Optional then + begin + S := S + '= ' + ValueStr(I); + end; + + L.AddObject(S, TObject(R.Id)); + if J = K then + break; + end; + end; +end; + +procedure TBaseSymbolTable.ExtractParametersEx(Id: Integer; + L: TStrings; + Upcase: Boolean; + SkipParameters: Integer = 0); +var + OverList: TIntegerList; + I: Integer; +begin + OverList := LookUpAll(Records[Id].Name, + Records[Id].Level, + Upcase); + try + for I := 0 to OverList.Count - 1 do + begin + ExtractParameters(OverList[I], L, lngPascal, SkipParameters); + if I <> OverList.Count - 1 then + L.Add(PARAMS_DELIMITER); + end; + finally + FreeAndNil(OverList); + end; +end; + +procedure TBaseSymbolTable.AddTypes(const TypeName: String; L: TStrings; + ErrorIndex: Integer; Upcase: Boolean); +var + I, J, K1, K2: Integer; + List: TIntegerList; + RI: TSymbolRec; + ok: Boolean; + R: TUndeclaredTypeRec; +begin + K1 := L.Count; + + List := HashArray.GetList(TypeName); + for J := List.Count - 1 downto 0 do + begin + I := List[J]; + RI := Records[I]; + if RI.Kind = kindTYPE then + begin + if UpCase then + ok := StrEql(RI.Name, TypeName) + else + ok := RI.Name = TypeName; + if ok then + begin + if L.IndexOf(RI.FullName) = -1 then + begin + R := TUndeclaredTypeRec.Create; + R.Id := I; + R.ErrorIndex := ErrorIndex; + L.AddObject(RI.FullName, R); + end; + end; + end; + end; + + K2 := L.Count; + if K1 = K2 then + if L.IndexOf(TypeName) = -1 then + begin + R := TUndeclaredTypeRec.Create; + R.Id := 0; + R.ErrorIndex := ErrorIndex; + L.AddObject(TypeName, R); + end; +end; + +procedure TBaseSymbolTable.AddUndeclaredIdent(const IdentName: String; L: TStrings; + ErrorIndex: Integer; Upcase: Boolean); +var + I, J, K1, K2, Level: Integer; + List: TIntegerList; + RI: TSymbolRec; + ok: Boolean; + R: TUndeclaredIdentRec; +begin + K1 := L.Count; + + List := HashArray.GetList(IdentName); + for J := List.Count - 1 downto 0 do + begin + I := List[J]; + RI := Records[I]; + if RI.Kind in (KindSUBS + [KindVAR, KindCONST, KindTYPE, KindNAMESPACE]) then + if not RI.Param then + begin + if UpCase then + ok := StrEql(RI.Name, IdentName) + else + ok := RI.Name = IdentName; + if ok then + begin + Level := RI.Level; + if Level > 0 then + ok := Records[Level].Kind = KindNAMESPACE; + end; + if ok then + begin + if L.IndexOf(RI.FullName) = -1 then + begin + R := TUndeclaredIdentRec.Create; + R.Id := I; + R.ErrorIndex := ErrorIndex; + L.AddObject(RI.FullName, R); + end; + end; + end; + end; + + K2 := L.Count; + if K1 = K2 then + if L.IndexOf(IdentName) = -1 then + begin + R := TUndeclaredIdentRec.Create; + R.Id := 0; + R.ErrorIndex := ErrorIndex; + L.AddObject(IdentName, R); + end; +end; + +procedure TBaseSymbolTable.CreateInterfaceMethodList(IntfId: Integer; + L: TIntegerList); +var + I: Integer; + R: TSymbolRec; +begin + repeat + IntfId := Records[IntfId].TerminalTypeId; + if IntfId = H_IUnknown then + begin + L.Add(H_QueryInterface); + L.Add(H_AddRef); + L.Add(H_Release); + break; + end; + + for I:= IntfId + 1 to Card do + begin + R := Records[I]; + if R.Level = IntfId then + if R.Kind = kindSUB then + L.Add(I); + end; + if Records[IntfId].SupportedInterfaces = nil then + break; + if Records[IntfId].SupportedInterfaces.Count = 0 then + break; + + IntfId := Records[IntfId].SupportedInterfaces[0].Id; + + until false; +end; + +procedure TBaseSymbolTable.CreateInterfaceMethodList(ClassId, IntfId: Integer; + InterfaceMethodIds, + ClassMethodIds: TIntegerList); +var + I, J, Id, MethodIndex: Integer; + R, RR: TSymbolRec; + Buff: array[0..1000] of Integer; +begin + InterfaceMethodIds.Clear; + ClassMethodIds.Clear; + CreateInterfaceMethodList(IntfId, InterfaceMethodIds); + FillChar(Buff, SizeOf(Buff), 0); + repeat + + I := Card; + while I > ClassId do + begin + R := Records[I]; + + if st_tag > 0 then + if R = SR0 then + begin + I := TLocalSymbolTable(Self).GlobalST.Card; + R := Records[I]; + end; + + if R.Level = ClassId then + if R.Kind = kindSUB then + begin + for J := InterfaceMethodIds.Count - 1 downto 0 do + begin + Id := InterfaceMethodIds[J]; + RR := Records[Id]; + if StrEql(R.Name, RR.Name) then + if StrEql(R.Signature, RR.Signature) then + begin + InterfaceMethodIds.RemoveAt(J); + + MethodIndex := RR.MethodIndex; + + Buff[MethodIndex] := I; + + R.PatternId := RR.Id; + + break; + end; + end; + end; + Dec(I); + end; + + if Records[ClassId].AncestorId = 0 then + break; + + if Records[ClassId].AncestorId = H_TObject then + break; + + ClassId := Records[ClassId].AncestorId; + + until false; + + if InterfaceMethodIds.Count > 0 then + Exit; + + for I:=1 to 1000 do + begin + Id := Buff[I]; + + if Id = 0 then + break; + + ClassMethodIds.Add(Id); + end; +end; + +type + TScriptClassRec = class + public + ClassId: Integer; + AncestorId: Integer; + Processed: Boolean; + PClass: TClass; + VirtualMethodList: TIntegerList; + constructor Create; + destructor Destroy; override; + end; + + TScriptClassList = class(TTypedList) + private + function GetRecord(I: Integer): TScriptClassRec; + public + procedure Reset; + function Add: TScriptClassRec; + function FindClass(ClassId: Integer): TScriptClassRec; + property Records[I: Integer]: TScriptClassRec read GetRecord; default; + end; + +//-- TScriptClassRec ---------------------------------------------------------- + +constructor TScriptClassRec.Create; +begin + inherited; + Processed := false; + VirtualMethodList := TIntegerList.Create; +end; + +destructor TScriptClassRec.Destroy; +begin + FreeAndNil(VirtualMethodList); + inherited; +end; + +//-- TScriptClassList --------------------------------------------------------- + +function TScriptClassList.Add: TScriptClassRec; +begin + result := TScriptClassRec.Create; + L.Add(result); +end; + +procedure TScriptClassList.Reset; +var + I: Integer; +begin + for I:=0 to Count - 1 do + Records[I].Processed := false; +end; + +function TScriptClassList.FindClass(ClassId: Integer): TScriptClassRec; +var + I: Integer; +begin + result := nil; + for I:=0 to Count - 1 do + if Records[I].ClassId = ClassId then + begin + result := Records[I]; + Exit; + end; +end; + +function TScriptClassList.GetRecord(I: Integer): TScriptClassRec; +begin + result := TScriptClassRec(L[I]); +end; + +procedure TBaseSymbolTable.ProcessClassFactory(AClassFactory: Pointer; + AProg: Pointer); + + var + ScriptClassList: TScriptClassList; + + procedure BuildScriptClassList; + var + I, LevelId: Integer; + R: TSymbolRec; + ScriptClassRec: TScriptClassRec; + begin + for I:=FirstLocalId + 1 to Card do + begin + R := Records[I]; + + if R.ClassIndex <> -1 then + begin + if R.Host then + continue; + + if ScriptClassList.FindClass(R.Id) = nil then + begin + ScriptClassRec := ScriptClassList.Add; + ScriptClassRec.ClassId := R.Id; + ScriptClassRec.PClass := R.PClass; + ScriptClassRec.AncestorId := R.AncestorId; + continue; + end; + end; + + if R.Kind in [kindSUB, kindCONSTRUCTOR] then + if (R.CallMode > 0) and (R.DynamicMethodIndex = 0) then + begin + LevelId := R.Level; + + if LevelId = 0 then + continue; + + if Records[LevelId].Host then + continue; + + if Records[LevelId].FinalTypeId <> typeCLASS then + continue; + + ScriptClassRec := ScriptClassList.FindClass(LevelId); + if ScriptClassRec = nil then + begin + ScriptClassRec := ScriptClassList.Add; + ScriptClassRec.ClassId := LevelId; + ScriptClassRec.PClass := Records[LevelId].PClass; + ScriptClassRec.AncestorId := Records[LevelId].AncestorId; + end; + ScriptClassRec.VirtualMethodList.Add(R.Id); + end; + end; + end; + +var + ClassFactory: TPaxClassFactory; + ClassFactoryRec: TPaxClassFactoryRec; + I, J, SubId, CallMode: Integer; + RR: TSymbolRec; + C, CA: TClass; + ScriptClassRec, AncestorScriptClassRec: TScriptClassRec; + VirtualMethodList: TIntegerList; + b: Boolean; + P, Q: PPointerArray; + MethodIndex: Integer; + Prog: TBaseRunner; + MapRec: TMapRec; + Name, FullName, Signature: String; + Address, Adr: Pointer; + OverCount: Integer; + II, JJ, temp: Integer; + Found: Boolean; + MR, SomeMR: TMapRec; + FileName, ProcName: String; + DestProg: Pointer; + T: Integer; +begin + ClassFactory := TPaxClassFactory(AClassFactory); + Prog := TBaseRunner(AProg); + + Prog.ForceMappingEvents; + + ClassFactory.SetupParents(Prog, Prog.ClassList); + ClassFactory.AddInheritedMethods; + + ScriptClassList := TScriptClassList.Create; + try + BuildScriptClassList; + + repeat + b := false; + + for I:=0 to ScriptClassList.Count - 1 do + begin + ScriptClassRec := ScriptClassList[I]; + if ScriptClassRec.Processed then + continue; + + if Records[ScriptClassRec.AncestorId].Host then + begin + ScriptClassRec.Processed := true; + b := true; + end + else + begin + AncestorScriptClassRec := ScriptClassList.FindClass(ScriptClassRec.AncestorId); + if AncestorScriptClassRec.Processed then + begin + ScriptClassRec.Processed := true; + b := true; + end + else + continue; + end; + + C := Records[ScriptClassRec.ClassId].PClass; + P := GetVArray(C); + + VirtualMethodList := ScriptClassRec.VirtualMethodList; + for J:=0 to VirtualMethodList.Count - 1 do + begin + SubId := VirtualMethodList[J]; + CallMode := Records[SubId].CallMode; + Name := Records[SubId].Name; + FullName := Records[SubId].FullName; + Signature := Records[SubId].Signature; + OverCount := Records[SubId].OverCount; + + Address := Prog.GetAddressEx(FullName, OverCount, MR); + + DestProg := Prog; + if Address = nil then + begin + FileName := ExtractOwner(FullName) + '.' + PCU_FILE_EXT; + ProcName := Copy(FullName, PosCh('.', FullName) + 1, Length(FullName)); + Address := Prog.LoadAddressEx(FileName, ProcName, false, OverCount, SomeMR, DestProg); + end; + + if CallMode = cmVIRTUAL then + begin + TBaseRunner(DestProg).WrapMethodAddress(Address); + + MethodIndex := VirtualMethodIndex(C, Address); + if MethodIndex = -1 then + MethodIndex := GetVirtualMethodCount(C) + 1 + else + Inc(MethodIndex); // method index starts from 1, not 0 + + Records[SubId].MethodIndex := MethodIndex; + P^[MethodIndex - 1] := Address; + + MapRec := Prog.ScriptMapTable.LookupEx(FullName, OverCount); + if MapRec <> nil then + MapRec.SubDesc.MethodIndex := MethodIndex; + + for II:=0 to ScriptClassList.Count - 1 do + begin + CA := ScriptClassList[II].PClass; + if CA.InheritsFrom(C) and (C <> CA) then + begin + Found := false; + for JJ:=0 to ScriptClassList[II].VirtualMethodList.Count - 1 do + begin + temp := ScriptClassList[II].VirtualMethodList[JJ]; + RR := Records[temp]; + if RR.MethodIndex = 0 then + if StrEql(Name, RR.Name) then + if StrEql(Signature, RR.Signature) then + begin + Found := true; + + RR.MethodIndex := MethodIndex; + Adr := Prog.GetAddress(RR.FullName, MR); + Prog.WrapMethodAddress(Adr); + Q := GetVArray(CA); + Q^[MethodIndex - 1] := Adr; + + MapRec := Prog.ScriptMapTable.LookupEx(RR.FullName, RR.OverCount); + if MapRec <> nil then + MapRec.SubDesc.MethodIndex := MethodIndex; + + break; + end; + end; + + if not Found then + begin + Q := GetVArray(CA); + Q^[MethodIndex - 1] := Address; + end; + end; + end; + end; + end; + end; + + if b = false then + break; + + until false; + + // process overriden methods + + ScriptClassList.Reset; + + repeat + b := false; + + for I:=0 to ScriptClassList.Count - 1 do + begin + ScriptClassRec := ScriptClassList[I]; + if ScriptClassRec.Processed then + continue; + + if Records[ScriptClassRec.AncestorId].Host then + begin + ScriptClassRec.Processed := true; + b := true; + end + else + begin + AncestorScriptClassRec := ScriptClassList.FindClass(ScriptClassRec.AncestorId); + if AncestorScriptClassRec.Processed then + begin + ScriptClassRec.Processed := true; + b := true; + end + else + continue; + end; + + C := Records[ScriptClassRec.ClassId].PClass; + P := GetVArray(C); + + VirtualMethodList := ScriptClassRec.VirtualMethodList; + for J:=0 to VirtualMethodList.Count - 1 do + begin + SubId := VirtualMethodList[J]; + CallMode := Records[SubId].CallMode; + Name := Records[SubId].Name; + FullName := Records[SubId].FullName; + Signature := Records[SubId].Signature; + OverCount := Records[SubId].OverCount; + Address := Prog.GetAddressEx(FullName, OverCount, MR); + + Prog.WrapMethodAddress(Address); + + if CallMode = cmOVERRIDE then + begin + MethodIndex := Records[SubId].MethodIndex; + if MethodIndex = 0 then + begin + temp := LookupParentMethod(SubId, true, true); + if temp = 0 then + if Records[SubId].DynamicMethodIndex = 0 then + RaiseError(errInternalError, []); + if Records[temp].MethodIndex = 0 then + begin +{$IFDEF UNIC} + if StrEql(Records[SubId].Name, 'toString') then + begin + T := Records[SubId].Level; + ClassFactoryRec := ClassFactory.FindRecordByFullName(Records[T].FullName); + if ClassFactoryRec = nil then + RaiseError(errInternalError, []); + vmtToStringSlot(ClassFactoryRec.VMTPtr)^ := Address; + continue; + end + else if StrEql(Records[SubId].Name, 'GetHashCode') then + begin + T := Records[SubId].Level; + ClassFactoryRec := ClassFactory.FindRecordByFullName(Records[T].FullName); + if ClassFactoryRec = nil then + RaiseError(errInternalError, []); + vmtGetHashCodeSlot(ClassFactoryRec.VMTPtr)^ := Address; + continue; + end + else if StrEql(Records[SubId].Name, 'Equals') then + begin + T := Records[SubId].Level; + ClassFactoryRec := ClassFactory.FindRecordByFullName(Records[T].FullName); + if ClassFactoryRec = nil then + RaiseError(errInternalError, []); + vmtEqualsSlot(ClassFactoryRec.VMTPtr)^ := Address; + continue; + end; +{$ENDIF} + RaiseError(errInternalError, []); + end; + MethodIndex := Records[temp].MethodIndex; + Records[SubId].MethodIndex := MethodIndex; + end; + + P^[MethodIndex - 1] := Address; + + MapRec := Prog.ScriptMapTable.LookupEx(FullName, OverCount); + if MapRec <> nil then + MapRec.SubDesc.MethodIndex := MethodIndex; + + for II:=0 to ScriptClassList.Count - 1 do + begin + CA := ScriptClassList[II].PClass; + if CA.InheritsFrom(C) and (C <> CA) then + begin + Found := false; + for JJ:=0 to ScriptClassList[II].VirtualMethodList.Count - 1 do + begin + temp := ScriptClassList[II].VirtualMethodList[JJ]; + RR := Records[temp]; + if RR.MethodIndex = 0 then + if StrEql(Name, RR.Name) then + if StrEql(Signature, RR.Signature) then + begin + Found := true; + RR.MethodIndex := MethodIndex; + Adr := Prog.GetAddress(RR.FullName, MR); + Prog.WrapMethodAddress(Adr); + Q := GetVArray(CA); + Q^[MethodIndex - 1] := Adr; + + MapRec := Prog.ScriptMapTable.LookupEx(RR.FullName, RR.OverCount); + if MapRec <> nil then + MapRec.SubDesc.MethodIndex := MethodIndex; + + break; + end; + end; + if not Found then + begin + Q := GetVArray(CA); + Q^[MethodIndex - 1] := Address; + end; + end; + end; + end; + end; + end; + + if b = false then + break; + + until false; + + finally + FreeAndNil(ScriptClassList); + end; +end; + +function TBaseSymbolTable.RegisterSpace(K: Integer): Integer; +var + I: Integer; +begin + result := Card; + for I:=1 to K do + AddRecord; +end; + +procedure TBaseSymbolTable.HideClass(C: TClass); +var + I: Integer; + R: TSymbolRec; +begin + for I := 1 to Card do + begin + R := Records[I]; + if R = SR0 then + continue; + if R.PClass <> nil then + if R.PClass = C then + if R.Kind = KindTYPE then + begin + R.Name := '@' + R.Name; + Exit; + end; + end; +end; + +function TBaseSymbolTable.ImportFromTable(st: TBaseSymbolTable; + const FullName: String; + UpCase: Boolean; + DoRaiseError: Boolean = true): Integer; + + function TranslateId(Id: Integer): Integer; + var + S: String; + begin + S := st[Id].FullName; + result := LookupFullName(S, UpCase); + if result = 0 then + result := ImportFromTable(st, S, UpCase); + end; + +var + I, J, Id, Id1, Id2, FinTypeId, Kind, LevelId, TypeBaseId, + OriginTypeId, FieldTypeId, RangeTypeId, ElemTypeId: Integer; + S, TypeName: String; + RI: TSymbolRec; + B1, B2: Integer; + ResTypeId, ParamId, ParamTypeId, H_Sub, OriginId: Integer; + PClass: TClass; + GUID: TGUID; + D: packed record + D1, D2: Double; + end; + IsGlobalMember: Boolean; + MethodClass: TClass; + MethodIndex: Integer; + OverList: TIntegerList; +begin + result := 0; + Id := st.LookupFullName(FullName, UpCase); + + if id = 0 then + begin + if DoRaiseError then + RaiseError(errUndeclaredIdentifier, [FullName]); + Exit; + end; + + MethodClass := nil; + + LevelId := st[Id].Level; + if LevelId > 0 then + begin + IsGlobalMember := st[LevelId].Kind = kindNAMESPACE; + if not IsGlobalMember then + if st[LevelId].FinalTypeId = typeCLASS then + MethodClass := st[LevelId].PClass; + + LevelId := TranslateId(LevelId); + end + else + IsGlobalMember := true; + + Kind := st[id].Kind; + FinTypeId := st[Id].FinalTypeId; + case Kind of + kindTYPE: + if FinTypeId in (StandardTypes - [typeENUM]) then + begin + TypeName := ExtractName(FullName); + if st[id].PatternId = 0 then // this is a subrange type + begin + Id1 := st.GetLowBoundRec(id).Id; + Id2 := st.GetHighBoundRec(id).Id; + + B1 := st[Id1].Value; + B2 := st[Id2].Value; + TypeBaseId := TranslateId(st[id].TypeID); + + result := RegisterSubrangeType(LevelId, TypeName, + TypeBaseId, + B1, B2); + end + else // this is an alias type + begin + OriginTypeId := TranslateId(st[id].PatternId); + result := RegisterTypeAlias(LevelId, TypeName, OriginTypeId); + end; + end + else if FinTypeId = typePOINTER then + begin + TypeName := ExtractName(FullName); + OriginTypeId := TranslateId(st[id].PatternId); + result := RegisterPointerType(LevelId, TypeName, OriginTypeId); + end + else if FinTypeId = typeRECORD then + begin + TypeName := ExtractName(FullName); + result := RegisterRecordType(LevelId, TypeName, st[Id].DefaultAlignment); + for I := Id + 1 to st.Card do + begin + RI := st[I]; + if RI = SR0 then + break; + if RI.Kind = kindTYPE_FIELD then + if RI.Level = Id then + begin + FieldTypeId := TranslateId(RI.TypeID); + RegisterTypeField(result, RI.Name, FieldTypeId, RI.Shift); + end; + end; + end // typeRECORD + else if FinTypeId = typeARRAY then + begin + TypeName := ExtractName(FullName); + st.GetArrayTypeInfo(id, RangeTypeId, ElemTypeId); + RangeTypeId := TranslateId(RangeTypeId); + ElemTypeId := TranslateId(ElemTypeId); + result := RegisterArrayType(LevelId, TypeName, + RangeTypeId, ElemTypeId, st[Id].DefaultAlignment); + end // type ARRAY + else if FinTypeId = typeDYNARRAY then + begin + TypeName := ExtractName(FullName); + ElemTypeId := TranslateId(st[id].PatternId); + result := RegisterDynamicArrayType(LevelId, TypeName, ElemTypeId); + end + else if FinTypeId = typeENUM then + begin + TypeName := ExtractName(FullName); + TypeBaseId := TranslateId(st[id].PatternId); + result := RegisterEnumType(LevelId, TypeName, TypeBaseId); + for I := Id + 1 to st.Card do + begin + RI := st[I]; + if RI = SR0 then + break; + if RI.Kind = KindTYPE then + break; + if RI.Kind = kindCONST then + if RI.TypeId = Id then + RegisterEnumValue(result, RI.Name, RI.Value); + end; + end // typeENUM + else if FinTypeId = typePROC then + begin + TypeName := ExtractName(FullName); + OriginId := TranslateId(st[id].PatternId); + result := RegisterProceduralType(LevelId, TypeName, Records[OriginId].Shift); + end + else if FinTypeId = typeEVENT then + begin + TypeName := ExtractName(FullName); + OriginId := TranslateId(st[id].PatternId); + result := RegisterEventType(LevelId, TypeName, Records[OriginId].Shift); + end + else if FinTypeId = typeSET then + begin + TypeName := ExtractName(FullName); + OriginTypeId := TranslateId(st[id].PatternId); + result := RegisterSetType(LevelId, TypeName, OriginTypeId); + end + else if FinTypeId = typeCLASSREF then + begin + TypeName := ExtractName(FullName); + OriginTypeId := TranslateId(st[id].PatternId); + result := RegisterClassReferenceType(LevelId, TypeName, OriginTypeId); + end + else if FinTypeId = typeCLASS then + begin + PClass := st[id].PClass; + result := RegisterClassType(LevelId, PClass); + for I := Id + 1 to st.Card do + begin + RI := st[I]; + if RI = SR0 then + break; + if RI.Kind = kindTYPE_FIELD then + if RI.Level = Id then + begin + FieldTypeId := TranslateId(RI.TypeID); + RegisterTypeField(result, RI.Name, FieldTypeId, RI.Shift); + end; + end; + end + else if FinTypeId = typeINTERFACE then + begin + TypeName := ExtractName(FullName); + D.D1 := st[Id + 1].Value; + D.D2 := st[Id + 2].Value; + Move(D, GUID, SizeOf(GUID)); + result := RegisterInterfaceType(LevelId, TypeName, GUID); + end + else + RaiseError(errInternalError, []); + // kindTYPE + kindSUB: + begin + S := ExtractName(FullName); + ResTypeId := TranslateId(st[Id].TypeID); + + OverList := TIntegerList.Create; + try + OverList := st.LookUpSub(S, + LevelId, + UpCase); + for J := 0 to OverList.Count - 1 do + begin + Id := OverList[J]; + + if IsGlobalMember then + begin + H_Sub := RegisterRoutine(LevelId, S, ResTypeId, + st[Id].CallConv, st[id].Address); + result := LastSubId; + end + else + begin + H_Sub := RegisterMethod(LevelId, S, ResTypeId, st[Id].CallConv, + st[Id].Address, st[Id].IsSharedMethod, + st[Id].CallMode, + st[Id].MethodIndex); + result := LastSubId; + Self[LastSubId].IsFakeMethod := st[id].IsFakeMethod; + if MethodClass <> nil then + begin + MethodIndex := VirtualMethodIndex(MethodClass, + st[Id].Address) + 1; + if MethodIndex > 0 then + Records[LastSubId].MethodIndex := MethodIndex; + end; + Records[LastSubId].CallMode := st[id].CallMode; + end; + Records[result].OverCount := st[id].OverCount; + for I := 0 to st[id].Count - 1 do + begin + ParamId := st.GetParamId(id, I); + ParamTypeId := TranslateId(st[ParamId].TypeId); + RegisterParameter(H_Sub, ParamTypeId, st[ParamId].Value, + st[ParamId].ByRef, st[ParamId].Name); + Records[Card].IsConst := st[ParamId].IsConst; + Records[Card].IsOpenArray := st[ParamId].IsOpenArray; + Records[Card].Optional := st[ParamId].Optional; + end; + end; + finally + FreeAndNil(OverList); + end; + end; // KindSUB + KindCONSTRUCTOR: + begin + S := ExtractName(FullName); + + OverList := TIntegerList.Create; + try + OverList := st.LookUpSub(S, + LevelId, + UpCase); + for J := 0 to OverList.Count - 1 do + begin + Id := OverList[J]; + H_Sub := RegisterConstructor(LevelId, S, st[id].Address, + st[id].IsSharedMethod, + st[Id].CallConv); + result := LastSubId; + if MethodClass <> nil then + begin + MethodIndex := VirtualMethodIndex(MethodClass, st[id].Address) + 1; + if MethodIndex > 0 then + Records[result].MethodIndex := MethodIndex; + end; + Records[result].OverCount := st[id].OverCount; + for I := 0 to st[id].Count - 1 do + begin + ParamId := st.GetParamId(id, I); + ParamTypeId := TranslateId(st[ParamId].TypeId); + RegisterParameter(H_Sub, ParamTypeId, st[ParamId].Value, + st[ParamId].ByRef, st[ParamId].Name); + Records[Card].IsConst := st[ParamId].IsConst; + Records[Card].IsOpenArray := st[ParamId].IsOpenArray; + Records[Card].Optional := st[ParamId].Optional; + end; + end; + finally + FreeAndNil(OverList); + end; + end; + KindDESTRUCTOR: + begin + S := ExtractName(FullName); + RegisterMethod(LevelId, S, TypeVOID, + st[id].CallConv, st[id].Address, false, + cmOVERRIDE, + 0); + result := LastSubId; + Records[result].Kind := kindDESTRUCTOR; + end; + KindVAR: + begin + S := ExtractName(FullName); + result := RegisterVariable(LevelId, S, + TranslateId(st[Id].TypeID), st[id].Address); + end; + KindCONST: + begin + S := ExtractName(FullName); + result := RegisterConstant(LevelId, S, + TranslateId(st[Id].TypeID), st[id].Value); + end; + end; +end; + +function TBaseSymbolTable.GetOpenArrayHighId(Id: Integer): Integer; +begin + if Records[Id].Kind = KindVAR then + Id := Records[Id].TypeId; + result := Id; + while Records[result].Kind <> KindVAR do + Inc(result); +end; + +function TBaseSymbolTable.GetOuterThisId(TypeId: Integer): Integer; +var + I: Integer; + R: TSymbolRec; +begin + result := 0; + CheckError(TypeId = 0); + if Records[TypeId].Kind <> KindTYPE then + Exit; + if Records[TypeId].FinalTypeId <> typeCLASS then + Exit; + + for I := TypeId + 1 to Card do + begin + R := Records[I]; + if R.Level = TypeId then + if R.Kind = KindTYPE_FIELD then + if R.Name = StrOuterThis then + begin + result := I; + Exit; + end; + end; +end; + +function TBaseSymbolTable.HasAbstractAncestor(ClassId: Integer): Boolean; +begin + result := false; + repeat + ClassId := Records[ClassId].AncestorId; + if ClassId = 0 then + Exit; + if Records[ClassId].IsAbstract then + begin + result := true; + break; + end; + until false; +end; + +function TBaseSymbolTable.GetTypeParameters(Id: Integer): TIntegerList; +var + I: Integer; + R: TSymbolRec; + b: Boolean; +begin + result := TIntegerList.Create; + R := Records[Id]; + if R.Kind = KindTYPE then + begin + if not R.IsGeneric then + Exit; + b := false; + for I := Id + 1 to Card do + begin + R := Records[I]; + if (R.Kind = KindTYPE) and (R.TypeId = typeTYPEPARAM) then + begin + b := true; + result.Add(I); + end + else if b then + Exit; + end; + end + else if R.Kind in KindSUBS then + begin + if not Records[R.Level].IsGeneric then + Exit; + b := false; + for I := Id + 1 to Card do + begin + R := Records[I]; + if (R.Kind = KindTYPE) and (R.TypeId = typeTYPEPARAM) then + begin + b := true; + result.Add(I); + end + else if b then + Exit; + end; + end; +end; + +function TBaseSymbolTable.ExtractEnumNames(EnumTypeId: Integer): TStringList; +var + I: Integer; + R: TSymbolRec; +begin + result := TStringList.Create; + for I:=EnumTypeId + 1 to Card do + begin + R := Records[I]; + if R = SR0 then + break; + if R.Kind in [KindTYPE, KindSUB, KindNAMESPACE] then + break; + if R.TypeId = EnumTypeId then + if R.Name <> '' then + result.Add(R.Name); + end; +end; + +function IsFrameworkTypeId(Id: Integer): Boolean; +begin + result := (Id = H_TFW_Boolean) or + (Id = H_TFW_ByteBool) or + (Id = H_TFW_WordBool) or + (Id = H_TFW_LongBool) or + (Id = H_TFW_Byte) or + (Id = H_TFW_SmallInt) or + (Id = H_TFW_ShortInt) or + (Id = H_TFW_Word) or + (Id = H_TFW_Cardinal) or + (Id = H_TFW_Double) or + (Id = H_TFW_Single) or + (Id = H_TFW_Extended) or + (Id = H_TFW_Currency) or + (Id = H_TFW_AnsiChar) or + (Id = H_TFW_WideChar) or + (Id = H_TFW_Integer) or + (Id = H_TFW_Int64) or + (Id = H_TFW_Variant) or + (Id = H_TFW_DateTime) or + (Id = H_TFW_AnsiString) or + (Id = H_TFW_UnicString) or + (Id = H_TFW_Array); +end; + +function TBaseSymbolTable.GetSizeOfPointer: Integer; +begin + result := SizeOf(Pointer); + if Types.PAX64 then + result := 8; +end; + +function TBaseSymbolTable.GetSizeOfTMethod: Integer; +begin + result := SizeOfPointer * 2; +end; + +procedure TBaseSymbolTable.SetPAX64(value: Boolean); +var + I: Integer; + R: TSymbolRec; +begin + Types.PAX64 := value; + if value then + begin + H_ExceptionPtr := H_ExceptionPtr_64; + H_ByteCodePtr := H_ByteCodePtr_64; + H_Flag := H_Flag_64; + H_SkipPop := H_SkipPop_64; + FirstShiftValue := FirstShiftValue_64; + end + else + begin + H_ExceptionPtr := H_ExceptionPtr_32; + H_ByteCodePtr := H_ByteCodePtr_32; + H_Flag := H_Flag_32; + H_SkipPop := H_SkipPop_32; + FirstShiftValue := FirstShiftValue_32; + end; + for I := Types.Count + 1 to Card do + begin + R := Records[I]; + if R <> SR0 then + if R.Shift <> 0 then + begin + R.Completed := false; + R.FinSize := -1; + end; + end; +end; + +function TBaseSymbolTable.LookupAnonymousInterface(ClassId: Integer): Integer; +var + I, J, SubId: Integer; + List: TIntegerList; + S: String; +begin + result := 0; + SubId := 0; + for I := ClassId + 1 to Card do + begin + if Records[I].Kind = KindSUB then + if Records[I].Level = ClassId then + begin + SubId := I; + break; + end; + end; + if SubId = 0 then + Exit; + if Records[SubId].Name <> ANONYMOUS_METHOD_NAME then + RaiseError(errInternalError, []); + + S := UpperCase(Records[SubId].SignatureEx); + + List := HashArray.GetList(ANONYMOUS_METHOD_NAME); + + for J := List.Count - 1 downto 0 do + begin + I := List[J]; + if I = SubId then + continue; + with Records[I] do + begin + if Kind <> KindSUB then + continue; + if Level = 0 then + continue; + if Name <> ANONYMOUS_METHOD_NAME then + continue; + if Records[Level].FinalTypeId <> typeINTERFACE then + continue; + if UpperCase(Records[I].SignatureEx) <> S then + continue; + + result := Level; + Exit; + end; + end; +end; + +function TBaseSymbolTable.LookupAnonymousMethod(IntfId: Integer): Integer; +var + I: Integer; +begin + result := 0; + for I := IntfId + 1 to Card do + begin + if Records[I].Kind = KindSUB then + if Records[I].Level = IntfId then + begin + if Records[I].Name = ANONYMOUS_METHOD_NAME then + result := I; + break; + end; + end; +end; + +function TBaseSymbolTable.GetTypeHelpers(TypeId: Integer): TIntegerList; + + procedure Collect(T: Integer); + var + I: Integer; + begin + for I := TypeHelpers.Count - 1 downto 0 do + if TypeHelpers.Values[I] = T then + result.Add(TypeHelpers.Keys[I]); + end; + +begin + result := TIntegerList.Create(true); + Collect(TypeId); + if Records[TypeId].HasPAnsiCharType or Records[TypeId].HasPWideCharType then + begin +{$IFNDEF PAXARM} + Collect(typeANSISTRING); + Collect(typeWIDESTRING); + Collect(typeSHORTSTRING); +{$ENDIF} + Collect(typeUNICSTRING); + end; +end; + +end. diff --git a/Sources/PAXCOMP_BASIC_PARSER.pas b/Sources/PAXCOMP_BASIC_PARSER.pas new file mode 100644 index 0000000..9ffe9e1 --- /dev/null +++ b/Sources/PAXCOMP_BASIC_PARSER.pas @@ -0,0 +1,6476 @@ +//////////////////////////////////////////////////////////////////////////// +// PaxCompiler +// Site: http://www.paxcompiler.com +// Author: Alexander Baranovsky (paxscript@gmail.com) +// ======================================================================== +// Copyright (c) Alexander Baranovsky, 2006-2014. All rights reserved. +// Code Version: 4.2 +// ======================================================================== +// Unit: PAXCOMP_BASIC_PARSER.pas +// ======================================================================== +//////////////////////////////////////////////////////////////////////////// + +{$I PaxCompiler.def} +unit PAXCOMP_BASIC_PARSER; +interface +uses {$I uses.def} + SysUtils, + Classes, + PAXCOMP_CONSTANTS, + PAXCOMP_TYPES, + PAXCOMP_SYS, + PAXCOMP_BYTECODE, + PAXCOMP_MODULE, + PAXCOMP_SCANNER, + PAXCOMP_STDLIB, + PAXCOMP_PARSER, + PAXCOMP_GENERIC; +type + TExitKind = (ekNone, + ekDo, + ekFor, + ekWhile, + ekSelect, + ekSub, + ekTry, + ekFunction); + + TBasicModifier = (modPublic, + modProtected, + modPublished, + modInternal, + modPrivate, + modShared, + modOverridable, + modNotOverridable, + modMustOverride, + modOverrides, + modOverloads, + modReadOnly, + modFriend, + modDefault, + modMustInherit, + modShadows, + modNotInheritable, + modWithEvents); + + TBasicModifierList = set of TBasicModifier; + + TForLoopRec = class + public + id, step_id, lg, lf: Integer; + Name: String; + end; + + TForLoopStack = class(TTypedList) + private + function GetRecord(I: Integer): TForLoopRec; + function GetTop: TForLoopRec; + public + procedure Push(id, step_id, lg, lf: Integer; const AName: String); + procedure Pop; + property Records[I: Integer]: TForLoopRec read GetRecord; + property Top: TForLoopRec read GetTop; + end; + + TBasicParser = class(TBaseParser) + private + exit_kind_stack: TIntegerStack; + for_loop_stack: TForLoopStack; + with_stack: TIntegerStack; + WasInherited: Boolean; + + ParsesModuleBody: Boolean; + ForEachCounter: Integer; + + SignThrow: Boolean; + function GetCurrExitKind: TExitKind; + function IsAssignment_operator(const S: String): Boolean; + procedure TestExplicitOff; + procedure Parse_Lib(SubId: Integer); + protected + function CreateScanner: TBaseScanner; override; + function GetLanguageName: String; override; + function GetFileExt: String; override; + procedure GenDefaultClassConstructor(ClassId: Integer; InitIds: TIntegerList); + procedure GenDefaultClassDestructor(ClassId: Integer); + procedure GenDefaultStructureConstructor(StructId: Integer; InitIds: TIntegerList); + procedure GenDefaultStructureDestructor(StructId: Integer); + function GetLanguageId: Integer; override; + function GetUpcase: Boolean; override; + + function Parse_AnonymousRoutine(IsFunc: Boolean): Integer; virtual; + public + constructor Create; override; + destructor Destroy; override; + + procedure ParseProgram; override; + function GetIncludedFileExt: String; override; + procedure InitSub(var SubId: Integer); override; + + procedure Init(i_kernel: Pointer; M: TModule); override; + + procedure PushExitKind(k: TExitKind); + procedure PopExitKind; + + procedure Parse_ImportsClause; + procedure Parse_NamespaceDeclaration; + procedure Parse_ModuleDeclaration; + procedure Parse_NamespaceMemberDeclaration; + procedure Parse_StructureTypeDeclaration(StructureMl: TBasicModifierList); + procedure Parse_ClassTypeDeclaration(ClassMl: TBasicModifierList); + procedure Parse_InterfaceTypeDeclaration(InterfaceMl: TBasicModifierList); + procedure Parse_TypeDefDeclaration; + procedure Parse_MethodRefTypeDeclaration(TypeID: Integer); + procedure Parse_EnumTypeDeclaration(EnumMl: TBasicModifierList); + function Parse_ArrayOfConstType: Integer; + function Parse_FormalParameterList(SubId: Integer): Integer; + procedure Parse_ExternalSubDeclaration(SubMl: TBasicModifierList); + procedure Parse_ExternalFunctionDeclaration(FunctionMl: TBasicModifierList); + procedure Parse_SubDeclaration(SubMl: TBasicModifierList); + procedure Parse_FunctionDeclaration(FunctionMl: TBasicModifierList); + procedure Parse_DelegateDeclaration(DelegateMl: TBasicModifierList); + procedure Parse_DimStmt(DimMl: TBasicModifierList); + procedure Parse_ReDimStmt(DimMl: TBasicModifierList); + procedure Parse_ConstStmt(ConstMl: TBasicModifierList); + procedure Parse_CallConvention(SubId: Integer; IsDeclaredProc: Boolean); + + procedure Parse_Statement; + procedure Parse_Statements; + procedure Parse_Block; + procedure Parse_ReturnStmt; + procedure Parse_GotoStmt; + procedure Parse_IfStmt; + procedure Parse_ContinueStmt; + procedure Parse_ExitStmt; + procedure Parse_SelectStmt; + procedure Parse_WhileStmt; + procedure Parse_DoLoopStmt; + procedure Parse_ForNextStmt; + procedure Parse_ForEachStmt; + procedure Parse_TryStmt; + procedure Parse_ThrowStmt; + procedure Parse_WithStmt; + procedure Parse_AssignmentStmt; + procedure Parse_PrintStmt; + procedure Parse_PrintlnStmt; + + procedure Parse_OptionStatement; + procedure Parse_OptionExplicitStatement; + procedure Parse_OptionStrictStatement; + procedure Parse_OptionCompareStatement; + + function Parse_ModifierList: TBasicModifierList; + function Parse_VisibilityModifierList: TBasicModifierList; + + function Parse_ArgumentList(SubId: Integer; HasParenthesis: Boolean = true): Integer; + function Parse_ArrayLiteral(ch1, ch2: Char): Integer; + function Parse_Expression: Integer; override; + + function Parse_AnonymousFunction: Integer; + function Parse_AnonymousSub: Integer; + function Parse_LambdaExpression: Integer; + function Parse_LambdaParameters(SubId: Integer) : Integer; + + function Parse_ConstantExpression: Integer; + function Parse_LogicalXORExpression: Integer; + function Parse_LogicalORExpression: Integer; + function Parse_LogicalANDExpression: Integer; + function Parse_RelationalExpression: Integer; + function Parse_ShiftExpression: Integer; + function Parse_ConcatenationExpression: Integer; + function Parse_AdditiveExpression: Integer; + function Parse_ModulusExpression: Integer; + function Parse_IntegerDivisionExpression: Integer; + function Parse_MultiplicativeExpression: Integer; + function Parse_Factor: Integer; override; + function Parse_NewExpression: Integer; + function Parse_Designator(init_id: Integer = 0): Integer; + function Parse_Type: Integer; + function Parse_Label: Integer; + + procedure Call_SCANNER; override; + function Parse_Ident: Integer; override; + function IsLineTerminator: Boolean; + function IsStatementTerminator: Boolean; + procedure MatchLineTerminator; + procedure MatchStatementTerminator; + procedure EndTypeDef(TypeId: Integer); override; + function AltTypeId(const S: String): Integer; override; + + property CurrExitKind: TExitKind read GetCurrExitKind; + //generics + function ParametrizedTypeExpected: Boolean; override; + procedure Parse_TypeRestriction(LocalTypeParams: TStringObjectList); override; + + end; + +implementation + +uses + PAXCOMP_BASIC_SCANNER, PAXCOMP_KERNEL; + +const + basic_Implicit = 'Implicit'; + basic_Explicit = 'Explicit'; + basic_Add = 'Add'; + basic_Divide = 'Divide'; + basic_IntDivide = 'IntDivide'; + basic_Modulus = 'Modulus'; + basic_Multiply = 'Multiply'; + basic_Subtract = 'Subtract'; + basic_Negative = 'Negative'; + basic_Positive = 'Positive'; + basic_LogicalNot = 'LogicalNot'; + basic_LeftShift = 'LeftShift'; + basic_RightShift = 'RightShift'; + basic_LogicalAnd = 'LogicalAnd'; + basic_LogicalOr = 'LogicalOr'; + basic_LogicalXor = 'LogicalXor'; + basic_LessThan = 'LessThan'; + basic_LessThanOrEqual = 'LessThanOrEqual'; + basic_GreaterThan = 'GreaterThan'; + basic_GreaterThanOrEqual = 'GreaterThanOrEqual'; + basic_Equal = 'Equal'; + basic_NotEqual = 'NotEqual'; + basic_Inc = 'Inc'; + basic_Dec = 'Inc'; + +procedure TForLoopStack.Push(id, step_id, lg, lf: Integer; const AName: String); +var + r: TForLoopRec; +begin + r := TForLoopRec.Create; + r.id := id; + r.step_id := step_id; + r.lg := lg; + r.lf := lf; + r.Name := UpperCase(AName); + L.Add(r); +end; + +procedure TForLoopStack.Pop; +begin + RemoveTop; +end; + +function TForLoopStack.GetRecord(I: Integer): TForLoopRec; +begin + result := TForLoopRec(L[I]); +end; + +function TForLoopStack.GetTop: TForLoopRec; +begin + result := Records[Count - 1]; +end; + +constructor TBasicParser.Create; +begin + inherited; + exit_kind_stack := TIntegerStack.Create; + for_loop_stack := TForLoopStack.Create; + with_stack := TIntegerStack.Create; + +{$IFNDEF TAB} + AddKeyword('AddHandler'); + AddKeyword('AddressOf'); + AddKeyword('Alias'); +{$ENDIF} + AddKeyword('And'); + AddKeyword('AndAlso'); +{$IFNDEF TAB} + AddKeyword('Ansi'); +{$ENDIF} + AddKeyword('Array'); + AddKeyword('As'); +{$IFNDEF TAB} + AddKeyword('Assembly'); + AddKeyword('Auto'); +{$ENDIF} + AddKeyword('Boolean'); + AddKeyword('ByRef'); + AddKeyword('Byte'); + AddKeyword('ByVal'); + AddKeyword('Call'); + AddKeyword('Case'); + AddKeyword('Catch'); +// AddKeyword('CBool'); +// AddKeyword('CByte'); + AddKeyword('CChar'); +// AddKeyword('CDate'); +// AddKeyword('CDbl'); + AddKeyword('CDec'); + AddKeyword('Char'); +// AddKeyword('CInt'); + AddKeyword('Class'); +// AddKeyword('CLng'); + AddKeyword('CObj'); + AddKeyword('Const'); + AddKeyword('Continue'); + AddKeyword('CShort'); +// AddKeyword('CSng'); +// AddKeyword('CStr'); + AddKeyword('CType'); +// AddKeyword('Date'); + AddKeyword('Decimal'); +{$IFNDEF TAB} + AddKeyword('Declare'); + AddKeyword('Default'); + AddKeyword('Delegate'); +{$ENDIF} + AddKeyword('Dim'); + AddKeyword('DirectCast'); +{$IFNDEF TAB} + AddKeyword('Do'); +{$ENDIF} + AddKeyword('Double'); + AddKeyword('Each'); + AddKeyword('Else'); + AddKeyword('ElseIf'); + AddKeyword('End'); + AddKeyword('EndIf'); +{$IFNDEF TAB} + AddKeyword('Enum'); + AddKeyword('Erase'); + AddKeyword('Error'); + AddKeyword('Event'); +{$ENDIF} + AddKeyword('Exit'); + AddKeyword('False'); + AddKeyword('Finally'); +{$IFNDEF TAB} + AddKeyword('For'); + AddKeyword('From'); + AddKeyword('Friend'); +{$ENDIF} + AddKeyword('Function'); +{$IFNDEF TAB} + AddKeyword('Get'); +// AddKeyword('GetType'); + AddKeyword('GoSub'); + AddKeyword('GoTo'); + AddKeyword('Handles'); +{$ENDIF} + AddKeyword('If'); +{$IFNDEF TAB} + AddKeyword('Implements'); + AddKeyword('Imports'); + AddKeyword('In'); + AddKeyword('Inherits'); +{$ENDIF} + AddKeyword('Integer'); +{$IFNDEF TAB} + AddKeyword('Interface'); +{$ENDIF} + AddKeyword('Is'); + AddKeyword('IsNot'); +{$IFNDEF TAB} + AddKeyword('Let'); + AddKeyword('Lib'); +{$ENDIF} + AddKeyword('Like'); + AddKeyword('Long'); + AddKeyword('Loop'); +{$IFNDEF TAB} + AddKeyword('Me'); +{$ENDIF} + AddKeyword('Mod'); +{$IFNDEF TAB} + AddKeyword('Module'); + AddKeyword('MustInherit'); + AddKeyword('MustOverride'); + AddKeyword('MyBase'); + AddKeyword('MyClass'); + AddKeyword('Namespace'); + AddKeyword('New'); +{$ENDIF} + AddKeyword('Next'); + AddKeyword('Not'); + AddKeyword('Nothing'); +{$IFNDEF TAB} + AddKeyword('NotInheritable'); + AddKeyword('NotOverridable'); +{$ENDIF} + AddKeyword('Null'); +{$IFNDEF TAB} + AddKeyword('Object'); + AddKeyword('On'); +{$ENDIF} + AddKeyword('Option'); +{$IFNDEF TAB} + AddKeyword('Optional'); +{$ENDIF} + AddKeyword('Or'); +{$IFNDEF TAB} + AddKeyword('Overloads'); + AddKeyword('Overridable'); + AddKeyword('Overrides'); + AddKeyword('ParamArray'); + AddKeyword('Preserve'); + AddKeyword('Private'); + AddKeyword('Property'); + AddKeyword('Protected'); + AddKeyword('Public'); + AddKeyword('Published'); + AddKeyword('RaiseEvent'); + AddKeyword('ReadOnly'); +{$ENDIF} + AddKeyword('ReDim'); + AddKeyword('REM'); +{$IFNDEF TAB} + AddKeyword('RemoveHandler'); + AddKeyword('Resume'); +{$ENDIF} + AddKeyword('Return'); + AddKeyword('Select'); +{$IFNDEF TAB} + AddKeyword('Set'); + AddKeyword('Shadows'); + AddKeyword('Shared'); +{$ENDIF} + AddKeyword('Short'); + AddKeyword('Single'); + AddKeyword('Static'); + AddKeyword('Step'); +{$IFNDEF TAB} + AddKeyword('Stop'); +{$ENDIF} + AddKeyword('String'); +{$IFNDEF TAB} + AddKeyword('Structure'); +{$ENDIF} + AddKeyword('Sub'); +{$IFNDEF TAB} + AddKeyword('SyncLock'); +{$ENDIF} + AddKeyword('Then'); + AddKeyword('Throw'); + AddKeyword('To'); + AddKeyword('True'); + AddKeyword('Try'); +{$IFNDEF TAB} + AddKeyword('TypeDef'); +{$ENDIF} + AddKeyword('TypeOf'); +{$IFNDEF TAB} + AddKeyword('Unicode'); +{$ENDIF} + AddKeyword('Until'); + AddKeyword('Variant'); +{$IFNDEF TAB} + AddKeyword('Wend'); + AddKeyword('When'); + AddKeyword('While'); +{$ENDIF} + AddKeyword('With'); +{$IFNDEF TAB} + AddKeyword('WithEvents'); + AddKeyword('WriteOnly'); +{$ENDIF} + AddKeyword('Xor'); + + AddKeyword('print'); + AddKeyword('println'); + +{$IFNDEF TAB} + AddKeyword('Register'); + AddKeyword('StdCall'); + AddKeyword('CDecl'); + AddKeyword('Pascal'); + AddKeyword('SafeCall'); + AddKeyword('MSFastCall'); + AddKeyword('Operator'); + + AddKeyword('Reference'); + AddKeyword('Lambda'); +{$ENDIF} + + AddOperator(basic_Implicit, gen_Implicit); + AddOperator(basic_Explicit, gen_Explicit); + AddOperator(basic_Add, gen_Add); + AddOperator(basic_Divide, gen_Divide); + AddOperator(basic_IntDivide, gen_IntDivide); + AddOperator(basic_Modulus, gen_Modulus); + AddOperator(basic_Multiply, gen_Multiply); + AddOperator(basic_Subtract, gen_Subtract); + AddOperator(basic_Negative, gen_Negative); + AddOperator(basic_Positive, gen_Positive); + AddOperator(basic_LogicalNot, gen_LogicalNot); + AddOperator(basic_LeftShift, gen_LeftShift); + AddOperator(basic_RightShift, gen_RightShift); + AddOperator(basic_LogicalAnd, gen_LogicalAnd); + AddOperator(basic_LogicalOr, gen_LogicalOr); + AddOperator(basic_LogicalXor, gen_LogicalXor); + AddOperator(basic_LessThan, gen_LessThan); + AddOperator(basic_LessThanOrEqual, gen_LessThanOrEqual); + AddOperator(basic_GreaterThan, gen_GreaterThan); + AddOperator(basic_GreaterThanOrEqual, gen_GreaterThanOrEqual); + AddOperator(basic_Equal, gen_Equal); + AddOperator(basic_NotEqual, gen_NotEqual); + AddOperator(basic_Inc, gen_Inc); + AddOperator(basic_Dec, gen_Dec); +end; + +destructor TBasicParser.Destroy; +begin + FreeAndNil(exit_kind_stack); + FreeAndNil(for_loop_stack); + FreeAndNil(with_stack); + inherited; +end; + +procedure TBasicParser.GenDefaultClassConstructor(ClassId: Integer; InitIds: TIntegerList); +var + SubId, ResId, L, I: Integer; +begin + LevelStack.Push(ClassId); + SubId := NewTempVar; + + BeginClassConstructor(SubId, ClassId); + SetVisibility(SubId, cvPublic); + inherited InitSub(SubId); + Gen(OP_SAVE_EDX, 0, 0, 0); + + L := NewLabel; + Gen(OP_GO_DL, L, 0, 0); + Gen(OP_CREATE_OBJECT, ClassId, 0, CurrSelfId); + SetLabelHere(L); + + Gen(OP_BEGIN_WITH, CurrSelfId, 0, 0); + WithStack.Push(CurrSelfId); + + NewTempVar; + ResId := NewTempVar; + + Gen(OP_PUSH_CLASSREF, CurrSelfId, 0, ResId); + Gen(OP_EVAL_INHERITED, SubId, 0, ResId); + + SetDefault(SubId, true); + Gen(OP_UPDATE_DEFAULT_CONSTRUCTOR, SubId, 0, ResId); +// will insertion here + + Gen(OP_CALL_INHERITED, ResId, 0, 0); + + if InitIds <> nil then + for I := 0 to InitIds.Count - 1 do + begin + Gen(OP_PUSH_INSTANCE, CurrSelfId, 0, InitIds[I]); + Gen(OP_CALL, InitIds[I], 0, 0); + end; + + Gen(OP_END_WITH, WithStack.Top, 0, 0); + WithStack.Pop; + + Gen(OP_RESTORE_EDX, 0, 0, 0); + L := NewLabel; + Gen(OP_GO_DL, L, 0, 0); + Gen(OP_ONCREATE_OBJECT, CurrSelfId, 0, 0); + Gen(OP_ON_AFTER_OBJECT_CREATION, CurrSelfId, 0, 0); + SetLabelHere(L); + + EndSub(SubId); + LevelStack.Pop; +end; + +procedure TBasicParser.GenDefaultClassDestructor(ClassId: Integer); +var + SubId, Id, ResId: Integer; +begin + LevelStack.Push(ClassId); + SubId := NewTempVar; + SetName(SubId, 'Destroy'); + BeginClassDestructor(SubId, ClassId); + SetName(CurrSelfId, 'Me'); + SetVisibility(SubId, cvPublic); + inherited InitSub(SubId); + + Gen(OP_BEGIN_WITH, CurrSelfId, 0, 0); + WithStack.Push(CurrSelfId); + + Id := NewTempVar; + ResId := NewTempVar; + SetName(Id, 'Destroy'); + Gen(OP_EVAL, 0, 0, Id); + Gen(OP_EVAL_INHERITED, Id, 0, ResId); + Gen(OP_CALL, ResId, 0, 0); + + Gen(OP_END_WITH, WithStack.Top, 0, 0); + WithStack.Pop; + + EndSub(SubId); + LevelStack.Pop; +end; + +procedure TBasicParser.GenDefaultStructureConstructor(StructId: Integer; InitIds: TIntegerList); +var + SubId, I: Integer; +begin + LevelStack.Push(StructId); + SubId := NewTempVar; + SetName(SubId, 'Create'); + BeginStructureConstructor(SubId, StructId); + SetVisibility(SubId, cvPublic); + inherited InitSub(SubId); + Gen(OP_BEGIN_WITH, CurrSelfId, 0, 0); + WithStack.Push(CurrSelfId); + SetName(CurrSelfId, 'Me'); + for I := 0 to InitIds.Count - 1 do + begin + Gen(OP_PUSH_INSTANCE, CurrSelfId, 0, InitIds[I]); + Gen(OP_CALL, InitIds[I], 0, 0); + end; + Gen(OP_END_WITH, WithStack.Top, 0, 0); + WithStack.Pop; + + EndSub(SubId); + LevelStack.Pop; +end; + +procedure TBasicParser.GenDefaultStructureDestructor(StructId: Integer); +var + SubId: Integer; +begin + LevelStack.Push(StructId); + SubId := NewTempVar; + SetName(SubId, 'Destroy'); + BeginStructureDestructor(SubId, StructId); + SetVisibility(SubId, cvPublic); + inherited InitSub(SubId); + + Gen(OP_BEGIN_WITH, CurrSelfId, 0, 0); + WithStack.Push(CurrSelfId); + + Gen(OP_END_WITH, WithStack.Top, 0, 0); + WithStack.Pop; + + EndSub(SubId); + LevelStack.Pop; +end; + +procedure TBasicParser.Init(i_kernel: Pointer; M: TModule); +begin + exit_kind_stack.Clear; + for_loop_stack.Clear; + with_stack.Clear; + ParsesModuleBody := false; + ForEachCounter := 0; + inherited; +end; + +function TBasicParser.CreateScanner: TBaseScanner; +begin + result := TBasicScanner.Create; +end; + +function TBasicParser.GetLanguageName: String; +begin + result := 'Basic'; +end; + +function TBasicParser.GetFileExt: String; +begin + result := 'bas'; +end; + +function TBasicParser.GetIncludedFileExt: String; +begin + result := 'bas'; +end; + +function TBasicParser.GetLanguageId: Integer; +begin + result := BASIC_LANGUAGE; +end; + +function TBasicParser.GetUpcase: Boolean; +begin + result := true; +end; + +procedure TBasicParser.ParseProgram; +var + B1, B2: Integer; +begin + + EXECUTABLE_SWITCH := 1; + + if IsEOF then + Exit; + + Call_SCANNER; + + if IsEOF then + Exit; + + while IsLineTerminator do + begin + if IsEOF then + Exit; + MatchLineTerminator; + end; + + if EXPLICIT_OFF then + Gen(OP_OPTION_EXPLICIT, 0, 0, 0); + while IsCurrText('Option') do + Parse_OptionStatement; + + if IsCurrText('Module') then + begin + Parse_ModuleDeclaration; + Exit; + end; + + while IsCurrText('Imports') do + Parse_ImportsClause; + + Gen(OP_END_IMPORT, 0, 0, 0); + + B1 := CodeCard; + + while IsCurrText('Namespace') do + Parse_NamespaceDeclaration; + + Gen(OP_END_INTERFACE_SECTION, CurrModule.ModuleNumber, 0, 0); + + Parse_Statements; + + B2 := CodeCard; + + BeginFinalization; + + Gen(OP_BEGIN_GLOBAL_BLOCK, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + + Gen(OP_EPILOGUE_GLOBAL_BLOCK, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + Gen(OP_EPILOGUE_GLOBAL_BLOCK2, 0, 0, 0); + + GenDestroyGlobalDynamicVariables(B1, B2); + + Gen(OP_NOP, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + Gen(OP_END_GLOBAL_BLOCK, 0, 0, 0); + + EndFinalization; +end; + +procedure TBasicParser.Parse_OptionStatement; +begin + SafeMatch('Option'); + if IsCurrText('Explicit') then + Parse_OptionExplicitStatement + else if IsCurrText('Strict') then + Parse_OptionStrictStatement + else if IsCurrText('Compare') then + Parse_OptionCompareStatement +end; + +procedure TBasicParser.Parse_OptionExplicitStatement; +begin + SafeMatch('Explicit'); + + if IsCurrText('On') then + begin + EXPLICIT_OFF := false; + Match('On'); + Gen(OP_OPTION_EXPLICIT, 1, 0, 0); + MatchLineTerminator(); + end + else if IsCurrText('Off') then + begin + EXPLICIT_OFF := true; + Match('Off'); + Gen(OP_OPTION_EXPLICIT, 0, 0, 0); + MatchLineTerminator(); + end + else + Match('On'); +end; + +procedure TBasicParser.Parse_OptionStrictStatement; +begin + +end; + +procedure TBasicParser.Parse_OptionCompareStatement; +begin + +end; + +procedure TBasicParser.Parse_Statement; +var + ml: TBasicModifierList; +begin +{$IFNDEF TAB} + if CurrToken.TokenClass = tcIdentifier then + if GetKind(CurrToken.Id) = KindLABEL then + begin + SetLabelHere(CurrToken.Id); + Call_SCANNER; + Match(':'); + end; +{$ENDIF} + + ml := Parse_VisibilityModifierList; + + Gen(OP_STMT, 0, 0, 0); +{$IFNDEF TAB} + if IsCurrText('TypeDef') then + Parse_TypeDefDeclaration + else if IsCurrText('Structure') then + Parse_StructureTypeDeclaration(ml) + else if IsCurrText('Class') then + Parse_ClassTypeDeclaration(ml) + else if IsCurrText('Interface') then + Parse_InterfaceTypeDeclaration(ml) + else if IsCurrText('Enum') then + Parse_EnumTypeDeclaration(ml) + else +{$ENDIF} + if IsCurrText('Sub') then + Parse_SubDeclaration(ml) + else if IsCurrText('Function') then + Parse_FunctionDeclaration(ml) + else +{$IFNDEF TAB} + if IsCurrText('Delegate') then + Parse_DelegateDeclaration(ml) + else if IsCurrText('Declare') then + begin + Call_SCANNER; + if IsCurrText('Sub') then + Parse_ExternalSubDeclaration(ml) + else if IsCurrText('Function') then + Parse_ExternalFunctionDeclaration(ml) + else + Match('Sub'); + end + else +{$ENDIF} + if IsCurrText('Dim') then + begin + Parse_DimStmt(ml); + end + else if IsCurrText('ReDim') then + begin + Parse_ReDimStmt(ml); + end + else if IsCurrText('Const') then + Parse_ConstStmt(ml) + else if IsCurrText('If') then + begin + Parse_IfStmt; + end + else if IsCurrText('Continue') then + begin + Parse_ContinueStmt; + end + else if IsCurrText('Exit') then + begin + Parse_ExitStmt; + end + else if IsCurrText('Select') then + begin + Parse_SelectStmt; + end + else +{$IFNDEF TAB} + if IsCurrText('Goto') then + begin + Parse_GotoStmt; + end + else if IsCurrText('While') then + begin + Parse_WhileStmt; + end + else if IsCurrText('Do') then + begin + Parse_DoLoopStmt; + end + else if IsCurrText('For') then + begin + if IsNextText('Each') then + Parse_ForEachStmt + else + Parse_ForNextStmt; + end + else +{$ENDIF} + if IsCurrText('Try') then + begin + Parse_TryStmt; + end + else if IsCurrText('Throw') then + begin + Parse_ThrowStmt; + end + else if IsCurrText('With') then + begin + Parse_WithStmt; + end + else if IsCurrText('Print') then + begin + Match('Print'); + Parse_PrintStmt; + if IsCurrText('else') then + Exit; + MatchStatementTerminator; + end + else if IsCurrText('Println') then + begin + Match('Println'); + Parse_PrintlnStmt; + if IsCurrText('else') then + Exit; + MatchStatementTerminator; + end + else if IsCurrText('Return') then + begin + Parse_ReturnStmt; + end + else + begin + Parse_AssignmentStmt; + end; +end; + +procedure TBasicParser.Parse_Statements; +begin + repeat + if IsEOF then + break; + if IsCurrText('End') then + break; + if IsCurrText('Else') then + break; + if IsCurrText('ElseIf') then + break; + if IsCurrText('Case') then + break; + if IsCurrText('Loop') then + break; + if IsCurrText('Next') then + break; + if IsCurrText('Finally') then + break; + if IsCurrText('Catch') then + break; + while IsLineTerminator do + MatchLineTerminator; + + Parse_Statement; + until false; +end; + +procedure TBasicParser.Parse_NamespaceDeclaration; +var + l: TIntegerList; + i, namespace_id: Integer; +begin + DECLARE_SWITCH := true; + Match('Namespace'); + + l := TIntegerList.Create; + + repeat // ParseQualifiedIdentifier + namespace_id := Parse_Ident; + l.Add(namespace_id); + BeginNamespace(namespace_id); + if NotMatch('.') then + break; + until false; + + // Parse namespace body + + repeat + if IsEOF then + Match('End'); + if IsCurrText('End') then + break; + if IsLineTerminator then + MatchLineTerminator +{$IFNDEF TAB} + else + Parse_NamespaceMemberDeclaration; +{$ENDIF} + until false; + + for i := l.Count - 1 downto 0 do + EndNamespace(l[i]); + + Match('End'); + Match('Namespace'); + MatchLineTerminator(); +end; + +procedure TBasicParser.Parse_ModuleDeclaration; +var + namespace_id, B1, B2: Integer; + S: String; +begin + DECLARE_SWITCH := true; + Match('Module'); + + namespace_id := Parse_UnitName(S); + + if CurrModule.IsExtra then + SaveExtraNamespace(namespace_id); + + MatchLineTerminator; + + while IsCurrText('Option') do + Parse_OptionStatement; + + while IsCurrText('Imports') do + Parse_ImportsClause; + + Gen(OP_END_IMPORT, 0, 0, 0); + + B1 := CodeCard; + + // Parse module body + ParsesModuleBody := true; + + repeat + if IsEOF then + Match('End'); + if IsCurrText('End') then + break; + if IsLineTerminator then + MatchLineTerminator +{$IFNDEF TAB} + else + Parse_NamespaceMemberDeclaration; +{$ENDIF} + until false; + + ParsesModuleBody := false; + + EndNamespace(namespace_id); + + Gen(OP_END_INTERFACE_SECTION, CurrModule.ModuleNumber, 0, 0); + + B2 := CodeCard; + + Match('End'); + Match('Module'); + MatchLineTerminator(); + + BeginFinalization; + + Gen(OP_BEGIN_GLOBAL_BLOCK, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + + Gen(OP_EPILOGUE_GLOBAL_BLOCK, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + Gen(OP_EPILOGUE_GLOBAL_BLOCK2, 0, 0, 0); + + GenDestroyGlobalDynamicVariables(B1, B2); + + Gen(OP_NOP, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + Gen(OP_END_GLOBAL_BLOCK, 0, 0, 0); + + EndFinalization; +end; + +procedure TBasicParser.Parse_ImportsClause; +var + unit_id, id: Integer; + S: String; + AlreadyExists: Boolean; +begin + DECLARE_SWITCH := false; + Match('Imports'); + + UsedUnitList.Clear; + + repeat + unit_id := Parse_UnitName(S); + + AlreadyExists := GetKind(unit_id) = kindNAMESPACE; + if not AlreadyExists then + AlreadyExists := HasModule(S); + + Gen(OP_BEGIN_USING, unit_id, 0, 0); + + if IsCurrText('From') then + begin + Call_SCANNER; + id := Parse_PCharLiteral; + S := GetValue(id); + + if (PosCh('\', S) > 0) or (PosCh('/', S) > 0) then + begin + if (Pos('.\', S) > 0) or (Pos('./', S) > 0) then + S := ExpandFileName(S) + else + S := GetCurrentDir + S; + end; + + AlreadyExists := false; + end + else + S := S + '.' + GetFileExt; + + if not AlreadyExists then + AddModuleFromFile(S, unit_id, false); + + if NotMatch(',') then + Break; + until false; + + MatchLineTerminator; +end; + +procedure TBasicParser.Parse_NamespaceMemberDeclaration; +var + ml: TBasicModifierList; +begin + ml := Parse_VisibilityModifierList; + + if IsCurrText('TypeDef') then + Parse_TypeDefDeclaration + else if IsCurrText('Interface') then + Parse_InterfaceTypeDeclaration(ml) + else if IsCurrText('Structure') then + Parse_StructureTypeDeclaration(ml) + else if IsCurrText('Class') then + Parse_ClassTypeDeclaration(ml) + else if IsCurrText('Enum') then + Parse_EnumTypeDeclaration(ml) + else if IsCurrText('Sub') then + Parse_SubDeclaration(ml) + else if IsCurrText('Function') then + Parse_FunctionDeclaration(ml) + else if IsCurrText('Delegate') then + Parse_DelegateDeclaration(ml) + else if IsCurrText('Declare') then + begin + Call_SCANNER; + if IsCurrText('Sub') then + Parse_ExternalSubDeclaration(ml) + else if IsCurrText('Function') then + Parse_ExternalFunctionDeclaration(ml) + else + Match('Sub'); + end + else if IsCurrText('Dim') then + Parse_DimStmt(ml) + else if IsCurrText('Const') then + Parse_ConstStmt(ml) + else + Parse_DimStmt(ml) +end; + +procedure TBasicParser.Parse_TypeDefDeclaration; +var + NewTypeId, OldTypeId: Integer; +begin + DECLARE_SWITCH := true; + Match('TypeDef'); + NewTypeId := Parse_Ident; + DECLARE_SWITCH := false; + Match('As'); + + if IsCurrText('Class') then + begin + Match('Class'); + Match('Of'); + BeginClassReferenceType(NewTypeID); + Gen(OP_CREATE_CLASSREF_TYPE, NewTypeId, Parse_Ident, 0); + EndClassReferenceType(NewTypeID); + Exit; + end + else if IsCurrText('Reference') then + begin + Match('Reference'); + Match('To'); + BeginTypeDef(NewTypeId); + Parse_MethodRefTypeDeclaration(NewTypeId); + Exit; + end; + + OldTypeId := Parse_Ident; + if IsCurrText('*') then + begin + Match('*'); + BeginPointerType(NewTypeID); + Gen(OP_CREATE_POINTER_TYPE, NewTypeId, OldTypeId, 0); + EndPointerType(NewTypeID); + end + else + begin + if InterfaceOnly then + Gen(OP_BEGIN_ALIAS_TYPE, NewTypeId, 0, 0); + SetType(NewTypeId, typeALIAS); + Gen(OP_ASSIGN_TYPE_ALIAS, NewTypeId, OldTypeId, 0); + if InterfaceOnly then + Gen(OP_END_ALIAS_TYPE, NewTypeId, 0, 0); + end; +end; + +procedure TBasicParser.Parse_Lib(SubId: Integer); +var + S: String; + SubNameId, LibId, AliasId, NP: Integer; +begin + SetExternal(SubId, true); + + S := GetName(SubId); + SubNameId := NewConst(typeSTRING, S); + + DECLARE_SWITCH := false; + if not IsCurrText('Lib') then + Match('Lib') + else + ReadToken; + + if CurrToken.TokenClass = tcPCharConst then + begin + S := RemoveCh('"', CurrToken.Text); + LibId := NewConst(typeSTRING, S); + end + else + begin + LibId := Lookups(CurrToken.Text, LevelStack); + + if LibId = 0 then + RaiseError(errUndeclaredIdentifier, [CurrToken.Text]); + + if not IsStringConst(LibId) then + RaiseError(errIncompatibleTypesNoArgs, []); + end; + ReadToken; + + if IsCurrText('Alias') then + begin + ReadToken; + if CurrToken.TokenClass = tcPCharConst then + begin + S := RemoveCh('"', CurrToken.Text); + AliasId := NewConst(typeSTRING, S); + end + else + begin + AliasId := Lookups(CurrToken.Text, LevelStack); + + if AliasId = 0 then + RaiseError(errUndeclaredIdentifier, [CurrToken.Text]); + + if not IsStringConst(AliasId) then + RaiseError(errIncompatibleTypesNoArgs, []); + end; + SubNameId := AliasId; + ReadToken; + end; + + DECLARE_SWITCH := true; + if IsCurrText('(') then + NP := Parse_FormalParameterList(SubId) + else + NP := 0; + + SetCount(SubId, NP); + SetName(CurrResultId, ''); + SetKind(CurrResultId, KindNONE); +// Gen(OP_ASSIGN_TYPE, SubId, TypeVOID, 0); +// Gen(OP_ASSIGN_TYPE, CurrResultId, TypeVOID, 0); + + EndSub(SubId); + RemoveSub; + + Gen(OP_LOAD_PROC, SubId, SubNameId, LibId); + + DECLARE_SWITCH := true; +end; + +procedure TBasicParser.Parse_StructureTypeDeclaration; + +var + ml: TBasicModifierList; + SubId, StructTypeId: Integer; + HasConstructor, HasDestructor: Boolean; + InitIds: TIntegerList; + + procedure Parse_MethodBody(L: TIntegerList = nil); + var + I: Integer; + begin + DECLARE_SWITCH := false; + SetName(CurrSelfId, 'Me'); + SetVisibility(SubId, cvPUBLIC); + if modPRIVATE in ml then + SetVisibility(SubId, cvPRIVATE); + if modPUBLIC in ml then + SetVisibility(SubId, cvPUBLIC); + if modPROTECTED in ml then + SetVisibility(SubId, cvPROTECTED); + if modPUBLISHED in ml then + SetVisibility(SubId, cvPUBLISHED); + if modOVERRIDABLE in ml then + SetCallMode(SubId, cmVIRTUAL); + if modOVERRIDES in ml then + SetCallMode(SubId, cmOVERRIDE); + if modOVERLOADS in ml then + SetOverloaded(SubId); + + Gen(OP_BEGIN_WITH, CurrSelfId, 0, 0); + WithStack.Push(CurrSelfId); + Gen(OP_STMT, 0, 0, 0); + + if L <> nil then + for I := 0 to L.Count - 1 do + begin + Gen(OP_PUSH_INSTANCE, CurrSelfId, 0, L[I]); + Gen(OP_CALL, L[I], 0, 0); + end; + + MatchLineTerminator; + Parse_Statements; + + Gen(OP_END_WITH, WithStack.Top, 0, 0); + WithStack.Pop; + DECLARE_SWITCH := true; + end; + + procedure Parse_SubMethodDeclaration; + var + NP: Integer; + begin + DECLARE_SWITCH := true; + Match('Sub'); + + if IsCurrText('New') then + begin + HasConstructor := true; + Match('New'); + SubId := NewTempVar; + BeginStructureConstructor(SubId, StructTypeId); + + if IsCurrText('Lib') then + Parse_Lib(SubId) + else + begin + NP := 0; + SetCount(SubId, NP); + InitSub(SubId); + Parse_MethodBody(InitIDs); + EndSub(SubId); + Match('End'); + Match('Sub'); + end; + end + else if IsCurrText('Finalize') then + begin + HasDestructor := true; + + Match('Finalize'); + SubId := NewTempVar; + BeginStructureDestructor(SubId, StructTypeId); + if IsCurrText('Lib') then + Parse_Lib(SubId) + else + begin + NP := 0; + SetCount(SubId, NP); + InitSub(SubId); + Parse_MethodBody; + EndSub(SubId); + Match('End'); + Match('Sub'); + end; + end + else + begin + SubId := Parse_Ident; + BeginStructureMethod(SubId, StructTypeId, false, modSHARED in ml); + + if IsCurrText('Lib') then + Parse_Lib(SubId) + else + begin + if IsCurrText('(') then + NP := Parse_FormalParameterList(SubId) + else + NP := 0; + + SetCount(SubId, NP); + SetName(CurrResultId, ''); + SetKind(CurrResultId, KindNONE); + Gen(OP_ASSIGN_TYPE, SubId, TypeVOID, 0); + Gen(OP_ASSIGN_TYPE, CurrResultId, TypeVOID, 0); + + InitSub(SubId); + Parse_MethodBody; + + EndSub(SubId); + Match('End'); + Match('Sub'); + end; + end; + end; + + procedure Parse_FunctionMethodDeclaration; + var + TypeId, NP: Integer; + begin + DECLARE_SWITCH := true; + Match('function'); + SubId := Parse_Ident; + BeginStructureMethod(SubId, StructTypeId, true, modSHARED in ml); + SetName(CurrResultId, ''); + + if IsCurrText('Lib') then + begin + Parse_Lib(SubId); + DECLARE_SWITCH := false; + if IsCurrText('As') then + begin + Match('As'); + TypeID := Parse_Type; + end + else + begin + TestExplicitOff; + TypeId := typeVARIANT; + end; + Gen(OP_ASSIGN_TYPE, SubId, TypeID, 0); + end + else + begin + if IsCurrText('(') then + NP := Parse_FormalParameterList(SubId) + else + NP := 0; + SetCount(SubId, NP); + DECLARE_SWITCH := false; + if IsCurrText('As') then + begin + Match('As'); + TypeID := Parse_Type; + end + else + begin + TestExplicitOff; + TypeId := typeVARIANT; + end; + Gen(OP_ASSIGN_TYPE, SubId, TypeID, 0); + Gen(OP_ASSIGN_TYPE, CurrResultId, TypeID, 0); + + InitSub(SubId); + Parse_MethodBody; + EndSub(SubId); + Match('End'); + Match('Function'); + end; + end; + + procedure Parse_OperatorDeclaration; + var + I, TypeId, NP: Integer; + begin + DECLARE_SWITCH := true; + Match('operator'); + + I := OperatorIndex(CurrToken.Text); + if I = -1 then + CreateError(errE2393, []); + // errE2393 = 'Invalid operator declaration'; + + SubId := Parse_Ident; + SetName(SubId, operators.Values[I]); + + BeginStructureOperator(SubId, StructTypeId); + SetName(CurrResultId, ''); + if IsCurrText('(') then + NP := Parse_FormalParameterList(SubId) + else + NP := 0; + SetCount(SubId, NP); + DECLARE_SWITCH := false; + if IsCurrText('As') then + begin + Match('As'); + TypeID := Parse_Type; + end + else + begin + TestExplicitOff; + TypeId := typeVARIANT; + end; + Gen(OP_ASSIGN_TYPE, SubId, TypeID, 0); + Gen(OP_ASSIGN_TYPE, CurrResultId, TypeID, 0); + SetOverloaded(SubId); + + InitSub(SubId); + DECLARE_SWITCH := false; + MatchLineTerminator; + + Parse_Statements; + EndSub(SubId); + Match('End'); + Match('Operator'); + end; + + procedure Parse_PropertyDeclaration; + + var + ParamIds, TypeIds, ByRefIds: TIntegerList; + + function Parse_ParamList: Integer; + begin + DECLARE_SWITCH := true; + Match('('); + result := 0; + + repeat + if IsCurrText('ByRef') then + begin + Match('ByRef'); + ByRefIds.Add(Integer(true)); + end + else if IsCurrText('ByVal') then + begin + Match('ByVal'); + ByRefIds.Add(Integer(false)); + end + else + ByRefIds.Add(Integer(false)); + + Inc(result); + ParamIds.Add(Parse_Ident); + + if IsCurrText('As') then + begin + DECLARE_SWITCH := false; + Match('As'); + TypeIds.Add(Parse_Type); + DECLARE_SWITCH := true; + end + else + begin + TestExplicitOff; + TypeIds.Add(typeVARIANT); + end; + + if NotMatch(',') then + Break; + until false; + Match(')'); + end; + + var + PropId, PropTypeId, NP, ReadId, WriteId, I, ParamId: Integer; + begin + DECLARE_SWITCH := true; + Match('property'); + + PropId := Parse_Ident; + BeginProperty(PropId, StructTypeId); + + if modPRIVATE in ml then + SetVisibility(PropId, cvPRIVATE); + if modPUBLIC in ml then + SetVisibility(PropId, cvPUBLIC); + if modPROTECTED in ml then + SetVisibility(PropId, cvPROTECTED); + if modPUBLISHED in ml then + SetVisibility(PropId, cvPUBLISHED); + + ParamIds := TIntegerList.Create; + TypeIds := TIntegerList.Create; + ByRefIds := TIntegerList.Create; + + try + if IsCurrText('(') then + NP := Parse_ParamList + else + NP := 0; + SetCount(PropId, NP); + + if IsCurrText('As') then + begin + DECLARE_SWITCH := false; + Match('As'); + DECLARE_SWITCH := true; + PropTypeId := Parse_Ident; + end + else + begin + TestExplicitOff; + PropTypeId := typeVARIANT; + end; + Gen(OP_ASSIGN_TYPE, PropId, PropTypeID, 0); + + ReadId := 0; + WriteId := 0; + + MatchLineTerminator; + + while IsCurrText('Get') or IsCurrText('Set') do + begin + if IsCurrText('Get') then + begin + if ReadId <> 0 then + RaiseError(errSyntaxError, []); + + Match('Get'); + SubId := NewTempVar; + ReadId := SubId; + SetReadId(PropId, ReadId); + + BeginStructureMethod(SubId, StructTypeId, true, modSHARED in ml); + + for I := 0 to ParamIds.Count - 1 do + begin + ParamId := NewTempVar; + SetParam(ParamId, true); + SetName(ParamId, GetName(ParamIds[I])); + Gen(OP_ASSIGN_TYPE, ParamId, TypeIds[I], 0); + if ByRefIds[I] > 0 then + SetByRef(PropId); + end; + + SetCount(SubId, NP); + DECLARE_SWITCH := false; + Gen(OP_ASSIGN_TYPE, SubId, PropTypeID, 0); + Gen(OP_ASSIGN_TYPE, CurrResultId, PropTypeID, 0); + + InitSub(SubId); + Parse_MethodBody; + EndSub(SubId); + Match('End'); + Match('Get'); + MatchLineTerminator; + end + else + begin + if WriteId <> 0 then + RaiseError(errSyntaxError, []); + + Match('Set'); + SubId := NewTempVar; + WriteId := SubId; + SetWriteId(PropId, WriteId); + + BeginStructureMethod(SubId, StructTypeId, true, modSHARED in ml); + + for I := 0 to ParamIds.Count - 1 do + begin + ParamId := NewTempVar; + SetParam(ParamId, true); + SetName(ParamId, GetName(ParamIds[I])); + Gen(OP_ASSIGN_TYPE, ParamId, TypeIds[I], 0); + if ByRefIds[I] > 0 then + SetByRef(PropId); + end; + + if IsCurrText('(') then + Inc(NP, Parse_FormalParameterList(SubId)) + else + begin + ParamId := NewTempVar; + SetParam(ParamId, true); + SetName(ParamId, 'value'); + Gen(OP_ASSIGN_TYPE, ParamId, PropTypeId, 0); + Inc(NP, 1); + end; + + SetCount(SubId, NP); + SetName(CurrResultId, ''); + SetKind(CurrResultId, KindNONE); + SetType(SubId, TypeVOID); + SetType(CurrResultId, TypeVOID); + + InitSub(SubId); + Parse_MethodBody; + EndSub(SubId); + Match('End'); + Match('Set'); + MatchLineTerminator; + end; + end; + + finally + FreeAndNil(ParamIds); + FreeAndNil(TypeIds); + FreeAndNil(ByRefIds); + end; + + EndProperty(PropId); + Match('End'); + Match('Property'); + end; + +var + Id, TypeID, TempId, ConstId, ArrayTypeId, LengthId: Integer; + IsArray, IsDynArray, IsFWArray: Boolean; + Lst: TIntegerList; + I: Integer; + ClassArrayTypeId: Integer; + TempID2: Integer; +begin + InitIds := TIntegerList.Create; + Lst := TIntegerList.Create; + try + DECLARE_SWITCH := true; + Match('Structure'); + BeginTypeDef(CurrToken.Id); + + StructTypeID := Parse_Ident; + BeginRecordType(StructTypeID); + MatchLineTerminator; + + SetPacked(StructTypeID); + + HasConstructor := false; + HasDestructor := false; + + repeat + if IsCurrText('End') then + Break; + + if IsEOF then + Break; + + if not IsLineTerminator then + begin + ml := Parse_ModifierList; + + Gen(OP_STMT, 0, 0, 0); + if IsCurrText('Sub') then + begin + Parse_SubMethodDeclaration; + end + else if IsCurrText('Function') then + begin + Parse_FunctionMethodDeclaration; + end + else if IsCurrText('Operator') then + begin + Parse_OperatorDeclaration; + end + else if IsCurrText('Property') then + begin + Parse_PropertyDeclaration; + end + else + begin + Id := Parse_Ident; + DECLARE_SWITCH := false; + + if modPRIVATE in ml then + SetVisibility(Id, cvPRIVATE); + if modPUBLIC in ml then + SetVisibility(Id, cvPUBLIC); + if modPROTECTED in ml then + SetVisibility(Id, cvPROTECTED); + if modPUBLISHED in ml then + SetVisibility(Id, cvPUBLISHED); + + Lst.Clear; + IsDynArray := false; + IsFWArray := false; + if IsCurrText('(') then + begin + Match('('); + if IsCurrText(')') then + begin + ConstId := NewConst(typeINTEGER, 0); + Lst.Add(ConstId); + end + else + repeat + ConstId := Parse_Expression; + Lst.Add(ConstId); + if NotMatch(',') then + break; + until false; + Match(')'); + IsArray := true; + IsFWArray := UseFWArrays; + end + else if IsCurrText('[') then + begin + Match('['); + if IsCurrText(']') then + begin + ConstId := NewConst(typeINTEGER, 0); + Lst.Add(ConstId); + end + else + repeat + ConstId := Parse_Expression; + Lst.Add(ConstId); + if NotMatch(',') then + break; + until false; + Match(']'); + IsArray := true; + IsDynArray := true; + end + else + begin + IsArray := false; + ConstId := 0; + end; + + if IsCurrText('As') then + begin + Match('As'); + TypeID := Parse_Type; + end + else + begin + TestExplicitOff; + TypeId := typeVARIANT; + end; + + SetKind(Id, KindTYPE_FIELD); + + if IsArray then + begin + if IsDynArray or IsFWArray then + begin + ArrayTypeId := typeVARIANT; + for I :=0 to Lst.Count - 1 do + begin + ArrayTypeId := NewTempVar; + BeginDynamicArrayType(ArrayTypeID); + Gen(OP_CREATE_DYNAMIC_ARRAY_TYPE, ArrayTypeId, TypeID, 0); + EndDynamicArrayType(ArrayTypeID); + TypeId := ArrayTypeId; + end; + Gen(OP_ADD_TYPEINFO, ArrayTypeId, 0, 0); + end + else + ArrayTypeId := typeVARIANT; + + ClassArrayTypeId := 0; + if IsFWArray then + begin + ClassArrayTypeId := NewTempVar; + SetName(ClassArrayTypeId, 'FWArray_' + IntToStr(ClassArrayTypeId)); + BeginClassType(ClassArrayTypeID); + SetAncestorId(ClassArrayTypeId, H_TFW_Array); + EndClassType(ClassArrayTypeId); + + SetType(ID, ClassArrayTypeId); + Gen(OP_ADD_TYPEINFO, ClassArrayTypeId, 0, 0); + + SetPatternId(ClassArrayTypeId, ArrayTypeId); + end + else + Gen(OP_ASSIGN_TYPE, ID, ArrayTypeId, 0); + + SubId := NewTempVar; + BeginStructureMethod(SubId, StructTypeId, false, modSHARED in ml); + SetCount(SubId, 0); + SetName(CurrResultId, ''); + SetKind(CurrResultId, KindNONE); + SetType(SubId, TypeVOID); + SetType(CurrResultId, TypeVOID); + + InitSub(SubId); + + DECLARE_SWITCH := false; + SetName(CurrSelfId, 'Me'); + Gen(OP_BEGIN_WITH, CurrSelfId, 0, 0); + WithStack.Push(CurrSelfId); + Gen(OP_STMT, 0, 0, 0); + TempId := NewTempVar; + SetName(TempId, GetName(Id)); + Gen(OP_EVAL, 0, 0, TempId); + + // body + if (Lst.Count = 1) and (not IsFWArray) then + begin + LengthId := NewTempVar(typeINTEGER); + Gen(OP_PLUS, ConstId, NewConst(typeINTEGER, 1), LengthId); + Gen(OP_SET_LENGTH, TempId, LengthId, 0); + end + else + begin + if IsFWArray then + begin + TempID2 := NewTempVar; + SetName(TempID2, '@'); + SetType(TempID2, ClassArrayTypeId); + Gen(OP_PUSH_CLASSREF, ClassArrayTypeId, 0, Id_FWArray_Create); + Gen(OP_CALL, Id_FWArray_Create, 0, TempID2); + Gen(OP_INIT_FWARRAY, TempId2, Lst.Count, 1); + Gen(OP_ASSIGN, TempId, TempId2, TempId); + end; + for I := 0 to Lst.Count - 1 do + begin + ConstId := Lst[I]; + LengthId := NewTempVar(typeINTEGER); + Gen(OP_PLUS, ConstId, NewConst(typeINTEGER, 1), LengthId); + Gen(OP_PUSH_LENGTH, LengthId, 0, 0); + end; + Gen(OP_SET_LENGTH_EX, TempId, Lst.Count, 0); + end; + + Gen(OP_END_WITH, WithStack.Top, 0, 0); + WithStack.Pop; + DECLARE_SWITCH := true; + + EndSub(SubId); + + InitIds.Add(SubId); + end + else + Gen(OP_ASSIGN_TYPE, ID, TypeID, 0); + + if IsCurrText('=') then + begin + Match('='); + SubId := NewTempVar; + BeginStructureMethod(SubId, StructTypeId, false, modSHARED in ml); + SetCount(SubId, 0); + SetName(CurrResultId, ''); + SetKind(CurrResultId, KindNONE); + SetType(SubId, TypeVOID); + SetType(CurrResultId, TypeVOID); + + InitSub(SubId); + + DECLARE_SWITCH := false; + SetName(CurrSelfId, 'Me'); + Gen(OP_BEGIN_WITH, CurrSelfId, 0, 0); + WithStack.Push(CurrSelfId); + Gen(OP_STMT, 0, 0, 0); + TempId := NewTempVar; + SetName(TempId, GetName(Id)); + + // body + Gen(OP_EVAL, 0, 0, TempId); + Gen(OP_ASSIGN, TempId, Parse_Expression, TempId); + + Gen(OP_END_WITH, WithStack.Top, 0, 0); + WithStack.Pop; + DECLARE_SWITCH := true; + + EndSub(SubId); + + InitIds.Add(SubId); + end; + end; + end; + + DECLARE_SWITCH := true; + MatchLineTerminator; + + until false; + + if not HasConstructor then + GenDefaultStructureConstructor(StructTypeId, InitIds); + if not HasDestructor then + GenDefaultStructureDestructor(StructTypeId); + + EndRecordType(StructTypeId); + + Match('End'); + Match('Structure'); + + EndTypeDef(StructTypeId); + + DECLARE_SWITCH := false; + MatchLineTerminator; + + finally + FreeAndNil(InitIds); + FreeAndNil(Lst); + end; + Gen(OP_ADD_TYPEINFO, StructTypeId, 0, 0); +end; + +function TBasicParser.Parse_ModifierList: TBasicModifierList; +begin + result := []; + + repeat + + if IsCurrText('default') then + begin + result := result + [modDEFAULT]; + Call_SCANNER; + end + else if IsCurrText('public') then + begin + result := result + [modPUBLIC]; + Call_SCANNER; + end + else if IsCurrText('published') then + begin + result := result + [modPUBLISHED]; + Call_SCANNER; + end + else if IsCurrText('private') then + begin + result := result + [modPRIVATE]; +{ + if NextToken.TokenClass <> tcKeyword then + begin + CurrToken.Text := NextToken.Text; + CurrToken.Text := 'Dim'; + Exit; + end; +} + Call_SCANNER; + end + else if IsCurrText('protected') then + begin + result := result + [modPROTECTED]; + Call_SCANNER; + end + else if IsCurrText('shared') then + begin + result := result + [modSHARED]; + Call_SCANNER; + end + else if IsCurrText('overridable') then + begin + result := result + [modOVERRIDABLE]; + Call_SCANNER; + end + else if IsCurrText('notoverridable') then + begin + result := result + [modNOTOVERRIDABLE]; + Call_SCANNER; + end + else if IsCurrText('mustoverride') then + begin + result := result + [modMUSTOVERRIDE]; + Call_SCANNER; + end + else if IsCurrText('overrides') then + begin + result := result + [modOVERRIDES]; + Call_SCANNER; + end + else if IsCurrText('overloads') then + begin + result := result + [modOVERLOADS]; + Call_SCANNER; + end + else if IsCurrText('readonly') then + begin + result := result + [modREADONLY]; + Call_SCANNER; + end + else if IsCurrText('friend') then + begin + result := result + [modFRIEND]; + Call_SCANNER; + end + else if IsCurrText('mustinherit') then + begin + result := result + [modMUSTINHERIT]; + Call_SCANNER; + end + else if IsCurrText('shadows') then + begin + result := result + [modSHADOWS]; + Call_SCANNER; + end + else if IsCurrText('notinheritable') then + begin + result := result + [modNOTINHERITABLE]; + Call_SCANNER; + end + else if IsCurrText('withevents') then + begin + result := result + [modWITHEVENTS]; + Call_SCANNER; + end + else if IsCurrText('internal') then + begin + result := result + [modINTERNAL]; + Call_SCANNER; + end + else + Exit; + + until false; +end; + +procedure TBasicParser.Parse_CallConvention(SubId: Integer; IsDeclaredProc: Boolean); +begin + if IsCurrText('Register') then + begin + SetCallConvention(SubId, ccREGISTER); + Call_SCANNER; + end + else if IsCurrText('StdCall') then + begin + SetCallConvention(SubId, ccSTDCALL); + Call_SCANNER; + end + else if IsCurrText('CDecl') then + begin + SetCallConvention(SubId, ccCDECL); + Call_SCANNER; + end + else if IsCurrText('Pascal') then + begin + SetCallConvention(SubId, ccPASCAL); + Call_SCANNER; + end + else if IsCurrText('SafeCall') then + begin + SetCallConvention(SubId, ccSAFECALL); + Call_SCANNER; + end + else if IsCurrText('MSFastCall') then + begin + SetCallConvention(SubId, ccMSFASTCALL); + Call_SCANNER; + end + else if IsDeclaredProc then + SetCallConvention(SubId, DeclareCallConv); +end; + +function TBasicParser.Parse_VisibilityModifierList: TBasicModifierList; +begin + result := [modPUBLIC]; + + repeat + + if IsCurrText('public') then + begin + DECLARE_SWITCH := true; + result := result + [modPUBLIC]; + Call_SCANNER; + end + else if IsCurrText('published') then + begin + DECLARE_SWITCH := true; + result := result + [modPUBLISHED]; + Call_SCANNER; + end + else if IsCurrText('private') then + begin + DECLARE_SWITCH := true; + result := result + [modPRIVATE]; +{ + if NextToken.TokenClass <> tcKeyword then + begin + CurrToken.Text := NextToken.Text; + CurrToken.Text := 'Dim'; + Exit; + end; +} + Call_SCANNER; + end + else if IsCurrText('protected') then + begin + DECLARE_SWITCH := true; + result := result + [modPROTECTED]; + Call_SCANNER; + end + else if IsCurrText('internal') then + begin + DECLARE_SWITCH := true; + result := result + [modINTERNAL]; + Call_SCANNER; + end + else + Exit; + + until false; +end; + +procedure TBasicParser.Parse_ClassTypeDeclaration; + +var + ml: TBasicModifierList; + SubId, ClassTypeId: Integer; + HasConstructor, HasDestructor: Boolean; + InitIds: TIntegerList; + + procedure Parse_MethodBody(L: TIntegerList = nil); + var + I: Integer; + begin + DECLARE_SWITCH := false; + SetName(CurrSelfId, 'Me'); + SetVisibility(SubId, cvPUBLIC); + if modPRIVATE in ml then + SetVisibility(SubId, cvPRIVATE); + if modPUBLIC in ml then + SetVisibility(SubId, cvPUBLIC); + if modPROTECTED in ml then + SetVisibility(SubId, cvPROTECTED); + if modPUBLISHED in ml then + SetVisibility(SubId, cvPUBLISHED); + if modOVERRIDABLE in ml then + SetCallMode(SubId, cmVIRTUAL); + if modOVERRIDES in ml then + begin + SetCallMode(SubId, cmOVERRIDE); + Gen(OP_CHECK_OVERRIDE, SubId, 0, 0); + Gen(OP_ADD_MESSAGE, SubId, NewConst(typeINTEGER, -1000), 0); + end; + if modOVERLOADS in ml then + SetOverloaded(SubId); + + Gen(OP_BEGIN_WITH, CurrSelfId, 0, 0); + WithStack.Push(CurrSelfId); + Gen(OP_STMT, 0, 0, 0); + + if L <> nil then + for I := 0 to L.Count - 1 do + begin + Gen(OP_PUSH_INSTANCE, CurrSelfId, 0, L[I]); + Gen(OP_CALL, L[I], 0, 0); + end; + + MatchLineTerminator; + Parse_Statements; + + Gen(OP_END_WITH, WithStack.Top, 0, 0); + WithStack.Pop; + DECLARE_SWITCH := true; + end; + + procedure Parse_SubMethodDeclaration; + var + NP, L: Integer; + begin + DECLARE_SWITCH := true; + Match('Sub'); + + if IsCurrText('New') then + begin + HasConstructor := true; + Match('New'); + SubId := NewTempVar; + BeginClassConstructor(SubId, ClassTypeId); + SetVisibility(SubId, cvPublic); + + if IsCurrText('Lib') then + Parse_Lib(SubId) + else + begin + if IsCurrText('(') then + NP := Parse_FormalParameterList(SubId) + else + NP := 0; + + SetCount(SubId, NP); + + InitSub(SubId); + + WasInherited := false; + + Gen(OP_SAVE_EDX, 0, 0, 0); + L := NewLabel; + Gen(OP_GO_DL, L, 0, 0); + Gen(OP_CREATE_OBJECT, ClassTypeId, 0, CurrSelfId); + SetLabelHere(L); + + Parse_MethodBody(InitIDs); + + if not WasInherited then + CreateError(errTheCallOfInheritedConstructorIsMandatory, []); + + Gen(OP_RESTORE_EDX, 0, 0, 0); + L := NewLabel; + Gen(OP_GO_DL, L, 0, 0); + Gen(OP_ON_AFTER_OBJECT_CREATION, CurrSelfId, 0, 0); + SetLabelHere(L); + + EndSub(SubId); + Match('End'); + Match('Sub'); + end; + end + else if IsCurrText('Finalize') then + begin + HasDestructor := true; + + Match('Finalize'); + SubId := NewTempVar; + SetName(SubId, 'Destroy'); + BeginClassDestructor(SubId, ClassTypeId); + SetVisibility(SubId, cvPublic); + + if IsCurrText('Lib') then + Parse_Lib(SubId) + else + begin + NP := 0; + SetCount(SubId, NP); + + InitSub(SubId); + Parse_MethodBody; + EndSub(SubId); + Match('End'); + Match('Sub'); + end; + end + else + begin + SubId := Parse_Ident; + BeginClassMethod(SubId, ClassTypeId, false, modSHARED in ml, false); + + if IsCurrText('Lib') then + Parse_Lib(SubId) + else + begin + if IsCurrText('(') then + NP := Parse_FormalParameterList(SubId) + else + NP := 0; + + SetCount(SubId, NP); + SetName(CurrResultId, ''); + SetKind(CurrResultId, KindNONE); + Gen(OP_ASSIGN_TYPE, SubId, TypeVOID, 0); + Gen(OP_ASSIGN_TYPE, CurrResultId, TypeVOID, 0); + + InitSub(SubId); + Parse_MethodBody; + + EndSub(SubId); + Match('End'); + Match('Sub'); + end; + end; + end; + + procedure Parse_FunctionMethodDeclaration; + var + TypeId, NP: Integer; + begin + DECLARE_SWITCH := true; + Match('function'); + SubId := Parse_Ident; + BeginClassMethod(SubId, ClassTypeId, true, modSHARED in ml, false); + SetName(CurrResultId, ''); + if IsCurrText('Lib') then + begin + Parse_Lib(SubId); + DECLARE_SWITCH := false; + if IsCurrText('As') then + begin + Match('As'); + TypeID := Parse_Type; + end + else + begin + TestExplicitOff; + TypeId := typeVARIANT; + end; + Gen(OP_ASSIGN_TYPE, SubId, TypeID, 0); + end + else + begin + if IsCurrText('(') then + NP := Parse_FormalParameterList(SubId) + else + NP := 0; + SetCount(SubId, NP); + DECLARE_SWITCH := false; + if IsCurrText('As') then + begin + Match('As'); + TypeID := Parse_Type; + end + else + begin + TestExplicitOff; + TypeId := typeVARIANT; + end; + Gen(OP_ASSIGN_TYPE, SubId, TypeID, 0); + Gen(OP_ASSIGN_TYPE, CurrResultId, TypeID, 0); + + InitSub(SubId); + Parse_MethodBody; + EndSub(SubId); + Match('End'); + Match('Function'); + end; + end; + + procedure Parse_PropertyDeclaration; + + var + ParamIds, TypeIds, ByRefIds: TIntegerList; + + function Parse_ParamList: Integer; + begin + DECLARE_SWITCH := true; + Match('('); + result := 0; + if not IsCurrText(')') then + repeat + if IsCurrText('ByRef') then + begin + Match('ByRef'); + ByRefIds.Add(Integer(true)); + end + else if IsCurrText('ByVal') then + begin + Match('ByVal'); + ByRefIds.Add(Integer(false)); + end + else + ByRefIds.Add(Integer(false)); + + Inc(result); + ParamIds.Add(Parse_Ident); + + if IsCurrText('As') then + begin + DECLARE_SWITCH := false; + Match('As'); + TypeIds.Add(Parse_Type); + DECLARE_SWITCH := true; + end + else + begin + TestExplicitOff; + TypeIds.Add(typeVARIANT); + end; + + if NotMatch(',') then + Break; + until false; + Match(')'); + end; + + var + PropId, PropTypeId, NP, ReadId, WriteId, I, ParamId: Integer; + begin + DECLARE_SWITCH := true; + Match('property'); + + PropId := Parse_Ident; + BeginProperty(PropId, ClassTypeId); + + if modPRIVATE in ml then + SetVisibility(PropId, cvPRIVATE); + if modPUBLIC in ml then + SetVisibility(PropId, cvPUBLIC); + if modPROTECTED in ml then + SetVisibility(PropId, cvPROTECTED); + if modPUBLISHED in ml then + SetVisibility(PropId, cvPUBLISHED); + + ParamIds := TIntegerList.Create; + TypeIds := TIntegerList.Create; + ByRefIds := TIntegerList.Create; + + try + if IsCurrText('(') then + NP := Parse_ParamList + else + NP := 0; + SetCount(PropId, NP); + + if IsCurrText('As') then + begin + DECLARE_SWITCH := false; + Match('As'); + DECLARE_SWITCH := true; + PropTypeId := Parse_Ident; + end + else + begin + TestExplicitOff; + PropTypeId := typeVARIANT; + end; + Gen(OP_ASSIGN_TYPE, PropId, PropTypeID, 0); + + ReadId := 0; + WriteId := 0; + + ml := [ModPRIVATE]; + + MatchLineTerminator; + + while IsCurrText('Get') or IsCurrText('Set') do + begin + if IsCurrText('Get') then + begin + if ReadId <> 0 then + RaiseError(errSyntaxError, []); + + Match('Get'); + SubId := NewTempVar; + ReadId := SubId; + SetReadId(PropId, ReadId); + + SetName(SubId, '__get' + GetName(PropId)); + + BeginClassMethod(SubId, ClassTypeId, true, modSHARED in ml, false); + + for I := 0 to ParamIds.Count - 1 do + begin + ParamId := NewTempVar; + SetParam(ParamId, true); + SetName(ParamId, GetName(ParamIds[I])); + Gen(OP_ASSIGN_TYPE, ParamId, TypeIds[I], 0); + if ByRefIds[I] > 0 then + SetByRef(PropId); + end; + + SetCount(SubId, NP); + DECLARE_SWITCH := false; + Gen(OP_ASSIGN_TYPE, SubId, PropTypeID, 0); + Gen(OP_ASSIGN_TYPE, CurrResultId, PropTypeID, 0); + + InitSub(SubId); + Parse_MethodBody; + EndSub(SubId); + Match('End'); + Match('Get'); + MatchLineTerminator; + end + else + begin + if WriteId <> 0 then + RaiseError(errSyntaxError, []); + + Match('Set'); + SubId := NewTempVar; + WriteId := SubId; + SetWriteId(PropId, WriteId); + + SetName(SubId, '__set' + GetName(PropId)); + + BeginClassMethod(SubId, ClassTypeId, true, modSHARED in ml, false); + + for I := 0 to ParamIds.Count - 1 do + begin + ParamId := NewTempVar; + SetParam(ParamId, true); + SetName(ParamId, GetName(ParamIds[I])); + Gen(OP_ASSIGN_TYPE, ParamId, TypeIds[I], 0); + if ByRefIds[I] > 0 then + SetByRef(PropId); + end; + + if IsCurrText('(') then + Inc(NP, Parse_FormalParameterList(SubId)) + else + begin + ParamId := NewTempVar; + SetParam(ParamId, true); + SetName(ParamId, 'value'); + Gen(OP_ASSIGN_TYPE, ParamId, PropTypeId, 0); + Inc(NP, 1); + end; + + SetCount(SubId, NP); + SetName(CurrResultId, ''); + SetKind(CurrResultId, KindNONE); + SetType(SubId, TypeVOID); + SetType(CurrResultId, TypeVOID); + + InitSub(SubId); + Parse_MethodBody; + EndSub(SubId); + Match('End'); + Match('Set'); + MatchLineTerminator; + end; + end; + + finally + FreeAndNil(ParamIds); + FreeAndNil(TypeIds); + FreeAndNil(ByRefIds); + end; + + EndProperty(PropId); + Match('End'); + Match('Property'); + end; + +var + Id, TypeID, TempId, ConstId, ArrayTypeId, LengthId, AncestorId: Integer; + IsArray, IsDynArray, IsFWArray: Boolean; + Lst: TIntegerList; + I: Integer; + ClassArrayTypeId: Integer; + TempId2: Integer; +begin + InitIds := TIntegerList.Create; + Lst := TIntegerList.Create; + try + DECLARE_SWITCH := true; + Match('Class'); + BeginTypeDef(CurrToken.Id); + + ClassTypeID := Parse_Ident; + BeginClassType(ClassTypeID); + MatchLineTerminator; + + SetPacked(ClassTypeID); + + HasConstructor := false; + HasDestructor := false; + + if IsCurrText('Inherits') then + begin + DECLARE_SWITCH := false; + Match('Inherits'); + Gen(OP_ADD_ANCESTOR, ClassTypeId, Parse_Ident, 0); + + if IsCurrText(',') then + begin + Call_SCANNER; + repeat + AncestorId := Parse_Ident; + Gen(OP_ADD_INTERFACE, ClassTypeId, AncestorId, 0); + if NotMatch(',') then + break; + until false; + end; + + DECLARE_SWITCH := true; + MatchLineTerminator; + end + else + Gen(OP_ADD_ANCESTOR, ClassTypeId, H_TObject, 0); + + repeat + + if IsCurrText('End') then + Break; + + if IsEOF then + Break; + + if not IsLineTerminator then + begin + ml := Parse_ModifierList; + + Gen(OP_STMT, 0, 0, 0); + if IsCurrText('Sub') then + begin + Parse_SubMethodDeclaration; + end + else if IsCurrText('Function') then + begin + Parse_FunctionMethodDeclaration; + end + else if IsCurrText('Property') then + begin + Parse_PropertyDeclaration; + end + else if IsCurrText('Class') then + begin + Parse_ClassTypeDeclaration(ml); + end + else + begin + if IsCurrText('Dim') then + Call_SCANNER + else if IsCurrText('Const') then + Call_SCANNER; + + Id := Parse_Ident; + DECLARE_SWITCH := false; + + if modPRIVATE in ml then + SetVisibility(Id, cvPRIVATE); + if modPUBLIC in ml then + SetVisibility(Id, cvPUBLIC); + if modPROTECTED in ml then + SetVisibility(Id, cvPROTECTED); + if modPUBLISHED in ml then + SetVisibility(Id, cvPUBLISHED); + + Lst.Clear; + IsDynArray := false; + IsFWArray := false; + if IsCurrText('(') then + begin + Match('('); + if IsCurrText(')') then + begin + ConstId := NewConst(typeINTEGER, 0); + Lst.Add(ConstId); + end + else + repeat + ConstId := Parse_Expression; + Lst.Add(ConstId); + if NotMatch(',') then + break; + until false; + Match(')'); + IsArray := true; + IsFWArray := UseFWArrays; + end + else if IsCurrText('[') then + begin + Match('['); + if IsCurrText(']') then + begin + ConstId := NewConst(typeINTEGER, 0); + Lst.Add(ConstId); + end + else + repeat + ConstId := Parse_Expression; + Lst.Add(ConstId); + if NotMatch(',') then + break; + until false; + Match(']'); + IsArray := true; + IsDynArray := true; + end + else + begin + IsArray := false; + ConstId := 0; + end; + + if IsCurrText('As') then + begin + Match('As'); + TypeID := Parse_Type; + end + else + begin + TestExplicitOff; + TypeId := typeVARIANT; + end; + + SetKind(Id, KindTYPE_FIELD); + + if IsArray then + begin + if IsDynArray or IsFWArray then + begin + ArrayTypeId := typeVARIANT; + for I :=0 to Lst.Count - 1 do + begin + ArrayTypeId := NewTempVar; + BeginDynamicArrayType(ArrayTypeID); + Gen(OP_CREATE_DYNAMIC_ARRAY_TYPE, ArrayTypeId, TypeID, 0); + EndDynamicArrayType(ArrayTypeID); + TypeId := ArrayTypeId; + end; + Gen(OP_ADD_TYPEINFO, ArrayTypeId, 0, 0); + end + else + ArrayTypeId := typeVARIANT; + + ClassArrayTypeId := 0; + if IsFWArray then + begin + ClassArrayTypeId := NewTempVar; + SetName(ClassArrayTypeId, 'FWArray_' + IntToStr(ClassArrayTypeId)); + BeginClassType(ClassArrayTypeID); + SetAncestorId(ClassArrayTypeId, H_TFW_Array); + EndClassType(ClassArrayTypeId); + + SetType(ID, ClassArrayTypeId); + Gen(OP_ADD_TYPEINFO, ClassArrayTypeId, 0, 0); + + SetPatternId(ClassArrayTypeId, ArrayTypeId); + end + else + Gen(OP_ASSIGN_TYPE, ID, ArrayTypeId, 0); + + SubId := NewTempVar; + BeginClassMethod(SubId, ClassTypeId, false, modSHARED in ml, false); + SetCount(SubId, 0); + SetName(CurrResultId, ''); + SetKind(CurrResultId, KindNONE); + SetType(SubId, TypeVOID); + SetType(CurrResultId, TypeVOID); + + InitSub(SubId); + + DECLARE_SWITCH := false; + SetName(CurrSelfId, 'Me'); + Gen(OP_BEGIN_WITH, CurrSelfId, 0, 0); + WithStack.Push(CurrSelfId); + Gen(OP_STMT, 0, 0, 0); + TempId := NewTempVar; + SetName(TempId, GetName(Id)); + Gen(OP_EVAL, 0, 0, TempId); + + // body + if (Lst.Count = 1) and (not IsFWArray) then + begin + LengthId := NewTempVar(typeINTEGER); + Gen(OP_PLUS, ConstId, NewConst(typeINTEGER, 1), LengthId); + Gen(OP_SET_LENGTH, TempId, LengthId, 0); + end + else + begin + if IsFWArray then + begin + TempID2 := NewTempVar; + SetName(TempID2, '@'); + SetType(TempID2, ClassArrayTypeId); + Gen(OP_PUSH_CLASSREF, ClassArrayTypeId, 0, Id_FWArray_Create); + Gen(OP_CALL, Id_FWArray_Create, 0, TempID2); + Gen(OP_INIT_FWARRAY, TempId2, Lst.Count, 1); + + Gen(OP_ASSIGN, TempId, TempId2, TempId); + end; + for I := 0 to Lst.Count - 1 do + begin + ConstId := Lst[I]; + LengthId := NewTempVar(typeINTEGER); + Gen(OP_PLUS, ConstId, NewConst(typeINTEGER, 1), LengthId); + Gen(OP_PUSH_LENGTH, LengthId, 0, 0); + end; + Gen(OP_SET_LENGTH_EX, TempId, Lst.Count, 0); + end; + + Gen(OP_END_WITH, WithStack.Top, 0, 0); + WithStack.Pop; + DECLARE_SWITCH := true; + + EndSub(SubId); + + InitIds.Add(SubId); + end + else + Gen(OP_ASSIGN_TYPE, ID, TypeID, 0); + + if IsCurrText('=') then + begin + Match('='); + SubId := NewTempVar; + BeginClassMethod(SubId, ClassTypeId, false, modSHARED in ml, false); + SetCount(SubId, 0); + SetName(CurrResultId, ''); + SetKind(CurrResultId, KindNONE); + SetType(SubId, TypeVOID); + SetType(CurrResultId, TypeVOID); + + InitSub(SubId); + + DECLARE_SWITCH := false; + SetName(CurrSelfId, 'Me'); + Gen(OP_BEGIN_WITH, CurrSelfId, 0, 0); + WithStack.Push(CurrSelfId); + Gen(OP_STMT, 0, 0, 0); + TempId := NewTempVar; + SetName(TempId, GetName(Id)); + + // body + Gen(OP_EVAL, 0, 0, TempId); + Gen(OP_ASSIGN, TempId, Parse_Expression, TempId); + + Gen(OP_END_WITH, WithStack.Top, 0, 0); + WithStack.Pop; + DECLARE_SWITCH := true; + + EndSub(SubId); + + InitIds.Add(SubId); + end + else if not IsArray then + begin + + SubId := NewTempVar; + BeginClassMethod(SubId, ClassTypeId, false, modSHARED in ml, false); + SetCount(SubId, 0); + SetName(CurrResultId, ''); + SetKind(CurrResultId, KindNONE); + SetType(SubId, TypeVOID); + SetType(CurrResultId, TypeVOID); + + InitSub(SubId); + + DECLARE_SWITCH := false; + SetName(CurrSelfId, 'Me'); + Gen(OP_BEGIN_WITH, CurrSelfId, 0, 0); + WithStack.Push(CurrSelfId); + Gen(OP_STMT, 0, 0, 0); + TempId := NewTempVar; + SetName(TempId, GetName(Id)); + + // body + Gen(OP_EVAL, 0, 0, TempId); + Gen(OP_CALL_DEFAULT_CONSTRUCTOR, TempID, 0, 0); + + Gen(OP_END_WITH, WithStack.Top, 0, 0); + WithStack.Pop; + DECLARE_SWITCH := true; + + EndSub(SubId); + + InitIds.Add(SubId); + + end; + end; + end; + + DECLARE_SWITCH := true; + if IsLineTerminator then + MatchLineTerminator; + + until false; + + if not HasConstructor then + GenDefaultClassConstructor(ClassTypeId, InitIds); + if not HasDestructor then + GenDefaultClassDestructor(ClassTypeId); + + if OuterClassId > 0 then + begin + Id := NewTempVar; + SetType(Id, OuterClassId); + SetName(Id, StrOuterThis); + SetLevel(Id, ClassTypeId); + SetKind(Id, KindTYPE_FIELD); + SetVisibility(Id, cvPublic); + end; + + EndClassType(ClassTypeId); + + Match('End'); + Match('Class'); + + EndTypeDef(ClassTypeId); + + DECLARE_SWITCH := false; + MatchLineTerminator; + + finally + FreeAndNil(InitIds); + FreeAndNil(Lst); + end; + Gen(OP_ADD_TYPEINFO, ClassTypeId, 0, 0); +end; + +procedure TBasicParser.Parse_MethodRefTypeDeclaration(TypeID: Integer); + +var + NegativeMethodIndex: Integer; + + function Parse_SubHeading: Integer; + begin + Dec(NegativeMethodIndex); + + DECLARE_SWITCH := true; + Match('Sub'); + result := NewTempVar(); + SetName(result, ANONYMOUS_METHOD_NAME); + BeginInterfaceMethod(result, TypeId, false); + Parse_FormalParameterList(result); + Gen(OP_ADD_METHOD_INDEX, result, NegativeMethodIndex, 0); + + DECLARE_SWITCH := true; + EndTypeDef(TypeId); + MatchLineTerminator; + + EndSub(result); + end; + + function Parse_FunctionHeading: Integer; + var + ResTypeID: Integer; + begin + Dec(NegativeMethodIndex); + + DECLARE_SWITCH := true; + Match('Function'); + result := NewTempVar(); + SetName(result, ANONYMOUS_METHOD_NAME); + BeginInterfaceMethod(result, TypeId, true); + Parse_FormalParameterList(result); + + DECLARE_SWITCH := false; + Match('As'); + ResTypeID := Parse_Type; + Gen(OP_ASSIGN_TYPE, result, ResTypeID, 0); + Gen(OP_ASSIGN_TYPE, CurrResultId, ResTypeID, 0); + Gen(OP_ADD_METHOD_INDEX, result, NegativeMethodIndex, 0); + + DECLARE_SWITCH := true; + EndTypeDef(TypeId); + MatchLineTerminator; + + EndSub(result); + end; + +begin + NegativeMethodIndex := 0; + + BeginMethodRefType(TypeID); + + if IsCurrText('Sub') then + begin + Parse_SubHeading; + end + else if IsCurrText('Function') then + begin + Parse_FunctionHeading; + end + else + Match('Function'); + + EndMethodRefType(TypeId); +end; + +procedure TBasicParser.Parse_InterfaceTypeDeclaration; +var + NegativeMethodIndex: Integer; + IntfTypeId: Integer; + + function Parse_SubHeading: Integer; + var + NP: Integer; + begin + Dec(NegativeMethodIndex); + DECLARE_SWITCH := true; + Match('Sub'); + result := Parse_Ident; + BeginInterfaceMethod(result, IntfTypeId, false); + if IsCurrText('(') then + NP := Parse_FormalParameterList(result) + else + NP := 0; + SetCount(result, NP); + Gen(OP_ADD_METHOD_INDEX, result, NegativeMethodIndex, 0); + DECLARE_SWITCH := true; + MatchLineTerminator; + EndSub(result); + end; + + function Parse_FunctionHeading: Integer; + var + NP, TypeID: Integer; + begin + Dec(NegativeMethodIndex); + + DECLARE_SWITCH := true; + Match('Function'); + result := Parse_Ident; + BeginInterfaceMethod(result, IntfTypeId, true); + SetName(CurrResultId, ''); + if IsCurrText('(') then + NP := Parse_FormalParameterList(result) + else + NP := 0; + SetCount(result, NP); + + DECLARE_SWITCH := false; + Match('As'); + TypeID := Parse_Type; + Gen(OP_ASSIGN_TYPE, result, TypeID, 0); + Gen(OP_ASSIGN_TYPE, CurrResultId, TypeID, 0); + Gen(OP_ADD_METHOD_INDEX, result, NegativeMethodIndex, 0); + + DECLARE_SWITCH := true; + MatchLineTerminator; + + EndSub(result); + end; + + function Parse_Property: Integer; + var + NP, TypeID, ReadId, WriteId: Integer; + begin + DECLARE_SWITCH := true; + Match('property'); + result := Parse_Ident; + BeginProperty(result, IntfTypeId); + SetVisibility(result, cvPublic); + if IsCurrText('[') then + NP := Parse_FormalParameterList(result) + else + NP := 0; + SetCount(result, NP); + + DECLARE_SWITCH := false; + Match(':'); + if CurrToken.TokenClass <> tcIdentifier then + RaiseError(errIdentifierExpected, [CurrToken.Text]); + TypeID := CurrToken.Id; + Gen(OP_ASSIGN_TYPE, result, TypeID, 0); + + ReadId := 0; + WriteId := 0; + + repeat + ReadToken; + + if IsCurrText('read') and (ReadId = 0) then + begin + ReadToken; + if CurrToken.TokenClass <> tcIdentifier then + RaiseError(errIdentifierExpected, [CurrToken.Text]); + ReadId := Lookup(CurrToken.Text, IntfTypeId); + if ReadId = 0 then + RaiseError(errUndeclaredIdentifier, [CurrToken.Text]); + SetReadId(result, ReadId); + end + else if IsCurrText('write') and (WriteId = 0) then + begin + ReadToken; + if CurrToken.TokenClass <> tcIdentifier then + RaiseError(errIdentifierExpected, [CurrToken.Text]); + WriteId := Lookup(CurrToken.Text, IntfTypeId); + if WriteId = 0 then + RaiseError(errUndeclaredIdentifier, [CurrToken.Text]); + SetWriteId(result, WriteId); + end + else + break; + until false; + + if IsCurrText(';') then + ReadToken + else + RaiseError(errTokenExpected, [';', CurrToken.Text]); + + if IsCurrText('default') then + begin + Call_SCANNER; + SetDefault(result, true); + end; + + EndProperty(result); + end; + +var + L: TIntegerList; + I, AncestorId: Integer; + S: String; +begin + Match('Interface'); + BeginTypeDef(CurrToken.Id); + + IntfTypeID := Parse_Ident; + + NegativeMethodIndex := 0; + + BeginInterfaceType(IntfTypeID); + SetPacked(IntfTypeID); + + while IsLineTerminator do + begin + if IsEOF then + Exit; + MatchLineTerminator; + end; + + if IsCurrText('Inherits') then + begin + DECLARE_SWITCH := false; + Match('Inherits'); + repeat + AncestorId := Parse_Ident; + Gen(OP_ADD_INTERFACE, IntfTypeId, AncestorId, 0); + if NotMatch(',') then + break; + until false; + DECLARE_SWITCH := true; + MatchLineTerminator; + end + else + Gen(OP_ADD_INTERFACE, IntfTypeId, H_IUnknown, 0); + + if IsCurrText('[') then + begin + Match('['); + I := Parse_PCharLiteral; + S := GetValue(I); + SetGuid(IntfTypeId, S); + Match(']'); + end + else + SetNewGuid(IntfTypeId); + + L := TIntegerList.Create; + try + repeat + if IsEOF then + Break; + if IsCurrText('end') then + Break; + + if IsCurrText('Sub') then + begin + Parse_SubHeading; + end + else if IsCurrText('Function') then + begin + Parse_FunctionHeading; + end; +{ + else if IsCurrText('property') then + begin + Parse_Property; + end; +} + + DECLARE_SWITCH := true; + + until false; + finally + FreeAndNil(L); + end; + + EndInterfaceType(IntfTypeId); + + Match('End'); + Match('Interface'); + + EndTypeDef(IntfTypeId); + + DECLARE_SWITCH := false; + MatchLineTerminator; + Gen(OP_ADD_TYPEINFO, IntfTypeId, 0, 0); +end; + +procedure TBasicParser.Parse_EnumTypeDeclaration; +var + TypeId, ID, TempID, L, K: Integer; +begin + L := CurrLevel; + + DECLARE_SWITCH := true; + Match('Enum'); + TypeId := Parse_Ident; + BeginEnumType(TypeID, TypeINTEGER); + + MatchLineTerminator; + + TempID := NewConst(TypeID, 0); + + K := 0; + + repeat + + If IsEOF then + Match('End'); + + if IsCurrText('End') then + Break; + + if not IsLineTerminator then + begin + ID := Parse_EnumIdent; + SetLevel(ID, L); + + Inc(K); + + if IsCurrText('=') then + begin + DECLARE_SWITCH := false; + Match('='); + Gen(OP_ASSIGN_ENUM, ID, Parse_ConstantExpression, ID); + Gen(OP_ASSIGN_ENUM, TempID, ID, TempID); + Gen(OP_INC, TempID, NewConst(typeINTEGER, 1), tempID); + DECLARE_SWITCH := true; + end + else + begin + Gen(OP_ASSIGN_ENUM, ID, TempID, ID); + Gen(OP_INC, TempID, NewConst(typeINTEGER, 1), tempID); + end; + end; + + MatchLineTerminator; + until false; + + EndEnumType(TypeID, K); + + Match('End'); + Match('Enum'); + + DECLARE_SWITCH := false; + MatchLineTerminator; + + Gen(OP_ADD_TYPEINFO, TypeId, 0, 0); +end; + +function TBasicParser.Parse_ArrayOfConstType: Integer; +var + S: String; +begin + Match('Const'); + Match('('); + Match(')'); + result := NewTempVar; + BeginOpenArrayType(result); + Gen(OP_CREATE_DYNAMIC_ARRAY_TYPE, result, H_TVarRec, 0); + EndOpenArrayType(result, S); + DECLARE_SWITCH := false; +end; + +function TBasicParser.Parse_FormalParameterList(SubId: Integer): Integer; +var + ID, TypeId, ArrayTypeId: Integer; + ByRef: Boolean; +begin + DECLARE_SWITCH := true; + Match('('); + result := 0; + if not IsCurrText(')') then + begin + repeat + if IsCurrText('ByRef') then + begin + Match('ByRef'); + ByRef := true; + end + else if IsCurrText('ByVal') then + begin + Match('ByVal'); + ByRef := false; + end + else + ByRef := false; + + Inc(result); + ID := Parse_FormalParameter; + Gen(OP_DECLARE_LOCAL_VAR, CurrLevel, ID, 0); + DECLARE_SWITCH := false; + + ArrayTypeId := 0; + + if IsCurrText('As') then + begin + Match('As'); + + if IsCurrText('Const') then + TypeId := Parse_ArrayOfConstType + else + TypeId := Parse_Type; + + if IsCurrText('(') then + begin + Match('('); + Match(')'); + ArrayTypeId := NewTempVar; + BeginDynamicArrayType(ArrayTypeID); + Gen(OP_CREATE_DYNAMIC_ARRAY_TYPE, ArrayTypeId, TypeID, 0); + EndDynamicArrayType(ArrayTypeID); + Gen(OP_ADD_TYPEINFO, ArrayTypeId, 0, 0); + TypeId := ArrayTypeId; + end; + end + else + begin + TestExplicitOff; + TypeId := typeVARIANT; + end; + DECLARE_SWITCH := true; + + if ByRef then + SetByRef(ID); + Gen(OP_ASSIGN_TYPE, ID, TypeID, 0); + + if IsCurrText('=') then + begin + DECLARE_SWITCH := false; + if ArrayTypeId = 0 then + Match('=') + else + Match(','); + Gen(OP_ASSIGN_CONST, ID, Parse_ConstantExpression, ID); + SetOptional(ID); + DECLARE_SWITCH := true; + end; + + if NotMatch(',') then + Break; + until false; + end; + Match(')'); + SetCount(SubId, result); +end; + +procedure TBasicParser.Parse_ExternalSubDeclaration(SubMl: TBasicModifierList); +var + SubId, NP, LibId, AliasId, SubNameId: Integer; + S: String; +begin + DECLARE_SWITCH := true; + Match('Sub'); + + SubId := Parse_Ident; + BeginSub(SubId); + Parse_CallConvention(SubId, true); + SetExternal(SubId, true); + + S := GetName(SubId); + SubNameId := NewConst(typeSTRING, S); + + DECLARE_SWITCH := false; + if not IsCurrText('Lib') then + Match('Lib') + else + ReadToken; + + if CurrToken.TokenClass = tcPCharConst then + begin + S := RemoveCh('"', CurrToken.Text); + LibId := NewConst(typeSTRING, S); + end + else + begin + LibId := Lookups(CurrToken.Text, LevelStack); + + if LibId = 0 then + RaiseError(errUndeclaredIdentifier, [CurrToken.Text]); + + if not IsStringConst(LibId) then + RaiseError(errIncompatibleTypesNoArgs, []); + end; + ReadToken; + + if IsCurrText('Alias') then + begin + ReadToken; + if CurrToken.TokenClass = tcPCharConst then + begin + S := RemoveCh('"', CurrToken.Text); + AliasId := NewConst(typeSTRING, S); + end + else + begin + AliasId := Lookups(CurrToken.Text, LevelStack); + + if AliasId = 0 then + RaiseError(errUndeclaredIdentifier, [CurrToken.Text]); + + if not IsStringConst(AliasId) then + RaiseError(errIncompatibleTypesNoArgs, []); + end; + SubNameId := AliasId; + ReadToken; + end; + + DECLARE_SWITCH := true; + if IsCurrText('(') then + NP := Parse_FormalParameterList(SubId) + else + NP := 0; + SetCount(SubId, NP); + SetName(CurrResultId, ''); + SetKind(CurrResultId, KindNONE); + Gen(OP_ASSIGN_TYPE, SubId, TypeVOID, 0); + Gen(OP_ASSIGN_TYPE, CurrResultId, TypeVOID, 0); + + EndSub(SubId); + RemoveSub; + + Gen(OP_LOAD_PROC, SubId, SubNameId, LibId); + + DECLARE_SWITCH := false; + MatchLineTerminator; +end; + +procedure TBasicParser.Parse_ExternalFunctionDeclaration(FunctionMl: TBasicModifierList); +var + SubId, NP, LibId, AliasId, SubNameId, TypeId: Integer; + S: String; +begin + DECLARE_SWITCH := true; + Match('Function'); + + SubId := Parse_Ident; + BeginSub(SubId); + Parse_CallConvention(SubId, true); + SetExternal(SubId, true); + + S := GetName(SubId); + SubNameId := NewConst(typeSTRING, S); + + DECLARE_SWITCH := false; + if not IsCurrText('Lib') then + Match('Lib') + else + ReadToken; + + if CurrToken.TokenClass = tcPCharConst then + begin + S := RemoveCh('"', CurrToken.Text); + LibId := NewConst(typeSTRING, S); + end + else + begin + LibId := Lookups(CurrToken.Text, LevelStack); + + if LibId = 0 then + RaiseError(errUndeclaredIdentifier, [CurrToken.Text]); + + if not IsStringConst(LibId) then + RaiseError(errIncompatibleTypesNoArgs, []); + end; + ReadToken; + + if IsCurrText('Alias') then + begin + ReadToken; + if CurrToken.TokenClass = tcPCharConst then + begin + S := RemoveCh('"', CurrToken.Text); + AliasId := NewConst(typeSTRING, S); + end + else + begin + AliasId := Lookups(CurrToken.Text, LevelStack); + + if AliasId = 0 then + RaiseError(errUndeclaredIdentifier, [CurrToken.Text]); + + if not IsStringConst(AliasId) then + RaiseError(errIncompatibleTypesNoArgs, []); + end; + SubNameId := AliasId; + ReadToken; + end; + + DECLARE_SWITCH := true; + if IsCurrText('(') then + NP := Parse_FormalParameterList(SubId) + else + NP := 0; + SetCount(SubId, NP); + DECLARE_SWITCH := false; + if IsCurrText('As') then + begin + Match('As'); + TypeID := Parse_Type; + end + else + begin + TestExplicitOff; + TypeId := typeVARIANT; + end; + Gen(OP_ASSIGN_TYPE, SubId, TypeID, 0); + Gen(OP_ASSIGN_TYPE, CurrResultId, TypeID, 0); + + EndSub(SubId); + RemoveSub; + + Gen(OP_LOAD_PROC, SubId, SubNameId, LibId); + + DECLARE_SWITCH := false; + MatchLineTerminator; +end; + +procedure TBasicParser.Parse_SubDeclaration(SubMl: TBasicModifierList); +var + SubId, NP: Integer; +begin + DECLARE_SWITCH := true; + Match('Sub'); + SubId := Parse_Ident; + BeginSub(SubId); + Parse_CallConvention(SubId, false); + + SetVisibility(SubId, cvPUBLIC); + if modPRIVATE in SubML then + SetVisibility(SubId, cvPRIVATE); + + if IsCurrText('(') then + NP := Parse_FormalParameterList(SubId) + else + NP := 0; + SetCount(SubId, NP); + SetName(CurrResultId, ''); + SetKind(CurrResultId, KindNONE); + Gen(OP_ASSIGN_TYPE, SubId, TypeVOID, 0); + Gen(OP_ASSIGN_TYPE, CurrResultId, TypeVOID, 0); + + InitSub(SubId); + DECLARE_SWITCH := false; + MatchLineTerminator; + Parse_Statements; + EndSub(SubId); + Match('End'); + Match('Sub'); + + DECLARE_SWITCH := false; + MatchLineTerminator; +end; + +procedure TBasicParser.Parse_FunctionDeclaration(FunctionMl: TBasicModifierList); +var + SubId, TypeId, NP: Integer; +begin + DECLARE_SWITCH := true; + Match('function'); + SubId := Parse_Ident; + BeginSub(SubId); + Parse_CallConvention(SubId, false); + + SetVisibility(SubId, cvPUBLIC); + if modPRIVATE in FunctionML then + SetVisibility(SubId, cvPRIVATE); + + SetName(CurrResultId, ''); + if IsCurrText('(') then + NP := Parse_FormalParameterList(SubId) + else + NP := 0; + SetCount(SubId, NP); + DECLARE_SWITCH := false; + if IsCurrText('As') then + begin + Match('As'); + TypeID := Parse_Type; + end + else + begin + TestExplicitOff; + TypeId := typeVARIANT; + end; + Gen(OP_ASSIGN_TYPE, SubId, TypeID, 0); + Gen(OP_ASSIGN_TYPE, CurrResultId, TypeID, 0); + + InitSub(SubId); + DECLARE_SWITCH := false; + MatchLineTerminator; + + Parse_Statements; + EndSub(SubId); + Match('End'); + Match('Function'); + MatchLineTerminator; + + DECLARE_SWITCH := false; +end; + +procedure TBasicParser.Parse_DelegateDeclaration(DelegateMl: TBasicModifierList); +var + SubId, TypeId, NP, DelegateTypeId: Integer; +begin + DECLARE_SWITCH := true; + Match('Delegate'); + if IsCurrText('Sub') then + Match('Sub') + else if IsCurrText('Function') then + Match('Function') + else + Match('Sub'); + DelegateTypeId := Parse_Ident; + SetKind(DelegateTypeId, KindTYPE); + + SubId := NewTempVar; + + BeginProceduralType(DelegateTypeId, SubId); + Parse_CallConvention(SubId, false); + SetName(CurrResultId, ''); + if IsCurrText('(') then + NP := Parse_FormalParameterList(SubId) + else + NP := 0; + SetCount(SubId, NP); + DECLARE_SWITCH := false; + if IsCurrText('As') then + begin + Match('As'); + TypeID := Parse_Type; + end + else + TypeId := typeVOID; + Gen(OP_ASSIGN_TYPE, SubId, TypeID, 0); + Gen(OP_ASSIGN_TYPE, CurrResultId, TypeID, 0); + EndProceduralType(DelegateTypeId); + + SetType(DelegateTypeId, typeEVENT); + + MatchLineTerminator; + + DECLARE_SWITCH := false; +end; + +procedure TBasicParser.Parse_PrintStmt; +var + ID, ID_L1, ID_L2: Integer; +begin + repeat + ID := Parse_Expression; + ID_L1 := 0; + ID_L2 := 0; + if IsCurrText(':') then + begin + Call_SCANNER; + ID_L1 := Parse_Expression; + end; + if IsCurrText(':') then + begin + Call_SCANNER; + ID_L2 := Parse_Expression; + end; + + Gen(OP_PRINT_EX, ID, ID_L1, ID_L2); + if NotMatch(',') then + Break; + until false; +end; + +procedure TBasicParser.Parse_PrintlnStmt; +begin + Parse_PrintStmt; +{$IFDEF PAXARM} + Gen(OP_PRINT_EX, NewConst(typeUNICSTRING, #13#10), 0, 0); +{$ELSE} + Gen(OP_PRINT_EX, NewConst(typeANSISTRING, #13#10), 0, 0); +{$ENDIF} +end; + +procedure TBasicParser.Parse_GotoStmt; +begin + Match('Goto'); + Gen(OP_GO, Parse_Label, 0, 0); + MatchStatementTerminator; +end; + +procedure TBasicParser.Parse_Block; +begin + DECLARE_SWITCH := false; + Parse_Statements; +end; + +procedure TBasicParser.Parse_IfStmt; +var + lg, lf, l1: Integer; +begin + Match('If'); + + lg := NewLabel; + lf := NewLabel; + + Gen(OP_GO_FALSE, lf, Parse_Expression, 0); + + if IsStatementTerminator then // block if statement + begin + MatchStatementTerminator; + + Parse_Block; + Gen(OP_GO, lg, 0, 0); + SetLabelHere(lf); + + while IsCurrText('ElseIf') do + begin + l1 := NewLabel(); + Match('ElseIf'); + Gen(OP_GO_FALSE, l1, Parse_Expression, 0); + + if IsCurrText('Then') then + Match('Then'); + + MatchStatementTerminator; + Parse_Block; + Gen(OP_GO, lg, 0, 0); + SetLabelHere(l1); + end; + + if IsCurrText('Else') then + begin + Match('Else'); + MatchStatementTerminator; + Parse_Block; + end; + + SetLabelHere(lg); + + Match('End'); + Match('If'); + MatchStatementTerminator; + end + else // line if statement + begin + Match('Then'); + + if not IsLineTerminator then + begin + Parse_Statement; + Gen(OP_GO, lg, 0, 0); + SetLabelHere(lf); + + if IsCurrText('Else') then + begin + Match('Else'); + Parse_Statements; + end; + + SetLabelHere(lg); + while IsLineTerminator do + MatchLineTerminator; + Exit; + end; + + + while IsLineTerminator do + MatchLineTerminator; + + SKIP_STATEMENT_TERMINATOR := true; + + Parse_Statements; + Gen(OP_GO, lg, 0, 0); + SetLabelHere(lf); + + while IsCurrText('ElseIf') do + begin + l1 := NewLabel(); + Match('ElseIf'); + Gen(OP_GO_FALSE, l1, Parse_Expression, 0); + + if IsCurrText('Then') then + Match('Then'); + + MatchStatementTerminator; + Parse_Block; + Gen(OP_GO, lg, 0, 0); + SetLabelHere(l1); + end; + + if IsCurrText('Else') then + begin + Match('Else'); + Parse_Statements; + end; + + SetLabelHere(lg); + if IsNextText('If') then + begin + Match('End'); + Match('If'); + MatchStatementTerminator; + end; + + SKIP_STATEMENT_TERMINATOR := false; + end; +end; + +procedure TBasicParser.Parse_SelectStmt; +var + lg, lf, id, expr1_id, cond_id, op: Integer; + lt: Integer; //new +begin + Match('Select'); + if IsCurrText('Case') then + Match('Case'); + + PushExitKind(ekSelect); + lg := NewLabel; + cond_id := NewTempVar; + BreakStack.Push(lg, lg); + + id := Parse_Expression; + MatchStatementTerminator; + + while IsCurrText('Case') do + begin + Match('Case'); + if not IsCurrText('Else') then // parse case statement + begin + lf := NewLabel; + lt := NewLabel; //new + + repeat // parse case clauses + // parse case clause + + if IsCurrText('Is') then + begin + Match('Is'); + + op := 0; + if IsCurrText('=') or + IsCurrText('<>') or + IsCurrText('>') or + IsCurrText('>=') or + IsCurrText('<') or + IsCurrText('<=') then + begin + op := CurrToken.Id; + Call_SCANNER; + end + else + Match('='); + + Gen(op, id, Parse_Expression, cond_id); + Gen(OP_GO_FALSE, lf, cond_id, 0); + Gen(OP_GO_TRUE, lt, cond_id, 0); //new + end + else + begin + expr1_id := Parse_Expression; + + if IsCurrText('To') then + begin + Gen(OP_GE, id, expr1_id, cond_id); + Gen(OP_GO_FALSE, lf, cond_id, 0); + Match('To'); + Gen(OP_LE, id, Parse_Expression, cond_id); + Gen(OP_GO_FALSE, lf, cond_id, 0); + Gen(OP_GO_TRUE, lt, cond_id, 0); //new + end + else + begin + Gen(OP_EQ, id, expr1_id, cond_id); +// Gen(OP_GO_FALSE, lf, cond_id, 0); //new + Gen(OP_GO_TRUE, lt, cond_id, 0); //new + end; + end; + + if NotMatch(',') then + begin + Gen(OP_GO, lf, 0, 0); //new + break; + end; + + until false; + + SetLabelHere(lt); + + MatchStatementTerminator; + Parse_Block; + Gen(OP_GO, lg, 0, 0); + SetLabelHere(lf); + end + else // parse case else statement + begin + Match('Else'); + MatchStatementTerminator; + Parse_Block; + end; + end; + + SetLabelHere(lg); + BreakStack.Pop; + PopExitKind; + + Match('End'); + Match('Select'); + MatchStatementTerminator; +end; + +procedure TBasicParser.Parse_WhileStmt; +var + lf, lg, l_loop: Integer; +begin + Match('While'); + PushExitKind(ekWhile); + + lf := NewLabel; + lg := NewLabel; + SetLabelHere(lg); + l_loop := lg; + Gen(OP_GO_FALSE, lf, Parse_Expression, 0); + MatchStatementTerminator; + BreakStack.Push(lf, l_loop); + ContinueStack.Push(lg, l_loop); + BeginLoop; + Parse_Block; + EndLoop; + BreakStack.Pop; + ContinueStack.Pop; + Gen(OP_GO, lg, 0, 0); + SetLabelHere(lf); + Match('End'); + Match('While'); + PopExitKind; + MatchStatementTerminator; +end; + +procedure TBasicParser.Parse_DoLoopStmt; +var + lf, lg, l_loop: Integer; +begin + Match('Do'); + PushExitKind(ekDo); + + lg := NewLabel; + lf := NewLabel; + SetLabelHere(lg); + l_loop := lg; + if IsCurrText('While') then + begin + Match('While'); + Gen(OP_GO_FALSE, lf, Parse_Expression, 0); + end + else if IsCurrText('Until') then + begin + Match('Until'); + Gen(OP_GO_TRUE, lf, Parse_Expression(), 0); + end; + MatchStatementTerminator; + + BreakStack.Push(lf, l_loop); + ContinueStack.Push(lg, l_loop); + BeginLoop; + Parse_Block; + EndLoop; + BreakStack.Pop; + ContinueStack.Pop; + + Match('Loop'); + if IsCurrText('While') then + begin + Match('While'); + Gen(OP_GO_TRUE, lg, Parse_Expression, 0); + end + else if IsCurrText('Until') then + begin + Match('Until'); + Gen(OP_GO_FALSE, lg, Parse_Expression, 0); + end + else + Gen(OP_GO, lg, 0, 0); + SetLabelHere(lf); + MatchStatementTerminator; + + PopExitKind; +end; + +procedure TBasicParser.Parse_ExitStmt; + +function GetExitLabel(ek: TExitKind; const AKeyword: String): Integer; +var + I: Integer; + S: String; +begin + result := 0; + if BreakStack.Count <> exit_kind_stack.Count then + RaiseError(errInternalError, []); + for I := exit_kind_stack.Count - 1 downto 0 do + if exit_kind_stack[I] = Integer(ek) then + begin + result := BreakStack[I].IntLabel; + Exit; + end; + ek := TExitKind(exit_kind_stack.Top); + case ek of + ekNone: S := ''; + ekDo: S := 'Do'; + ekFor: S := 'For'; + ekWhile: S := 'While'; + ekSelect: S := 'Select'; + ekSub: S := 'Sub'; + ekTry: S := 'Try'; + ekFunction: S := 'Function'; + end; + RaiseError(errTokenExpected, [S, AKeyword]); +end; + +var + L: Integer; +begin + Match('Exit'); +{$IFNDEF TAB} + if IsCurrText('Do') then + begin + Match('Do'); + L := GetExitLabel(ekDo, 'Do'); + Gen(OP_GO, L, 0, 0); + end + else if IsCurrText('For') then + begin + Match('For'); + L := GetExitLabel(ekFor, 'For'); + Gen(OP_GO, L, 0, 0); + end + else if IsCurrText('While') then + begin + Match('While'); + L := GetExitLabel(ekWhile, 'While'); + Gen(OP_GO, L, 0, 0); + end + else +{$ENDIF} + if IsCurrText('Select') then + begin + Match('Select'); + L := GetExitLabel(ekSelect, 'Select'); + Gen(OP_GO, L, 0, 0); + end + else if IsCurrText('Sub') then + begin + Match('Sub'); + Gen(OP_EXIT, SkipLabelStack.Top, 0, CurrLevel); + end + else if IsCurrText('Function') then + begin + Match('Function'); + Gen(OP_EXIT, SkipLabelStack.Top, 0, CurrLevel); + end + else if IsCurrText('Try') then + begin + Match('Try'); + L := GetExitLabel(ekTry, 'Try'); + Gen(OP_GO, L, 0, 0); + end + else if IsCurrText('else') then + begin + Gen(OP_EXIT, SkipLabelStack.Top, 0, CurrLevel); + Exit; + end + else + begin + Gen(OP_GO, BreakStack.TopLabel, 0, 0); + end; + if IsCurrText('else') then + Exit; + MatchStatementTerminator; +end; + +procedure TBasicParser.Parse_ContinueStmt; +begin + if ContinueStack.Count = 0 then + RaiseError(errBreakOrContinueOutsideOfLoop, []); + Match('Continue'); + if IsCurrText('(') then + begin + Match('('); + Match(')'); + end; + Gen(OP_GO, ContinueStack.TopLabel, 0, 0); + MatchStatementTerminator; +end; + +procedure TBasicParser.Parse_ThrowStmt; +begin + Match('Throw'); + if IsStatementTerminator then + Gen(OP_RAISE, 0, RaiseMode, 0) + else + begin + try + SignThrow := true; + Gen(OP_RAISE, Parse_Expression, RaiseMode, 0); + finally + SignThrow := false; + end; + end; + MatchStatementTerminator; +end; + +procedure TBasicParser.Parse_TryStmt; +var + l_try, l_finally, id, block_id, type_id, l_loop: Integer; + S: String; +begin + l_loop := NewLabel; + SetLabelHere(l_loop); + + Match('Try'); + PushExitKind(ekTry); + + MatchStatementTerminator(); + l_try := GenBeginTry; + BreakStack.Push(l_try, l_loop); + Parse_Block(); + + Gen(OP_EXCEPT_SEH, 0, 0, 0); + + l_finally := NewLabel; + Gen(OP_GO, l_finally, 0, 0); + + while IsCurrText('Catch') do + begin + Gen(OP_GO, l_try, 0, 0); + GenExcept; + //ExceptionBlock + + block_id := NewTempVar; + LevelStack.push(block_id); + Gen(OP_BEGIN_BLOCK, block_id, 0, 0); + + S := GetNextText; + if not ((PosCh(#13, S) > 0) or (Pos(#10, S) > 0)) then + DECLARE_SWITCH := true; + Call_SCANNER; + + if not IsStatementTerminator then + begin + id := Parse_Ident; + DECLARE_SWITCH := false; + Match('As'); + type_id := Parse_Ident; + Gen(OP_ASSIGN_TYPE, id, type_id, 0); + + GenExceptOn(type_id); + Gen(OP_ASSIGN, id, CurrExceptionObjectId, id); + end + else + begin + GenExceptOn(0); + end; + + Gen(OP_BEGIN_EXCEPT_BLOCK, 0, 0, 0); + MatchStatementTerminator(); + Parse_Block();// on catch + Gen(OP_END_EXCEPT_BLOCK, 0, 0, 0); + Gen(OP_GO, l_finally, 0, 0); + Gen(OP_END_BLOCK, block_id, 0, 0); + LevelStack.Pop; + end; + + SetLabelHere(l_finally); + + if IsCurrText('Finally') then + begin + GenFinally; + Call_SCANNER; + MatchStatementTerminator(); + Parse_Block(); + GenCondRaise; + end; + + SetLabelHere(l_try); + GenEndTry; + + Match('End'); + Match('Try'); + + BreakStack.Pop; + PopExitKind(); + + MatchStatementTerminator(); +end; + + +procedure TBasicParser.Parse_ForEachStmt; +var + lf, lg, lc, l_loop: Integer; + element_id, collection_id, enumerator_id, bool_id: Integer; + next_id: Integer; + r: TForLoopRec; +begin + l_loop := NewLabel; + SetLabelHere(l_loop); + PushExitKind(ekFor); + Match('For'); + Match('Each'); + Inc(ForEachCounter); + lf := NewLabel; + lg := NewLabel; + lc := NewLabel; + enumerator_id := NewTempVar; + bool_id := NewTempVar; + element_id := Parse_Ident; + Match('in'); + collection_id := Parse_Expression; + MatchLineTerminator; + + for_loop_stack.Push(element_id, 0, lg, lf, GetName(element_id)); + + Gen(OP_LOCK_VARRAY, collection_id, ForEachCounter, 0); + Gen(OP_GET_ENUMERATOR, collection_id, ForEachCounter, enumerator_id); + SetLabelHere(lg); + + Gen(OP_CURRENT, enumerator_id, ForEachCounter, element_id); + BreakStack.Push(lf, l_loop); + ContinueStack.Push(lc, l_loop); + BeginLoop; + repeat + if IsCurrText('Next') then + break; + if IsEOF then + break; + if for_loop_stack.Count = 0 then + break; + Parse_Statement; + until false; + EndLoop; + BreakStack.Pop; + ContinueStack.Pop; + + SetLabelHere(lc, ForEachCounter); + + Match('Next'); + if not IsStatementTerminator() then + begin + repeat + next_id := Parse_Expression; + r := for_loop_stack.Top; + if r.Name <> UpperCase(GetName(next_id)) then + RaiseError(errNextControlVariableDoesNotMatchForLoopControlVariable, [GetName(r.id)]); + + Gen(OP_MOVE_NEXT, r.id, ForEachCounter, bool_id); + Gen(OP_GO_FALSE, r.lf, bool_id, 0); + Gen(OP_GO, r.lg, 0, 0); + SetLabelHere(r.lf, 0, ForEachCounter); + + for_loop_stack.Pop; + + if NotMatch(',') then + break; + until false; + end + else + begin + + Gen(OP_MOVE_NEXT, element_id, ForEachCounter, bool_id); + Gen(OP_GO_FALSE, lf, bool_id, 0); + Gen(OP_GO, lg, 0, 0); + SetLabelHere(lf, 0, ForEachCounter); + + for_loop_stack.Pop; + end; + + Gen(OP_UNLOCK_VARRAY, collection_id, ForEachCounter, 0); + + MatchStatementTerminator(); + PopExitKind(); +end; + +procedure TBasicParser.Parse_ForNextStmt; +var + lf, lg, l_loop, id, limit_cond_id, step_id, next_id: Integer; + r: TForLoopRec; +begin + Match('For'); + PushExitKind(ekFor); + + lg := NewLabel; + lf := NewLabel; + limit_cond_id := NewTempVar; + + id := Parse_Ident; + Match('='); + Gen(OP_ASSIGN, id, Parse_Expression, id); + SetLabelHere(lg); + + l_loop := lg; + + Match('To'); + Gen(OP_LE, id, Parse_Expression, limit_cond_id); + Gen(OP_GO_FALSE, lf, limit_cond_id, 0); + + if IsCurrText('Step') then + begin + Match('Step'); + step_id := Parse_Expression; + end + else + step_id := NewConst(typeINTEGER, 1); + + MatchStatementTerminator; + + for_loop_stack.Push(id, step_id, lg, lf, GetName(id)); + BreakStack.Push(lf, l_loop); + ContinueStack.Push(lg, l_loop); + + BeginLoop; + repeat + if IsCurrText('Next') then + break; + if IsEOF then + break; + if for_loop_stack.Count = 0 then + break; + Parse_Statement; + until false; + EndLoop; + + BreakStack.Pop(); + ContinueStack.Pop(); + + if for_loop_stack.Count = 0 then + begin + SetLabelHere(lf); + Exit; + end; + + Match('Next'); + if not IsStatementTerminator() then + begin + repeat + next_id := Parse_Expression; + r := for_loop_stack.Top; + if r.Name <> UpperCase(GetName(next_id)) then + RaiseError(errNextControlVariableDoesNotMatchForLoopControlVariable, [GetName(r.id)]); + + Gen(OP_PLUS, r.id, r.step_id, r.id); + Gen(OP_GO, r.lg, 0, 0); + SetLabelHere(r.lf); + + for_loop_stack.Pop; + + if NotMatch(',') then + break; + until false; + end + else + begin + Gen(OP_PLUS, id, step_id, id); + Gen(OP_GO, lg, 0, 0); + SetLabelHere(lf); + for_loop_stack.Pop; + end; + + PopExitKind(); + + MatchStatementTerminator(); +end; + +procedure TBasicParser.Parse_WithStmt; +var + Id: Integer; +begin + Match('With'); + Id := Parse_Expression; + with_stack.Push(Id); + Gen(OP_BEGIN_WITH, id, 0, 0); + MatchStatementTerminator; + if not IsCurrText('End') then + Parse_Block; + Gen(OP_END_WITH, id, 0, 0); + with_stack.Pop; + Match('End'); + Match('With'); + MatchStatementTerminator; +end; + +procedure TBasicParser.Parse_ReturnStmt; +begin + Match('Return'); + if not IsStatementTerminator then + Gen(OP_ASSIGN, CurrResultId, Parse_Expression, CurrResultId); + //Gen(OP_GO, SkipLabelStack.Top, 0, 0); + Gen(OP_EXIT, SkipLabelStack.Top, 0, CurrLevel); + MatchStatementTerminator; +end; + +function TBasicParser.IsAssignment_operator(const S: String): Boolean; +begin + if S = '=' then + result := true + else if S = '*=' then + result := true + else if S = '/=' then + result := true + else if S = '%=' then + result := true + else if S = '+=' then + result := true + else if S = '-=' then + result := true + else if S = '<<=' then + result := true + else if S = '>>=' then + result := true + else if S = '>>>=' then + result := true + else if S = '&=' then + result := true + else if S = '^=' then + result := true + else if S = '|=' then + result := true + else + result := false; +end; + +procedure TBasicParser.Parse_AssignmentStmt; +var + LeftID, SubId, L, I, TempId, P: Integer; + SubName: String; + R: TCodeRec; + IsCall: Boolean; +begin + if EXPLICIT_OFF then + begin + R := LastEvalRec(CurrToken.Id); + if R <> nil then + if IsAssignment_operator(GetNextText) then + begin + if WithStack.Count = 0 then + begin + SetKind(R.Res, KindVAR); + R.Op := OP_NOP; + end; + end; + end; + + if IsCurrText('SetLength') then + begin + Call_SCANNER; + Match('('); + LeftID := Parse_Designator; + Call_SCANNER; + Gen(OP_SET_LENGTH, LeftID, Parse_Expression, 0); + Match(')'); + MatchStatementTerminator; + Exit; + end + else if IsCurrText('pause') then + begin + Call_SCANNER; + if IsCurrText('(') then + begin + Match('('); + Match(')'); + end; + L := NewLabel; + Gen(OP_PAUSE, L, 0, 0); + SetLabelHere(L); + MatchStatementTerminator; + Exit; + end + else if IsCurrText('halt') or IsCurrText('abort') then + begin + Call_SCANNER; + if IsCurrText('(') then + begin + Match('('); + if not IsCurrText(')') then + begin + Gen(OP_HALT, Parse_ConstantExpression, 0, 0); + end + else + Gen(OP_HALT, NewConst(typeINTEGER, 0), 0, 0); + Match(')'); + end + else + Gen(OP_HALT, NewConst(typeINTEGER, 0), 0, 0); + MatchStatementTerminator; + Exit; + end; + + if IsCurrText('MyClass') then + begin + Call_SCANNER; + Match('.'); + LeftID := Parse_Ident; + Gen(OP_MYCLASS, LeftId, 0, 0); + end + else if IsCurrText('MyBase') then + begin + Call_SCANNER; + Match('.'); + LeftId := NewTempVar; + if IsLineTerminator then + begin + SubId := CurrLevel; + L := NewTempVar; + SetName(L, GetName(SubId)); + Gen(OP_EVAL, 0, 0, L); + Gen(OP_EVAL_INHERITED, L, 0, LeftId); + for I:=0 to GetCount(SubId) - 1 do + Gen(OP_PUSH, GetParamId(SubId, I), I, LeftId); + Gen(OP_CALL_INHERITED, LeftID, 0, 0); + end + else + begin + if GetName(CurrSubId) = '' then + begin + if IsCurrText('New') then + Gen(OP_PUSH_INSTANCE, CurrSelfId, 0, LeftId); +// else if GetSymbolRec(CurrSubId).Kind = KindCONSTRUCTOR then +// Gen(OP_PUSH_INSTANCE, CurrSelfId, 0, LeftId); + + Gen(OP_EVAL_INHERITED, CurrSubId, 0, LeftId); + Call_SCANNER; + end + else + begin + L := Parse_Ident; + Gen(OP_EVAL_INHERITED, L, 0, LeftId); + end; + + if IsCurrText('(') then + Gen(OP_CALL_INHERITED, LeftID, Parse_ArgumentList(LeftId), 0) + else + Gen(OP_CALL_INHERITED, LeftID, 0, 0); + end; + if GetKind(CurrSubId) = kindCONSTRUCTOR then + begin + Gen(OP_RESTORE_EDX, 0, 0, 0); + + L := NewLabel; + Gen(OP_GO_DL, L, 0, 0); + Gen(OP_ONCREATE_OBJECT, CurrSelfId, 0, 0); + SetLabelHere(L); + + Gen(OP_SAVE_EDX, 0, 0, 0); + + WasInherited := true; + end; + MatchStatementTerminator; + Exit; + end + else + LeftID := Parse_Designator; + + SubName := GetName(CurrSubId); + P := Pos('__get', SubName); + if P = 1 then + SubName := Copy(SubName, 6, Length(SubName) - 5) + else + begin + P := Pos('__set', SubName); + if P = 1 then + SubName := Copy(SubName, 6, Length(SubName) - 5) + end; + + if (GetName(LeftId) <> '') and StrEql(GetName(LeftId), SubName) then + begin + if GetCodeRec(CodeCard).Op = OP_EVAL then + if StrEql(GetName(LeftId), GetName(GetCodeRec(CodeCard).Res)) then + GetCodeRec(CodeCard).Op := OP_NOP; + + LeftId := CurrResultId; + end; + + R := LastCodeRec; + IsCall := R.Op = OP_CALL; + + Gen(OP_LVALUE, LeftId, 0, 0); + + if IsCurrText('=') then + begin + Call_SCANNER; + Gen(OP_ASSIGN, LeftID, Parse_Expression, LeftID); + end + else if IsCurrText('+=') then + begin + TempId := NewTempVar; + Call_SCANNER; + Gen(OP_PLUS, LeftID, Parse_Expression, TempId); + Gen(OP_ASSIGN, LeftID, TempId, LeftId); + end + else if IsCurrText('-=') then + begin + TempId := NewTempVar; + Call_SCANNER; + Gen(OP_MINUS, LeftID, Parse_Expression, TempId); + Gen(OP_ASSIGN, LeftID, TempId, LeftId); + end + else if IsCurrText('*=') then + begin + TempId := NewTempVar; + Call_SCANNER; + Gen(OP_MULT, LeftID, Parse_Expression, TempId); + Gen(OP_ASSIGN, LeftID, TempId, LeftId); + end + else if IsCurrText('/=') then + begin + TempId := NewTempVar; + Call_SCANNER; + Gen(OP_DIV, LeftID, Parse_Expression, TempId); + Gen(OP_ASSIGN, LeftID, TempId, LeftId); + end + else if IsCurrText('\=') then + begin + TempId := NewTempVar; + Call_SCANNER; + Gen(OP_IDIV, LeftID, Parse_Expression, TempId); + Gen(OP_ASSIGN, LeftID, TempId, LeftId); + end + else if IsCurrText('(') then + begin + SubId := LeftId; + R := Gen(OP_CALL, SubId, Parse_ArgumentList(SubId), 0); + + if IsCurrText('=') then + begin + LeftId := NewTempVar; + R.Res := LeftId; + Call_SCANNER; + Gen(OP_ASSIGN, LeftID, Parse_Expression, LeftID); + end; + end + else + begin + if not IsCall then + Gen(OP_CALL, LeftID, 0, 0); + end; + + if IsStatementTerminator then + MatchStatementTerminator + else if IsCurrText('else') then + Exit + else + begin + if (LastCodeRec.Op = OP_CALL) and (LastCodeRec.Arg1 = LeftId) then + LastCodeRec.Op := OP_NOP; + + SubId := LeftId; + LeftId := NewTempVar; + Gen(OP_CHECK_SUB_CALL, SubId, 0, 0); + Gen(OP_CALL, SubId, Parse_ArgumentList(SubId, false), LeftId); + MatchStatementTerminator; + end; +end; + +procedure TBasicParser.Parse_DimStmt(DimMl: TBasicModifierList); +var + ID, TypeID, + ExprID, ArrayTypeId, LengthId, + L, TempId, I, ClassTypeId: Integer; + IsArray, IsDynArray, IsFWArray: Boolean; + Lst: TIntegerList; +begin + Lst := TIntegerList.Create; + + try + DECLARE_SWITCH := true; + if IsCurrText('Dim') then + Match('Dim'); + + L := CurrLevel; + if L > 0 then + if GetKind(L) in KindSUBS then + L := -1; + + IsDynArray := false; + IsFWArray := false; + + repeat + ID := Parse_Ident; + SetVisibility(Id, cvPUBLIC); + if modPRIVATE in DimML then + SetVisibility(Id, cvPRIVATE); + + Gen(OP_DECLARE_LOCAL_VAR, CurrLevel, ID, 0); + DECLARE_SWITCH := false; + + Lst.Clear; + if IsCurrText('(') then + begin + Match('('); + if IsCurrText(')') then + begin + ExprID := NewConst(typeINTEGER, 0); + Lst.Add(ExprID); + end + else + begin + repeat + ExprID := Parse_Expression; + Lst.Add(ExprId); + if NotMatch(',') then + break; + until false; + end; + Match(')'); + IsArray := true; + IsFWArray := UseFWArrays; + end + else if IsCurrText('[') then + begin + Match('['); + if IsCurrText(']') then + begin + ExprID := NewConst(typeINTEGER, 0); + Lst.Add(ExprID); + end + else + begin + repeat + ExprID := Parse_Expression; + Lst.Add(ExprId); + if NotMatch(',') then + break; + until false; + end; + Match(']'); + IsArray := true; + IsDynArray := true; + end + else + begin + IsArray := false; + ExprId := 0; + end; + + if IsCurrText('As') then + begin + DECLARE_SWITCH := false; + Match('As'); +{$IFNDEF TAB} + if IsCurrText('New') then + begin + Match('New'); + + TypeId := Parse_QualId; + if IsCurrText('(') then + begin + TempId := NewTempVar; + ExprId := NewTempVar; + Gen(OP_EVAL_CONSTRUCTOR, TypeId, 0, TempId); + Gen(OP_CALL, TempId, Parse_ArgumentList(TempId), ExprId); + end + else + begin + TempId := NewTempVar; + ExprId := NewTempVar; + Gen(OP_EVAL_CONSTRUCTOR, TypeId, 0, TempId); + Gen(OP_CALL, TempId, 0, ExprId); + end; + + if L >= 0 then + if ParsesModuleBody and (not IsArray) then + Gen(OP_BEGIN_INIT_CONST, ID, 0, 0); + + Gen(OP_ASSIGN, ID, ExprID, ID); + + GenAssignOuterInstance(Id, TypeId); + + if L >= 0 then + if ParsesModuleBody and (not IsArray) then + Gen(OP_END_INIT_CONST, ID, 0, 0); + + DECLARE_SWITCH := true; + + if NotMatch(',') then + break + else + continue; + end + else +{$ENDIF} + TypeID := Parse_Type; + end + else + begin + TestExplicitOff; + TypeId := typeVARIANT; + end; + + if IsArray then + begin + if IsDynArray or IsFWArray then + begin + ArrayTypeId := typeVARIANT; + for I :=0 to Lst.Count - 1 do + begin + ArrayTypeId := NewTempVar; + BeginDynamicArrayType(ArrayTypeID); + Gen(OP_CREATE_DYNAMIC_ARRAY_TYPE, ArrayTypeId, TypeID, 0); + EndDynamicArrayType(ArrayTypeID); + TypeId := ArrayTypeId; + end; + Gen(OP_ADD_TYPEINFO, ArrayTypeId, 0, 0); + end + else + ArrayTypeId := typeVARIANT; + + ClassTypeId := 0; + if IsFWArray then + begin + ClassTypeId := NewTempVar; + SetName(ClassTypeId, 'FWArray_' + IntToStr(ClassTypeId)); + BeginClassType(ClassTypeID); + SetAncestorId(ClassTypeId, H_TFW_Array); + EndClassType(ClassTypeId); + + SetType(ID, ClassTypeId); + Gen(OP_ADD_TYPEINFO, ClassTypeId, 0, 0); + + SetPatternId(ClassTypeId, ArrayTypeId); + end + else + Gen(OP_ASSIGN_TYPE, ID, ArrayTypeId, 0); + +{ + if L >= 0 then + begin + lab := NewLabel; + Gen(OP_GO, lab, 0, 0); + Gen(OP_BEGIN_INIT_CONST, ID, 0, 0); + end; +} + if (Lst.Count = 1) and (not IsFWArray) then + begin + LengthId := NewTempVar(typeINTEGER); + Gen(OP_PLUS, ExprId, NewConst(typeINTEGER, 1), LengthId); + Gen(OP_SET_LENGTH, ID, LengthId, 0); + end + else + begin + if IsFWArray then + begin + Gen(OP_PUSH_CLASSREF, ClassTypeId, 0, Id_FWArray_Create); + Gen(OP_CALL, Id_FWArray_Create, 0, ID); + Gen(OP_ASSIGN_PROG, 0, 0, Id); + Gen(OP_INIT_FWARRAY, Id, Lst.Count, 0); + end; + for I := 0 to Lst.Count - 1 do + begin + ExprId := Lst[I]; + LengthId := NewTempVar(typeINTEGER); + Gen(OP_PLUS, ExprId, NewConst(typeINTEGER, 1), LengthId); + Gen(OP_PUSH_LENGTH, LengthId, 0, 0); + end; + Gen(OP_SET_LENGTH_EX, ID, Lst.Count, 0); + end; +{ + if L >= 0 then + begin + Gen(OP_END_INIT_CONST, ID, 0, 0); + SetLabelHere(lab); + end; +} + end + else + Gen(OP_ASSIGN_TYPE, ID, TypeID, 0); + + if IsCurrText('=') then + begin + DECLARE_SWITCH := false; + Match('='); + + if L >= 0 then + if ParsesModuleBody and (not IsArray) then + Gen(OP_BEGIN_INIT_CONST, ID, 0, 0); + + ExprID := Parse_Expression; + Gen(OP_ASSIGN, ID, ExprID, ID); + + if L >= 0 then + if ParsesModuleBody and (not IsArray) then + Gen(OP_END_INIT_CONST, ID, 0, 0); + end + else if not IsArray then + Gen(OP_CALL_DEFAULT_CONSTRUCTOR, ID, 0, 0); + + DECLARE_SWITCH := true; + + if NotMatch(',') then + break; + until false; + + DECLARE_SWITCH := false; + MatchStatementTerminator; + + finally + FreeAndNil(Lst); + end; +end; + +procedure TBasicParser.Parse_ReDimStmt; +var + ID, ExprID, LengthId, I: Integer; + Lst: TIntegerList; +begin + Lst := TIntegerList.Create; + + try + DECLARE_SWITCH := false; + Match('ReDim'); + + repeat + ID := Parse_Ident; + Gen(OP_DECLARE_LOCAL_VAR, CurrLevel, ID, 0); + DECLARE_SWITCH := false; + + Lst.Clear; + if IsCurrText('(') then + begin + Match('('); + if IsCurrText(')') then + begin + ExprID := NewConst(typeINTEGER, 0); + Lst.Add(ExprID); + end + else + begin + repeat + ExprID := Parse_Expression; + if IsCurrText('To') then + begin + Match('To'); + ExprID := Parse_Expression; + end; + Lst.Add(ExprId); + if NotMatch(',') then + break; + until false; + end; + Match(')'); + end + else if IsCurrText('[') then + begin + Match('['); + if IsCurrText(']') then + begin + ExprID := NewConst(typeINTEGER, 0); + Lst.Add(ExprID); + end + else + begin + repeat + ExprID := Parse_Expression; + Lst.Add(ExprId); + if NotMatch(',') then + break; + until false; + end; + Match(']'); + end + else + Match('('); + + if Lst.Count = 1 then + begin + ExprId := Lst[0]; + LengthId := NewTempVar(typeINTEGER); + Gen(OP_PLUS, ExprId, NewConst(typeINTEGER, 1), LengthId); + Gen(OP_SET_LENGTH, ID, LengthId, 0); + end + else + begin + for I := 0 to Lst.Count - 1 do + begin + ExprId := Lst[I]; + LengthId := NewTempVar(typeINTEGER); + Gen(OP_PLUS, ExprId, NewConst(typeINTEGER, 1), LengthId); + Gen(OP_PUSH_LENGTH, LengthId, 0, 0); + end; + Gen(OP_SET_LENGTH_EX, ID, Lst.Count, 0); + end; + + if NotMatch(',') then + break; + until false; + + DECLARE_SWITCH := false; + MatchStatementTerminator; + + finally + FreeAndNil(Lst); + end; +end; + + +procedure TBasicParser.Parse_ConstStmt; +var + ID: Integer; +begin + DECLARE_SWITCH := true; + Match('const'); + + repeat + ID := Parse_Ident; + Gen(OP_DECLARE_LOCAL_VAR, CurrLevel, ID, 0); + SetKind(ID, kindCONST); + DECLARE_SWITCH := false; + if IsCurrText('As') then + begin + Match('As'); + Gen(OP_ASSIGN_TYPE, ID, Parse_Type, 0); + end; + Match('='); + Gen(OP_ASSIGN_CONST, ID, Parse_ConstantExpression, ID); + DECLARE_SWITCH := true; + + if NotMatch(',') then + break; + until false; + + DECLARE_SWITCH := false; + MatchStatementTerminator; +end; + +function TBasicParser.Parse_ArgumentList(SubId: Integer; HasParenthesis: Boolean = true): Integer; +var + I: Integer; + L: TIntegerList; +begin + L := TIntegerList.Create; + try + if HasParenthesis then + Match('('); + result := 0; + if (not IsCurrText(')')) then + begin + repeat + Inc(result); + L.Add(Parse_Expression); + if NotMatch(',') then + Break; + until false; + end; + + for I:=0 to L.Count - 1 do + Gen(OP_PUSH, L[I], I, SubID); + + if HasParenthesis then + Match(')'); + finally + FreeAndNil(L); + end; +end; + +function TBasicParser.Parse_ArrayLiteral(ch1, ch2: Char): Integer; +var + elem_id, K: Integer; + R: TCodeRec; + IsFWArray: Boolean; +begin + IsFWArray := false; + + Match(ch1); + K := 0; + result := NewTempVar; + Gen(OP_DECLARE_LOCAL_VAR, GetLevel(result), result, 0); + + if ch1 = '[' then + Gen(OP_DETERMINE_TYPE, result, 0, 0) + else + begin + if UseFWArrays then + begin + Gen(OP_DETERMINE_TYPE, result, 0, 0); + IsFWArray := true; + end + else + SetType(result, typeVARIANT); + end; + + if IsFWArray then + begin + Gen(OP_PUSH_CLASSREF, 0, 0, Id_FWArray_Create); // will be determined later + Gen(OP_CALL, Id_FWArray_Create, 0, result); + R := Gen(OP_PUSH_LENGTH, 0, 0, 0); + Gen(OP_SET_LENGTH_EX, result, 1, 0); + SetName(result, '@'); + end + else + R := Gen(OP_SET_LENGTH, result, 0, 0); + + repeat + while IsLineTerminator do + MatchLineTerminator; + if IsCurrText(ch2) then + break + else + begin + elem_id := NewTempVar; + Gen(OP_ELEM, result, NewConst(typeINTEGER, K), elem_id); + Gen(OP_ASSIGN, elem_id, Parse_Expression, elem_id); + end; + if NotMatch(',') then + Break + else + Inc(K); + until false; + Match(ch2); + + if IsFWArray then + R.Arg1 := NewConst(typeINTEGER, K + 1) + else + R.Arg2 := NewConst(typeINTEGER, K + 1); +end; + +function TBasicParser.Parse_Expression: Integer; +var + Id: Integer; +begin + if IsCurrText('TypeOf') then + begin + Match('TypeOf'); + Id := Parse_Expression; + Match('Is'); + result := NewTempVar; + Gen(OP_IS, Id, Parse_Type, result); + end +{$IFNDEF TAB} + else if IsCurrText('Sub') then + begin + result := Parse_AnonymousSub; + end + else if IsCurrText('Function') then + begin + result := Parse_AnonymousFunction; + end + else if IsCurrText('Lambda') then + begin + result := Parse_LambdaExpression; + end +{$ENDIF} + else + result := Parse_LogicalXORExpression; +end; + +function TBasicParser.Parse_AnonymousFunction: Integer; +begin + result := Parse_AnonymousRoutine(true); +end; + +function TBasicParser.Parse_AnonymousSub: Integer; +begin + result := Parse_AnonymousRoutine(false); +end; + +function TBasicParser.Parse_AnonymousRoutine(IsFunc: Boolean): Integer; +var + I, Id, RefId, ClassId, SubId, ResTypeId: Integer; + ClsName, ObjName: String; +begin + NewAnonymousNames(ClsName, ObjName); + GenComment('BEGIN OF ANONYMOUS CLASS ' + ClsName); + + TypeParams.Clear; + + ClassId := NewTempVar; + SetName(ClassId, ClsName); + BeginClassType(ClassId); + SetPacked(ClassId); + SetAncestorId(ClassId, H_TInterfacedObject); +// Gen(OP_ADD_INTERFACE, ClassId, 0, 0); // 0 - anonymous + + GenDefaultClassConstructor(ClassId, nil); + GenDefaultClassDestructor(ClassId); + + DECLARE_SWITCH := true; + if IsFunc then + Match('Function') + else + Match('Sub'); + + DECLARE_SWITCH := false; + + SubId := NewTempVar; + SetName(SubId, ANONYMOUS_METHOD_NAME); + BeginClassMethod(SubId, + ClassId, + IsFunc, // has result + false, // is shared + true); // is implementation + + Parse_FormalParameterList(SubId); + DECLARE_SWITCH := false; + if IsFunc then + begin + Match('As'); + ResTypeId := Parse_Type; + Gen(OP_ASSIGN_TYPE, SubId, ResTypeId, 0); + Gen(OP_ASSIGN_TYPE, CurrResultId, ResTypeId, 0); + end; + + DECLARE_SWITCH := false; + + AnonymStack.Push(SubId); + try + InitSub(SubId); + SetName(CurrSelfId, 'Me'); + Gen(OP_BEGIN_WITH, CurrSelfId, 0, 0); + WithStack.Push(CurrSelfId); + Gen(OP_STMT, 0, 0, 0); + MatchLineTerminator; + Parse_Statements; + Gen(OP_END_WITH, WithStack.Top, 0, 0); + WithStack.Pop; + EndSub(SubId); + + for I := 0 to AnonymStack.Top.BindList.Count - 1 do + begin + Id := NewTempVar; + SetName(Id, GetName(AnonymStack.Top.BindList[I])); + SetLevel(Id, ClassId); + SetKind(Id, KindTYPE_FIELD); + SetVisibility(Id, cvPublic); + Gen(OP_ASSIGN_THE_SAME_TYPE, Id, AnonymStack.Top.BindList[I], 0); + end; + + EndClassType(ClassId); + GenComment('END OF ANONYMOUS CLASS ' + ClsName); + Gen(OP_ADD_TYPEINFO, ClassId, 0, 0); + + result := NewTempVar; + Gen(OP_DECLARE_LOCAL_VAR, CurrSubId, result, 0); + SetName(result, ObjName); + SetType(result, ClassId); + + RefId := NewField('Create', result); + Gen(OP_FIELD, ClassId, RefId, RefId); + Gen(OP_ASSIGN, result, RefId, result); + + for I := 0 to AnonymStack.Top.BindList.Count - 1 do + begin + RefId := NewField(GetName(AnonymStack.Top.BindList[I]), result); + Gen(OP_FIELD, result, RefId, RefId); + Gen(OP_ASSIGN, RefId, AnonymStack.Top.BindList[I], RefId); + end; + finally + AnonymStack.Pop; + end; + Gen(OP_ADD_INTERFACE, ClassId, 0, 0); // 0 - anonymous + Match('End'); + if IsFunc then + Match('Function') + else + Match('Sub'); +end; + +function TBasicParser.Parse_LambdaExpression: Integer; +var + I, Id, RefId, ClassId, SubId: Integer; + ClsName, ObjName: String; +begin + NewAnonymousNames(ClsName, ObjName); + GenComment('BEGIN OF ANONYMOUS CLASS ' + ClsName); + + TypeParams.Clear; + + ClassId := NewTempVar; + SetName(ClassId, ClsName); + BeginClassType(ClassId); + SetPacked(ClassId); + SetAncestorId(ClassId, H_TInterfacedObject); + + GenDefaultClassConstructor(ClassId, nil); + GenDefaultClassDestructor(ClassId); + + SubId := NewTempVar; + Gen(OP_ASSIGN_LAMBDA_TYPES, SubId, 0, 0); + + SetName(SubId, ANONYMOUS_METHOD_NAME); + BeginClassMethod(SubId, + ClassId, + true, // has result + false, // is shared + true); // is implementation + + DECLARE_SWITCH := true; + Match('lambda'); + + Parse_LambdaParameters(SubId); + DECLARE_SWITCH := false; + + Match('=>'); + + AnonymStack.Push(SubId); + try + InitSub(SubId); + Gen(OP_BEGIN_WITH, CurrSelfId, 0, 0); + WithStack.Push(CurrSelfId); + Id := CurrResultId; + Gen(OP_ASSIGN, Id, Parse_Expression, Id); + Gen(OP_END_WITH, WithStack.Top, 0, 0); + WithStack.Pop; + EndSub(SubId); + + for I := 0 to AnonymStack.Top.BindList.Count - 1 do + begin + Id := NewTempVar; + SetName(Id, GetName(AnonymStack.Top.BindList[I])); + SetLevel(Id, ClassId); + SetKind(Id, KindTYPE_FIELD); + SetVisibility(Id, cvPublic); + Gen(OP_ASSIGN_THE_SAME_TYPE, Id, AnonymStack.Top.BindList[I], 0); + end; + EndClassType(ClassId); + GenComment('END OF ANONYMOUS CLASS ' + ClsName); + Gen(OP_ADD_TYPEINFO, ClassId, 0, 0); + + result := NewTempVar; + Gen(OP_DECLARE_LOCAL_VAR, CurrSubId, result, 0); + SetName(result, ObjName); + SetType(result, ClassId); + + RefId := NewField('Create', result); + Gen(OP_FIELD, ClassId, RefId, RefId); + Gen(OP_ASSIGN, result, RefId, result); + + for I := 0 to AnonymStack.Top.BindList.Count - 1 do + begin + RefId := NewField(GetName(AnonymStack.Top.BindList[I]), result); + Gen(OP_FIELD, result, RefId, RefId); + Gen(OP_ASSIGN, RefId, AnonymStack.Top.BindList[I], RefId); + end; + finally + AnonymStack.Pop; + end; + + Gen(OP_ASSIGN_LAMBDA_TYPES, SubId, ClassId, result); +end; + +function TBasicParser.Parse_LambdaParameters(SubId: Integer) : Integer; +var + ID: Integer; +begin + result := 0; + + if not IsCurrText('(') then + repeat + Inc(result); + ID := Parse_FormalParameter; + Gen(OP_DECLARE_LOCAL_VAR, SubId, ID, 0); + SetCount(SubId, result); + if NotMatch(',') then + Exit; + until false; + + Match('('); + if IsCurrText(')') then + begin + Match(')'); + SetCount(SubId, result); + Exit; + end; + + repeat + Inc(result); + ID := Parse_FormalParameter; + Gen(OP_DECLARE_LOCAL_VAR, SubId, ID, 0); + if NotMatch(',') then + break; + until false; + + Match(')'); + SetCount(SubId, result); +end; + +function TBasicParser.Parse_ConstantExpression: Integer; +begin + result := Parse_Expression; +end; + +function TBasicParser.Parse_LogicalXORExpression: Integer; +begin + result := Parse_LogicalORExpression; + while IsCurrText('Xor') do + begin + Call_SCANNER(); + result := BinOp(OP_XOR, result, Parse_LogicalORExpression); + end; +end; + +function TBasicParser.Parse_LogicalORExpression: Integer; +var + id, lt: Integer; +begin + result := Parse_LogicalANDExpression; + while IsCurrText('Or') or IsCurrText('OrElse') do + begin + if IsCurrText('Or') then + begin + Call_SCANNER(); + result := BinOp(OP_OR, result, Parse_LogicalANDExpression); + end + else + begin + id := result; + lt := NewLabel; + result := NewTempVar; + Gen(OP_ASSIGN, result, id, result); + Gen(OP_GO_TRUE, lt, result, 0); + Call_SCANNER; + Gen(OP_ASSIGN, result, Parse_LogicalANDExpression, result); + SetLabelHere(lt); + end; + end; +end; + +function TBasicParser.Parse_LogicalANDExpression: Integer; +var + id, lf: Integer; +begin + result := Parse_RelationalExpression; + while IsCurrText('And') or IsCurrText('AndAlso') do + begin + if IsCurrText('And') then + begin + Call_SCANNER; + result := BinOp(OP_AND, result, Parse_RelationalExpression); + end + else + begin + id := result; + lf := NewLabel; + result := NewTempVar; + Gen(OP_ASSIGN, result, id, result); + Gen(OP_GO_FALSE, lf, result, 0); + Call_SCANNER; + Gen(OP_ASSIGN, result, Parse_RelationalExpression, result); + SetLabelHere(lf); + end; + end; +end; + +function TBasicParser.Parse_RelationalExpression: Integer; +begin + result := Parse_ShiftExpression; + while IsCurrText('=') or IsCurrText('<>') or + IsCurrText('>') or IsCurrText('>=') or + IsCurrText('<') or IsCurrText('<=') do + begin + if IsCurrText('=') then + begin + Call_SCANNER; + result := BinOp(OP_EQ, result, Parse_ShiftExpression); + end + else if IsCurrText('<>') then + begin + Call_SCANNER; + result := BinOp(OP_NE, result, Parse_ShiftExpression); + end + else if IsCurrText('>') then + begin + Call_SCANNER; + result := BinOp(OP_GT, result, Parse_ShiftExpression); + end + else if IsCurrText('>=') then + begin + Call_SCANNER; + result := BinOp(OP_GE, result, Parse_ShiftExpression); + end + else if IsCurrText('<') then + begin + Call_SCANNER; + result := BinOp(OP_LT, result, Parse_ShiftExpression); + end + else if IsCurrText('<=') then + begin + Call_SCANNER; + result := BinOp(OP_LE, result, Parse_ShiftExpression); + end; + end +end; + +function TBasicParser.Parse_ShiftExpression: Integer; +begin + result := Parse_ConcatenationExpression; + while IsCurrText('<<') or IsCurrText('>>') do + begin + if IsCurrText('<<') then + begin + Call_SCANNER; + result := BinOp(OP_SHL, result, Parse_ConcatenationExpression); + end + else + begin + Call_SCANNER; + result := BinOp(OP_SHR, result, Parse_ConcatenationExpression); + end; + end; +end; + +function TBasicParser.Parse_ConcatenationExpression: Integer; +begin + result := Parse_AdditiveExpression; + while IsCurrText('&') do + begin + Call_SCANNER; + result := BinOp(OP_PLUS, result, Parse_AdditiveExpression); + end; +end; + +function TBasicParser.Parse_AdditiveExpression: Integer; +begin + result := Parse_ModulusExpression; + while IsCurrText('+') or IsCurrText('-') do + begin + if IsCurrText('+') then + begin + Call_SCANNER(); + result := BinOp(OP_PLUS, result, Parse_ModulusExpression); + end + else + begin + Call_SCANNER; + result := BinOp(OP_MINUS, result, Parse_ModulusExpression); + end; + end; +end; + +function TBasicParser.Parse_ModulusExpression: Integer; +begin + result := Parse_IntegerDivisionExpression; + while IsCurrText('Mod') do + begin + Call_SCANNER; + result := BinOp(OP_MOD, result, Parse_IntegerDivisionExpression); + end; +end; + +function TBasicParser.Parse_IntegerDivisionExpression: Integer; +begin + result := Parse_MultiplicativeExpression; + while IsCurrText('\') do + begin + Call_SCANNER; + result := BinOp(OP_IDIV, result, Parse_MultiplicativeExpression); + end; +end; + +function TBasicParser.Parse_MultiplicativeExpression: Integer; +begin + result := Parse_Factor; + while IsCurrText('*') or IsCurrText('/') do + begin + if IsCurrText('*') then + begin + Call_SCANNER; + result := BinOp(OP_MULT, result, Parse_Factor); + end + else + begin + Call_SCANNER; + result := BinOp(OP_DIV, result, Parse_Factor); + end; + end; +end; + +function TBasicParser.Parse_Factor: Integer; +var + SubId, K, type_id, expr_id, Id: Integer; + ValidConst: Boolean; + v: Variant; +begin + if CurrToken.TokenClass = tcBooleanConst then + begin + result := Parse_BooleanLiteral; + if IsCurrText('.') then + result := Parse_Designator(result); + end + else if CurrToken.TokenClass = tcCharConst then + begin + result := Parse_CharLiteral; + if IsCurrText('.') then + result := Parse_Designator(result); + end + else if CurrToken.TokenClass = tcPCharConst then + begin + result := Parse_PCharLiteral; + if IsCurrText('.') then + result := Parse_Designator(result); + end + else if CurrToken.TokenClass = tcIntegerConst then + begin + result := Parse_IntegerLiteral; + if IsCurrText('.') then + result := Parse_Designator(result); + end + else if CurrToken.TokenClass = tcDoubleConst then + begin + result := Parse_DoubleLiteral; + if IsCurrText('.') then + result := Parse_Designator(result); + end + else if IsCurrText('CType') then + begin + Call_SCANNER; + Match('('); + result := NewTempVar; + expr_id := Parse_Expression(); + Match(','); + type_id := Parse_Ident(); + Gen(OP_TYPE_CAST, type_id, expr_id, result); + Match(')'); + end + else if IsCurrText('MyClass') then + begin + Call_SCANNER; + Match('.'); + result := Parse_Ident; + Gen(OP_MYCLASS, result, 0, 0); + end + else if IsCurrText('MyBase') then + begin + Call_SCANNER; + Match('.'); + SubId := NewTempVar; + result := NewTempVar; + K := Parse_Ident; + RemoveInstruction(OP_EVAL, -1, -1, K); + Gen(OP_EVAL_INHERITED, K, 0, SubId); + if IsCurrText('(') then + Gen(OP_CALL_INHERITED, SubID, Parse_ArgumentList(SubId), result) + else + Gen(OP_CALL_INHERITED, SubID, 0, result); + end + else if IsCurrText('+') then + begin + Call_SCANNER; + result := Parse_Factor; + end + else if IsCurrText('-') then + begin + Call_SCANNER; + ValidConst := CurrToken.TokenClass in [tcIntegerConst, tcDoubleConst]; + Id := Parse_Factor; + if ValidConst then + begin + result := Id; + v := GetValue(id); + if v > 0 then + SetValue(Id, - v); + end + else + result := UnaryOp(OP_NEG, Id); + end + else if IsCurrText('Not') then + begin + Call_SCANNER; + result := UnaryOp(OP_NOT, Parse_Factor); + end + else if IsCurrText('*') then + begin + Call_SCANNER; + result := NewTempVar; + Gen(OP_TERMINAL, Parse_Ident, 0, result); + result := Parse_Designator(result); + end + else if IsCurrText('(') then + begin + Match('('); + result := Parse_Expression; + Match(')'); + end + else if IsCurrText('[') then + result := Parse_ArrayLiteral('[', ']') + else if IsCurrText('{') then + result := Parse_ArrayLiteral('{', '}') + else if IsCurrText('Array') then + begin + Match('Array'); + result := Parse_ArrayLiteral('(', ')'); + end +{$IFNDEF TAB} + else if IsCurrText('AddressOf') then + begin + Match('AddressOf'); + result := NewTempVar; + Gen(OP_ADDRESS, Parse_Designator, 0, result); + end +{$ENDIF} + else if IsCurrText('assigned') then + begin + Call_SCANNER; + Match('('); + result := NewTempVar; + Gen(OP_ASSIGNED, Parse_Expression, 0, result); + Match(')'); + Exit; + end + else if IsCurrText('IsNull') then + begin + Call_SCANNER; + Match('('); + result := NewTempVar; + Gen(OP_ASSIGNED, Parse_Expression, 0, result); + Gen(OP_NOT, result, 0, result); + Match(')'); + Exit; + end + else if IsCurrText('IsNothing') then + begin + Call_SCANNER; + Match('('); + result := NewTempVar; + Gen(OP_ASSIGNED, Parse_Expression, 0, result); + Gen(OP_NOT, result, 0, result); + Match(')'); + Exit; + end + else if IsCurrText('CChar') then + begin + Match('CChar'); + Match('('); + result := NewTempVar; + Gen(OP_CHR, Parse_Expression, 0, result); + Match(')'); + end + else if IsCurrText('CDec') then + begin + Call_SCANNER; + result := NewTempVar; + Match('('); + Gen(OP_PUSH, Parse_Expression, 0, typeCURRENCY); + Match(')'); + Gen(OP_CALL, typeCURRENCY, 1, result); + end + else if IsCurrText('CSByte') then + begin + Call_SCANNER; + result := NewTempVar; + Match('('); + Gen(OP_PUSH, Parse_Expression, 0, typeSMALLINT); + Match(')'); + Gen(OP_CALL, typeSMALLINT, 1, result); + end + else if IsCurrText('CShort') then + begin + Call_SCANNER; + result := NewTempVar; + Match('('); + Gen(OP_PUSH, Parse_Expression, 0, typeSHORTINT); + Match(')'); + Gen(OP_CALL, typeSHORTINT, 1, result); + end +{ + else if IsCurrText('CStr') then + begin + Call_SCANNER; + Match('('); + result := Parse_Expression; + Match(')'); + scanner.Position := scanner.Position - 1; + scanner.InsertText('.ToString()'); + Call_SCANNER; + result := Parse_Designator(result); + end +} + else if IsCurrText('CUInt') then + begin + Call_SCANNER; + result := NewTempVar; + Match('('); + Gen(OP_PUSH, Parse_Expression, 0, typeCARDINAL); + Match(')'); + Gen(OP_CALL, typeCARDINAL, 1, result); + end + else if IsCurrText('CUlng') then + begin + Call_SCANNER; + result := NewTempVar; + Match('('); + Gen(OP_PUSH, Parse_Expression, 0, typeCARDINAL); + Match(')'); + Gen(OP_CALL, typeCARDINAL, 1, result); + end + else if IsCurrText('CUShort') then + begin + Call_SCANNER; + result := NewTempVar; + Match('('); + Gen(OP_PUSH, Parse_Expression, 0, typeWORD); + Match(')'); + Gen(OP_CALL, typeWORD, 1, result); + end + else if IsCurrText('Abs') then + begin + Match('Abs'); + Match('('); + result := NewTempVar; + Gen(OP_ABS, Parse_Expression, 0, result); + Match(')'); + end + else if IsCurrText('Asc') then + begin + Match('Asc'); + Match('('); + result := NewTempVar; + Gen(OP_ORD, Parse_Expression, 0, result); + Match(')'); + end +{$IFNDEF TAB} + else if IsCurrText('new') then + begin + result := Parse_NewExpression; + end +{$ENDIF} + else + begin + result := Parse_Designator; + + if IsCurrText('(') then + begin + SubId := result; + result := NewTempVar; + Gen(OP_CALL, SubID, Parse_ArgumentList(SubId), result); + end + else if GetKind(result) = KindSUB then + begin + SubId := result; + result := NewTempVar; + SetName(result, GetName(SubId)); + SetKind(result, KindNONE); + Gen(OP_EVAL, 0, 0, result); + + if IsCurrText('.') or IsCurrText('[') then + result := Parse_Designator(result); + end; + + end; +end; + +function TBasicParser.Parse_NewExpression: Integer; +var + id, TypeId: Integer; + S: String; + ExcId: Integer; +begin + Match('new'); + + S := CurrToken.Text; + ExcId := CurrToken.Id; + + TypeId := Parse_QualId; + if IsCurrText('(') then + begin + if IsNextText(')') and SignThrow and StrEql(S, 'Exception') then + begin + RemoveInstruction(OP_EVAL, -1, -1, ExcId); + Match('('); + Match(')'); + result := 0; // anonymous exception + Exit; + end; + + if IsNextText(')') and IsNext2Text('{') then + begin + Match('('); + Match(')'); + result := Parse_ArrayLiteral('{', '}'); + Exit; + end + else if IsNextText(',') then + begin + result := 0; + while IsNextText(',') do + Call_SCANNER; + Call_SCANNER; + Match(')'); + if IsCurrText('{') then + result := Parse_ArrayLiteral('{', '}') + else + Match('{'); + Exit; + end; + + Id := NewTempVar; + result := NewTempVar; + Gen(OP_EVAL_CONSTRUCTOR, TypeId, 0, Id); + Gen(OP_CALL, Id, Parse_ArgumentList(Id), result); + end + else + begin + if SignThrow and StrEql(S, 'Exception') then + begin + RemoveInstruction(OP_EVAL, -1, -1, ExcId); + + result := 0; // anonymous exception + Exit; + end; + + Id := NewTempVar; + result := NewTempVar; + Gen(OP_EVAL_CONSTRUCTOR, TypeId, 0, Id); + Gen(OP_CALL, Id, 0, result); + end; + + GenAssignOuterInstance(result, TypeId); +end; + +function TBasicParser.Parse_Designator(init_id: Integer = 0): Integer; +var + ok: Boolean; + id: Integer; + S: String; +begin + if init_id = 0 then + begin + if IsCurrText('*') then + begin + Call_SCANNER; + result := NewTempVar; + Gen(OP_TERMINAL, Parse_Ident, 0, result); + end + else + result := Parse_QualId; + end + else + result := init_id; + + if IsOuterLocalVar(result) then + begin + AnonymStack.Top.BindList.Add(result); + S := GetName(result); + result := NewTempVar; + SetName(result, S); + Gen(OP_EVAL, 0, 0, result); + end; + + ok := false; + repeat + if IsCurrText('.') then + begin + FIELD_OWNER_ID := result; + id := FIELD_OWNER_ID; + + Match('.'); + result := Parse_Ident; + Gen(OP_FIELD, id, result, result); + ok := true; + end + else if IsCurrText('[') then // index + begin + Match('['); + repeat + id := result; + result := NewTempVar; + Gen(OP_ELEM, id, Parse_Expression, result); + if NotMatch(',') then + Break; + until false; + Match(']'); + ok := true; + end + else if IsCurrText('^') then + begin + Match('^'); + id := result; + result := NewTempVar; + Gen(OP_TERMINAL, id, 0, result); + end + else if IsCurrText('(') then + begin + Id := result; + result := NewTempVar; + Gen(OP_CALL, Id, Parse_ArgumentList(Id), result); + ok := true; + end + else + ok := false; + until not ok; +end; + +function TBasicParser.Parse_Type: Integer; +var + OldTypeId: Integer; +begin + if DECLARE_SWITCH then + RaiseError(errInternalError, []); + + if IsCurrText('Byte') then + begin + result := typeBYTE; + Call_SCANNER; + end + else if IsCurrText('Char') then + begin + result := typeCHAR; + Call_SCANNER; + end + else if IsCurrText('Word') then + begin + result := typeWORD; + Call_SCANNER; + end + else if IsCurrText('Integer') then + begin + result := typeINTEGER; + Call_SCANNER; + end + else if IsCurrText('Boolean') then + begin + result := typeBOOLEAN; + Call_SCANNER; + end + else if IsCurrText('Variant') then + begin + result := typeVARIANT; + Call_SCANNER; + end + else if IsCurrText('Double') then + begin + result := typeDOUBLE; + Call_SCANNER; + end + else if IsCurrText('Single') then + begin + result := typeSINGLE; + Call_SCANNER; + end + else if IsCurrText('Decimal') then + begin + result := typeCURRENCY; + Call_SCANNER; + end + else + result := Parse_QualId; + + Gen(OP_ADD_TYPEINFO, result, 0, 0); + + if IsCurrText('*') then + begin + Match('*'); + OldTypeId := result; + result := NewTempVar; + SetKind(result, KindTYPE); + BeginPointerType(result); + Gen(OP_CREATE_POINTER_TYPE, result, OldTypeId, 0); + EndPointerType(result); + end; + +end; + +function TBasicParser.Parse_Label: Integer; +begin + if not (CurrToken.TokenClass in [tcIntegerConst, tcIdentifier]) then + RaiseError(errIdentifierExpected, [CurrToken.Text]); + result := CurrToken.Id; + if DECLARE_SWITCH then + SetKind(result, KindLABEL) + else if GetKind(result) = KindNONE then + SetKind(result, KindLABEL) + else if GetKind(result) <> KindLABEL then + RaiseError(errLabelExpected, []); + Call_SCANNER; +end; + +procedure TBasicParser.Call_SCANNER; +begin + inherited; + + if IsCurrText('_') then + begin + RemoveInstruction(OP_EVAL, -1, -1, CurrToken.Id); + + Call_SCANNER(); + while IsLineTerminator do + MatchLineTerminator(); + end + else if IsCurrText('null') then + begin + CurrToken.Id := NilId; + CurrToken.TokenClass := tcIdentifier; + end + else if IsCurrText('me') then + begin + CurrToken.Id := CurrSelfId; + CurrToken.TokenClass := tcIdentifier; + end + else if IsCurrText('char') then + begin + CurrToken.Id := typeCHAR; + CurrToken.TokenClass := tcIdentifier; + end + else if IsCurrText('integer') then + begin + CurrToken.Id := typeINTEGER; + CurrToken.TokenClass := tcIdentifier; + end + else if IsCurrText('boolean') then + begin + CurrToken.Id := typeBOOLEAN; + CurrToken.TokenClass := tcIdentifier; + end + else if IsCurrText('string') then + begin + CurrToken.Id := typeSTRING; + CurrToken.TokenClass := tcIdentifier; + end + else if IsCurrText('short') then + begin + CurrToken.Id := typeSHORTINT; + CurrToken.TokenClass := tcIdentifier; + end + else if IsCurrText('long') then + begin + CurrToken.Id := typeINTEGER; + CurrToken.TokenClass := tcIdentifier; + end + else if IsCurrText('decimal') then + begin + CurrToken.Id := typeCURRENCY; + CurrToken.TokenClass := tcIdentifier; + end; +end; + +function TBasicParser.AltTypeId(const S: String): Integer; +begin + result := 0; + if StrEql(S, 'short') then + result := typeSHORTINT + else if StrEql(S, 'long') then + result := typeINTEGER + else if StrEql(S, 'decimal') then + result := typeCURRENCY; +end; + +function TBasicParser.Parse_Ident: Integer; +var + id: Integer; +begin + result := 0; + if IsCurrText('.') then + begin + if with_stack.Count = 0 then + RaiseError(errIdentifierExpected, [CurrToken.Text]) + else + begin + FIELD_OWNER_ID := with_stack.Top; + id := FIELD_OWNER_ID; + Match('.'); + result := Parse_Ident; + Gen(OP_FIELD, id, result, result); + end; + end + else + begin + if IsCurrText('Object') then + begin + result := H_TObject; + CurrToken.Id := H_TObject; + CurrToken.TokenClass := tcIdentifier; + Call_SCANNER; + end + else + result := inherited Parse_Ident; + end; +end; + +function TBasicParser.IsLineTerminator: Boolean; +begin + result := IsNewLine; +end; + +function TBasicParser.IsStatementTerminator: Boolean; +begin + result := IsLineTerminator or IsCurrText(':') or IsEOF; +end; + +procedure TBasicParser.MatchLineTerminator; +begin + if IsEOF then + Exit; + + if not IsNewLine then + RaiseError(errLineTerminatorExpected, []); + + while CurrToken.TokenClass = tcSeparator do + begin + Gen(OP_SEPARATOR, CurrModule.ModuleNumber, CurrToken.Id, 0); + Call_SCANNER; + end; +end; + +procedure TBasicParser.MatchStatementTerminator; +begin + if IsEOF then + Exit; + + if not SKIP_STATEMENT_TERMINATOR then + if not IsNewLine then + RaiseError(errStatementTerminatorExpected, []); + + while CurrToken.TokenClass = tcSeparator do + begin + Gen(OP_SEPARATOR, CurrModule.ModuleNumber, CurrToken.Id, 0); + Call_SCANNER; + end; +end; + +procedure TBasicParser.PushExitKind(k: TExitKind); +begin + exit_kind_stack.Push(Integer(k)); +end; + +procedure TBasicParser.PopExitKind; +begin + exit_kind_stack.Pop; +end; + +function TBasicParser.GetCurrExitKind: TExitKind; +begin + result := TExitKind(exit_kind_stack.Top); +end; + +procedure TBasicParser.InitSub(var SubId: Integer); +begin + inherited InitSub(SubId); + if GetSymbolRec(SubId).CallMode = cmSTATIC then + GetSymbolRec(CurrSelfId).Name := ''; +end; + +procedure TBasicParser.TestExplicitOff; +begin + if EXPLICIT_OFF = false then + CreateError(errExplicitTypeDeclarationRequired, []); +end; + +procedure TBasicParser.EndTypeDef(TypeId: Integer); +var + FT: Integer; + R: TTypeDefRec; +{$IFNDEF MSWINDOWS} + Ch: Char; +{$ENDIF} +begin + inherited; + + if not IsGeneric(TypeId) then + Exit; + + R := TKernel(kernel).TypeDefList.Top; + FT := GetSymbolRec(TypeId).FinalTypeId; + +{$IFNDEF MSWINDOWS} + if R.Definition <> '' then + begin + Ch := R.Definition[SHigh(R.Definition)]; + if not ByteInSet(Ch, [13, 10]) then + SDelete(R.Definition, SHigh(R.Definition), 1); + end; +{$ENDIF} + + case FT of + typeCLASS: + begin + R.Definition := 'Class ' + R.Definition; + end; + typeRECORD: + begin + R.Definition := 'Structure ' + R.Definition; + end; + typeINTERFACE: + begin + R.Definition := 'Interface ' + R.Definition; + end; + else + RaiseError(errTypeParameterNotAllowed, []); + end; +end; + +function _ParametrizedTypeExpected(scanner: TBaseScanner; const Buff: String; P: Integer): Boolean; +var + I, L: Integer; +label again; +begin + result := false; + L := Length(Buff); + I := P; + while ByteInSet(Buff[I], WhiteSpaces) do + begin + Inc(I); + if I > L then + Exit; + end; + if Buff[I] <> '<' then + Exit; + Inc(I); +again: + while ByteInSet(Buff[I], WhiteSpaces) do + begin + Inc(I); + if I > L then + Exit; + end; + if not scanner.IsAlpha(Buff[I]) then + Exit; + Inc(I); + while scanner.IsAlpha(Buff[I]) or TBaseScanner.IsDigit(Buff[I]) do + begin + Inc(I); + if I > L then + Exit; + end; + while ByteInSet(Buff[I], WhiteSpaces) do + begin + Inc(I); + if I > L then + Exit; + end; + if Buff[I] = '>' then + begin + result := true; + Exit; + end; + if Buff[I] = ',' then + begin + result := true; + Exit; + end; + + if I + 3 < Length(Buff) then + if (UpCase(Buff[I]) = 'A') and (UpCase(Buff[I+1]) = 'S') and (Buff[I+2] = ' ') then + begin + result := true; + Exit; + end; + + if Buff[I] = '<' then + begin + result := true; + Exit; + end; + if Buff[I] = '.' then + begin + Inc(I); + goto again; + end; +end; + +function TBasicParser.ParametrizedTypeExpected: Boolean; +begin + if not GENERICS_ALLOWED then + result := false + else + result := _ParametrizedTypeExpected(scanner, Scanner.Buff, Scanner.Position + 1); +end; + +procedure TBasicParser.Parse_TypeRestriction(LocalTypeParams: TStringObjectList); +var + temp: Boolean; + I: Integer; + TR: TTypeRestrictionRec; +begin + temp := DECLARE_SWITCH; + try + DECLARE_SWITCH := false; + if not IsCurrText('As') then + Exit; + Call_SCANNER; + TR := TTypeRestrictionRec.Create; + TR.N := TKernel(kernel).Code.Card; + if IsCurrText('class') then + begin + Call_SCANNER; + if IsCurrText(',') then + begin + Match(','); + Match('constructor'); + end; + TR.Id := H_TObject; + end + else if IsCurrText('constructor') then + begin + Call_SCANNER; + if IsCurrText(',') then + begin + Match(','); + Match('class'); + end; + TR.Id := H_TObject; + end + else if IsCurrText('record') then + begin + Call_SCANNER; + TR.Id := typeRECORD; + end + else + begin + TR.Id := Parse_QualId; + if IsCurrText(',') then + begin + Match(','); + Match('constructor'); + end; + end; + finally + DECLARE_SWITCH := temp; + end; + if TR = nil then + Exit; + for I := LocalTypeParams.Count - 1 downto 0 do + begin + if LocalTypeParams.Objects[I] <> nil then + break; + LocalTypeParams.Objects[I] := TR.Clone; + end; + FreeAndNil(TR); +end; + +end. diff --git a/Sources/PAXCOMP_BASIC_SCANNER.pas b/Sources/PAXCOMP_BASIC_SCANNER.pas new file mode 100644 index 0000000..9f35253 --- /dev/null +++ b/Sources/PAXCOMP_BASIC_SCANNER.pas @@ -0,0 +1,759 @@ +//////////////////////////////////////////////////////////////////////////// +// PaxCompiler +// Site: http://www.paxcompiler.com +// Author: Alexander Baranovsky (paxscript@gmail.com) +// ======================================================================== +// Copyright (c) Alexander Baranovsky, 2006-2014. All rights reserved. +// Code Version: 4.2 +// ======================================================================== +// Unit: PAXCOMP_BASIC_SCANNER.pas +// ======================================================================== +//////////////////////////////////////////////////////////////////////////// + +{$I PaxCompiler.def} +unit PAXCOMP_BASIC_SCANNER; +interface +uses {$I uses.def} + SysUtils, + PAXCOMP_CONSTANTS, + PAXCOMP_SYS, + PAXCOMP_SCANNER, + PAXCOMP_BYTECODE; + +type + TBasicScanner = class(TBaseScanner) + private + function Scan_LogicalXORExpression: Variant; + function Scan_LogicalORExpression: Variant; + function Scan_LogicalANDExpression: Variant; + function Scan_LogicalNOTExpression: Variant; + function Scan_RelationalExpression: Variant; + function Scan_ShiftExpression: Variant; + function Scan_ConcatenationExpression: Variant; + function Scan_AdditiveExpression: Variant; + function Scan_ModulusExpression: Variant; + function Scan_IntegerDivisionExpression: Variant; + function Scan_MultiplicativeExpression: Variant; + + procedure ScanCondDir; + procedure ScanCustDir; + public + function Scan_Expression: Variant; override; + function Scan_Ident: Variant; override; + procedure ReadCustomToken; override; + end; + +implementation + +uses + PAXCOMP_KERNEL; + +procedure TBasicScanner.ReadCustomToken; +var + c: Char; +begin + repeat + GetNextChar; + c := LA(0); + Token.Position := Position; + if IsWhiteSpace(c) then + begin + continue; + end + else if c = #13 then + ScanSeparator + else if c = #10 then + ScanSeparator + else if IsEOF(c) then + ScanSpecial + else if IsEOF then + ScanEOF + else if IsAlpha(c) then + ScanIdentifier + else if IsDigit(c) then + ScanNumberLiteral + else if c = '$' then + ScanHexLiteral + else if c = CHAR_DOUBLE_AP then + ScanStringLiteral(CHAR_DOUBLE_AP) + else if c = CHAR_AP then + begin + ScanSingleLineComment(); + continue; + end + else if c = '+' then + begin + ScanSpecial; + if LA(1) = '=' then + begin + GetNextChar; + ScanSpecial; + end; + Token.Id := OP_PLUS; + end + else if c = '-' then + begin + ScanSpecial; + if LA(1) = '=' then + begin + GetNextChar; + ScanSpecial; + end; + Token.Id := OP_MINUS; + end + else if c = '*' then + begin + ScanSpecial; + if LA(1) = '=' then + begin + GetNextChar; + ScanSpecial; + end; + Token.Id := OP_MULT; + end + else if c = '/' then + begin + if LA(1) = '/' then + begin + ScanSingleLineComment(); + continue; + end + else + begin + ScanSpecial; + if LA(1) = '=' then + begin + GetNextChar; + ScanSpecial; + end; + Token.Id := OP_DIV; + end; + end + else if c = '\' then + begin + ScanSpecial; + if LA(1) = '=' then + begin + GetNextChar; + ScanSpecial; + end; + Token.Id := OP_IDIV; + end + else if c = '=' then + begin + ScanSpecial; + Token.Id := OP_EQ; + if LA(1) = '>' then + begin + GetNextChar; + ScanSpecial; + end; + end + else if c = '<' then + begin + ScanSpecial; + if LA(1) = '=' then + begin + GetNextChar; + ScanSpecial; + Token.Id := OP_LE; + end + else if LA(1) = '>' then + begin + GetNextChar; + ScanSpecial; + Token.Id := OP_NE; + end + else if LA(1) = '<' then + begin + GetNextChar; + ScanSpecial; + Token.Id := OP_SHL; + end + else + Token.Id := OP_LT; + end + else if c = '>' then + begin + ScanSpecial; + if LA(1) = '=' then + begin + GetNextChar; + ScanSpecial; + Token.Id := OP_GE; + end + else if LA(1) = '>' then + begin + GetNextChar; + ScanSpecial; + Token.Id := OP_SHR; + end + else + Token.Id := OP_GT; + end + else if c = ':' then + begin + ScanSpecial; + if LA(1) = '=' then + begin + GetNextChar; + ScanSpecial; + Token.Id := OP_ASSIGN; + end; + end + else if c = ',' then + ScanSpecial + else if c = '.' then + ScanSpecial + else if c = '(' then + ScanSpecial + else if c = ')' then + ScanSpecial + else if c = '[' then + ScanSpecial + else if c = ']' then + ScanSpecial + else if c = '{' then + ScanSpecial + else if c = '}' then + ScanSpecial + else if c = '^' then + ScanSpecial + else if c = ':' then + ScanSpecial + else if c = ';' then + ScanSpecial +{$IFNDEF TAB} + else if c = '#' then + begin + ScanCondDir; + Token.TokenClass := tcNone; + continue; + end + else if c = '@' then + begin + ScanCustDir; + Token.TokenClass := tcNone; + continue; + end +{$ELSE} + else if c = '#' then + begin + ScanSingleLineComment(); + continue; + end +{$ENDIF} + else if c = '&' then + begin + c := LA(1); + if ByteInSet(c, [Ord('h'),Ord('H')]) then + begin + GetNextChar; + ScanHexLiteral; + end + else + ScanSpecial; + end + else + RaiseError(errSyntaxError, []); + until Token.TokenClass <> tcNone; +end; + +procedure TBasicScanner.ScanCustDir; +label + NextComment, Fin; +const + IdsSet = paxcomp_constants.IdsSet + [Ord('_'), Ord('\'), Ord('/'), Ord('"')]; + Start1 = '@'; +var + S: String; + DirName: String; + ok: Boolean; +begin + DirName := ''; + + S := ''; + repeat + GetNextChar; + if ByteInSet(LA(0), [10,13]) then + begin + Inc(LineCount); + GenSeparator; + + if LA(0) = #13 then + GetNextChar; + end + else + S := S + LA(0); + until not ByteInSet(LA(0), IdsSet); + + + ScanChars(IdsSet + [Ord('_'), Ord('.'), Ord('-'), Ord('['), Ord(']'), Ord('('), + Ord(')'), Ord(','), Ord('\'), Ord('/'), Ord('"'), Ord(' '), Ord(':')]); + + DirName := s + Token.Text; + + with TKernel(kernel) do + if Assigned(OnUnknownDirective) then + begin + ok := true; + OnUnknownDirective(Owner, DirName, ok); + if not ok then + Self.RaiseError(errInvalidCompilerDirective, [DirName]); + end; + + ScanChars(WhiteSpaces); + GenSeparator; +end; + +procedure TBasicScanner.ScanCondDir; +label + NextComment, Fin; +const + IdsSet = paxcomp_constants.IdsSet; + Start1 = '#'; +var + S: String; + I, J, J1, J2: Integer; + Visible: Boolean; + DirName: String; + ok: Boolean; + value: Variant; +begin + DirName := ''; + + Visible := true; + +NextComment: + + S := ''; + repeat + GetNextChar; + if ByteInSet(LA(0), [10,13]) then + begin + Inc(LineCount); + GenSeparator; + + if LA(0) = #13 then + GetNextChar; + end + else + S := S + LA(0); + until not ByteInSet(LA(0), IdsSet); + + I := Pos('CONST ', UpperCase(S) + ' '); + if I > 0 then + begin + while not ByteInSet(LA(0), IdsSet) do + GetNextChar; + + ScanChars(IdsSet + [Ord('.'), Ord('-'), Ord('['), Ord(']'), + Ord('('), Ord(')'), Ord(',')]); + + DirName := Token.Text; + + ScanChars(WhiteSpaces); + + if LA(1) = '=' then + begin + ScanChars([Ord('='), Ord(' ')]); + ReadToken; + value := Scan_Expression; + end; + + TKernel(kernel).DefList.Add(DirName, value); + + with TKernel(kernel) do + if Assigned(OnDefineDirective) then + begin + ok := true; + OnDefineDirective(Owner, DirName, ok); + if not ok then + Self.RaiseError(errInvalidCompilerDirective, [DirName]); + end; + + ScanChars(WhiteSpaces); + GenSeparator; + Exit; + end; + + I := Pos('IF ', UpperCase(S) + ' '); + + if I = 1 then + begin + ScanChars(WhiteSpaces); + ReadToken; + value := Scan_Expression; + if value then + Visible := DefStack.OuterVis + else + Visible := false; + Match('Then'); + + DefStack.Push(_IFDEF, '', Visible); + + ScanChars(WhiteSpaces); + if not Visible then + GenSeparator; + goto Fin; + end; + + I := Pos('ELSEIF ', UpperCase(S) + ' '); + if I = 1 then + begin + ScanChars(WhiteSpaces); + ReadToken; + value := Scan_Expression; + if value then + Visible := DefStack.OuterVis + else + Visible := false; + Match('Then'); + + if DefStack.Count = 0 then + Self.RaiseError(errInvalidCompilerDirective, ['ElseIf']); + + if not DefStack.Top.Word in [_IFDEF, _ELSEIF] then + Self.RaiseError(errInvalidCompilerDirective, ['ElseIf']); + + for J:=DefStack.Count - 1 downto 0 do + begin + if DefStack[J].Vis then + begin + Visible := false; + Break; + end; + if DefStack[J].Word = _IFDEF then + break; + end; + + DefStack.Push(_ELSEIF, '', Visible); + + ScanChars(WhiteSpaces); + if not Visible then + GenSeparator; + goto Fin; + end; + + I := Pos('ELSE ', UpperCase(S) + ' '); + if I = 1 then + begin + ScanChars(WhiteSpaces); + + if DefStack.Count = 0 then + Self.RaiseError(errInvalidCompilerDirective, ['']); + + Visible := DefStack.OuterVis; + + if DefStack.Top.Word in [_IFDEF, _ELSEIF] then + begin + for J:=DefStack.Count - 1 downto 0 do + begin + if DefStack[J].Vis then + begin + Visible := false; + Break; + end; + if DefStack[J].Word = _IFDEF then + break; + end; + + end + else + Self.RaiseError(errInvalidCompilerDirective, ['']); + + DefStack.Push(_ELSE, '', Visible); + + ScanChars(WhiteSpaces); + if not Visible then + GenSeparator; + goto Fin; + end; + + I := Pos('END ', UpperCase(S) + ' '); + + if I = 1 then + begin + ScanChars(WhiteSpaces); + + J1 := 0; + J2 := 0; + for I := DefStack.Count - 1 downto 0 do + if DefStack[I].Word in [_IFDEF, _IFNDEF] then + Inc(J1) + else if DefStack[I].Word = _ENDIF then + Inc(J2); + if J2 >= J1 then + Self.RaiseError(errInvalidCompilerDirective, ['']); + + for I:=DefStack.Count - 1 downto 0 do + if DefStack[I].Word in [_IFDEF, _IFNDEF] then + begin + while DefStack.Count > I do + DefStack.Pop; + Break; + end; + + if DefStack.Count = 0 then + Visible := true + else + Visible := DefStack[DefStack.Count - 1].Vis; + + ReadToken; + Match('If'); + + ScanChars(WhiteSpaces); + if not Visible then + GenSeparator; + + goto Fin; + end; + + DirName := S; + + while not ByteInSet(LA(0), IdsSet + [Ord('\'), Ord('/'), Ord('"')]) do + GetNextChar; + + ScanChars(IdsSet + [Ord('.'), Ord('-'), Ord('['), Ord(']'), Ord('('), Ord(')'), + Ord(','), Ord('\'), Ord('/'), Ord('"')]); + + DirName := s + Token.Text; + + ok := False; + + with TKernel(kernel) do + if Assigned(OnUnknownDirective) then + begin + OnUnknownDirective(Owner, DirName, ok); + if not ok then + Self.RaiseError(errInvalidCompilerDirective, [DirName]); + ScanChars(WhiteSpaces); + end + else + Self.RaiseError(errInvalidCompilerDirective, [DirName]); + +Fin: + + if not Visible then + begin + + repeat + GetNextChar; + if ByteInSet(LA(0), [10,13]) then + begin + Inc(LineCount); + GenSeparator; + if LA(0) = #13 then + GetNextChar; + end; + until (LA(0) = Start1) or IsEOF; + + if IsEOF then + Self.RaiseError(errMissingENDIFdirective, []); + + goto NextComment; + end; +end; + +function TBasicScanner.Scan_Expression: Variant; +begin + result := Scan_LogicalXORExpression; +end; + +function TBasicScanner.Scan_LogicalXORExpression: Variant; +begin + result := Scan_LogicalORExpression; + while IsCurrText('Xor') do + begin + ReadToken; + result := result xor Scan_LogicalORExpression; + end; +end; + +function TBasicScanner.Scan_LogicalORExpression: Variant; +begin + result := Scan_LogicalANDExpression; + while IsCurrText('Or') or IsCurrText('OrElse') do + begin + if IsCurrText('Or') then + begin + ReadToken; + result := result or Scan_LogicalANDExpression; + end + else + begin + if result then + Exit; + result := Scan_LogicalANDExpression; + end; + end; +end; + +function TBasicScanner.Scan_LogicalANDExpression: Variant; +begin + result := Scan_LogicalNOTExpression; + while IsCurrText('And') or IsCurrText('AndAlso') do + begin + if IsCurrText('And') then + begin + ReadToken; + result := result and Scan_LogicalNOTExpression; + end + else + begin + if not result then + Exit; + result := Scan_LogicalNOTExpression; + end; + end; +end; + +function TBasicScanner.Scan_LogicalNOTExpression: Variant; +begin + if IsCurrText('Not') then + begin + Match('Not'); + result := not Scan_Expression; + end + else + result := Scan_RelationalExpression; +end; + +function TBasicScanner.Scan_RelationalExpression: Variant; +begin + result := Scan_ShiftExpression; + while IsCurrText('=') or IsCurrText('<>') or + IsCurrText('>') or IsCurrText('>=') or + IsCurrText('<') or IsCurrText('<=') do + begin + if IsCurrText('=') then + begin + ReadToken; + result := result = Scan_ShiftExpression; + end + else if IsCurrText('<>') then + begin + ReadToken; + result := result <> Scan_ShiftExpression; + end + else if IsCurrText('>') then + begin + ReadToken; + result := result > Scan_ShiftExpression; + end + else if IsCurrText('>=') then + begin + ReadToken; + result := result >= Scan_ShiftExpression; + end + else if IsCurrText('<') then + begin + ReadToken; + result := result < Scan_ShiftExpression; + end + else if IsCurrText('<=') then + begin + ReadToken; + result := result <= Scan_ShiftExpression; + end; + end +end; + +function TBasicScanner.Scan_ShiftExpression: Variant; +begin + result := Scan_ConcatenationExpression; + while IsCurrText('<<') or IsCurrText('>>') do + begin + if IsCurrText('<<') then + begin + ReadToken; + result := result shl Scan_ConcatenationExpression; + end + else + begin + ReadToken; + result := result shr Scan_ConcatenationExpression; + end; + end; +end; + +function TBasicScanner.Scan_ConcatenationExpression: Variant; +begin + result := Scan_AdditiveExpression; + while IsCurrText('&') do + begin + ReadToken; + result := result + Scan_AdditiveExpression; + end; +end; + +function TBasicScanner.Scan_AdditiveExpression: Variant; +begin + result := Scan_ModulusExpression; + while IsCurrText('+') or IsCurrText('-') do + begin + if IsCurrText('+') then + begin + ReadToken; + result := result + Scan_ModulusExpression; + end + else + begin + ReadToken; + result := result - Scan_ModulusExpression; + end; + end; +end; + +function TBasicScanner.Scan_ModulusExpression: Variant; +begin + result := Scan_IntegerDivisionExpression; + while IsCurrText('Mod') do + begin + ReadToken; + result := result Mod Scan_IntegerDivisionExpression; + end; +end; + +function TBasicScanner.Scan_IntegerDivisionExpression: Variant; +begin + result := Scan_MultiplicativeExpression; + while IsCurrText('\') do + begin + ReadToken; + result := result div Scan_MultiplicativeExpression; + end; +end; + +function TBasicScanner.Scan_MultiplicativeExpression: Variant; +begin + result := Scan_Factor; + while IsCurrText('*') or IsCurrText('/') do + begin + if IsCurrText('*') then + begin + ReadToken; + result := result * Scan_Factor; + end + else + begin + ReadToken; + result := result / Scan_Factor; + end; + end; +end; + +function TBasicScanner.Scan_Ident: Variant; +var + I: Integer; + DefList: TDefList; +begin + DefList := TKernel(kernel).DefList; + I := DefList.IndexOf(Token.Text); + if I = -1 then + RaiseError(errInvalidCompilerDirective, [Token.Text]); + result := DefList[I].value; + ReadToken; +end; + +end. diff --git a/Sources/PAXCOMP_BRIDGE.pas b/Sources/PAXCOMP_BRIDGE.pas new file mode 100644 index 0000000..68f8e3d --- /dev/null +++ b/Sources/PAXCOMP_BRIDGE.pas @@ -0,0 +1,2085 @@ +//////////////////////////////////////////////////////////////////////////// +// PaxCompiler +// Site: http://www.paxcompiler.com +// Author: Alexander Baranovsky (paxscript@gmail.com) +// ======================================================================== +// Copyright (c) Alexander Baranovsky, 2006-2014. All rights reserved. +// Code Version: 4.2 +// ======================================================================== +// Unit: PAXCOMP_BRIDGE.pas +// ======================================================================== +//////////////////////////////////////////////////////////////////////////// + +{$I PaxCompiler.def} +unit PAXCOMP_BRIDGE; +interface +uses {$I uses.def} + PAXCOMP_CONSTANTS, + PAXCOMP_SYS; + +function GetFakeAddRefAddress(Index: Integer): Pointer; +function GetFakeReleaseAddress(Index: Integer): Pointer; +function GetFakeHandlerAddress(Index: Integer): Pointer; +function GetFakeGlobalAddress(Index: Integer): Pointer; + +implementation + +uses + PAXCOMP_BASERUNNER; + +var + FakeHandlerAddressList, + FakeGlobalAddressList, + FakeAddRefAddressList, + FakeReleaseAddressList: array[0..100] of Pointer; + +{$IFDEF PAX64} +{$DEFINE PARAM4} +{$ENDIF} + +{$IFDEF PAXARM_DEVICE} +{$DEFINE PARAM4} +{$ENDIF} + +{$IFDEF PARAM4} + +{$IFDEF PAX64} +procedure LoadRAX(R_AX: IntPax); assembler; +asm + mov RAX, R_AX +end; +{$ELSE} +function LoadRAX(R_AX: IntPax): Integer; +begin + result := R_AX; +end; +{$ENDIF} + +procedure CallGlobal(P1: IntPax; + P2: IntPax; + P3: IntPax; + P4: IntPax; + CommonGlobalIndex: Integer; + StackPtr: Pointer); +var + Runner: TBaseRunner; + N, FT, RetSize: Integer; + R_AX: IntPax; + ResBuff: array[0..SizeOf(Variant)-1] of Byte; +begin + Runner := CurrRunner; + + N := Runner.ByteCodeGlobalEntryList[CommonGlobalIndex]; + + FillChar(ResBuff, SizeOf(ResBuff), 0); +{$IFDEF PAX64} + RetSize := Runner.CallByteCode(N, nil, 0, P1, P2, P3, P4, +{$ELSE} + RetSize := Runner.CallByteCode(N, nil, P1, P2, P3, P4, 0, +{$ENDIF} + StackPtr, @ResBuff, FT); + R_AX := 0; + if FT in (OrdinalTypes + [ +{$IFNDEF PAXARM} + typeANSISTRING, typeWIDESTRING, +{$ENDIF} + typeUNICSTRING, typeVARIANT, + typeOLEVARIANT, typeINT64, typeUINT64, + typePOINTER, typeCLASS, typeCLASSREF, typeDYNARRAY, + typeINTERFACE]) then + begin + Move(ResBuff, R_AX, Types.GetSize(FT)); + LoadRAX(R_AX); + end + else if FT = typeDOUBLE then + LoadDouble(@ResBuff) + else if FT = typeSINGLE then + LoadSingle(@ResBuff) + else if FT = typeEXTENDED then + LoadExtended(@ResBuff) + else if FT = typeCURRENCY then + LoadCurrency(@ResBuff); +end; + +procedure FakeGlobal_00(P1, P2, P3, P4: IntPax); +begin + CallGlobal(P1, P2, P3, P4, 0, GetRBPPtr); +end; + +procedure FakeGlobal_01(P1, P2, P3, P4: IntPax); +begin + CallGlobal(P1, P2, P3, P4, 1, GetRBPPtr); +end; + +procedure FakeGlobal_02(P1, P2, P3, P4: IntPax); +begin + CallGlobal(P1, P2, P3, P4, 2, GetRBPPtr); +end; + +procedure FakeGlobal_03(P1, P2, P3, P4: IntPax); +begin + CallGlobal(P1, P2, P3, P4, 3, GetRBPPtr); +end; + +procedure FakeGlobal_04(P1, P2, P3, P4: IntPax); +begin + CallGlobal(P1, P2, P3, P4, 4, GetRBPPtr); +end; + +procedure FakeGlobal_05(P1, P2, P3, P4: IntPax); +begin + CallGlobal(P1, P2, P3, P4, 5, GetRBPPtr); +end; + +procedure FakeGlobal_06(P1, P2, P3, P4: IntPax); +begin + CallGlobal(P1, P2, P3, P4, 6, GetRBPPtr); +end; + +procedure FakeGlobal_07(P1, P2, P3, P4: IntPax); +begin + CallGlobal(P1, P2, P3, P4, 7, GetRBPPtr); +end; + +procedure FakeGlobal_08(P1, P2, P3, P4: IntPax); +begin + CallGlobal(P1, P2, P3, P4, 8, GetRBPPtr); +end; + +procedure FakeGlobal_09(P1, P2, P3, P4: IntPax); +begin + CallGlobal(P1, P2, P3, P4, 9, GetRBPPtr); +end; + +procedure FakeGlobal_10(P1, P2, P3, P4: IntPax); +begin + CallGlobal(P1, P2, P3, P4, 10, GetRBPPtr); +end; + +procedure FakeGlobal_11(P1, P2, P3, P4: IntPax); +begin + CallGlobal(P1, P2, P3, P4, 11, GetRBPPtr); +end; + +procedure FakeGlobal_12(P1, P2, P3, P4: IntPax); +begin + CallGlobal(P1, P2, P3, P4, 12, GetRBPPtr); +end; + +procedure FakeGlobal_13(P1, P2, P3, P4: IntPax); +begin + CallGlobal(P1, P2, P3, P4, 13, GetRBPPtr); +end; + +procedure FakeGlobal_14(P1, P2, P3, P4: IntPax); +begin + CallGlobal(P1, P2, P3, P4, 14, GetRBPPtr); +end; + +procedure FakeGlobal_15(P1, P2, P3, P4: IntPax); +begin + CallGlobal(P1, P2, P3, P4, 15, GetRBPPtr); +end; + +procedure FakeGlobal_16(P1, P2, P3, P4: IntPax); +begin + CallGlobal(P1, P2, P3, P4, 16, GetRBPPtr); +end; + +procedure FakeGlobal_17(P1, P2, P3, P4: IntPax); +begin + CallGlobal(P1, P2, P3, P4, 17, GetRBPPtr); +end; + +procedure FakeGlobal_18(P1, P2, P3, P4: IntPax); +begin + CallGlobal(P1, P2, P3, P4, 18, GetRBPPtr); +end; + +procedure FakeGlobal_19(P1, P2, P3, P4: IntPax); +begin + CallGlobal(P1, P2, P3, P4, 19, GetRBPPtr); +end; + +procedure FakeGlobal_20(P1, P2, P3, P4: IntPax); +begin + CallGlobal(P1, P2, P3, P4, 20, GetRBPPtr); +end; + +procedure FakeGlobal_21(P1, P2, P3, P4: IntPax); +begin + CallGlobal(P1, P2, P3, P4, 21, GetRBPPtr); +end; + +procedure FakeGlobal_22(P1, P2, P3, P4: IntPax); +begin + CallGlobal(P1, P2, P3, P4, 22, GetRBPPtr); +end; + +procedure FakeGlobal_23(P1, P2, P3, P4: IntPax); +begin + CallGlobal(P1, P2, P3, P4, 23, GetRBPPtr); +end; + +procedure FakeGlobal_24(P1, P2, P3, P4: IntPax); +begin + CallGlobal(P1, P2, P3, P4, 24, GetRBPPtr); +end; + +procedure FakeGlobal_25(P1, P2, P3, P4: IntPax); +begin + CallGlobal(P1, P2, P3, P4, 25, GetRBPPtr); +end; + +procedure FakeGlobal_26(P1, P2, P3, P4: IntPax); +begin + CallGlobal(P1, P2, P3, P4, 26, GetRBPPtr); +end; + +procedure FakeGlobal_27(P1, P2, P3, P4: IntPax); +begin + CallGlobal(P1, P2, P3, P4, 27, GetRBPPtr); +end; + +procedure FakeGlobal_28(P1, P2, P3, P4: IntPax); +begin + CallGlobal(P1, P2, P3, P4, 28, GetRBPPtr); +end; + +procedure FakeGlobal_29(P1, P2, P3, P4: IntPax); +begin + CallGlobal(P1, P2, P3, P4, 29, GetRBPPtr); +end; + +procedure FakeGlobal_30(P1, P2, P3, P4: IntPax); +begin + CallGlobal(P1, P2, P3, P4, 30, GetRBPPtr); +end; + +procedure FakeGlobal_31(P1, P2, P3, P4: IntPax); +begin + CallGlobal(P1, P2, P3, P4, 31, GetRBPPtr); +end; + +procedure FakeGlobal_32(P1, P2, P3, P4: IntPax); +begin + CallGlobal(P1, P2, P3, P4, 32, GetRBPPtr); +end; + +procedure FakeGlobal_33(P1, P2, P3, P4: IntPax); +begin + CallGlobal(P1, P2, P3, P4, 33, GetRBPPtr); +end; + +procedure FakeGlobal_34(P1, P2, P3, P4: IntPax); +begin + CallGlobal(P1, P2, P3, P4, 34, GetRBPPtr); +end; + +procedure FakeGlobal_35(P1, P2, P3, P4: IntPax); +begin + CallGlobal(P1, P2, P3, P4, 35, GetRBPPtr); +end; + +procedure FakeGlobal_36(P1, P2, P3, P4: IntPax); +begin + CallGlobal(P1, P2, P3, P4, 36, GetRBPPtr); +end; + +procedure FakeGlobal_37(P1, P2, P3, P4: IntPax); +begin + CallGlobal(P1, P2, P3, P4, 37, GetRBPPtr); +end; + +procedure FakeGlobal_38(P1, P2, P3, P4: IntPax); +begin + CallGlobal(P1, P2, P3, P4, 38, GetRBPPtr); +end; + +procedure FakeGlobal_39(P1, P2, P3, P4: IntPax); +begin + CallGlobal(P1, P2, P3, P4, 39, GetRBPPtr); +end; + +procedure FakeGlobal_40(P1, P2, P3, P4: IntPax); +begin + CallGlobal(P1, P2, P3, P4, 40, GetRBPPtr); +end; + +procedure FakeGlobal_41(P1, P2, P3, P4: IntPax); +begin + CallGlobal(P1, P2, P3, P4, 41, GetRBPPtr); +end; + +procedure FakeGlobal_42(P1, P2, P3, P4: IntPax); +begin + CallGlobal(P1, P2, P3, P4, 42, GetRBPPtr); +end; + +procedure FakeGlobal_43(P1, P2, P3, P4: IntPax); +begin + CallGlobal(P1, P2, P3, P4, 43, GetRBPPtr); +end; + +procedure FakeGlobal_44(P1, P2, P3, P4: IntPax); +begin + CallGlobal(P1, P2, P3, P4, 44, GetRBPPtr); +end; + +procedure FakeGlobal_45(P1, P2, P3, P4: IntPax); +begin + CallGlobal(P1, P2, P3, P4, 45, GetRBPPtr); +end; + +procedure FakeGlobal_46(P1, P2, P3, P4: IntPax); +begin + CallGlobal(P1, P2, P3, P4, 46, GetRBPPtr); +end; + +procedure FakeGlobal_47(P1, P2, P3, P4: IntPax); +begin + CallGlobal(P1, P2, P3, P4, 47, GetRBPPtr); +end; + +procedure FakeGlobal_48(P1, P2, P3, P4: IntPax); +begin + CallGlobal(P1, P2, P3, P4, 48, GetRBPPtr); +end; + +procedure FakeGlobal_49(P1, P2, P3, P4: IntPax); +begin + CallGlobal(P1, P2, P3, P4, 49, GetRBPPtr); +end; + +procedure FakeGlobal_50(P1, P2, P3, P4: IntPax); +begin + CallGlobal(P1, P2, P3, P4, 50, GetRBPPtr); +end; + +procedure FakeGlobal_51(P1, P2, P3, P4: IntPax); +begin + CallGlobal(P1, P2, P3, P4, 51, GetRBPPtr); +end; + +procedure FakeGlobal_52(P1, P2, P3, P4: IntPax); +begin + CallGlobal(P1, P2, P3, P4, 52, GetRBPPtr); +end; + +procedure FakeGlobal_53(P1, P2, P3, P4: IntPax); +begin + CallGlobal(P1, P2, P3, P4, 53, GetRBPPtr); +end; + +procedure FakeGlobal_54(P1, P2, P3, P4: IntPax); +begin + CallGlobal(P1, P2, P3, P4, 54, GetRBPPtr); +end; + +procedure FakeGlobal_55(P1, P2, P3, P4: IntPax); +begin + CallGlobal(P1, P2, P3, P4, 55, GetRBPPtr); +end; + +procedure FakeGlobal_56(P1, P2, P3, P4: IntPax); +begin + CallGlobal(P1, P2, P3, P4, 56, GetRBPPtr); +end; + +procedure FakeGlobal_57(P1, P2, P3, P4: IntPax); +begin + CallGlobal(P1, P2, P3, P4, 57, GetRBPPtr); +end; + +procedure FakeGlobal_58(P1, P2, P3, P4: IntPax); +begin + CallGlobal(P1, P2, P3, P4, 58, GetRBPPtr); +end; + +procedure FakeGlobal_59(P1, P2, P3, P4: IntPax); +begin + CallGlobal(P1, P2, P3, P4, 59, GetRBPPtr); +end; + +procedure FakeGlobal_60(P1, P2, P3, P4: IntPax); +begin + CallGlobal(P1, P2, P3, P4, 60, GetRBPPtr); +end; + +procedure FakeGlobal_61(P1, P2, P3, P4: IntPax); +begin + CallGlobal(P1, P2, P3, P4, 61, GetRBPPtr); +end; + +procedure FakeGlobal_62(P1, P2, P3, P4: IntPax); +begin + CallGlobal(P1, P2, P3, P4, 62, GetRBPPtr); +end; + +procedure FakeGlobal_63(P1, P2, P3, P4: IntPax); +begin + CallGlobal(P1, P2, P3, P4, 63, GetRBPPtr); +end; + +procedure FakeGlobal_64(P1, P2, P3, P4: IntPax); +begin + CallGlobal(P1, P2, P3, P4, 64, GetRBPPtr); +end; + +procedure FakeGlobal_65(P1, P2, P3, P4: IntPax); +begin + CallGlobal(P1, P2, P3, P4, 65, GetRBPPtr); +end; + +procedure FakeGlobal_66(P1, P2, P3, P4: IntPax); +begin + CallGlobal(P1, P2, P3, P4, 66, GetRBPPtr); +end; + +procedure FakeGlobal_67(P1, P2, P3, P4: IntPax); +begin + CallGlobal(P1, P2, P3, P4, 67, GetRBPPtr); +end; + +procedure FakeGlobal_68(P1, P2, P3, P4: IntPax); +begin + CallGlobal(P1, P2, P3, P4, 68, GetRBPPtr); +end; + +procedure FakeGlobal_69(P1, P2, P3, P4: IntPax); +begin + CallGlobal(P1, P2, P3, P4, 69, GetRBPPtr); +end; + +procedure FakeGlobal_70(P1, P2, P3, P4: IntPax); +begin + CallGlobal(P1, P2, P3, P4, 70, GetRBPPtr); +end; + +procedure CallHandler(P1: IntPax; + P2: IntPax; + P3: IntPax; + P4: IntPax; + CommonMethodIndex: Integer; + StackPtr: Pointer); +var + C: TClass; + PaxInfo: PPaxInfo; + Runner: TBaseRunner; + Self: Pointer; + N, FT, RetSize: Integer; + R_AX: IntPax; + ResBuff: array[1..64] of Byte; + ResAddress: Pointer; +begin +{$IFDEF FPC} + if P1 = 0 then + Self := Pointer(P2) + else + Self := Pointer(P1); +{$ELSE} + Self := Pointer(P1); +{$ENDIF} + if IsDelphiClass(Self) then + C := TClass(Self) + else + C := TObject(Self).ClassType; + PaxInfo := GetPaxInfo(C); + Assert(PaxInfo <> nil); + Runner := TBaseRunner(PaxInfo^.Prog); + + N := Runner.ClassList[PaxInfo^.ClassIndex]. + ByteCodeMethodEntryList[CommonMethodIndex]; + +// FT := Runner.GetReturnFinalTypeId(N); + + FillChar(ResBuff, SizeOf(ResBuff), 0); + ResAddress := @ ResBuff; + +{$IFDEF PAX64} + RetSize := Runner.CallByteCode(N, Self, 0, P1, P2, P3, P4, +{$ELSE} + RetSize := Runner.CallByteCode(N, Self, P1, P2, P3, P4, 0, +{$ENDIF} + StackPtr, ResAddress, FT); + + R_AX := 0; + if FT in (OrdinalTypes + [ +{$IFNDEF PAXARM} + typeANSISTRING, typeWIDESTRING, +{$ENDIF} + typeUNICSTRING, typeVARIANT, + typeOLEVARIANT, typeINT64, typeUINT64, + typePOINTER, typeCLASS, typeCLASSREF, typeDYNARRAY, + typeINTERFACE]) then + begin + if FT = typeCLASS then + begin + LoadRAX(IntPax(ResAddress^)); + end + else + begin + Move(ResAddress^, R_AX, Types.GetSize(FT)); + LoadRAX(R_AX); + end; + end + else if FT = typeDOUBLE then + LoadDouble(@ResBuff) + else if FT = typeSINGLE then + LoadSingle(@ResBuff) + else if FT = typeEXTENDED then + LoadExtended(@ResBuff) + else if FT = typeCURRENCY then + LoadCurrency(@ResBuff); +end; + +procedure FakeHandler_00(P1, P2, P3, P4: IntPax); +begin + CallHandler(P1, P2, P3, P4, 0, GetRBPPtr); +end; + +procedure FakeHandler_01(P1, P2, P3, P4: IntPax); +begin + CallHandler(P1, P2, P3, P4, 1, GetRBPPtr); +end; + +procedure FakeHandler_02(P1, P2, P3, P4: IntPax); +begin + CallHandler(P1, P2, P3, P4, 2, GetRBPPtr); +end; + +procedure FakeHandler_03(P1, P2, P3, P4: IntPax); +begin + CallHandler(P1, P2, P3, P4, 3, GetRBPPtr); +end; + +procedure FakeHandler_04(P1, P2, P3, P4: IntPax); +begin + CallHandler(P1, P2, P3, P4, 4, GetRBPPtr); +end; + +procedure FakeHandler_05(P1, P2, P3, P4: IntPax); +begin + CallHandler(P1, P2, P3, P4, 5, GetRBPPtr); +end; + +procedure FakeHandler_06(P1, P2, P3, P4: IntPax); +begin + CallHandler(P1, P2, P3, P4, 6, GetRBPPtr); +end; + +procedure FakeHandler_07(P1, P2, P3, P4: IntPax); +begin + CallHandler(P1, P2, P3, P4, 7, GetRBPPtr); +end; + +procedure FakeHandler_08(P1, P2, P3, P4: IntPax); +begin + CallHandler(P1, P2, P3, P4, 8, GetRBPPtr); +end; + +procedure FakeHandler_09(P1, P2, P3, P4: IntPax); +begin + CallHandler(P1, P2, P3, P4, 9, GetRBPPtr); +end; + +procedure FakeHandler_10(P1, P2, P3, P4: IntPax); +begin + CallHandler(P1, P2, P3, P4, 10, GetRBPPtr); +end; + +procedure FakeHandler_11(P1, P2, P3, P4: IntPax); +begin + CallHandler(P1, P2, P3, P4, 11, GetRBPPtr); +end; + +procedure FakeHandler_12(P1, P2, P3, P4: IntPax); +begin + CallHandler(P1, P2, P3, P4, 12, GetRBPPtr); +end; + +procedure FakeHandler_13(P1, P2, P3, P4: IntPax); +begin + CallHandler(P1, P2, P3, P4, 13, GetRBPPtr); +end; + +procedure FakeHandler_14(P1, P2, P3, P4: IntPax); +begin + CallHandler(P1, P2, P3, P4, 14, GetRBPPtr); +end; + +procedure FakeHandler_15(P1, P2, P3, P4: IntPax); +begin + CallHandler(P1, P2, P3, P4, 15, GetRBPPtr); +end; + +procedure FakeHandler_16(P1, P2, P3, P4: IntPax); +begin + CallHandler(P1, P2, P3, P4, 16, GetRBPPtr); +end; + +procedure FakeHandler_17(P1, P2, P3, P4: IntPax); +begin + CallHandler(P1, P2, P3, P4, 17, GetRBPPtr); +end; + +procedure FakeHandler_18(P1, P2, P3, P4: IntPax); +begin + CallHandler(P1, P2, P3, P4, 18, GetRBPPtr); +end; + +procedure FakeHandler_19(P1, P2, P3, P4: IntPax); +begin + CallHandler(P1, P2, P3, P4, 19, GetRBPPtr); +end; + +procedure FakeHandler_20(P1, P2, P3, P4: IntPax); +begin + CallHandler(P1, P2, P3, P4, 20, GetRBPPtr); +end; + +procedure FakeHandler_21(P1, P2, P3, P4: IntPax); +begin + CallHandler(P1, P2, P3, P4, 21, GetRBPPtr); +end; + +procedure FakeHandler_22(P1, P2, P3, P4: IntPax); +begin + CallHandler(P1, P2, P3, P4, 22, GetRBPPtr); +end; + +procedure FakeHandler_23(P1, P2, P3, P4: IntPax); +begin + CallHandler(P1, P2, P3, P4, 23, GetRBPPtr); +end; + +procedure FakeHandler_24(P1, P2, P3, P4: IntPax); +begin + CallHandler(P1, P2, P3, P4, 24, GetRBPPtr); +end; + +procedure FakeHandler_25(P1, P2, P3, P4: IntPax); +begin + CallHandler(P1, P2, P3, P4, 25, GetRBPPtr); +end; + +procedure FakeHandler_26(P1, P2, P3, P4: IntPax); +begin + CallHandler(P1, P2, P3, P4, 26, GetRBPPtr); +end; + +procedure FakeHandler_27(P1, P2, P3, P4: IntPax); +begin + CallHandler(P1, P2, P3, P4, 27, GetRBPPtr); +end; + +procedure FakeHandler_28(P1, P2, P3, P4: IntPax); +begin + CallHandler(P1, P2, P3, P4, 28, GetRBPPtr); +end; + +procedure FakeHandler_29(P1, P2, P3, P4: IntPax); +begin + CallHandler(P1, P2, P3, P4, 29, GetRBPPtr); +end; + +procedure FakeHandler_30(P1, P2, P3, P4: IntPax); +begin + CallHandler(P1, P2, P3, P4, 30, GetRBPPtr); +end; + +procedure FakeHandler_31(P1, P2, P3, P4: IntPax); +begin + CallHandler(P1, P2, P3, P4, 31, GetRBPPtr); +end; + +procedure FakeHandler_32(P1, P2, P3, P4: IntPax); +begin + CallHandler(P1, P2, P3, P4, 32, GetRBPPtr); +end; + +procedure FakeHandler_33(P1, P2, P3, P4: IntPax); +begin + CallHandler(P1, P2, P3, P4, 33, GetRBPPtr); +end; + +procedure FakeHandler_34(P1, P2, P3, P4: IntPax); +begin + CallHandler(P1, P2, P3, P4, 34, GetRBPPtr); +end; + +procedure FakeHandler_35(P1, P2, P3, P4: IntPax); +begin + CallHandler(P1, P2, P3, P4, 35, GetRBPPtr); +end; + +procedure FakeHandler_36(P1, P2, P3, P4: IntPax); +begin + CallHandler(P1, P2, P3, P4, 36, GetRBPPtr); +end; + +procedure FakeHandler_37(P1, P2, P3, P4: IntPax); +begin + CallHandler(P1, P2, P3, P4, 37, GetRBPPtr); +end; + +procedure FakeHandler_38(P1, P2, P3, P4: IntPax); +begin + CallHandler(P1, P2, P3, P4, 38, GetRBPPtr); +end; + +procedure FakeHandler_39(P1, P2, P3, P4: IntPax); +begin + CallHandler(P1, P2, P3, P4, 39, GetRBPPtr); +end; + +procedure FakeHandler_40(P1, P2, P3, P4: IntPax); +begin + CallHandler(P1, P2, P3, P4, 40, GetRBPPtr); +end; + +procedure FakeHandler_41(P1, P2, P3, P4: IntPax); +begin + CallHandler(P1, P2, P3, P4, 41, GetRBPPtr); +end; + +procedure FakeHandler_42(P1, P2, P3, P4: IntPax); +begin + CallHandler(P1, P2, P3, P4, 42, GetRBPPtr); +end; + +procedure FakeHandler_43(P1, P2, P3, P4: IntPax); +begin + CallHandler(P1, P2, P3, P4, 43, GetRBPPtr); +end; + +procedure FakeHandler_44(P1, P2, P3, P4: IntPax); +begin + CallHandler(P1, P2, P3, P4, 44, GetRBPPtr); +end; + +procedure FakeHandler_45(P1, P2, P3, P4: IntPax); +begin + CallHandler(P1, P2, P3, P4, 45, GetRBPPtr); +end; + +procedure FakeHandler_46(P1, P2, P3, P4: IntPax); +begin + CallHandler(P1, P2, P3, P4, 46, GetRBPPtr); +end; + +procedure FakeHandler_47(P1, P2, P3, P4: IntPax); +begin + CallHandler(P1, P2, P3, P4, 47, GetRBPPtr); +end; + +procedure FakeHandler_48(P1, P2, P3, P4: IntPax); +begin + CallHandler(P1, P2, P3, P4, 48, GetRBPPtr); +end; + +procedure FakeHandler_49(P1, P2, P3, P4: IntPax); +begin + CallHandler(P1, P2, P3, P4, 49, GetRBPPtr); +end; + +procedure FakeHandler_50(P1, P2, P3, P4: IntPax); +begin + CallHandler(P1, P2, P3, P4, 50, GetRBPPtr); +end; + +procedure FakeHandler_51(P1, P2, P3, P4: IntPax); +begin + CallHandler(P1, P2, P3, P4, 51, GetRBPPtr); +end; + +procedure FakeHandler_52(P1, P2, P3, P4: IntPax); +begin + CallHandler(P1, P2, P3, P4, 52, GetRBPPtr); +end; + +procedure FakeHandler_53(P1, P2, P3, P4: IntPax); +begin + CallHandler(P1, P2, P3, P4, 53, GetRBPPtr); +end; + +procedure FakeHandler_54(P1, P2, P3, P4: IntPax); +begin + CallHandler(P1, P2, P3, P4, 54, GetRBPPtr); +end; + +procedure FakeHandler_55(P1, P2, P3, P4: IntPax); +begin + CallHandler(P1, P2, P3, P4, 55, GetRBPPtr); +end; + +procedure FakeHandler_56(P1, P2, P3, P4: IntPax); +begin + CallHandler(P1, P2, P3, P4, 56, GetRBPPtr); +end; + +procedure FakeHandler_57(P1, P2, P3, P4: IntPax); +begin + CallHandler(P1, P2, P3, P4, 57, GetRBPPtr); +end; + +procedure FakeHandler_58(P1, P2, P3, P4: IntPax); +begin + CallHandler(P1, P2, P3, P4, 58, GetRBPPtr); +end; + +procedure FakeHandler_59(P1, P2, P3, P4: IntPax); +begin + CallHandler(P1, P2, P3, P4, 59, GetRBPPtr); +end; + +procedure FakeHandler_60(P1, P2, P3, P4: IntPax); +begin + CallHandler(P1, P2, P3, P4, 60, GetRBPPtr); +end; + +procedure FakeHandler_61(P1, P2, P3, P4: IntPax); +begin + CallHandler(P1, P2, P3, P4, 61, GetRBPPtr); +end; + +procedure FakeHandler_62(P1, P2, P3, P4: IntPax); +begin + CallHandler(P1, P2, P3, P4, 62, GetRBPPtr); +end; + +procedure FakeHandler_63(P1, P2, P3, P4: IntPax); +begin + CallHandler(P1, P2, P3, P4, 63, GetRBPPtr); +end; + +procedure FakeHandler_64(P1, P2, P3, P4: IntPax); +begin + CallHandler(P1, P2, P3, P4, 64, GetRBPPtr); +end; + +procedure FakeHandler_65(P1, P2, P3, P4: IntPax); +begin + CallHandler(P1, P2, P3, P4, 65, GetRBPPtr); +end; + +procedure FakeHandler_66(P1, P2, P3, P4: IntPax); +begin + CallHandler(P1, P2, P3, P4, 66, GetRBPPtr); +end; + +procedure FakeHandler_67(P1, P2, P3, P4: IntPax); +begin + CallHandler(P1, P2, P3, P4, 67, GetRBPPtr); +end; + +procedure FakeHandler_68(P1, P2, P3, P4: IntPax); +begin + CallHandler(P1, P2, P3, P4, 68, GetRBPPtr); +end; + +procedure FakeHandler_69(P1, P2, P3, P4: IntPax); +begin + CallHandler(P1, P2, P3, P4, 69, GetRBPPtr); +end; + +procedure FakeHandler_70(P1, P2, P3, P4: IntPax); +begin + CallHandler(P1, P2, P3, P4, 70, GetRBPPtr); +end; + +{$ELSE} + +procedure CallGlobal(P1: IntPax; + P2: IntPax; + P3: IntPax; + CommonGlobalIndex: Integer; + StackPtr: Pointer); +var + Runner: TBaseRunner; + N, R_AX, R_DX, RetSize, FT: Integer; + ResBuff: array[0..SizeOf(Variant)-1] of Byte; +begin + Runner := CurrRunner; + + N := Runner.ByteCodeGlobalEntryList[CommonGlobalIndex]; + + FillChar(ResBuff, SizeOf(ResBuff), 0); + RetSize := Runner.CallByteCode(N, nil, P1, P3, P2, 0, 0, + StackPtr, @ResBuff, FT); + R_AX := 0; + R_DX := 0; +{$IFDEF PAXARM} + if FT in (OrdinalTypes + [typeUNICSTRING, typeVARIANT, + typeOLEVARIANT, + typePOINTER, typeCLASS, typeCLASSREF, typeDYNARRAY, + typeINTERFACE]) then +{$ELSE} + if FT in (OrdinalTypes + [typeANSISTRING, typeWIDESTRING, typeUNICSTRING, typeVARIANT, + typeOLEVARIANT, + typePOINTER, typeCLASS, typeCLASSREF, typeDYNARRAY, + typeINTERFACE]) then +{$ENDIF} + begin + Move(ResBuff, R_AX, Types.GetSize(FT)); + end + else if FT in Int64Types then + begin + Move(ResBuff, R_AX, SizeOf(Integer)); + Move(ResBuff[SizeOf(Integer)], R_DX, SizeOf(Integer)); + end + else if FT = typeDOUBLE then + LoadDouble(@ResBuff) + else if FT = typeSINGLE then + LoadSingle(@ResBuff) + else if FT = typeEXTENDED then + LoadExtended(@ResBuff) + else if FT = typeCURRENCY then + LoadCurrency(@ResBuff); +{$IFNDEF PAXARM_DEVICE} + ProcessRet32(R_AX, R_DX, RetSize, StackPtr); +{$ENDIF} +end; + +procedure FakeGlobal_00(P1, P2, P3: IntPax); +begin + CallGlobal(P1, P2, P3, 0, GetRBPPtr); +end; + +procedure FakeGlobal_01(P1, P2, P3: IntPax); +begin + CallGlobal(P1, P2, P3, 1, GetRBPPtr); +end; + +procedure FakeGlobal_02(P1, P2, P3: IntPax); +begin + CallGlobal(P1, P2, P3, 2, GetRBPPtr); +end; + +procedure FakeGlobal_03(P1, P2, P3: IntPax); +begin + CallGlobal(P1, P2, P3, 3, GetRBPPtr); +end; + +procedure FakeGlobal_04(P1, P2, P3: IntPax); +begin + CallGlobal(P1, P2, P3, 4, GetRBPPtr); +end; + +procedure FakeGlobal_05(P1, P2, P3: IntPax); +begin + CallGlobal(P1, P2, P3, 5, GetRBPPtr); +end; + +procedure FakeGlobal_06(P1, P2, P3: IntPax); +begin + CallGlobal(P1, P2, P3, 6, GetRBPPtr); +end; + +procedure FakeGlobal_07(P1, P2, P3: IntPax); +begin + CallGlobal(P1, P2, P3, 7, GetRBPPtr); +end; + +procedure FakeGlobal_08(P1, P2, P3: IntPax); +begin + CallGlobal(P1, P2, P3, 8, GetRBPPtr); +end; + +procedure FakeGlobal_09(P1, P2, P3: IntPax); +begin + CallGlobal(P1, P2, P3, 9, GetRBPPtr); +end; + +procedure FakeGlobal_10(P1, P2, P3: IntPax); +begin + CallGlobal(P1, P2, P3, 10, GetRBPPtr); +end; + +procedure FakeGlobal_11(P1, P2, P3: IntPax); +begin + CallGlobal(P1, P2, P3, 11, GetRBPPtr); +end; + +procedure FakeGlobal_12(P1, P2, P3: IntPax); +begin + CallGlobal(P1, P2, P3, 12, GetRBPPtr); +end; + +procedure FakeGlobal_13(P1, P2, P3: IntPax); +begin + CallGlobal(P1, P2, P3, 13, GetRBPPtr); +end; + +procedure FakeGlobal_14(P1, P2, P3: IntPax); +begin + CallGlobal(P1, P2, P3, 14, GetRBPPtr); +end; + +procedure FakeGlobal_15(P1, P2, P3: IntPax); +begin + CallGlobal(P1, P2, P3, 15, GetRBPPtr); +end; + +procedure FakeGlobal_16(P1, P2, P3: IntPax); +begin + CallGlobal(P1, P2, P3, 16, GetRBPPtr); +end; + +procedure FakeGlobal_17(P1, P2, P3: IntPax); +begin + CallGlobal(P1, P2, P3, 17, GetRBPPtr); +end; + +procedure FakeGlobal_18(P1, P2, P3: IntPax); +begin + CallGlobal(P1, P2, P3, 18, GetRBPPtr); +end; + +procedure FakeGlobal_19(P1, P2, P3: IntPax); +begin + CallGlobal(P1, P2, P3, 19, GetRBPPtr); +end; + +procedure FakeGlobal_20(P1, P2, P3: IntPax); +begin + CallGlobal(P1, P2, P3, 20, GetRBPPtr); +end; + +procedure FakeGlobal_21(P1, P2, P3: IntPax); +begin + CallGlobal(P1, P2, P3, 21, GetRBPPtr); +end; + +procedure FakeGlobal_22(P1, P2, P3: IntPax); +begin + CallGlobal(P1, P2, P3, 22, GetRBPPtr); +end; + +procedure FakeGlobal_23(P1, P2, P3: IntPax); +begin + CallGlobal(P1, P2, P3, 23, GetRBPPtr); +end; + +procedure FakeGlobal_24(P1, P2, P3: IntPax); +begin + CallGlobal(P1, P2, P3, 24, GetRBPPtr); +end; + +procedure FakeGlobal_25(P1, P2, P3: IntPax); +begin + CallGlobal(P1, P2, P3, 25, GetRBPPtr); +end; + +procedure FakeGlobal_26(P1, P2, P3: IntPax); +begin + CallGlobal(P1, P2, P3, 26, GetRBPPtr); +end; + +procedure FakeGlobal_27(P1, P2, P3: IntPax); +begin + CallGlobal(P1, P2, P3, 27, GetRBPPtr); +end; + +procedure FakeGlobal_28(P1, P2, P3: IntPax); +begin + CallGlobal(P1, P2, P3, 28, GetRBPPtr); +end; + +procedure FakeGlobal_29(P1, P2, P3: IntPax); +begin + CallGlobal(P1, P2, P3, 29, GetRBPPtr); +end; + +procedure FakeGlobal_30(P1, P2, P3: IntPax); +begin + CallGlobal(P1, P2, P3, 30, GetRBPPtr); +end; + +procedure FakeGlobal_31(P1, P2, P3: IntPax); +begin + CallGlobal(P1, P2, P3, 31, GetRBPPtr); +end; + +procedure FakeGlobal_32(P1, P2, P3: IntPax); +begin + CallGlobal(P1, P2, P3, 32, GetRBPPtr); +end; + +procedure FakeGlobal_33(P1, P2, P3: IntPax); +begin + CallGlobal(P1, P2, P3, 33, GetRBPPtr); +end; + +procedure FakeGlobal_34(P1, P2, P3: IntPax); +begin + CallGlobal(P1, P2, P3, 34, GetRBPPtr); +end; + +procedure FakeGlobal_35(P1, P2, P3: IntPax); +begin + CallGlobal(P1, P2, P3, 35, GetRBPPtr); +end; + +procedure FakeGlobal_36(P1, P2, P3: IntPax); +begin + CallGlobal(P1, P2, P3, 36, GetRBPPtr); +end; + +procedure FakeGlobal_37(P1, P2, P3: IntPax); +begin + CallGlobal(P1, P2, P3, 37, GetRBPPtr); +end; + +procedure FakeGlobal_38(P1, P2, P3: IntPax); +begin + CallGlobal(P1, P2, P3, 38, GetRBPPtr); +end; + +procedure FakeGlobal_39(P1, P2, P3: IntPax); +begin + CallGlobal(P1, P2, P3, 39, GetRBPPtr); +end; + +procedure FakeGlobal_40(P1, P2, P3: IntPax); +begin + CallGlobal(P1, P2, P3, 40, GetRBPPtr); +end; + +procedure FakeGlobal_41(P1, P2, P3: IntPax); +begin + CallGlobal(P1, P2, P3, 41, GetRBPPtr); +end; + +procedure FakeGlobal_42(P1, P2, P3: IntPax); +begin + CallGlobal(P1, P2, P3, 42, GetRBPPtr); +end; + +procedure FakeGlobal_43(P1, P2, P3: IntPax); +begin + CallGlobal(P1, P2, P3, 43, GetRBPPtr); +end; + +procedure FakeGlobal_44(P1, P2, P3: IntPax); +begin + CallGlobal(P1, P2, P3, 44, GetRBPPtr); +end; + +procedure FakeGlobal_45(P1, P2, P3: IntPax); +begin + CallGlobal(P1, P2, P3, 45, GetRBPPtr); +end; + +procedure FakeGlobal_46(P1, P2, P3: IntPax); +begin + CallGlobal(P1, P2, P3, 46, GetRBPPtr); +end; + +procedure FakeGlobal_47(P1, P2, P3: IntPax); +begin + CallGlobal(P1, P2, P3, 47, GetRBPPtr); +end; + +procedure FakeGlobal_48(P1, P2, P3: IntPax); +begin + CallGlobal(P1, P2, P3, 48, GetRBPPtr); +end; + +procedure FakeGlobal_49(P1, P2, P3: IntPax); +begin + CallGlobal(P1, P2, P3, 49, GetRBPPtr); +end; + +procedure FakeGlobal_50(P1, P2, P3: IntPax); +begin + CallGlobal(P1, P2, P3, 50, GetRBPPtr); +end; + +procedure FakeGlobal_51(P1, P2, P3: IntPax); +begin + CallGlobal(P1, P2, P3, 51, GetRBPPtr); +end; + +procedure FakeGlobal_52(P1, P2, P3: IntPax); +begin + CallGlobal(P1, P2, P3, 52, GetRBPPtr); +end; + +procedure FakeGlobal_53(P1, P2, P3: IntPax); +begin + CallGlobal(P1, P2, P3, 53, GetRBPPtr); +end; + +procedure FakeGlobal_54(P1, P2, P3: IntPax); +begin + CallGlobal(P1, P2, P3, 54, GetRBPPtr); +end; + +procedure FakeGlobal_55(P1, P2, P3: IntPax); +begin + CallGlobal(P1, P2, P3, 55, GetRBPPtr); +end; + +procedure FakeGlobal_56(P1, P2, P3: IntPax); +begin + CallGlobal(P1, P2, P3, 56, GetRBPPtr); +end; + +procedure FakeGlobal_57(P1, P2, P3: IntPax); +begin + CallGlobal(P1, P2, P3, 57, GetRBPPtr); +end; + +procedure FakeGlobal_58(P1, P2, P3: IntPax); +begin + CallGlobal(P1, P2, P3, 58, GetRBPPtr); +end; + +procedure FakeGlobal_59(P1, P2, P3: IntPax); +begin + CallGlobal(P1, P2, P3, 59, GetRBPPtr); +end; + +procedure FakeGlobal_60(P1, P2, P3: IntPax); +begin + CallGlobal(P1, P2, P3, 60, GetRBPPtr); +end; + +procedure FakeGlobal_61(P1, P2, P3: IntPax); +begin + CallGlobal(P1, P2, P3, 61, GetRBPPtr); +end; + +procedure FakeGlobal_62(P1, P2, P3: IntPax); +begin + CallGlobal(P1, P2, P3, 62, GetRBPPtr); +end; + +procedure FakeGlobal_63(P1, P2, P3: IntPax); +begin + CallGlobal(P1, P2, P3, 63, GetRBPPtr); +end; + +procedure FakeGlobal_64(P1, P2, P3: IntPax); +begin + CallGlobal(P1, P2, P3, 64, GetRBPPtr); +end; + +procedure FakeGlobal_65(P1, P2, P3: IntPax); +begin + CallGlobal(P1, P2, P3, 65, GetRBPPtr); +end; + +procedure FakeGlobal_66(P1, P2, P3: IntPax); +begin + CallGlobal(P1, P2, P3, 66, GetRBPPtr); +end; + +procedure FakeGlobal_67(P1, P2, P3: IntPax); +begin + CallGlobal(P1, P2, P3, 67, GetRBPPtr); +end; + +procedure FakeGlobal_68(P1, P2, P3: IntPax); +begin + CallGlobal(P1, P2, P3, 68, GetRBPPtr); +end; + +procedure FakeGlobal_69(P1, P2, P3: IntPax); +begin + CallGlobal(P1, P2, P3, 69, GetRBPPtr); +end; + +procedure FakeGlobal_70(P1, P2, P3: IntPax); +begin + CallGlobal(P1, P2, P3, 70, GetRBPPtr); +end; + +///////////// + +procedure CallHandler(P1: IntPax; + P2: IntPax; + P3: IntPax; + CommonMethodIndex: Integer; + StackPtr: Pointer); +var + C: TClass; + PaxInfo: PPaxInfo; + Runner: TBaseRunner; + Self: Pointer; + N, R_AX, R_DX, RetSize, FT: Integer; + ResBuff: array[0..SizeOf(Variant)-1] of Byte; +begin + {$IFDEF FPC} + if P1 = 0 then + Self := Pointer(P2) + else + Self := Pointer(P1); + {$ELSE} + Self := Pointer(P1); + {$ENDIF} + if IsDelphiClass(Self) then + C := TClass(Self) + else + C := TObject(Self).ClassType; + PaxInfo := GetPaxInfo(C); + Assert(PaxInfo <> nil); + Runner := TBaseRunner(PaxInfo^.Prog); + + N := Runner.ClassList[PaxInfo^.ClassIndex]. + ByteCodeMethodEntryList[CommonMethodIndex]; + + FillChar(ResBuff, SizeOf(ResBuff), 0); + RetSize := Runner.CallByteCode(N, Self, P1, P3, P2, 0, 0, + StackPtr, @ResBuff, FT); + R_AX := 0; + R_DX := 0; +{$IFDEF PAXARM} + if FT in (OrdinalTypes + [typeUNICSTRING, typeVARIANT, + typeOLEVARIANT, + typePOINTER, typeCLASS, typeCLASSREF, typeDYNARRAY, + typeINTERFACE]) then +{$ELSE} + if FT in (OrdinalTypes + [typeANSISTRING, typeWIDESTRING, typeUNICSTRING, typeVARIANT, + typeOLEVARIANT, + typePOINTER, typeCLASS, typeCLASSREF, typeDYNARRAY, + typeINTERFACE]) then +{$ENDIF} + begin + Move(ResBuff, R_AX, Types.GetSize(FT)); +{$IFDEF ARC} +{ + if FT = typeCLASS then + if R_AX <> 0 then + begin + if TObject(R_AX).RefCount > 1 then + TObject(R_AX).__ObjRelease + else + begin + Self := ShiftPointer(Pointer(R_AX), SizeOf(Pointer)); + Pointer(Self^) := nil; + end; + end; +} +{$ENDIF} + end + else if FT = typeINT64 then + begin + Move(ResBuff, R_AX, SizeOf(Integer)); + Move(ResBuff[SizeOf(Integer)], R_DX, SizeOf(Integer)); + end + else if FT = typeDOUBLE then + LoadDouble(@ResBuff) + else if FT = typeSINGLE then + LoadSingle(@ResBuff) + else if FT = typeEXTENDED then + LoadExtended(@ResBuff) + else if FT = typeCURRENCY then + LoadCurrency(@ResBuff); +{$IFNDEF PAXARM_DEVICE} + ProcessRet32(R_AX, R_DX, RetSize, StackPtr); +{$ENDIF} +end; + +procedure FakeHandler_00(P1, P2, P3: IntPax); +begin + CallHandler(P1, P2, P3, 0, GetRBPPtr); +end; + +procedure FakeHandler_01(P1, P2, P3: IntPax); +begin + CallHandler(P1, P2, P3, 1, GetRBPPtr); +end; + +procedure FakeHandler_02(P1, P2, P3: IntPax); +begin + CallHandler(P1, P2, P3, 2, GetRBPPtr); +end; + +procedure FakeHandler_03(P1, P2, P3: IntPax); +begin + CallHandler(P1, P2, P3, 3, GetRBPPtr); +end; + +procedure FakeHandler_04(P1, P2, P3: IntPax); +begin + CallHandler(P1, P2, P3, 4, GetRBPPtr); +end; + +procedure FakeHandler_05(P1, P2, P3: IntPax); +begin + CallHandler(P1, P2, P3, 5, GetRBPPtr); +end; + +procedure FakeHandler_06(P1, P2, P3: IntPax); +begin + CallHandler(P1, P2, P3, 6, GetRBPPtr); +end; + +procedure FakeHandler_07(P1, P2, P3: IntPax); +begin + CallHandler(P1, P2, P3, 7, GetRBPPtr); +end; + +procedure FakeHandler_08(P1, P2, P3: IntPax); +begin + CallHandler(P1, P2, P3, 8, GetRBPPtr); +end; + +procedure FakeHandler_09(P1, P2, P3: IntPax); +begin + CallHandler(P1, P2, P3, 9, GetRBPPtr); +end; + +procedure FakeHandler_10(P1, P2, P3: IntPax); +begin + CallHandler(P1, P2, P3, 10, GetRBPPtr); +end; + +procedure FakeHandler_11(P1, P2, P3: IntPax); +begin + CallHandler(P1, P2, P3, 11, GetRBPPtr); +end; + +procedure FakeHandler_12(P1, P2, P3: IntPax); +begin + CallHandler(P1, P2, P3, 12, GetRBPPtr); +end; + +procedure FakeHandler_13(P1, P2, P3: IntPax); +begin + CallHandler(P1, P2, P3, 13, GetRBPPtr); +end; + +procedure FakeHandler_14(P1, P2, P3: IntPax); +begin + CallHandler(P1, P2, P3, 14, GetRBPPtr); +end; + +procedure FakeHandler_15(P1, P2, P3: IntPax); +begin + CallHandler(P1, P2, P3, 15, GetRBPPtr); +end; + +procedure FakeHandler_16(P1, P2, P3: IntPax); +begin + CallHandler(P1, P2, P3, 16, GetRBPPtr); +end; + +procedure FakeHandler_17(P1, P2, P3: IntPax); +begin + CallHandler(P1, P2, P3, 17, GetRBPPtr); +end; + +procedure FakeHandler_18(P1, P2, P3: IntPax); +begin + CallHandler(P1, P2, P3, 18, GetRBPPtr); +end; + +procedure FakeHandler_19(P1, P2, P3: IntPax); +begin + CallHandler(P1, P2, P3, 19, GetRBPPtr); +end; + +procedure FakeHandler_20(P1, P2, P3: IntPax); +begin + CallHandler(P1, P2, P3, 20, GetRBPPtr); +end; + +procedure FakeHandler_21(P1, P2, P3: IntPax); +begin + CallHandler(P1, P2, P3, 21, GetRBPPtr); +end; + +procedure FakeHandler_22(P1, P2, P3: IntPax); +begin + CallHandler(P1, P2, P3, 22, GetRBPPtr); +end; + +procedure FakeHandler_23(P1, P2, P3: IntPax); +begin + CallHandler(P1, P2, P3, 23, GetRBPPtr); +end; + +procedure FakeHandler_24(P1, P2, P3: IntPax); +begin + CallHandler(P1, P2, P3, 24, GetRBPPtr); +end; + +procedure FakeHandler_25(P1, P2, P3: IntPax); +begin + CallHandler(P1, P2, P3, 25, GetRBPPtr); +end; + +procedure FakeHandler_26(P1, P2, P3: IntPax); +begin + CallHandler(P1, P2, P3, 26, GetRBPPtr); +end; + +procedure FakeHandler_27(P1, P2, P3: IntPax); +begin + CallHandler(P1, P2, P3, 27, GetRBPPtr); +end; + +procedure FakeHandler_28(P1, P2, P3: IntPax); +begin + CallHandler(P1, P2, P3, 28, GetRBPPtr); +end; + +procedure FakeHandler_29(P1, P2, P3: IntPax); +begin + CallHandler(P1, P2, P3, 29, GetRBPPtr); +end; + +procedure FakeHandler_30(P1, P2, P3: IntPax); +begin + CallHandler(P1, P2, P3, 30, GetRBPPtr); +end; + +procedure FakeHandler_31(P1, P2, P3: IntPax); +begin + CallHandler(P1, P2, P3, 31, GetRBPPtr); +end; + +procedure FakeHandler_32(P1, P2, P3: IntPax); +begin + CallHandler(P1, P2, P3, 32, GetRBPPtr); +end; + +procedure FakeHandler_33(P1, P2, P3: IntPax); +begin + CallHandler(P1, P2, P3, 33, GetRBPPtr); +end; + +procedure FakeHandler_34(P1, P2, P3: IntPax); +begin + CallHandler(P1, P2, P3, 34, GetRBPPtr); +end; + +procedure FakeHandler_35(P1, P2, P3: IntPax); +begin + CallHandler(P1, P2, P3, 35, GetRBPPtr); +end; + +procedure FakeHandler_36(P1, P2, P3: IntPax); +begin + CallHandler(P1, P2, P3, 36, GetRBPPtr); +end; + +procedure FakeHandler_37(P1, P2, P3: IntPax); +begin + CallHandler(P1, P2, P3, 37, GetRBPPtr); +end; + +procedure FakeHandler_38(P1, P2, P3: IntPax); +begin + CallHandler(P1, P2, P3, 38, GetRBPPtr); +end; + +procedure FakeHandler_39(P1, P2, P3: IntPax); +begin + CallHandler(P1, P2, P3, 39, GetRBPPtr); +end; + +procedure FakeHandler_40(P1, P2, P3: IntPax); +begin + CallHandler(P1, P2, P3, 40, GetRBPPtr); +end; + +procedure FakeHandler_41(P1, P2, P3: IntPax); +begin + CallHandler(P1, P2, P3, 41, GetRBPPtr); +end; + +procedure FakeHandler_42(P1, P2, P3: IntPax); +begin + CallHandler(P1, P2, P3, 42, GetRBPPtr); +end; + +procedure FakeHandler_43(P1, P2, P3: IntPax); +begin + CallHandler(P1, P2, P3, 43, GetRBPPtr); +end; + +procedure FakeHandler_44(P1, P2, P3: IntPax); +begin + CallHandler(P1, P2, P3, 44, GetRBPPtr); +end; + +procedure FakeHandler_45(P1, P2, P3: IntPax); +begin + CallHandler(P1, P2, P3, 45, GetRBPPtr); +end; + +procedure FakeHandler_46(P1, P2, P3: IntPax); +begin + CallHandler(P1, P2, P3, 46, GetRBPPtr); +end; + +procedure FakeHandler_47(P1, P2, P3: IntPax); +begin + CallHandler(P1, P2, P3, 47, GetRBPPtr); +end; + +procedure FakeHandler_48(P1, P2, P3: IntPax); +begin + CallHandler(P1, P2, P3, 48, GetRBPPtr); +end; + +procedure FakeHandler_49(P1, P2, P3: IntPax); +begin + CallHandler(P1, P2, P3, 49, GetRBPPtr); +end; + +procedure FakeHandler_50(P1, P2, P3: IntPax); +begin + CallHandler(P1, P2, P3, 50, GetRBPPtr); +end; + +procedure FakeHandler_51(P1, P2, P3: IntPax); +begin + CallHandler(P1, P2, P3, 51, GetRBPPtr); +end; + +procedure FakeHandler_52(P1, P2, P3: IntPax); +begin + CallHandler(P1, P2, P3, 52, GetRBPPtr); +end; + +procedure FakeHandler_53(P1, P2, P3: IntPax); +begin + CallHandler(P1, P2, P3, 53, GetRBPPtr); +end; + +procedure FakeHandler_54(P1, P2, P3: IntPax); +begin + CallHandler(P1, P2, P3, 54, GetRBPPtr); +end; + +procedure FakeHandler_55(P1, P2, P3: IntPax); +begin + CallHandler(P1, P2, P3, 55, GetRBPPtr); +end; + +procedure FakeHandler_56(P1, P2, P3: IntPax); +begin + CallHandler(P1, P2, P3, 56, GetRBPPtr); +end; + +procedure FakeHandler_57(P1, P2, P3: IntPax); +begin + CallHandler(P1, P2, P3, 57, GetRBPPtr); +end; + +procedure FakeHandler_58(P1, P2, P3: IntPax); +begin + CallHandler(P1, P2, P3, 58, GetRBPPtr); +end; + +procedure FakeHandler_59(P1, P2, P3: IntPax); +begin + CallHandler(P1, P2, P3, 59, GetRBPPtr); +end; + +procedure FakeHandler_60(P1, P2, P3: IntPax); +begin + CallHandler(P1, P2, P3, 60, GetRBPPtr); +end; + +procedure FakeHandler_61(P1, P2, P3: IntPax); +begin + CallHandler(P1, P2, P3, 61, GetRBPPtr); +end; + +procedure FakeHandler_62(P1, P2, P3: IntPax); +begin + CallHandler(P1, P2, P3, 62, GetRBPPtr); +end; + +procedure FakeHandler_63(P1, P2, P3: IntPax); +begin + CallHandler(P1, P2, P3, 63, GetRBPPtr); +end; + +procedure FakeHandler_64(P1, P2, P3: IntPax); +begin + CallHandler(P1, P2, P3, 64, GetRBPPtr); +end; + +procedure FakeHandler_65(P1, P2, P3: IntPax); +begin + CallHandler(P1, P2, P3, 65, GetRBPPtr); +end; + +procedure FakeHandler_66(P1, P2, P3: IntPax); +begin + CallHandler(P1, P2, P3, 66, GetRBPPtr); +end; + +procedure FakeHandler_67(P1, P2, P3: IntPax); +begin + CallHandler(P1, P2, P3, 67, GetRBPPtr); +end; + +procedure FakeHandler_68(P1, P2, P3: IntPax); +begin + CallHandler(P1, P2, P3, 68, GetRBPPtr); +end; + +procedure FakeHandler_69(P1, P2, P3: IntPax); +begin + CallHandler(P1, P2, P3, 69, GetRBPPtr); +end; + +procedure FakeHandler_70(P1, P2, P3: IntPax); +begin + CallHandler(P1, P2, P3, 70, GetRBPPtr); +end; + +{$ENDIF} + +type + TMyInterfacedObject = class(TInterfacedObject); + +function fake_AddRefGen(I: Pointer; Index: Integer): Integer; stdcall; +var + N, Offset: Integer; +begin + N := CurrRunner.ByteCodeInterfaceSetupList[Index]; + Offset := CurrRunner.GetInterfaceToObjectOffset(N); + I := ShiftPointer(I, Offset); + + result := TMyInterfacedObject(I)._AddRef; +end; + +function fake_ReleaseGen(I: Pointer; Index: Integer): Integer; stdcall; +var + N, Offset: Integer; +begin + N := CurrRunner.ByteCodeInterfaceSetupList[Index]; + Offset := CurrRunner.GetInterfaceToObjectOffset(N); + I := ShiftPointer(I, Offset); + + result := TMyInterfacedObject(I)._Release; +end; + +function fake_AddRef00(I: Pointer): Integer; stdcall; +begin + result := fake_AddRefGen(I, 00); +end; + +function fake_AddRef01(I: Pointer): Integer; stdcall; +begin + result := fake_AddRefGen(I, 01); +end; + +function fake_AddRef02(I: Pointer): Integer; stdcall; +begin + result := fake_AddRefGen(I, 02); +end; + +function fake_AddRef03(I: Pointer): Integer; stdcall; +begin + result := fake_AddRefGen(I, 03); +end; + +function fake_AddRef04(I: Pointer): Integer; stdcall; +begin + result := fake_AddRefGen(I, 04); +end; + +function fake_AddRef05(I: Pointer): Integer; stdcall; +begin + result := fake_AddRefGen(I, 05); +end; + +function fake_AddRef06(I: Pointer): Integer; stdcall; +begin + result := fake_AddRefGen(I, 06); +end; + +function fake_AddRef07(I: Pointer): Integer; stdcall; +begin + result := fake_AddRefGen(I, 07); +end; + +function fake_AddRef08(I: Pointer): Integer; stdcall; +begin + result := fake_AddRefGen(I, 08); +end; + +function fake_AddRef09(I: Pointer): Integer; stdcall; +begin + result := fake_AddRefGen(I, 09); +end; + +function fake_AddRef10(I: Pointer): Integer; stdcall; +begin + result := fake_AddRefGen(I, 10); +end; + +function fake_Release00(I: Pointer): Integer; stdcall; +begin + result := fake_ReleaseGen(I, 00); +end; + +function fake_Release01(I: Pointer): Integer; stdcall; +begin + result := fake_ReleaseGen(I, 01); +end; + +function fake_Release02(I: Pointer): Integer; stdcall; +begin + result := fake_ReleaseGen(I, 02); +end; + +function fake_Release03(I: Pointer): Integer; stdcall; +begin + result := fake_ReleaseGen(I, 03); +end; + +function fake_Release04(I: Pointer): Integer; stdcall; +begin + result := fake_ReleaseGen(I, 04); +end; + +function fake_Release05(I: Pointer): Integer; stdcall; +begin + result := fake_ReleaseGen(I, 05); +end; + +function fake_Release06(I: Pointer): Integer; stdcall; +begin + result := fake_ReleaseGen(I, 06); +end; + +function fake_Release07(I: Pointer): Integer; stdcall; +begin + result := fake_ReleaseGen(I, 07); +end; + +function fake_Release08(I: Pointer): Integer; stdcall; +begin + result := fake_ReleaseGen(I, 08); +end; + +function fake_Release09(I: Pointer): Integer; stdcall; +begin + result := fake_ReleaseGen(I, 09); +end; + +function fake_Release10(I: Pointer): Integer; stdcall; +begin + result := fake_ReleaseGen(I, 10); +end; + +function GetFakeAddRefAddress(Index: Integer): Pointer; +begin + result := FakeAddRefAddressList[Index]; +end; + +function GetFakeReleaseAddress(Index: Integer): Pointer; +begin + result := FakeReleaseAddressList[Index]; +end; + +function GetFakeHandlerAddress(Index: Integer): Pointer; +begin + result := FakeHandlerAddressList[Index]; +end; + +function GetFakeGlobalAddress(Index: Integer): Pointer; +begin + result := FakeGlobalAddressList[Index]; +end; + +procedure InitFakeAddRefMethods; +begin + FakeAddRefAddressList[00] := @ fake_AddRef00; + FakeAddRefAddressList[01] := @ fake_AddRef01; + FakeAddRefAddressList[02] := @ fake_AddRef02; + FakeAddRefAddressList[03] := @ fake_AddRef03; + FakeAddRefAddressList[04] := @ fake_AddRef04; + FakeAddRefAddressList[05] := @ fake_AddRef05; + FakeAddRefAddressList[06] := @ fake_AddRef06; + FakeAddRefAddressList[07] := @ fake_AddRef07; + FakeAddRefAddressList[08] := @ fake_AddRef08; + FakeAddRefAddressList[09] := @ fake_AddRef09; + FakeAddRefAddressList[10] := @ fake_AddRef10; +end; + +procedure InitFakeReleaseMethods; +begin + FakeReleaseAddressList[00] := @ fake_Release00; + FakeReleaseAddressList[01] := @ fake_Release01; + FakeReleaseAddressList[02] := @ fake_Release02; + FakeReleaseAddressList[03] := @ fake_Release03; + FakeReleaseAddressList[04] := @ fake_Release04; + FakeReleaseAddressList[05] := @ fake_Release05; + FakeReleaseAddressList[06] := @ fake_Release06; + FakeReleaseAddressList[07] := @ fake_Release07; + FakeReleaseAddressList[08] := @ fake_Release08; + FakeReleaseAddressList[09] := @ fake_Release09; + FakeReleaseAddressList[10] := @ fake_Release10; +end; + +procedure InitFakeMethods; +begin + FakeHandlerAddressList[00] := @ FakeHandler_00; + FakeHandlerAddressList[01] := @ FakeHandler_01; + FakeHandlerAddressList[02] := @ FakeHandler_02; + FakeHandlerAddressList[03] := @ FakeHandler_03; + FakeHandlerAddressList[04] := @ FakeHandler_04; + FakeHandlerAddressList[05] := @ FakeHandler_05; + FakeHandlerAddressList[06] := @ FakeHandler_06; + FakeHandlerAddressList[07] := @ FakeHandler_07; + FakeHandlerAddressList[08] := @ FakeHandler_08; + FakeHandlerAddressList[09] := @ FakeHandler_09; + FakeHandlerAddressList[10] := @ FakeHandler_10; + FakeHandlerAddressList[11] := @ FakeHandler_11; + FakeHandlerAddressList[12] := @ FakeHandler_12; + FakeHandlerAddressList[13] := @ FakeHandler_13; + FakeHandlerAddressList[14] := @ FakeHandler_14; + FakeHandlerAddressList[15] := @ FakeHandler_15; + FakeHandlerAddressList[16] := @ FakeHandler_16; + FakeHandlerAddressList[17] := @ FakeHandler_17; + FakeHandlerAddressList[18] := @ FakeHandler_18; + FakeHandlerAddressList[19] := @ FakeHandler_19; + FakeHandlerAddressList[20] := @ FakeHandler_20; + FakeHandlerAddressList[21] := @ FakeHandler_21; + FakeHandlerAddressList[22] := @ FakeHandler_22; + FakeHandlerAddressList[23] := @ FakeHandler_23; + FakeHandlerAddressList[24] := @ FakeHandler_24; + FakeHandlerAddressList[25] := @ FakeHandler_25; + FakeHandlerAddressList[26] := @ FakeHandler_26; + FakeHandlerAddressList[27] := @ FakeHandler_27; + FakeHandlerAddressList[28] := @ FakeHandler_28; + FakeHandlerAddressList[29] := @ FakeHandler_29; + FakeHandlerAddressList[30] := @ FakeHandler_30; + FakeHandlerAddressList[31] := @ FakeHandler_31; + FakeHandlerAddressList[32] := @ FakeHandler_32; + FakeHandlerAddressList[33] := @ FakeHandler_33; + FakeHandlerAddressList[34] := @ FakeHandler_34; + FakeHandlerAddressList[35] := @ FakeHandler_35; + FakeHandlerAddressList[36] := @ FakeHandler_36; + FakeHandlerAddressList[37] := @ FakeHandler_37; + FakeHandlerAddressList[38] := @ FakeHandler_38; + FakeHandlerAddressList[39] := @ FakeHandler_39; + FakeHandlerAddressList[40] := @ FakeHandler_40; + FakeHandlerAddressList[41] := @ FakeHandler_41; + FakeHandlerAddressList[42] := @ FakeHandler_42; + FakeHandlerAddressList[43] := @ FakeHandler_43; + FakeHandlerAddressList[44] := @ FakeHandler_44; + FakeHandlerAddressList[45] := @ FakeHandler_45; + FakeHandlerAddressList[46] := @ FakeHandler_46; + FakeHandlerAddressList[47] := @ FakeHandler_47; + FakeHandlerAddressList[48] := @ FakeHandler_48; + FakeHandlerAddressList[49] := @ FakeHandler_49; + FakeHandlerAddressList[50] := @ FakeHandler_50; + FakeHandlerAddressList[51] := @ FakeHandler_51; + FakeHandlerAddressList[52] := @ FakeHandler_52; + FakeHandlerAddressList[53] := @ FakeHandler_53; + FakeHandlerAddressList[54] := @ FakeHandler_54; + FakeHandlerAddressList[55] := @ FakeHandler_55; + FakeHandlerAddressList[56] := @ FakeHandler_56; + FakeHandlerAddressList[57] := @ FakeHandler_57; + FakeHandlerAddressList[58] := @ FakeHandler_58; + FakeHandlerAddressList[59] := @ FakeHandler_59; + FakeHandlerAddressList[60] := @ FakeHandler_60; + FakeHandlerAddressList[61] := @ FakeHandler_61; + FakeHandlerAddressList[62] := @ FakeHandler_62; + FakeHandlerAddressList[63] := @ FakeHandler_63; + FakeHandlerAddressList[64] := @ FakeHandler_64; + FakeHandlerAddressList[65] := @ FakeHandler_65; + FakeHandlerAddressList[66] := @ FakeHandler_66; + FakeHandlerAddressList[67] := @ FakeHandler_67; + FakeHandlerAddressList[68] := @ FakeHandler_68; + FakeHandlerAddressList[69] := @ FakeHandler_69; + FakeHandlerAddressList[70] := @ FakeHandler_70; +end; + +procedure InitFakeGlobals; +begin + FakeGlobalAddressList[00] := @ FakeGlobal_00; + FakeGlobalAddressList[01] := @ FakeGlobal_01; + FakeGlobalAddressList[02] := @ FakeGlobal_02; + FakeGlobalAddressList[03] := @ FakeGlobal_03; + FakeGlobalAddressList[04] := @ FakeGlobal_04; + FakeGlobalAddressList[05] := @ FakeGlobal_05; + FakeGlobalAddressList[06] := @ FakeGlobal_06; + FakeGlobalAddressList[07] := @ FakeGlobal_07; + FakeGlobalAddressList[08] := @ FakeGlobal_08; + FakeGlobalAddressList[09] := @ FakeGlobal_09; + FakeGlobalAddressList[10] := @ FakeGlobal_10; + FakeGlobalAddressList[11] := @ FakeGlobal_11; + FakeGlobalAddressList[12] := @ FakeGlobal_12; + FakeGlobalAddressList[13] := @ FakeGlobal_13; + FakeGlobalAddressList[14] := @ FakeGlobal_14; + FakeGlobalAddressList[15] := @ FakeGlobal_15; + FakeGlobalAddressList[16] := @ FakeGlobal_16; + FakeGlobalAddressList[17] := @ FakeGlobal_17; + FakeGlobalAddressList[18] := @ FakeGlobal_18; + FakeGlobalAddressList[19] := @ FakeGlobal_19; + FakeGlobalAddressList[20] := @ FakeGlobal_20; + FakeGlobalAddressList[21] := @ FakeGlobal_21; + FakeGlobalAddressList[22] := @ FakeGlobal_22; + FakeGlobalAddressList[23] := @ FakeGlobal_23; + FakeGlobalAddressList[24] := @ FakeGlobal_24; + FakeGlobalAddressList[25] := @ FakeGlobal_25; + FakeGlobalAddressList[26] := @ FakeGlobal_26; + FakeGlobalAddressList[27] := @ FakeGlobal_27; + FakeGlobalAddressList[28] := @ FakeGlobal_28; + FakeGlobalAddressList[29] := @ FakeGlobal_29; + FakeGlobalAddressList[30] := @ FakeGlobal_30; + FakeGlobalAddressList[31] := @ FakeGlobal_31; + FakeGlobalAddressList[32] := @ FakeGlobal_32; + FakeGlobalAddressList[33] := @ FakeGlobal_33; + FakeGlobalAddressList[34] := @ FakeGlobal_34; + FakeGlobalAddressList[35] := @ FakeGlobal_35; + FakeGlobalAddressList[36] := @ FakeGlobal_36; + FakeGlobalAddressList[37] := @ FakeGlobal_37; + FakeGlobalAddressList[38] := @ FakeGlobal_38; + FakeGlobalAddressList[39] := @ FakeGlobal_39; + FakeGlobalAddressList[40] := @ FakeGlobal_40; + FakeGlobalAddressList[41] := @ FakeGlobal_41; + FakeGlobalAddressList[42] := @ FakeGlobal_42; + FakeGlobalAddressList[43] := @ FakeGlobal_43; + FakeGlobalAddressList[44] := @ FakeGlobal_44; + FakeGlobalAddressList[45] := @ FakeGlobal_45; + FakeGlobalAddressList[46] := @ FakeGlobal_46; + FakeGlobalAddressList[47] := @ FakeGlobal_47; + FakeGlobalAddressList[48] := @ FakeGlobal_48; + FakeGlobalAddressList[49] := @ FakeGlobal_49; + FakeGlobalAddressList[50] := @ FakeGlobal_50; + FakeGlobalAddressList[51] := @ FakeGlobal_51; + FakeGlobalAddressList[52] := @ FakeGlobal_52; + FakeGlobalAddressList[53] := @ FakeGlobal_53; + FakeGlobalAddressList[54] := @ FakeGlobal_54; + FakeGlobalAddressList[55] := @ FakeGlobal_55; + FakeGlobalAddressList[56] := @ FakeGlobal_56; + FakeGlobalAddressList[57] := @ FakeGlobal_57; + FakeGlobalAddressList[58] := @ FakeGlobal_58; + FakeGlobalAddressList[59] := @ FakeGlobal_59; + FakeGlobalAddressList[60] := @ FakeGlobal_60; + FakeGlobalAddressList[61] := @ FakeGlobal_61; + FakeGlobalAddressList[62] := @ FakeGlobal_62; + FakeGlobalAddressList[63] := @ FakeGlobal_63; + FakeGlobalAddressList[64] := @ FakeGlobal_64; + FakeGlobalAddressList[65] := @ FakeGlobal_65; + FakeGlobalAddressList[66] := @ FakeGlobal_66; + FakeGlobalAddressList[67] := @ FakeGlobal_67; + FakeGlobalAddressList[68] := @ FakeGlobal_68; + FakeGlobalAddressList[69] := @ FakeGlobal_69; + FakeGlobalAddressList[70] := @ FakeGlobal_70; +end; + +initialization + + InitFakeAddRefMethods; + InitFakeReleaseMethods; + InitFakeMethods; + InitFakeGlobals; + +end. + diff --git a/Sources/PAXCOMP_BYTECODE.pas b/Sources/PAXCOMP_BYTECODE.pas new file mode 100644 index 0000000..240a1fa --- /dev/null +++ b/Sources/PAXCOMP_BYTECODE.pas @@ -0,0 +1,32194 @@ +/// ///////////////////////////////////////////////////////////////////////// +// PaxCompiler +// Site: http://www.paxcompiler.com +// Author: Alexander Baranovsky (paxscript@gmail.com) +// ======================================================================== +// Copyright (c) Alexander Baranovsky, 2006-2014. All rights reserved. +// Code Version: 4.2 +// ======================================================================== +// Unit: PAXCOMP_BYTECODE.pas +// ======================================================================== +/// ///////////////////////////////////////////////////////////////////////// + +{$I PaxCompiler.def} +unit PAXCOMP_BYTECODE; + +interface + +uses {$I uses.def} + TypInfo, + System.Types, + Classes, + SysUtils, + PAXCOMP_CONSTANTS, + PAXCOMP_TYPES, + PAXCOMP_SYS, + PAXCOMP_VAROBJECT, + PAXCOMP_MODULE, + PAXCOMP_SYMBOL_REC, + PAXCOMP_BASESYMBOL_TABLE, + PAXCOMP_SYMBOL_TABLE, + PAXCOMP_MAP, + PAXCOMP_TYPEINFO, + PAXCOMP_RTI, + PAXCOMP_CLASSLST, + PAXCOMP_GENERIC, + PAXCOMP_FORBID; + +type + TCode = class; + + TCodeRec = class + public + Op: Integer; + Arg1: Integer; + Arg2: Integer; + Res: Integer; + GenOp: Integer; + Language: Integer; + SavedSubId: Integer; + ModuleNum: Integer; + IsStatic: Boolean; + Upcase: Boolean; + SwappedArgs: Boolean; + LinePos: Integer; + CodeRecTag: Integer; + PatternFieldId: Integer; + SavedLevel: Integer; + OwnerObject: TCode; + + BreakLabel: Integer; + ContinueLabel: Integer; + LoopLabel: Integer; + + IsInherited: Boolean; + + constructor Create(i_OP: Integer; Code: TCode); + procedure SwapArguments; + function Clone: TCodeRec; + procedure SaveToStream(S: TStream); + procedure LoadFromStream(S: TStream); + end; + +{$IFDEF ARC} + + TCodeRecList = class(TList); +{$ELSE} + TCodeRecList = TList; +{$ENDIF} + TCodeProc = procedure of object; + + TCode = class + private + ProcList: array of TCodeProc; + + generic_binary_operators: TIntegerList; + generic_unary_operators: TIntegerList; + map_list: TIntegerList; + context_list: TIntegerStack; + + SignTypeCast: Boolean; + + CRT_JS_FUNC_OBJECT_SWITCH: Boolean; + + temp_var_list: TAssocIntegers; + + SkipCheckFinal: Boolean; + NoOverloadSearch: Boolean; + + procedure CreateUsingList(J: Integer); + function GetPAX64: Boolean; + function GetSizeOfPointer: Integer; + function CheckAssignment(Arg1, Arg2: Integer): Boolean; + function LookupTempVarId(Level, FinTypeId: Integer): Integer; + function InsertSubCall(I: Integer): Boolean; + procedure DiscardImport; + function IsExplicitOff: Boolean; + function CallExpected(ResId: Integer): Boolean; + function InheritedExpected(ResId: Integer): Boolean; + + function PrevRec(J: Integer): TCodeRec; + function NextRec(J: Integer): TCodeRec; + + function PrevN(J: Integer): Integer; + function PrevPrevRec(J: Integer): TCodeRec; + procedure RemoveDeclaredVar(Id: Integer); + + procedure MoveLValue(N_ASS: Integer); + procedure MoveRValue(N_ASS: Integer); + + function IsValidOP(Op: Integer): Boolean; + + function GetRecord(I: Integer): TCodeRec; + procedure SetRecord(I: Integer; value: TCodeRec); + + function ExistsOrdinalRelationalOperator(T1, T2: Integer): Boolean; + function MatchSetTypes(T1, T2: Integer): Boolean; + + function GetDeclaredVar(const VarName: String; SubId: Integer; + Upcase: Boolean; CurrPos: Integer): Integer; + + function EvalFrameworkType(const S: String): Integer; + function CreateConst(TypeId: Integer; const value: Variant; + ValueType: Integer = 0): Integer; + function NewTempVar(Level, TypeId: Integer): Integer; + function NewField(const FName: String; TypeId, OwnerId: Integer): Integer; + function CreateWideCharVar(Level: Integer): Integer; + function CreateBooleanVar(Level: Integer): Integer; + function CreateByteBoolVar(Level: Integer): Integer; + function CreateWordBoolVar(Level: Integer): Integer; + function CreateLongBoolVar(Level: Integer): Integer; + function CreateIntegerVar(Level: Integer): Integer; + function CreatePointerVar(Level: Integer): Integer; + function CreateCardinalVar(Level: Integer): Integer; + function CreateSmallIntVar(Level: Integer): Integer; + function CreateShortIntVar(Level: Integer): Integer; + function CreateByteVar(Level: Integer): Integer; + function CreateWordVar(Level: Integer): Integer; + function CreateDoubleVar(Level: Integer): Integer; + function CreateCurrencyVar(Level: Integer): Integer; + function CreateSingleVar(Level: Integer): Integer; + function CreateExtendedVar(Level: Integer): Integer; + function CreateInt64Var(Level: Integer): Integer; + function CreateUInt64Var(Level: Integer): Integer; +{$IFNDEF PAXARM} + function CreateAnsiCharVar(Level: Integer): Integer; + function CreateStringVar(Level: Integer): Integer; + function CreateWideStringVar(Level: Integer): Integer; + function CreateShortStringVar(Level, TypeId: Integer): Integer; +{$ENDIF} + function CreateInterfaceVar(Level: Integer): Integer; + function CreateClassVar(Level: Integer): Integer; + function CreateUnicStringVar(Level: Integer): Integer; + function CreateRecordVar(Level, TypeId: Integer): Integer; + function CreateDynarrayVar(Level, TypeId: Integer): Integer; + function CreateVariantVar(Level: Integer): Integer; + function CreateOleVariantVar(Level: Integer): Integer; + + function InsertImplicitConversion(I, Arg, RecordTypeId, + ResultTypeId: Integer): TCodeRec; + + function InsertExplicitConversion(I, RecordTypeId, ResultTypeId: Integer) + : TCodeRec; + + function InsertConversionToInterface(I: Integer; Arg: Integer; + InterfaceTypeId: Integer): TCodeRec; + function InsertConversionToClass(I: Integer; Arg: Integer; + ClassTypeId: Integer): TCodeRec; + function InsertConversionToFrameworkClass(I: Integer; Arg: Integer; + ClassTypeId: Integer): TCodeRec; + + function InsertDestroyLocalVar(I: Integer; Id: Integer): TCodeRec; + function InsertConversionToWideChar(I: Integer; Arg: Integer): TCodeRec; + function InsertConversionToBoolean(I: Integer; Arg: Integer): TCodeRec; + function InsertConversionToByteBool(I: Integer; Arg: Integer): TCodeRec; + function InsertConversionToWordBool(I: Integer; Arg: Integer): TCodeRec; + function InsertConversionToLongBool(I: Integer; Arg: Integer): TCodeRec; + function InsertConversionToInteger(I: Integer; Arg: Integer): TCodeRec; + function InsertConversionToCardinal(I: Integer; Arg: Integer): TCodeRec; + function InsertConversionToByte(I: Integer; Arg: Integer): TCodeRec; + function InsertConversionToWord(I: Integer; Arg: Integer): TCodeRec; + function InsertConversionToShortInt(I: Integer; Arg: Integer): TCodeRec; + function InsertConversionToSmallInt(I: Integer; Arg: Integer): TCodeRec; + + function InsertConversionToDouble(I: Integer; Arg: Integer): TCodeRec; + function InsertConversionToSingle(I: Integer; Arg: Integer): TCodeRec; + function InsertConversionToExtended(I: Integer; Arg: Integer): TCodeRec; + function InsertConversionToCurrency(I: Integer; Arg: Integer): TCodeRec; +{$IFNDEF PAXARM} + function InsertConversionToAnsiChar(I: Integer; Arg: Integer): TCodeRec; + function InsertConversionToAnsiString(I: Integer; Arg: Integer; + Lang: Integer = PASCAL_LANGUAGE): TCodeRec; + function InsertConversionToWideString(I: Integer; Arg: Integer): TCodeRec; + function InsertConversionToShortString(I: Integer; Arg: Integer): TCodeRec; +{$ENDIF} + function InsertConversionToUnicString(I: Integer; Arg: Integer; + Lang: Integer = PASCAL_LANGUAGE): TCodeRec; + function InsertConversionToVariant(I: Integer; Arg: Integer): TCodeRec; + function InsertConversionToOleVariant(I: Integer; Arg: Integer): TCodeRec; + function InsertConversionToInt64(I: Integer; Arg: Integer): TCodeRec; + function InsertConversionToUInt64(I: Integer; Arg: Integer): TCodeRec; + function FindImplicitConversion(RecordTypeId, ParamArg, + ResultArg: Integer): Integer; + function FindExplicitConversion(RecordTypeId, ParamArg, + ResultArg: Integer): Integer; + function InsertConversionToRecord(I, Arg, RecordTypeId, ValueId: Integer) + : TCodeRec; + function ExistsBinaryOperator(RecordTypeId: Integer; + const OperatorName: String): Boolean; + procedure InsertBinaryOperator(RecordTypeId: Integer; + const OperatorName: String); + procedure InsertUnaryOperator(RecordTypeId: Integer; + const OperatorName: String); + + procedure CompressListOfOverloaded(applicable_list, pos: TIntegerList); + procedure CheckSubrangeBounds(SubrangeTypeId: Integer; + ValueRec: TSymbolRec); + + function ConvertSetLiteralToDynarrayLiteral(CurrLevel, DynarrayTypeId, + SetId: Integer): Integer; + procedure CreateSetObject(Id: Integer); + function GetNextStmt(I: Integer): Integer; + function GetNextRec(I: Integer): TCodeRec; + + procedure InsertDeclareTempVar; overload; + procedure InsertDeclareTempVar(Id: Integer); overload; + + procedure OperAddAncestor; + + procedure OperCheckOverride(List: TIntegerList); + procedure OperAddMessage; + + procedure OperOP_BEGIN_CLASS_TYPE; + procedure OperInitSub; + procedure OperAddress; + procedure OperEval; + procedure OperEvalInherited; + procedure OperEvalConstructor; + procedure OperImplements; + procedure OperGoTrue; + procedure OperGoFalse; + procedure OperGoTrueBool; + procedure OperGoFalseBool; + + procedure OperSizeOf; + + procedure OperAssignment; + procedure OperAssignEnum; + procedure OperAssignmentConst; + procedure OperCheckSubrangeType; + + procedure OperDetermineType; + procedure OperCreateShortStringType; + + procedure OperCreateMethod; + procedure OperAddMethodIndex; + + procedure OperPushContext; + procedure OperPopContext; + + procedure OperAbs; + procedure OperInc; + procedure OperDec; + procedure OperPred; + procedure OperSucc; + procedure OperOrd; + procedure OperChr; + procedure OperStr; + procedure OperSetLength; + procedure OperLow; + procedure OperHigh; + procedure OperAssigned; + + procedure OperAddition; + procedure OperSubtraction; + procedure OperMultiplication; + procedure OperDivision; + procedure OperIDivision; + procedure OperModulo; + procedure OperLeftShift; + procedure OperRightShift; + procedure OperAnd; + procedure OperOr; + procedure OperXor; + + procedure OperNegation; + procedure OperPositive; + procedure OperNot; + + procedure OperLessThan; + procedure OperLessThanOrEqual; + procedure OperGreaterThan; + procedure OperGreaterThanOrEqual; + procedure OperEqual; + procedure OperNotEqual; + procedure OperRaise; + procedure OperIs; + procedure OperAs; + procedure OperTypeInfo; + procedure OperAddTypeInfo; + + procedure OperPush; + procedure OperPushInstance; + procedure OperAdjustInstance; + procedure OperCall; + procedure OperCallDefaultConstructor; + procedure OperCheckSubCall; + procedure OperVCall; + + procedure OperCheckFinal; + + procedure OperField; + procedure OperElem; + + procedure OperItem; + procedure OperRecordItem; + procedure OperBeginInitConst; + procedure OperEndInitConst; + + procedure OperPrint; + procedure OperTerminal; + + procedure OperTypeCast; + + procedure OperSetInclude; + procedure OperSetExclude; + procedure OperSetMembership; + + procedure OperVarArrayIdx; + procedure OperSetEventProp; + + procedure OperOleValue; + procedure OperOleParam; + + procedure OperFindConstructor; + + procedure OperBeginCrtJsFuncObject; + procedure OperEndCrtJsFuncObject; + procedure OperGetNextJSProp; + procedure OperJStypeof; + procedure OperJSvoid; + + procedure OperGetEnumerator; + procedure OperSetReadId; + procedure OperSetWriteId; + procedure OperDetermineProp; + + procedure OperToFWObject; + procedure OperFrameworkOn; + procedure OperFrameworkOff; + procedure OperAssignLambdaTypes; + + procedure RemoveNOP; + procedure RemovePause; + procedure Remove(R: TCodeRec); + function Insert(I: Integer; R: TCodeRec): Integer; + + procedure OperNop; + + procedure CreateError(const Message: string; params: array of Const); + procedure CreateEvalError(const VarName: String; + using_stack: TIntegerStack); + + procedure RaiseError(const Message: string; params: array of Const); + function HasError: Boolean; + function GetCard: Integer; + + function AddTypeInfo(TypeId, SourceTypeId: Integer): TTypeInfoContainer; + procedure AdjustTypes; + function LookupInExtraUnitList(const S: String): Integer; + function GetCurrSourceLineNumber: Integer; + + public + A: TCodeRecList; + N: Integer; + + kernel: Pointer; + using_list: TIntegerList; + extra_using_list: TIntegerList; + used_private_members: TIntegerList; + + constructor Create(i_kernel: Pointer); + destructor Destroy; override; + procedure RestoreFieldType(J: Integer); + function IsLocalPos(pos: Integer): Boolean; + procedure Reset; + procedure RemoveInstruction(Op, Arg1, Arg2, Res: Integer); + function RemoveLastEvalInstruction(const S: String; + Upcase: Boolean = true): Integer; + function Add(Op, Arg1, Arg2, Res: Integer; SavedLevel: Integer; + Upcase: Boolean; Language: Integer; ModuleNum: Integer; LinePos: Integer) + : TCodeRec; + function Ins(Ip, Op, Arg1, Arg2, Res: Integer; SavedLevel: Integer; + Upcase: Boolean; Language: Integer; ModuleNum: Integer; LinePos: Integer) + : TCodeRec; + procedure RemoveEvalOp; + procedure ProcessImplements; + procedure RemoveEvalOpForTypes; + procedure UpdateDefaultConstructors; + procedure CheckTypes; + function GetSymbolRec(Id: Integer): TSymbolRec; + function GetModule(I: Integer): TModule; + function GetModuleNumber(J: Integer): Integer; + function GetSourceLineNumber(I: Integer): Integer; + function GetSourceLine(I: Integer): String; + function GetIncludedFileName(I: Integer): String; + function GetLinePos(I: Integer): Integer; + procedure ProcessSizeOf; + procedure ChangeOrderOfActualParams; + procedure RemoveLoadProc; + procedure InsertHostMonitoring; + procedure Optimization; + procedure Optimization2; + + procedure InsertDynamicTypeDestructors; + function CompareConversions(Id, id1, id2: Integer): Integer; + function ExistsImplicitNumericConversion(type_id_source, + type_id_dest: Integer): Boolean; + function ExistsImplicitConversion(id_source, id_dest: Integer): Boolean; + procedure ReplaceId(old_id, new_id: Integer); + procedure ReplaceIdEx(old_id, new_id, start_pos, end_pos: Integer; + Local: Boolean; ReplaceDeclId: Boolean = true); + procedure AssignShifts; + procedure CreateMapping(result: TMapTable; Host: Boolean; + HostMapTable, ScriptMapTable: TMapTable); + procedure GenHostStructConst; + function GetUpcase(J: Integer): Boolean; + function GetLanguage(J: Integer): Integer; + function GetCurrSubId(CurrN: Integer): Integer; + function GetCurrSelfId(CurrN: Integer): Integer; + function GetCurrNamespaceId(J: Integer): Integer; + function GetCurrClassId(J: Integer): Integer; + function FindRecord1(Op, Arg1: Integer): Integer; + procedure LocateDummyName(var NN: Integer); + procedure InsertFinalizators; + procedure InsertTryFinally; + procedure AdjustTryList; + procedure SetLastCondRaise; + function GetLevel(pos: Integer): Integer; + function GetClassId(pos: Integer): Integer; + function GetStructureId(pos: Integer): Integer; + procedure DestroyExpressionTempVars(ResultId: Integer); + procedure OperNotImpl; + + function GetPrintKeyword: String; + function GetPrintlnKeyword: String; + function GetStmt(I: Integer): Integer; + function ParamHasBeenChanged(I, Id: Integer): Boolean; + procedure CreateExecLines(MR: TModuleRec); + procedure AddWarnings; + procedure DeleteRecord(I: Integer); + function GetCompletionVisibility(Id: Integer; NN: Integer) + : TMemberVisibilitySet; + procedure CheckExpansions; + procedure RemoveUnusedLabels; + procedure CheckOverride; + function GetTrueSubId: Integer; + procedure CreateMethodEntryLists; + procedure CreateEvalList(L: TStringList); + procedure CreateExportList(MapTable: TMapTable); + procedure InsertCallHostEvents; + + property Card: Integer read GetCard; + property Records[I: Integer]: TCodeRec read GetRecord + write SetRecord; default; + property PAX64: Boolean read GetPAX64; + property SizeOfPointer: Integer read GetSizeOfPointer; + property CurrSourceLineNumber: Integer read GetCurrSourceLineNumber; + end; + +implementation + +uses + PAXCOMP_KERNEL, + PAXCOMP_BASERUNNER, + PAXCOMP_STDLIB; + +constructor TCode.Create(i_kernel: Pointer); +var + I: Integer; +begin + Self.kernel := i_kernel; + A := TCodeRecList.Create; + SetLength(ProcList, -OP_DUMMY); + + for I := 0 to System.Length(ProcList) - 1 do + ProcList[I] := OperNop; + + ProcList[-OP_NOP] := OperNop; + ProcList[-OP_SEPARATOR] := OperNop; + ProcList[-OP_STMT] := OperNop; + ProcList[-OP_SET_CODE_LINE] := OperNop; + ProcList[-OP_BEGIN_MODULE] := OperNop; + ProcList[-OP_END_MODULE] := OperNop; + ProcList[-OP_EXTRA_BYTECODE] := OperNop; + + ProcList[-OP_BEGIN_NAMESPACE] := OperNop; + ProcList[-OP_END_NAMESPACE] := OperNop; + + ProcList[-OP_BEGIN_TYPE] := OperNop; + ProcList[-OP_END_TYPE] := OperNop; + + ProcList[-OP_BEGIN_CLASS_TYPE] := OperOP_BEGIN_CLASS_TYPE; + ProcList[-OP_END_CLASS_TYPE] := OperNop; + + ProcList[-OP_BEGIN_HELPER_TYPE] := OperNop; + ProcList[-OP_END_HELPER_TYPE] := OperNop; + + ProcList[-OP_BEGIN_CLASSREF_TYPE] := OperNop; + ProcList[-OP_END_CLASSREF_TYPE] := OperNop; + + ProcList[-OP_BEGIN_INTERFACE_TYPE] := OperNop; + ProcList[-OP_END_INTERFACE_TYPE] := OperNop; + + ProcList[-OP_BEGIN_RECORD_TYPE] := OperNop; + ProcList[-OP_END_RECORD_TYPE] := OperNop; + + ProcList[-OP_BEGIN_ARRAY_TYPE] := OperNop; + ProcList[-OP_END_ARRAY_TYPE] := OperNop; + + ProcList[-OP_BEGIN_DYNARRAY_TYPE] := OperNop; + ProcList[-OP_END_DYNARRAY_TYPE] := OperNop; + + ProcList[-OP_BEGIN_SUBRANGE_TYPE] := OperNop; + ProcList[-OP_END_SUBRANGE_TYPE] := OperNop; + + ProcList[-OP_BEGIN_ENUM_TYPE] := OperNop; + ProcList[-OP_END_ENUM_TYPE] := OperNop; + + ProcList[-OP_BEGIN_SET_TYPE] := OperNop; + ProcList[-OP_END_SET_TYPE] := OperNop; + + ProcList[-OP_BEGIN_POINTER_TYPE] := OperNop; + ProcList[-OP_END_POINTER_TYPE] := OperNop; + + ProcList[-OP_BEGIN_PROC_TYPE] := OperNop; + ProcList[-OP_END_PROC_TYPE] := OperNop; + + ProcList[-OP_BEGIN_ALIAS_TYPE] := OperNop; + ProcList[-OP_END_ALIAS_TYPE] := OperNop; + +{$IFNDEF PAXARM} + ProcList[-OP_BEGIN_SHORTSTRING_TYPE] := OperNop; + ProcList[-OP_END_SHORTSTRING_TYPE] := OperNop; +{$ENDIF} + ProcList[-OP_BEGIN_CONST] := OperNop; + ProcList[-OP_END_CONST] := OperNop; + + ProcList[-OP_BEGIN_VAR] := OperNop; + ProcList[-OP_END_VAR] := OperNop; + + ProcList[-OP_END_INTERFACE_SECTION] := OperNop; + ProcList[-OP_END_IMPORT] := OperNop; + ProcList[-OP_BEGIN_INITIALIZATION] := OperNop; + ProcList[-OP_END_INITIALIZATION] := OperNop; + ProcList[-OP_BEGIN_FINALIZATION] := OperNop; + ProcList[-OP_END_FINALIZATION] := OperNop; + ProcList[-OP_BEGIN_USING] := OperNop; + ProcList[-OP_END_USING] := OperNop; + ProcList[-OP_BEGIN_BLOCK] := OperNop; + ProcList[-OP_END_BLOCK] := OperNop; + ProcList[-OP_EMIT_OFF] := OperNop; + ProcList[-OP_EMIT_ON] := OperNop; + ProcList[-OP_EVAL] := OperEval; + ProcList[-OP_EVAL_INHERITED] := OperEvalInherited; + ProcList[-OP_EVAL_CONSTRUCTOR] := OperEvalConstructor; + ProcList[-OP_UPDATE_INSTANCE] := OperNop; + ProcList[-OP_CLEAR_EDX] := OperNop; + ProcList[-OP_IMPLEMENTS] := OperImplements; + ProcList[-OP_LOAD_PROC] := OperNop; + ProcList[-OP_CHECK_OVERRIDE] := OperNop; + ProcList[-OP_BEGIN_WITH] := OperPushContext; + ProcList[-OP_END_WITH] := OperPopContext; + ProcList[-OP_BEGIN_INIT_CONST] := OperBeginInitConst; + ProcList[-OP_END_INIT_CONST] := OperEndInitConst; + ProcList[-OP_EXIT] := OperNop; + ProcList[-OP_GO] := OperNop; + ProcList[-OP_GO_TRUE] := OperGoTrue; + ProcList[-OP_GO_FALSE] := OperGoFalse; + ProcList[-OP_GO_TRUE_BOOL] := OperGoTrueBool; + ProcList[-OP_GO_FALSE_BOOL] := OperGoFalseBool; + ProcList[-OP_GO_DL] := OperNop; + ProcList[-OP_SAVE_EDX] := OperNop; + ProcList[-OP_RESTORE_EDX] := OperNop; + ProcList[-OP_BEGIN_CALL] := OperNop; + ProcList[-OP_CHECK_SUB_CALL] := OperCheckSubCall; + ProcList[-OP_CHECK_FINAL] := OperCheckFinal; + ProcList[-OP_PUSH_INSTANCE] := OperPushInstance; + ProcList[-OP_ADJUST_INSTANCE] := OperAdjustInstance; + ProcList[-OP_CALL] := OperCall; + ProcList[-OP_VCALL] := OperVCall; + ProcList[-OP_CALL_DEFAULT_CONSTRUCTOR] := OperCallDefaultConstructor; + ProcList[-OP_TYPE_CAST] := OperTypeCast; + ProcList[-OP_DESTROY_LOCAL_VAR] := OperNop; + ProcList[-OP_PUSH] := OperPush; + ProcList[-OP_PUSH_EBP] := OperNop; + ProcList[-OP_POP] := OperNop; + ProcList[-OP_PUSH_CONTEXT] := OperPushContext; + ProcList[-OP_POP_CONTEXT] := OperPopContext; + ProcList[-OP_LABEL] := OperNop; + ProcList[-OP_BEGIN_SUB] := OperNop; + ProcList[-OP_DECLARE_LOCAL_VAR] := OperNop; + ProcList[-OP_DECLARE_TEMP_VAR] := OperNop; + ProcList[-OP_INIT_SUB] := OperInitSub; + ProcList[-OP_END_SUB] := OperNop; + ProcList[-OP_FIN_SUB] := OperNop; + ProcList[-OP_EPILOGUE_SUB] := OperNop; + + ProcList[-OP_BEGIN_GLOBAL_BLOCK] := OperNop; + ProcList[-OP_EPILOGUE_GLOBAL_BLOCK] := OperNop; + ProcList[-OP_EPILOGUE_GLOBAL_BLOCK2] := OperNop; + ProcList[-OP_END_GLOBAL_BLOCK] := OperNop; + + ProcList[-OP_ASSIGN_TYPE] := OperNop; + ProcList[-OP_DETERMINE_TYPE] := OperDetermineType; + ProcList[-OP_ASSIGN_THE_SAME_TYPE] := OperNop; + ProcList[-OP_ASSIGN_TYPE_ALIAS] := OperNop; + ProcList[-OP_ASSIGN_LAMBDA_TYPES] := OperAssignLambdaTypes; + ProcList[-OP_CREATE_POINTER_TYPE] := OperNop; + ProcList[-OP_CREATE_CLASSREF_TYPE] := OperNop; + ProcList[-OP_CREATE_DYNAMIC_ARRAY_TYPE] := OperNop; + ProcList[-OP_CREATE_SHORTSTRING_TYPE] := OperCreateShortStringType; + ProcList[-OP_ADDRESS] := OperAddress; + ProcList[-OP_TERMINAL] := OperTerminal; + ProcList[-OP_ADDRESS_PROG] := OperNop; + ProcList[-OP_ASSIGN_PROG] := OperNop; + ProcList[-OP_ASSIGN_INT_M] := OperNop; + ProcList[-OP_LVALUE] := OperNop; + ProcList[-OP_ASSIGN] := OperAssignment; + ProcList[-OP_ASSIGN_CONST] := OperAssignmentConst; + ProcList[-OP_ASSIGN_ENUM] := OperAssignEnum; + ProcList[-OP_CHECK_SUBRANGE_TYPE] := OperCheckSubrangeType; + ProcList[-OP_SIZEOF] := OperSizeOf; + + ProcList[-OP_TRY_ON] := OperNop; + ProcList[-OP_TRY_OFF] := OperNop; + ProcList[-OP_FINALLY] := OperNop; + ProcList[-OP_RAISE] := OperRaise; + ProcList[-OP_COND_RAISE] := OperNop; + ProcList[-OP_BEGIN_EXCEPT_BLOCK] := OperNop; + ProcList[-OP_END_EXCEPT_BLOCK] := OperNop; + ProcList[-OP_EXCEPT] := OperNop; + ProcList[-OP_EXCEPT_ON] := OperNop; + ProcList[-OP_PAUSE] := OperNop; + ProcList[-OP_CHECK_PAUSE] := OperNop; + ProcList[-OP_CHECK_PAUSE_LIGHT] := OperNop; + ProcList[-OP_HALT] := OperNop; + + ProcList[-OP_OVERFLOW_CHECK] := OperNop; + + ProcList[-OP_SET_INCLUDE] := OperSetInclude; + ProcList[-OP_SET_INCLUDE_INTERVAL] := OperSetInclude; + ProcList[-OP_SET_EXCLUDE] := OperSetExclude; + ProcList[-OP_SET_MEMBERSHIP] := OperSetMembership; + + ProcList[-OP_ABS] := OperAbs; + ProcList[-OP_INC] := OperInc; + ProcList[-OP_DEC] := OperDec; + ProcList[-OP_PRED] := OperPred; + ProcList[-OP_SUCC] := OperSucc; + ProcList[-OP_ORD] := OperOrd; + ProcList[-OP_CHR] := OperChr; + ProcList[-OP_LOW] := OperLow; + ProcList[-OP_HIGH] := OperHigh; + ProcList[-OP_STR] := OperStr; + ProcList[-OP_SET_LENGTH] := OperSetLength; + ProcList[-OP_ASSIGNED] := OperAssigned; + + ProcList[-OP_PLUS] := OperAddition; + ProcList[-OP_MINUS] := OperSubtraction; + ProcList[-OP_MULT] := OperMultiplication; + ProcList[-OP_DIV] := OperDivision; + ProcList[-OP_IDIV] := OperIDivision; + ProcList[-OP_MOD] := OperModulo; + ProcList[-OP_SHL] := OperLeftShift; + ProcList[-OP_SHR] := OperRightShift; + ProcList[-OP_AND] := OperAnd; + ProcList[-OP_OR] := OperOr; + ProcList[-OP_XOR] := OperXor; + + ProcList[-OP_NEG] := OperNegation; + ProcList[-OP_POSITIVE] := OperPositive; + ProcList[-OP_NOT] := OperNot; + + ProcList[-OP_LT] := OperLessThan; + ProcList[-OP_LE] := OperLessThanOrEqual; + ProcList[-OP_GT] := OperGreaterThan; + ProcList[-OP_GE] := OperGreaterThanOrEqual; + ProcList[-OP_EQ] := OperEqual; + ProcList[-OP_NE] := OperNotEqual; + ProcList[-OP_IS] := OperIs; + ProcList[-OP_AS] := OperAs; + ProcList[-OP_TYPEINFO] := OperTypeInfo; + ProcList[-OP_ADD_TYPEINFO] := OperAddTypeInfo; + + ProcList[-OP_CLASSNAME] := OperNop; + + ProcList[-OP_GET_PROG] := OperNop; + + ProcList[-OP_ADD_MESSAGE] := OperAddMessage; + + ProcList[-OP_CREATE_METHOD] := OperCreateMethod; + ProcList[-OP_ADD_METHOD_INDEX] := OperAddMethodIndex; + + ProcList[-OP_RET] := OperNop; + ProcList[-OP_FIELD] := OperField; + ProcList[-OP_ELEM] := OperElem; + ProcList[-OP_ITEM] := OperItem; + ProcList[-OP_RECORD_ITEM] := OperRecordItem; + ProcList[-OP_PRINT] := OperPrint; + ProcList[-OP_PRINT_EX] := OperNop; + + ProcList[-OP_DETERMINE_PROP] := OperDetermineProp; + + ProcList[-OP_SET_SET_PROP] := OperNop; + ProcList[-OP_SET_ORD_PROP] := OperNop; + ProcList[-OP_SET_INTERFACE_PROP] := OperNop; +{$IFNDEF PAXARM} + ProcList[-OP_SET_ANSISTR_PROP] := OperNop; + ProcList[-OP_SET_WIDESTR_PROP] := OperNop; +{$ENDIF} + ProcList[-OP_SET_UNICSTR_PROP] := OperNop; + ProcList[-OP_SET_FLOAT_PROP] := OperNop; + ProcList[-OP_SET_VARIANT_PROP] := OperNop; + ProcList[-OP_SET_INT64_PROP] := OperNop; + ProcList[-OP_SET_EVENT_PROP] := OperSetEventProp; + ProcList[-OP_SET_EVENT_PROP2] := OperNop; + + ProcList[-OP_VARARRAY_PUT] := OperNop; + ProcList[-OP_VARARRAY_GET] := OperNop; + ProcList[-OP_VARARRAY_IDX] := OperVarArrayIdx; + + ProcList[-OP_OLE_VALUE] := OperOleValue; + ProcList[-OP_OLE_PARAM] := OperOleParam; + ProcList[-OP_OLE_GET] := OperNop; + ProcList[-OP_OLE_SET] := OperNop; + + ProcList[-OP_ONCREATE_OBJECT] := OperNop; + ProcList[-OP_ON_AFTER_OBJECT_CREATION] := OperNop; + ProcList[-OP_CREATE_OBJECT] := OperNop; + ProcList[-OP_DESTROY_OBJECT] := OperNop; + ProcList[-OP_GET_VMT_ADDRESS] := OperNop; + ProcList[-OP_PUSH_INSTANCE] := OperNop; + + ProcList[-OP_ONCREATE_HOST_OBJECT] := OperNop; + ProcList[-OP_ONDESTROY_HOST_OBJECT] := OperNop; + + ProcList[-OP_SAVE_REGS] := OperNop; + ProcList[-OP_RESTORE_REGS] := OperNop; + + ProcList[-OP_ADD_ANCESTOR] := OperAddAncestor; + + ProcList[-OP_ERR_ABSTRACT] := OperNop; + ProcList[-OP_UPDATE_DEFAULT_CONSTRUCTOR] := OperNop; + ProcList[-OP_FIND_CONSTRUCTOR] := OperFindConstructor; + + ProcList[-OP_BEGIN_CRT_JS_FUNC_OBJECT] := OperBeginCrtJsFuncObject; + ProcList[-OP_END_CRT_JS_FUNC_OBJECT] := OperEndCrtJsFuncObject; + + ProcList[-OP_ASSIGN_SHIFT] := OperNop; + + ProcList[-OP_GET_NEXTJSPROP] := OperGetNextJSProp; + ProcList[-OP_JS_TYPEOF] := OperJStypeof; + ProcList[-OP_JS_VOID] := OperJSvoid; + + ProcList[-OP_GET_ENUMERATOR] := OperGetEnumerator; + + ProcList[-OP_SET_READ_ID] := OperSetReadId; + ProcList[-OP_SET_WRITE_ID] := OperSetWriteId; + + ProcList[-OP_TO_FW_OBJECT] := OperToFWObject; + ProcList[-OP_FRAMEWORK_ON] := OperFrameworkOn; + ProcList[-OP_FRAMEWORK_OFF] := OperFrameworkOff; + + CRT_JS_FUNC_OBJECT_SWITCH := false; + + generic_binary_operators := TIntegerList.Create; + with generic_binary_operators do + begin + Add(OP_PLUS); + Add(OP_MINUS); + Add(OP_MULT); + Add(OP_DIV); + Add(OP_IDIV); + Add(OP_MOD); + end; + + generic_unary_operators := TIntegerList.Create; + with generic_unary_operators do + begin + Add(OP_NEG); + end; + + map_list := TIntegerList.Create; + context_list := TIntegerStack.Create; + using_list := TIntegerList.Create(true); + temp_var_list := TAssocIntegers.Create; + + extra_using_list := TIntegerList.Create; + + used_private_members := TIntegerList.Create(true); +end; + +destructor TCode.Destroy; +begin + Reset; + FreeAndNil(A); + FreeAndNil(generic_binary_operators); + FreeAndNil(generic_unary_operators); + FreeAndNil(map_list); + FreeAndNil(context_list); + FreeAndNil(using_list); + FreeAndNil(temp_var_list); + FreeAndNil(extra_using_list); + FreeAndNil(used_private_members); + + inherited; +end; + +function TCode.GetPrintKeyword: String; +var + I: Integer; +begin + result := 'print'; + for I := N downto 1 do + if Records[I].Op = OP_PRINT_KWD then + begin + result := GetSymbolRec(Records[I].Arg1).value; + Exit; + end; +end; + +function TCode.GetPrintlnKeyword: String; +var + I: Integer; +begin + result := 'println'; + for I := N downto 1 do + if Records[I].Op = OP_PRINTLN_KWD then + begin + result := GetSymbolRec(Records[I].Arg1).value; + Exit; + end; +end; + +function TCode.GetLevel(pos: Integer): Integer; +var + I, K: Integer; +begin + K := Card; + + if pos > K then + I := K + else + I := pos; + + result := Records[I].SavedLevel; + if result >= 0 then + Exit; + + repeat + Inc(I); + if I > K then + Exit; + result := Records[I].SavedLevel; + if result >= 0 then + Exit; + until false; +end; + +function TCode.GetClassId(pos: Integer): Integer; +var + Op, K: Integer; +begin + result := 0; + K := Card; + repeat + Op := Records[pos].Op; + + if Op = OP_BEGIN_CLASS_TYPE then + Exit; + if Op = OP_BEGIN_MODULE then + Exit; + if Op = OP_END_MODULE then + Exit; + if Op = OP_END_CLASS_TYPE then + begin + result := Records[pos].Arg1; + Exit; + end; + if Op = OP_END_SUB then + begin + result := GetSymbolRec(Records[pos].Arg1).Level; + Exit; + end; + Inc(pos); + if pos > K then + Exit; + until false; +end; + +function TCode.GetStructureId(pos: Integer): Integer; +var + Op, K: Integer; +begin + result := 0; + K := Card; + repeat + Op := Records[pos].Op; + + if Op = OP_BEGIN_RECORD_TYPE then + Exit; + if Op = OP_BEGIN_MODULE then + Exit; + if Op = OP_END_MODULE then + Exit; + if Op = OP_END_RECORD_TYPE then + begin + result := Records[pos].Arg1; + Exit; + end; + if Op = OP_END_SUB then + begin + result := GetSymbolRec(Records[pos].Arg1).Level; + Exit; + end; + Inc(pos); + if pos > K then + Exit; + until false; +end; + +function TCode.IsLocalPos(pos: Integer): Boolean; +var + L: Integer; +begin + L := GetLevel(pos); + if L = 0 then + begin + result := false; + Exit; + end; + result := GetSymbolRec(L).Kind in kindSUBS; +end; + +procedure TCode.ReplaceId(old_id, new_id: Integer); +begin + ReplaceIdEx(old_id, new_id, 1, Card, false); +end; + +procedure TCode.ReplaceIdEx(old_id, new_id, start_pos, end_pos: Integer; + Local: Boolean; ReplaceDeclId: Boolean = true); +var + I: Integer; + R: TCodeRec; + SymbolTable: TSymbolTable; + SR: TSymbolRec; +begin + if old_id = new_id then + Exit; + + if ReplaceDeclId then + if old_id = TKernel(kernel).FindDeclId then + TKernel(kernel).FindDeclId := new_id; + + SymbolTable := TKernel(kernel).SymbolTable; + + for I := start_pos to end_pos do + begin + R := Records[I]; + + if Local then + if R.Op = OP_END_MODULE then + break; + + if R.Op <> OP_SEPARATOR then + begin + if R.Arg1 = old_id then + R.Arg1 := new_id; + if R.Arg2 = old_id then + R.Arg2 := new_id; + if R.Res = old_id then + R.Res := new_id; + end; + end; + + if GetSymbolRec(new_id).Kind = KindTYPE then + TKernel(kernel).TypeDefList.ReplaceId(old_id, new_id); + + if GetSymbolRec(new_id).Kind in kindSUBS then + Exit; + + for I := SymbolTable.CompileCard to SymbolTable.Card do + begin + SR := SymbolTable[I]; + if SR.OwnerId = old_id then + SR.OwnerId := new_id; + if SR.PatternId = old_id then + SR.PatternId := new_id; + end; +end; + +procedure TCode.OperNotImpl; +begin + RaiseError(errInternalError, []); +end; + +procedure TCode.OperNop; +begin +end; + +function TCode.GetCard: Integer; +begin + result := A.Count; +end; + +function TCode.GetStmt(I: Integer): Integer; +begin + result := I; + while Records[result].Op <> OP_STMT do + begin + Dec(result); + + if Records[result].Op = OP_BEGIN_MODULE then + break; + + if result = 1 then + Exit; + end; +end; + +function TCode.GetNextRec(I: Integer): TCodeRec; +var + K: Integer; +begin + result := nil; + K := Card; + repeat + Inc(I); + if I > K then + Exit; + if Records[I].Op <> OP_SEPARATOR then + begin + result := Records[I]; + Exit; + end; + until false; +end; + +function TCode.GetNextStmt(I: Integer): Integer; +var + K: Integer; +begin + result := I + 1; + K := Card; + while Records[result].Op <> OP_STMT do + with Records[result] do + begin + Inc(result); + if result = K then + Exit; + if Op = OP_EPILOGUE_SUB then + begin + Dec(result); + Exit; + end; + if Op = OP_END_SUB then + begin + Dec(result); + Exit; + end; + if Op = OP_END_MODULE then + begin + Dec(result); + Exit; + end; + end; +end; + +function TCode.GetModuleNumber(J: Integer): Integer; +var + I: Integer; +begin + if J > Card then + I := Card + else + I := J; + result := Records[I].ModuleNum; +end; + +function TCode.GetUpcase(J: Integer): Boolean; +var + I: Integer; +begin + if J > Card then + I := Card + else + I := J; + result := Records[I].Upcase; +end; + +function TCode.GetLanguage(J: Integer): Integer; +var + I: Integer; +begin + if J > Card then + I := Card + else + I := J; + result := Records[I].Language; +end; + +function TCode.GetCurrClassId(J: Integer): Integer; +var + I: Integer; + R: TCodeRec; +begin + result := 0; + + if J > Card then + I := Card + else + I := J; + + repeat + R := Records[I]; + if R.Op = OP_END_MODULE then + Exit; + if R.Op = OP_END_CLASS_TYPE then + Exit; + if R.Op = OP_BEGIN_CLASS_TYPE then + begin + result := R.Arg1; + Exit; + end; + + Dec(I); + if I <= 0 then + Exit; + until false; +end; + +function TCode.GetCurrNamespaceId(J: Integer): Integer; +var + I: Integer; + R: TCodeRec; +begin + result := 0; + + if J > Card then + I := Card + else + I := J; + + repeat + R := Records[I]; + if R.Op = OP_END_MODULE then + Exit; + if R.Op = OP_END_NAMESPACE then + Exit; + if R.Op = OP_BEGIN_NAMESPACE then + begin + result := R.Arg1; + Exit; + end; + + Dec(I); + if I <= 0 then + Exit; + until false; +end; + +procedure TCode.Reset; +var + I: Integer; +begin + for I := 1 to Card do +{$IFDEF ARC} + Records[I] := nil; +{$ELSE} + Records[I].Free; +{$ENDIF} + A.Clear; + SignTypeCast := false; + map_list.Clear; + context_list.Clear; + using_list.Clear; + temp_var_list.Clear; + extra_using_list.Clear; + used_private_members.Clear; +end; + +function TCode.Add(Op, Arg1, Arg2, Res: Integer; SavedLevel: Integer; + Upcase: Boolean; Language: Integer; ModuleNum: Integer; LinePos: Integer) + : TCodeRec; +begin + result := TCodeRec.Create(Op, nil); + result.OwnerObject := Self; + result.Upcase := Upcase; + result.Language := Language; + result.ModuleNum := ModuleNum; + + result.SavedLevel := SavedLevel; + result.Arg1 := Arg1; + result.Arg2 := Arg2; + result.Res := Res; + result.LinePos := LinePos; + A.Add(result); +end; + +function TCode.Ins(Ip, Op, Arg1, Arg2, Res: Integer; SavedLevel: Integer; + Upcase: Boolean; Language: Integer; ModuleNum: Integer; LinePos: Integer) + : TCodeRec; +begin + result := TCodeRec.Create(Op, nil); + result.OwnerObject := Self; + result.Upcase := Upcase; + result.Language := Language; + result.ModuleNum := ModuleNum; + + result.SavedLevel := SavedLevel; + result.Arg1 := Arg1; + result.Arg2 := Arg2; + result.Res := Res; + result.LinePos := LinePos; + A.Insert(Ip, result); +end; + +function TCode.GetSymbolRec(Id: Integer): TSymbolRec; +begin + result := TKernel(kernel).SymbolTable[Id]; +end; + +procedure TCode.Remove(R: TCodeRec); +begin + A.Remove(R); +end; + +function TCode.Insert(I: Integer; R: TCodeRec): Integer; +// var +// J: Integer; +begin + result := I; + A.Insert(I - 1, R); + { + for J:=I to Card do + if Records[J].Op = OP_SET_CODE_LINE then + Inc(Records[J].Arg1); + } +end; + +{$O+} + +function TCode.GetRecord(I: Integer): TCodeRec; +begin + result := TCodeRec(A[I - 1]); +end; +{$O-} + +procedure TCode.SetRecord(I: Integer; value: TCodeRec); +begin + A[I - 1] := value; +end; + +procedure TCode.DeleteRecord(I: Integer); +begin +{$IFDEF ARC} + Records[I] := nil; +{$ELSE} + Records[I].Free; +{$ENDIF} + A.Delete(I - 1); +end; + +function TCode.CreateConst(TypeId: Integer; const value: Variant; + ValueType: Integer = 0): Integer; +var + FT: Integer; + S: String; + SymbolTable: TSymbolTable; +begin + SymbolTable := TKernel(kernel).SymbolTable; + FT := SymbolTable[TypeId].FinalTypeId; + + result := 0; + case FT of + typeBOOLEAN: + result := SymbolTable.AddBooleanConst(value).Id; + typeBYTEBOOL: + if TVarData(value).VInteger <> 0 then + result := SymbolTable.AddByteBoolConst(true).Id + else + result := SymbolTable.AddByteBoolConst(false).Id; + typeWORDBOOL: + if TVarData(value).VInteger <> 0 then + result := SymbolTable.AddWordBoolConst(true).Id + else + result := SymbolTable.AddWordBoolConst(false).Id; + typeLONGBOOL: + if TVarData(value).VInteger <> 0 then + result := SymbolTable.AddLongBoolConst(true).Id + else + result := SymbolTable.AddLongBoolConst(false).Id; + typeINTEGER: + result := SymbolTable.AddIntegerConst(value).Id; + typePOINTER: + result := SymbolTable.AddPointerConst(TypeId, Pointer(Integer(value))).Id; + typeSMALLINT: + result := SymbolTable.AddSmallIntConst(value).Id; + typeSHORTINT: + result := SymbolTable.AddShortIntConst(value).Id; + typeBYTE: + result := SymbolTable.AddByteConst(value).Id; + typeWORD: + result := SymbolTable.AddWordConst(value).Id; + typeCARDINAL: + result := SymbolTable.AddCardinalConst(value).Id; + typeDOUBLE: + result := SymbolTable.AddDoubleConst(value).Id; + typeCURRENCY: + result := SymbolTable.AddCurrencyConst(value).Id; + typeSINGLE: + result := SymbolTable.AddSingleConst(value).Id; + typeEXTENDED: + result := SymbolTable.AddExtendedConst(value).Id; +{$IFNDEF PAXARM} + typeANSISTRING, typeWIDESTRING, typeSHORTSTRING: + begin + if VarType(value) in [varByte, varInteger] then + begin + S := Chr(Integer(value)); + result := SymbolTable.AddPAnsiCharConst(AnsiString(S)).Id; + end + else + result := SymbolTable.AddPAnsiCharConst(AnsiString(value)).Id; + end; +{$ENDIF} + typeUNICSTRING: + begin + if VarType(value) in [varByte, varInteger] then + begin + S := Chr(Integer(value)); + result := SymbolTable.AddPWideCharConst(S).Id; + end + else + result := SymbolTable.AddPWideCharConst(value).Id; + end; +{$IFNDEF PAXARM} + typeANSICHAR: + result := SymbolTable.AddAnsiCharConst(AnsiChar(Chr(Integer(value)))).Id; +{$ENDIF} + typeWIDECHAR: + result := SymbolTable.AddWideCharConst(Integer(value)).Id; +{$IFDEF VARIANTS} + typeINT64: + result := SymbolTable.AddInt64Const(value).Id; + typeUINT64: + result := SymbolTable.AddUInt64Const(value).Id; +{$ELSE} + typeINT64: + result := SymbolTable.AddInt64Const(Integer(value)).Id; + typeUINT64: + result := SymbolTable.AddUInt64Const(Integer(value)).Id; +{$ENDIF} + typeVARIANT: + begin + if ValueType = typeBOOLEAN then + begin + if Integer(value) = 0 then + result := SymbolTable.AddVariantConst(false).Id + else + result := SymbolTable.AddVariantConst(true).Id + end + else + result := SymbolTable.AddVariantConst(value).Id; + end; + typeOLEVARIANT: + begin + if ValueType = typeBOOLEAN then + begin + if Integer(value) = 0 then + result := SymbolTable.AddOleVariantConst(false).Id + else + result := SymbolTable.AddOleVariantConst(true).Id + end + else + result := SymbolTable.AddOleVariantConst(value).Id; + end; + else + begin + if FT = typeENUM then + result := SymbolTable.AddEnumConst(TypeId, value).Id + else if FT = typeSET then + result := SymbolTable.AddSetConst(H_TByteSet, value).Id + else if FT = typeCLASS then + begin + if Integer(value) = 0 then + result := SymbolTable.NilId + else + result := SymbolTable.AddClassConst(TypeId, + TObject(Integer(value))).Id; + end + else + begin + if FT in OrdinalTypes then + result := CreateConst(FT, value) + else + RaiseError(errInternalError, []); + end; + end; + end; +end; + +function TCode.NewTempVar(Level, TypeId: Integer): Integer; +var + R: TSymbolRec; +begin + if CRT_JS_FUNC_OBJECT_SWITCH then + Level := JS_TempNamespaceId; + + R := TKernel(kernel).SymbolTable.AddRecord; + R.Kind := KindVAR; + R.Level := Level; + R.TypeId := TypeId; + result := R.Id; +end; + +function TCode.NewField(const FName: String; TypeId, OwnerId: Integer): Integer; +begin + result := NewTempVar(GetSymbolRec(OwnerId).Level, TypeId); + GetSymbolRec(result).OwnerId := OwnerId; + GetSymbolRec(result).Name := FName; +end; + +{$IFNDEF PAXARM} + +function TCode.CreateAnsiCharVar(Level: Integer): Integer; +begin + if CRT_JS_FUNC_OBJECT_SWITCH then + Level := JS_TempNamespaceId; + + result := TKernel(kernel).SymbolTable.AddAnsiCharVar(Level).Id; +end; +{$ENDIF} + +function TCode.CreateWideCharVar(Level: Integer): Integer; +begin + if CRT_JS_FUNC_OBJECT_SWITCH then + Level := JS_TempNamespaceId; + + result := TKernel(kernel).SymbolTable.AddWideCharVar(Level).Id; +end; + +function TCode.CreatePointerVar(Level: Integer): Integer; +begin + if CRT_JS_FUNC_OBJECT_SWITCH then + Level := JS_TempNamespaceId; + + result := TKernel(kernel).SymbolTable.AddPointerVar(Level).Id; +end; + +function TCode.CreateIntegerVar(Level: Integer): Integer; +begin + if CRT_JS_FUNC_OBJECT_SWITCH then + Level := JS_TempNamespaceId; + + result := TKernel(kernel).SymbolTable.AddIntegerVar(Level).Id; +end; + +function TCode.CreateCardinalVar(Level: Integer): Integer; +begin + if CRT_JS_FUNC_OBJECT_SWITCH then + Level := JS_TempNamespaceId; + + result := TKernel(kernel).SymbolTable.AddCardinalVar(Level).Id; +end; + +function TCode.CreateSmallIntVar(Level: Integer): Integer; +begin + if CRT_JS_FUNC_OBJECT_SWITCH then + Level := JS_TempNamespaceId; + + result := TKernel(kernel).SymbolTable.AddSmallIntVar(Level).Id; +end; + +function TCode.CreateShortIntVar(Level: Integer): Integer; +begin + if CRT_JS_FUNC_OBJECT_SWITCH then + Level := JS_TempNamespaceId; + + result := TKernel(kernel).SymbolTable.AddShortIntVar(Level).Id; +end; + +function TCode.CreateByteVar(Level: Integer): Integer; +begin + if CRT_JS_FUNC_OBJECT_SWITCH then + Level := JS_TempNamespaceId; + + result := TKernel(kernel).SymbolTable.AddByteVar(Level).Id; +end; + +function TCode.CreateWordVar(Level: Integer): Integer; +begin + if CRT_JS_FUNC_OBJECT_SWITCH then + Level := JS_TempNamespaceId; + + result := TKernel(kernel).SymbolTable.AddWordVar(Level).Id; +end; + +function TCode.CreateBooleanVar(Level: Integer): Integer; +begin + if CRT_JS_FUNC_OBJECT_SWITCH then + Level := JS_TempNamespaceId; + + result := TKernel(kernel).SymbolTable.AddBooleanVar(Level).Id; +end; + +function TCode.CreateByteBoolVar(Level: Integer): Integer; +begin + if CRT_JS_FUNC_OBJECT_SWITCH then + Level := JS_TempNamespaceId; + + result := TKernel(kernel).SymbolTable.AddByteBoolVar(Level).Id; +end; + +function TCode.CreateWordBoolVar(Level: Integer): Integer; +begin + if CRT_JS_FUNC_OBJECT_SWITCH then + Level := JS_TempNamespaceId; + + result := TKernel(kernel).SymbolTable.AddWordBoolVar(Level).Id; +end; + +function TCode.CreateLongBoolVar(Level: Integer): Integer; +begin + if CRT_JS_FUNC_OBJECT_SWITCH then + Level := JS_TempNamespaceId; + + result := TKernel(kernel).SymbolTable.AddLongBoolVar(Level).Id; +end; + +function TCode.CreateDoubleVar(Level: Integer): Integer; +begin + if CRT_JS_FUNC_OBJECT_SWITCH then + Level := JS_TempNamespaceId; + + result := TKernel(kernel).SymbolTable.AddDoubleVar(Level).Id; +end; + +function TCode.CreateCurrencyVar(Level: Integer): Integer; +begin + if CRT_JS_FUNC_OBJECT_SWITCH then + Level := JS_TempNamespaceId; + + result := TKernel(kernel).SymbolTable.AddCurrencyVar(Level).Id; +end; + +function TCode.CreateSingleVar(Level: Integer): Integer; +begin + if CRT_JS_FUNC_OBJECT_SWITCH then + Level := JS_TempNamespaceId; + + result := TKernel(kernel).SymbolTable.AddSingleVar(Level).Id; +end; + +function TCode.CreateExtendedVar(Level: Integer): Integer; +begin + if CRT_JS_FUNC_OBJECT_SWITCH then + Level := JS_TempNamespaceId; + + result := TKernel(kernel).SymbolTable.AddExtendedVar(Level).Id; +end; + +function TCode.CreateInt64Var(Level: Integer): Integer; +begin + if CRT_JS_FUNC_OBJECT_SWITCH then + Level := JS_TempNamespaceId; + + result := TKernel(kernel).SymbolTable.AddInt64Var(Level).Id; +end; + +function TCode.CreateUInt64Var(Level: Integer): Integer; +begin + if CRT_JS_FUNC_OBJECT_SWITCH then + Level := JS_TempNamespaceId; + + result := TKernel(kernel).SymbolTable.AddUInt64Var(Level).Id; +end; + +{$IFNDEF PAXARM} + +function TCode.CreateStringVar(Level: Integer): Integer; +begin + if CRT_JS_FUNC_OBJECT_SWITCH then + Level := JS_TempNamespaceId; + + result := TKernel(kernel).SymbolTable.AddStringVar(Level).Id; +end; + +function TCode.CreateWideStringVar(Level: Integer): Integer; +begin + if CRT_JS_FUNC_OBJECT_SWITCH then + Level := JS_TempNamespaceId; + + result := TKernel(kernel).SymbolTable.AddWideStringVar(Level).Id; +end; + +function TCode.CreateShortStringVar(Level, TypeId: Integer): Integer; +begin + if CRT_JS_FUNC_OBJECT_SWITCH then + Level := JS_TempNamespaceId; + + result := TKernel(kernel).SymbolTable.AddShortStringVar(Level, TypeId).Id; +end; +{$ENDIF} + +function TCode.CreateInterfaceVar(Level: Integer): Integer; +begin + if CRT_JS_FUNC_OBJECT_SWITCH then + Level := JS_TempNamespaceId; + + result := TKernel(kernel).SymbolTable.AddInterfaceVar(Level).Id; +end; + +function TCode.CreateClassVar(Level: Integer): Integer; +begin + if CRT_JS_FUNC_OBJECT_SWITCH then + Level := JS_TempNamespaceId; + + result := TKernel(kernel).SymbolTable.AddClassVar(Level).Id; +end; + +function TCode.CreateUnicStringVar(Level: Integer): Integer; +begin + if CRT_JS_FUNC_OBJECT_SWITCH then + Level := JS_TempNamespaceId; + + result := TKernel(kernel).SymbolTable.AddUnicStringVar(Level).Id; +end; + +function TCode.CreateRecordVar(Level, TypeId: Integer): Integer; +begin + if CRT_JS_FUNC_OBJECT_SWITCH then + Level := JS_TempNamespaceId; + + result := TKernel(kernel).SymbolTable.AddRecordVar(Level, TypeId).Id; +end; + +function TCode.CreateDynarrayVar(Level, TypeId: Integer): Integer; +begin + if CRT_JS_FUNC_OBJECT_SWITCH then + Level := JS_TempNamespaceId; + + result := TKernel(kernel).SymbolTable.AddDynarrayVar(Level, TypeId).Id; +end; + +function TCode.CreateVariantVar(Level: Integer): Integer; +begin + if CRT_JS_FUNC_OBJECT_SWITCH then + Level := JS_TempNamespaceId; + + result := TKernel(kernel).SymbolTable.AddVariantVar(Level).Id; +end; + +function TCode.CreateOleVariantVar(Level: Integer): Integer; +begin + if CRT_JS_FUNC_OBJECT_SWITCH then + Level := JS_TempNamespaceId; + + result := TKernel(kernel).SymbolTable.AddOleVariantVar(Level).Id; +end; + +function TCode.InsertDestroyLocalVar(I: Integer; Id: Integer): TCodeRec; +begin + result := TCodeRec.Create(OP_DESTROY_LOCAL_VAR, Self); + result.Arg1 := Id; + Insert(I, result); +end; + +{$IFNDEF PAXARM} + +function TCode.InsertConversionToAnsiChar(I: Integer; Arg: Integer): TCodeRec; +var + R, RC: TCodeRec; + Level: Integer; + T: Integer; +begin + R := Records[I]; + RC := TCodeRec.Create(0, Self); + result := RC; + + if Arg = 1 then + RC.Arg1 := R.Arg1 + else if Arg = 2 then + RC.Arg1 := R.Arg2 + else if Arg = 3 then + RC.Arg1 := R.Res + else + RaiseError(errInternalError, []); + + T := GetSymbolRec(RC.Arg1).FinalTypeId; + if T in VariantTypes then + RC.Op := OP_ANSICHAR_FROM_VARIANT + else if T = typeRECORD then + begin + FreeAndNil(RC); + InsertImplicitConversion(I, Arg, GetSymbolRec(RC.Arg1).TerminalTypeId, + typeANSICHAR); + Dec(N); // will be increased by 1 + Exit; + end + else + RaiseError(errIncompatibleTypesNoArgs, []); + + Level := GetLevel(N); + + RC.Arg2 := RC.Arg1; + RC.Res := CreateAnsiCharVar(Level); + + if Arg = 1 then + R.Arg1 := RC.Res + else if Arg = 2 then + R.Arg2 := RC.Res + else + R.Res := RC.Res; + + Insert(I, RC); +end; +{$ENDIF} + +function TCode.InsertConversionToWideChar(I: Integer; Arg: Integer): TCodeRec; +var + R, RC: TCodeRec; + Level: Integer; + T: Integer; +begin + R := Records[I]; + RC := TCodeRec.Create(0, Self); + result := RC; + + if Arg = 1 then + RC.Arg1 := R.Arg1 + else if Arg = 2 then + RC.Arg1 := R.Arg2 + else if Arg = 3 then + RC.Arg1 := R.Res + else + RaiseError(errInternalError, []); + + T := GetSymbolRec(RC.Arg1).FinalTypeId; + if T in VariantTypes then + RC.Op := OP_WIDECHAR_FROM_VARIANT + else if T = typeRECORD then + begin + FreeAndNil(RC); + InsertImplicitConversion(I, Arg, GetSymbolRec(RC.Arg1).TerminalTypeId, + typeWIDECHAR); + Dec(N); // will be increased by 1 + Exit; + end + else + RaiseError(errIncompatibleTypesNoArgs, []); + + Level := GetLevel(N); + + RC.Arg2 := RC.Arg1; + RC.Res := CreateWideCharVar(Level); + + if Arg = 1 then + R.Arg1 := RC.Res + else if Arg = 2 then + R.Arg2 := RC.Res + else + R.Res := RC.Res; + + Insert(I, RC); +end; + +function TCode.InsertConversionToInteger(I: Integer; Arg: Integer): TCodeRec; +var + R, RC: TCodeRec; + Level: Integer; + T: Integer; +begin + R := Records[I]; + RC := TCodeRec.Create(0, Self); + result := RC; + + if Arg = 1 then + RC.Arg1 := R.Arg1 + else if Arg = 2 then + RC.Arg1 := R.Arg2 + else if Arg = 3 then + RC.Arg1 := R.Res + else + RaiseError(errInternalError, []); + + T := GetSymbolRec(RC.Arg1).FinalTypeId; + if T in VariantTypes then + RC.Op := OP_INT_FROM_VARIANT + else if T = typeINT64 then + RC.Op := OP_INT_FROM_INT64 + else if T = typeRECORD then + begin + FreeAndNil(RC); + InsertImplicitConversion(I, Arg, GetSymbolRec(RC.Arg1).TerminalTypeId, + typeINTEGER); + Dec(N); // will be increased by 1 + Exit; + end + else + RaiseError(errIncompatibleTypesNoArgs, []); + + Level := GetLevel(N); + + RC.Arg2 := RC.Arg1; + RC.Res := CreateIntegerVar(Level); + + if Arg = 1 then + R.Arg1 := RC.Res + else if Arg = 2 then + R.Arg2 := RC.Res + else + R.Res := RC.Res; + + Insert(I, RC); +end; + +function TCode.InsertConversionToCardinal(I: Integer; Arg: Integer): TCodeRec; +var + R, RC: TCodeRec; + Level: Integer; + T: Integer; +begin + R := Records[I]; + RC := TCodeRec.Create(0, Self); + result := RC; + + if Arg = 1 then + RC.Arg1 := R.Arg1 + else if Arg = 2 then + RC.Arg1 := R.Arg2 + else if Arg = 3 then + RC.Arg1 := R.Res + else + RaiseError(errInternalError, []); + + T := GetSymbolRec(RC.Arg1).FinalTypeId; + if T in VariantTypes then + RC.Op := OP_CARDINAL_FROM_VARIANT + else if T = typeINT64 then + RC.Op := OP_CARDINAL_FROM_INT64 + else if T = typeRECORD then + begin + FreeAndNil(RC); + InsertImplicitConversion(I, Arg, GetSymbolRec(RC.Arg1).TerminalTypeId, + typeCARDINAL); + Dec(N); // will be increased by 1 + Exit; + end + else + RaiseError(errIncompatibleTypesNoArgs, []); + + Level := GetLevel(N); + + RC.Arg2 := RC.Arg1; + RC.Res := CreateCardinalVar(Level); + + if Arg = 1 then + R.Arg1 := RC.Res + else if Arg = 2 then + R.Arg2 := RC.Res + else + R.Res := RC.Res; + + Insert(I, RC); +end; + +function TCode.InsertConversionToSmallInt(I: Integer; Arg: Integer): TCodeRec; +var + R, RC: TCodeRec; + Level: Integer; + T: Integer; +begin + R := Records[I]; + RC := TCodeRec.Create(0, Self); + result := RC; + + if Arg = 1 then + RC.Arg1 := R.Arg1 + else if Arg = 2 then + RC.Arg1 := R.Arg2 + else if Arg = 3 then + RC.Arg1 := R.Res + else + RaiseError(errInternalError, []); + + T := GetSymbolRec(RC.Arg1).FinalTypeId; + if T in VariantTypes then + RC.Op := OP_SMALLINT_FROM_VARIANT + else if T = typeINT64 then + RC.Op := OP_SMALLINT_FROM_INT64 + else if T = typeRECORD then + begin + FreeAndNil(RC); + InsertImplicitConversion(I, Arg, GetSymbolRec(RC.Arg1).TerminalTypeId, + typeSMALLINT); + Dec(N); // will be increased by 1 + Exit; + end + else + RaiseError(errIncompatibleTypesNoArgs, []); + + Level := GetLevel(N); + + RC.Arg2 := RC.Arg1; + RC.Res := CreateSmallIntVar(Level); + + if Arg = 1 then + R.Arg1 := RC.Res + else if Arg = 2 then + R.Arg2 := RC.Res + else + R.Res := RC.Res; + + Insert(I, RC); +end; + +function TCode.InsertConversionToShortInt(I: Integer; Arg: Integer): TCodeRec; +var + R, RC: TCodeRec; + Level: Integer; + T: Integer; +begin + R := Records[I]; + RC := TCodeRec.Create(0, Self); + result := RC; + + if Arg = 1 then + RC.Arg1 := R.Arg1 + else if Arg = 2 then + RC.Arg1 := R.Arg2 + else if Arg = 3 then + RC.Arg1 := R.Res + else + RaiseError(errInternalError, []); + + T := GetSymbolRec(RC.Arg1).FinalTypeId; + if T in VariantTypes then + RC.Op := OP_SHORTINT_FROM_VARIANT + else if T = typeINT64 then + RC.Op := OP_SHORTINT_FROM_INT64 + else if T = typeRECORD then + begin + FreeAndNil(RC); + InsertImplicitConversion(I, Arg, GetSymbolRec(RC.Arg1).TerminalTypeId, + typeSHORTINT); + Dec(N); // will be increased by 1 + Exit; + end + else + RaiseError(errIncompatibleTypesNoArgs, []); + + Level := GetLevel(N); + + RC.Arg2 := RC.Arg1; + RC.Res := CreateShortIntVar(Level); + + if Arg = 1 then + R.Arg1 := RC.Res + else if Arg = 2 then + R.Arg2 := RC.Res + else + R.Res := RC.Res; + + Insert(I, RC); +end; + +function TCode.InsertConversionToByte(I: Integer; Arg: Integer): TCodeRec; +var + R, RC: TCodeRec; + Level: Integer; + T: Integer; +begin + R := Records[I]; + RC := TCodeRec.Create(0, Self); + result := RC; + + if Arg = 1 then + RC.Arg1 := R.Arg1 + else if Arg = 2 then + RC.Arg1 := R.Arg2 + else if Arg = 3 then + RC.Arg1 := R.Res + else + RaiseError(errInternalError, []); + + T := GetSymbolRec(RC.Arg1).FinalTypeId; + if T in VariantTypes then + RC.Op := OP_BYTE_FROM_VARIANT + else if T = typeINT64 then + RC.Op := OP_BYTE_FROM_INT64 + else if T = typeRECORD then + begin + FreeAndNil(RC); + InsertImplicitConversion(I, Arg, GetSymbolRec(RC.Arg1).TerminalTypeId, + typeBYTE); + Dec(N); // will be increased by 1 + Exit; + end + else + RaiseError(errIncompatibleTypesNoArgs, []); + + Level := GetLevel(N); + + RC.Arg2 := RC.Arg1; + RC.Res := CreateByteVar(Level); + + if Arg = 1 then + R.Arg1 := RC.Res + else if Arg = 2 then + R.Arg2 := RC.Res + else + R.Res := RC.Res; + + Insert(I, RC); +end; + +function TCode.InsertConversionToWord(I: Integer; Arg: Integer): TCodeRec; +var + R, RC: TCodeRec; + Level: Integer; + T: Integer; +begin + R := Records[I]; + RC := TCodeRec.Create(0, Self); + result := RC; + + if Arg = 1 then + RC.Arg1 := R.Arg1 + else if Arg = 2 then + RC.Arg1 := R.Arg2 + else if Arg = 3 then + RC.Arg1 := R.Res + else + RaiseError(errInternalError, []); + + T := GetSymbolRec(RC.Arg1).FinalTypeId; + if T in VariantTypes then + RC.Op := OP_WORD_FROM_VARIANT + else if T = typeINT64 then + RC.Op := OP_WORD_FROM_INT64 + else if T = typeRECORD then + begin + FreeAndNil(RC); + InsertImplicitConversion(I, Arg, GetSymbolRec(RC.Arg1).TerminalTypeId, + typeWORD); + Dec(N); // will be increased by 1 + Exit; + end + else + RaiseError(errIncompatibleTypesNoArgs, []); + + Level := GetLevel(N); + + RC.Arg2 := RC.Arg1; + RC.Res := CreateWordVar(Level); + + if Arg = 1 then + R.Arg1 := RC.Res + else if Arg = 2 then + R.Arg2 := RC.Res + else + R.Res := RC.Res; + + Insert(I, RC); +end; + +function TCode.InsertConversionToInterface(I: Integer; Arg: Integer; + InterfaceTypeId: Integer): TCodeRec; +var + R, RC, RD: TCodeRec; + Level: Integer; + T: Integer; +begin + R := Records[I]; + RC := TCodeRec.Create(0, Self); + result := RC; + + if Arg = 1 then + RC.Arg2 := R.Arg1 + else if Arg = 2 then + RC.Arg2 := R.Arg2 + else if Arg = 3 then + RC.Arg2 := R.Res + else + RaiseError(errInternalError, []); + + T := GetSymbolRec(RC.Arg2).FinalTypeId; + if T = typeCLASS then + RC.Op := OP_INTERFACE_FROM_CLASS + else if T = typeRECORD then + begin + InsertImplicitConversion(I, Arg, GetSymbolRec(RC.Arg2).TerminalTypeId, + GetSymbolRec(RC.Arg2).TerminalTypeId); + FreeAndNil(RC); + Dec(N); // will be increased by 1 + Exit; + end + else + RaiseError(errIncompatibleTypesNoArgs, []); + + Level := GetLevel(N); + + RC.Res := NewTempVar(Level, InterfaceTypeId); + RC.Arg1 := RC.Res; + + if Arg = 1 then + R.Arg1 := RC.Res + else if Arg = 2 then + R.Arg2 := RC.Res + else + R.Res := RC.Res; + + RD := TCodeRec.Create(OP_DECLARE_TEMP_VAR, Self); + RD.Arg1 := Level; + RD.Arg2 := RC.Res; + RD.Res := 0; + Insert(I, RD); + Inc(I); + Inc(N); + + Insert(I, RC); +end; + +function TCode.InsertConversionToClass(I: Integer; Arg: Integer; + ClassTypeId: Integer): TCodeRec; +var + R, RC: TCodeRec; + Level: Integer; + T: Integer; +begin + R := Records[I]; + RC := TCodeRec.Create(0, Self); + result := RC; + + if Arg = 1 then + RC.Arg1 := R.Arg1 + else if Arg = 2 then + RC.Arg1 := R.Arg2 + else if Arg = 3 then + RC.Arg1 := R.Res + else + RaiseError(errInternalError, []); + + T := GetSymbolRec(RC.Arg1).FinalTypeId; + if T in VariantTypes then + RC.Op := OP_CLASS_FROM_VARIANT + else if T = typeRECORD then + begin + InsertImplicitConversion(I, Arg, GetSymbolRec(RC.Arg1).TerminalTypeId, + ClassTypeId); + FreeAndNil(RC); + Dec(N); // will be increased by 1 + Exit; + end + else + RaiseError(errIncompatibleTypesNoArgs, []); + + Level := GetLevel(N); + RC.Arg2 := RC.Arg1; + RC.Res := CreateClassVar(Level); + GetSymbolRec(RC.Res).TypeId := ClassTypeId; + + if Arg = 1 then + R.Arg1 := RC.Res + else if Arg = 2 then + R.Arg2 := RC.Res + else + R.Res := RC.Res; + + Insert(I, RC); +end; + +function TCode.InsertConversionToFrameworkClass(I: Integer; Arg: Integer; + ClassTypeId: Integer): TCodeRec; +var + R, RC: TCodeRec; +begin + R := Records[I]; + + RC := TCodeRec.Create(0, Self); + result := RC; + + if Arg = 1 then + RC.Arg1 := R.Arg1 + else if Arg = 2 then + RC.Arg1 := R.Arg2 + else if Arg = 3 then + RC.Arg1 := R.Res + else + RaiseError(errInternalError, []); + + RC.Op := OP_TO_FW_OBJECT; + + RC.Arg2 := GetSymbolRec(RC.Arg1).TerminalTypeId; + RC.Res := CreateClassVar(GetLevel(N)); + GetSymbolRec(RC.Res).TypeId := ClassTypeId; + + if Arg = 1 then + R.Arg1 := RC.Res + else if Arg = 2 then + R.Arg2 := RC.Res + else + R.Res := RC.Res; + + Insert(I, RC); +end; + +function TCode.InsertConversionToBoolean(I: Integer; Arg: Integer): TCodeRec; +var + R, RC: TCodeRec; + Level: Integer; + T: Integer; +begin + R := Records[I]; + RC := TCodeRec.Create(0, Self); + result := RC; + + if Arg = 1 then + RC.Arg1 := R.Arg1 + else if Arg = 2 then + RC.Arg1 := R.Arg2 + else if Arg = 3 then + RC.Arg1 := R.Res + else + RaiseError(errInternalError, []); + + T := GetSymbolRec(RC.Arg1).FinalTypeId; + if T in VariantTypes then + RC.Op := OP_BOOL_FROM_VARIANT + else if T = typeBYTEBOOL then + RC.Op := OP_BOOL_FROM_BYTEBOOL + else if T = typeWORDBOOL then + RC.Op := OP_BOOL_FROM_WORDBOOL + else if T = typeLONGBOOL then + RC.Op := OP_BOOL_FROM_LONGBOOL + else if T = typeRECORD then + begin + InsertImplicitConversion(I, Arg, GetSymbolRec(RC.Arg1).TerminalTypeId, + typeBOOLEAN); + FreeAndNil(RC); + Dec(N); // will be increased by 1 + Exit; + end + else + RaiseError(errIncompatibleTypesNoArgs, []); + + Level := GetLevel(N); + RC.Arg2 := RC.Arg1; + RC.Res := CreateBooleanVar(Level); + + if Arg = 1 then + R.Arg1 := RC.Res + else if Arg = 2 then + R.Arg2 := RC.Res + else + R.Res := RC.Res; + + Insert(I, RC); +end; + +function TCode.InsertConversionToByteBool(I: Integer; Arg: Integer): TCodeRec; +var + R, RC: TCodeRec; + Level: Integer; + T: Integer; +begin + R := Records[I]; + RC := TCodeRec.Create(0, Self); + result := RC; + + if Arg = 1 then + RC.Arg1 := R.Arg1 + else if Arg = 2 then + RC.Arg1 := R.Arg2 + else if Arg = 3 then + RC.Arg1 := R.Res + else + RaiseError(errInternalError, []); + + T := GetSymbolRec(RC.Arg1).FinalTypeId; + if T in VariantTypes then + RC.Op := OP_BYTEBOOL_FROM_VARIANT + else if T = typeRECORD then + begin + InsertImplicitConversion(I, Arg, GetSymbolRec(RC.Arg1).TerminalTypeId, + typeBYTEBOOL); + FreeAndNil(RC); + Dec(N); // will be increased by 1 + Exit; + end + else + RaiseError(errIncompatibleTypesNoArgs, []); + + Level := GetLevel(N); + + RC.Arg2 := RC.Arg1; + RC.Res := CreateByteBoolVar(Level); + + if Arg = 1 then + R.Arg1 := RC.Res + else if Arg = 2 then + R.Arg2 := RC.Res + else + R.Res := RC.Res; + + Insert(I, RC); +end; + +function TCode.InsertConversionToWordBool(I: Integer; Arg: Integer): TCodeRec; +var + R, RC: TCodeRec; + Level: Integer; + T: Integer; +begin + R := Records[I]; + RC := TCodeRec.Create(0, Self); + result := RC; + + if Arg = 1 then + RC.Arg1 := R.Arg1 + else if Arg = 2 then + RC.Arg1 := R.Arg2 + else if Arg = 3 then + RC.Arg1 := R.Res + else + RaiseError(errInternalError, []); + + T := GetSymbolRec(RC.Arg1).FinalTypeId; + if T in VariantTypes then + RC.Op := OP_WORDBOOL_FROM_VARIANT + else if T = typeRECORD then + begin + InsertImplicitConversion(I, Arg, GetSymbolRec(RC.Arg1).TerminalTypeId, + typeWORDBOOL); + FreeAndNil(RC); + Dec(N); // will be increased by 1 + Exit; + end + else + RaiseError(errIncompatibleTypesNoArgs, []); + + Level := GetLevel(N); + + RC.Arg2 := RC.Arg1; + RC.Res := CreateWordBoolVar(Level); + + if Arg = 1 then + R.Arg1 := RC.Res + else if Arg = 2 then + R.Arg2 := RC.Res + else + R.Res := RC.Res; + + Insert(I, RC); +end; + +function TCode.InsertConversionToLongBool(I: Integer; Arg: Integer): TCodeRec; +var + R, RC: TCodeRec; + Level: Integer; + T: Integer; +begin + R := Records[I]; + RC := TCodeRec.Create(0, Self); + result := RC; + + if Arg = 1 then + RC.Arg1 := R.Arg1 + else if Arg = 2 then + RC.Arg1 := R.Arg2 + else if Arg = 3 then + RC.Arg1 := R.Res + else + RaiseError(errInternalError, []); + + T := GetSymbolRec(RC.Arg1).FinalTypeId; + if T in VariantTypes then + RC.Op := OP_LONGBOOL_FROM_VARIANT + else if T = typeRECORD then + begin + InsertImplicitConversion(I, Arg, GetSymbolRec(RC.Arg1).TerminalTypeId, + typeLONGBOOL); + FreeAndNil(RC); + Dec(N); // will be increased by 1 + Exit; + end + else + RaiseError(errIncompatibleTypesNoArgs, []); + + Level := GetLevel(N); + + RC.Arg2 := RC.Arg1; + RC.Res := CreateLongBoolVar(Level); + + if Arg = 1 then + R.Arg1 := RC.Res + else if Arg = 2 then + R.Arg2 := RC.Res + else + R.Res := RC.Res; + + Insert(I, RC); +end; + +function TCode.InsertConversionToDouble(I: Integer; Arg: Integer): TCodeRec; +var + R, RC: TCodeRec; + Level: Integer; + T: Integer; +begin + R := Records[I]; + RC := TCodeRec.Create(0, Self); + + result := RC; + + if Arg = 1 then + RC.Arg1 := R.Arg1 + else if Arg = 2 then + RC.Arg1 := R.Arg2 + else if Arg = 3 then + RC.Arg1 := R.Res + else + RaiseError(errInternalError, []); + + T := GetSymbolRec(RC.Arg1).FinalTypeId; + if T = typeINT64 then + RC.Op := OP_INT64_TO_DOUBLE + else if T = typeUINT64 then + RC.Op := OP_UINT64_TO_DOUBLE + else if T in IntegerTypes then + RC.Op := OP_INT_TO_DOUBLE + else if T = typeSINGLE then + RC.Op := OP_SINGLE_TO_DOUBLE + else if T = typeCURRENCY then + RC.Op := OP_CURRENCY_TO_DOUBLE + else if T = typeEXTENDED then + RC.Op := OP_EXTENDED_TO_DOUBLE + else if T in VariantTypes then + RC.Op := OP_DOUBLE_FROM_VARIANT + else if T = typeRECORD then + begin + InsertImplicitConversion(I, Arg, GetSymbolRec(RC.Arg1).TerminalTypeId, + typeDOUBLE); + FreeAndNil(RC); + Dec(N); // will be increased by 1 + Exit; + end + else + RaiseError(errIncompatibleTypesNoArgs, []); + + Level := GetLevel(N); + + RC.Arg2 := RC.Arg1; + RC.Res := CreateDoubleVar(Level); + + if Arg = 1 then + R.Arg1 := RC.Res + else if Arg = 2 then + R.Arg2 := RC.Res + else + R.Res := RC.Res; + + Insert(I, RC); +end; + +function TCode.InsertConversionToCurrency(I: Integer; Arg: Integer): TCodeRec; +var + R, RC: TCodeRec; + Level: Integer; + T: Integer; +begin + R := Records[I]; + RC := TCodeRec.Create(0, Self); + + result := RC; + + if Arg = 1 then + RC.Arg2 := R.Arg1 + else if Arg = 2 then + RC.Arg2 := R.Arg2 + else if Arg = 3 then + RC.Arg2 := R.Res + else + RaiseError(errInternalError, []); + + T := GetSymbolRec(RC.Arg2).FinalTypeId; + if T = typeINT64 then + RC.Op := OP_CURRENCY_FROM_INT64 + else if T in IntegerTypes then + RC.Op := OP_CURRENCY_FROM_INT + else if T in RealTypes then + RC.Op := OP_CURRENCY_FROM_REAL + else if T in VariantTypes then + RC.Op := OP_CURRENCY_FROM_VARIANT + else if T = typeRECORD then + begin + InsertImplicitConversion(I, Arg, GetSymbolRec(RC.Arg1).TerminalTypeId, + typeCURRENCY); + FreeAndNil(RC); + Dec(N); // will be increased by 1 + Exit; + end + else + RaiseError(errIncompatibleTypesNoArgs, []); + + Level := GetLevel(N); + + RC.Res := CreateCurrencyVar(Level); + + if Arg = 1 then + R.Arg1 := RC.Res + else if Arg = 2 then + R.Arg2 := RC.Res + else + R.Res := RC.Res; + + Insert(I, RC); +end; + +function TCode.InsertConversionToSingle(I: Integer; Arg: Integer): TCodeRec; +var + R, RC: TCodeRec; + Level: Integer; + T: Integer; +begin + R := Records[I]; + RC := TCodeRec.Create(0, Self); + + result := RC; + + if Arg = 1 then + RC.Arg1 := R.Arg1 + else if Arg = 2 then + RC.Arg1 := R.Arg2 + else if Arg = 3 then + RC.Arg1 := R.Res + else + RaiseError(errInternalError, []); + + T := GetSymbolRec(RC.Arg1).FinalTypeId; + + if T = typeINT64 then + RC.Op := OP_INT64_TO_SINGLE + else if T = typeUINT64 then + RC.Op := OP_UINT64_TO_SINGLE + else if T in IntegerTypes then + RC.Op := OP_INT_TO_SINGLE + else if T = typeDOUBLE then + RC.Op := OP_DOUBLE_TO_SINGLE + else if T = typeCURRENCY then + RC.Op := OP_CURRENCY_TO_SINGLE + else if T = typeEXTENDED then + RC.Op := OP_EXTENDED_TO_SINGLE + else if T in VariantTypes then + RC.Op := OP_SINGLE_FROM_VARIANT + else if T = typeRECORD then + begin + InsertImplicitConversion(I, Arg, GetSymbolRec(RC.Arg1).TerminalTypeId, + typeSINGLE); + FreeAndNil(RC); + Dec(N); // will be increased by 1 + Exit; + end + else + RaiseError(errIncompatibleTypesNoArgs, []); + + Level := GetLevel(N); + + RC.Arg2 := RC.Arg1; + RC.Res := CreateSingleVar(Level); + + if Arg = 1 then + R.Arg1 := RC.Res + else if Arg = 2 then + R.Arg2 := RC.Res + else + R.Res := RC.Res; + + Insert(I, RC); +end; + +function TCode.InsertConversionToExtended(I: Integer; Arg: Integer): TCodeRec; +var + R, RC: TCodeRec; + Level: Integer; + T: Integer; + E: Extended; +begin + R := Records[I]; + RC := TCodeRec.Create(0, Self); + + result := RC; + + if Arg = 1 then + RC.Arg1 := R.Arg1 + else if Arg = 2 then + RC.Arg1 := R.Arg2 + else if Arg = 3 then + RC.Arg1 := R.Res + else + RaiseError(errInternalError, []); + + T := GetSymbolRec(RC.Arg1).FinalTypeId; + if T = typeINT64 then + RC.Op := OP_INT64_TO_EXTENDED + else if T = typeUINT64 then + RC.Op := OP_UINT64_TO_EXTENDED + else if T in IntegerTypes then + begin + if GetSymbolRec(RC.Arg1).Kind = KindCONST then + begin + RC.Op := OP_NOP; + E := GetSymbolRec(RC.Arg1).value; + RC.Res := TKernel(kernel).SymbolTable.AddExtendedConst(E).Id; + if Arg = 1 then + R.Arg1 := RC.Res + else if Arg = 3 then + R.Res := RC.Res + else + R.Arg2 := RC.Res; + Insert(I, RC); + Exit; + end; + + RC.Op := OP_INT_TO_EXTENDED; + end + else if T = typeDOUBLE then + RC.Op := OP_DOUBLE_TO_EXTENDED + else if T = typeCURRENCY then + RC.Op := OP_CURRENCY_TO_EXTENDED + else if T = typeSINGLE then + RC.Op := OP_SINGLE_TO_EXTENDED + else if T in VariantTypes then + RC.Op := OP_EXTENDED_FROM_VARIANT + else if T = typeRECORD then + begin + InsertImplicitConversion(I, Arg, GetSymbolRec(RC.Arg1).TerminalTypeId, + typeEXTENDED); + FreeAndNil(RC); + Dec(N); // will be increased by 1 + Exit; + end + else + RaiseError(errIncompatibleTypesNoArgs, []); + + Level := GetLevel(N); + + RC.Arg2 := RC.Arg1; + RC.Res := CreateExtendedVar(Level); + + if Arg = 1 then + R.Arg1 := RC.Res + else if Arg = 3 then + R.Res := RC.Res + else + R.Arg2 := RC.Res; + + Insert(I, RC); +end; + +function TCode.InsertConversionToInt64(I: Integer; Arg: Integer): TCodeRec; +var + R, RC: TCodeRec; + Level: Integer; + T: Integer; +begin + R := Records[I]; + RC := TCodeRec.Create(0, Self); + + result := RC; + + if Arg = 1 then + RC.Arg1 := R.Arg1 + else if Arg = 2 then + RC.Arg1 := R.Arg2 + else if Arg = 3 then + RC.Arg1 := R.Res + else + RaiseError(errInternalError, []); + + T := GetSymbolRec(RC.Arg1).FinalTypeId; + + if T = typeUINT64 then + begin + FreeAndNil(RC); + Dec(N); + Exit; + end; + + if T = typeINTEGER then + RC.Op := OP_INT_TO_INT64 + else if T = typeBYTE then + RC.Op := OP_BYTE_TO_INT64 + else if T = typeWORD then + RC.Op := OP_WORD_TO_INT64 + else if T = typeCARDINAL then + RC.Op := OP_CARDINAL_TO_INT64 + else if T = typeSMALLINT then + RC.Op := OP_SMALLINT_TO_INT64 + else if T = typeSHORTINT then + RC.Op := OP_SHORTINT_TO_INT64 + else if T in VariantTypes then + RC.Op := OP_INT64_FROM_VARIANT + else if T = typeRECORD then + begin + InsertImplicitConversion(I, Arg, GetSymbolRec(RC.Arg1).TerminalTypeId, + typeINT64); + FreeAndNil(RC); + Dec(N); // will be increased by 1 + Exit; + end + else + RaiseError(errIncompatibleTypesNoArgs, []); + + Level := GetLevel(N); + + RC.Arg2 := RC.Arg1; + RC.Res := CreateInt64Var(Level); + + if Arg = 1 then + R.Arg1 := RC.Res + else if Arg = 3 then + R.Res := RC.Res + else + R.Arg2 := RC.Res; + + Insert(I, RC); +end; + +function TCode.InsertConversionToUInt64(I: Integer; Arg: Integer): TCodeRec; +var + R, RC: TCodeRec; + Level: Integer; + T: Integer; +begin + R := Records[I]; + RC := TCodeRec.Create(0, Self); + + result := RC; + + if Arg = 1 then + RC.Arg1 := R.Arg1 + else if Arg = 2 then + RC.Arg1 := R.Arg2 + else if Arg = 3 then + RC.Arg1 := R.Res + else + RaiseError(errInternalError, []); + + T := GetSymbolRec(RC.Arg1).FinalTypeId; + if T = typeINT64 then + begin + FreeAndNil(RC); + Dec(N); + Exit; + end; + + if T = typeINTEGER then + RC.Op := OP_INT_TO_UINT64 + else if T = typeBYTE then + RC.Op := OP_BYTE_TO_UINT64 + else if T = typeWORD then + RC.Op := OP_WORD_TO_UINT64 + else if T = typeCARDINAL then + RC.Op := OP_CARDINAL_TO_UINT64 + else if T = typeSMALLINT then + RC.Op := OP_SMALLINT_TO_UINT64 + else if T = typeSHORTINT then + RC.Op := OP_SHORTINT_TO_UINT64 + else if T in VariantTypes then + RC.Op := OP_UINT64_FROM_VARIANT + else if T = typeINT64 then + RC.Op := OP_ASSIGN_INT64 + else if T = typeRECORD then + begin + InsertImplicitConversion(I, Arg, GetSymbolRec(RC.Arg1).TerminalTypeId, + typeUINT64); + FreeAndNil(RC); + Dec(N); // will be increased by 1 + Exit; + end + else + RaiseError(errIncompatibleTypesNoArgs, []); + + Level := GetLevel(N); + + RC.Arg2 := RC.Arg1; + RC.Res := CreateUInt64Var(Level); + + if Arg = 1 then + R.Arg1 := RC.Res + else if Arg = 3 then + R.Res := RC.Res + else + R.Arg2 := RC.Res; + + Insert(I, RC); +end; + +function TCode.FindImplicitConversion(RecordTypeId, ParamArg, + ResultArg: Integer): Integer; +var + L: TIntegerList; + SymbolTable: TSymbolTable; + I, SubId, ResultId, T: Integer; +begin + result := 0; + SymbolTable := TKernel(kernel).SymbolTable; + L := SymbolTable.LookUpAll(gen_Implicit, RecordTypeId, GetUpcase(N)); + try + if L.Count = 0 then + Exit; + + T := GetSymbolRec(ParamArg).TerminalTypeId; + if RecordTypeId = T then + begin + for I := 0 to L.Count - 1 do + begin + SubId := L[I]; + ResultId := SymbolTable.GetResultId(SubId); + if ExistsImplicitConversion(ResultId, ResultArg) then + begin + result := SubId; + Exit; + end; + end; + end + else + begin + T := GetSymbolRec(ResultArg).TerminalTypeId; + if RecordTypeId = T then + begin + for I := 0 to L.Count - 1 do + begin + SubId := L[I]; + ResultId := SymbolTable.GetParamId(SubId, 0); + if ExistsImplicitConversion(ResultId, ParamArg) then + begin + result := SubId; + Exit; + end; + end; + end; + end; + + finally + FreeAndNil(L); + end; +end; + +function TCode.FindExplicitConversion(RecordTypeId, ParamArg, + ResultArg: Integer): Integer; +var + L: TIntegerList; + SymbolTable: TSymbolTable; + I, SubId, ResultId, T: Integer; +begin + result := 0; + SymbolTable := TKernel(kernel).SymbolTable; + L := SymbolTable.LookUpAll(gen_Explicit, RecordTypeId, GetUpcase(N)); + try + if L.Count = 0 then + Exit; + + T := GetSymbolRec(ParamArg).TerminalTypeId; + if RecordTypeId = T then + begin + for I := 0 to L.Count - 1 do + begin + SubId := L[I]; + ResultId := SymbolTable.GetResultId(SubId); + if ExistsImplicitConversion(ResultId, ResultArg) then + begin + result := SubId; + Exit; + end; + end; + end + else + begin + T := GetSymbolRec(ResultArg).TerminalTypeId; + if RecordTypeId = T then + begin + for I := 0 to L.Count - 1 do + begin + SubId := L[I]; + ResultId := SymbolTable.GetParamId(SubId, 0); + if ExistsImplicitConversion(ResultId, ParamArg) then + begin + result := SubId; + Exit; + end; + end; + end; + end; + + finally + FreeAndNil(L); + end; +end; + +function TCode.InsertConversionToRecord(I, Arg, RecordTypeId, ValueId: Integer) + : TCodeRec; +var + R, RC: TCodeRec; + Level, SubId: Integer; + S: String; +begin + R := Records[I]; + + S := gen_Implicit; + SubId := TKernel(kernel).SymbolTable.LookUp(S, RecordTypeId, GetUpcase(N)); + if SubId = 0 then + RaiseError(errIncompatibleTypesNoArgs, []); + + Level := GetLevel(N); + + RC := TCodeRec.Create(OP_PUSH, Self); + RC.Arg1 := ValueId; + RC.Arg2 := 0; + RC.Res := SubId; + Insert(N, RC); + Inc(N); + + RC := TCodeRec.Create(OP_CALL, Self); + RC.Arg1 := SubId; + RC.Arg2 := 1; + RC.Res := CreateRecordVar(Level, RecordTypeId); + Insert(N, RC); + Inc(N); + + case Arg of + 1: + R.Arg1 := RC.Res; + 2: + R.Arg2 := RC.Res; + 3: + R.Res := RC.Res; + end; + + Dec(N, 3); + + result := RC; +end; + +function TCode.ExistsBinaryOperator(RecordTypeId: Integer; + const OperatorName: String): Boolean; +var + R: TCodeRec; + SubId: Integer; +begin + result := false; + R := Records[N]; + SubId := TKernel(kernel).SymbolTable.LookUp(OperatorName, RecordTypeId, + GetUpcase(N)); + if SubId = 0 then + begin + if GetSymbolRec(R.Arg1).TerminalTypeId = GetSymbolRec(R.Arg2).TerminalTypeId + then + if (OperatorName = gen_Equal) or (OperatorName = gen_NotEqual) then + result := true; + end + else + result := true; +end; + +procedure TCode.InsertBinaryOperator(RecordTypeId: Integer; + const OperatorName: String); +var + R, RC: TCodeRec; + Level, SubId, Res: Integer; +begin + R := Records[N]; + Res := R.Res; + + SubId := TKernel(kernel).SymbolTable.LookUp(OperatorName, RecordTypeId, + GetUpcase(N)); + if SubId = 0 then + begin + if GetSymbolRec(R.Arg1).TerminalTypeId = GetSymbolRec(R.Arg2).TerminalTypeId + then + begin + + if OperatorName = gen_Equal then + begin + R.Op := OP_EQ_STRUCT; + Dec(N); + Exit; + end; + + if OperatorName = gen_NotEqual then + begin + R.Op := OP_NE_STRUCT; + Dec(N); + Exit; + end; + + end; + + RaiseError(errE2015, []); + // Operator not applicable to this operand type + end; + + Level := GetLevel(N); + + RC := TCodeRec.Create(OP_PUSH, Self); + RC.Arg1 := R.Arg1; + RC.Arg2 := 0; + RC.Res := SubId; + Insert(N, RC); + Inc(N); + + RC := TCodeRec.Create(OP_PUSH, Self); + RC.Arg1 := R.Arg2; + RC.Arg2 := 1; + RC.Res := SubId; + Insert(N, RC); + Inc(N); + + R.Op := OP_CALL; + R.Arg1 := SubId; + R.Arg2 := 2; + R.Res := CreateRecordVar(Level, RecordTypeId); + + ReplaceId(Res, R.Res); + + Dec(N, 4); +end; + +procedure TCode.InsertUnaryOperator(RecordTypeId: Integer; + const OperatorName: String); +var + R, RC: TCodeRec; + Level, SubId, Res: Integer; +begin + R := Records[N]; + Res := R.Res; + + SubId := TKernel(kernel).SymbolTable.LookUp(OperatorName, RecordTypeId, + GetUpcase(N)); + if SubId = 0 then + RaiseError(errE2015, []); + // Operator not applicable to this operand type + + Level := GetLevel(N); + + RC := TCodeRec.Create(OP_PUSH, Self); + RC.Arg1 := R.Arg1; + RC.Arg2 := 0; + RC.Res := SubId; + Insert(N, RC); + Inc(N); + + R.Op := OP_CALL; + R.Arg1 := SubId; + R.Arg2 := 1; + R.Res := CreateRecordVar(Level, RecordTypeId); + + ReplaceId(Res, R.Res); + + Dec(N, 3); +end; + +{$IFNDEF PAXARM} + +function TCode.InsertConversionToAnsiString(I: Integer; Arg: Integer; + Lang: Integer = PASCAL_LANGUAGE): TCodeRec; +var + R, RC, RD: TCodeRec; + Level: Integer; + SymbolTable: TSymbolTable; + Id, T: Integer; + S: String; +begin + R := Records[I]; + SymbolTable := TKernel(kernel).SymbolTable; + + RC := TCodeRec.Create(0, Self); + + result := RC; + + if Arg = 1 then + begin + RC.Arg2 := R.Arg1; + Id := R.Arg1; + end + else if Arg = 2 then + begin + RC.Arg2 := R.Arg2; + Id := R.Arg2; + end + else if Arg = 3 then + begin + RC.Arg2 := R.Res; + Id := R.Res; + end + else + begin + CreateError(errInternalError, []); + FreeAndNil(RC); + result := nil; + Exit; + end; + + T := SymbolTable[Id].FinalTypeId; + + if T = typeWIDECHAR then + begin + if SymbolTable[Id].Kind = KindCONST then + begin + S := Chr(Integer(SymbolTable[Id].value)); + RC.Arg2 := TKernel(kernel).SymbolTable.AddPAnsiCharConst + (AnsiString(S)).Id; + RC.Op := OP_ANSISTRING_FROM_PANSICHAR; + end + else + RC.Op := OP_ANSISTRING_FROM_WIDECHAR; + end + else if T = typeANSICHAR then + begin + if SymbolTable[Id].Kind = KindCONST then + begin + S := Chr(Integer(SymbolTable[Id].value)); + RC.Arg2 := TKernel(kernel).SymbolTable.AddPAnsiCharConst + (AnsiString(S)).Id; + RC.Op := OP_ANSISTRING_FROM_PANSICHAR; + end + else + RC.Op := OP_ANSISTRING_FROM_ANSICHAR; + end + else if T = typeWIDESTRING then + RC.Op := OP_ANSISTRING_FROM_WIDESTRING + else if T = typeSHORTSTRING then + RC.Op := OP_ANSISTRING_FROM_SHORTSTRING + else if T = typeUNICSTRING then + RC.Op := OP_ANSISTRING_FROM_UNICSTRING + else if T in VariantTypes then + RC.Op := OP_ANSISTRING_FROM_VARIANT + else if SymbolTable[Id].HasPAnsiCharType then + RC.Op := OP_ANSISTRING_FROM_PANSICHAR + else if SymbolTable[Id].HasPWideCharType then + RC.Op := OP_ANSISTRING_FROM_PWIDECHAR + else if T = typeRECORD then + begin + InsertImplicitConversion(I, Arg, SymbolTable[Id].TerminalTypeId, + typeANSISTRING); + FreeAndNil(RC); + Dec(N); // will be increased by 1 + result := nil; + Exit; + end + else + begin + if Lang = JS_LANGUAGE then + begin + if T in IntegerTypes then + RC.Op := OP_ANSISTRING_FROM_INT + else if T = typeDOUBLE then + RC.Op := OP_ANSISTRING_FROM_DOUBLE + else if T = typeSINGLE then + RC.Op := OP_ANSISTRING_FROM_SINGLE + else if T = typeEXTENDED then + RC.Op := OP_ANSISTRING_FROM_EXTENDED + else if T = typeBOOLEAN then + RC.Op := OP_ANSISTRING_FROM_BOOLEAN + else + begin + CreateError(errIncompatibleTypesNoArgs, []); + FreeAndNil(RC); + result := nil; + Exit; + end; + end + else + begin + CreateError(errIncompatibleTypesNoArgs, []); + FreeAndNil(RC); + result := nil; + Exit; + end; + end; + + Level := GetLevel(N); + + RC.Arg1 := CreateStringVar(Level); + RC.Res := RC.Arg1; + + if Arg = 1 then + R.Arg1 := RC.Res + else if Arg = 3 then + R.Res := RC.Res + else + R.Arg2 := RC.Res; + + RD := TCodeRec.Create(OP_DECLARE_TEMP_VAR, Self); + RD.Arg1 := Level; + RD.Arg2 := RC.Res; + RD.Res := 0; + Insert(I, RD); + Inc(I); + Inc(N); + + Insert(I, RC); +end; + +function TCode.InsertConversionToShortString(I: Integer; Arg: Integer) + : TCodeRec; +var + R, RC: TCodeRec; + Level: Integer; + SymbolTable: TSymbolTable; + Id, T, L, TypeId: Integer; + S: String; +begin + R := Records[I]; + SymbolTable := TKernel(kernel).SymbolTable; + + RC := TCodeRec.Create(0, Self); + + result := RC; + + if Arg = 1 then + begin + RC.Arg2 := R.Arg1; + Id := R.Arg1; + end + else if Arg = 2 then + begin + RC.Arg2 := R.Arg2; + Id := R.Arg2; + end + else if Arg = 3 then + begin + RC.Arg2 := R.Res; + Id := R.Res; + end + else + begin + CreateError(errInternalError, []); + FreeAndNil(RC); + result := nil; + Exit; + end; + + T := SymbolTable[Id].FinalTypeId; + + if SymbolTable[Id].HasPAnsiCharType then + begin + if SymbolTable[Id].Kind = KindCONST then + RC.Op := OP_SHORTSTRING_FROM_PANSICHAR_LITERAL + else + begin + CreateError(errInternalError, []); + FreeAndNil(RC); + result := nil; + Exit; + end; + end + else if T = typeANSICHAR then + begin + if SymbolTable[Id].Kind = KindCONST then + begin + S := Chr(Integer(SymbolTable[Id].value)); + RC.Arg2 := TKernel(kernel).SymbolTable.AddPAnsiCharConst + (AnsiString(S)).Id; + RC.Op := OP_SHORTSTRING_FROM_PANSICHAR_LITERAL; + end + else + RC.Op := OP_SHORTSTRING_FROM_ANSICHAR; + end + else if SymbolTable[Id].HasPWideCharType then + begin + if SymbolTable[Id].Kind = KindCONST then + RC.Op := OP_SHORTSTRING_FROM_PWIDECHAR_LITERAL + else + begin + CreateError(errInternalError, []); + FreeAndNil(RC); + result := nil; + Exit; + end; + end + else if T = typeANSISTRING then + begin + RC.Op := OP_SHORTSTRING_FROM_ANSISTRING; + end + else if T = typeWIDESTRING then + begin + RC.Op := OP_SHORTSTRING_FROM_WIDESTRING; + end + else if T = typeUNICSTRING then + begin + RC.Op := OP_SHORTSTRING_FROM_UNICSTRING; + end + else if T in VariantTypes then + begin + RC.Op := OP_SHORTSTRING_FROM_VARIANT; + end + else if T = typeRECORD then + begin + InsertImplicitConversion(I, Arg, SymbolTable[Id].TerminalTypeId, + typeSHORTSTRING); + FreeAndNil(RC); + Dec(N); // will be increased by 1 + result := nil; + Exit; + end + else + begin + CreateError(errIncompatibleTypesNoArgs, []); + FreeAndNil(RC); + result := nil; + Exit; + end; + + Level := GetLevel(N); + + L := 255; + TypeId := SymbolTable.RegisterShortStringType(0, '', L); + + RC.Arg1 := CreateShortStringVar(Level, TypeId); + RC.Res := RC.Arg1; + + if Arg = 1 then + R.Arg1 := RC.Res + else if Arg = 2 then + R.Arg2 := RC.Res + else + R.Res := RC.Res; + + Insert(I, RC); +end; + +function TCode.InsertConversionToWideString(I: Integer; Arg: Integer): TCodeRec; +var + R, RC, RD: TCodeRec; + Level: Integer; + SymbolTable: TSymbolTable; + Id, T: Integer; + S: String; + TempVarId: Integer; + Found: Boolean; +begin + R := Records[I]; + SymbolTable := TKernel(kernel).SymbolTable; + + RC := TCodeRec.Create(0, Self); + + result := RC; + + if Arg = 1 then + begin + RC.Arg2 := R.Arg1; + Id := R.Arg1; + end + else if Arg = 2 then + begin + RC.Arg2 := R.Arg2; + Id := R.Arg2; + end + else if Arg = 3 then + begin + RC.Arg2 := R.Res; + Id := R.Res; + end + else + begin + CreateError(errInternalError, []); + FreeAndNil(RC); + result := nil; + Exit; + end; + + T := SymbolTable[Id].FinalTypeId; + + if T = typeWIDECHAR then + begin + if SymbolTable[Id].Kind = KindCONST then + RC.Op := OP_WIDESTRING_FROM_WIDECHAR_LITERAL + else + RC.Op := OP_WIDESTRING_FROM_WIDECHAR; + end + else if T = typeANSICHAR then + begin + if SymbolTable[Id].Kind = KindCONST then + begin + S := Chr(Integer(SymbolTable[Id].value)); + RC.Arg2 := TKernel(kernel).SymbolTable.AddPAnsiCharConst + (AnsiString(S)).Id; + RC.Op := OP_WIDESTRING_FROM_PANSICHAR_LITERAL; + end + else + RC.Op := OP_WIDESTRING_FROM_ANSICHAR; + end + else if T = typeSHORTSTRING then + RC.Op := OP_WIDESTRING_FROM_SHORTSTRING + else if T = typeUNICSTRING then + RC.Op := OP_WIDESTRING_FROM_UNICSTRING + else if T = typeANSISTRING then + RC.Op := OP_WIDESTRING_FROM_ANSISTRING + else if T in VariantTypes then + RC.Op := OP_WIDESTRING_FROM_VARIANT + else if SymbolTable[Id].HasPAnsiCharType then + RC.Op := OP_WIDESTRING_FROM_PANSICHAR_LITERAL + else if SymbolTable[Id].HasPWideCharType then + RC.Op := OP_WIDESTRING_FROM_PWIDECHAR_LITERAL + else if T = typeRECORD then + begin + InsertImplicitConversion(I, Arg, SymbolTable[Id].TerminalTypeId, + typeWIDESTRING); + FreeAndNil(RC); + Dec(N); // will be increased by 1 + result := nil; + Exit; + end + else + begin + CreateError(errIncompatibleTypesNoArgs, []); + FreeAndNil(RC); + result := nil; + Exit; + end; + + Level := GetLevel(N); + + TempVarId := LookupTempVarId(Level, typeWIDESTRING); + + if TempVarId = 0 then + begin + Found := false; + TempVarId := CreateWideStringVar(Level); + temp_var_list.Add(TempVarId, GetStmt(N)); + end + else + Found := true; + + RC.Arg1 := TempVarId; + RC.Res := RC.Arg1; + + if Arg = 1 then + R.Arg1 := RC.Res + else if Arg = 3 then + R.Res := RC.Res + else + R.Arg2 := RC.Res; + + if not Found then + begin + RD := TCodeRec.Create(OP_DECLARE_TEMP_VAR, Self); + RD.Arg1 := Level; + RD.Arg2 := RC.Res; + RD.Res := 0; + Insert(I, RD); + Inc(I); + Inc(N); + end; + + Insert(I, RC); +end; +{$ENDIF} + +function TCode.InsertImplicitConversion(I, Arg, RecordTypeId, + ResultTypeId: Integer): TCodeRec; +var + Id: Integer; + R, RD: TCodeRec; + TempId, TempResId, SubId, T2, OldN, OldCard: Integer; + SymbolTable: TSymbolTable; +begin + result := nil; + + R := Records[I]; + SymbolTable := TKernel(kernel).SymbolTable; + + if Arg = 1 then + Id := R.Arg1 + else if Arg = 2 then + Id := R.Arg2 + else + Id := R.Res; + + OldN := N; + OldCard := Card; + + TempId := NewTempVar(GetLevel(N), ResultTypeId); + SubId := FindImplicitConversion(RecordTypeId, Id, TempId); + + if SubId = 0 then + begin + RaiseError(errIncompatibleTypesNoArgs, []); + Exit; + end; + + T2 := SymbolTable.GetResultId(SubId); + T2 := GetSymbolRec(T2).TypeId; + + TempResId := NewTempVar(GetLevel(N), T2); + + RD := TCodeRec.Create(OP_DECLARE_TEMP_VAR, Self); + RD.Arg1 := GetLevel(N); + RD.Arg2 := TempId; + RD.Res := 0; + Insert(I, RD); + Inc(I); + + RD := TCodeRec.Create(OP_DECLARE_TEMP_VAR, Self); + RD.Arg1 := GetLevel(N); + RD.Arg2 := TempResId; + RD.Res := 0; + Insert(I, RD); + Inc(I); + + RD := TCodeRec.Create(OP_PUSH, Self); + RD.Arg1 := Id; + RD.Arg2 := 0; + RD.Res := SubId; + Insert(I, RD); + Inc(I); + + RD := TCodeRec.Create(OP_CALL, Self); + RD.Arg1 := SubId; + RD.Arg2 := 1; + RD.Res := TempResId; + Insert(I, RD); + + N := I; + NoOverloadSearch := true; + OperCall; + Inc(N); + + RD := TCodeRec.Create(OP_ASSIGN, Self); + RD.Arg1 := TempId; + RD.Arg2 := TempResId; + RD.Res := TempId; + Insert(N, RD); + + result := RD; + + OperAssignment; + + if Arg = 1 then + R.Arg1 := TempId + else if Arg = 2 then + R.Arg2 := TempId + else if Arg = 3 then + R.Res := TempId; + + N := OldN + (Card - OldCard); +end; + +function TCode.InsertExplicitConversion(I, RecordTypeId, ResultTypeId: Integer) + : TCodeRec; +var + Id: Integer; + R, RD: TCodeRec; + TempId, TempResId, SubId, T2, OldN, OldCard: Integer; + SymbolTable: TSymbolTable; +begin + result := nil; + + R := Records[I]; + SymbolTable := TKernel(kernel).SymbolTable; + + Id := R.Arg2; + + OldN := N; + OldCard := Card; + + TempId := NewTempVar(GetLevel(N), ResultTypeId); + + SubId := FindExplicitConversion(RecordTypeId, Id, TempId); + if SubId = 0 then + SubId := FindImplicitConversion(RecordTypeId, Id, TempId); + + if SubId = 0 then + begin + RaiseError(errIncompatibleTypesNoArgs, []); + Exit; + end; + + T2 := SymbolTable.GetResultId(SubId); + T2 := GetSymbolRec(T2).TypeId; + + TempResId := NewTempVar(GetLevel(N), T2); + + RD := TCodeRec.Create(OP_DECLARE_TEMP_VAR, Self); + RD.Arg1 := GetLevel(N); + RD.Arg2 := TempId; + RD.Res := 0; + Insert(I, RD); + Inc(I); + + RD := TCodeRec.Create(OP_DECLARE_TEMP_VAR, Self); + RD.Arg1 := GetLevel(N); + RD.Arg2 := TempResId; + RD.Res := 0; + Insert(I, RD); + Inc(I); + + RD := TCodeRec.Create(OP_PUSH, Self); + RD.Arg1 := Id; + RD.Arg2 := 0; + RD.Res := SubId; + Insert(I, RD); + Inc(I); + + RD := TCodeRec.Create(OP_CALL, Self); + RD.Arg1 := SubId; + RD.Arg2 := 1; + RD.Res := TempResId; + Insert(I, RD); + + N := I; + NoOverloadSearch := true; + OperCall; + Inc(N); + + RD := TCodeRec.Create(OP_ASSIGN, Self); + RD.Arg1 := TempId; + RD.Arg2 := TempResId; + RD.Res := TempId; + Insert(N, RD); + + result := RD; + + OperAssignment; + + R.Arg2 := TempId; + + N := OldN + (Card - OldCard); +end; + +function TCode.InsertConversionToUnicString(I: Integer; Arg: Integer; + Lang: Integer = PASCAL_LANGUAGE): TCodeRec; +var + R, RC, RD: TCodeRec; + Level: Integer; + SymbolTable: TSymbolTable; + Id, T, TempVarId: Integer; +{$IFNDEF PAXARM} + S: String; +{$ENDIF} + Found: Boolean; +begin + R := Records[I]; + SymbolTable := TKernel(kernel).SymbolTable; + + RC := TCodeRec.Create(0, Self); + + result := RC; + + if Arg = 1 then + begin + RC.Arg2 := R.Arg1; + Id := R.Arg1; + end + else if Arg = 2 then + begin + RC.Arg2 := R.Arg2; + Id := R.Arg2; + end + else if Arg = 3 then + begin + RC.Arg2 := R.Res; + Id := R.Res; + end + else + begin + CreateError(errInternalError, []); + FreeAndNil(RC); + result := nil; + Exit; + end; + + T := SymbolTable[Id].FinalTypeId; + + if T = typeWIDECHAR then + begin + if SymbolTable[Id].Kind = KindCONST then + RC.Op := OP_UNICSTRING_FROM_WIDECHAR_LITERAL + else + RC.Op := OP_UNICSTRING_FROM_WIDECHAR; + end +{$IFNDEF PAXARM} + else if T = typeANSICHAR then + begin + if SymbolTable[Id].Kind = KindCONST then + begin + S := Chr(Integer(SymbolTable[Id].value)); + RC.Arg2 := TKernel(kernel).SymbolTable.AddPAnsiCharConst + (AnsiString(S)).Id; + RC.Op := OP_UNICSTRING_FROM_PANSICHAR_LITERAL; + end + else + RC.Op := OP_UNICSTRING_FROM_ANSICHAR; + end + else if T = typeWIDESTRING then + RC.Op := OP_UNICSTRING_FROM_WIDESTRING + else if T = typeSHORTSTRING then + RC.Op := OP_UNICSTRING_FROM_SHORTSTRING + else if T = typeANSISTRING then + RC.Op := OP_UNICSTRING_FROM_ANSISTRING + else if SymbolTable[Id].HasPAnsiCharType then + RC.Op := OP_UNICSTRING_FROM_PANSICHAR_LITERAL +{$ENDIF} + else if T in VariantTypes then + RC.Op := OP_UNICSTRING_FROM_VARIANT + else if SymbolTable[Id].HasPWideCharType then + RC.Op := OP_UNICSTRING_FROM_PWIDECHAR_LITERAL + else if T = typeRECORD then + begin + FreeAndNil(RC); + InsertImplicitConversion(I, Arg, SymbolTable[Id].TerminalTypeId, + typeUNICSTRING); + Dec(N); // will be increased by 1 + result := nil; + Exit; + end + else + begin + if Lang = JS_LANGUAGE then + begin + if T in IntegerTypes then + RC.Op := OP_UNICSTRING_FROM_INT + else if T = typeDOUBLE then + RC.Op := OP_UNICSTRING_FROM_DOUBLE + else if T = typeSINGLE then + RC.Op := OP_UNICSTRING_FROM_SINGLE + else if T = typeEXTENDED then + RC.Op := OP_UNICSTRING_FROM_EXTENDED + else if T = typeBOOLEAN then + RC.Op := OP_UNICSTRING_FROM_BOOLEAN + else + begin + CreateError(errIncompatibleTypesNoArgs, []); + FreeAndNil(RC); + result := nil; + Exit; + end; + end + else + begin + CreateError(errIncompatibleTypesNoArgs, []); + FreeAndNil(RC); + result := nil; + Exit; + end; + end; + + Level := GetLevel(N); + + TempVarId := LookupTempVarId(Level, typeUNICSTRING); + + if TempVarId = 0 then + begin + Found := false; + TempVarId := CreateUnicStringVar(Level); + temp_var_list.Add(TempVarId, GetStmt(N)); + end + else + Found := true; + + RC.Arg1 := TempVarId; + RC.Res := RC.Arg1; + + if Arg = 1 then + R.Arg1 := RC.Res + else if Arg = 3 then + R.Res := RC.Res + else + R.Arg2 := RC.Res; + + if not Found then + begin + RD := TCodeRec.Create(OP_DECLARE_TEMP_VAR, Self); + RD.Arg1 := Level; + RD.Arg2 := RC.Res; + RD.Res := 0; + Insert(I, RD); + Inc(I); + Inc(N); + end; + + Insert(I, RC); +end; + +function TCode.InsertConversionToVariant(I: Integer; Arg: Integer): TCodeRec; +var + R, RC, RD: TCodeRec; + Level: Integer; + SymbolTable: TSymbolTable; + Id, T: Integer; +{$IFNDEF PAXARM} + S: String; +{$ENDIF} + Lang, TempVarId: Integer; + Found: Boolean; +begin + R := Records[I]; + Lang := R.Language; + + SymbolTable := TKernel(kernel).SymbolTable; + + RC := TCodeRec.Create(0, Self); + + result := RC; + + if Arg = 1 then + begin + RC.Arg2 := R.Arg1; + Id := R.Arg1; + end + else if Arg = 2 then + begin + RC.Arg2 := R.Arg2; + Id := R.Arg2; + end + else if Arg = 3 then + begin + RC.Arg2 := R.Res; + Id := R.Res; + end + else + begin + CreateError(errInternalError, []); + FreeAndNil(RC); + result := nil; + Exit; + end; + + T := SymbolTable[Id].FinalTypeId; + + if T = typeWIDECHAR then + begin + if SymbolTable[Id].Kind = KindCONST then + RC.Op := OP_VARIANT_FROM_WIDECHAR_LITERAL + else + RC.Op := OP_VARIANT_FROM_WIDECHAR; + end +{$IFNDEF PAXARM} + else if T = typeANSICHAR then + begin + if SymbolTable[Id].Kind = KindCONST then + begin + S := Chr(Integer(SymbolTable[Id].value)); + RC.Arg2 := TKernel(kernel).SymbolTable.AddPAnsiCharConst + (AnsiString(S)).Id; + RC.Op := OP_VARIANT_FROM_PANSICHAR_LITERAL; + end + else + RC.Op := OP_VARIANT_FROM_ANSICHAR; + end +{$ENDIF} + else if T in IntegerTypes then + begin + if GetSymbolRec(Id).Kind = KindCONST then + begin + RC.Op := OP_NOP; + RC.Res := TKernel(kernel).SymbolTable.AddVariantConst + (GetSymbolRec(Id).value).Id; + case Arg of + 1: + R.Arg1 := RC.Res; + 2: + R.Arg2 := RC.Res; + 3: + R.Res := RC.Res; + end; + Insert(I, RC); + Exit; + end; + case T of + typeINTEGER: + RC.Op := OP_VARIANT_FROM_INT; + typeINT64: + RC.Op := OP_VARIANT_FROM_INT64; + typeBYTE: + RC.Op := OP_VARIANT_FROM_BYTE; + typeWORD: + RC.Op := OP_VARIANT_FROM_WORD; + typeCARDINAL: + RC.Op := OP_VARIANT_FROM_CARDINAL; + typeSMALLINT: + RC.Op := OP_VARIANT_FROM_SMALLINT; + typeSHORTINT: + RC.Op := OP_VARIANT_FROM_SHORTINT; + end; + end + else if T = typeBOOLEAN then + begin + if GetSymbolRec(Id).Kind = KindCONST then + begin + RC.Op := OP_NOP; + RC.Res := TKernel(kernel).SymbolTable.AddVariantConst + (Boolean(GetSymbolRec(Id).value)).Id; + case Arg of + 1: + R.Arg1 := RC.Res; + 2: + R.Arg2 := RC.Res; + 3: + R.Res := RC.Res; + end; + Insert(I, RC); + Exit; + end; + RC.Op := OP_VARIANT_FROM_BOOL; + end + else if T = typeDOUBLE then + RC.Op := OP_VARIANT_FROM_DOUBLE + else if T = typeCURRENCY then + RC.Op := OP_VARIANT_FROM_CURRENCY + else if T = typeSINGLE then + RC.Op := OP_VARIANT_FROM_SINGLE + else if T = typeEXTENDED then + RC.Op := OP_VARIANT_FROM_EXTENDED + else if T = typeINTERFACE then + RC.Op := OP_VARIANT_FROM_INTERFACE +{$IFNDEF PAXARM} + else if T = typeSHORTSTRING then + RC.Op := OP_VARIANT_FROM_SHORTSTRING + else if T = typeWIDESTRING then + RC.Op := OP_VARIANT_FROM_WIDESTRING + else if T = typeANSISTRING then + RC.Op := OP_VARIANT_FROM_ANSISTRING + else if SymbolTable[Id].HasPAnsiCharType then + RC.Op := OP_VARIANT_FROM_PANSICHAR_LITERAL +{$ENDIF} + else if T = typeUNICSTRING then + RC.Op := OP_VARIANT_FROM_UNICSTRING + else if SymbolTable[Id].HasPWideCharType then + RC.Op := OP_VARIANT_FROM_PWIDECHAR_LITERAL + else if T = typeRECORD then + begin + InsertImplicitConversion(I, Arg, SymbolTable[Id].TerminalTypeId, + typeVARIANT); + FreeAndNil(RC); + Dec(N); // will be increased by 1 + result := nil; + Exit; + end + else + begin + + if (Lang = JS_LANGUAGE) or (Lang = BASIC_LANGUAGE) then + begin + + if T = typeCLASS then + RC.Op := OP_VARIANT_FROM_CLASS + else if T = typePOINTER then + RC.Op := OP_VARIANT_FROM_POINTER + else + begin + CreateError(errIncompatibleTypesNoArgs, []); + FreeAndNil(RC); + Exit; + end; + + end + else + begin + CreateError(errIncompatibleTypesNoArgs, []); + FreeAndNil(RC); + result := nil; + Exit; + end; + end; + + Level := GetLevel(N); + + TempVarId := 0; // LookupTempVarId(Level, typeVARIANT); + + if TempVarId = 0 then + begin + Found := false; + TempVarId := CreateVariantVar(Level); + temp_var_list.Add(TempVarId, GetStmt(N)); + end + else + Found := true; + + RC.Arg1 := TempVarId; + RC.Res := RC.Arg1; + + if Arg = 1 then + R.Arg1 := RC.Res + else if Arg = 3 then + R.Res := RC.Res + else + R.Arg2 := RC.Res; + + if not Found then + begin + RD := TCodeRec.Create(OP_DECLARE_TEMP_VAR, Self); + RD.Arg1 := Level; + RD.Arg2 := RC.Res; + RD.Res := 0; + Insert(I, RD); + Inc(I); + Inc(N); + end; + + Insert(I, RC); +end; + +function TCode.InsertConversionToOleVariant(I: Integer; Arg: Integer): TCodeRec; +var + R, RC, RD: TCodeRec; + Level: Integer; + SymbolTable: TSymbolTable; + Id, T: Integer; +{$IFNDEF PAXARM} + S: String; +{$ENDIF} + Lang, TempVarId: Integer; + Found: Boolean; +begin + R := Records[I]; + Lang := R.Language; + + SymbolTable := TKernel(kernel).SymbolTable; + + RC := TCodeRec.Create(0, Self); + + result := RC; + + if Arg = 1 then + begin + RC.Arg2 := R.Arg1; + Id := R.Arg1; + end + else if Arg = 2 then + begin + RC.Arg2 := R.Arg2; + Id := R.Arg2; + end + else if Arg = 3 then + begin + RC.Arg2 := R.Res; + Id := R.Res; + end + else + begin + CreateError(errInternalError, []); + FreeAndNil(RC); + result := nil; + Exit; + end; + + T := SymbolTable[Id].FinalTypeId; + + if T = typeWIDECHAR then + begin + if SymbolTable[Id].Kind = KindCONST then + RC.Op := OP_OLEVARIANT_FROM_WIDECHAR_LITERAL + else + RC.Op := OP_OLEVARIANT_FROM_WIDECHAR; + end +{$IFNDEF PAXARM} + else if T = typeANSICHAR then + begin + if SymbolTable[Id].Kind = KindCONST then + begin + S := Chr(Integer(SymbolTable[Id].value)); + RC.Arg2 := TKernel(kernel).SymbolTable.AddPAnsiCharConst + (AnsiString(S)).Id; + RC.Op := OP_OLEVARIANT_FROM_PANSICHAR_LITERAL; + end + else + RC.Op := OP_OLEVARIANT_FROM_ANSICHAR; + end +{$ENDIF} + else if T in IntegerTypes then + begin + if GetSymbolRec(Id).Kind = KindCONST then + begin + RC.Op := OP_NOP; + RC.Res := TKernel(kernel).SymbolTable.AddVariantConst + (GetSymbolRec(Id).value).Id; + case Arg of + 1: + R.Arg1 := RC.Res; + 2: + R.Arg2 := RC.Res; + 3: + R.Res := RC.Res; + end; + Insert(I, RC); + Exit; + end; + case T of + typeINTEGER: + RC.Op := OP_OLEVARIANT_FROM_INT; + typeINT64: + RC.Op := OP_OLEVARIANT_FROM_INT64; + typeBYTE: + RC.Op := OP_OLEVARIANT_FROM_BYTE; + typeWORD: + RC.Op := OP_OLEVARIANT_FROM_WORD; + typeCARDINAL: + RC.Op := OP_OLEVARIANT_FROM_CARDINAL; + typeSMALLINT: + RC.Op := OP_OLEVARIANT_FROM_SMALLINT; + typeSHORTINT: + RC.Op := OP_OLEVARIANT_FROM_SHORTINT; + end; + end + else if T = typeBOOLEAN then + begin + if GetSymbolRec(Id).Kind = KindCONST then + begin + RC.Op := OP_NOP; + RC.Res := TKernel(kernel).SymbolTable.AddVariantConst + (Boolean(GetSymbolRec(Id).value)).Id; + case Arg of + 1: + R.Arg1 := RC.Res; + 2: + R.Arg2 := RC.Res; + 3: + R.Res := RC.Res; + end; + Insert(I, RC); + Exit; + end; + RC.Op := OP_OLEVARIANT_FROM_BOOL; + end + else if T = typeDOUBLE then + RC.Op := OP_OLEVARIANT_FROM_DOUBLE + else if T = typeCURRENCY then + RC.Op := OP_OLEVARIANT_FROM_CURRENCY + else if T = typeSINGLE then + RC.Op := OP_OLEVARIANT_FROM_SINGLE + else if T = typeEXTENDED then + RC.Op := OP_OLEVARIANT_FROM_EXTENDED + else if T = typeINTERFACE then + RC.Op := OP_OLEVARIANT_FROM_INTERFACE +{$IFNDEF PAXARM} + else if T = typeSHORTSTRING then + RC.Op := OP_OLEVARIANT_FROM_SHORTSTRING + else if T = typeWIDESTRING then + RC.Op := OP_OLEVARIANT_FROM_WIDESTRING + else if T = typeANSISTRING then + RC.Op := OP_OLEVARIANT_FROM_ANSISTRING + else if SymbolTable[Id].HasPAnsiCharType then + RC.Op := OP_OLEVARIANT_FROM_PANSICHAR_LITERAL +{$ENDIF} + else if T = typeUNICSTRING then + RC.Op := OP_OLEVARIANT_FROM_UNICSTRING + else if T = typeVARIANT then + RC.Op := OP_OLEVARIANT_FROM_VARIANT + else if SymbolTable[Id].HasPWideCharType then + RC.Op := OP_OLEVARIANT_FROM_PWIDECHAR_LITERAL + else if T = typeRECORD then + begin + InsertImplicitConversion(I, Arg, SymbolTable[Id].TerminalTypeId, + typeOLEVARIANT); + FreeAndNil(RC); + Dec(N); // will be increased by 1 + result := nil; + Exit; + end + else + begin + + if Lang = JS_LANGUAGE then + begin + + if T = typeCLASS then + RC.Op := OP_VARIANT_FROM_CLASS + else if T = typePOINTER then + RC.Op := OP_VARIANT_FROM_POINTER + else + begin + CreateError(errIncompatibleTypesNoArgs, []); + FreeAndNil(RC); + result := nil; + Exit; + end; + + end + else + begin + CreateError(errIncompatibleTypesNoArgs, []); + FreeAndNil(RC); + result := nil; + Exit; + end; + end; + + Level := GetLevel(N); + + TempVarId := LookupTempVarId(Level, typeOLEVARIANT); + + if TempVarId = 0 then + begin + Found := false; + TempVarId := CreateOleVariantVar(Level); + temp_var_list.Add(TempVarId, GetStmt(N)); + end + else + Found := true; + + RC.Arg1 := TempVarId; + RC.Res := RC.Arg1; + + if Arg = 1 then + R.Arg1 := RC.Res + else if Arg = 3 then + R.Res := RC.Res + else + R.Arg2 := RC.Res; + + if not Found then + begin + RD := TCodeRec.Create(OP_DECLARE_TEMP_VAR, Self); + RD.Arg1 := Level; + RD.Arg2 := RC.Res; + RD.Res := 0; + Insert(I, RD); + Inc(I); + Inc(N); + end; + + Insert(I, RC); +end; + +procedure TCode.CompressListOfOverloaded(applicable_list, pos: TIntegerList); +var + p_id, q_id, n_p, n_q, I, J, actual_id, p_formal_id, q_formal_id, val: Integer; + cannot_compress: Boolean; + SymbolTable: TSymbolTable; + sub_id, NP, FinalTypeId, TypeId: Integer; + ok: Boolean; +label + cont; +begin + SymbolTable := TKernel(kernel).SymbolTable; + + NP := pos.Count; + + if NP = 1 then + begin + actual_id := Records[pos[0]].Arg1; + TypeId := GetSymbolRec(actual_id).TerminalTypeId; + FinalTypeId := GetSymbolRec(actual_id).FinalTypeId; + for I := applicable_list.Count - 1 downto 0 do + begin + sub_id := applicable_list[I]; + if GetSymbolRec(sub_id).Count <> 1 then + continue; + + p_formal_id := SymbolTable.GetParamId(sub_id, 0); + if GetSymbolRec(p_formal_id).FinalTypeId = FinalTypeId then + begin + if FinalTypeId = typeENUM then + continue; + if FinalTypeId = typeCLASS then + begin + if (GetSymbolRec(actual_id).IsFWArrayVar) and + (GetSymbolRec(p_formal_id).TerminalTypeId = H_TFW_Array) then + begin + ok := true; + end + else + ok := GetSymbolRec(p_formal_id).TerminalTypeId = TypeId; + end + else if FinalTypeId in StandardTypes then + begin + ok := true; + end + else + ok := GetSymbolRec(p_formal_id).TerminalTypeId = TypeId; + + if ok then + begin + applicable_list.Clear; + applicable_list.Add(sub_id); + Exit; + end; + end; + end; + end; + + for I := applicable_list.Count - 1 downto 0 do + begin + sub_id := applicable_list[I]; + if SymbolTable[sub_id].Count < NP then + applicable_list.RemoveAt(I) + else if SymbolTable[sub_id].Count > NP then + begin + p_id := SymbolTable.GetParamId(sub_id, NP); + if not SymbolTable[p_id].Optional then + applicable_list.RemoveAt(I); + end; + end; + + while applicable_list.Count >= 2 do + begin + p_id := applicable_list[0]; + + cannot_compress := true; + + for I := 1 to applicable_list.Count - 1 do + begin + q_id := applicable_list[I]; + + n_p := 0; + n_q := 0; + for J := 0 to pos.Count - 1 do + begin + actual_id := Records[pos[J]].Arg1; + p_formal_id := SymbolTable.GetParamId(p_id, J); + q_formal_id := SymbolTable.GetParamId(q_id, J); + + val := CompareConversions(actual_id, p_formal_id, q_formal_id); + + if val = 0 then + begin + if not ExistsImplicitConversion(actual_id, p_formal_id) then + begin + cannot_compress := false; + applicable_list.DeleteValue(p_id); + goto cont; + end; + if not ExistsImplicitConversion(actual_id, q_formal_id) then + begin + cannot_compress := false; + applicable_list.DeleteValue(q_id); + goto cont; + end; + end + else if val > 0 then + begin + if val = 2 then + begin + cannot_compress := false; + applicable_list.DeleteValue(q_id); + goto cont; + end; + + Inc(n_p); + end + else if val < 0 then + begin + if val = -2 then + begin + cannot_compress := false; + applicable_list.DeleteValue(p_id); + goto cont; + end; + + Inc(n_q); + end; + end; + + if (n_p > 0) and (n_q = 0) then + begin + // p-member is better + cannot_compress := false; + applicable_list.DeleteValue(q_id); + break; + end + else if (n_q > 0) and (n_p = 0) then + begin + // q-member is better + cannot_compress := false; + applicable_list.DeleteValue(p_id); + break; + end; + end; + + cont: + + if cannot_compress then + break; + end; +end; + +procedure TCode.CheckSubrangeBounds(SubrangeTypeId: Integer; + ValueRec: TSymbolRec); +{$IFDEF VARIANTS} +var + B1, B2: Int64; +{$ELSE} +var + B1, B2: Integer; +{$ENDIF} +begin + B1 := TKernel(kernel).SymbolTable.GetLowBoundRec(SubrangeTypeId).value; + B2 := TKernel(kernel).SymbolTable.GetHighBoundRec(SubrangeTypeId).value; + if (ValueRec.value < B1) or (ValueRec.value > B2) then + CreateError(errConstantExpressionViolatesSubrangeBounds, []); +end; + +procedure TCode.OperOP_BEGIN_CLASS_TYPE; +var + ClassId, AncestorId: Integer; +begin + ClassId := Records[N].Arg1; + AncestorId := GetSymbolRec(ClassId).AncestorId; + if GetSymbolRec(AncestorId).IsFinal then + begin + if GetLanguage(N) = JAVA_LANGUAGE then + CreateError(errCannotInheritFromFinalClass, + [GetSymbolRec(AncestorId).FullName]) + else + CreateError(errCannotInheritFromSealedClass, + [GetSymbolRec(AncestorId).FullName]) + end; +end; + +procedure TCode.OperInitSub; +var + I, J, K, NP, SubId, ParamId, T: Integer; + SymbolTable: TSymbolTable; + RC, RD, RK, R1, R2: TCodeRec; + Changed: Boolean; +begin + temp_var_list.Clear; + + SymbolTable := TKernel(kernel).SymbolTable; + SubId := Records[N].Arg1; + + if GetSymbolRec(SubId).Kind = KindSUB then + if GetSymbolRec(SubId).Name <> '' then + begin + I := SymbolTable.LookupParentMethod(SubId, GetUpcase(N), false); + if I > 0 then + if GetSymbolRec(I).IsFinal then + CreateError(errOverridenMethodIsFinal, [GetSymbolRec(I).FullName]); + end; + + NP := SymbolTable[SubId].Count; + + J := N; + if Records[J + 1].Op = OP_NOP then + Inc(J); + if Records[J + 1].Op = OP_GO_DL then + Inc(J); + + for I := 0 to NP - 1 do + begin + ParamId := SymbolTable.GetParamId(SubId, I); + + T := SymbolTable[ParamId].FinalTypeId; + if T in [typeARRAY, typeRECORD] then + continue; + + if T in (StringTypes + VariantTypes + [typeINTERFACE]) then + begin + if GetSymbolRec(ParamId).IsConst then + continue; + if GetSymbolRec(ParamId).ByRef then + continue; + { + if GetSymbolRec(SubId).Kind = KindCONSTRUCTOR then + begin + RC := TCodeRec.Create(OP_SAVE_EDX, Self); + Inc(J); + Insert(J, RC); + end; + + RC := TCodeRec.Create(OP_ADDREF, Self); + RC.Arg1 := ParamId; + Inc(J); + Insert(J, RC); + + if GetSymbolRec(SubId).Kind = KindCONSTRUCTOR then + begin + RC := TCodeRec.Create(OP_RESTORE_EDX, Self); + Inc(J); + Insert(J, RC); + end; + + dmp; + continue; + } + RC := TCodeRec.Create(OP_ASSIGN, Self); + case T of +{$IFNDEF PAXARM} + typeANSISTRING: + RC.Arg1 := CreateStringVar(SubId); + typeWIDESTRING: + RC.Arg1 := CreateWideStringVar(SubId); + typeSHORTSTRING: + RC.Arg1 := CreateShortStringVar(SubId, typeSHORTSTRING); +{$ENDIF} + typeUNICSTRING: + RC.Arg1 := CreateUnicStringVar(SubId); + typeVARIANT: + RC.Arg1 := CreateVariantVar(SubId); + typeOLEVARIANT: + RC.Arg1 := CreateOleVariantVar(SubId); + typeINTERFACE: + begin + RC.Arg1 := CreateInterfaceVar(SubId); + GetSymbolRec(RC.Arg1).TypeId := GetSymbolRec(ParamId).TypeId; + end; + end; + RC.Arg2 := ParamId; + RC.Res := RC.Arg1; + + RD := TCodeRec.Create(OP_DECLARE_TEMP_VAR, Self); + RD.Arg1 := SubId; + RD.Arg2 := RC.Res; + RD.Res := ParamId; // substitute + + if GetSymbolRec(SubId).Kind = KindCONSTRUCTOR then + begin + R1 := TCodeRec.Create(OP_SAVE_EDX, Self); + R2 := TCodeRec.Create(OP_RESTORE_EDX, Self); + end + else + begin + R1 := TCodeRec.Create(OP_NOP, Self); + R2 := TCodeRec.Create(OP_NOP, Self); + end; + + Inc(J); + Insert(J, RD); + + Inc(J); + Insert(J, R1); + + Inc(J); + Insert(J, RC); + + Inc(J); + Insert(J, R2); + + ReplaceIdEx(ParamId, RC.Arg1, J + 1, Card, false, false); + end + else if TKernel(kernel).DEBUG_MODE then + begin + if GetLanguage(N) <> PASCAL_LANGUAGE then + continue; + + if GetSymbolRec(ParamId).IsConst then + continue; + + Changed := false; + + for K := J to Card do + begin + RK := Records[K]; + + if RK.Op = OP_END_SUB then + if RK.Arg1 = SubId then + break; + + if RK.Op = OP_ASSIGN then + if RK.Arg1 = ParamId then + Changed := true; + + if Changed then + if GetSymbolRec(ParamId).ByRef then + begin + RC := TCodeRec.Create(OP_PARAM_CHANGED, Self); + RC.Arg1 := ParamId; + + Inc(J); + Insert(K + 1, RC); + + break; + end; + end; + + if not Changed then + continue; + + if GetSymbolRec(ParamId).ByRef then + continue; + + RC := TCodeRec.Create(OP_ASSIGN, Self); + RC.Arg1 := NewTempVar(SubId, 0); + GetSymbolRec(RC.Arg1).Name := GetSymbolRec(ParamId).Name; + RC.Arg2 := ParamId; + RC.Res := RC.Arg1; + + RD := TCodeRec.Create(OP_DECLARE_TEMP_VAR, Self); + RD.Arg1 := SubId; + RD.Arg2 := RC.Res; + RD.Res := ParamId; // substitute + + R1 := TCodeRec.Create(OP_SAVE_EDX, Self); + R2 := TCodeRec.Create(OP_RESTORE_EDX, Self); + + Inc(J); + Insert(J, RD); + + Inc(J); + Insert(J, R1); + + Inc(J); + Insert(J, RC); + + Inc(J); + Insert(J, R2); + + ReplaceIdEx(ParamId, RC.Arg1, J + 1, Card, false); + end; + end; +end; + +procedure TCode.OperTypeCast; +var + R, RC: TCodeRec; + K2, T1, T2, OldRes, NewRes: Integer; + RecordTypeId, ResultTypeId: Integer; +begin + R := Records[N]; + + T1 := GetSymbolRec(R.Arg1).FinalTypeId; + T2 := GetSymbolRec(R.Arg2).FinalTypeId; + + K2 := GetSymbolRec(R.Arg2).Kind; + + map_list.Add(R.Arg1); + + if GetSymbolRec(R.Arg1).FinalTypeId = typeRECORD then + begin + if GetSymbolRec(R.Arg1).TerminalTypeId <> GetSymbolRec(R.Arg2).TerminalTypeId + then + begin + OldRes := R.Res; + + RecordTypeId := GetSymbolRec(R.Arg1).TerminalTypeId; + ResultTypeId := GetSymbolRec(R.Arg1).TerminalTypeId; + + NewRes := InsertExplicitConversion(N, RecordTypeId, ResultTypeId).Res; + + R.Op := OP_NOP; + if OldRes <> NewRes then + begin + ReplaceId(OldRes, NewRes); + GetSymbolRec(OldRes).Kind := KindNONE; + end; + end + else + begin + SignTypeCast := true; + + R.Op := OP_ASSIGN; + R.Arg1 := R.Res; + Dec(N); + end; + Exit; + end; + + if GetSymbolRec(R.Arg2).FinalTypeId = typeRECORD then + begin + if GetSymbolRec(R.Arg1).TerminalTypeId <> GetSymbolRec(R.Arg2).TerminalTypeId + then + begin + OldRes := R.Res; + + RecordTypeId := GetSymbolRec(R.Arg2).TerminalTypeId; + ResultTypeId := GetSymbolRec(R.Arg1).TerminalTypeId; + + NewRes := InsertExplicitConversion(N, RecordTypeId, ResultTypeId).Res; + + R.Op := OP_NOP; + if OldRes <> NewRes then + begin + ReplaceId(OldRes, NewRes); + GetSymbolRec(OldRes).Kind := KindNONE; + end; + end + else + begin + SignTypeCast := true; + + R.Op := OP_ASSIGN; + R.Arg1 := R.Res; + Dec(N); + end; + Exit; + end; + + if (GetSymbolRec(T1).Size = GetSymbolRec(T2).Size) and + (not(T1 in StringTypes)) and +{$IFNDEF PAXARM} + (not GetSymbolRec(R.Arg1).HasPAnsiCharType) and +{$ENDIF} + (not GetSymbolRec(R.Arg1).HasPWideCharType) then + // variable type cast + begin + R.Op := OP_NOP; + GetSymbolRec(R.Res).TypeId := R.Arg1; + + if K2 = KindCONST then + begin + R.Op := OP_NOP; + GetSymbolRec(R.Res).Kind := KindCONST; + GetSymbolRec(R.Res).value := GetSymbolRec(R.Arg2).value; + + if GetSymbolRec(R.Arg2).FinalTypeId = typeENUM then + if R.Arg2 > R.Res then + if GetSymbolRec(R.Arg2 + 1).Kind = KindCONST then + GetSymbolRec(R.Res).value := GetSymbolRec(R.Arg2 + 1).value; + + Exit; + end; + + if T1 in [typePOINTER, typePROC] then + begin + R.Op := OP_ASSIGN_INT_M; + R.Arg1 := R.Res; + Exit; + end; + + if T1 in [typeCLASS, typeCLASSREF] then + if (Records[N + 1].Arg1 = R.Res) then + begin + R.Op := OP_ASSIGN_INT_M; + R.Arg1 := R.Res; + Exit; + end; + + if T1 in [typeCLASS, typeCLASSREF] then + if (Records[N + 1].Arg2 = R.Res) then + begin + R.Op := OP_ASSIGN_INT_M; + R.Arg1 := R.Res; + Exit; + end; + + GetSymbolRec(R.Res).UnionID := R.Arg2; + GetSymbolRec(R.Res).ByRef := GetSymbolRec(R.Arg2).ByRef; + GetSymbolRec(R.Res).Level := GetSymbolRec(R.Arg2).Level; + if GetSymbolRec(R.Arg2).Name = '' then + ReplaceIdEx(R.Arg2, R.Res, 1, N, false); + end + else if T2 in VariantTypes then + begin + case T1 of +{$IFNDEF PAXARM} + typeANSICHAR: + R.Op := OP_ANSICHAR_FROM_VARIANT; + typeANSISTRING: + R.Op := OP_ANSISTRING_FROM_VARIANT; + typeWIDESTRING: + R.Op := OP_WIDESTRING_FROM_VARIANT; + typeSHORTSTRING: + R.Op := OP_SHORTSTRING_FROM_VARIANT; +{$ENDIF} + typeUNICSTRING: + R.Op := OP_UNICSTRING_FROM_VARIANT; + typeWIDECHAR: + R.Op := OP_WIDECHAR_FROM_VARIANT; + typeDOUBLE: + R.Op := OP_DOUBLE_FROM_VARIANT; + typeCURRENCY: + R.Op := OP_CURRENCY_FROM_VARIANT; + typeSINGLE: + R.Op := OP_SINGLE_FROM_VARIANT; + typeEXTENDED: + R.Op := OP_EXTENDED_FROM_VARIANT; + typeINT64: + R.Op := OP_INT64_FROM_VARIANT; + typeINTEGER: + R.Op := OP_INT_FROM_VARIANT; + typeBYTE: + R.Op := OP_BYTE_FROM_VARIANT; + typeWORD: + R.Op := OP_WORD_FROM_VARIANT; + typeCARDINAL: + R.Op := OP_CARDINAL_FROM_VARIANT; + typeBOOLEAN: + R.Op := OP_BOOL_FROM_VARIANT; + typeBYTEBOOL: + R.Op := OP_BYTEBOOL_FROM_VARIANT; + typeWORDBOOL: + R.Op := OP_WORDBOOL_FROM_VARIANT; + typeLONGBOOL: + R.Op := OP_LONGBOOL_FROM_VARIANT; + typeSMALLINT: + R.Op := OP_SMALLINT_FROM_VARIANT; + typeSHORTINT: + R.Op := OP_SHORTINT_FROM_VARIANT; + else + RaiseError(errInvalidTypeCast, []); + end; + GetSymbolRec(R.Res).TypeId := T1; + end + else // value type cast + begin + GetSymbolRec(R.Res).TypeId := R.Arg1; + + if K2 = KindCONST then + begin + R.Op := OP_NOP; + GetSymbolRec(R.Res).Kind := KindCONST; + GetSymbolRec(R.Res).value := GetSymbolRec(R.Arg2).value; + + if GetSymbolRec(R.Arg2).FinalTypeId = typeENUM then + if R.Arg2 > R.Res then + if GetSymbolRec(R.Arg2 + 1).Kind = KindCONST then + GetSymbolRec(R.Res).value := GetSymbolRec(R.Arg2 + 1).value; +{$IFNDEF PAXARM} + if GetSymbolRec(R.Arg2).HasPAnsiCharType then + GetSymbolRec(R.Res).TypeId := GetSymbolRec(R.Arg2).TypeId; +{$ENDIF} + if GetSymbolRec(R.Arg2).HasPWideCharType then + GetSymbolRec(R.Res).TypeId := GetSymbolRec(R.Arg2).TypeId; + + Exit; + end; + + // R.Op := OP_ASSIGN_INT_M; + // R.Arg1 := R.Res; + + SignTypeCast := true; + + R.Op := OP_ASSIGN; + R.Arg1 := R.Res; + + if T1 in DynamicTypes then + begin + RC := TCodeRec.Create(OP_DECLARE_TEMP_VAR, Self); + RC.Arg1 := GetLevel(N); + RC.Arg2 := R.Res; + RC.Res := 0; + Insert(N, RC); + Exit; + end; + + Dec(N); + end; +end; + +procedure TCode.OperCallDefaultConstructor; +var + R, RC: TCodeRec; + SymbolTable: TSymbolTable; + L, Id, FinTypeId, TypeId, SubId: Integer; + V: Variant; +begin + R := Records[N]; + SymbolTable := TKernel(kernel).SymbolTable; + Id := R.Arg1; + FinTypeId := SymbolTable[Id].FinalTypeId; + if FinTypeId = typeRECORD then + begin + TypeId := SymbolTable[Id].TerminalTypeId; + if GetSymbolRec(TypeId).Host then + begin + R.Op := OP_NOP; + Exit; + end; + + SubId := SymbolTable.FindConstructorId(TypeId); + if SubId = 0 then + begin + R.Op := OP_NOP; + Exit; + end; + + R.Op := OP_CALL; + R.Arg1 := SubId; + R.Arg2 := 0; + R.Res := 0; + + RC := TCodeRec.Create(OP_PUSH_INSTANCE, Self); + RC.Arg1 := Id; + RC.Arg2 := 0; + RC.Res := SubId; + Insert(N, RC); + Dec(N); + end + else + begin + L := GetSymbolRec(Id).Level; + if L = 0 then + begin + R.Op := OP_NOP; + Exit; + end; + if not(GetSymbolRec(L).Kind in kindSUBS) then + begin + R.Op := OP_NOP; + Exit; + end; + case FinTypeId of + typeBOOLEAN, typeBYTEBOOL, typeWORDBOOL, typeLONGBOOL: + begin + R.Arg2 := CreateConst(FinTypeId, false); + R.Op := OP_ASSIGN; + R.Res := R.Arg1; + Dec(N); + end; + typeBYTE, typeINTEGER, typeSMALLINT, typeSHORTINT, typeWORD, typeCARDINAL, + typeCLASS, typeCLASSREF, typeDOUBLE, typeSINGLE, typeCURRENCY, + typeEXTENDED: + begin + R.Arg2 := CreateConst(FinTypeId, 0); + R.Op := OP_ASSIGN; + R.Res := R.Arg1; + Dec(N); + end; +{$IFDEF PAXARM} + typeUNICSTRING: +{$ELSE} + typeANSISTRING, typeWIDESTRING, typeSHORTSTRING +{$IFDEF UNIC}, typeUNICSTRING{$ENDIF}: +{$ENDIF} + begin + R.Arg2 := CreateConst(FinTypeId, ''); + R.Op := OP_ASSIGN; + R.Res := R.Arg1; + Dec(N); + end; + typeVARIANT, typeOLEVARIANT: + begin + R.Arg2 := CreateConst(FinTypeId, V); + R.Op := OP_ASSIGN; + R.Res := R.Arg1; + Dec(N); + end; + else + R.Op := OP_NOP; + end; + end; +end; + +procedure TCode.OperCheckFinal; +begin + if Records[N].Arg1 <> 0 then + SkipCheckFinal := true + else + SkipCheckFinal := false; +end; + +procedure TCode.OperCheckSubCall; +var + SubId: Integer; +begin + SubId := Records[N].Arg1; + if GetSymbolRec(SubId).Kind = KindSUB then + if GetSymbolRec(SubId).TypeId = typeVOID then + begin + Records[N].Op := OP_NOP; + end + else + CreateError(errThisWayOfCallIsAllowedOnlyForProcedures, []); +end; + +procedure TCode.OperPushInstance; +var + SubId: Integer; +begin + SubId := Records[N].Res; + if SubId > 0 then + if GetSymbolRec(SubId).CallMode = cmSTATIC then + Records[N].Op := OP_NOP; +end; + +procedure TCode.OperPush; +begin +end; + +procedure TCode.OperAdjustInstance; +var + I, Id: Integer; +begin + I := N; + Records[I].Op := OP_NOP; + Id := Records[I].Arg1; + while Records[I].Op <> OP_PUSH_INST do + Dec(I); + Records[I].Arg1 := Id; +end; + +procedure TCode.OperCall; + + function CheckSub(var AnId: Integer): Boolean; + var + I, J, Id: Integer; + S, S1, S2: String; + SymbolTable: TSymbolTable; + begin + SymbolTable := TKernel(kernel).SymbolTable; + S2 := GetSymbolRec(AnId).Name; + result := false; + Id := 0; + J := N; + while Records[J].Op <> OP_BEGIN_MODULE do + Dec(J); + for I := J to N do + if Records[I].Op = OP_BEGIN_USING then + begin + S1 := GetSymbolRec(Records[I].Arg1).Name; + if S1 = '' then + continue; + S := S1 + '.' + S2; + Id := SymbolTable.LookupFullName(S, GetUpcase(N)); + if Id > 0 then + if GetSymbolRec(Id).Kind in kindSUBS then + begin + result := true; + break; + end; + end; + if not result then + Exit; + Records[N].Arg1 := Id; + for J := N downto GetStmt(N) do + if (Records[J].Op = OP_PUSH) and (Records[J].Res = AnId) then + Records[J].Res := Id; + AnId := Id; + end; + + function IsVarArrayIndex(Id, T1, J: Integer; P: TIntegerList): Boolean; + var + I, K, ArrayId, temp, temp_2: Integer; + R, RC: TCodeRec; + ParamIds: TIntegerList; + begin + result := false; + ParamIds := TIntegerList.Create; + ArrayId := 0; + try + for I := N downto 1 do + begin + R := Records[I]; + if R.Op = OP_BEGIN_MODULE then + break; + if R.Op = OP_VARARRAY_GET then + if R.Res = Id then + begin + ArrayId := R.Arg1; + for K := I downto 1 do + if Records[K].Op = OP_PUSH_ADDRESS then + begin + ParamIds.Add(Records[K].Arg1); + if ParamIds.Count = R.Arg2 then + break; + end; + + result := true; + break; + end; + end; + + if not result then + Exit; + + temp := 0; + case T1 of + typeINTEGER: + temp := InsertConversionToInteger(P[J], 1).Res; + typeBYTE: + temp := InsertConversionToByte(P[J], 1).Res; + typeWORD: + temp := InsertConversionToWord(P[J], 1).Res; + typeCARDINAL: + temp := InsertConversionToCardinal(P[J], 1).Res; + typeSHORTINT: + temp := InsertConversionToShortInt(P[J], 1).Res; + typeSMALLINT: + temp := InsertConversionToSmallInt(P[J], 1).Res; + typeSINGLE: + temp := InsertConversionToSingle(P[J], 1).Res; + typeDOUBLE: + temp := InsertConversionToDouble(P[J], 1).Res; + typeEXTENDED: + temp := InsertConversionToExtended(P[J], 1).Res; + typeCURRENCY: + temp := InsertConversionToCurrency(P[J], 1).Res; + typeBOOLEAN: + temp := InsertConversionToBoolean(P[J], 1).Res; +{$IFNDEF PAXARM} + typeANSISTRING: + temp := InsertConversionToAnsiString(P[J], 1).Res; + typeSHORTSTRING: + temp := InsertConversionToShortString(P[J], 1).Res; + typeWIDESTRING: + temp := InsertConversionToWideString(P[J], 1).Res; + typeANSICHAR: + temp := InsertConversionToAnsiChar(P[J], 1).Res; +{$ENDIF} + typeUNICSTRING: + temp := InsertConversionToUnicString(P[J], 1).Res; + typeWIDECHAR: + temp := InsertConversionToWideChar(P[J], 1).Res; + else + CreateError(errTypesOfActualAndFormalVarParametersMustBeIdentical, []); + end; + + Inc(N); + for I := J to P.Count - 1 do + P[I] := P[I] + 1; + + I := N + 1; + + temp_2 := NewTempVar(GetLevel(N), typeVARIANT); + + RC := TCodeRec.Create(OP_ASSIGN, Self); + RC.Arg1 := temp_2; + RC.Arg2 := temp; + RC.Res := temp_2; + Insert(I, RC); + Inc(I); + + RC := TCodeRec.Create(OP_PUSH_ADDRESS, Self); + RC.Arg1 := ParamIds[0]; + RC.Arg2 := 0; + RC.Res := 0; + Insert(I, RC); + Inc(I); + + RC := TCodeRec.Create(OP_VARARRAY_PUT, Self); + RC.Arg1 := ArrayId; + RC.Arg2 := 1; + RC.Res := temp_2; + Insert(I, RC); + + finally + FreeAndNil(ParamIds); + end; + end; + + function PassedProc: Boolean; + var + I, ResId, SubId, PCount, ParamId, FinTypeId, TypeId, PatternSubId: Integer; + SymbolTable: TSymbolTable; + begin + result := false; + ResId := Records[N].Res; + SymbolTable := TKernel(kernel).SymbolTable; + if ResId = 0 then + Exit; + if Records[N - 1].Op <> OP_BEGIN_CALL then + Exit; + + for I := N + 1 to Card do + if Records[I].Op = OP_PUSH then + if Records[I].Arg1 = ResId then + begin + SubId := Records[I].Res; + PCount := Records[I].Arg2; + ParamId := SymbolTable.GetParamId(SubId, PCount); + FinTypeId := GetSymbolRec(ParamId).FinalTypeId; + if FinTypeId = typePROC then + begin + TypeId := GetSymbolRec(ParamId).TerminalTypeId; + PatternSubId := GetSymbolRec(TypeId).PatternId; + if SymbolTable.EqualHeaders(Records[N].Arg1, PatternSubId) then + begin + result := true; + Records[N - 1].Op := OP_ADDRESS; + Records[N - 1].Res := CreatePointerVar(GetLevel(N)); + Records[N].Op := OP_NOP; + Records[I].Arg1 := Records[N - 1].Res; + Dec(N, 2); + end; + end; + + break; + end; + end; + +var + P: TIntegerList; + + procedure P_Add(J: Integer); + var + R, RJ: TCodeRec; + I: Integer; + begin + RJ := Records[J]; + for I := 0 to P.Count - 1 do + begin + R := Records[P[I]]; + if (R.Arg2 = RJ.Arg2) and (R.Res = RJ.Res) then + begin + P[I] := J; + Exit; + end; + end; + + P.Add(J); + end; + +var + R, RR: TCodeRec; + SubId, J: Integer; + SymbolTable: TSymbolTable; + Arg1, Arg2, T1, T2, K2: Integer; + L: TCodeRecList; + OverList: TIntegerList; + IsOverloadedCall: Boolean; + p_id: Integer; + RC, RC_BEGIN_CALL: TCodeRec; + SavedSubId: Integer; + PosInstance: Integer; + PosClassRef: Integer; + S: String; + J1, Card1, Card2: Integer; + N_BeginCall: Integer; + + I, I1, Id, K: Integer; + Id_VMT: Integer; + CallRefId: Integer; + ThisId, ThisRefId: Integer; + b: Boolean; + GenOp, SubId1, SubId2: Integer; + ParamId, ArrLength: Integer; + VarArgIds: TIntegerList; + ArrTypeId, ElemTypeId, DynArrayId: Integer; + ResId: Integer; + RJ: TCodeRec; + KZ: Integer; + SubIdLevel: Integer; +{$IFDEF PAXARM} + SS: String; +{$ELSE} + SS: ShortString; +{$ENDIF} +begin + SymbolTable := TKernel(kernel).SymbolTable; + PosInstance := 0; + PosClassRef := 0; + N_BeginCall := 0; + IsOverloadedCall := false; + + R := Records[N]; + RR := Records[N]; + + SubId := R.Arg1; + + SavedSubId := -1; + if GetSymbolRec(SubId).Kind = KindCONST then + begin + RaiseError(errIdentifierExpectedNoArgs, []); + end + else if GetSymbolRec(SubId).Kind = KindVAR then + begin + + if R.Language = JS_LANGUAGE then + begin + if GetSymbolRec(SubId).TypeId = typeVARIANT then + begin + for J := GetStmt(N) to N do + if (Records[J].Op = OP_FIND_CONTEXT) and (Records[J].Res = SubId) then + begin + Records[J].Op := OP_FIND_JS_FUNC; + break; + end; + + SubId := NewTempVar(GetSymbolRec(R.Arg1).Level, JS_FunctionClassId); + + I := 0; + ThisId := 0; + for J := GetStmt(N) to N do + if (Records[J].Op = OP_PUSH) and (Records[J].Res = R.Arg1) then + begin + if I = 0 then + I := J; + Records[J].Res := SubId; + end + else if (Records[J].Op = OP_CALL) and (Records[J].Res = R.Arg1) then + begin + K := J - 1; + while Records[K].Op <> OP_PUSH_INST do + Dec(K); + + ThisId := Records[K].Arg1; + end; + + if I = 0 then + I := N; + + b := false; + I1 := N; + for J := I downto GetStmt(N) do + if (Records[J].Op = OP_CALL) and (Records[J].Arg1 = JS_GetPropertyId) + and (Records[J].Res = Records[N].Arg1) then + begin + b := true; + I1 := J; + break; + end; + + if b { and false } then + begin + Records[I1].Arg1 := JS_GetPropertyAsObjectId; + Records[I1].Res := SubId; + J := I1; + repeat + Dec(J); + if Records[J].Res = JS_GetPropertyId then + Records[J].Res := JS_GetPropertyAsObjectId; + + until (Records[J].Op = OP_BEGIN_CALL) and + (Records[J].Arg1 = JS_GetPropertyId); + Records[J].Arg1 := JS_GetPropertyAsObjectId; + end + else + begin + RC := TCodeRec.Create(OP_JS_FUNC_OBJ_FROM_VARIANT, Self); + RC.Arg1 := R.Arg1; + RC.Arg2 := 0; + RC.Res := SubId; + Insert(I, RC); + Inc(N); + end; + + if ThisId > 0 then + begin + ThisRefId := NewTempVar(GetSymbolRec(R.Res).Level, typePOINTER); + GetSymbolRec(ThisRefId).OwnerId := SubId; + GetSymbolRec(ThisRefId).Name := str__this; + RC := TCodeRec.Create(OP_FIELD, Self); + RC.Arg1 := SubId; + RC.Arg2 := ThisRefId; + RC.Res := ThisRefId; + Insert(N, RC); + Inc(N); + + RC := TCodeRec.Create(OP_ASSIGN, Self); + RC.Arg1 := ThisRefId; + RC.Arg2 := ThisId; + RC.Res := ThisRefId; + Insert(N, RC); + Inc(N); + + R.Arg1 := SubId; + + { + if Records[N].Op = OP_CALL then + begin + RC := TCodeRec.Create(OP_ADJUST_INSTANCE, Self); + RC.Arg1 := ThisId; + Insert(N + 1, RC); + end; + } + Dec(N, 3); + + Exit; + end; + + R.Arg1 := SubId; + end; + end; + + if GetSymbolRec(SubId).TypeId = JS_FunctionClassId then + begin + CallRefId := NewTempVar(GetLevel(N), typeVARIANT); + GetSymbolRec(CallRefId).Name := strInternalCall; + GetSymbolRec(CallRefId).OwnerId := Records[N].Arg1; + + P := TIntegerList.Create; + + for J := GetStmt(N) to N do + begin + if (Records[J].Op = OP_PUSH) and (Records[J].Res = SubId) then + begin + P_Add(J); + Records[J].Res := CallRefId; + Inc(Records[J].Arg2, 1); + end; + end; + Records[N].Arg1 := CallRefId; + Inc(Records[N].Arg2); + + if P.Count > 0 then + N := P[0]; + + RC := TCodeRec.Create(OP_FIELD, Self); + RC.Arg1 := SubId; + RC.Arg2 := CallRefId; + RC.Res := CallRefId; + Insert(N, RC); + Inc(N); + + RC := TCodeRec.Create(OP_PUSH, Self); + RC.Arg1 := CreateConst(typeINTEGER, P.Count); + RC.Arg2 := 0; + RC.Res := CallRefId; + Insert(N, RC); + + Dec(N, 2); + + FreeAndNil(P); + Exit; + end; + + if GetSymbolRec(SubId).FinalTypeId in [typePROC, typeEVENT] then + begin + SavedSubId := SubId; + T1 := GetSymbolRec(SubId).TerminalTypeId; + SubId := SymbolTable.GetPatternSubId(T1); + R.Arg1 := SubId; + for J := GetStmt(N) to N do + if (Records[J].Op = OP_PUSH) and (Records[J].Res = SavedSubId) then + begin + Records[J].Res := SubId; + Records[J].SavedSubId := SavedSubId; + end; + end + else + begin + if Records[N - 1].Op = OP_OLE_GET then + begin + Records[N].Op := OP_NOP; + Exit; + end; + + if (GetSymbolRec(R.Arg1).FinalTypeId in [typeCLASS, typeINTERFACE]) and + (not GetSymbolRec(R.Arg1).IsFWArrayVar) then + begin + I := 0; + + if GetSymbolRec(R.Arg1).FinalTypeId = typeINTERFACE then + I := SymbolTable.LookupAnonymousMethod(GetSymbolRec(R.Arg1) + .TerminalTypeId); + + if I = 0 then + I := SymbolTable.FindDefaultPropertyId(GetSymbolRec(R.Arg1) + .TerminalTypeId); + + if I <> 0 then + begin + S := GetSymbolRec(I).Name; + Id := NewTempVar(GetLevel(N), GetSymbolRec(I).TypeId); + + GetSymbolRec(Id).OwnerId := R.Arg1; + GetSymbolRec(Id).Name := GetSymbolRec(I).Name; + + RC := TCodeRec.Create(OP_FIELD, Self); + RC.Arg1 := R.Arg1; + RC.Arg2 := Id; + RC.Res := Id; + + K := 0; + for J := GetStmt(N) to N do + begin + if (Records[J].Op = OP_PUSH) and (Records[J].Res = SubId) then + begin + if K = 0 then + K := J; + Records[J].Res := Id; + end + end; + + R.Arg1 := Id; + + if K > 0 then + N := K; + + Insert(N, RC); + Dec(N); + end + else + begin + S := GetSymbolRec(GetSymbolRec(R.Arg1).TerminalTypeId).Name; + CreateError(errClassDoesNotHaveDefaultProperty, [S]); + end; + Exit; + end; + + if Records[N - 1].Op = OP_CALL then + if Records[N - 1].Res = Records[N].Arg1 then + begin + Records[N].Op := OP_NOP; + Exit; + end; + + if (GetSymbolRec(R.Arg1).FinalTypeId in [typeDYNARRAY, typeVARIANT]) or + GetSymbolRec(R.Arg1).IsFWArrayVar then + begin + P := TIntegerList.Create; + try + for J := GetStmt(N) to N do + begin + if (Records[J].Op = OP_PUSH) and (Records[J].Res = SubId) then + begin + P_Add(J); + if R.Res = 0 then + Records[J].Op := OP_NOP; + end; + end; + + if R.Res = 0 then + begin + R.Op := OP_NOP; + Exit; + end; + + if P.Count = 0 then + RaiseError(errCannotApplyCall, [GetSymbolRec(SubId).Name]); + + ResId := SubId; + + for J := 0 to P.Count - 1 do + begin + I := P[J]; + Records[I].Op := OP_ELEM; + Records[I].Arg2 := Records[I].Arg1; + Records[I].Arg1 := ResId; + Records[I].Res := CreateVariantVar(GetLevel(N)); + ResId := Records[I].Res; + + GetSymbolRec(ResId).OwnerId := Records[I].Arg1; + end; + + Records[N].Op := OP_NOP; + ReplaceId(Records[N].Res, ResId); + + Dec(N, P.Count + 1); + + finally + FreeAndNil(P); + end; + end + else if GetLanguage(N) <> JS_LANGUAGE then + begin + RaiseError(errCannotApplyCall, [GetSymbolRec(R.Arg1).Name]); + end; + + Exit; + end; + end + else if GetSymbolRec(SubId).Kind = KindTYPE then + if not CheckSub(SubId) then + begin + + if R.Arg2 <> 1 then + CreateError(errTooManyActualParameters, []); + p_id := 0; + for J := N downto GetStmt(N) do + if (Records[J].Op = OP_PUSH) and (Records[J].Res = SubId) then + begin + p_id := Records[J].Arg1; + Records[J].Op := OP_NOP; + break; + end; + R.Arg2 := p_id; + + R.Op := OP_TYPE_CAST; + Dec(N); + + Exit; + end; + + P := TIntegerList.Create; + + try + PosInstance := 0; + PosClassRef := 0; + + for J := GetStmt(N) to N do + begin + RJ := Records[J]; + + if (RJ.Op = OP_PUSH) and (RJ.Res = SubId) then + P_Add(J); + if (RJ.Op = OP_PUSH_INSTANCE) and (RJ.Res = SubId) then + begin + if GetSymbolRec(RJ.Res).CallMode = cmSTATIC then + RJ.Op := OP_NOP + else + PosInstance := J; + end; + if (RJ.Op = OP_PUSH_CLASSREF) and (RJ.Res = SubId) then + begin + if GetSymbolRec(RJ.Res).CallMode = cmSTATIC then + RJ.Op := OP_NOP + else + PosClassRef := J; + end; + end; + + // insert begin call ///////////// + + RC := TCodeRec.Create(OP_BEGIN_CALL, Self); + RC.Arg1 := SubId; + RC.Arg2 := 0; + RC.Res := 0; + + RC_BEGIN_CALL := RC; + + if GetSymbolRec(SubId).CallConv = ccSAFECALL then + if GetSymbolRec(SubId).TypeId <> typeVOID then + RC.Res := NewTempVar(GetLevel(N), typeINTEGER); + + if P.Count > 0 then + N_BeginCall := Insert(P[0], RC) + else + N_BeginCall := Insert(N, RC); + + for J := P.Count - 1 downto 0 do + P[J] := P[J] + 1; + + Inc(N); + + SubIdLevel := SymbolTable[SubId].Level; + + /// /////////////////////////////// + if (SymbolTable[SubId].Name = '') or NoOverloadSearch then + begin + if SymbolTable[SubId].Kind = KindCONSTRUCTOR then + begin + OverList := SymbolTable.FindConstructorIds(GetSymbolRec(SubId).TypeId); + end + else + begin + OverList := TIntegerList.Create; + OverList.Add(SubId); + end; + end + else + begin + if SymbolTable[SubId].NSOwnerId > 0 then + begin + OverList := SymbolTable.LookUpSub(SymbolTable[SubId].Name, + SymbolTable[SubId].NSOwnerId, GetUpcase(N)); + end + else if PosInstance + PosClassRef = 0 then // global function call + OverList := SymbolTable.LookUpSubs(SymbolTable[SubId].Name, + SymbolTable[SubId].Level, using_list, GetUpcase(N)) + else + OverList := SymbolTable.LookUpSub(SymbolTable[SubId].Name, + SymbolTable[SubId].Level, GetUpcase(N)); + end; + NoOverloadSearch := false; + + if OverList.Count > 1 then // overloaded call + begin + + IsOverloadedCall := true; + CompressListOfOverloaded(OverList, P); + + if OverList.Count = 0 then + CreateError(errThereIsNoOverloaded, [SymbolTable[SubId].Name]) + // else if OverList.Count > 1 then + // CreateError(errThereIsNoOverloaded, [SymbolTable[SubId].Name]) + else // ok + begin + SubId := -1; + for J := 0 to OverList.Count - 1 do + if GetSymbolRec(OverList[J]).Level = SubIdLevel then + begin + SubId := OverList[J]; + break; + end; + if SubId = -1 then + SubId := OverList[OverList.Count - 1]; + + R.Arg1 := SubId; + for J := P.Count - 1 downto 0 do + Records[P[J]].Res := SubId; + + RC_BEGIN_CALL.Arg1 := SubId; + end; + end + else // OverList.Count = 1 + if SubId <> JS_FunctionCallId then + begin + IsOverloadedCall := false; + if P.Count > SymbolTable[SubId].Count then + begin + if true then // GetLanguage(N) <> PASCAL_LANGUAGE then + begin + if SymbolTable[SubId].Count = 0 then + CreateError(errTooManyActualParameters, []) + else + begin + ParamId := SymbolTable.GetParamId(SubId, + SymbolTable[SubId].Count - 1); + if SymbolTable[ParamId].FinalTypeId <> typeDYNARRAY then + begin + CreateError(errTooManyActualParameters, []); + end + else + begin + if GetLanguage(N) = PASCAL_LANGUAGE then + CreateError(errTooManyActualParameters, []); + + RC_BEGIN_CALL.Op := OP_NOP; + + ArrLength := P.Count - SymbolTable[SubId].Count + 1; + + Dec(Records[N].Arg2, ArrLength - 1); + + VarArgIds := TIntegerList.Create; + try + for I := P.Count - 1 downto 0 do + begin + Records[P[I]].Op := OP_NOP; + VarArgIds.Insert(0, Records[P[I]].Arg1); + if VarArgIds.Count = ArrLength then + break; + end; + + ArrTypeId := GetSymbolRec(ParamId).TerminalTypeId; + ElemTypeId := GetSymbolRec(ArrTypeId).PatternId; + DynArrayId := NewTempVar(GetLevel(N), ArrTypeId); + + RC := TCodeRec.Create(OP_DECLARE_TEMP_VAR, Self); + RC.Arg1 := GetLevel(N); + RC.Arg2 := DynArrayId; + RC.Res := 0; + Insert(N, RC); + Inc(N); + + RC := TCodeRec.Create(OP_SET_LENGTH, Self); + RC.Arg1 := DynArrayId; + RC.Arg2 := CreateConst(typeINTEGER, ArrLength); + RC.Res := 0; + Insert(N, RC); + Inc(N); + + for I := 0 to VarArgIds.Count - 1 do + begin + RC := TCodeRec.Create(OP_ELEM, Self); + RC.Arg1 := DynArrayId; + RC.Arg2 := CreateConst(typeINTEGER, I); + ParamId := NewTempVar(GetLevel(N), ElemTypeId); + RC.Res := ParamId; + + Insert(N, RC); + Inc(N); + + RC := TCodeRec.Create(OP_ASSIGN, Self); + RC.Arg1 := ParamId; + RC.Arg2 := VarArgIds[I]; + RC.Res := ParamId; + + Insert(N, RC); + Inc(N); + end; + + RC := TCodeRec.Create(OP_PUSH, Self); + RC.Arg1 := DynArrayId; + RC.Arg2 := P.Count - ArrLength; + RC.Res := SubId; + Insert(N, RC); + Inc(N); + + Dec(N, 4 + VarArgIds.Count * 2); + + finally + FreeAndNil(VarArgIds); + FreeAndNil(OverList); + end; + PosClassRef := 0; + Exit; + + end; + end; + end + else + CreateError(errTooManyActualParameters, []); + end + else if P.Count < SymbolTable[SubId].Count then + begin + p_id := SymbolTable.GetParamId(SubId, P.Count); + + if not SymbolTable[p_id].Optional then + begin + if PassedProc then + begin + FreeAndNil(OverList); + Exit; + end + else if SymbolTable[p_id].FinalTypeId + in [typeDYNARRAY, typeOPENARRAY] then + begin + if GetLanguage(N) = PASCAL_LANGUAGE then + CreateError(errNotEnoughActualParameters, []); + + RC_BEGIN_CALL.Op := OP_NOP; + + ArrTypeId := SymbolTable[p_id].TypeId; + if GetSymbolRec(ArrTypeId).FinalTypeId = typeOPENARRAY then + ArrTypeId := SymbolTable.RegisterDynamicArrayType(0, '', + GetSymbolRec(ArrTypeId).PatternId); + + DynArrayId := SymbolTable.AddDynarrayVar(GetLevel(N), + ArrTypeId).Id; + + RC := TCodeRec.Create(OP_DECLARE_TEMP_VAR, Self); + RC.Arg1 := GetLevel(N); + RC.Arg2 := DynArrayId; + RC.Res := 0; + Insert(N, RC); + Inc(N); + + RC := TCodeRec.Create(OP_CREATE_EMPTY_DYNARRAY, Self); + RC.Arg1 := DynArrayId; + RC.Arg2 := 0; + RC.Res := 0; + Insert(N, RC); + Inc(N); + + RC := TCodeRec.Create(OP_PUSH, Self); + RC.Arg1 := DynArrayId; + RC.Arg2 := P.Count; + RC.Res := SubId; + Insert(N, RC); + Inc(N); + + Dec(N, 3); + PosClassRef := 0; + + FreeAndNil(OverList); + Exit; + end + else + CreateError(errNotEnoughActualParameters, []); + end; + end + else if (P.Count = 1) and (SymbolTable[SubId].Count = 1) and + (Records[P[0]].Arg1 <> SymbolTable.NilId) and + (SymbolTable[SymbolTable.GetParamId(SubId, SymbolTable[SubId].Count - + 1)].FinalTypeId in [typeDYNARRAY, typeOPENARRAY]) and + (not SymbolTable[Records[P[0]].Arg1].IsFWArrayVar) and + (not(SymbolTable[Records[P[0]].Arg1].FinalTypeId in [typeDYNARRAY, + typeSET, typeARRAY])) then + begin + ParamId := SymbolTable.GetParamId(SubId, + SymbolTable[SubId].Count - 1); + RC_BEGIN_CALL.Op := OP_NOP; + + ArrLength := P.Count - SymbolTable[SubId].Count + 1; + + Dec(Records[N].Arg2, ArrLength - 1); + + VarArgIds := TIntegerList.Create; + try + for I := P.Count - 1 downto 0 do + begin + Records[P[I]].Op := OP_NOP; + VarArgIds.Insert(0, Records[P[I]].Arg1); + if VarArgIds.Count = ArrLength then + break; + end; + + ArrTypeId := GetSymbolRec(ParamId).TerminalTypeId; + ElemTypeId := GetSymbolRec(ArrTypeId).PatternId; + if GetSymbolRec(ArrTypeId).FinalTypeId = typeOPENARRAY then + ArrTypeId := SymbolTable.RegisterDynamicArrayType(0, '', + ElemTypeId); + DynArrayId := NewTempVar(GetLevel(N), ArrTypeId); + + RC := TCodeRec.Create(OP_SET_LENGTH, Self); + RC.Arg1 := DynArrayId; + RC.Arg2 := CreateConst(typeINTEGER, ArrLength); + RC.Res := 0; + Insert(N, RC); + Inc(N); + + for I := 0 to VarArgIds.Count - 1 do + begin + RC := TCodeRec.Create(OP_ELEM, Self); + RC.Arg1 := DynArrayId; + RC.Arg2 := CreateConst(typeINTEGER, I); + ParamId := NewTempVar(GetLevel(N), ElemTypeId); + RC.Res := ParamId; + + Insert(N, RC); + Inc(N); + + RC := TCodeRec.Create(OP_ASSIGN, Self); + RC.Arg1 := ParamId; + RC.Arg2 := VarArgIds[I]; + RC.Res := ParamId; + + Insert(N, RC); + Inc(N); + end; + + RC := TCodeRec.Create(OP_PUSH, Self); + RC.Arg1 := DynArrayId; + RC.Arg2 := P.Count - ArrLength; + RC.Res := SubId; + Insert(N, RC); + Inc(N); + + RC := TCodeRec.Create(OP_DESTROY_LOCAL_VAR, Self); + RC.Arg1 := DynArrayId; + Insert(N + 1, RC); + + Dec(N, 3 + VarArgIds.Count * 2); + PosClassRef := 0; + + finally + FreeAndNil(VarArgIds); + FreeAndNil(OverList); + end; + + Exit; + end; + end; + + FreeAndNil(OverList); + + if HasError then + Exit; + + { + if SymbolTable[SymbolTable[SubId].Level].Kind = KindSUB then // internal sub call + begin + RC := TCodeRec.Create(OP_PUSH_EBP, Self); + RC.Arg1 := 0; + RC.Arg2 := 0; + RC.Res := SubId; + + Insert(N, RC); + Inc(N); + end; + } + + if P.Count < SymbolTable[SubId].Count then + // insert optional parameter values + begin + for J := P.Count to SymbolTable[SubId].Count - 1 do + begin + p_id := SymbolTable.GetParamId(SubId, J); + + RC := TCodeRec.Create(OP_PUSH, Self); + if SymbolTable[p_id].FinalTypeId = typeINTERFACE then + RC.Arg1 := CreateConst(typePOINTER, SymbolTable[p_id].value) + else + RC.Arg1 := CreateConst(SymbolTable[p_id].TerminalTypeId, + SymbolTable[p_id].value); + RC.Arg2 := J; + RC.Res := SubId; + Insert(N, RC); + + Inc(N); + end; + end; + + // if subroutine has default parameter - recalculate p + P.Clear; + for J := GetStmt(N) to N do + if (Records[J].Op = OP_PUSH) and (Records[J].Res = SubId) then + P_Add(J); + + if GetSymbolRec(SubId).CallConv in [ccSTDCALL, ccCDECL, ccSAFECALL, + ccMSFASTCALL] then + begin + L := TCodeRecList.Create; + try + for J := P.Count - 1 downto 0 do + begin + L.Add(Records[P[J]]); + Remove(Records[P[J]]); + Dec(N); + end; + + for J := 0 to P.Count - 1 do + Insert(N, TCodeRec(L[P.Count - J - 1])); + Inc(N, P.Count); + + P.Clear(); + for J := GetStmt(N) to N do + if (Records[J].Op = OP_PUSH) and (Records[J].Res = SubId) then + P_Add(J); + finally + FreeAndNil(L); + end; + end; + + if (SymbolTable[SubId].Kind <> KindCONSTRUCTOR) or + (SymbolTable[R.Res].Name = '') then + begin + if (SymbolTable[SubId].Kind = KindCONSTRUCTOR) and (Records[N].Res = 0) + then + if not Records[N].IsInherited then + begin + T1 := SymbolTable[SubId].Level; + if GetSymbolRec(T1).FinalTypeId = typeCLASS then + CreateError(errWrongCall, []); + end; + + if (SymbolTable[SubId].Kind = KindCONSTRUCTOR) and (PosClassRef > 0) then + begin + T1 := GetSymbolRec(Records[PosClassRef].Arg1).TerminalTypeId; + T1 := GetSymbolRec(T1).PatternId; + SymbolTable[R.Res].TypeId := T1; + end + else + SymbolTable[R.Res].TypeId := SymbolTable[SubId].TypeId; + end; + + R.Arg2 := P.Count; + + for J := P.Count - 1 downto 0 do + if SubId = JS_FunctionCallId then + begin + R := Records[P[J]]; + if PAX64 then + KZ := 0 + else + KZ := P.Count - 1; + if J = KZ then + begin + Records[N].Arg2 := 1; // only 1-st parameter is passed + R.Op := OP_PUSH_INT_IMM; + end + else + begin + R.Op := OP_PUSH_ADDRESS; + Arg2 := R.Arg1; + T2 := GetSymbolRec(Arg2).FinalTypeId; + if not(T2 in VariantTypes) then + begin + InsertConversionToVariant(P[J], 1); + Inc(N); + end; + end; + end + else + begin + R := Records[P[J]]; + Arg1 := SymbolTable.GetParamId(SubId, R.Arg2); + Arg2 := R.Arg1; + + T1 := GetSymbolRec(Arg1).FinalTypeId; + T2 := GetSymbolRec(Arg2).FinalTypeId; + K2 := GetSymbolRec(Arg2).Kind; + + if T2 = 0 then + if GetLanguage(N) = JS_LANGUAGE then + begin + GetSymbolRec(Arg2).TypeId := typeVARIANT; + T2 := typeVARIANT; + end; + + if (K2 = KindTYPE) and (T2 = typeCLASS) then + begin + Inc(R.Arg1); + Arg2 := R.Arg1; + T2 := GetSymbolRec(Arg2).FinalTypeId; + K2 := GetSymbolRec(Arg2).Kind; + end; + + if GetSymbolRec(Arg1).ByRef and (not GetSymbolRec(Arg1).IsConst) then + begin + if (GetSymbolRec(Arg2).Name = '') and + (not(T1 in [typeRECORD, typeARRAY])) then // 18.09.2009 + begin + for K := N downto 1 do + begin + if Records[K].Op = OP_STMT then + break + + else + begin + if Records[K].Res = Arg2 then + begin + GenOp := Records[K].GenOp; + if Records[K].Op = OP_NOP then + GenOp := OP_NOP; + + if (GenOp = OP_PLUS) or (GenOp = OP_MINUS) or + (GenOp = OP_MULT) or (GenOp = OP_DIV) or (GenOp = OP_IDIV) + or (GenOp = OP_MOD) or (GenOp = OP_SHL) or (GenOp = OP_SHR) + or (GenOp = OP_AND) or (GenOp = OP_OR) or (GenOp = OP_XOR) + or (GenOp = OP_NOT) or (GenOp = OP_IS) or (GenOp = OP_AS) or + (GenOp = OP_GT) or (GenOp = OP_GE) or (GenOp = OP_LT) or + (GenOp = OP_LE) or (GenOp = OP_EQ) or (GenOp = OP_NE) or + (GenOp = OP_CALL) then + begin + CreateError + (errTypesOfActualAndFormalVarParametersMustBeIdentical, [] + ); + break; + end; + end; + end; + end; + end + else if GetSymbolRec(Arg2).Kind = KindCONST then + CreateError(errConstantObjectCannotBePassedAsVarParameter, []) + else if GetSymbolRec(Arg2).IsConst then + CreateError(errConstantObjectCannotBePassedAsVarParameter, []) + else if GetSymbolRec(Arg2).TypedConst then + CreateError(errConstantObjectCannotBePassedAsVarParameter, []); + + if GetSymbolRec(Arg1).IsOut then + begin + InsertDestroyLocalVar(P[J], Arg2); + Inc(N); + end; + + R.Op := OP_PUSH_ADDRESS; + + if (T2 = typeINTERFACE) and (K2 = KindTYPE) and (T1 = typeINTERFACE) + then + begin + R.Arg1 := GetSymbolRec(Arg2).TerminalTypeId + 1; + continue; + end + else if (T2 = typeINTERFACE) and (K2 = KindTYPE) and + (GetSymbolRec(Arg1).TerminalTypeId = H_TGUID) then + begin + R.Arg1 := GetSymbolRec(Arg2).TerminalTypeId + 1; + continue; + end; + + if T1 = typeOPENARRAY then + T1 := typeDYNARRAY; + + if not((K2 = KindVAR) and ((T1 = T2) or GetSymbolRec(Arg1) + .HasPVoidType)) then + begin + if T2 = typeVARIANT then + if IsVarArrayIndex(Arg2, T1, J, P) then + continue; + + CreateError + (errTypesOfActualAndFormalVarParametersMustBeIdentical, []); + end; + + if (T1 = typeDYNARRAY) and (T2 = typeDYNARRAY) then + begin + T1 := GetSymbolRec(Arg1).TerminalTypeId; + T2 := GetSymbolRec(Arg2).TerminalTypeId; + + if GetSymbolRec(Arg1).IsOpenArray then + R.Op := OP_PUSH_DYNARRAY; + + T1 := GetSymbolRec(T1).PatternId; + T2 := GetSymbolRec(T2).PatternId; + + if (T1 = T2) or (T1 = 0) then + begin + // ok + end + else + CreateError(errIncompatibleTypesNoArgs, []); + + end; + end + else if (T1 = typeEVENT) and (T2 = typeEVENT) then + begin + R.Op := OP_PUSH_EVENT; + end + else if (T1 = typeEVENT) and (T2 = typeRECORD) then + begin + R.Op := OP_PUSH_EVENT; + end + else if (T1 = typeEVENT) and (Arg2 = SymbolTable.NilId) then + begin + R.Arg1 := SymbolTable.EventNilId; + R.Op := OP_PUSH_EVENT; + end + else if (T1 = typeRECORD) and (T2 = typeRECORD) then + begin + T1 := GetSymbolRec(Arg1).TerminalTypeId; + T2 := GetSymbolRec(Arg2).TerminalTypeId; + if T1 <> T2 then + if T1 <> H_TGUID then + if T1 <> H_TVarRec then + begin + Dec(N); + InsertConversionToRecord(P[J], 1, + GetSymbolRec(Arg1).TerminalTypeId, Arg2); + Inc(N); + Inc(N); + R.Arg1 := Records[N].Res; + Dec(N); + + Records[N_BeginCall].Op := OP_NOP; + for I := 0 to P.Count - 1 do + Records[P[I]].Op := OP_PUSH; + if PosInstance > 0 then + Records[PosInstance].Op := OP_PUSH_INSTANCE; + if PosClassRef > 0 then + Records[PosInstance].Op := OP_PUSH_CLASSREF; + + Exit; + end; + + if not StrEql(GetSymbolRec(T1).Name, GetSymbolRec(T2).Name) then + begin + CreateError(errIncompatibleTypes, [GetSymbolRec(T1).Name, + GetSymbolRec(T2).Name]); + end; + // if GetSymbolRec(SubId).CallConv = ccREGISTER then + // R.Op := OP_PUSH_ADDRESS + // else + R.Op := OP_PUSH_STRUCTURE; + end + else if GetSymbolRec(Arg1).HasPVoidType then + begin + R.Op := OP_PUSH_ADDRESS; + end + else if (T1 = typeARRAY) and (T2 = typeARRAY) then + begin + T1 := GetSymbolRec(Arg1).TerminalTypeId; + T2 := GetSymbolRec(Arg2).TerminalTypeId; + if T1 <> T2 then + begin + CreateError(errIncompatibleTypes, [GetSymbolRec(T1).Name, + GetSymbolRec(T2).Name]); + end; + R.Op := OP_PUSH_STRUCTURE; + end + else if (T1 = typeVARIANT) and (T2 in VariantTypes) then + begin + R.Op := OP_PUSH_ADDRESS; + if SymbolTable[SubId].Host then + if SymbolTable[SubId].CallConv in [ccSTDCALL, ccCDECL, ccSAFECALL] + then + if not SymbolTable[Arg1].IsConst then + R.Op := OP_PUSH_STRUCTURE; + end + else if (T1 = typeVARIANT) and (T2 <> typeVARIANT) then + begin + R.Op := OP_PUSH_ADDRESS; + InsertConversionToVariant(P[J], 1); + Inc(N); + if SymbolTable[SubId].Host then + if SymbolTable[SubId].CallConv in [ccSTDCALL, ccCDECL, ccSAFECALL] + then + if not SymbolTable[Arg1].IsConst then + R.Op := OP_PUSH_STRUCTURE; + end + else if (T1 = typeOLEVARIANT) and (T2 = typeOLEVARIANT) then + begin + R.Op := OP_PUSH_ADDRESS; + if SymbolTable[SubId].Host then + if SymbolTable[SubId].CallConv in [ccSTDCALL, ccCDECL, ccSAFECALL] + then + if not SymbolTable[Arg1].IsConst then + R.Op := OP_PUSH_STRUCTURE; + end + else if (T1 = typeOLEVARIANT) and (T2 <> typeOLEVARIANT) then + begin + R.Op := OP_PUSH_ADDRESS; + InsertConversionToOleVariant(P[J], 1); + Inc(N); + if SymbolTable[SubId].Host then + if SymbolTable[SubId].CallConv in [ccSTDCALL, ccCDECL, ccSAFECALL] + then + if not SymbolTable[Arg1].IsConst then + R.Op := OP_PUSH_STRUCTURE; + end + else if (T1 = typeBOOLEAN) and (T2 in BooleanTypes) then + begin + if K2 = KindCONST then + R.Op := OP_PUSH_BYTE_IMM + else + R.Op := OP_PUSH_BYTE; + end + else if (T1 = typeBOOLEAN) and (T2 in VariantTypes) then + begin + R.Op := OP_PUSH_BYTE; + InsertConversionToBoolean(P[J], 1); + Inc(N); + end + else if (T1 = typeBYTEBOOL) and (T2 in BooleanTypes) then + begin + if K2 = KindCONST then + R.Op := OP_PUSH_WORD_IMM + else + R.Op := OP_PUSH_WORD; + end + else if (T1 = typeBYTEBOOL) and (T2 in VariantTypes) then + begin + R.Op := OP_PUSH_WORD; + InsertConversionToByteBool(P[J], 1); + Inc(N); + end + else if (T1 = typeWORDBOOL) and (T2 in BooleanTypes) then + begin + if K2 = KindCONST then + R.Op := OP_PUSH_WORD_IMM + else + R.Op := OP_PUSH_WORD; + end + else if (T1 = typeWORDBOOL) and (T2 in VariantTypes) then + begin + R.Op := OP_PUSH_WORD; + InsertConversionToWordBool(P[J], 1); + Inc(N); + end + else if (T1 = typeLONGBOOL) and (T2 in BooleanTypes) then + begin + if K2 = KindCONST then + R.Op := OP_PUSH_INT_IMM + else + R.Op := OP_PUSH_INT; + end + else if (T1 = typeLONGBOOL) and (T2 in VariantTypes) then + begin + R.Op := OP_PUSH_INT; + InsertConversionToLongBool(P[J], 1); + Inc(N); + end +{$IFNDEF PAXARM} + else if (T1 = typeANSICHAR) and (T2 = typeANSICHAR) then + begin + if K2 = KindCONST then + R.Op := OP_PUSH_BYTE_IMM + else + R.Op := OP_PUSH_BYTE; + end + else if (T1 = typeANSICHAR) and (T2 = typeWIDECHAR) then + begin + if K2 = KindCONST then + R.Op := OP_PUSH_WORD_IMM + else + R.Op := OP_PUSH_WORD; + end +{$ENDIF} + else if (T1 = typeWIDECHAR) and (T2 in CharTypes) then + begin + if K2 = KindCONST then + R.Op := OP_PUSH_WORD_IMM + else + R.Op := OP_PUSH_WORD; + end + else if (T1 = typeBYTE) and (T2 in IntegerTypes) then + begin + if K2 = KindCONST then + R.Op := OP_PUSH_BYTE_IMM + else + R.Op := OP_PUSH_BYTE; + end + else if (T1 = typeWORD) and (T2 in IntegerTypes) then + begin + if K2 = KindCONST then + R.Op := OP_PUSH_WORD_IMM + else + R.Op := OP_PUSH_WORD; + end + else if (T1 = typeCARDINAL) and (T2 in IntegerTypes) then + begin + if K2 = KindCONST then + R.Op := OP_PUSH_CARDINAL_IMM + else + R.Op := OP_PUSH_CARDINAL; + end + else if (T1 = typeCARDINAL) and (T2 in VariantTypes) then + begin + R.Op := OP_PUSH_CARDINAL; + InsertConversionToCardinal(P[J], 1); + Inc(N); + end + else if (T1 = typeSMALLINT) and (T2 in IntegerTypes) then + begin + if K2 = KindCONST then + R.Op := OP_PUSH_SMALLINT_IMM + else + R.Op := OP_PUSH_SMALLINT; + end + else if (T1 = typeSMALLINT) and (T2 in VariantTypes) then + begin + R.Op := OP_PUSH_SMALLINT; + InsertConversionToSmallInt(P[J], 1); + Inc(N); + end + else if (T1 = typeSHORTINT) and (T2 in IntegerTypes) then + begin + if K2 = KindCONST then + R.Op := OP_PUSH_SHORTINT_IMM + else + R.Op := OP_PUSH_SHORTINT; + end + else if (T1 = typeSHORTINT) and (T2 in VariantTypes) then + begin + R.Op := OP_PUSH_SHORTINT; + InsertConversionToShortInt(P[J], 1); + Inc(N); + end + else if (T1 = typeINTEGER) and (T2 in IntegerTypes) then + begin + if K2 = KindCONST then + R.Op := OP_PUSH_INT_IMM + else + R.Op := OP_PUSH_INT; + end + else if (T1 = typeINTEGER) and (T2 in VariantTypes) then + begin + R.Op := OP_PUSH_INT; + InsertConversionToInteger(P[J], 1); + Inc(N); + end + else if (T1 = typeBYTE) and (T2 in VariantTypes) then + begin + R.Op := OP_PUSH_BYTE; + InsertConversionToByte(P[J], 1); + Inc(N); + end + else if (T1 = typeWORD) and (T2 in VariantTypes) then + begin + R.Op := OP_PUSH_WORD; + InsertConversionToWord(P[J], 1); + Inc(N); + end + else if (T1 = typeDOUBLE) and (T2 in VariantTypes) then + begin + R.Op := OP_PUSH_DOUBLE; + InsertConversionToDouble(P[J], 1); + Inc(N); + end + else if (T1 = typeSINGLE) and (T2 in VariantTypes) then + begin + R.Op := OP_PUSH_SINGLE; + InsertConversionToSingle(P[J], 1); + Inc(N); + end + else if (T1 = typeEXTENDED) and (T2 in VariantTypes) then + begin + R.Op := OP_PUSH_EXTENDED; + InsertConversionToExtended(P[J], 1); + Inc(N); + end +{$IFNDEF PAXARM} + else if (T1 = typeANSISTRING) and (T2 in VariantTypes) then + begin + R.Op := OP_PUSH_ANSISTRING; + InsertConversionToAnsiString(P[J], 1); + Inc(N); + end + else if (T1 = typeWIDESTRING) and (T2 in VariantTypes) then + begin + R.Op := OP_PUSH_WIDESTRING; + InsertConversionToWideString(P[J], 1); + Inc(N); + end + else if (T1 = typeWIDESTRING) and (SymbolTable[Arg2].HasPWideCharType) + then + begin + R.Op := OP_PUSH_WIDESTRING; + InsertConversionToWideString(P[J], 1); + Inc(N); + end +{$ENDIF} + else if (T1 = typeCLASS) and (T2 = typeCLASS) then + begin + T1 := GetSymbolRec(Arg1).TypeId; + T2 := GetSymbolRec(Arg2).TypeId; + if not SymbolTable.Inherits(T2, T1) then + begin + if T1 <> typeCLASS then + CreateError(errIncompatibleTypes, + [GetSymbolRec(T1).Name, GetSymbolRec(T2).Name]); + end; + + if K2 = KindCONST then + R.Op := OP_PUSH_INT_IMM + else + R.Op := OP_PUSH_INT; + end + else if (T1 = typeCLASS) and (Arg2 = SymbolTable.NilId) then + begin + R.Op := OP_PUSH_INT_IMM; + end + else if (T1 = typeINTERFACE) and (T2 = typeINTERFACE) then + begin + if K2 = KindCONST then + R.Op := OP_PUSH_INT_IMM + else + R.Op := OP_PUSH_INT; + T1 := GetSymbolRec(Arg1).TerminalTypeId; + T2 := GetSymbolRec(Arg2).TerminalTypeId; + if not SymbolTable.Supports(T2, T1) then + CreateError(errIncompatibleTypes, [GetSymbolRec(T1).Name, + GetSymbolRec(T2).Name]); + end + else if (T1 = typeINTERFACE) and (T2 = typePOINTER) then + begin + if K2 = KindCONST then + R.Op := OP_PUSH_INT_IMM + else + begin + T1 := GetSymbolRec(Arg1).TypeId; + T2 := GetSymbolRec(Arg2).TypeId; + CreateError(errIncompatibleTypes, [GetSymbolRec(T1).Name, + GetSymbolRec(T2).Name]); + end; + end + else if (T1 = typeINTERFACE) and (Arg2 = SymbolTable.NilId) then + begin + R.Op := OP_PUSH_INT_IMM; + end + else if (T1 = typeINTERFACE) and (T2 = typeCLASS) then + begin + T1 := GetSymbolRec(Arg1).TerminalTypeId; + T2 := GetSymbolRec(Arg2).TerminalTypeId; + if not SymbolTable.Supports(T2, T1) then + CreateError(errIncompatibleTypesNoArgs, []); + + R.Op := OP_PUSH_INT; + InsertConversionToInterface(P[J], 1, + GetSymbolRec(Arg1).TerminalTypeId); + Inc(N); + end + else if (T2 = typeINTERFACE) and (K2 = KindTYPE) and (T1 = typeINTERFACE) + then + begin + R.Op := OP_PUSH_ADDRESS; + R.Arg1 := GetSymbolRec(Arg2).TerminalTypeId + 1; + end + else if (T2 = typeINTERFACE) and (K2 = KindTYPE) and + (GetSymbolRec(Arg1).TerminalTypeId = H_TGUID) then + begin + R.Op := OP_PUSH_ADDRESS; + R.Arg1 := GetSymbolRec(Arg2).TerminalTypeId + 1; + end + else if (T1 = typeCLASSREF) and (T2 = typeCLASSREF) then + begin + T1 := GetSymbolRec(GetSymbolRec(Arg1).TerminalTypeId).PatternId; + T2 := GetSymbolRec(GetSymbolRec(Arg2).TerminalTypeId).PatternId; + if not SymbolTable.Inherits(T2, T1) then + begin + T1 := GetSymbolRec(Arg1).TypeId; + T2 := GetSymbolRec(Arg2).TypeId; + CreateError(errIncompatibleTypes, [GetSymbolRec(T1).Name, + GetSymbolRec(T2).Name]); + end; + + if K2 = KindCONST then + R.Op := OP_PUSH_INT_IMM + else + R.Op := OP_PUSH_INT; + end + else if (T1 = typeCLASSREF) and (Arg2 = SymbolTable.NilId) then + begin + R.Op := OP_PUSH_INT_IMM; + end + else if (T1 = typeCLASSREF) and (T2 = typeCLASS) then + begin + T1 := GetSymbolRec(GetSymbolRec(Arg1).TerminalTypeId).PatternId; + T2 := Arg2; + if (not SymbolTable.Inherits(T2, T1)) or (K2 <> KindTYPE) then + begin + T1 := GetSymbolRec(Arg1).TypeId; + T2 := GetSymbolRec(Arg2).TypeId; + CreateError(errIncompatibleTypes, [GetSymbolRec(T1).Name, + GetSymbolRec(T2).Name]); + end; + + R.Op := OP_PUSH_INT; + Inc(R.Arg1); + end + + else if (T1 = typeOPENARRAY) and (T2 = typeOPENARRAY) then + begin + R.Op := OP_PUSH_OPENARRAY; + + T1 := GetSymbolRec(Arg1).TerminalTypeId; + T2 := GetSymbolRec(Arg2).TerminalTypeId; + + T1 := GetSymbolRec(T1).PatternId; + T2 := GetSymbolRec(T2).PatternId; + + if not((T1 = T2) or (T1 = 0)) then + CreateError(errIncompatibleTypesNoArgs, []); + end + + else if (T1 = typeOPENARRAY) and (T2 = typeDYNARRAY) then + begin + R.Op := OP_PUSH_DYNARRAY; + + T1 := GetSymbolRec(Arg1).TerminalTypeId; + T2 := GetSymbolRec(Arg2).TerminalTypeId; + + T1 := GetSymbolRec(T1).PatternId; + T2 := GetSymbolRec(T2).PatternId; + + if not((T1 = T2) or (T1 = 0)) then + CreateError(errIncompatibleTypesNoArgs, []); + end + + else if (T1 = typeOPENARRAY) and (T2 = typeARRAY) then + begin + R.Op := OP_PUSH_OPENARRAY; + + T1 := GetSymbolRec(Arg1).TerminalTypeId; + T2 := GetSymbolRec(Arg2).TerminalTypeId; + + T1 := GetSymbolRec(T1).PatternId; + SymbolTable.GetArrayTypeInfo(T2, K, T2); + + if not((T1 = T2) or (T1 = 0)) then + CreateError(errIncompatibleTypesNoArgs, []); + end + + else if (T1 = typeOPENARRAY) and (GetSymbolRec(Arg2).IsFWArrayVar) then + begin + R.Op := OP_PUSH_OPENARRAY; + + T1 := GetSymbolRec(Arg1).TerminalTypeId; + T2 := GetSymbolRec(Arg2).TerminalTypeId; + + T1 := GetSymbolRec(T1).PatternId; + T2 := GetSymbolRec(T2).PatternId; + T2 := GetSymbolRec(T2).PatternId; + + if not((T1 = T2) or (T1 = 0)) then + CreateError(errIncompatibleTypesNoArgs, []); + end + + else if (T1 = typeDYNARRAY) and (T2 = typeDYNARRAY) then + begin + R.Op := OP_PUSH_DYNARRAY; + + T1 := GetSymbolRec(Arg1).TypeId; + T2 := GetSymbolRec(Arg2).TypeId; + + T1 := GetSymbolRec(T1).PatternId; + T2 := GetSymbolRec(T2).PatternId; + + if not((T1 = T2) or (T1 = 0)) then + CreateError(errIncompatibleTypesNoArgs, []); + end + else if (T1 = typeDYNARRAY) and (Arg2 = SymbolTable.NilId) then + begin + R.Op := OP_PUSH_INT_IMM; + end + else if (T1 in [typeDYNARRAY, typeOPENARRAY]) and (T2 = typeSET) then + begin + if T1 = typeOPENARRAY then + begin + T1 := SymbolTable.RegisterDynamicArrayType(0, '', + GetSymbolRec(GetSymbolRec(Arg1).TypeId).PatternId) + end + else + T1 := GetSymbolRec(Arg1).TypeId; + Card1 := Card; + Arg2 := ConvertSetLiteralToDynarrayLiteral(GetSymbolRec(R.Arg1).Level, + T1, R.Arg1); + Card2 := Card; + + for J1 := P.Count - 1 downto 0 do + P[J1] := P[J1] + (Card2 - Card1); + + if Arg2 = 0 then + begin + Arg2 := SymbolTable.AddDynarrayVar(GetLevel(N), T1).Id; + R.Arg1 := Arg2; + + RC := TCodeRec.Create(OP_CREATE_EMPTY_DYNARRAY, Self); + RC.Arg1 := R.Arg1; + RC.Arg2 := 0; + RC.Res := 0; + + Insert(P[J], RC); + Inc(N); + + RC := TCodeRec.Create(OP_DECLARE_TEMP_VAR, Self); + RC.Arg1 := GetLevel(N); + RC.Arg2 := R.Arg1; + RC.Res := 0; + + Insert(P[J], RC); + Inc(N); + + end + else + R.Arg1 := Arg2; + R.Op := OP_PUSH_DYNARRAY; + end + else if (T1 = typePOINTER) and + (T2 in [typePOINTER, typeCLASS, typeCLASSREF]) then + begin + if GetSymbolRec(Arg1).HasPWideCharType then + begin + if K2 = KindCONST then + begin + if GetSymbolRec(Arg2).HasPWideCharType then + R.Op := OP_PUSH_PWIDECHAR_IMM +{$IFNDEF PAXARM} + else if GetSymbolRec(Arg2).HasPAnsiCharType then + begin + R.Op := OP_PUSH_WIDESTRING; + InsertConversionToWideString(P[J], 1); + Inc(N); + end +{$ENDIF} + else + R.Op := OP_PUSH_INT_IMM; + end + else + R.Op := OP_PUSH_INT; + end +{$IFNDEF PAXARM} + else if GetSymbolRec(Arg1).HasPAnsiCharType then + begin + if K2 = KindCONST then + begin + if GetSymbolRec(Arg2).HasPAnsiCharType then + R.Op := OP_PUSH_PANSICHAR_IMM + else if GetSymbolRec(Arg2).HasPWideCharType then + begin + R.Op := OP_PUSH_ANSISTRING; + InsertConversionToAnsiString(P[J], 1); + Inc(N); + end + else + R.Op := OP_PUSH_INT_IMM; + end + else + R.Op := OP_PUSH_INT; + end +{$ENDIF} + else + begin + if K2 = KindCONST then + R.Op := OP_PUSH_INT_IMM + else + R.Op := OP_PUSH_INT; + end; + end +{$IFNDEF PAXARM} + else if (T1 = typeANSISTRING) and (T2 = typeANSISTRING) then + begin + R.Op := OP_PUSH_ANSISTRING; + end + else if (T1 = typeSHORTSTRING) and (T2 = typeSHORTSTRING) then + begin + R.Op := OP_PUSH_SHORTSTRING; + end + else if (T1 = typeANSISTRING) and (T2 = typePOINTER) then + begin + R.Op := OP_PUSH_ANSISTRING; + if GetSymbolRec(Records[P[J]].Arg1).HasPAnsiCharType then + begin + InsertConversionToAnsiString(P[J], 1); + Inc(N); + end + else if GetSymbolRec(Records[P[J]].Arg1).HasPWideCharType then + begin + InsertConversionToAnsiString(P[J], 1); + Inc(N); + end + else + begin + T1 := GetSymbolRec(Arg1).TypeId; + T2 := GetSymbolRec(Arg2).TypeId; + CreateError(errIncompatibleTypes, [GetSymbolRec(T1).Name, + GetSymbolRec(T2).Name]); + end; + end + else if (T1 = typeANSISTRING) and (T2 in CharTypes) then + begin + R.Op := OP_PUSH_ANSISTRING; + InsertConversionToAnsiString(P[J], 1); + Inc(N); + end + else if (T1 = typeANSISTRING) and (T2 = typeSHORTSTRING) then + begin + R.Op := OP_PUSH_ANSISTRING; + InsertConversionToAnsiString(P[J], 1); + Inc(N); + end + else if (T1 = typeANSISTRING) and (T2 = typeWIDESTRING) then + begin + R.Op := OP_PUSH_ANSISTRING; + InsertConversionToAnsiString(P[J], 1); + Inc(N); + end + else if (T1 = typeSHORTSTRING) and (T2 = typePOINTER) then + begin + R.Op := OP_PUSH_SHORTSTRING; + if (K2 = KindCONST) and GetSymbolRec(Records[P[J]].Arg1).HasPAnsiCharType + then + begin + InsertConversionToShortString(P[J], 1); + Inc(N); + end + else if (K2 = KindCONST) and GetSymbolRec(Records[P[J]].Arg1).HasPWideCharType + then + begin + InsertConversionToShortString(P[J], 1); + Inc(N); + end + else + begin + T1 := GetSymbolRec(Arg1).TypeId; + T2 := GetSymbolRec(Arg2).TypeId; + CreateError(errIncompatibleTypes, [GetSymbolRec(T1).Name, + GetSymbolRec(T2).Name]); + end; + end + else if (T1 = typeSHORTSTRING) and (T2 in CharTypes) then + begin + R.Op := OP_PUSH_SHORTSTRING; + InsertConversionToShortString(P[J], 1); + Inc(N); + end + else if (T1 = typeSHORTSTRING) and (T2 = typeANSISTRING) then + begin + R.Op := OP_PUSH_SHORTSTRING; + InsertConversionToShortString(P[J], 1); + Inc(N); + end + else if (T1 = typeSHORTSTRING) and (T2 = typeWIDESTRING) then + begin + R.Op := OP_PUSH_SHORTSTRING; + InsertConversionToShortString(P[J], 1); + Inc(N); + end + else if (T1 = typeWIDESTRING) and (T2 = typeWIDESTRING) then + begin + R.Op := OP_PUSH_WIDESTRING; + end + else if (T1 = typeWIDESTRING) and (T2 = typePOINTER) then + begin + R.Op := OP_PUSH_WIDESTRING; + if (K2 = KindCONST) and GetSymbolRec(Records[P[J]].Arg1).HasPAnsiCharType + then + begin + InsertConversionToWideString(P[J], 1); + Inc(N); + end + else + begin + T1 := GetSymbolRec(Arg1).TypeId; + T2 := GetSymbolRec(Arg2).TypeId; + CreateError(errIncompatibleTypes, [GetSymbolRec(T1).Name, + GetSymbolRec(T2).Name]); + end; + end + else if (T1 = typeWIDESTRING) and (T2 in CharTypes) then + begin + R.Op := OP_PUSH_WIDESTRING; + InsertConversionToWideString(P[J], 1); + Inc(N); + end + else if (T1 = typeWIDESTRING) and (T2 = typeANSISTRING) then + begin + R.Op := OP_PUSH_WIDESTRING; + InsertConversionToWideString(P[J], 1); + Inc(N); + end + else if (T1 = typeWIDESTRING) and (T2 = typeSHORTSTRING) then + begin + R.Op := OP_PUSH_WIDESTRING; + InsertConversionToWideString(P[J], 1); + Inc(N); + end +{$ENDIF} // NOT PAXARM + + // unic string - begin + + else if (T1 = typeUNICSTRING) and (T2 = typeUNICSTRING) then + begin + R.Op := OP_PUSH_UNICSTRING; + end + else if (T1 = typeUNICSTRING) and (T2 <> typeUNICSTRING) then + begin + R.Op := OP_PUSH_UNICSTRING; + InsertConversionToUnicString(P[J], 1); + Inc(N); + end + + // unic string - end +{$IFNDEF PAXARM} + else if (T1 = typeANSISTRING) and (T2 <> typeANSISTRING) then + begin + R.Op := OP_PUSH_ANSISTRING; + InsertConversionToAnsiString(P[J], 1); + Inc(N); + end + else if (T1 = typeSHORTSTRING) and (T2 <> typeSHORTSTRING) then + begin + R.Op := OP_PUSH_SHORTSTRING; + InsertConversionToShortString(P[J], 1); + Inc(N); + end + else if (T1 = typeWIDESTRING) and (T2 <> typeWIDESTRING) then + begin + R.Op := OP_PUSH_WIDESTRING; + InsertConversionToWideString(P[J], 1); + Inc(N); + end +{$ENDIF} + else if (T1 = typeDOUBLE) and (T2 = typeDOUBLE) then + begin + R.Op := OP_PUSH_DOUBLE; + end + else if (T1 = typeDOUBLE) and (T2 in NumberTypes) then + begin + R.Op := OP_PUSH_DOUBLE; + if K2 = KindCONST then + Records[P[J]].Arg1 := CreateConst(typeDOUBLE, + GetSymbolRec(Records[P[J]].Arg1).value) + else + begin + InsertConversionToDouble(P[J], 1); + Inc(N); + end; + end + else if (T1 = typeCURRENCY) and (T2 = typeCURRENCY) then + begin + R.Op := OP_PUSH_CURRENCY; + end + else if (T1 = typeCURRENCY) and (T2 in NumberTypes) then + begin + R.Op := OP_PUSH_CURRENCY; + if K2 = KindCONST then + Records[P[J]].Arg1 := CreateConst(typeCURRENCY, + GetSymbolRec(Records[P[J]].Arg1).value) + else + begin + InsertConversionToCurrency(P[J], 1); + Inc(N); + end; + end + else if (T1 = typeSINGLE) and (T2 = typeSINGLE) then + begin + R.Op := OP_PUSH_SINGLE; + end + else if (T1 = typeSINGLE) and (T2 in NumberTypes) then + begin + R.Op := OP_PUSH_SINGLE; + if K2 = KindCONST then + Records[P[J]].Arg1 := CreateConst(typeSINGLE, + GetSymbolRec(Records[P[J]].Arg1).value) + else + begin + InsertConversionToSingle(P[J], 1); + Inc(N); + end; + end + else if (T1 = typeEXTENDED) and (T2 = typeEXTENDED) then + begin + R.Op := OP_PUSH_EXTENDED; + end + else if (T1 = typeEXTENDED) and (T2 in NumberTypes) then + begin + R.Op := OP_PUSH_EXTENDED; + if K2 = KindCONST then + Records[P[J]].Arg1 := CreateConst(typeEXTENDED, + GetSymbolRec(Records[P[J]].Arg1).value) + else + begin + InsertConversionToExtended(P[J], 1); + Inc(N); + end; + end + else if (T1 in INT64Types) and (T2 in INT64Types) then + begin + R.Op := OP_PUSH_INT64; + end + else if (T1 = typeINT64) and (T2 in (NumberTypes + VariantTypes)) then + begin + R.Op := OP_PUSH_INT64; + if K2 = KindCONST then + Records[P[J]].Arg1 := CreateConst(typeINT64, + GetSymbolRec(Records[P[J]].Arg1).value) + else + begin + InsertConversionToInt64(P[J], 1); + Inc(N); + end; + end + else if (T1 = typeUINT64) and (T2 in (NumberTypes + VariantTypes)) then + begin + R.Op := OP_PUSH_INT64; + if K2 = KindCONST then + Records[P[J]].Arg1 := CreateConst(typeUINT64, + GetSymbolRec(Records[P[J]].Arg1).value) + else + begin + InsertConversionToUInt64(P[J], 1); + Inc(N); + end; + end +{$IFNDEF PAXARM} + else if GetSymbolRec(Arg1).HasPAnsiCharType and (T2 = typeANSISTRING) + then + begin + R.Op := OP_PUSH_INT; + end + else if GetSymbolRec(Arg1).HasPAnsiCharType and + SymbolTable.IsZerobasedAnsiCharArray(Arg2) then + begin + R.Op := OP_PUSH_ADDRESS; + end +{$ENDIF} + else if GetSymbolRec(Arg1).HasPWideCharType and + SymbolTable.IsZerobasedWideCharArray(Arg2) then + begin + R.Op := OP_PUSH_ADDRESS; + end + else if (T1 = typeSET) and (T2 = typeSET) then + begin + T1 := GetSymbolRec(Arg1).TerminalTypeId; + T2 := GetSymbolRec(Arg2).TerminalTypeId; + + if not SymbolTable.CheckSetTypes(T1, T2) then + begin + CreateError(errIncompatibleTypes, [GetSymbolRec(T1).Name, + GetSymbolRec(T2).Name]); + end; + + if SymbolTable.GetSizeOfSetType(T1) <= 4 then + R.Op := OP_PUSH_SET + else + R.Op := OP_PUSH_ADDRESS; + + end + else if (T1 = typePROC) and (T2 = typePROC) then + begin + R.Op := OP_PUSH_PTR; + end + else if (T1 = typePROC) and (T2 = typePOINTER) then + begin + R.Op := OP_PUSH_PTR; + end + else if (T1 = typePROC) and (K2 = KindSUB) then + begin + T1 := GetSymbolRec(Arg1).TerminalTypeId; + SubId1 := TKernel(kernel).SymbolTable.GetPatternSubId(T1); + SubId2 := Arg2; + if not SymbolTable.EqualHeaders(SubId1, SubId2) then + CreateError(errIncompatibleTypesNoArgs, []); + R.Op := OP_PUSH_ADDRESS; + end + else if (T1 = typeENUM) and (T2 = typeENUM) then + begin + T1 := GetSymbolRec(Arg1).TerminalTypeId; + T2 := GetSymbolRec(Arg2).TerminalTypeId; + + if T1 = T2 then + begin + R.Op := OP_PUSH_INT; + end + else + begin + T1 := GetSymbolRec(Arg1).TypeId; + T2 := GetSymbolRec(Arg2).TypeId; + CreateError(errIncompatibleTypes, [GetSymbolRec(T1).Name, + GetSymbolRec(T2).Name]); + end; + end + else if (T2 = typeENUM) and (SubId = Id_WriteInt) then + begin + R.Op := OP_PUSH_INT; + end + else if T1 = typeRECORD then + begin + T1 := GetSymbolRec(Arg1).TerminalTypeId; + T2 := GetSymbolRec(Arg2).TerminalTypeId; + if T1 <> T2 then + if T1 <> H_TGUID then + if T1 <> H_TVarRec then + begin + Dec(N); + InsertConversionToRecord(P[J], 1, + GetSymbolRec(Arg1).TerminalTypeId, Arg2); + Inc(N); + Inc(N); + R.Arg1 := Records[N].Res; + Dec(N); + + Records[N_BeginCall].Op := OP_NOP; + for I := 0 to P.Count - 1 do + Records[P[I]].Op := OP_PUSH; + if PosInstance > 0 then + Records[PosInstance].Op := OP_PUSH_INSTANCE; + if PosClassRef > 0 then + Records[PosInstance].Op := OP_PUSH_CLASSREF; + + Exit; + end; + + if not StrEql(GetSymbolRec(T1).Name, GetSymbolRec(T2).Name) then + begin + CreateError(errIncompatibleTypes, [GetSymbolRec(T1).Name, + GetSymbolRec(T2).Name]); + end; + if GetSymbolRec(SubId).CallConv = ccREGISTER then + R.Op := OP_PUSH_ADDRESS + else + R.Op := OP_PUSH_STRUCTURE; + end + + else if (SubId = Id_ImplicitInt) and (T1 = typeINTEGER) and + (T2 = typeENUM) then + begin + R.Op := OP_PUSH_INT; + end + + else + begin + if IsOverloadedCall then + begin + if P.Count = 1 then + begin + R := Records[P[0]]; + ParamId := R.Arg1; + if GetSymbolRec(ParamId).FinalTypeId = typeOPENARRAY then + if StrEql('Length', SymbolTable[SubId].Name) then + begin + Records[N_BeginCall].Op := OP_NOP; + Records[N_BeginCall].GenOp := OP_NOP; + R.Op := OP_HIGH; + R.Res := Records[N].Res; + Records[N].Op := OP_PLUS; + Records[N].Arg1 := R.Res; + Records[N].Arg2 := CreateConst(typeINTEGER, 1); + Records[N].Res := R.Res; + N := P[0] - 1; + Exit; + end; + end; + + CreateError(errThereIsNoOverloaded, [SymbolTable[SubId].Name]); + end + else + begin + T1 := GetSymbolRec(Arg1).TypeId; + T2 := GetSymbolRec(Arg2).TypeId; + + if (SubId = JS_GetPropertyId) or (SubId = JS_PutPropertyId) then + begin + T2 := GetSymbolRec(Arg2).FinalTypeId; + if K2 = KindCONST then + begin +{$IFDEF UNIC} + R.Op := OP_PUSH_PWIDECHAR_IMM; +{$ELSE} + R.Op := OP_PUSH_PANSICHAR_IMM; +{$ENDIF} + if T2 in IntegerTypes then + begin + R.Op := OP_PUSH_INT_IMM; + if SubId = JS_GetPropertyId then + begin + Records[N_BeginCall].Arg1 := JS_GetArrPropertyId; + Records[N].Arg1 := JS_GetArrPropertyId; + end + else + begin + Records[N_BeginCall].Arg1 := JS_PutArrPropertyId; + Records[N].Arg1 := JS_PutArrPropertyId; + end; + end + else if T2 in BooleanTypes then + begin + if GetSymbolRec(R.Arg1).value then + R.Arg1 := CreateConst(typeSTRING, 'true') + else + R.Arg1 := CreateConst(typeSTRING, 'false'); + end + else if T2 in RealTypes then + begin + STR(Extended(GetSymbolRec(R.Arg1).value), SS); + R.Arg1 := CreateConst(typeSTRING, String(SS)); + end + else + CreateError(errIncompatibleTypesNoArgs, []); + end + else + begin + T2 := GetSymbolRec(Arg2).FinalTypeId; + if T2 in IntegerTypes then + begin + R.Op := OP_PUSH_INT; + if SubId = JS_GetPropertyId then + begin + Records[N_BeginCall].Arg1 := JS_GetArrPropertyId; + Records[N].Arg1 := JS_GetArrPropertyId; + end + else + begin + Records[N_BeginCall].Arg1 := JS_PutArrPropertyId; + Records[N].Arg1 := JS_PutArrPropertyId; + end; + end + else + begin +{$IFDEF UNIC} + R.Op := OP_PUSH_UNICSTRING; + if T2 <> typeUNICSTRING then + begin + InsertConversionToUnicString(P[J], 1, JS_LANGUAGE); + Inc(N); + end; +{$ELSE} + R.Op := OP_PUSH_ANSISTRING; + if T2 <> typeANSISTRING then + begin + InsertConversionToAnsiString(P[J], 1, JS_LANGUAGE); + Inc(N); + end; +{$ENDIF} + end; + end; + end + else + begin + if GetLanguage(N) = JS_LANGUAGE then + begin + if (GetSymbolRec(T1).FinalTypeId = typeCLASS) and + (GetSymbolRec(T2).FinalTypeId = typeVARIANT) then + begin + R.Op := OP_PUSH_INT; + InsertConversionToClass(P[J], 1, T1); + Inc(N); + continue; + end; + end; + + if GetSymbolRec(Arg1).HasFrameworkType then + begin + if Arg2 = TKernel(kernel).SymbolTable.NilId then + begin + // ok + end + else if GetSymbolRec(Arg1).TerminalTypeId = GetSymbolRec(Arg2).TerminalTypeId + then + begin + + end + else + begin + InsertConversionToFrameworkClass(P[J], 1, + GetSymbolRec(Arg1).TerminalTypeId); + Inc(N); + end; + R.Op := OP_PUSH_INT; + continue; + end; + + if GetSymbolRec(Arg2).FinalTypeId = typeRECORD then + begin + InsertImplicitConversion(P[J], 1, + GetSymbolRec(Arg2).TerminalTypeId, T1); + T1 := GetSymbolRec(Arg1).FinalTypeId; + if T1 in OrdinalTypes then + R.Op := OP_PUSH_INT + else + case T1 of + typeCLASS, typePOINTER, typeCLASSREF, typeINTERFACE: + R.Op := OP_PUSH_INT; + typeDYNARRAY: + R.Op := OP_PUSH_DYNARRAY; + typeSINGLE: + R.Op := OP_PUSH_SINGLE; + typeDOUBLE: + R.Op := OP_PUSH_DOUBLE; + typeEXTENDED: + R.Op := OP_PUSH_EXTENDED; +{$IFNDEF PAXARM} + typeANSISTRING: + R.Op := OP_PUSH_ANSISTRING; + typeWIDESTRING: + R.Op := OP_PUSH_WIDESTRING; + typeSHORTSTRING: + R.Op := OP_PUSH_SHORTSTRING; +{$ENDIF} + typeUNICSTRING: + R.Op := OP_PUSH_UNICSTRING; + typeVARIANT, typeOLEVARIANT: + begin + R.Op := OP_PUSH_ADDRESS; + if SymbolTable[SubId].Host then + if SymbolTable[SubId].CallConv + in [ccSTDCALL, ccCDECL, ccSAFECALL] then + if not SymbolTable[Arg1].IsConst then + R.Op := OP_PUSH_STRUCTURE; + end; + else + CreateError(errIncompatibleTypesNoArgs, []) + end; + continue; + end; + + if (GetSymbolRec(T1).Name = '') or (GetSymbolRec(T2).Name = '') + then + CreateError(errIncompatibleTypesNoArgs, []) + else + CreateError(errIncompatibleTypes, + [GetSymbolRec(T1).Name, GetSymbolRec(T2).Name]); + end; + end; + end; + end; + + if SymbolTable[SymbolTable[SubId].Level].Kind = KindSUB then + // nested sub call + begin + RC := TCodeRec.Create(OP_POP, Self); + RC.Arg1 := 0; + RC.Arg2 := 0; + RC.Res := 0; + + Insert(N + 1, RC); + // Inc(N); + end; + finally + if SavedSubId <> -1 then + begin + for J := GetStmt(N) to N do + if (Records[J].Op = OP_PUSH) and (Records[J].Res = SubId) then + Records[J].Res := SavedSubId + else if (Records[J].Op = OP_BEGIN_CALL) and (Records[J].Arg1 = SubId) + then + begin + Records[J].Arg1 := SavedSubId; + end; + + RR.Arg1 := SavedSubId; + + if GetSymbolRec(SavedSubId).FinalTypeId = typeEVENT then + begin + + RC := TCodeRec.Create(OP_PUSH_DATA, Self); + RC.Arg1 := SavedSubId; + RC.Arg2 := 0; + RC.Res := SubId; + + Insert(N, RC); + Inc(N); + + end; + + end; + FreeAndNil(P); + + Id_VMT := 0; + + if (PosInstance = 0) and (PosClassRef <> 0) then + begin + T1 := GetSymbolRec(SubId).Level; + if T1 > 0 then + if GetSymbolRec(T1).Kind = KindTYPE then + if GetSymbolRec(SubId).Kind = KindCONSTRUCTOR then + if GetSymbolRec(T1).FinalTypeId = typeRECORD then + begin + PosInstance := PosClassRef; + PosClassRef := 0; + Records[PosInstance].Arg1 := Records[N].Res; + end; + end; + + if PosInstance <> 0 then + begin + Records[PosInstance].Op := OP_NOP; + + RC := TCodeRec.Create(OP_PUSH_INST, Self); + RC.Arg1 := Records[PosInstance].Arg1; + RC.Arg2 := 0; + RC.Res := SubId; + RC.CodeRecTag := Records[PosInstance].CodeRecTag; + + Insert(N, RC); + Inc(N); + + if not Records[N].IsStatic then + if GetSymbolRec(SubId).IsVirtual then + begin + Id_VMT := NewTempVar(GetLevel(N), typePOINTER); + + RC := TCodeRec.Create(OP_GET_VMT_ADDRESS, Self); + RC.Arg1 := Records[PosInstance].Arg1; + RC.Arg2 := SubId; + RC.Res := Id_VMT; + + Insert(N, RC); + Inc(N); + end; + end; + + if PosClassRef <> 0 then + begin + Records[PosClassRef].Op := OP_NOP; + + T1 := GetSymbolRec(SubId).Level; + if GetSymbolRec(T1).Kind = KindTYPE then + begin + if GetSymbolRec(T1).Host then + begin + RC := TCodeRec.Create(OP_PUSH_CLSREF, Self); + + if GetSymbolRec(Records[PosClassRef].Arg1).Kind = KindVAR then + RC.Arg1 := Records[PosClassRef].Arg1 + else + RC.Arg1 := T1 + 1; + + RC.Arg2 := 0; + RC.Res := SubId; + + Insert(N, RC); + Inc(N); + + if GetSymbolRec(Records[PosClassRef].Arg1).Kind = KindVAR then + if GetSymbolRec(Records[PosClassRef].Arg1).Name <> '' then + if GetSymbolRec(SubId).IsVirtual then + begin + + Id_VMT := NewTempVar(GetLevel(N), typePOINTER); + + RC := TCodeRec.Create(OP_GET_VMT_ADDRESS, Self); + RC.Arg1 := Records[PosClassRef].Arg1; + RC.Arg2 := SubId; + RC.Res := Id_VMT; + + Insert(N, RC); + Inc(N); + end; + + end + else if GetSymbolRec(SubId).Kind = KindCONSTRUCTOR then + begin + { + J1 := NewTempVar(GetLevel(N), T1); + + RC := TCodeRec.Create(OP_CREATE_OBJECT, GetUpcase(N), GetLanguage(N), + GetModuleNumber(N)); + RC.Arg1 := T1; + RC.Arg2 := 0; + RC.Res := J1; + + Insert(N_BeginCall, RC); + Inc(N); + + RC := TCodeRec.Create(OP_PUSH_INST, Self); + RC.Arg1 := J1; + RC.Arg2 := 0; + RC.Res := SubId; + } + + RC := TCodeRec.Create(OP_PUSH_CLSREF, Self); + if GetSymbolRec(Records[PosClassRef].Arg1).Kind = KindVAR then + RC.Arg1 := Records[PosClassRef].Arg1 + else + RC.Arg1 := T1 + 1; + RC.Arg2 := 0; + RC.Res := SubId; + + Insert(N, RC); + Inc(N); + + if GetSymbolRec(SubId).IsVirtual then + begin + Id_VMT := NewTempVar(GetLevel(N), typePOINTER); + + RC := TCodeRec.Create(OP_GET_VMT_ADDRESS, Self); + RC.Arg1 := Records[PosClassRef].Arg1; + RC.Arg2 := SubId; + RC.Res := Id_VMT; + + Insert(N, RC); + Inc(N); + end; + + end + else + begin + RC := TCodeRec.Create(OP_PUSH_CLSREF, Self); + if GetSymbolRec(Records[PosClassRef].Arg1).Kind = KindVAR then + RC.Arg1 := Records[PosClassRef].Arg1 + else + RC.Arg1 := T1 + 1; + RC.Arg2 := 0; + RC.Res := SubId; + + Insert(N, RC); + Inc(N); + + if GetSymbolRec(SubId) + .IsVirtual { and (GetSymbolRec(SubId).Kind = KindSUB) } then + begin + Id_VMT := NewTempVar(GetLevel(N), typePOINTER); + + RC := TCodeRec.Create(OP_GET_VMT_ADDRESS, Self); + RC.Arg1 := Records[PosClassRef].Arg1; + RC.Arg2 := SubId; + RC.Res := Id_VMT; + + Insert(N, RC); + Inc(N); + end; + + end; + end + else + RaiseError(errInternalError, []); + end; + + if Records[N].Res = 0 then + if GetSymbolRec(Records[N].Arg1).FinalTypeId in RealTypes then + begin + Records[N].Res := NewTempVar(GetLevel(N), GetSymbolRec(Records[N].Arg1) + .FinalTypeId); + end; + + if Records[N].Res > 0 then + begin + if GetSymbolRec(Records[N].Res).TypeId = 0 then + GetSymbolRec(Records[N].Res).TypeId := GetSymbolRec(SubId).TypeId; + if GetSymbolRec(Records[N].Res).FinalTypeId + in (DynamicTypes + [typeRECORD, typeARRAY]) then + begin + if GetSymbolRec(Records[N].Res).FinalTypeId = typeINTERFACE then + if GetSymbolRec(Records[N].Res).Name = '' then + begin + RC := TCodeRec.Create(OP_INTERFACE_CLR, Self); + RC.Arg1 := Records[N].Res; + RC.Arg2 := 0; + RC.Res := 0; + Insert(N_BeginCall + 1, RC); + Inc(N); + end; + + RC := TCodeRec.Create(OP_DECLARE_TEMP_VAR, Self); + RC.Arg1 := GetSymbolRec(Records[N].Res).Level; + RC.Arg2 := Records[N].Res; + RC.Res := 0; + Insert(N, RC); + Inc(N); + end; + end + else + begin + Id := Records[N].Arg1; + + if GetSymbolRec(Id).Kind = KindCONSTRUCTOR then + begin + J := GetSymbolRec(Id).Level; + if GetSymbolRec(J).FinalTypeId = typeRECORD then + T1 := 0 + else + T1 := GetSymbolRec(Id).FinalTypeId; + end + else + T1 := GetSymbolRec(Id).FinalTypeId; + + if T1 in (DynamicTypes + [typeRECORD, typeARRAY]) then + begin + case T1 of +{$IFNDEF PAXARM} + typeANSISTRING: + Records[N].Res := CreateStringVar(GetLevel(N)); + typeWIDESTRING: + Records[N].Res := CreateWideStringVar(GetLevel(N)); +{$ENDIF} + typeUNICSTRING: + Records[N].Res := CreateUnicStringVar(GetLevel(N)); + typeVARIANT: + Records[N].Res := CreateVariantVar(GetLevel(N)); + typeOLEVARIANT: + Records[N].Res := CreateOleVariantVar(GetLevel(N)); + typeDYNARRAY: + Records[N].Res := CreateDynarrayVar(GetLevel(N), + GetSymbolRec(Records[N].Arg1).TypeId); + typeINTERFACE: + Records[N].Res := CreateInterfaceVar(GetLevel(N)); + typeRECORD, typeARRAY: + Records[N].Res := NewTempVar(GetLevel(N), + GetSymbolRec(Records[N].Arg1).TerminalTypeId); + end; + if GetSymbolRec(Records[N].Res).FinalTypeId = typeINTERFACE then + begin + RC := TCodeRec.Create(OP_INTERFACE_CLR, Self); + RC.Arg1 := Records[N].Res; + RC.Arg2 := 0; + RC.Res := 0; + Insert(N_BeginCall + 1, RC); + Inc(N); + end; + RC := TCodeRec.Create(OP_DECLARE_TEMP_VAR, Self); + RC.Arg1 := GetSymbolRec(Records[N].Res).Level; + RC.Arg2 := Records[N].Res; + RC.Res := 0; + Insert(N, RC); + Inc(N); + end + else if GetSymbolRec(Records[N].Arg1).FinalTypeId > typeVOID then + begin // this is a function + Records[N].Res := NewTempVar(GetLevel(N), GetSymbolRec(Records[N].Arg1) + .FinalTypeId); + end; + end; + + if Id_VMT > 0 then + Records[N].Arg1 := Id_VMT; + end; +end; + +procedure TCode.OperTerminal; +var + TypeId: Integer; +begin + TypeId := GetSymbolRec(Records[N].Arg1).TypeId; + TypeId := GetSymbolRec(TypeId).PatternId; + GetSymbolRec(Records[N].Res).TypeId := TypeId; + GetSymbolRec(Records[N].Res).ByRef := true; +end; + +procedure TCode.OperAddMethodIndex; +var + R: TCodeRec; + SymbolTable: TSymbolTable; + I, SubId, IntfType: Integer; +begin + R := Records[N]; + R.Op := OP_NOP; + SymbolTable := TKernel(kernel).SymbolTable; + SubId := R.Arg1; + IntfType := SymbolTable[SubId].Level; + I := SymbolTable.RestorePositiveIndex(IntfType); + I := I + Abs(R.Arg2); + SymbolTable[SubId].MethodIndex := I; + SymbolTable[SubId].NegativeMethodIndex := -R.Arg2; +end; + +procedure TCode.OperAddMessage; + + function SetIndex(K: Integer): Integer; + var + R: TMessageRec; + V: Variant; + SubId, I, J, Id, Level: Integer; + L: TIntegerList; + SymbolTable: TSymbolTable; + SymbolRec: TSymbolRec; + begin + result := 0; + + SubId := Records[K].Arg1; + if GetSymbolRec(Records[K].Arg2).Kind = KindVAR then + begin + Records[K].Res := CreateConst(typeSTRING, GetSymbolRec(SubId).FullName); + Exit; // later, at run-time + end + else + begin + V := GetSymbolRec(Records[K].Arg2).value; + end; + + try + I := V; + except + RaiseError(errIncompatibleTypesNoArgs, []); + Exit; + end; + + if I = -1000 then // it was not set up yet + begin + SymbolTable := TKernel(kernel).SymbolTable; + Level := GetSymbolRec(SubId).Level; + I := 0; + Id := 0; + + if GetSymbolRec(SubId).CallMode = cmDYNAMIC then + begin + for J := Level + 1 to SubId do + begin + SymbolRec := SymbolTable[J]; + if SymbolRec.CallMode = cmDYNAMIC then + if SymbolRec.Level = Level then + Dec(I); + end; + end; + + if (GetSymbolRec(SubId).Name = '') and + (GetSymbolRec(SubId).Kind = KindCONSTRUCTOR) then + L := SymbolTable.LookupParentConstructors(SubId) + else + L := SymbolTable.LookupParentMethods(SubId, GetUpcase(N)); + + try + for J := 0 to L.Count - 1 do + begin + Id := L[J]; + SymbolRec := GetSymbolRec(Id); + if SymbolRec.CallMode in [cmDYNAMIC, cmOVERRIDE] then + if SymbolRec.DynamicMethodIndex <> 0 then + begin + I := SymbolRec.DynamicMethodIndex; + break; + end; + end; + + if I = 0 then + begin + Records[K].Op := OP_NOP; + Exit; + end; + + if I = -1000 then + begin + for J := 1 to Card do + if Records[J].Op = OP_ADD_MESSAGE then + if Records[J].Arg1 = Id then + begin + I := SetIndex(J); + break; + end; + end; + + finally + FreeAndNil(L); + end; + end; + + GetSymbolRec(SubId).DynamicMethodIndex := I; + R := TKernel(kernel).MessageList.AddRecord; + R.msg_id := I; + R.FullName := GetSymbolRec(SubId).FullName; + Records[K].Op := OP_NOP; + + result := I; + end; + +begin + SetIndex(N); +end; + +procedure TCode.OperCreateMethod; +var + R: TCodeRec; + SymbolTable: TSymbolTable; + TypeId, PatternFieldId, AddressId: Integer; + S: String; + RC: TCodeRec; +begin + R := Records[N]; + + if GetSymbolRec(R.Arg1).Kind <> KindVAR then + begin + CreateError(errIncompatibleTypesNoArgs, []); + Exit; + end; + + SymbolTable := TKernel(kernel).SymbolTable; + TypeId := GetSymbolRec(R.Arg1).TerminalTypeId; + S := GetSymbolRec(R.Arg2).Name; + PatternFieldId := SymbolTable.LookUp(S, TypeId, GetUpcase(N)); + + if PatternFieldId = 0 then + begin + CreateError(errUndeclaredIdentifier, [S]); + Exit; + end; + + if GetSymbolRec(PatternFieldId).Kind <> KindSUB then + begin + CreateError(errIncompatibleTypesNoArgs, []); + Exit; + end; + + AddressId := SymbolTable.AddPointerVar(GetLevel(N)).Id; + + GetSymbolRec(R.Arg2).Kind := KindNONE; + R.Arg2 := AddressId; + + RC := TCodeRec.Create(OP_ADDRESS, Self); + RC.Arg1 := PatternFieldId; + RC.Arg2 := 0; + RC.Res := AddressId; + + Insert(N, RC); + Inc(N); +end; + +procedure TCode.MoveRValue(N_ASS: Integer); +var + I, J: Integer; + L: TCodeRecList; + RI: TCodeRec; +begin + L := TCodeRecList.Create; + try + I := N_ASS - 1; + while Records[I].Op <> OP_LVALUE do + begin + L.Insert(0, Records[I].Clone); + Records[I].Op := OP_NOP; + Dec(I); + end; + + J := N; + + for I := 0 to L.Count - 1 do + begin + RI := TCodeRec(L[I]); + Insert(J, RI); + Inc(J); + end; + + finally + FreeAndNil(L); + end; +end; + +procedure TCode.MoveLValue(N_ASS: Integer); +var + L: TCodeRecList; + I: Integer; + RI: TCodeRec; +begin + L := TCodeRecList.Create; + try + for I := N to N_ASS - 1 do + begin + RI := Records[I]; + if RI.Op = OP_LVALUE then + break; + L.Add(RI.Clone); + RI.Op := OP_NOP; + end; + + for I := L.Count - 1 downto 0 do + begin + RI := TCodeRec(L[I]); + Insert(N_ASS, RI); + end; + + finally + FreeAndNil(L); + end; +end; + +procedure TCode.InsertDeclareTempVar; +var + R, RC: TCodeRec; +begin + R := Records[N]; + if GetSymbolRec(R.Res).Name = '' then + begin + RC := TCodeRec.Create(OP_DECLARE_TEMP_VAR, Self); + RC.Arg1 := GetLevel(N); + RC.Arg2 := R.Res; + RC.Res := 0; + Insert(N, RC); + Inc(N); + end; +end; + +procedure TCode.InsertDeclareTempVar(Id: Integer); +var + RC: TCodeRec; +begin + RC := TCodeRec.Create(OP_DECLARE_TEMP_VAR, Self); + RC.Arg1 := GetLevel(N); + RC.Arg2 := Id; + RC.Res := 0; + Insert(N, RC); + Inc(N); +end; + +function TCode.CallExpected(ResId: Integer): Boolean; +var + I: Integer; +begin + result := false; + for I := N + 1 to Card do + with Records[I] do + begin + if Op = OP_STMT then + break; + if (Op = OP_CALL) and (Arg1 = ResId) then + begin + result := true; + Exit; + end; + end; +end; + +function TCode.InheritedExpected(ResId: Integer): Boolean; +var + I: Integer; +begin + result := false; + for I := N + 1 to Card do + with Records[I] do + begin + if Op = OP_STMT then + break; + + if (Op = OP_EVAL_INHERITED) and (Arg1 = ResId) then + begin + result := true; + Exit; + end; + end; +end; + +procedure TCode.OperVCall; +var + VarArgIds: TIntegerList; + Id_Object, Id_Prop, SubId, ResId, I, DynArrayId, ParamId, Cnt: Integer; + RC: TCodeRec; + S: String; +begin + Id_Object := 0; + Id_Prop := 0; + SubId := Records[N].Arg1; + ResId := Records[N].Res; + Cnt := Records[N].Arg2; + if ResId = 0 then + ResId := NewTempVar(GetLevel(N), typeVARIANT) + else + GetSymbolRec(ResId).TypeId := typeVARIANT; + VarArgIds := TIntegerList.Create; + + I := N; + repeat + Dec(I); + if Records[I].Op = OP_BEGIN_VCALL then + if Records[I].Res = SubId then + begin + S := GetSymbolRec(Records[I].Arg1).Name; + Id_Object := CreateConst(typeSTRING, S); + + S := GetSymbolRec(Records[I].Arg2).Name; + Id_Prop := CreateConst(typeSTRING, S); + + Records[I].Op := OP_NOP; + Records[I].GenOp := OP_NOP; + + Records[N].Op := OP_NOP; + Records[N].GenOp := OP_NOP; + + break; + end; + + if Records[I].Op = OP_PUSH then + if Records[I].Res = SubId then + begin + VarArgIds.Insert(0, Records[I].Arg1); + + Records[I].Op := OP_NOP; + Records[I].GenOp := OP_NOP; + end; + until false; + + if Cnt = VarArgIds.Count then + SubId := Id_CallVirt + else + begin + SubId := Id_PutVirt; + ResId := VarArgIds.Top; + VarArgIds.RemoveAt(VarArgIds.Count - 1); + end; + + Inc(N); + + try + DynArrayId := NewTempVar(GetLevel(N), H_DYN_VAR); + + RC := TCodeRec.Create(OP_DECLARE_TEMP_VAR, Self); + RC.Arg1 := GetLevel(N); + RC.Arg2 := DynArrayId; + RC.Res := 0; + Insert(N, RC); + Inc(N); + + RC := TCodeRec.Create(OP_SET_LENGTH, Self); + RC.Arg1 := DynArrayId; + RC.Arg2 := CreateConst(typeINTEGER, VarArgIds.Count); + RC.Res := 0; + Insert(N, RC); + Inc(N); + + for I := 0 to VarArgIds.Count - 1 do + begin + RC := TCodeRec.Create(OP_ELEM, Self); + RC.Arg1 := DynArrayId; + RC.Arg2 := CreateConst(typeINTEGER, I); + ParamId := NewTempVar(GetLevel(N), typeVARIANT); + RC.Res := ParamId; + + Insert(N, RC); + Inc(N); + + RC := TCodeRec.Create(OP_ASSIGN, Self); + RC.Arg1 := ParamId; + RC.Arg2 := VarArgIds[I]; + RC.Res := ParamId; + + Insert(N, RC); + Inc(N); + end; + + RC := TCodeRec.Create(OP_PUSH, Self); + RC.Arg1 := Id_Object; + RC.Arg2 := 0; + RC.Res := SubId; + Insert(N, RC); + Inc(N); + + RC := TCodeRec.Create(OP_PUSH, Self); + RC.Arg1 := Id_Prop; + RC.Arg2 := 1; + RC.Res := SubId; + Insert(N, RC); + Inc(N); + + RC := TCodeRec.Create(OP_PUSH, Self); + RC.Arg1 := DynArrayId; + RC.Arg2 := 2; + RC.Res := SubId; + Insert(N, RC); + Inc(N); + + RC := TCodeRec.Create(OP_PUSH, Self); + RC.Arg1 := ResId; + RC.Arg2 := 3; + RC.Res := SubId; + Insert(N, RC); + Inc(N); + + RC := TCodeRec.Create(OP_CALL, Self); + RC.Arg1 := SubId; + RC.Arg2 := 4; + RC.Res := SubId; + Insert(N, RC); + Inc(N); + + Dec(N, 8 + VarArgIds.Count * 2); + + finally + FreeAndNil(VarArgIds); + end; +end; + +procedure TCode.OperField; + +var + R: TCodeRec; + SymbolTable: TSymbolTable; + OldArg1: Integer; + + procedure CheckVis(PatternFieldId: Integer); + + function IsExtraByteCode: Boolean; + var + I, Op: Integer; + begin + result := false; + for I := N downto 1 do + begin + Op := Records[I].Op; + if Op = OP_EXTRA_BYTECODE then + begin + result := true; + Exit; + end; + end; + end; + + var + Id, I1, I2, L, ClassId: Integer; + Vis: TClassVisibility; + OwnerTypeId, PatternTypeId, Lang, K: Integer; + begin + Vis := GetSymbolRec(PatternFieldId).Vis; + if Vis in [cvPrivate, cvStrictPrivate] then + used_private_members.Add(PatternFieldId); + + Id := OldArg1; + + if GetSymbolRec(Id).Name = '' then + Exit; + + I1 := TKernel(kernel).Modules.IndexOfModuleById(Id); + I2 := TKernel(kernel).Modules.IndexOfModuleById(PatternFieldId); + + Lang := GetLanguage(N); + + if I1 = I2 then // the same module + begin + if Lang = PASCAL_LANGUAGE then + begin + if Vis = cvStrictPrivate then + begin + PatternTypeId := GetSymbolRec(PatternFieldId).Level; + case GetSymbolRec(PatternTypeId).FinalTypeId of + typeCLASS: + OwnerTypeId := GetClassId(N); + typeRECORD: + OwnerTypeId := GetStructureId(N); + else + Exit; + end; + + if PatternTypeId <> OwnerTypeId then + CreateError(errProtectionLevel, + [GetSymbolRec(PatternFieldId).Name]); + end; + if I1 <= 0 then + Exit; + K := GetSymbolRec(Id).Kind; + if K <> KindTYPE then + Exit; + end; + end; + + if Vis = cvPrivate then + begin + if Lang in [BASIC_LANGUAGE, JAVA_LANGUAGE] then + begin + PatternTypeId := GetSymbolRec(PatternFieldId).Level; + case GetSymbolRec(PatternTypeId).FinalTypeId of + typeCLASS: + OwnerTypeId := GetClassId(N); + typeRECORD: + OwnerTypeId := GetStructureId(N); + else + Exit; + end; + + if PatternTypeId <> OwnerTypeId then + CreateError(errProtectionLevel, [GetSymbolRec(PatternFieldId).Name]); + end + else + begin + if not IsExtraByteCode then + CreateError(errProtectionLevel, [GetSymbolRec(PatternFieldId).Name]); + end; + end + else if Vis in [cvProtected, cvStrictProtected] then + begin + if Vis = cvStrictProtected then + begin + PatternTypeId := GetSymbolRec(PatternFieldId).Level; + case GetSymbolRec(PatternTypeId).FinalTypeId of + typeCLASS: + OwnerTypeId := GetClassId(N); + typeRECORD: + OwnerTypeId := GetStructureId(N); + else + Exit; + end; + + if PatternTypeId <> OwnerTypeId then + CreateError(errProtectionLevel, [GetSymbolRec(PatternFieldId).Name]); + end; + + L := GetSymbolRec(R.Arg1).TerminalTypeId; + if I1 = TKernel(kernel).Modules.IndexOfModuleById(L) then + Exit; + + Id := GetLevel(N); + + if Id = 0 then + if not IsExtraByteCode then + begin + CreateError(errProtectionLevel, [GetSymbolRec(PatternFieldId).Name]); + Exit; + end; + + L := GetSymbolRec(Id).Level; + + if L = 0 then + if not IsExtraByteCode then + begin + CreateError(errProtectionLevel, [GetSymbolRec(PatternFieldId).Name]); + Exit; + end; + + while GetSymbolRec(L).Kind in kindSUBS do + begin + L := GetSymbolRec(L).Level; + if L = 0 then + RaiseError(errProtectionLevel, [GetSymbolRec(PatternFieldId).Name]); + end; + + if GetSymbolRec(L).Kind <> KindTYPE then + if not IsExtraByteCode then + begin + CreateError(errProtectionLevel, [GetSymbolRec(PatternFieldId).Name]); + Exit; + end; + + if GetSymbolRec(L).FinalTypeId = typeCLASS then + begin + ClassId := GetSymbolRec(PatternFieldId).Level; + if not SymbolTable.Inherits(L, ClassId) then + begin + CreateError(errProtectionLevel, [GetSymbolRec(PatternFieldId).Name]); + end; + end + else + begin + if not IsExtraByteCode then + CreateError(errProtectionLevel, [GetSymbolRec(PatternFieldId).Name]); + end; + end; + end; + + procedure InsertCall; + var + SubId: Integer; + RC: TCodeRec; + begin + SubId := R.Res; + + RC := TCodeRec.Create(OP_CALL, Self); + RC.Arg1 := SubId; + RC.Arg2 := 0; + if GetSymbolRec(SubId).TypeId = typeVOID then + RC.Res := 0 + else + RC.Res := NewTempVar(GetLevel(N), GetSymbolRec(SubId).TypeId); + + Insert(N + 1, RC); + ReplaceIdEx(SubId, RC.Res, N + 2, GetNextStmt(N + 2), true); + end; + + procedure InsertCallEx(I, NParams: Integer); + var + SubId: Integer; + RC: TCodeRec; + begin + SubId := R.Res; + + RC := TCodeRec.Create(OP_CALL, Self); + RC.Arg1 := SubId; + RC.Arg2 := NParams; + if GetSymbolRec(SubId).TypeId = typeVOID then + RC.Res := 0 + else + RC.Res := NewTempVar(GetLevel(N), GetSymbolRec(SubId).TypeId); + + Insert(I + 1, RC); + ReplaceIdEx(SubId, RC.Res, I + 2, Card, true); + end; + + function ReplaceOP_ELEM(SubId: Integer; var K: Integer; + var OldRes: Integer): Integer; + var + I, IndexId, ParCount: Integer; + R: TCodeRec; + begin + result := N; + K := -1; + OldRes := SubId; + + ParCount := GetSymbolRec(SubId).Count; + + for I := N + 1 to Card do + begin + R := Records[I]; + + if R.Op = OP_STMT then + break; + + if (R.Op = OP_ELEM) and (R.Arg1 = OldRes) then + begin + result := I; + OldRes := R.Res; + IndexId := R.Arg2; + Inc(K); + + GetSymbolRec(OldRes).Kind := 0; + + R.GenOp := OP_PUSH; + R.Op := OP_PUSH; + R.Arg1 := IndexId; + R.Arg2 := K; + R.Res := SubId; + + if ParCount - 1 = K then + break; + end; + end; + end; + + function InsertCreateEvent(PatternFieldId: Integer): Boolean; + var + J, J1, N1, ParamId: Integer; + S1, S2: String; + begin + result := false; + + N1 := N + 1; + + J := N; + repeat + Inc(J); + if J > Card then + break; + + if Records[J].Op = OP_STMT then + break; + + if Records[J].Op = OP_ASSIGN then + begin + N1 := J; + break; + end; + until false; + + if Records[N1].Op = OP_ASSIGN then + begin + if Records[N1].Arg2 = Records[N].Res then + if GetSymbolRec(Records[N1].Arg1).FinalTypeId = typeEVENT then + begin + S1 := GetSymbolRec(PatternFieldId).SignatureSimple; + J1 := GetSymbolRec(Records[N1].Arg1).TerminalTypeId; + J1 := GetSymbolRec(J1).PatternId; + S2 := GetSymbolRec(J1).SignatureSimple; + + if not StrEql(S1, S2) then + CreateError(errIncompatibleTypesNoArgs, []); + + Records[N].Op := OP_CREATE_EVENT; + R.Arg2 := PatternFieldId; + GetSymbolRec(R.Res).OwnerId := 0; + GetSymbolRec(R.Res).TypeId := GetSymbolRec(Records[N1].Arg1).TypeId; + GetSymbolRec(R.Res).Name := ''; + + result := true; + + Exit; + end; + end; + J := N; + repeat + Inc(J); + if J > Card then + break; + + if Records[J].Op = OP_STMT then + break; + + if Records[J].Op = OP_PUSH then + if Records[J].Arg1 = Records[N].Res then + if GetSymbolRec(Records[J].Res).Kind in kindSUBS then + begin + if SymbolTable[Records[J].Res].Count = 0 then + break; + + ParamId := SymbolTable.GetParamId(Records[J].Res, Records[J].Arg2); + if GetSymbolRec(ParamId).FinalTypeId = typeEVENT then + begin + S1 := GetSymbolRec(PatternFieldId).SignatureSimple; + J1 := GetSymbolRec(ParamId).TerminalTypeId; + J1 := GetSymbolRec(J1).PatternId; + S2 := GetSymbolRec(J1).SignatureSimple; + + if not StrEql(S1, S2) then + CreateError(errIncompatibleTypesNoArgs, []); + + Records[N].Op := OP_CREATE_EVENT; + R.Arg2 := PatternFieldId; + GetSymbolRec(R.Res).OwnerId := 0; + GetSymbolRec(R.Res).TypeId := GetSymbolRec(ParamId).TypeId; + GetSymbolRec(R.Res).Name := ''; + + result := true; + + Exit; + end; + + break; + end; + until false; + end; + + procedure ProcessVOBJECT(ResId: Integer); + var + I, J, Res, K, IndexId: Integer; + RC: TCodeRec; + has_assign: Boolean; + begin + K := 0; + if CallExpected(ResId) then + begin + Records[N].Op := OP_BEGIN_VCALL; + Records[N].GenOp := OP_BEGIN_VCALL; + for I := N + 1 to Card do + begin + if Records[I].Op = OP_STMT then + break; + + if Records[I].Op = OP_PUSH then + if Records[I].Res = ResId then + begin + Inc(K); + end; + + if Records[I].Op = OP_CALL then + if Records[I].Arg1 = ResId then + begin + if GetLanguage(N) = BASIC_LANGUAGE then + begin + if Records[I + 1].Op = OP_LVALUE then + begin + Res := Records[I].Res; + for J := I + 1 to Card do + begin + if Records[J].Op = OP_ASSIGN then + if Records[J].Arg1 = Res then + begin + Records[I].Op := OP_NOP; + Records[I].GenOp := OP_NOP; + + IndexId := Records[J].Arg2; + + Records[J].Op := OP_PUSH; + Records[J].GenOp := OP_PUSH; + Records[J].Arg1 := IndexId; + Records[J].Arg2 := K; + Records[J].Res := ResId; + + RC := TCodeRec.Create(OP_VCALL, Self); + RC.Arg1 := ResId; + RC.Arg2 := K; + RC.Res := 0; + Insert(J + 1, RC); + Exit; + end; + end; + end; + end; + + Records[I].Op := OP_VCALL; + Records[I].GenOp := OP_VCALL; + Records[I].Arg2 := K; + break; + end; + end; + end + else + begin + has_assign := false; + Records[N].Op := OP_BEGIN_VCALL; + Records[N].GenOp := OP_BEGIN_VCALL; + Res := ResId; + for I := N + 1 to Card do + begin + if Records[I].Op = OP_STMT then + break; + + if Records[I].Op = OP_ELEM then + if Records[I].Arg1 = Res then + begin + IndexId := Records[I].Arg2; + + Records[I].Op := OP_PUSH; + Records[I].GenOp := OP_PUSH; + Records[I].Arg1 := IndexId; + Records[I].Arg2 := K; + Res := Records[I].Res; + Records[I].Res := ResId; + Inc(K); + end; + if Records[I].Op = OP_ASSIGN then + if Records[I].Arg1 = Res then + begin + has_assign := true; + + IndexId := Records[I].Arg2; + + Records[I].Op := OP_PUSH; + Records[I].GenOp := OP_PUSH; + Records[I].Arg1 := IndexId; + Records[I].Arg2 := K; + Records[I].Res := ResId; + + RC := TCodeRec.Create(OP_VCALL, Self); + RC.Arg1 := ResId; + RC.Arg2 := K; + RC.Res := 0; + Insert(I + 1, RC); + break; + end; + end; + if not has_assign then + begin + RC := TCodeRec.Create(OP_VCALL, Self); + RC.Arg1 := ResId; + RC.Arg2 := 0; + RC.Res := ResId; + Insert(N + 1, RC); + end; + end; + end; + +var + Arg1, Arg2, T1, T2, K1: Integer; + PatternFieldId: Integer; + FinalOwnerId: Integer; + Level: Integer; + S: String; + I, J, K, RValueId, OldRes: Integer; + ok: Boolean; + RC: TCodeRec; + Id: Integer; + Final_T1: Integer; + NP: Integer; + PropNameId: Integer; + ValId, ResId: Integer; + IsCallExpected, IsAssignmentExpected: Boolean; + IsInheritedExpected: Boolean; + J1, J2, J3, tempN: Integer; + KK: Integer; + ParamId: Integer; + TerminalTypeArg2, PatternArg2, RV_Count: Integer; + IsDRTTI: Boolean; + HelperTypeId: Integer; +label + labelPROP; +begin + HelperTypeId := 0; + SymbolTable := TKernel(kernel).SymbolTable; + + R := Records[N]; + + Arg1 := R.Arg1; + Arg2 := R.Arg2; + ResId := R.Res; + T1 := GetSymbolRec(Arg1).TerminalTypeId; + K1 := GetSymbolRec(Arg1).Kind; + + OldArg1 := Arg1; + + if K1 = KindSUB then + begin + if GetSymbolRec(Arg1).Count = 0 then + begin + RC := TCodeRec.Create(OP_CALL, Self); + RC.Arg1 := Arg1; + RC.Arg2 := 0; + RC.Res := NewTempVar(GetSymbolRec(ResId).Level, + GetSymbolRec(Arg1).TypeId); + Insert(N, RC); + + R.Arg1 := RC.Res; + + Dec(N); + end + else + CreateError(errRecordRequired, []); + + Exit; + end + else if K1 in [KindVAR, KindCONST] then + begin + if K1 = KindCONST then + GetSymbolRec(Arg1).MustBeAllocated := true; + + Final_T1 := GetSymbolRec(Arg1).FinalTypeId; + + if Final_T1 = typeVOBJECT then + begin + ProcessVOBJECT(ResId); + Exit; + end; + + if Final_T1 in VariantTypes then + begin + if TKernel(kernel).IsFramework then + begin + S := GetSymbolRec(Arg2).Name; + PatternFieldId := SymbolTable.LookUp(S, H_TFW_Variant, GetUpcase(N)); + if (PatternFieldId > 0) or (S = DummyName) then + begin + RC := TCodeRec.Create(OP_TO_FW_OBJECT, Self); + RC.Arg1 := R.Arg1; + RC.Arg2 := GetSymbolRec(Arg1).TerminalTypeId; + RC.Res := NewTempVar(GetLevel(N), typeVARIANT); + Insert(N, RC); + + Dec(N); + + R.Arg1 := RC.Res; + + Exit; + end; + end; + + GetSymbolRec(R.Res).TypeId := Final_T1; + GetSymbolRec(R.Res).OwnerId := 0; + + S := GetSymbolRec(Arg2).Name; + PropNameId := CreateConst(typeSTRING, S); + + NP := 0; + J := -1; + K := -1; + ValId := 0; + ResId := R.Res; + + for I := N + 1 to Card do + begin + if Records[I].Op = OP_STMT then + break; + + if Records[I].Op = OP_ELEM then + begin + if Records[I].Arg1 = ResId then + begin + K := I; + + Inc(NP); + ResId := Records[I].Res; + + GetSymbolRec(ResId).Kind := KindNONE; + GetSymbolRec(ResId).OwnerId := 0; + + Records[I].Op := OP_OLE_PARAM; + Records[I].Arg1 := Records[I].Arg2; + Records[I].Arg2 := 0; + Records[I].Res := PropNameId; + end; + end + else if Records[I].Op = OP_CALL then + begin + if (Records[I].Arg1 = ResId) and (Records[I].Arg2 > 0) then + begin + for J1 := 1 to I - 1 do + begin + if (Records[J1].Op = OP_PUSH) and + (Records[J1].Res = Records[I].Arg1) then + begin + K := J1; + Inc(NP); + Records[J1].Op := OP_OLE_PARAM; + Records[J1].Arg2 := 0; + Records[J1].Res := PropNameId; + end; + end; + + ResId := Records[I].Res; + + GetSymbolRec(ResId).Kind := KindNONE; + GetSymbolRec(ResId).OwnerId := 0; + Records[I].Op := OP_NOP; + end; + end; + + if Records[I].Op = OP_ASSIGN then + if Records[I].Arg1 = ResId then + begin + J := I; + ValId := Records[I].Arg2; + Records[I].Op := OP_OLE_VALUE; + Records[I].Arg1 := ValId; + Records[I].Arg2 := 0; + Records[I].Res := PropNameId; + break; + end; + end; + + if J <= 0 then // read prop + begin + if NP = 0 then + begin + R.Op := OP_OLE_GET; + R.Arg2 := PropNameId; + end + else + begin + RC := TCodeRec.Create(OP_OLE_GET, Self); + RC.Arg1 := R.Arg1; + RC.Arg2 := PropNameId; + RC.Res := R.Res; + + Insert(K + 1, RC); + R.Op := OP_NOP; + + for I := K + 1 to Card do + begin + if Records[I].Op = OP_STMT then + break; + + if Records[I].Arg1 = ResId then + begin + Records[I].Arg1 := R.Res; + break; + end + else if Records[I].Arg2 = ResId then + begin + Records[I].Arg2 := R.Res; + break; + end; + end; + end; + end + else // write prop + begin + RemoveDeclaredVar(Arg2); + + RC := TCodeRec.Create(OP_OLE_SET, Self); + RC.Arg1 := R.Arg1; + RC.Arg2 := PropNameId; + RC.Res := ValId; + + Insert(J + 1, RC); + R.Op := OP_NOP; + end; + + Exit; + end; + + if not(Final_T1 in [typeRECORD, typeCLASS, typeCLASSREF, typeINTERFACE]) + then + begin + S := GetSymbolRec(Arg2).Name; + SymbolTable.LookUpEx(HelperTypeId, S, T1, GetUpcase(N)); + if HelperTypeId > 0 then + Final_T1 := typeRECORD; + end; + + if not(Final_T1 in [typeRECORD, typeCLASS, typeCLASSREF, typeINTERFACE]) + then + begin + if Records[N].Language = JS_LANGUAGE then + begin + RC := TCodeRec.Create(OP_TO_JS_OBJECT, Self); + RC.Arg1 := R.Arg1; + RC.Arg2 := GetSymbolRec(Arg1).TerminalTypeId; + RC.Res := NewTempVar(GetLevel(N), typeVARIANT); + Insert(N, RC); + + R.Arg1 := RC.Res; + + Exit; + end + else + begin + if Final_T1 = typePOINTER then +{$IFNDEF PAXARM} + if not GetSymbolRec(Arg1).HasPAnsiCharType then +{$ENDIF} + if not GetSymbolRec(Arg1).HasPWideCharType then + begin + T1 := GetSymbolRec(Arg1).TerminalTypeId; + T1 := GetSymbolRec(T1).PatternId; + + RC := TCodeRec.Create(OP_TERMINAL, Self); + RC.Arg1 := R.Arg1; + RC.Arg2 := 0; + RC.Res := NewTempVar(GetLevel(N), T1); + Insert(N, RC); + R.Arg1 := RC.Res; + GetSymbolRec(R.Res).OwnerId := RC.Res; + + Dec(N); + + Exit; + end; + + dmp; + + RC := TCodeRec.Create(OP_TO_FW_OBJECT, Self); + RC.Arg1 := R.Arg1; + RC.Arg2 := GetSymbolRec(Arg1).TerminalTypeId; + RC.Res := NewTempVar(GetLevel(N), typeVARIANT); + Insert(N, RC); + + Dec(N); + + R.Arg1 := RC.Res; + + Exit; + end; + + CreateError(errRecordRequired, []); + Exit; + end; + + if Final_T1 = typeCLASSREF then + T1 := GetSymbolRec(T1).PatternId; + + S := GetSymbolRec(Arg2).Name; + if Records[N].PatternFieldId <> 0 then + PatternFieldId := Records[N].PatternFieldId + else + PatternFieldId := SymbolTable.LookUpEx(HelperTypeId, S, T1, GetUpcase(N), + MaxInt, not IsFrameworkTypeId(T1)); + if PatternFieldId = 0 then + begin + if GetSymbolRec(T1).IsJavaScriptClass then + begin + R.Op := OP_ELEM; + Arg2 := R.Arg2; + R.Arg2 := CreateConst(typeSTRING, GetSymbolRec(R.Arg2).Name); + R.Res := NewTempVar(GetSymbolRec(R.Arg1).Level, typeVARIANT); + ReplaceIdEx(Arg2, R.Res, N + 1, Card, true); + + Dec(N); + GetSymbolRec(Arg2).Kind := KindNONE; + + Exit; + end; + + if Records[N].Language = JS_LANGUAGE then + if S = StrProgram then + begin + // OP_FIELD (PROG) + // OP_ASSIGN_PROG + + GetSymbolRec(R.Res).Kind := KindNONE; + GetSymbolRec(R.Arg2).Kind := KindNONE; + Records[N].Op := OP_NOP; + Records[N + 1].Op := OP_NOP; + + // OP_FIELD (CONSTRUCTOR) + // OP_ASSIGN + + GetSymbolRec(Records[N + 2].Res).Kind := KindNONE; + GetSymbolRec(Records[N + 2].Arg2).Kind := KindNONE; + Records[N + 2].Op := OP_NOP; + Records[N + 3].Op := OP_NOP; + + Exit; + end; + + CreateError(errUndeclaredIdentifier, [S]); + Exit; + end; + + CheckVis(PatternFieldId); + + if GetSymbolRec(PatternFieldId).Kind = KindCONST then + begin + Records[N].Op := OP_NOP; + Records[N].GenOp := OP_NOP; + ReplaceId(Records[N].Res, PatternFieldId); + Exit; + end; + + GetSymbolRec(Arg2).TypeId := GetSymbolRec(PatternFieldId).TypeId; + GetSymbolRec(Arg2).PatternId := PatternFieldId; + + if Final_T1 = typeCLASSREF then + begin + case GetSymbolRec(PatternFieldId).Kind of + KindCONSTRUCTOR: + begin + IsCallExpected := CallExpected(ResId); + + GetSymbolRec(Arg2).Name := ''; + GetSymbolRec(Arg2).Kind := 0; + + ReplaceId(Arg2, PatternFieldId); + R.Op := OP_PUSH_CLASSREF; + + if not IsCallExpected then + InsertCall; + end; + KindPROP: + begin + goto labelPROP; + end; + KindSUB: + begin + if not GetSymbolRec(PatternFieldId).IsSharedMethod then + if not StrEql('ClassName', GetSymbolRec(PatternFieldId).Name) then + CreateError + (errThisFormOfMethodCanOnlyAllowedForClassMethod, []); + + IsCallExpected := CallExpected(ResId); + + GetSymbolRec(Arg2).Name := ''; + GetSymbolRec(Arg2).Kind := 0; + + ReplaceId(Arg2, PatternFieldId); + R.Op := OP_PUSH_CLASSREF; + + if not IsCallExpected then + begin + if Self[N + 1].Op = OP_EVAL_INHERITED then + if R.Res = Self[N + 1].Arg1 then + Exit; + + InsertCall; + end; + + if not GetSymbolRec(Self[N].Arg1).Host then + if StrEql(GetSymbolRec(Self[N + 1].Arg1).Name, 'ClassName') then + begin + Self[N].Op := OP_NOP; + Self[N + 1].Op := OP_CLASSNAME; + Self[N + 1].Arg1 := Self[N].Arg1; + end; + + end; + end; + Exit; + end + else if (Final_T1 in [typeCLASS, typeINTERFACE]) or + ((Final_T1 = typeRECORD) and (GetSymbolRec(PatternFieldId).Kind + in [KindSUB, KindPROP])) then + begin + case GetSymbolRec(PatternFieldId).Kind of + KindCONSTRUCTOR: + begin + GetSymbolRec(Arg2).Name := ''; + GetSymbolRec(Arg2).Kind := 0; + + ReplaceId(Arg2, PatternFieldId); + R.Op := OP_PUSH_CLASSREF; + R.Arg2 := 0; + end; + KindSUB: + begin + if InsertCreateEvent(PatternFieldId) then + Exit; + + GetSymbolRec(Arg2).Name := ''; + GetSymbolRec(Arg2).Kind := 0; + + IsCallExpected := CallExpected(ResId); + + ReplaceIdEx(Arg2, PatternFieldId, N, GetNextStmt(N), true); + R.Op := OP_PUSH_INSTANCE; + R.Arg2 := 0; + + if not IsCallExpected then + begin + if Self[N + 1].Op = OP_EVAL_INHERITED then + if R.Res = Self[N + 1].Arg1 then + Exit; + + InsertCall; + end; + end; + KindDESTRUCTOR: + begin + tempN := N; + + GetSymbolRec(Arg2).Name := ''; + GetSymbolRec(Arg2).Kind := 0; + + IsCallExpected := CallExpected(ResId); + IsInheritedExpected := InheritedExpected(ResId); + + ReplaceId(Arg2, PatternFieldId); + R.Op := OP_PUSH_INSTANCE; + R.Arg2 := 0; + + if not(IsCallExpected or IsInheritedExpected) then + InsertCall; + + if IsInheritedExpected then + Exit; + + Exit; + + RC := TCodeRec.Create(OP_DESTROY_OBJECT, Self); + RC.Arg1 := R.Arg1; + RC.Arg2 := 0; + RC.Res := 0; + + while (Records[N].Op <> OP_CALL) do + Inc(N); + + Insert(N + 1, RC); + N := tempN; + end; + KindTYPE_FIELD: + begin + if GetSymbolRec(PatternFieldId).CompIndex >= 0 then + begin + R.Op := OP_GET_COMPONENT; + R.Arg2 := GetSymbolRec(PatternFieldId).CompIndex; + GetSymbolRec(R.Res).Kind := KindVAR; + GetSymbolRec(R.Res).PatternId := 0; + GetSymbolRec(R.Res).OwnerId := 0; + end + else + GetSymbolRec(Arg2).ByRef := true; + end; + KindPROP: + begin + labelPROP: + if (GetSymbolRec(PatternFieldId).IsPublished or + GetSymbolRec(PatternFieldId).IsDRTTI) and + GetSymbolRec(PatternFieldId).Host then + + begin + IsDRTTI := GetSymbolRec(PatternFieldId).IsDRTTI; + + T2 := GetSymbolRec(PatternFieldId).Level; + + if Assigned(ForbiddenPropList) then + if GetSymbolRec(T2).PClass <> nil then + if ForbiddenPropList.IsForbidden(GetSymbolRec(T2).PClass, + GetSymbolRec(PatternFieldId).Name) then + begin + CreateError(errPropertyIsForbidden, + [GetSymbolRec(PatternFieldId).Name, + GetSymbolRec(T2).Name]); + end; + + T2 := GetSymbolRec(PatternFieldId).FinalTypeId; + R.Arg2 := PatternFieldId; + GetSymbolRec(R.Res).OwnerId := 0; + + RV_Count := -1; + + for I := N to Card do + begin + if Records[I].Op = OP_STMT then + break; + + if Records[I].Op = OP_LVALUE then + RV_Count := 0 + else if RV_Count >= 0 then + begin + if (Records[I].Op <> OP_SEPARATOR) and + (Records[I].Op <> OP_NOP) then + Inc(RV_Count); + end; + + if Records[I].Arg1 = R.Res then + if Records[I].Op = OP_ASSIGN then + begin + // process put property + + RValueId := Records[I].Arg2; + + if GetSymbolRec(RValueId).Name = DummyName then + begin + CreateError(errCanceled, []); + Exit; + end; + + if (GetSymbolRec(RValueId).TypeId = 0) or + (Records[I - 1].Op = OP_ADDRESS) or + (Records[I - 1].Op = OP_CALL) then + begin + if Records[I - 1].Op = OP_ADDRESS then + begin + if RV_Count > 1 then + begin + MoveLValue(I); + Exit; + end; + end; + + if T2 = typeEVENT then + GetSymbolRec(RValueId).TypeId := T2 + else + begin + if RV_Count > 1 then + begin + MoveLValue(I); + Exit; + end; + end; + end + else if (RV_Count > 1) and (T2 <> typeEVENT) then + begin + MoveRValue(I); + Dec(N); + Exit; + end; + + R.Res := RValueId; + + Records[I].Arg1 := R.Arg1; + Records[I].Arg2 := R.Arg2; + Records[I].Res := R.Res; + + R.Op := OP_NOP; + + R := Records[I]; + + if IsDRTTI then + begin + RC := TCodeRec.Create(OP_ASSIGN, Self); + RC.Arg1 := NewTempVar(GetLevel(N), H_TValue); + RC.Arg2 := R.Res; + RC.Res := RC.Arg1; + Insert(I, RC); + + R.Res := RC.Res; + + R.Op := OP_SET_DRTTI_PROP; + + N := I - 1; + Exit; + end + else + case T2 of +{$IFNDEF PAXARM} + typeANSISTRING, typeSHORTSTRING: + begin + if GetSymbolRec(R.Res).Kind = KindCONST then + begin + if GetSymbolRec(R.Res).FinalTypeId in CharTypes + then + begin + S := Chr(Integer(GetSymbolRec(R.Res).value)); + R.Res := SymbolTable.AddPAnsiCharConst + (AnsiString(S)).Id; + end + else if GetSymbolRec(R.Res).FinalTypeId <> typeANSISTRING + then + begin + RC := InsertConversionToAnsiString(I, 3); + R.Res := RC.Res; + Inc(N); + end; + end + else if GetSymbolRec(R.Res).FinalTypeId <> typeANSISTRING + then + begin + RC := InsertConversionToAnsiString(I, 3); + R.Res := RC.Res; + Inc(N); + end; + R.Op := OP_SET_ANSISTR_PROP; + end; + typeWIDESTRING: + begin + if GetSymbolRec(R.Res).FinalTypeId <> typeWIDESTRING + then + begin + RC := InsertConversionToWideString(I, 3); + R.Res := RC.Res; + Inc(N); + end; + R.Op := OP_SET_WIDESTR_PROP; + end; +{$ENDIF} + typeUNICSTRING: + begin + if GetSymbolRec(R.Res).FinalTypeId <> typeUNICSTRING + then + begin + RC := InsertConversionToUnicString(I, 3); + R.Res := RC.Res; + Inc(N); + end; + R.Op := OP_SET_UNICSTR_PROP; + end; + typeINTEGER, typeBYTE, typeWORD, typeCARDINAL, + typeSMALLINT, typeSHORTINT: + begin + if not(GetSymbolRec(R.Res).FinalTypeId + in IntegerTypes) then + begin + RC := InsertConversionToInteger(I, 3); + R.Res := RC.Res; + Inc(N); + end; + R.Op := OP_SET_ORD_PROP; + end; + typeINTERFACE: + begin + if GetSymbolRec(R.Res).FinalTypeId <> typeINTERFACE + then + CreateError(errIncompatibleTypesNoArgs, []); + R.Op := OP_SET_INTERFACE_PROP; + end; +{$IFNDEF PAXARM} + typeANSICHAR: + begin + if GetSymbolRec(R.Res).FinalTypeId <> typeANSICHAR + then + CreateError(errIncompatibleTypesNoArgs, []); + R.Op := OP_SET_ORD_PROP; + end; +{$ENDIF} + typeWIDECHAR: + begin + if GetSymbolRec(R.Res).FinalTypeId <> typeWIDECHAR + then + CreateError(errIncompatibleTypesNoArgs, []); + R.Op := OP_SET_ORD_PROP; + end; + typeBOOLEAN, typeBYTEBOOL, typeWORDBOOL, typeLONGBOOL: + begin + if GetSymbolRec(R.Res).FinalTypeId <> typeBOOLEAN + then + begin + RC := InsertConversionToBoolean(I, 3); + R.Res := RC.Res; + Inc(N); + end; + R.Op := OP_SET_ORD_PROP; + end; + typeENUM: + begin + if GetSymbolRec(R.Res).FinalTypeId <> typeENUM then + CreateError(errIncompatibleTypesNoArgs, []); + R.Op := OP_SET_ORD_PROP; + end; + typeSET: + begin + if GetSymbolRec(R.Res).FinalTypeId <> typeSET then + begin + ok := false; + for J := N to Card do + begin + if Records[J].Op = OP_STMT then + break; + + with Records[J] do + if (Op = OP_SET_INCLUDE) or + (Op = OP_SET_INCLUDE_INTERVAL) then + if Arg1 = R.Res then + begin + ok := true; + end; + end; + + if ok then + begin + Records[I].Op := OP_SET_SET_PROP; + Records[I].Arg1 := R.Arg1; + Records[I].Arg2 := R.Arg2; + Records[I].Res := R.Res; + + R.Op := OP_NOP; + + Exit; + end; + + CreateError(errIncompatibleTypesNoArgs, []); + end; + R.Op := OP_SET_SET_PROP; + end; + typeCLASS: + begin + if GetSymbolRec(R.Res).FinalTypeId <> typeCLASS then + begin + if R.Res <> SymbolTable.NilId then + CreateError(errIncompatibleTypesNoArgs, []); + R.Op := OP_SET_ORD_PROP; + Exit; + end; + + if not CheckAssignment(PatternFieldId, R.Res) then + CreateError(errIncompatibleTypesNoArgs, []); + + R.Op := OP_SET_ORD_PROP; + end; + typeEXTENDED, typeSINGLE, typeDOUBLE, typeCURRENCY: + begin + if GetSymbolRec(R.Res).FinalTypeId <> typeEXTENDED + then + begin + RC := InsertConversionToExtended(I, 3); + R.Res := RC.Res; + Inc(N); + end; + R.Op := OP_SET_FLOAT_PROP; + end; + typeVARIANT: + begin + if GetSymbolRec(R.Res).FinalTypeId <> typeVARIANT + then + begin + RC := InsertConversionToVariant(I, 3); + R.Res := RC.Res; + Inc(N); + end; + R.Op := OP_SET_VARIANT_PROP; + end; + typeOLEVARIANT: + begin + if GetSymbolRec(R.Res).FinalTypeId <> typeOLEVARIANT + then + begin + RC := InsertConversionToOleVariant(I, 3); + R.Res := RC.Res; + Inc(N); + end; + R.Op := OP_SET_VARIANT_PROP; + end; + typeINT64, typeUINT64: + begin + if not(GetSymbolRec(R.Res).FinalTypeId in INT64Types) + then + begin + RC := InsertConversionToInt64(I, 3); + R.Res := RC.Res; + Inc(N); + end; + R.Op := OP_SET_INT64_PROP; + end; + typeEVENT, typeRECORD: + begin + R.Op := OP_SET_EVENT_PROP; + for J := GetStmt(N) to I do + if Records[J].Op = OP_FIELD then + if Records[J].Res = R.Res then + begin + Records[J].Op := OP_NOP; + T1 := GetSymbolRec(Records[J].Arg1) + .TerminalTypeId; + if T1 = 0 then + begin + RestoreFieldType(J); + T1 := GetSymbolRec(Records[J].Arg1) + .TerminalTypeId; + end; + + break; + end; + + if R.Res = SymbolTable.NilId then + Exit; + + GetSymbolRec(R.Res).Kind := KindNONE; + + S := GetSymbolRec(R.Res).Name; + if S = '' then + RaiseError(errIncompatibleTypesNoArgs, []); + + PatternFieldId := + SymbolTable.LookUp(S, T1, GetUpcase(N)); + if PatternFieldId = 0 then + begin + if GetSymbolRec(R.Res).FinalTypeId = typeEVENT + then + begin + GetSymbolRec(R.Res).Kind := KindVAR; + R.Op := OP_SET_EVENT_PROP2; + Exit; + end; + + // CreateError(errUndeclaredIdentifier, [S]); + Exit; + end; + + GetSymbolRec(R.Res).PatternId := PatternFieldId; + + TerminalTypeArg2 := GetSymbolRec(Arg2) + .TerminalTypeId; + PatternArg2 := GetSymbolRec(TerminalTypeArg2) + .PatternId; + + if (GetSymbolRec(PatternFieldId).Kind + in [KindCONSTRUCTOR, KindDESTRUCTOR]) then + CreateError(errIncompatibleTypesNoArgs, []); + + if (GetSymbolRec(PatternFieldId).Kind = KindSUB) + then + if (GetSymbolRec(PatternArg2).Kind = KindSUB) then + begin + if not SymbolTable.EqualHeaders(PatternFieldId, + PatternArg2) then + CreateError(errIncompatibleTypesNoArgs, []); + end; + end; + else + CreateError(errInternalError, []); + end; + Exit; + end; + end; // for + + InsertDeclareTempVar(R.Res); + + if IsDRTTI then + begin + R.Op := OP_GET_DRTTI_PROP; + if T2 = typeINT64 then + GetSymbolRec(R.Res).TypeId := typeINT64 + else if T2 = typeUINT64 then + GetSymbolRec(R.Res).TypeId := typeUINT64 + else if T2 in IntegerTypes then + GetSymbolRec(R.Res).TypeId := typeINTEGER + else if T2 in StringTypes then + GetSymbolRec(R.Res).TypeId := typeSTRING + else if T2 in RealTypes then + GetSymbolRec(R.Res).TypeId := typeEXTENDED + else if T2 in VariantTypes then + GetSymbolRec(R.Res).TypeId := typeVARIANT + else + begin + GetSymbolRec(R.Res).TypeId := H_TValue; + + Id := NewTempVar(GetLevel(N), GetSymbolRec(PatternFieldId) + .TerminalTypeId); + RC := TCodeRec.Create(OP_VAR_FROM_TVALUE, Self); + RC.Arg1 := Id; + RC.Arg2 := R.Res; + RC.Res := 0; + + Insert(N + 1, RC); + ReplaceIdEx(R.Res, Id, N + 2, Card, false); + + end; + end + else + case T2 of +{$IFNDEF PAXARM} + typeANSISTRING: + R.Op := OP_GET_ANSISTR_PROP; + typeSHORTSTRING: + begin + R.Op := OP_GET_ANSISTR_PROP; + + Id := R.Res; + Level := SymbolTable[Id].Level; + R.Res := CreateStringVar(Level); + + RC := TCodeRec.Create(OP_ASSIGN, Self); + RC.Arg1 := Id; + RC.Arg2 := R.Res; + RC.Res := Id; + + Insert(N + 1, RC); + end; + typeWIDESTRING: + R.Op := OP_GET_WIDESTR_PROP; + typeANSICHAR: + R.Op := OP_GET_ORD_PROP; +{$ENDIF} + typeUNICSTRING: + R.Op := OP_GET_UNICSTR_PROP; + typeINTEGER, typeBYTE, typeWORD, typeCARDINAL, typeSMALLINT, + typeSHORTINT: + R.Op := OP_GET_ORD_PROP; + typeBOOLEAN, typeBYTEBOOL, typeWORDBOOL, typeLONGBOOL: + R.Op := OP_GET_ORD_PROP; + typeENUM: + R.Op := OP_GET_ORD_PROP; + typeSET: + R.Op := OP_GET_SET_PROP; + typeINTERFACE: + R.Op := OP_GET_INTERFACE_PROP; + typeCLASS: + R.Op := OP_GET_ORD_PROP; + typeEXTENDED: + R.Op := OP_GET_FLOAT_PROP; + typeVARIANT: + R.Op := OP_GET_VARIANT_PROP; + typeOLEVARIANT: + R.Op := OP_GET_VARIANT_PROP; + typeINT64, typeUINT64: + R.Op := OP_GET_INT64_PROP; + typeSINGLE, typeDOUBLE, typeCURRENCY: + begin + R.Op := OP_GET_FLOAT_PROP; + + Id := R.Res; + Level := SymbolTable[Id].Level; + R.Res := CreateExtendedVar(Level); + + RC := TCodeRec.Create(OP_ASSIGN, Self); + RC.Arg1 := Id; + RC.Arg2 := R.Res; + RC.Res := Id; + + Insert(N + 1, RC); + end; + typeEVENT: + begin + R.Op := OP_GET_EVENT_PROP; + end; + else + CreateError(errInternalError, []); + end; + end + else // not published property + begin + Id := SymbolTable[PatternFieldId].ReadId; + + if Id > 0 then + begin + I := GetSymbolRec(Id).Level; + if GetSymbolRec(I).FinalTypeId = typeINTERFACE then + if GetSymbolRec(Arg1).FinalTypeId = typeCLASS then + begin + S := GetSymbolRec(Id).Name; + Id := SymbolTable.LookUp(S, + GetSymbolRec(Arg1).TerminalTypeId, GetUpcase(N)); + end; + end; + + if Id <> 0 then + if SymbolTable[Id].Kind = KindSUB then + begin + + IsAssignmentExpected := false; + for I := N to Card do + begin + + if Records[I].Op = OP_STMT then + break; + + if Records[I].Arg1 = R.Res then + if Records[I].Op = OP_ASSIGN then + begin + IsAssignmentExpected := true; + break; + end; + end; + + if SymbolTable[Id].Count = 0 then + begin + + if not IsAssignmentExpected then + begin + J := R.Res; + + if GetSymbolRec(Id).IsSharedMethod then + R.Op := OP_PUSH_CLASSREF + else + R.Op := OP_PUSH_INSTANCE; + + R.Arg1 := R.Arg1; + R.Arg2 := 0; + R.Res := Id; + + RC := TCodeRec.Create(OP_CALL, Self); + RC.Arg1 := Id; + RC.Arg2 := 0; + RC.Res := NewTempVar(GetLevel(N), SymbolTable[Id].TypeId); + + Insert(N + 1, RC); + + ReplaceIdEx(J, RC.Res, N + 1, Card, true); + + SymbolTable[J].Kind := KindNONE; + + Exit; + end; + end + else if (SymbolTable[Id].Count = 1) and // fake method + ((SymbolTable[Id].Level = 0) or + (GetSymbolRec(SymbolTable[Id].Level).Kind = KindNAMESPACE)) + then + begin + + if not IsAssignmentExpected then + begin + J := R.Res; + + R.Op := OP_PUSH; + R.Arg1 := R.Arg1; + R.Arg2 := 0; + R.Res := Id; + + RC := TCodeRec.Create(OP_CALL, Self); + RC.Arg1 := Id; + RC.Arg2 := 0; + RC.Res := NewTempVar(GetLevel(N), SymbolTable[Id].TypeId); + + Insert(N + 1, RC); + + ReplaceIdEx(J, RC.Res, N + 1, Card, true); + + SymbolTable[J].Kind := KindNONE; + + Exit; + end; + end; + end; + + Id := R.Res; + + IsCallExpected := false; + J2 := 0; + + for I := N to Card do + begin + if Records[I].Op = OP_STMT then + break; + + if Records[I].Op = OP_ELEM then + if Records[I].Arg1 = Id then + Id := Records[I].Res; + + if Records[I].Op = OP_CALL then + if Records[I].Arg1 = Id then + begin + Id := Records[I].Res; + IsCallExpected := true; + + if GetLanguage(N) = PASCAL_LANGUAGE then + begin + // CreateError(errCannotApplyCall, [GetSymbolRec(PatternFieldId).Name]); + end; + + J2 := I; + end; + + if Records[I].Arg1 = Id then + if Records[I].Op = OP_ASSIGN then + begin + // process put property + + PatternFieldId := GetSymbolRec(PatternFieldId).WriteId; + + if PatternFieldId > 0 then + begin + if GetSymbolRec(GetSymbolRec(PatternFieldId).Level) + .FinalTypeId = typeINTERFACE then + if GetSymbolRec(Arg1).FinalTypeId = typeCLASS then + begin + S := GetSymbolRec(PatternFieldId).Name; + PatternFieldId := + SymbolTable.LookUp(S, + GetSymbolRec(Arg1).TerminalTypeId, GetUpcase(N)); + end; + end; + + if PatternFieldId = 0 then + begin + CreateError(errCannotAssignToReadOnlyProperty, []); + Exit; + end; + + if GetSymbolRec(PatternFieldId).Kind = KindTYPE_FIELD then + begin + GetSymbolRec(Arg2).PatternId := PatternFieldId; + GetSymbolRec(Arg2).ByRef := true; + end + else if GetSymbolRec(PatternFieldId).Kind = KindSUB then + begin + GetSymbolRec(Arg2).Name := ''; + GetSymbolRec(Arg2).Kind := 0; + + ReplaceId(Arg2, PatternFieldId); + R.Op := OP_PUSH_INSTANCE; + R.Arg2 := 0; + + if GetSymbolRec(PatternFieldId).Count > 1 then + begin + // if GetLanguage(n) = PASCAL_LANGUAGE then + begin + J1 := ReplaceOP_ELEM(PatternFieldId, K, OldRes); + if K = -1 then + begin + if IsCallExpected then + begin + for J3 := 1 to J2 do + if Records[J3].Op = OP_PUSH then + if Records[J3].Res = PatternFieldId then + Inc(K); + + Records[J2].Op := OP_NOP; + + // push value + + Records[I].Op := OP_PUSH; + Records[I].Arg1 := Records[I].Arg2; + Records[I].Arg2 := K + 1; + Records[I].Res := PatternFieldId; + + RC := TCodeRec.Create(OP_CALL, Self); + RC.Arg1 := PatternFieldId; + RC.Arg2 := K + 2; + RC.Res := 0; + + Insert(I + 1, RC); + + Exit; + end; + + CreateError(errNotEnoughActualParameters, []); + end + else + begin + // push value + + Records[I].Op := OP_PUSH; + Records[I].Arg1 := Records[I].Arg2; + Records[I].Arg2 := K + 1; + Records[I].Res := PatternFieldId; + + RC := TCodeRec.Create(OP_CALL, Self); + RC.Arg1 := PatternFieldId; + RC.Arg2 := K + 2; + RC.Res := 0; + + Insert(I + 1, RC); + + if J1 <> N then + begin + RC := TCodeRec.Create(OP_RESTORE_REGS, Self); + Insert(I, RC); + RC := TCodeRec.Create(OP_SAVE_REGS, Self); + Insert(J1 + 1, RC); + end; + end; + end; + Exit; + end; + + // push value + + Records[I].Op := OP_PUSH; + Records[I].Arg1 := Records[I].Arg2; + Records[I].Arg2 := 0; + Records[I].Res := PatternFieldId; + + RC := TCodeRec.Create(OP_CALL, Self); + RC.Arg1 := PatternFieldId; + RC.Arg2 := 1; + RC.Res := 0; + + Insert(I + 1, RC); + + if GetSymbolRec(PatternFieldId).Count = 1 then + begin + ParamId := SymbolTable.GetParamId(PatternFieldId, 0); + if GetSymbolRec(ParamId).FinalTypeId = typeEVENT then + begin + if Records[I - 1].Op = OP_FIELD then + begin + ParamId := SymbolTable.AddTMethodVar + (GetLevel(N)).Id; + Records[I - 1].Op := OP_CREATE_METHOD; + Records[I - 1].Res := ParamId; + + Records[I].Arg1 := ParamId; + end; + end; + end; + + end + else + CreateError(errInternalError, []); + + Exit; + end; + end; // for-loop + + PatternFieldId := GetSymbolRec(PatternFieldId).ReadId; + if PatternFieldId = 0 then + begin + CreateError(errCannotReadWriteOnlyProperty, []); + Exit; + end; + + if GetSymbolRec(PatternFieldId).Kind = KindTYPE_FIELD then + begin + GetSymbolRec(Arg2).PatternId := PatternFieldId; + GetSymbolRec(Arg2).ByRef := true; + end + else if GetSymbolRec(PatternFieldId).Kind = KindSUB then + begin + IsCallExpected := CallExpected(ResId); + + GetSymbolRec(Arg2).Name := ''; + GetSymbolRec(Arg2).Kind := 0; + + ReplaceId(Arg2, PatternFieldId); + R.Op := OP_PUSH_INSTANCE; + R.Arg2 := 0; + + KK := GetSymbolRec(PatternFieldId).Count; + + if KK > 0 then + begin + // if GetLanguage(n) = PASCAL_LANGUAGE then + begin + J := ReplaceOP_ELEM(PatternFieldId, K, OldRes); + if K = -1 then + begin + if IsCallExpected then + Exit; + Exit; + CreateError(errNotEnoughActualParameters, []); + end + else + begin + InsertCallEx(J, K + 1); + ReplaceId(OldRes, Records[J + 1].Res); + end; + end; + Exit; + end; + + if not IsCallExpected then + InsertCall; + end + else + CreateError(errInternalError, []); + end + end; // KindPROP + else + CreateError(errInternalError, []); + end; + Exit; + end; + + // typeRECORD + + FinalOwnerId := GetSymbolRec(Arg2).FinalOwnerId; + Level := GetSymbolRec(FinalOwnerId).Level; + if GetSymbolRec(Level).Kind in kindSUBS then + begin + if SymbolTable.GetResultId(Level) = FinalOwnerId then + begin + GetSymbolRec(FinalOwnerId).ByRef := true; + end; + { + if GetSymbolRec(FinalOwnerId).Param then + if not StrEql(GetSymbolRec(FinalOwnerId).Name, 'Self') then + begin + GetSymbolRec(FinalOwnerId).ByRef := true; + end; + } + end; + + if GetSymbolRec(FinalOwnerId).Host or (GetSymbolRec(Arg1).Name = '') or + GetSymbolRec(Arg2).HasByRefOwner or (FinalOwnerId > Arg2) or + GetSymbolRec(FinalOwnerId).Param then + GetSymbolRec(Arg2).ByRef := true + else + R.Op := OP_NOP; + end + else if K1 = KindTYPE then + begin + if GetSymbolRec(Arg1).TypeId = TypeALIAS then + Arg1 := GetSymbolRec(Arg1).TerminalTypeId; + + T1 := Arg1; + + if not(GetSymbolRec(Arg1).FinalTypeId in [typeRECORD, typeCLASS]) then + begin + S := GetSymbolRec(Arg2).Name; + SymbolTable.LookUpEx(HelperTypeId, S, T1, GetUpcase(N)); + end; + + if not(GetSymbolRec(Arg1).FinalTypeId in [typeRECORD, typeCLASS]) then + if HelperTypeId = 0 then + begin + if GetSymbolRec(Arg1).FinalTypeId = typeENUM then + begin + S := GetSymbolRec(Arg2).Name; + PatternFieldId := SymbolTable.LookUpEnumItem(S, T1, GetUpcase(N)); + if PatternFieldId = 0 then + CreateError(errUndeclaredIdentifier, [S]) + else + begin + R.Op := OP_NOP; + GetSymbolRec(Arg2).Kind := KindNONE; + GetSymbolRec(Arg2).OwnerId := 0; + ReplaceId(Arg2, PatternFieldId); + end; + Exit; + end; + + CreateError(errRecordRequired, []); + Exit; + end; + + S := GetSymbolRec(Arg2).Name; + if Records[N].PatternFieldId <> 0 then + PatternFieldId := Records[N].PatternFieldId + else + PatternFieldId := SymbolTable.LookUpEx(HelperTypeId, S, T1, GetUpcase(N)); + if PatternFieldId = 0 then + CreateError(errUndeclaredIdentifier, [S]); + + CheckVis(PatternFieldId); + + if GetSymbolRec(PatternFieldId).Kind in kindSUBS then + if Records[N + 1].Op = OP_ADDRESS then + if Records[N + 1].Arg1 = Records[N].Res then + begin + Records[N].Op := OP_NOP; + Records[N + 1].Arg1 := PatternFieldId; + Exit; + end; + + GetSymbolRec(Arg2).TypeId := GetSymbolRec(PatternFieldId).TypeId; + GetSymbolRec(Arg2).PatternId := PatternFieldId; + + case GetSymbolRec(PatternFieldId).Kind of + KindCONSTRUCTOR: + begin + IsCallExpected := CallExpected(ResId); + + GetSymbolRec(Arg2).Name := ''; + GetSymbolRec(Arg2).Kind := 0; + + ReplaceId(Arg2, PatternFieldId); + R.Op := OP_PUSH_CLASSREF; + Inc(R.Arg1); + R.Arg2 := 0; + + if not IsCallExpected then + InsertCall; + end; + KindSUB: + begin + if not GetSymbolRec(PatternFieldId).IsSharedMethod then + if not StrEql('ClassName', GetSymbolRec(PatternFieldId).Name) then + CreateError(errThisFormOfMethodCanOnlyAllowedForClassMethod, []); + + if InsertCreateEvent(PatternFieldId) then + Exit; + + IsCallExpected := CallExpected(ResId); + + GetSymbolRec(Arg2).Name := ''; + GetSymbolRec(Arg2).Kind := 0; + + ReplaceId(Arg2, PatternFieldId); + R.Op := OP_PUSH_CLASSREF; + Inc(R.Arg1); + R.Arg2 := 0; + + if not IsCallExpected then + InsertCall; + + if not GetSymbolRec(Self[N].Arg1).Host then + if StrEql(GetSymbolRec(Self[N + 1].Arg1).Name, 'ClassName') then + begin + Self[N].Op := OP_NOP; + Self[N + 1].Op := OP_CLASSNAME; + Self[N + 1].Arg1 := Self[N].Arg1; + end; + + end; + KindTYPE_FIELD: + begin + GetSymbolRec(Arg2).ByRef := true; + end; + KindCONST: + begin + Records[N].Op := OP_NOP; + Records[N].GenOp := OP_NOP; + ReplaceId(Records[N].Res, PatternFieldId); + end; + else + CreateError(errPropertyInaccessibleHere, [S]); + end; + end + else if K1 = KindNAMESPACE then + begin + CreateUsingList(N); + if using_list.IndexOf(Arg1) = -1 then + begin + S := GetSymbolRec(Arg1).Name; + CreateError(errUndeclaredIdentifier, [S]); + SymbolTable.AddUndeclaredIdent(S, TKernel(kernel).UndeclaredIdents, + TKernel(kernel).Errors.Count - 1, true); + end; + + S := GetSymbolRec(Arg2).Name; + PatternFieldId := SymbolTable.LookUp(S, Arg1, GetUpcase(N)); + + if PatternFieldId = 0 then + begin + if ((Arg1 = H_PascalNamespace) and (GetLanguage(N) = PASCAL_LANGUAGE)) or + ((Arg1 = H_BasicNamespace) and (GetLanguage(N) = BASIC_LANGUAGE)) then + PatternFieldId := SymbolTable.LookUp(S, 0, GetUpcase(N)); + end; + + if PatternFieldId = 0 then + begin + CreateError(errUndeclaredIdentifier, [S]); + if TKernel(kernel).Canceled then + begin + Exit; + end; + end; + + GetSymbolRec(PatternFieldId).NSOwnerId := Arg1; + + ReplaceIdEx(R.Res, PatternFieldId, N + 1, Card, true); + R.Op := OP_NOP; + end + else + begin + + if Records[N].Language = JS_LANGUAGE then + begin + + RC := TCodeRec.Create(OP_TO_JS_OBJECT, Self); + RC.Arg1 := R.Arg1; + RC.Arg2 := 0; + RC.Res := NewTempVar(GetLevel(N), typeVARIANT); + Insert(N, RC); + + R.Arg1 := RC.Res; + + Exit; + end; + + CreateError(errRecordRequired, []); + end; +end; + +procedure TCode.AssignShifts; +var + I, J, OwnerId, DestId, K, FinTypeId, FieldDescriptorId, OwnerShift, DestShift, + DestSize, D: Integer; + R: TCodeRec; + SymbolTable: TSymbolTable; +begin + SymbolTable := TKernel(kernel).SymbolTable; + for I := Card downto 1 do + begin + R := Self[I]; + if R.Op = OP_ABSOLUTE then + begin + OwnerShift := GetSymbolRec(R.Arg2).Shift; + if OwnerShift = 0 then + begin + N := I; + CreateError(errIdentifierExpected, []); + end; + GetSymbolRec(R.Arg1).Shift := OwnerShift; + end + else if R.Op = OP_ASSIGN_SHIFT then + begin + OwnerId := R.Arg1; + K := R.Arg2; + DestId := R.Res; + + FinTypeId := SymbolTable[OwnerId].FinalTypeId; + OwnerShift := SymbolTable[OwnerId].Shift; + DestShift := SymbolTable[DestId].Shift; + DestSize := SymbolTable[DestId].Size; + case FinTypeId of + typeARRAY: + begin + SymbolTable[DestId].Shift := OwnerShift + K * DestSize; + end; + typeRECORD: + begin + FieldDescriptorId := SymbolTable.GetFieldDescriptorId(OwnerId, K); + SymbolTable[DestId].Shift := OwnerShift + SymbolTable + [FieldDescriptorId].Shift; + end; + end; + D := DestShift - SymbolTable[DestId].Shift; + for J := DestId + 1 to SymbolTable.Card do + if SymbolTable[J].OwnerId = DestId then + SymbolTable[J].Shift := SymbolTable[J].Shift - D; + + R.Op := OP_NOP; + end; + end; +end; + +procedure TCode.OperCheckOverride(List: TIntegerList); +var + R: TCodeRec; + SymbolTable: TSymbolTable; + temp, I, SubId, L, BestId, J: Integer; + temp_l: TIntegerList; + SR, ST: TSymbolRec; +begin + if TKernel(kernel).InterfaceOnly then + Exit; + + R := Records[N]; + R.Op := OP_NOP; + SubId := R.Arg1; + + BestId := 0; + + L := GetSymbolRec(SubId).Level; + if L = 0 then + Exit; + if GetSymbolRec(L).Kind <> KindTYPE then + Exit; + + SymbolTable := TKernel(kernel).SymbolTable; + if (GetSymbolRec(SubId).Name = '') and + (GetSymbolRec(SubId).Kind = KindCONSTRUCTOR) then + begin + temp_l := SymbolTable.LookupParentConstructors(SubId); + try + for I := 0 to temp_l.Count - 1 do + begin + if GetSymbolRec(temp_l[I]).CallMode in [cmNONE, cmSTATIC] then + begin + GetSymbolRec(SubId).CallMode := GetSymbolRec(temp_l[I]).CallMode; + Exit; + end; + end; + finally + FreeAndNil(temp_l); + end; + Exit; + end + else + temp := SymbolTable.LookupParentMethodBase(SubId, GetUpcase(N), BestId); + if temp = 0 then + begin + if GetSymbolRec(SubId).Kind = KindCONSTRUCTOR then + begin + // fix default constructor + GetSymbolRec(SubId).CallMode := cmNONE; + end + else + begin + if BestId > 0 then + begin + if SymbolTable[BestId].CallMode in [cmNONE, cmSTATIC] then + CreateError(errCannotOverrideStaticMethod, []) + else + CreateError(errDeclarationDiffersFromPreviousDeclaration, + [GetSymbolRec(SubId).Name]); + end + else + CreateError(errMethodDoesNotExistsInTheBaseClass, + [GetSymbolRec(SubId).Name]); + end; + end + else if SymbolTable[temp].CallMode in [cmNONE, cmSTATIC] then + begin + if GetSymbolRec(SubId).Kind = KindCONSTRUCTOR then + begin + // fix default constructor + GetSymbolRec(SubId).CallMode := cmNONE; + end + else + CreateError(errCannotOverrideStaticMethod, []); + end + else + begin + for J := 0 to List.Count - 1 do + begin + I := List[J]; + if Records[I].Op = OP_CHECK_OVERRIDE then + if Records[I].Arg1 = temp then + begin + N := I; + OperCheckOverride(List); + GetSymbolRec(SubId).CallMode := GetSymbolRec(temp).CallMode; + break; + end; + end; + end; + SR := GetSymbolRec(SubId); + ST := GetSymbolRec(temp); + + SR.MethodIndex := ST.MethodIndex; + SR.DynamicMethodIndex := ST.DynamicMethodIndex; +end; + +procedure TCode.OperBeginInitConst; + +var + SymbolTable: TSymbolTable; + + procedure CheckArray(Id: Integer); + var + ArrayTypeId, RangeTypeId, ElemTypeId, B1, B2, K, I: Integer; + RI: TCodeRec; + begin + ArrayTypeId := SymbolTable[Id].TerminalTypeId; + SymbolTable.GetArrayTypeInfo(ArrayTypeId, RangeTypeId, ElemTypeId); + B1 := SymbolTable.GetLowBoundRec(RangeTypeId).value; + B2 := SymbolTable.GetHighBoundRec(RangeTypeId).value; + K := 0; + I := N; + repeat + Inc(I); + if I > Card then + RaiseError(errInternalError, []); + RI := Records[I]; + if RI.Op = OP_ITEM then + begin + if RI.Arg1 = Id then + Inc(K); + end + else if RI.Op = OP_BEGIN_INIT_CONST then + Exit + else if RI.Op = OP_END_INIT_CONST then + begin + if RI.Arg1 = Id then + begin + if K <> B2 - B1 + 1 then + RaiseError(errE2072, [K, B2 - B1 + 1]); + Exit; + end; + end; + until false; + end; + +var + R, RI, RJ: TCodeRec; + K, I, J, FinTypeId, OwnerId, ItemNumber, B1, B2, L, KK: Integer; + ArrayTypeId, RangeTypeId, ElemTypeId, FieldDescriptorId: Integer; +begin + R := Records[N]; + SymbolTable := TKernel(kernel).SymbolTable; + FinTypeId := SymbolTable[R.Arg1].FinalTypeId; + + if FinTypeId = typeARRAY then + CheckArray(R.Arg1); + + if FinTypeId in [typeRECORD, typeARRAY] then + Exit; + + if FinTypeId = 0 then // this is a nested initializer + begin + if Self[N + 1].Op = OP_ASSIGN then + begin + if GetSymbolRec(Self[N + 1].Arg2).HasPWideCharType then + begin + SymbolTable[R.Arg1].TypeId := typeUNICSTRING; + Exit; + end +{$IFNDEF PAXARM} + else if GetSymbolRec(Self[N + 1].Arg2).HasPAnsiCharType then + begin + SymbolTable[R.Arg1].TypeId := typeANSISTRING; + Exit; + end; +{$ENDIF} + end; + + K := 0; + for I := N - 1 downto 1 do + begin + RI := Self[I]; + if RI.Op = OP_BEGIN_INIT_CONST then + begin + Inc(K); + if K = 1 then + begin + OwnerId := RI.Arg1; + FinTypeId := SymbolTable[OwnerId].FinalTypeId; + + ItemNumber := -1; + + for J := N + 1 to Card do + begin + RJ := Self[J]; + if RJ.Op = OP_ASSIGN_SHIFT then + if RJ.Res = R.Arg1 then + begin + ItemNumber := RJ.Arg2; + + RJ.Arg1 := OwnerId; + break; + end; + end; + + case FinTypeId of + typeRECORD: + begin + if ItemNumber = -1 then + RaiseError(errInternalError, []); + FieldDescriptorId := SymbolTable.GetFieldDescriptorId(OwnerId, + ItemNumber); + SymbolTable[R.Arg1].TypeId := + SymbolTable[FieldDescriptorId].TypeId; + end; + typeARRAY: + begin + ArrayTypeId := SymbolTable[OwnerId].TerminalTypeId; + SymbolTable.GetArrayTypeInfo(ArrayTypeId, RangeTypeId, + ElemTypeId); + SymbolTable[R.Arg1].TypeId := ElemTypeId; + if GetSymbolRec(R.Arg1).FinalTypeId = typeARRAY then + CheckArray(R.Arg1); + B1 := SymbolTable.GetLowBoundRec(RangeTypeId).value; + B2 := SymbolTable.GetHighBoundRec(RangeTypeId).value; + if ItemNumber > B2 - B1 then + CreateError(errRangeCheckError, []); + + if ItemNumber > 0 then + Exit; + + L := 0; + KK := 0; + + if SymbolTable[ElemTypeId].FinalTypeId = typeARRAY then + begin + for J := N to Card do + begin + RJ := Self[J]; + if RJ.Op = OP_BEGIN_INIT_CONST then + begin + Inc(KK); + if KK = 1 then + Inc(L); + end + else if RJ.Op = OP_END_INIT_CONST then + begin + Dec(KK); + if KK < 0 then + break; + end; + end; + + if L <> B2 - B1 + 1 then + CreateError(errE2072, [L, B2 - B1 + 1]); + end; + end + else + CreateError(errIncompatibleTypesNoArgs, []); + end; + + Exit; + end; + end + else if RI.Op = OP_END_INIT_CONST then + begin + Dec(K); + end; + end; + end; +end; + +procedure TCode.OperEndInitConst; +begin +end; + +procedure TCode.OperItem; +var + R: TCodeRec; + SymbolTable: TSymbolTable; + K, FieldDescriptorId, FinTypeId, ArrayTypeId, RangeTypeId, ElemTypeId, H1, + H2: Integer; + S: String; +begin + R := Records[N]; + SymbolTable := TKernel(kernel).SymbolTable; + + FinTypeId := SymbolTable[R.Arg1].FinalTypeId; + + case FinTypeId of + typeRECORD: + begin + K := R.Arg2; + FieldDescriptorId := SymbolTable.GetFieldDescriptorId(R.Arg1, K); + S := SymbolTable[FieldDescriptorId].Name; + SymbolTable[R.Res].Name := S; + SymbolTable[R.Res].TypeId := FieldDescriptorId; + SymbolTable[R.Res].OwnerId := R.Arg1; + R.Arg2 := R.Res; + R.Op := OP_FIELD; + Dec(N); + end; + typeARRAY: + begin + K := R.Arg2; + + ArrayTypeId := SymbolTable[R.Arg1].TypeId; + SymbolTable.GetArrayTypeInfo(ArrayTypeId, RangeTypeId, ElemTypeId); + + H1 := SymbolTable.GetLowBoundRec(RangeTypeId).value; + H2 := SymbolTable.GetHighBoundRec(RangeTypeId).value; + + if K + H1 > H2 then + CreateError(errConstantExpressionViolatesSubrangeBounds, []); + + R.Arg2 := CreateConst(SymbolTable[RangeTypeId].TypeId, K + H1); + SymbolTable[R.Res].TypeId := ElemTypeId; + R.Op := OP_ELEM; + Dec(N); + end; + else + CreateError(errIncompatibleTypesNoArgs, []); + end; +end; + +procedure TCode.OperRecordItem; +var + R: TCodeRec; + SymbolTable: TSymbolTable; + FieldDescriptorId, FinTypeId: Integer; + S: String; +begin + R := Records[N]; + SymbolTable := TKernel(kernel).SymbolTable; + + FinTypeId := SymbolTable[R.Arg1].FinalTypeId; + + case FinTypeId of + typeRECORD: + begin + S := SymbolTable[R.Arg2].value; + FieldDescriptorId := SymbolTable.GetFieldDescriptorIdByName(R.Arg1, S); + + if FieldDescriptorId = 0 then + CreateError(errUndeclaredIdentifier, [S]); + + SymbolTable[R.Res].Name := S; + SymbolTable[R.Res].TypeId := FieldDescriptorId; + SymbolTable[R.Res].OwnerId := R.Arg1; + R.Arg2 := R.Res; + R.Op := OP_FIELD; + Dec(N); + end; + else + CreateError(errIncompatibleTypesNoArgs, []); + end; + +end; + +procedure TCode.OperElem; +var + Arg1, Arg2, Res, K1, K2, ArrayTypeId, TRange, TElem: Integer; + R: TCodeRec; + SymbolTable: TSymbolTable; + FinalOwnerId: Integer; + S: String; + I, J, LastI, LastN: Integer; + RI, RC: TCodeRec; + Id: Integer; + OldList: TCodeRecList; + NewList: TCodeRecList; +begin + SymbolTable := TKernel(kernel).SymbolTable; + + R := Records[N]; + + Arg1 := R.Arg1; + Arg2 := R.Arg2; + Res := R.Res; + K1 := GetSymbolRec(Arg1).Kind; + K2 := GetSymbolRec(Arg2).Kind; + + OldList := TCodeRecList.Create; + NewList := TCodeRecList.Create; + + try + + if K1 = KindVAR then + begin + + if GetSymbolRec(Arg1).IsFWArrayVar then + begin + GetSymbolRec(Res).ByRef := true; + + ArrayTypeId := GetSymbolRec(Arg1).TerminalTypeId; + TElem := GetSymbolRec(ArrayTypeId).PatternId; + TElem := GetSymbolRec(TElem).PatternId; + + GetSymbolRec(Res).TypeId := TElem; + + Exit; + end; + + if GetSymbolRec(Arg1).FinalTypeId = typeDYNARRAY then + begin + GetSymbolRec(Res).ByRef := true; + + ArrayTypeId := GetSymbolRec(Arg1).TerminalTypeId; + TElem := GetSymbolRec(ArrayTypeId).PatternId; + + GetSymbolRec(Res).TypeId := TElem; + Exit; + end; + + if GetSymbolRec(Arg1).FinalTypeId = typeOPENARRAY then + begin + GetSymbolRec(Res).ByRef := true; + + ArrayTypeId := GetSymbolRec(Arg1).TerminalTypeId; + TElem := GetSymbolRec(ArrayTypeId).PatternId; + + GetSymbolRec(Res).TypeId := TElem; + Exit; + end; +{$IFNDEF PAXARM} + if GetSymbolRec(Arg1).FinalTypeId = typeANSISTRING then + begin + GetSymbolRec(Res).ByRef := true; + GetSymbolRec(Res).TypeId := typeANSICHAR; + Exit; + end; + + if GetSymbolRec(Arg1).FinalTypeId = typeSHORTSTRING then + begin + GetSymbolRec(Res).ByRef := true; + GetSymbolRec(Res).TypeId := typeANSICHAR; + Exit; + end; + + if GetSymbolRec(Arg1).FinalTypeId = typeWIDESTRING then + begin + GetSymbolRec(Res).ByRef := true; + GetSymbolRec(Res).TypeId := typeWIDECHAR; + Exit; + end; +{$ENDIF} + if GetSymbolRec(Arg1).FinalTypeId = typeUNICSTRING then + begin + GetSymbolRec(Res).ByRef := true; + GetSymbolRec(Res).TypeId := typeWIDECHAR; + Exit; + end; + + if GetSymbolRec(Arg1).FinalTypeId <> typeARRAY then + begin + if GetSymbolRec(Arg1).FinalTypeId in [typeCLASS, typeINTERFACE] then + begin + I := SymbolTable.FindDefaultPropertyId + (GetSymbolRec(Arg1).TerminalTypeId); + if I <> 0 then + begin + if R.Language = JS_LANGUAGE then + if Records[N + 1].Op = OP_ELEM then + if Records[N + 1].Arg1 = Res then + begin + Id := NewTempVar(GetSymbolRec(Res).Level, 0); + RC := TCodeRec.Create(OP_ASSIGN, Self); + RC.Arg1 := Id; + RC.Arg2 := Res; + RC.Res := Id; + + GetSymbolRec(Id).TypeId := GetSymbolRec(Arg1).TypeId; + GetSymbolRec(Res).TypeId := GetSymbolRec(Arg1).TypeId; + + Records[N + 1].Arg1 := Id; + Insert(N + 1, RC); + Dec(N); + + Exit; + end; + + S := GetSymbolRec(I).Name; + Id := NewTempVar(GetLevel(N), GetSymbolRec(I).TypeId); + + GetSymbolRec(Id).OwnerId := R.Arg1; + GetSymbolRec(Id).Name := GetSymbolRec(I).Name; + + RC := TCodeRec.Create(OP_FIELD, Self); + RC.Arg1 := R.Arg1; + RC.Arg2 := Id; + RC.Res := Id; + + R.Arg1 := Id; + Insert(N, RC); + + Dec(N); + + Exit; + end + else + begin + S := GetSymbolRec(GetSymbolRec(Arg1).TerminalTypeId).Name; + CreateError(errClassDoesNotHaveDefaultProperty, [S]); + Exit; + end; + end + else if GetSymbolRec(Arg1).FinalTypeId in VariantTypes then + begin + OldList.Add(Records[N].Clone); + NewList.Add(Records[N]); + + J := 1; + K1 := R.Res; + Records[N].Op := OP_VARARRAY_IDX; + GetSymbolRec(Records[N].Res).Kind := KindNONE; + Records[N].Res := 0; + + LastI := N; + + I := N + 1; + while I <= Card do + begin + if Records[I].Op = OP_ELEM then + begin + if Records[I].Arg1 = K1 then + begin + OldList.Add(Records[I].Clone); + NewList.Add(Records[I]); + + K1 := Records[I].Res; + Records[I].Op := OP_VARARRAY_IDX; + Records[I].Arg1 := R.Arg1; + GetSymbolRec(Records[I].Res).Kind := KindNONE; + Records[I].Res := 0; + + LastI := I; + + Inc(J); + end; + end + else if (Records[I].Op = OP_ASSIGN) and (Records[I].Arg1 = K1) then + begin + break; + end; + Inc(I); + end; + + if I > Card then + I := LastI + 1; + + if (Records[I].Op = OP_ASSIGN) and (Records[I].Arg1 = K1) then + begin + LastN := N; + + RI := Records[I]; + + if GetSymbolRec(RI.Arg2).TypeId = 0 then + begin + MoveRValue(I); + + for I := 0 to OldList.Count - 1 do + begin + TCodeRec(NewList[I]).Op := TCodeRec(OldList[I]).Op; + TCodeRec(NewList[I]).Arg1 := TCodeRec(OldList[I]).Arg1; + TCodeRec(NewList[I]).Arg2 := TCodeRec(OldList[I]).Arg2; + TCodeRec(NewList[I]).Res := TCodeRec(OldList[I]).Res; + end; + + Dec(N); + Exit; + end + else if GetSymbolRec(RI.Arg2).FinalTypeId <> typeVARIANT then + InsertConversionToVariant(I, 2); + + RI.Op := OP_VARARRAY_PUT; + RI.Arg1 := R.Arg1; + RI.Res := RI.Arg2; + RI.Arg2 := J; + + N := LastN; + end + else + begin + RC := TCodeRec.Create(OP_VARARRAY_GET, Self); + RC.Arg1 := R.Arg1; + RC.Arg2 := J; + RC.Res := K1; + Insert(I, RC); + + GetSymbolRec(K1).TypeId := typeVARIANT; + GetSymbolRec(K1).Kind := KindVAR; + GetSymbolRec(K1).OwnerId := 0; + + InsertDeclareTempVar(RC.Res); + end; + + Dec(N); + end + else + CreateError(errArrayTypeRequired, []); + + Exit; + end; + + ArrayTypeId := SymbolTable[Arg1].TerminalTypeId; + SymbolTable.GetArrayTypeInfo(ArrayTypeId, TRange, TElem); + + GetSymbolRec(Res).TypeId := TElem; + + if (K2 = KindCONST) and (not GetSymbolRec(Arg1).ByRef) then + begin + CheckSubrangeBounds(TRange, GetSymbolRec(Arg2)); + FinalOwnerId := GetSymbolRec(Res).FinalOwnerId; + if GetSymbolRec(FinalOwnerId).Host or GetSymbolRec(FinalOwnerId).ByRef + then + GetSymbolRec(Res).ByRef := true + else + begin + // save index value for TSymbolTable.SetShifts + // GetSymbolRec(Res).Value := GetSymbolRec(Arg2).Value; + // R.Op := OP_NOP; + GetSymbolRec(Res).ByRef := true; + end; + end + else + begin + GetSymbolRec(Res).ByRef := true; + end; + end + else if K1 = KindCONST then + begin + if GetSymbolRec(Arg1).HasPWideCharType then + begin + GetSymbolRec(Res).TypeId := typeWIDECHAR; + if K2 = KindCONST then + begin + GetSymbolRec(Res).Kind := KindCONST; + S := GetSymbolRec(Arg1).value; + I := GetSymbolRec(Arg2).value; + GetSymbolRec(Res).value := Integer(S[I]); + R.Op := OP_NOP; + end + else if K2 = KindVAR then + begin + GetSymbolRec(Res).ByRef := true; + GetSymbolRec(Res).TypeId := typeWIDECHAR; + end + else + CreateError(errIncompatibleTypesNoArgs, []); + end +{$IFNDEF PAXARM} + else if GetSymbolRec(Arg1).HasPAnsiCharType then + begin + GetSymbolRec(Res).TypeId := typeANSICHAR; + if K2 = KindCONST then + begin + GetSymbolRec(Res).Kind := KindCONST; + S := GetSymbolRec(Arg1).value; + I := GetSymbolRec(Arg2).value; + GetSymbolRec(Res).value := Integer(S[I]); + R.Op := OP_NOP; + end + else if K2 = KindVAR then + begin + GetSymbolRec(Res).ByRef := true; + GetSymbolRec(Res).TypeId := typeANSICHAR; + end + else + CreateError(errIncompatibleTypesNoArgs, []); + end +{$ENDIF} + else + CreateError(errArrayTypeRequired, []); + end + else if K1 = KindSUB then + begin + R.Op := OP_CALL; + R.GenOp := OP_CALL; + + RC := TCodeRec.Create(OP_PUSH, Self); + RC.Arg1 := R.Arg2; + RC.Arg2 := 0; + RC.Res := R.Arg1; + + R.Arg2 := 1; + + Insert(N, RC); + Dec(N); + + for I := N downto 1 do + if Records[I].Op = OP_STMT then + begin + Records[I].Op := OP_NOP; + break; + end; + end + else + CreateError(errArrayTypeRequired, []); + + finally + + FreeAndNil(NewList); + for I := 0 to OldList.Count - 1 do +{$IFDEF ARC} + OldList[I] := nil; +{$ELSE} + TCodeRec(OldList[I]).Free; +{$ENDIF} + FreeAndNil(OldList); + + end; +end; + +procedure TCode.OperPrint; +var + R: TCodeRec; + Arg1, Arg2, Res, T1, K1, SubId: Integer; + SymbolTable: TSymbolTable; +begin + SymbolTable := TKernel(kernel).SymbolTable; + + R := Records[N]; + + Arg1 := R.Arg1; + Arg2 := R.Arg2; + Res := R.Res; + + if (Arg1 = 0) and (Arg2 = 0) and (Res = 0) then // writeln + begin + SubId := SymbolTable.LookUp(strWriteln, 0, false); + R.Op := OP_CALL; + R.Arg1 := SubId; + R.Arg2 := 0; + R.Res := 0; + if SubId = 0 then + RaiseError(errInternalError, []); + Dec(N); + Exit; + end; + + T1 := GetSymbolRec(Arg1).FinalTypeId; + + if GetSymbolRec(Arg1).HasPWideCharType then + T1 := typePWIDECHAR; + + K1 := GetSymbolRec(Arg1).Kind; + if K1 in [KindVAR, KindCONST] then + begin + case T1 of + typeBOOLEAN: + begin + SubId := Id_WriteBool; + + if (Arg2 <> 0) or (Res <> 0) then + CreateError(errIllegalTypeInWriteStatememt, []); + + R.Op := OP_CALL; + R.Arg1 := SubId; + R.Arg2 := 1; + R.Res := 0; + + R := TCodeRec.Create(OP_PUSH, Self); + R.Arg1 := Arg1; + R.Arg2 := 0; // param number + R.Res := SubId; + + Insert(N, R); + end; + typeBYTEBOOL: + begin + SubId := Id_WriteByteBool; + + if (Arg2 <> 0) or (Res <> 0) then + CreateError(errIllegalTypeInWriteStatememt, []); + + R.Op := OP_CALL; + R.Arg1 := SubId; + R.Arg2 := 1; + R.Res := 0; + + R := TCodeRec.Create(OP_PUSH, Self); + R.Arg1 := Arg1; + R.Arg2 := 0; // param number + R.Res := SubId; + + Insert(N, R); + end; + typeWORDBOOL: + begin + SubId := Id_WriteWordBool; + + if (Arg2 <> 0) or (Res <> 0) then + CreateError(errIllegalTypeInWriteStatememt, []); + + R.Op := OP_CALL; + R.Arg1 := SubId; + R.Arg2 := 1; + R.Res := 0; + + R := TCodeRec.Create(OP_PUSH, Self); + R.Arg1 := Arg1; + R.Arg2 := 0; // param number + R.Res := SubId; + + Insert(N, R); + end; + typeLONGBOOL: + begin + SubId := Id_WriteLongBool; + + if (Arg2 <> 0) or (Res <> 0) then + CreateError(errIllegalTypeInWriteStatememt, []); + + R.Op := OP_CALL; + R.Arg1 := SubId; + R.Arg2 := 1; + R.Res := 0; + + R := TCodeRec.Create(OP_PUSH, Self); + R.Arg1 := Arg1; + R.Arg2 := 0; // param number + R.Res := SubId; + + Insert(N, R); + end; + typeCLASS: + begin + SubId := Id_WriteObject; + + if (Arg2 <> 0) or (Res <> 0) then + CreateError(errIllegalTypeInWriteStatememt, []); + + R.Op := OP_CALL; + R.Arg1 := SubId; + R.Arg2 := 1; + R.Res := 0; + + R := TCodeRec.Create(OP_PUSH, Self); + R.Arg1 := Arg1; + R.Arg2 := 0; // param number + R.Res := SubId; + + Insert(N, R); + end; +{$IFNDEF PAXARM} + typeANSICHAR: + begin + SubId := Id_WriteAnsiChar; + + if (Arg2 <> 0) or (Res <> 0) then + CreateError(errIllegalTypeInWriteStatememt, []); + + R.Op := OP_CALL; + R.Arg1 := SubId; + R.Arg2 := 1; + R.Res := 0; + + R := TCodeRec.Create(OP_PUSH, Self); + R.Arg1 := Arg1; + R.Arg2 := 0; // param number + R.Res := SubId; + + Insert(N, R); + end; +{$ENDIF} + typeWIDECHAR: + begin + SubId := Id_WriteWideChar; + + if (Arg2 <> 0) or (Res <> 0) then + CreateError(errIllegalTypeInWriteStatememt, []); + + R.Op := OP_CALL; + R.Arg1 := SubId; + R.Arg2 := 1; + R.Res := 0; + + R := TCodeRec.Create(OP_PUSH, Self); + R.Arg1 := Arg1; + R.Arg2 := 0; // param number + R.Res := SubId; + + Insert(N, R); + end; + typeBYTE: + begin + SubId := Id_WriteByte; + + if Res <> 0 then + CreateError(errIllegalTypeInWriteStatememt, []); + + R.Op := OP_CALL; + R.Arg1 := SubId; + R.Arg2 := 2; + R.Res := 0; + + R := TCodeRec.Create(OP_PUSH, Self); + R.Arg1 := Arg1; + R.Arg2 := 0; // param number + R.Res := SubId; + + Insert(N, R); + + R := TCodeRec.Create(OP_PUSH, Self); + if Arg2 = 0 then + R.Arg1 := CreateConst(typeINTEGER, 0) + else + R.Arg1 := Arg2; + R.Arg2 := 1; // param number + R.Res := SubId; + + Insert(N + 1, R); + end; + typeWORD: + begin + SubId := Id_WriteWord; + + if Res <> 0 then + CreateError(errIllegalTypeInWriteStatememt, []); + + R.Op := OP_CALL; + R.Arg1 := SubId; + R.Arg2 := 2; + R.Res := 0; + + R := TCodeRec.Create(OP_PUSH, Self); + R.Arg1 := Arg1; + R.Arg2 := 0; // param number + R.Res := SubId; + + Insert(N, R); + + R := TCodeRec.Create(OP_PUSH, Self); + if Arg2 = 0 then + R.Arg1 := CreateConst(typeINTEGER, 0) + else + R.Arg1 := Arg2; + R.Arg2 := 1; // param number + R.Res := SubId; + + Insert(N + 1, R); + end; + typeCARDINAL: + begin + SubId := Id_WriteCardinal; + + if Res <> 0 then + CreateError(errIllegalTypeInWriteStatememt, []); + + R.Op := OP_CALL; + R.Arg1 := SubId; + R.Arg2 := 2; + R.Res := 0; + + R := TCodeRec.Create(OP_PUSH, Self); + R.Arg1 := Arg1; + R.Arg2 := 0; // param number + R.Res := SubId; + + Insert(N, R); + + R := TCodeRec.Create(OP_PUSH, Self); + if Arg2 = 0 then + R.Arg1 := CreateConst(typeINTEGER, 0) + else + R.Arg1 := Arg2; + R.Arg2 := 1; // param number + R.Res := SubId; + + Insert(N + 1, R); + end; + typeSMALLINT: + begin + SubId := Id_WriteSmallInt; + + if Res <> 0 then + CreateError(errIllegalTypeInWriteStatememt, []); + + R.Op := OP_CALL; + R.Arg1 := SubId; + R.Arg2 := 2; + R.Res := 0; + + R := TCodeRec.Create(OP_PUSH, Self); + R.Arg1 := Arg1; + R.Arg2 := 0; // param number + R.Res := SubId; + + Insert(N, R); + + R := TCodeRec.Create(OP_PUSH, Self); + if Arg2 = 0 then + R.Arg1 := CreateConst(typeINTEGER, 0) + else + R.Arg1 := Arg2; + R.Arg2 := 1; // param number + R.Res := SubId; + + Insert(N + 1, R); + end; + typeSHORTINT: + begin + SubId := Id_WriteShortInt; + + if Res <> 0 then + CreateError(errIllegalTypeInWriteStatememt, []); + + R.Op := OP_CALL; + R.Arg1 := SubId; + R.Arg2 := 2; + R.Res := 0; + + R := TCodeRec.Create(OP_PUSH, Self); + R.Arg1 := Arg1; + R.Arg2 := 0; // param number + R.Res := SubId; + + Insert(N, R); + + R := TCodeRec.Create(OP_PUSH, Self); + if Arg2 = 0 then + R.Arg1 := CreateConst(typeINTEGER, 0) + else + R.Arg1 := Arg2; + R.Arg2 := 1; // param number + R.Res := SubId; + + Insert(N + 1, R); + end; + typeINTEGER, typeENUM: + begin + SubId := Id_WriteInt; + + if Res <> 0 then + CreateError(errIllegalTypeInWriteStatememt, []); + + R.Op := OP_CALL; + R.Arg1 := SubId; + R.Arg2 := 2; + R.Res := 0; + + R := TCodeRec.Create(OP_PUSH, Self); + R.Arg1 := Arg1; + R.Arg2 := 0; // param number + R.Res := SubId; + + Insert(N, R); + + R := TCodeRec.Create(OP_PUSH, Self); + if Arg2 = 0 then + R.Arg1 := CreateConst(typeINTEGER, 0) + else + R.Arg1 := Arg2; + R.Arg2 := 1; // param number + R.Res := SubId; + + Insert(N + 1, R); + end; + typeINT64, typeUINT64: + begin + SubId := Id_WriteInt64; + + if Res <> 0 then + CreateError(errIllegalTypeInWriteStatememt, []); + + R.Op := OP_CALL; + R.Arg1 := SubId; + R.Arg2 := 2; + R.Res := 0; + + R := TCodeRec.Create(OP_PUSH, Self); + R.Arg1 := Arg1; + R.Arg2 := 0; // param number + R.Res := SubId; + + Insert(N, R); + + R := TCodeRec.Create(OP_PUSH, Self); + if Arg2 = 0 then + R.Arg1 := CreateConst(typeINTEGER, 0) + else + R.Arg1 := Arg2; + R.Arg2 := 1; // param number + R.Res := SubId; + + Insert(N + 1, R); + end; + typePOINTER: + begin + if GetSymbolRec(Arg1).HasPWideCharType then + begin + SubId := Id_WriteUnicString; + + if Res <> 0 then + CreateError(errIllegalTypeInWriteStatememt, []); + + R.Op := OP_CALL; + R.Arg1 := SubId; + R.Arg2 := 2; + R.Res := 0; + + R := TCodeRec.Create(OP_PUSH, Self); + R.Arg1 := Arg1; + R.Arg2 := 0; // param number + R.Res := SubId; + + Insert(N, R); + + R := TCodeRec.Create(OP_PUSH, Self); + if Arg2 = 0 then + R.Arg1 := CreateConst(typeINTEGER, 0) + else + R.Arg1 := Arg2; + R.Arg2 := 1; // param number + R.Res := SubId; + + Insert(N + 1, R); + end +{$IFNDEF PAXARM} + else if GetSymbolRec(Arg1).HasPAnsiCharType then + begin + SubId := Id_WriteString; + + if Res <> 0 then + CreateError(errIllegalTypeInWriteStatememt, []); + + R.Op := OP_CALL; + R.Arg1 := SubId; + R.Arg2 := 2; + R.Res := 0; + + R := TCodeRec.Create(OP_PUSH, Self); + R.Arg1 := Arg1; + R.Arg2 := 0; // param number + R.Res := SubId; + + Insert(N, R); + + R := TCodeRec.Create(OP_PUSH, Self); + if Arg2 = 0 then + R.Arg1 := CreateConst(typeINTEGER, 0) + else + R.Arg1 := Arg2; + R.Arg2 := 1; // param number + R.Res := SubId; + + Insert(N + 1, R); + end +{$ENDIF} + else + CreateError(errIllegalTypeInWriteStatememt, []); + end; +{$IFNDEF PAXARM} + typeANSISTRING: + begin + SubId := Id_WriteString; + + if Res <> 0 then + CreateError(errIllegalTypeInWriteStatememt, []); + + R.Op := OP_CALL; + R.Arg1 := SubId; + R.Arg2 := 2; + R.Res := 0; + + R := TCodeRec.Create(OP_PUSH, Self); + R.Arg1 := Arg1; + R.Arg2 := 0; // param number + R.Res := SubId; + + Insert(N, R); + + R := TCodeRec.Create(OP_PUSH, Self); + if Arg2 = 0 then + R.Arg1 := CreateConst(typeINTEGER, 0) + else + R.Arg1 := Arg2; + R.Arg2 := 1; // param number + R.Res := SubId; + + Insert(N + 1, R); + end; + typeSHORTSTRING: + begin + SubId := Id_WriteShortString; + + if SubId = 0 then + RaiseError(errInternalError, []); + + if Res <> 0 then + CreateError(errIllegalTypeInWriteStatememt, []); + + R.Op := OP_CALL; + R.Arg1 := SubId; + R.Arg2 := 2; + R.Res := 0; + + R := TCodeRec.Create(OP_PUSH, Self); + R.Arg1 := Arg1; + R.Arg2 := 0; // param number + R.Res := SubId; + + Insert(N, R); + + R := TCodeRec.Create(OP_PUSH, Self); + if Arg2 = 0 then + R.Arg1 := CreateConst(typeINTEGER, 0) + else + R.Arg1 := Arg2; + R.Arg2 := 1; // param number + R.Res := SubId; + + Insert(N + 1, R); + end; + typeWIDESTRING, typePWIDECHAR: + begin + SubId := Id_WriteWideString; + + if Res <> 0 then + CreateError(errIllegalTypeInWriteStatememt, []); + + R.Op := OP_CALL; + R.Arg1 := SubId; + R.Arg2 := 2; + R.Res := 0; + + R := TCodeRec.Create(OP_PUSH, Self); + R.Arg1 := Arg1; + R.Arg2 := 0; // param number + R.Res := SubId; + + Insert(N, R); + + R := TCodeRec.Create(OP_PUSH, Self); + if Arg2 = 0 then + R.Arg1 := CreateConst(typeINTEGER, 0) + else + R.Arg1 := Arg2; + R.Arg2 := 1; // param number + R.Res := SubId; + + Insert(N + 1, R); + end; +{$ENDIF} + typeUNICSTRING: + begin + SubId := Id_WriteUnicString; + + if Res <> 0 then + CreateError(errIllegalTypeInWriteStatememt, []); + + R.Op := OP_CALL; + R.Arg1 := SubId; + R.Arg2 := 2; + R.Res := 0; + + R := TCodeRec.Create(OP_PUSH, Self); + R.Arg1 := Arg1; + R.Arg2 := 0; // param number + R.Res := SubId; + + Insert(N, R); + + R := TCodeRec.Create(OP_PUSH, Self); + if Arg2 = 0 then + R.Arg1 := CreateConst(typeINTEGER, 0) + else + R.Arg1 := Arg2; + R.Arg2 := 1; // param number + R.Res := SubId; + + Insert(N + 1, R); + end; + typeDOUBLE: + begin + SubId := Id_WriteDouble; + + R.Op := OP_CALL; + R.Arg1 := SubId; + R.Arg2 := 3; + R.Res := 0; + + R := TCodeRec.Create(OP_PUSH, Self); + R.Arg1 := Arg1; + R.Arg2 := 0; // param number + R.Res := SubId; + Insert(N, R); + + R := TCodeRec.Create(OP_PUSH, Self); + if Arg2 = 0 then + R.Arg1 := CreateConst(typeINTEGER, 0) + else + R.Arg1 := Arg2; + R.Arg2 := 1; // param number + R.Res := SubId; + Insert(N + 1, R); + + R := TCodeRec.Create(OP_PUSH, Self); + if Res = 0 then + R.Arg1 := CreateConst(typeINTEGER, 0) + else + R.Arg1 := Res; + R.Arg2 := 2; // param number + R.Res := SubId; + Insert(N + 2, R); + end; + typeSINGLE: + begin + SubId := Id_WriteSingle; + + R.Op := OP_CALL; + R.Arg1 := SubId; + R.Arg2 := 3; + R.Res := 0; + + R := TCodeRec.Create(OP_PUSH, Self); + R.Arg1 := Arg1; + R.Arg2 := 0; // param number + R.Res := SubId; + Insert(N, R); + + R := TCodeRec.Create(OP_PUSH, Self); + if Arg2 = 0 then + R.Arg1 := CreateConst(typeINTEGER, 0) + else + R.Arg1 := Arg2; + R.Arg2 := 1; // param number + R.Res := SubId; + Insert(N + 1, R); + + R := TCodeRec.Create(OP_PUSH, Self); + if Res = 0 then + R.Arg1 := CreateConst(typeINTEGER, 0) + else + R.Arg1 := Res; + R.Arg2 := 2; // param number + R.Res := SubId; + Insert(N + 2, R); + + end; + typeCURRENCY: + begin + SubId := Id_WriteCurrency; + + R.Op := OP_CALL; + R.Arg1 := SubId; + R.Arg2 := 3; + R.Res := 0; + + R := TCodeRec.Create(OP_PUSH, Self); + R.Arg1 := Arg1; + R.Arg2 := 0; // param number + R.Res := SubId; + Insert(N, R); + + R := TCodeRec.Create(OP_PUSH, Self); + if Arg2 = 0 then + R.Arg1 := CreateConst(typeINTEGER, 0) + else + R.Arg1 := Arg2; + R.Arg2 := 1; // param number + R.Res := SubId; + Insert(N + 1, R); + + R := TCodeRec.Create(OP_PUSH, Self); + if Res = 0 then + R.Arg1 := CreateConst(typeINTEGER, 0) + else + R.Arg1 := Res; + R.Arg2 := 2; // param number + R.Res := SubId; + Insert(N + 2, R); + + end; + typeEXTENDED: + begin + SubId := Id_WriteExtended; + + R.Op := OP_CALL; + R.Arg1 := SubId; + R.Arg2 := 3; + R.Res := 0; + + R := TCodeRec.Create(OP_PUSH, Self); + R.Arg1 := Arg1; + R.Arg2 := 0; // param number + R.Res := SubId; + Insert(N, R); + + R := TCodeRec.Create(OP_PUSH, Self); + if Arg2 = 0 then + R.Arg1 := CreateConst(typeINTEGER, 0) + else + R.Arg1 := Arg2; + R.Arg2 := 1; // param number + R.Res := SubId; + Insert(N + 1, R); + + R := TCodeRec.Create(OP_PUSH, Self); + if Res = 0 then + R.Arg1 := CreateConst(typeINTEGER, 0) + else + R.Arg1 := Res; + R.Arg2 := 2; // param number + R.Res := SubId; + Insert(N + 2, R); + + end; + typeVARIANT, typeOLEVARIANT: + begin + SubId := Id_WriteVariant; + + R.Op := OP_CALL; + R.Arg1 := SubId; + R.Arg2 := 3; + R.Res := 0; + + R := TCodeRec.Create(OP_PUSH, Self); + R.Arg1 := Arg1; + R.Arg2 := 0; // param number + R.Res := SubId; + Insert(N, R); + + R := TCodeRec.Create(OP_PUSH, Self); + if Arg2 = 0 then + R.Arg1 := CreateConst(typeINTEGER, 0) + else + R.Arg1 := Arg2; + R.Arg2 := 1; // param number + R.Res := SubId; + Insert(N + 1, R); + + R := TCodeRec.Create(OP_PUSH, Self); + if Res = 0 then + R.Arg1 := CreateConst(typeINTEGER, 0) + else + R.Arg1 := Res; + R.Arg2 := 2; // param number + R.Res := SubId; + Insert(N + 2, R); + end; + else + CreateError(errIllegalTypeInWriteStatememt, []); + end; + end + else + CreateError(errIllegalTypeInWriteStatememt, []); +end; + +procedure TCode.OperDetermineType; +var + I, Id, DestId, DestTypeId, SubId, ParamNumber: Integer; +begin + Id := Records[N].Arg1; + for I := N to Card do + if Records[I].Op = OP_CALL then + begin + if (Records[I].Res = Id) and (Records[I].Arg1 <> Id_FWArray_Create) then + begin + DestId := Records[I].Arg1; + DestTypeId := GetSymbolRec(DestId).TypeId; + + if DestTypeId = 0 then + begin + RaiseError(errIncompatibleTypesNoArgs, []); + end; + + DestTypeId := GetSymbolRec(DestId).TerminalTypeId; + + if GetSymbolRec(DestTypeId).FinalTypeId = typeOPENARRAY then + begin + DestTypeId := TKernel(kernel).SymbolTable.RegisterDynamicArrayType(0, + '', GetSymbolRec(DestTypeId).PatternId); + end; + + GetSymbolRec(Id).TypeId := DestTypeId; + Exit; + end; + end + else if Records[I].Op = OP_ASSIGN then + begin + if Records[I].Arg2 = Id then + begin + DestId := Records[I].Arg1; + DestTypeId := GetSymbolRec(DestId).TypeId; + if DestTypeId = 0 then + begin + RaiseError(errIncompatibleTypesNoArgs, []); + end; + DestTypeId := GetSymbolRec(DestId).TerminalTypeId; + + if GetSymbolRec(DestTypeId).FinalTypeId = typeOPENARRAY then + begin + DestTypeId := TKernel(kernel).SymbolTable.RegisterDynamicArrayType(0, + '', GetSymbolRec(DestTypeId).PatternId); + end; + + GetSymbolRec(Id).TypeId := DestTypeId; + Records[N].Op := OP_NOP; + if Records[N + 1].Op = OP_PUSH_CLASSREF then + if Records[N + 1].Arg1 = 0 then + Records[N + 1].Arg1 := DestTypeId; + + Exit; + end; + end + else if Records[I].Op = OP_PUSH then + begin + if Records[I].Arg1 = Id then + begin + SubId := Records[I].Res; + ParamNumber := Records[I].Arg2; + DestId := TKernel(kernel).SymbolTable.GetParamId(SubId, ParamNumber); + DestTypeId := GetSymbolRec(DestId).TypeId; + if DestTypeId = 0 then + begin + RaiseError(errIncompatibleTypesNoArgs, []); + end; + DestTypeId := GetSymbolRec(DestId).TerminalTypeId; + + if GetSymbolRec(DestTypeId).FinalTypeId = typeOPENARRAY then + begin + DestTypeId := TKernel(kernel).SymbolTable.RegisterDynamicArrayType(0, + '', GetSymbolRec(DestTypeId).PatternId); + end; + + GetSymbolRec(Id).TypeId := DestTypeId; + Records[N].Op := OP_NOP; + + if Records[N + 1].Op = OP_PUSH_CLASSREF then + if Records[N + 1].Arg1 = 0 then + Records[N + 1].Arg1 := DestTypeId; + + Exit; + end; + end; + + RaiseError(errIncompatibleTypesNoArgs, []); +end; + +procedure TCode.OperCreateShortStringType; +var + K2, T2: Integer; + R: TCodeRec; +begin + R := Records[N]; + + T2 := GetSymbolRec(R.Arg2).FinalTypeId; + K2 := GetSymbolRec(R.Arg2).Kind; + + R.Op := OP_NOP; + + if not(T2 in IntegerTypes) then + begin + CreateError(errIncompatibleTypesNoArgs, []); + Exit; + end; + + if K2 <> KindCONST then + begin + CreateError(errConstantExpressionExpected, []); + Exit; + end; + + GetSymbolRec(R.Arg1).Count := GetSymbolRec(R.Arg2).value; +end; + +procedure TCode.OperCheckSubrangeType; +var + SymbolTable: TSymbolTable; + Arg1, Arg2, T1, T2: Integer; + R: TCodeRec; + B1, B2: Integer; +begin + SymbolTable := TKernel(kernel).SymbolTable; + + R := Records[N]; + + Arg1 := R.Arg1; + Arg2 := R.Arg2; + + T1 := GetSymbolRec(Arg1).FinalTypeId; + T2 := GetSymbolRec(Arg2).FinalTypeId; + + if T1 <> T2 then + begin + T1 := GetSymbolRec(Arg1).TypeId; + T2 := GetSymbolRec(Arg2).TypeId; + CreateError(errIncompatibleTypes, [GetSymbolRec(T1).Name, + GetSymbolRec(T2).Name]); + end; + + B1 := SymbolTable[Arg1].value; + B2 := SymbolTable[Arg2].value; + if B1 > B2 then + CreateError(errLowBoundExceedsHighBound, []); + + R.Op := OP_NOP; +end; + +procedure TCode.OperAssignEnum; +var + Arg1, Arg2, T1, T2, K2: Integer; + R: TCodeRec; +begin + R := Records[N]; + + Arg1 := R.Arg1; + Arg2 := R.Arg2; + T1 := GetSymbolRec(Arg1).FinalTypeId; + T2 := GetSymbolRec(Arg2).FinalTypeId; + K2 := GetSymbolRec(Arg2).Kind; + + R.Op := OP_NOP; + + if K2 <> KindCONST then + if T2 <> typeENUM then + begin + CreateError(errConstantExpressionExpected, []); + Exit; + end; + + if (T1 = typeENUM) and (T2 in (IntegerTypes + [typeENUM])) then + begin + GetSymbolRec(Arg1).value := GetSymbolRec(Arg2).value; + GetSymbolRec(Arg1).Kind := KindCONST; + end + else + begin + T1 := GetSymbolRec(Arg1).TypeId; + T2 := GetSymbolRec(Arg2).TypeId; + CreateError(errIncompatibleTypes, [GetSymbolRec(T1).Name, + GetSymbolRec(T2).Name]); + end; +end; + +function TCode.MatchSetTypes(T1, T2: Integer): Boolean; +begin + T1 := GetSymbolRec(T1).PatternId; + T2 := GetSymbolRec(T2).PatternId; + + if T1 = T2 then + begin + result := true; + Exit; + end; + + result := ExistsOrdinalRelationalOperator(T1, T2) or (T1 = typeVOID) or + // empty set + (T2 = typeVOID); // not empty set +end; + +procedure TCode.CreateSetObject(Id: Integer); +var + I, J, temp, K, B1, B2: Integer; + SetObject: TSetObject; + ByteSet: TByteSet; +begin + ByteSet := []; + + for I := 1 to Card do + begin + if Records[I].Op = OP_STMT then + break; + + if (Records[I].Op = OP_SET_INCLUDE) and (Records[I].Arg1 = Id) then + begin + temp := Records[I].Arg2; + K := GetSymbolRec(temp).Kind; + if K = KindCONST then + begin + if TVarData(GetSymbolRec(temp).value).VType in IntegerVariantTypes then + ByteSet := ByteSet + [Integer(GetSymbolRec(temp).value)] + else + begin + N := I; + RaiseError(errIncompatibleTypesNoArgs, []); + end; + end + else + Exit; + end + else if (Records[I].Op = OP_SET_INCLUDE_INTERVAL) and (Records[I].Arg1 = Id) + then + begin + temp := Records[I].Arg2; + K := GetSymbolRec(temp).Kind; + if K <> KindCONST then + Exit; + B1 := GetSymbolRec(temp).value; + + temp := Records[I].Res; + K := GetSymbolRec(temp).Kind; + if K <> KindCONST then + Exit; + B2 := GetSymbolRec(temp).value; + + for J := B1 to B2 do + ByteSet := ByteSet + [J]; + end; + end; + + if ByteSet <> [] then + begin + SetObject := TSetObject.Create(TKernel(kernel).SymbolTable, ByteSet, + GetSymbolRec(Id).TypeId, TKernel(kernel).SymbolTable.GetTypeBase + (GetSymbolRec(Id).TypeId)); + GetSymbolRec(Id).value := VarObjectToVariant(SetObject); + GetSymbolRec(Id).Kind := KindCONST; + end; +end; + +procedure TCode.OperSizeOf; +var + R: TCodeRec; + T, SZ: Integer; +begin + R := Records[N]; + if GetSymbolRec(R.Arg1).FinalTypeId = typePOINTER then + begin + if GetSymbolRec(R.Arg1).Kind = KindTYPE then + T := typePOINTER + else + T := GetSymbolRec(GetSymbolRec(R.Arg1).TerminalTypeId).PatternId; + end + else + T := GetSymbolRec(R.Arg1).TerminalTypeId; + + SZ := GetSymbolRec(T).Size; + if SZ > 0 then + begin + GetSymbolRec(R.Res).value := SZ; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + end; +end; + +procedure TCode.OperAssignmentConst; +var + Arg1, Arg2, T1, T2, K1, K2: Integer; + R: TCodeRec; +begin + R := Records[N]; + + Arg1 := R.Arg1; + Arg2 := R.Arg2; + T1 := GetSymbolRec(Arg1).FinalTypeId; + T2 := GetSymbolRec(Arg2).FinalTypeId; + + if T2 = typeSET then + CreateSetObject(Arg2); + + K1 := GetSymbolRec(Arg1).Kind; + K2 := GetSymbolRec(Arg2).Kind; + + R.Op := OP_NOP; + + if K2 <> KindCONST then + begin + if TKernel(kernel).InterfaceOnly then + Exit; + + // CreateError(errConstantExpressionExpected, []); + // Exit; + end; + + if (T1 in [0, typeENUM]) and (T2 = typeENUM) then + begin + GetSymbolRec(Arg1).value := GetSymbolRec(Arg2).value; + if T1 = 0 then + GetSymbolRec(Arg1).TypeId := GetSymbolRec(Arg2).TypeId; + end + else if (T1 in [0, typeBOOLEAN]) and (T2 in BooleanTypes) then + begin + GetSymbolRec(Arg1).value := Boolean(GetSymbolRec(Arg2).value); + if T1 = 0 then + GetSymbolRec(Arg1).TypeId := typeBOOLEAN; + end + else if (T1 in [0, typeBYTEBOOL]) and (T2 in BooleanTypes) then + begin +{$IFDEF UNIX} + GetSymbolRec(Arg1).value := Boolean(GetSymbolRec(Arg2).value); +{$ELSE} + GetSymbolRec(Arg1).value := ByteBool(Byte(GetSymbolRec(Arg2).value)); +{$ENDIF} + if T1 = 0 then + GetSymbolRec(Arg1).TypeId := typeBYTEBOOL; + end + else if (T1 in [0, typeWORDBOOL]) and (T2 in BooleanTypes) then + begin + GetSymbolRec(Arg1).value := WordBool(GetSymbolRec(Arg2).value); + if T1 = 0 then + GetSymbolRec(Arg1).TypeId := typeWORDBOOL; + end + else if (T1 in [0, typeLONGBOOL]) and (T2 in BooleanTypes) then + begin + GetSymbolRec(Arg1).value := LongBool(GetSymbolRec(Arg2).value); + if T1 = 0 then + GetSymbolRec(Arg1).TypeId := typeLONGBOOL; + end +{$IFNDEF PAXARM} + else if (T1 in [0, typeANSICHAR]) and (T2 in CharTypes) then + begin + GetSymbolRec(Arg1).value := GetSymbolRec(Arg2).value; + if T1 = 0 then + GetSymbolRec(Arg1).TypeId := typeANSICHAR; + end +{$ENDIF} + else if (T1 in [0, typeWIDECHAR]) and (T2 in CharTypes) then + begin + GetSymbolRec(Arg1).value := GetSymbolRec(Arg2).value; + if T1 = 0 then + GetSymbolRec(Arg1).TypeId := typeWIDECHAR; + end + else if (T1 in [0, typeINTEGER]) and (T2 in IntegerTypes) then + begin + GetSymbolRec(Arg1).value := GetSymbolRec(Arg2).value; + if T1 = 0 then + begin + if Abs(GetSymbolRec(Arg1).value) > MaxInt then + GetSymbolRec(Arg1).TypeId := typeINT64 + else + GetSymbolRec(Arg1).TypeId := typeINTEGER; + end; + CheckSubrangeBounds(GetSymbolRec(Arg1).TypeId, GetSymbolRec(Arg2)); + end + else if (T1 in [0, typeBYTE]) and (T2 in IntegerTypes) then + begin + GetSymbolRec(Arg1).value := GetSymbolRec(Arg2).value; + if T1 = 0 then + GetSymbolRec(Arg1).TypeId := typeBYTE; + CheckSubrangeBounds(GetSymbolRec(Arg1).TypeId, GetSymbolRec(Arg2)); + end + else if (T1 in [0, typeWORD]) and (T2 in IntegerTypes) then + begin + GetSymbolRec(Arg1).value := GetSymbolRec(Arg2).value; + if T1 = 0 then + GetSymbolRec(Arg1).TypeId := typeWORD; + CheckSubrangeBounds(GetSymbolRec(Arg1).TypeId, GetSymbolRec(Arg2)); + end + else if (T1 in [0, typeDOUBLE]) and + (T2 in (IntegerTypes + RealTypes + [typeCURRENCY] + VariantTypes)) then + begin + GetSymbolRec(Arg1).value := GetSymbolRec(Arg2).value; + if T1 = 0 then + GetSymbolRec(Arg1).TypeId := typeDOUBLE; + end + else if (T1 in [0, typeCURRENCY]) and + (T2 in (IntegerTypes + RealTypes + [typeCURRENCY] + VariantTypes)) then + begin + GetSymbolRec(Arg1).value := GetSymbolRec(Arg2).value; + if T1 = 0 then + GetSymbolRec(Arg1).TypeId := typeCURRENCY; + end + else if (T1 in [0, typeSINGLE]) and + (T2 in (IntegerTypes + RealTypes + [typeCURRENCY] + VariantTypes)) then + begin + GetSymbolRec(Arg1).value := Single(GetSymbolRec(Arg2).value); + if T1 = 0 then + GetSymbolRec(Arg1).TypeId := typeSINGLE; + end + else if (T1 in [0, typeEXTENDED]) and + (T2 in (IntegerTypes + RealTypes + [typeCURRENCY] + VariantTypes)) then + begin + GetSymbolRec(Arg1).value := Single(GetSymbolRec(Arg2).value); + if T1 = 0 then + GetSymbolRec(Arg1).TypeId := typeEXTENDED; + end + +{$IFNDEF PAXARM} + else if (T1 in [0, typeANSISTRING]) and (T2 = typeANSISTRING) then + begin + GetSymbolRec(Arg1).value := GetSymbolRec(Arg2).value; + if T1 = 0 then + GetSymbolRec(Arg1).TypeId := typeANSISTRING; + end + else if (T1 in [0, typeANSISTRING, typeWIDESTRING, typeSHORTSTRING]) and + GetSymbolRec(Arg2).HasPAnsiCharType then + begin + GetSymbolRec(Arg1).value := GetSymbolRec(Arg2).value; + if T1 = 0 then + begin + if K1 = KindCONST then + GetSymbolRec(Arg1).TypeId := typePANSICHAR + else + GetSymbolRec(Arg1).TypeId := typeANSISTRING; + end; + end + else if (T1 in [0, typeANSISTRING, typeWIDESTRING, typeSHORTSTRING]) and + (T2 = typeANSICHAR) then + begin + GetSymbolRec(Arg1).value := GetSymbolRec(Arg2).value; + if T1 = 0 then + begin + if K1 = KindCONST then + GetSymbolRec(Arg1).TypeId := typePANSICHAR + else + GetSymbolRec(Arg1).TypeId := typeANSISTRING; + end; + end +{$ENDIF} + // unic string + + else if (T1 in [0, typeUNICSTRING]) and (T2 = typeUNICSTRING) then + begin + GetSymbolRec(Arg1).value := GetSymbolRec(Arg2).value; + if T1 = 0 then + GetSymbolRec(Arg1).TypeId := typeUNICSTRING; + end + else if (T1 in ([0] + StringTypes)) and (T2 in CharTypes) then + begin + GetSymbolRec(Arg1).value := Chr(Integer(GetSymbolRec(Arg2).value)); + if T1 = 0 then + begin + if K1 = KindCONST then +{$IFDEF PAXARM} + GetSymbolRec(Arg1).TypeId := typePWIDECHAR +{$ELSE} + GetSymbolRec(Arg1).TypeId := typePANSICHAR +{$ENDIF} + else + GetSymbolRec(Arg1).TypeId := typeSTRING; + end; + end +{$IFNDEF PAXARM} + else if (T1 in ([0] + StringTypes)) and GetSymbolRec(Arg2).HasPAnsiCharType + then + begin + GetSymbolRec(Arg1).value := GetSymbolRec(Arg2).value; + if T1 = 0 then + begin + if K1 = KindCONST then + GetSymbolRec(Arg1).TypeId := typePANSICHAR + else + GetSymbolRec(Arg1).TypeId := typeANSISTRING; + end; + end +{$ENDIF} + else if (T1 in ([0] + StringTypes)) and GetSymbolRec(Arg2).HasPWideCharType + then + begin + GetSymbolRec(Arg1).value := GetSymbolRec(Arg2).value; + if T1 = 0 then + begin + if K1 = KindCONST then + GetSymbolRec(Arg1).TypeId := typePWIDECHAR + else +{$IFDEF UNIC} + GetSymbolRec(Arg1).TypeId := typeUNICSTRING; +{$ELSE} + GetSymbolRec(Arg1).TypeId := typeWIDESTRING; +{$ENDIF} + end; + end + + else if (T1 in [0, typeSET]) and (T2 = typeSET) then + begin + if T1 = 0 then + GetSymbolRec(Arg1).TypeId := GetSymbolRec(Arg2).TypeId; + + GetSymbolRec(Arg1).value := GetSymbolRec(Arg2).value; + end + else if (T1 in [0, typePOINTER]) and (T2 = typePOINTER) then + begin + T1 := GetSymbolRec(Arg1).TypeId; + + if T1 = 0 then + GetSymbolRec(Arg1).TypeId := GetSymbolRec(Arg2).TypeId; + + GetSymbolRec(Arg1).value := GetSymbolRec(Arg2).value; + end + else if T1 = typeINTERFACE then + begin + if T2 = typeCLASS then + R.Op := OP_INTERFACE_FROM_CLASS + else if T2 = typeINTERFACE then + R.Op := OP_ASSIGN_INTERFACE + else if Arg2 = TKernel(kernel).SymbolTable.NilId then + begin + R.Op := OP_INTERFACE_CLR; + GetSymbolRec(Arg1).value := 0; + end; + end + else if T1 = typeCLASS then + begin + if Arg2 = TKernel(kernel).SymbolTable.NilId then + GetSymbolRec(Arg1).value := 0; + end + else if T1 = typeCLASSREF then + begin + if Arg2 = TKernel(kernel).SymbolTable.NilId then + GetSymbolRec(Arg1).value := 0; + end + else + begin + if GetSymbolRec(Arg1).Param then + CreateError(errParameterCannotHaveDefaultValue, []) + else + begin + T1 := GetSymbolRec(Arg1).TypeId; + T2 := GetSymbolRec(Arg2).TypeId; + + CreateError(errIncompatibleTypes, [GetSymbolRec(T1).Name, + GetSymbolRec(T2).Name]); + end; + end; +end; + +procedure TCode.OperOleValue; +var + R, RC: TCodeRec; + Arg1, T1: Integer; + PropNameId: Integer; + I: Integer; +begin + R := Records[N]; + + PropNameId := R.Res; + + Arg1 := R.Arg1; + T1 := GetSymbolRec(Arg1).FinalTypeId; + if not(T1 in VariantTypes) then + begin + RC := InsertConversionToVariant(N, 1); + + for I := N + 1 to Card do + begin + if Records[I].Op = OP_STMT then + break; + + if Records[I].Op = OP_OLE_SET then + if Records[I].Arg2 = PropNameId then + Records[I].Res := RC.Res; + end; + + Inc(N); + end; + R.Op := OP_NOP; +end; + +procedure TCode.OperOleParam; +var + R, RC, RI: TCodeRec; + Arg1, T1: Integer; + PropNameId: Integer; + I: Integer; + TempVarId, N1: Integer; +begin + R := Records[N]; + + PropNameId := R.Res; + + Arg1 := R.Arg1; + T1 := GetSymbolRec(Arg1).FinalTypeId; + if not(T1 in VariantTypes) then + begin + RC := InsertConversionToVariant(N, 1); + + TempVarId := RC.Arg1; + N1 := 0; + + for I := N + 1 to Card do + begin + RI := Records[I]; + + if RI.Op = OP_STMT then + break; + + if RI.Op = OP_OLE_SET then + begin + if RI.Arg2 = PropNameId then + begin + RI.Res := RC.Res; + break; + end; + end + else if RI.Op = OP_OLE_GET then + if RI.Arg2 = PropNameId then + begin + N1 := I; + break; + end; + + end; + + Inc(N); + + if N1 > 0 then + if GetSymbolRec(Arg1).Kind = KindVAR then + if not GetSymbolRec(Arg1).IsConst then + begin + RC := TCodeRec.Create(OP_ASSIGN, Self); + RC.Arg1 := Arg1; + RC.Arg2 := TempVarId; + RC.Res := Arg1; + Insert(N1 + 1, RC); + end; + end; +end; + +procedure TCode.OperBeginCrtJsFuncObject; +begin + CRT_JS_FUNC_OBJECT_SWITCH := true; +end; + +procedure TCode.OperEndCrtJsFuncObject; +begin + CRT_JS_FUNC_OBJECT_SWITCH := false; +end; + +procedure TCode.OperGetNextJSProp; +begin + GetSymbolRec(Records[N].Arg2).TypeId := typeSTRING; + GetSymbolRec(Records[N].Res).TypeId := typeBOOLEAN; +end; + +procedure TCode.OperJStypeof; +begin + if GetSymbolRec(Records[N].Arg1).FinalTypeId <> typeVARIANT then + begin + InsertConversionToVariant(N, 1); + Inc(N); + end; + + GetSymbolRec(Records[N].Arg1).TypeId := typeVARIANT; + GetSymbolRec(Records[N].Res).TypeId := typeSTRING; +end; + +procedure TCode.OperJSvoid; +begin + if GetSymbolRec(Records[N].Arg1).FinalTypeId <> typeVARIANT then + begin + InsertConversionToVariant(N, 1); + Inc(N); + end; + + GetSymbolRec(Records[N].Arg1).TypeId := typeVARIANT; + GetSymbolRec(Records[N].Res).TypeId := typeVOID; +end; + +procedure TCode.OperFindConstructor; +var + R, RC, RCall: TCodeRec; + TypeId, SubId, I, ObjectId, AddressId, FunctionConstructorId, + InternalLengthId, NN, CallRefId: Integer; + P: TIntegerList; + S: String; +begin + R := Records[N]; + + TypeId := R.Arg1; + if TKernel(kernel).SymbolTable[TypeId].TypeId = TypeALIAS then + TypeId := TKernel(kernel).SymbolTable[TypeId].TerminalTypeId; + + if R.Language = JS_LANGUAGE then + begin + if TKernel(kernel).SymbolTable[TypeId].Kind = KindVAR then + begin + S := TKernel(kernel).SymbolTable[TypeId].Name; + + I := TKernel(kernel).SymbolTable.LookUpTypeEx(S, JS_JavaScriptNamespace, + false, Types.Count); + if I > 0 then + begin + R.Arg1 := I; + TypeId := I; + end; + { + if S = 'Object' then + begin + R.Arg1 := JS_ObjectClassId; + TypeId := JS_ObjectClassId; + end; + } + end; + end; + + SubId := TKernel(kernel).SymbolTable.FindConstructorId(TypeId); + + if SubId = 0 then + begin + if R.Language = JS_LANGUAGE then + begin + R.Op := OP_FIELD; + with TKernel(kernel) do + begin + SymbolTable[R.Res].Name := strInternalCall; + SymbolTable[R.Res].OwnerId := R.Arg1; + end; + R.Arg2 := R.Res; + + ObjectId := R.Arg1; + CallRefId := R.Res; + + P := TIntegerList.Create; + I := N; + repeat + Inc(I); + if (Records[I].Op = OP_PUSH) and (Records[I].Res = CallRefId) then + begin + P.Add(I); + Inc(Records[I].Arg2, 1); + end; + if Records[I].Op = OP_CALL then + if Records[I].Arg1 = R.Res then + begin + break; + end; + until I = Card; + + if I = Card then + RaiseError(errConstructorNotFoundInClass, + [TKernel(kernel).SymbolTable[TypeId].Name]); + + RCall := Records[I]; + + RC := TCodeRec.Create(OP_PUSH, Self); + RC.Arg1 := CreateConst(typeINTEGER, P.Count); + RC.Arg2 := 0; + RC.Res := CallRefId; + Insert(N + 1, RC); + + FreeAndNil(P); + + NN := N - 1; + + FunctionConstructorId := NewTempVar(GetSymbolRec(R.Res).Level, + JS_FunctionClassId); + GetSymbolRec(FunctionConstructorId).OwnerId := JS_FunctionClassId; + GetSymbolRec(FunctionConstructorId).Name := strInternalCreate; + RC := TCodeRec.Create(OP_FIELD, Self); + RC.Arg1 := JS_FunctionClassId; + RC.Arg2 := FunctionConstructorId; + RC.Res := FunctionConstructorId; + Insert(N, RC); + Inc(N); + + AddressId := NewTempVar(GetSymbolRec(R.Res).Level, typePOINTER); + GetSymbolRec(AddressId).OwnerId := ObjectId; + GetSymbolRec(AddressId).Name := strInternalFuncAddr; + RC := TCodeRec.Create(OP_FIELD, Self); + RC.Arg1 := ObjectId; + RC.Arg2 := AddressId; + RC.Res := AddressId; + Insert(N, RC); + Inc(N); + + RC := TCodeRec.Create(OP_PUSH, Self); + RC.Arg1 := AddressId; + RC.Arg2 := 0; // the first arg + RC.Res := FunctionConstructorId; + Insert(N, RC); + Inc(N); + + InternalLengthId := NewTempVar(GetSymbolRec(R.Res).Level, typeINTEGER); + GetSymbolRec(InternalLengthId).OwnerId := ObjectId; + GetSymbolRec(InternalLengthId).Name := strInternalLength; + RC := TCodeRec.Create(OP_FIELD, Self); + RC.Arg1 := ObjectId; + RC.Arg2 := InternalLengthId; + RC.Res := InternalLengthId; + Insert(N, RC); + Inc(N); + + RC := TCodeRec.Create(OP_PUSH, Self); + RC.Arg1 := InternalLengthId; + RC.Arg2 := 1; // the second arg + RC.Res := FunctionConstructorId; + Insert(N, RC); + Inc(N); + + AddressId := NewTempVar(GetSymbolRec(R.Res).Level, typePOINTER); + RC := TCodeRec.Create(OP_ADDRESS_PROG, Self); + RC.Arg1 := 0; + RC.Arg2 := 0; + RC.Res := AddressId; + Insert(N, RC); + Inc(N); + + RC := TCodeRec.Create(OP_PUSH, Self); + RC.Arg1 := AddressId; + RC.Arg2 := 2; // the third arg + RC.Res := FunctionConstructorId; + Insert(N, RC); + Inc(N); + + ObjectId := NewTempVar(GetSymbolRec(R.Res).Level, JS_FunctionClassId); + RC := TCodeRec.Create(OP_CALL, Self); + RC.Arg1 := FunctionConstructorId; + RC.Arg2 := 3; + RC.Res := ObjectId; + Insert(N, RC); + Inc(N); + + R.Arg1 := ObjectId; + ReplaceIdEx(RCall.Res, ObjectId, N, Card, true); + RCall.Res := 0; + + N := NN; + + Exit; + end + else + RaiseError(errConstructorNotFoundInClass, + [TKernel(kernel).SymbolTable[TypeId].Name]); + end; + + R.Op := OP_FIELD; + with TKernel(kernel) do + begin + SymbolTable[R.Res].Name := SymbolTable[SubId].Name; + SymbolTable[R.Res].OwnerId := R.Arg1; + end; + R.Arg2 := R.Res; + Dec(N); +end; + +function TCode.CheckAssignment(Arg1, Arg2: Integer): Boolean; +var + T1, T2: Integer; + SymbolTable: TSymbolTable; +begin + result := true; + + SymbolTable := TKernel(kernel).SymbolTable; + T1 := GetSymbolRec(Arg1).TerminalTypeId; + T2 := GetSymbolRec(Arg2).TerminalTypeId; + + if T1 = T2 then + Exit; + + if IsJSType(T1, SymbolTable) and IsJSType(T2, SymbolTable) and + (GetSymbolRec(Arg1).Name <> '') and + (GetSymbolRec(Arg1).Name <> strInternalConstructor) and + (GetSymbolRec(Arg2).Name <> '') then + Exit; + + if SymbolTable.Inherits(T2, T1) then + Exit; + + result := false; +end; + +procedure TCode.OperAssignment; + + function IsFuncResult(Id: Integer): Boolean; + var + I: Integer; + begin + result := false; + I := N - 1; + if I <= 0 then + Exit; + while I > 0 do + begin + if Records[I].Op = OP_SEPARATOR then + Dec(I) + else if Records[I].Op = OP_LVALUE then + Dec(I) + else if Records[I].Op = OP_CALL then + begin + result := Records[I].Res = Id; + Exit; + end + else + Exit; + end; + end; + + function IsConstElement(Id: Integer): Boolean; + var + RC: TCodeRec; + I: Integer; + begin + result := false; + RC := PrevRec(N); + if RC <> nil then + begin + if RC.Op = OP_ELEM then + begin + if RC.Res = Id then + if GetSymbolRec(RC.Arg1).IsConst then + result := true; + end + else if RC.Op = OP_LVALUE then + begin + I := N; + while Records[I] <> RC do + Dec(I); + RC := PrevRec(I); + if RC.Op = OP_ELEM then + if RC.Res = Id then + if GetSymbolRec(RC.Arg1).IsConst then + result := true; + end; + end; + end; + +var + Arg1, Arg2, T1, T2, K1, K2: Integer; + R, RC: TCodeRec; + SubId1, SubId2: Integer; +{$IFNDEF PAXARM} + S: String; +{$ENDIF} + SymbolTable: TSymbolTable; + SignTypeCast1: Boolean; + b: Boolean; + OverList: TIntegerList; + I: Integer; +label + ok, err; +begin + SignTypeCast1 := SignTypeCast; + SignTypeCast := false; + SymbolTable := TKernel(kernel).SymbolTable; + + R := Records[N]; + + Arg1 := R.Arg1; + Arg2 := R.Arg2; + T1 := GetSymbolRec(Arg1).FinalTypeId; + T2 := GetSymbolRec(Arg2).FinalTypeId; + + if R.Arg1 = TKernel(kernel).SymbolTable.ResultId then + begin + GetSymbolRec(Arg1).TypeId := GetSymbolRec(Arg2).TypeId; + T1 := T2; + end; + + if T2 = typeSET then + begin + if T1 <> typeDYNARRAY then + CreateSetObject(Arg2); + end; + + K1 := GetSymbolRec(Arg1).Kind; + K2 := GetSymbolRec(Arg2).Kind; + + if not SkipCheckFinal then + begin + if GetSymbolRec(Arg1).IsFinal then + K1 := KindCONST + else + begin + if GetSymbolRec(Arg1).PatternId > 0 then + if GetSymbolRec(GetSymbolRec(Arg1).PatternId).IsFinal then + K1 := KindCONST; + end; + end; + + if (T1 = typeENUM) and (T2 = typeENUM) then + begin + T1 := GetSymbolRec(Arg1).TypeId; + T2 := GetSymbolRec(Arg2).TypeId; + + T1 := GetSymbolRec(T1).PatternId; + T2 := GetSymbolRec(T2).PatternId; + + if GetSymbolRec(Arg1).HasSubrangeEnumType then // enum subrange type + begin + T1 := GetSymbolRec(Arg1).TypeId + 1; + T1 := GetSymbolRec(T1).TypeId; + T1 := GetSymbolRec(T1).PatternId; + end; + + if GetSymbolRec(Arg2).HasSubrangeEnumType then // enum subrange type + begin + T2 := GetSymbolRec(Arg1).TypeId + 1; + T2 := GetSymbolRec(T2).TypeId; + T2 := GetSymbolRec(T2).PatternId; + end; + end; + + if GetSymbolRec(Arg1).IsConst then + CreateError(errLeftSideCannotBeAssignedTo, []); + + if IsConstElement(Arg1) then + CreateError(errLeftSideCannotBeAssignedTo, []); + + if IsFuncResult(Arg1) then + CreateError(errLeftSideCannotBeAssignedTo, []); + + if TKernel(kernel).InterfaceOnly then + begin + if (T1 = 0) or (T2 = 0) then + begin + R.Op := OP_NOP; + Exit; + end; + end; + + if not((K1 = KindVAR) and (K2 in [KindVAR, KindCONST])) then + begin + if (T1 = typePROC) and (K2 = KindSUB) then + goto ok; + + if (T1 = typeCLASSREF) and (K2 = KindTYPE) then + goto ok; + + if T2 = typeINTERFACE then + goto ok; + + if Arg2 = SymbolTable.NilId then + goto ok; + + CreateError(errLeftSideCannotBeAssignedTo, []); + Exit; + end; + +ok: + + if T1 = 0 then + begin + if (R.Language = JS_LANGUAGE) and (T2 = typeINTERFACE) then + begin + T1 := typeVARIANT; // ole + GetSymbolRec(Arg1).TypeId := typeVARIANT; + end + else + begin + T1 := T2; + GetSymbolRec(Arg1).TypeId := GetSymbolRec(Arg2).TypeId; + if +{$IFNDEF PAXARM} + GetSymbolRec(Arg2).HasPAnsiCharType or +{$ENDIF} + GetSymbolRec(Arg2).HasPWideCharType then + begin + T1 := typeSTRING; + GetSymbolRec(Arg1).TypeId := T1; + end; + end; + end; + + if (T1 = typeTYPEPARAM) and (T2 = typeTYPEPARAM) then + begin + R.Op := OP_ERR_ABSTRACT; + end + else if (T1 = typeENUM) and (T2 = typeENUM) then + begin + R.Op := OP_ASSIGN_INT_M; + end + else if (T1 = typeINTEGER) and (T2 = typeINT64) then + begin + R.Op := OP_INT_FROM_INT64; + end + else if (T1 = typeINTEGER) and (T2 = typeUINT64) then + begin + R.Op := OP_INT_FROM_UINT64; + end + else if (T1 = typeBYTE) and (T2 = typeINT64) then + begin + R.Op := OP_BYTE_FROM_INT64; + end + else if (T1 = typeBYTE) and (T2 = typeUINT64) then + begin + R.Op := OP_BYTE_FROM_UINT64; + end + else if (T1 = typeWORD) and (T2 = typeINT64) then + begin + R.Op := OP_WORD_FROM_INT64; + end + else if (T1 = typeWORD) and (T2 = typeUINT64) then + begin + R.Op := OP_WORD_FROM_UINT64; + end + else if (T1 = typeCARDINAL) and (T2 = typeINT64) then + begin + R.Op := OP_CARDINAL_FROM_INT64; + end + else if (T1 = typeCARDINAL) and (T2 = typeUINT64) then + begin + R.Op := OP_CARDINAL_FROM_UINT64; + end + else if (T1 = typeSMALLINT) and (T2 = typeINT64) then + begin + R.Op := OP_SMALLINT_FROM_INT64; + end + else if (T1 = typeSMALLINT) and (T2 = typeUINT64) then + begin + R.Op := OP_SMALLINT_FROM_UINT64; + end + else if (T1 = typeSHORTINT) and (T2 = typeINT64) then + begin + R.Op := OP_SHORTINT_FROM_INT64; + end + else if (T1 = typeSHORTINT) and (T2 = typeUINT64) then + begin + R.Op := OP_SHORTINT_FROM_UINT64; + end + else if (T1 = typeBOOLEAN) and (T2 in BooleanTypes) then + begin + if K2 = KindVAR then + begin + R.Op := OP_ASSIGN_BYTE_M; + if T2 <> typeBOOLEAN then + begin + InsertConversionToBoolean(N, 2); + Inc(N); + end; + end + else + begin + if T2 <> typeBOOLEAN then + R.Arg2 := CreateConst(typeBOOLEAN, GetSymbolRec(R.Arg2).value); + R.Op := OP_ASSIGN_BYTE_I; + end; + end + else if (T1 = typeBYTEBOOL) and (T2 in BooleanTypes) then + begin + if K2 = KindVAR then + R.Op := OP_ASSIGN_BYTE_M + else + begin + if T2 <> typeBYTEBOOL then + R.Arg2 := CreateConst(typeBYTEBOOL, GetSymbolRec(R.Arg2).value); + R.Op := OP_ASSIGN_BYTE_I; + end; + end + else if (T1 = typeWORDBOOL) and (T2 in BooleanTypes) then + begin + if K2 = KindVAR then + R.Op := OP_ASSIGN_WORD_M + else + begin + if T2 <> typeWORDBOOL then + R.Arg2 := CreateConst(typeWORDBOOL, GetSymbolRec(R.Arg2).value); + R.Op := OP_ASSIGN_WORD_I; + end; + end + else if (T1 = typeLONGBOOL) and (T2 in BooleanTypes) then + begin + if K2 = KindVAR then + R.Op := OP_ASSIGN_INT_M + else + begin + if T2 <> typeLONGBOOL then + R.Arg2 := CreateConst(typeLONGBOOL, GetSymbolRec(R.Arg2).value); + R.Op := OP_ASSIGN_INT_I; + end; + end +{$IFNDEF PAXARM} + else if (T1 = typeANSICHAR) and (T2 = typeANSICHAR) then + begin + if K2 = KindVAR then + R.Op := OP_ASSIGN_BYTE_M + else + R.Op := OP_ASSIGN_BYTE_I; + end + else if (T1 = typeANSICHAR) and GetSymbolRec(Arg2).HasPAnsiCharType and + (K2 = KindCONST) then + begin + S := GetSymbolRec(Arg2).value; + if Length(S) = 1 then + begin + GetSymbolRec(Arg2).TypeId := typeANSICHAR; + GetSymbolRec(Arg2).value := Ord(S[1]); + R.Op := OP_ASSIGN_BYTE_I; + end + else + begin + T1 := GetSymbolRec(Arg1).TypeId; + T2 := GetSymbolRec(Arg2).TypeId; + CreateError(errIncompatibleTypes, [GetSymbolRec(T1).Name, + GetSymbolRec(T2).Name]); + Exit; + end; + end + else if (T1 = typeWIDECHAR) and (T2 = typeANSICHAR) then + begin + if K2 = KindCONST then + R.Op := OP_ASSIGN_WORD_I + else + R.Op := OP_ASSIGN_WORD_M; + end +{$ENDIF} + else if (T1 = typeWIDECHAR) and (T2 = typeWIDECHAR) then + begin + if K2 = KindVAR then + R.Op := OP_ASSIGN_WORD_M + else + R.Op := OP_ASSIGN_WORD_I; + end + else if (T1 = typeBYTE) and (T2 in IntegerTypes) then + begin + if K2 = KindVAR then + R.Op := OP_ASSIGN_BYTE_M + else + begin + R.Op := OP_ASSIGN_BYTE_I; + CheckSubrangeBounds(GetSymbolRec(Arg1).TypeId, GetSymbolRec(Arg2)); + end; + end + else if (T1 = typeWORD) and (T2 in IntegerTypes) then + begin + if K2 = KindVAR then + R.Op := OP_ASSIGN_WORD_M + else + begin + R.Op := OP_ASSIGN_WORD_I; + CheckSubrangeBounds(GetSymbolRec(Arg1).TypeId, GetSymbolRec(Arg2)); + end; + end + else if (T1 = typeINTEGER) and (T2 in IntegerTypes) then + begin + if K2 = KindVAR then + R.Op := OP_ASSIGN_INT_M + else + begin + R.Op := OP_ASSIGN_INT_I; + CheckSubrangeBounds(GetSymbolRec(Arg1).TypeId, GetSymbolRec(Arg2)); + end; + end + else if (T1 = typeCARDINAL) and (T2 in IntegerTypes) then + begin + if K2 = KindVAR then + R.Op := OP_ASSIGN_CARDINAL_M + else + begin + R.Op := OP_ASSIGN_CARDINAL_I; + CheckSubrangeBounds(GetSymbolRec(Arg1).TypeId, GetSymbolRec(Arg2)); + end; + end + else if (T1 = typeSMALLINT) and (T2 in IntegerTypes) then + begin + if K2 = KindVAR then + R.Op := OP_ASSIGN_SMALLINT_M + else + begin + R.Op := OP_ASSIGN_SMALLINT_I; + CheckSubrangeBounds(GetSymbolRec(Arg1).TypeId, GetSymbolRec(Arg2)); + end; + end + else if (T1 = typeSHORTINT) and (T2 in IntegerTypes) then + begin + if K2 = KindVAR then + R.Op := OP_ASSIGN_SHORTINT_M + else + begin + R.Op := OP_ASSIGN_SHORTINT_I; + CheckSubrangeBounds(GetSymbolRec(Arg1).TypeId, GetSymbolRec(Arg2)); + end; + end + else if (T1 = typeINTEGER) and (T2 in VariantTypes) then + begin + R.Op := OP_INT_FROM_VARIANT; + end + else if (T1 = typeWORD) and (T2 in VariantTypes) then + begin + R.Op := OP_WORD_FROM_VARIANT; + end + else if (T1 = typeBYTE) and (T2 in VariantTypes) then + begin + R.Op := OP_BYTE_FROM_VARIANT; + end + else if (T1 = typeBOOLEAN) and (T2 in VariantTypes) then + begin + R.Op := OP_BOOL_FROM_VARIANT; + end + else if (T1 = typeBYTEBOOL) and (T2 in VariantTypes) then + begin + R.Op := OP_BYTEBOOL_FROM_VARIANT; + end + else if (T1 = typeWORDBOOL) and (T2 in VariantTypes) then + begin + R.Op := OP_WORDBOOL_FROM_VARIANT; + end + else if (T1 = typeLONGBOOL) and (T2 in VariantTypes) then + begin + R.Op := OP_LONGBOOL_FROM_VARIANT; + end +{$IFNDEF PAXARM} + else if (T1 = typeANSISTRING) and GetSymbolRec(Arg2).HasPAnsiCharType then + begin + R.Op := OP_ANSISTRING_FROM_PANSICHAR; + end + else if (T1 = typeANSISTRING) and GetSymbolRec(Arg2).HasPWideCharType then + begin + R.Op := OP_ANSISTRING_FROM_PWIDECHAR; + end + else if (T1 = typeANSISTRING) and SymbolTable.IsZerobasedAnsiCharArray(Arg2) + then + begin + RC := TCodeRec.Create(OP_ADDRESS, Self); + RC.Arg1 := Arg2; + RC.Arg2 := 0; + RC.Res := CreatePointerVar(GetLevel(N)); + Insert(N, RC); + Inc(N); + + R.Op := OP_ANSISTRING_FROM_PANSICHAR; + R.Arg2 := RC.Res; + end + else if GetSymbolRec(Arg1).HasPAnsiCharType and + SymbolTable.IsZerobasedAnsiCharArray(Arg2) then + begin + RC := TCodeRec.Create(OP_ADDRESS, Self); + RC.Arg1 := Arg2; + RC.Arg2 := 0; + RC.Res := CreatePointerVar(GetLevel(N)); + Insert(N, RC); + Inc(N); + + R.Op := OP_ASSIGN_INT_M; + R.Arg2 := RC.Res; + end + else if (T1 = typeANSISTRING) and (T2 = typeANSISTRING) then + begin + if K2 = KindVAR then + R.Op := OP_ASSIGN_ANSISTRING + else + CreateError(errInternalError, []); + end + else if (T1 = typeANSISTRING) and (T2 in VariantTypes) then + begin + R.Op := OP_ANSISTRING_FROM_VARIANT; + end + else if (T1 = typeANSISTRING) and (T2 in CharTypes) then + begin + if K2 = KindVAR then + R.Op := OP_ANSISTRING_FROM_ANSICHAR + else + begin + if GetSymbolRec(Arg2).HasName then + begin + S := Chr(Integer(GetSymbolRec(Arg2).value)); + R.Arg2 := TKernel(kernel).SymbolTable.AddPAnsiCharConst + (AnsiString(S)).Id; + R.Op := OP_ANSISTRING_FROM_PANSICHAR; + end + else + begin + S := Chr(Integer(GetSymbolRec(Arg2).value)); + GetSymbolRec(Arg2).TypeId := typePANSICHAR; + GetSymbolRec(Arg2).value := S; + R.Op := OP_ANSISTRING_FROM_PANSICHAR; + end; + end; + end + else if (T1 = typeSHORTSTRING) and (GetSymbolRec(Arg2).HasPAnsiCharType) then + begin + if (K1 = KindVAR) and (K2 = KindCONST) then + R.Op := OP_SHORTSTRING_FROM_PANSICHAR_LITERAL + else + CreateError(errLeftSideCannotBeAssignedTo, []); + end + else if (T1 = typeSHORTSTRING) and (GetSymbolRec(Arg2).HasPWideCharType) then + begin + if (K1 = KindVAR) and (K2 = KindCONST) then + R.Op := OP_SHORTSTRING_FROM_PWIDECHAR_LITERAL + else + CreateError(errLeftSideCannotBeAssignedTo, []); + end + else if (T1 = typeSHORTSTRING) and (T2 = typeANSISTRING) then + begin + R.Op := OP_SHORTSTRING_FROM_ANSISTRING; + end + else if (T1 = typeSHORTSTRING) and (T2 in VariantTypes) then + begin + R.Op := OP_SHORTSTRING_FROM_VARIANT; + end + else if (T1 = typeSHORTSTRING) and (T2 = typeWIDESTRING) then + begin + R.Op := OP_SHORTSTRING_FROM_WIDESTRING; + end + else if (T1 = typeUNICSTRING) and (T2 = typeWIDESTRING) then + begin + R.Op := OP_UNICSTRING_FROM_WIDESTRING; + end + else if (T1 = typeSHORTSTRING) and (T2 = typeUNICSTRING) then + begin + R.Op := OP_SHORTSTRING_FROM_UNICSTRING; + end + else if (T1 = typeANSISTRING) and (T2 = typeSHORTSTRING) then + begin + R.Op := OP_ANSISTRING_FROM_SHORTSTRING; + end + else if (T1 = typeWIDESTRING) and (T2 = typeSHORTSTRING) then + begin + R.Op := OP_WIDESTRING_FROM_SHORTSTRING; + end + else if (T1 = typeWIDESTRING) and (T2 = typeUNICSTRING) then + begin + R.Op := OP_WIDESTRING_FROM_UNICSTRING; + end + else if (T1 = typeUNICSTRING) and (T2 = typeSHORTSTRING) then + begin + R.Op := OP_UNICSTRING_FROM_SHORTSTRING; + end + else if (T1 = typeANSISTRING) and (T2 = typeWIDESTRING) then + begin + R.Op := OP_ANSISTRING_FROM_WIDESTRING; + end + else if (T1 = typeANSISTRING) and (T2 = typeUNICSTRING) then + begin + R.Op := OP_ANSISTRING_FROM_UNICSTRING; + end + else if (T1 = typeSHORTSTRING) and (T2 = typeANSICHAR) then + begin + if K2 = KindVAR then + R.Op := OP_SHORTSTRING_FROM_ANSICHAR + else + begin + if GetSymbolRec(Arg2).HasName then + begin + S := Chr(Integer(GetSymbolRec(Arg2).value)); + R.Arg2 := TKernel(kernel).SymbolTable.AddPAnsiCharConst + (AnsiString(S)).Id; + R.Op := OP_SHORTSTRING_FROM_PANSICHAR_LITERAL; + end + else + begin + S := Chr(Integer(GetSymbolRec(Arg2).value)); + GetSymbolRec(Arg2).TypeId := typePANSICHAR; + GetSymbolRec(Arg2).value := S; + R.Op := OP_SHORTSTRING_FROM_PANSICHAR_LITERAL; + end; + end; + end + else if (T1 = typeSHORTSTRING) and (T2 = typeWIDECHAR) then + begin + if K2 = KindVAR then + R.Op := OP_SHORTSTRING_FROM_WIDECHAR + else + begin + if GetSymbolRec(Arg2).HasName then + begin + S := Chr(Integer(GetSymbolRec(Arg2).value)); + R.Arg2 := TKernel(kernel).SymbolTable.AddPAnsiCharConst + (AnsiString(S)).Id; + R.Op := OP_SHORTSTRING_FROM_PWIDECHAR_LITERAL; + end + else + begin + S := Chr(Integer(GetSymbolRec(Arg2).value)); + GetSymbolRec(Arg2).TypeId := typePWIDECHAR; + GetSymbolRec(Arg2).value := S; + R.Op := OP_SHORTSTRING_FROM_PWIDECHAR_LITERAL; + end; + end; + end + else if (T1 = typeSHORTSTRING) and (T2 = typeSHORTSTRING) then + begin + R.Op := OP_ASSIGN_SHORTSTRING + end + + // wide strings + + else if (T1 = typeWIDESTRING) and (T2 in VariantTypes) then + begin + R.Op := OP_WIDESTRING_FROM_VARIANT; + end + else if (T1 = typeWIDESTRING) and (T2 = typeWIDESTRING) then + begin + if K2 = KindVAR then + R.Op := OP_ASSIGN_WIDESTRING + else + CreateError(errInternalError, []); + end + else if (T1 = typeWIDESTRING) and (GetSymbolRec(Arg2).HasPAnsiCharType) then + begin + if K2 = KindCONST then + R.Op := OP_WIDESTRING_FROM_PANSICHAR_LITERAL + else + CreateError(errLeftSideCannotBeAssignedTo, []); + end + else if (T1 = typeWIDESTRING) and (GetSymbolRec(Arg2).HasPWideCharType) then + begin + R.Op := OP_WIDESTRING_FROM_PWIDECHAR_LITERAL; + end + else if (T1 = typeWIDESTRING) and (T2 = typeANSISTRING) then + begin + R.Op := OP_WIDESTRING_FROM_ANSISTRING; + end + else if (T1 = typeUNICSTRING) and (T2 = typeANSISTRING) then + begin + R.Op := OP_UNICSTRING_FROM_ANSISTRING; + end + else if (T1 = typeWIDESTRING) and (T2 = typeANSICHAR) then + begin + if K2 = KindVAR then + R.Op := OP_WIDESTRING_FROM_ANSICHAR + else + begin + if GetSymbolRec(Arg2).HasName then + begin + S := Chr(Integer(GetSymbolRec(Arg2).value)); + R.Arg2 := TKernel(kernel).SymbolTable.AddPAnsiCharConst + (AnsiString(S)).Id; + R.Op := OP_WIDESTRING_FROM_PANSICHAR_LITERAL; + end + else + begin + S := Chr(Integer(GetSymbolRec(Arg2).value)); + GetSymbolRec(Arg2).TypeId := typePANSICHAR; + GetSymbolRec(Arg2).value := S; + R.Op := OP_WIDESTRING_FROM_PANSICHAR_LITERAL; + end; + end; + end + else if (T1 = typeWIDESTRING) and (T2 = typeWIDECHAR) then + begin + if K2 = KindVAR then + R.Op := OP_WIDESTRING_FROM_WIDECHAR + else + R.Op := OP_WIDESTRING_FROM_WIDECHAR_LITERAL; + end + else if (T1 = typeWIDESTRING) and SymbolTable.IsZerobasedWideCharArray(Arg2) + then + begin + RC := TCodeRec.Create(OP_ADDRESS, Self); + RC.Arg1 := Arg2; + RC.Arg2 := 0; + RC.Res := CreatePointerVar(GetLevel(N)); + Insert(N, RC); + Inc(N); + + R.Op := OP_WIDESTRING_FROM_WIDECHAR_LITERAL; + R.Arg2 := RC.Res; + end +{$ENDIF} + else if GetSymbolRec(Arg1).HasPWideCharType and + SymbolTable.IsZerobasedWideCharArray(Arg2) then + begin + RC := TCodeRec.Create(OP_ADDRESS, Self); + RC.Arg1 := Arg2; + RC.Arg2 := 0; + RC.Res := CreatePointerVar(GetLevel(N)); + Insert(N, RC); + Inc(N); + + R.Op := OP_ASSIGN_INT_M; + R.Arg2 := RC.Res; + end + + // unic string - begin + + else if (T1 = typeUNICSTRING) and (T2 in VariantTypes) then + begin + R.Op := OP_UNICSTRING_FROM_VARIANT; + end + else if (T1 = typeUNICSTRING) and (T2 = typeUNICSTRING) then + begin + if K2 = KindVAR then + R.Op := OP_ASSIGN_UNICSTRING + else + CreateError(errInternalError, []); + end + else if (T1 = typeUNICSTRING) and (GetSymbolRec(Arg2).HasPWideCharType) then + begin + R.Op := OP_UNICSTRING_FROM_PWIDECHAR_LITERAL; + end +{$IFNDEF PAXARM} + else if (T1 = typeUNICSTRING) and (GetSymbolRec(Arg2).HasPAnsiCharType) then + begin + // if K2 = KindCONST then + R.Op := OP_UNICSTRING_FROM_PANSICHAR_LITERAL + // else + // CreateError(errLeftSideCannotBeAssignedTo, []); + end + else if (T1 = typeUNICSTRING) and (T2 = typeANSICHAR) then + begin + if K2 = KindVAR then + R.Op := OP_UNICSTRING_FROM_ANSICHAR + else + begin + if GetSymbolRec(Arg2).HasName then + begin + S := Chr(Integer(GetSymbolRec(Arg2).value)); + R.Arg2 := TKernel(kernel).SymbolTable.AddPAnsiCharConst + (AnsiString(S)).Id; + R.Op := OP_UNICSTRING_FROM_PANSICHAR_LITERAL; + end + else + begin + S := Chr(Integer(GetSymbolRec(Arg2).value)); + GetSymbolRec(Arg2).TypeId := typePANSICHAR; + GetSymbolRec(Arg2).value := S; + R.Op := OP_UNICSTRING_FROM_PANSICHAR_LITERAL; + end; + end; + end +{$ENDIF} + else if (T1 = typeUNICSTRING) and (T2 = typeWIDECHAR) then + begin + if K2 = KindVAR then + R.Op := OP_UNICSTRING_FROM_WIDECHAR + else + R.Op := OP_UNICSTRING_FROM_WIDECHAR_LITERAL; + end + + // unic string - end + + else if (T1 = typeDOUBLE) and (T2 in RealTypes) then + begin + R.Op := OP_ASSIGN_DOUBLE; + end + else if (T1 = typeDOUBLE) and (T2 = typeCURRENCY) then + begin + R.Op := OP_CURRENCY_TO_DOUBLE; + R.Arg1 := R.Arg2; + end + else if (T1 = typeDOUBLE) and (T2 in IntegerTypes) then + begin + R.Op := OP_ASSIGN_DOUBLE; + if K2 = KindCONST then + R.Arg2 := CreateConst(typeDOUBLE, GetSymbolRec(R.Arg2).value) + else + begin + InsertConversionToDouble(N, 2); + Inc(N); + end; + end + else if (T1 = typeDOUBLE) and (T2 in VariantTypes) then + begin + R.Op := OP_DOUBLE_FROM_VARIANT; + end + else if (T1 = typeSINGLE) and (T2 in VariantTypes) then + begin + R.Op := OP_SINGLE_FROM_VARIANT; + end + else if (T1 = typeSINGLE) and (T2 in RealTypes) then + begin + R.Op := OP_ASSIGN_SINGLE; + end + else if (T1 = typeSINGLE) and (T2 = typeCURRENCY) then + begin + R.Op := OP_CURRENCY_TO_SINGLE; + R.Arg1 := R.Arg2; + end + else if (T1 = typeSINGLE) and (T2 in IntegerTypes) then + begin + R.Op := OP_ASSIGN_SINGLE; + if K2 = KindCONST then + R.Arg2 := CreateConst(typeDOUBLE, GetSymbolRec(R.Arg2).value) + else + begin + InsertConversionToSingle(N, 2); + Inc(N); + end; + end + else if (T1 = typeEXTENDED) and (T2 in VariantTypes) then + begin + R.Op := OP_EXTENDED_FROM_VARIANT; + end + else if (T1 = typeEXTENDED) and (T2 = typeCURRENCY) then + begin + R.Op := OP_CURRENCY_TO_EXTENDED; + R.Arg1 := R.Arg2; + end + else if (T1 = typeEXTENDED) and (T2 in RealTypes) then + begin + R.Op := OP_ASSIGN_EXTENDED; + end + else if (T1 = typeEXTENDED) and (T2 in IntegerTypes) then + begin + R.Op := OP_ASSIGN_EXTENDED; + if K2 = KindCONST then + R.Arg2 := CreateConst(typeEXTENDED, GetSymbolRec(R.Arg2).value) + else + begin + InsertConversionToExtended(N, 2); + Inc(N); + end; + end + else if (T1 = typeINT64) and (T2 in (IntegerTypes + VariantTypes)) then + begin + R.Op := OP_ASSIGN_INT64; + if K2 = KindCONST then + begin + if T2 <> typeINT64 then + R.Arg2 := CreateConst(typeINT64, GetSymbolRec(R.Arg2).value); + end + else + begin + if T2 = typeINT64 then + begin + // ok + end + else + begin + InsertConversionToInt64(N, 2); + Inc(N); + end; + end; + end + else if (T1 = typeUINT64) and (T2 in (IntegerTypes + VariantTypes)) then + begin + R.Op := OP_ASSIGN_UINT64; + if K2 = KindCONST then + begin + if T2 <> typeUINT64 then + R.Arg2 := CreateConst(typeUINT64, GetSymbolRec(R.Arg2).value); + end + else + begin + if T2 = typeUINT64 then + begin + // ok + end + else + begin + InsertConversionToUInt64(N, 2); + Inc(N); + end; + end; + end + /// /////// + else if (T1 = typeVARIANT) and (T2 in VariantTypes) then + begin + R.Op := OP_ASSIGN_VARIANT; + end + else if (T1 = typeOLEVARIANT) and (T2 in VariantTypes) then + begin + R.Op := OP_ASSIGN_OLEVARIANT; + end +{$IFNDEF PAXARM} + else if (T1 = typeVARIANT) and (GetSymbolRec(Arg2).HasPAnsiCharType) then + begin + R.Op := OP_VARIANT_FROM_PANSICHAR_LITERAL + end + else if (T1 = typeOLEVARIANT) and (GetSymbolRec(Arg2).HasPAnsiCharType) then + begin + R.Op := OP_OLEVARIANT_FROM_PANSICHAR_LITERAL + end + else if (T1 = typeVARIANT) and (T2 = typeANSISTRING) then + begin + R.Op := OP_VARIANT_FROM_ANSISTRING; + end + else if (T1 = typeOLEVARIANT) and (T2 = typeANSISTRING) then + begin + R.Op := OP_OLEVARIANT_FROM_ANSISTRING; + end + else if (T1 = typeVARIANT) and (T2 = typeWIDESTRING) then + begin + R.Op := OP_VARIANT_FROM_WIDESTRING; + end + else if (T1 = typeOLEVARIANT) and (T2 = typeWIDESTRING) then + begin + R.Op := OP_OLEVARIANT_FROM_WIDESTRING; + end + else if (T1 = typeVARIANT) and (T2 = typeSHORTSTRING) then + begin + R.Op := OP_VARIANT_FROM_SHORTSTRING; + end + else if (T1 = typeOLEVARIANT) and (T2 = typeSHORTSTRING) then + begin + R.Op := OP_OLEVARIANT_FROM_SHORTSTRING; + end + else if (T1 = typeVARIANT) and (T2 = typeANSICHAR) then + begin + if K2 = KindVAR then + R.Op := OP_VARIANT_FROM_ANSICHAR + else + begin + if GetSymbolRec(Arg2).HasName then + begin + S := Chr(Integer(GetSymbolRec(Arg2).value)); + R.Arg2 := TKernel(kernel).SymbolTable.AddPAnsiCharConst + (AnsiString(S)).Id; + R.Op := OP_VARIANT_FROM_PANSICHAR_LITERAL; + end + else + begin + S := Chr(Integer(GetSymbolRec(Arg2).value)); + GetSymbolRec(Arg2).TypeId := typePANSICHAR; + GetSymbolRec(Arg2).value := S; + R.Op := OP_VARIANT_FROM_PANSICHAR_LITERAL; + end; + end; + end + else if (T1 = typeOLEVARIANT) and (T2 = typeANSICHAR) then + begin + if K2 = KindVAR then + R.Op := OP_OLEVARIANT_FROM_ANSICHAR + else + begin + if GetSymbolRec(Arg2).HasName then + begin + S := Chr(Integer(GetSymbolRec(Arg2).value)); + R.Arg2 := TKernel(kernel).SymbolTable.AddPAnsiCharConst + (AnsiString(S)).Id; + R.Op := OP_OLEVARIANT_FROM_PANSICHAR_LITERAL; + end + else + begin + S := Chr(Integer(GetSymbolRec(Arg2).value)); + GetSymbolRec(Arg2).TypeId := typePANSICHAR; + GetSymbolRec(Arg2).value := S; + R.Op := OP_OLEVARIANT_FROM_PANSICHAR_LITERAL; + end; + end; + end +{$ENDIF} + else if (T1 = typeVARIANT) and (GetSymbolRec(Arg2).HasPWideCharType) then + begin + R.Op := OP_VARIANT_FROM_PWIDECHAR_LITERAL + end + else if (T1 = typeOLEVARIANT) and (GetSymbolRec(Arg2).HasPWideCharType) then + begin + R.Op := OP_OLEVARIANT_FROM_PWIDECHAR_LITERAL + end + else if (T1 = typeVARIANT) and (T2 = typeUNICSTRING) then + begin + R.Op := OP_VARIANT_FROM_UNICSTRING; + end + else if (T1 = typeOLEVARIANT) and (T2 = typeUNICSTRING) then + begin + R.Op := OP_OLEVARIANT_FROM_UNICSTRING; + end + else if (T1 = typeVARIANT) and (T2 = typeINTERFACE) then + begin + R.Op := OP_VARIANT_FROM_INTERFACE; + end + else if (T1 = typeOLEVARIANT) and (T2 = typeINTERFACE) then + begin + R.Op := OP_OLEVARIANT_FROM_INTERFACE; + end + else if (T1 = typeVARIANT) and (T2 = typeWIDECHAR) then + begin + if K2 = KindVAR then + R.Op := OP_VARIANT_FROM_WIDECHAR + else + R.Op := OP_VARIANT_FROM_WIDECHAR_LITERAL; + end + else if (T1 = typeOLEVARIANT) and (T2 = typeWIDECHAR) then + begin + if K2 = KindVAR then + R.Op := OP_OLEVARIANT_FROM_WIDECHAR + else + R.Op := OP_OLEVARIANT_FROM_WIDECHAR_LITERAL; + end + else if (T1 = typeVARIANT) and + (T2 in (IntegerTypes + RealTypes + BooleanTypes + [typeCURRENCY])) then + begin + R.Op := OP_ASSIGN_VARIANT; + if K2 = KindCONST then + R.Arg2 := CreateConst(typeVARIANT, GetSymbolRec(R.Arg2).value, T2) + else + begin + InsertConversionToVariant(N, 2); + Inc(N); + end; + end + else if (T1 = typeOLEVARIANT) and + (T2 in (IntegerTypes + RealTypes + BooleanTypes + [typeCURRENCY])) then + begin + R.Op := OP_ASSIGN_OLEVARIANT; + if K2 = KindCONST then + R.Arg2 := CreateConst(typeOLEVARIANT, GetSymbolRec(R.Arg2).value, T2) + else + begin + InsertConversionToOleVariant(N, 2); + Inc(N); + end; + end + else if IsJSType(GetSymbolRec(Arg1).TerminalTypeId, SymbolTable) and + (T2 = typeVARIANT) then + begin + InsertConversionToClass(N, 2, GetSymbolRec(Arg1).TerminalTypeId); + Inc(N); + R.Op := OP_ASSIGN_CLASS; + end + else if GetSymbolRec(Arg1).HasFrameworkType then + begin + if Arg2 = TKernel(kernel).SymbolTable.NilId then + begin +{$IFDEF PAXARM} + R.Op := OP_CLASS_CLR; + Exit; +{$ENDIF} + end + else if GetSymbolRec(Arg1).TerminalTypeId = GetSymbolRec(Arg2).TerminalTypeId + then + begin + + end + else + begin + InsertConversionToFrameworkClass(N, 2, GetSymbolRec(Arg1).TerminalTypeId); + Inc(N); + end; + R.Op := OP_ASSIGN_CLASS; + end + else if (T1 = typeCLASS) and (T2 = typeCLASS) then + begin + T1 := GetSymbolRec(Arg1).TerminalTypeId; + T2 := GetSymbolRec(Arg2).TerminalTypeId; + + if IsJSType(T1, SymbolTable) and IsJSType(T2, SymbolTable) and + (GetSymbolRec(Arg1).Name <> '') and + (GetSymbolRec(Arg1).Name <> strInternalConstructor) and + (GetSymbolRec(Arg2).Name <> '') then + begin + R.Op := OP_ASSIGN_CLASS; + Exit; + end; + + if not SymbolTable.Inherits(T2, T1) then + begin + // ok, let's check that we have not case + // F := TForm.Create(......... + // [TForm] := [TCustomForm] + + b := false; + if SymbolTable.Inherits(T1, T2) then + if Arg2 = PrevRec(N).Res then + if PrevRec(N).Op = OP_CALL then + begin + if GetSymbolRec(PrevRec(N).Arg1).Kind in kindSUBS then + begin + if PrevPrevRec(N).Op = OP_PUSH_CLSREF then + begin + T2 := GetSymbolRec(PrevPrevRec(N).Arg1).TypeId; + if GetSymbolRec(T2).FinalTypeId = typeCLASSREF then + begin + T2 := GetSymbolRec(T2).PatternId; + b := SymbolTable.Inherits(T2, T1); + end; + end; + end + else if PrevPrevRec(N).Op = OP_GET_VMT_ADDRESS then + b := true + end; + + if not b then + begin + if GetLanguage(N) = JS_LANGUAGE then + begin + R.Arg1 := NewTempVar(TKernel(kernel).SymbolTable[Arg1].Level, + TKernel(kernel).SymbolTable[Arg2].TypeId); + ReplaceIdEx(Arg1, R.Arg1, N + 1, Card, false); + TKernel(kernel).SymbolTable[R.Arg1].Name := TKernel(kernel) + .SymbolTable[Arg1].Name; + Dec(N); + Exit; + end; + + T1 := GetSymbolRec(Arg1).TypeId; + T2 := GetSymbolRec(Arg2).TypeId; + CreateError(errIncompatibleTypes, [GetSymbolRec(T1).Name, + GetSymbolRec(T2).Name]); + end; + end; +{$IFDEF PAXARM} + R.Op := OP_ASSIGN_CLASS; +{$ELSE} + if K2 = KindVAR then + R.Op := OP_ASSIGN_INT_M + else + R.Op := OP_ASSIGN_INT_I; +{$ENDIF} + end + else if (T1 = typePOINTER) and (T2 = typeCLASS) then + begin + if K2 = KindVAR then + R.Op := OP_ASSIGN_INT_M + else + R.Op := OP_ASSIGN_INT_I; + end + else if (T1 = typePOINTER) and (T2 = typeCLASSREF) then + begin + if K2 = KindVAR then + R.Op := OP_ASSIGN_INT_M + else + R.Op := OP_ASSIGN_INT_I; + end + else if (T1 = typeCLASS) and (Arg2 = TKernel(kernel).SymbolTable.NilId) then + begin +{$IFDEF PAXARM} + R.Op := OP_CLASS_CLR; +{$ELSE} + R.Op := OP_ASSIGN_INT_I; +{$ENDIF} + end + else if (T1 = typeCLASS) and + (Arg2 = TKernel(kernel).SymbolTable.CurrExceptionObjectId) then + begin +{$IFDEF PAXARM} + R.Op := OP_ASSIGN_CLASS; +{$ELSE} + R.Op := OP_ASSIGN_INT_M; +{$ENDIF} + end + else if (T1 = typeCLASSREF) and (T2 = typeCLASS) then + begin + T1 := GetSymbolRec(Arg1).TerminalTypeId; + T1 := GetSymbolRec(T1).PatternId; + T2 := Arg2; + if (not SymbolTable.Inherits(T2, T1)) or (K2 <> KindTYPE) then + begin + CreateError(errIncompatibleTypes, [GetSymbolRec(T1).Name, + GetSymbolRec(T2).Name]); + end; + R.Op := OP_ASSIGN_INT_M; + Inc(R.Arg2); + end + else if (T1 = typeCLASSREF) and (T2 = typeCLASSREF) then + begin + T1 := GetSymbolRec(GetSymbolRec(Arg1).TerminalTypeId).PatternId; + T2 := GetSymbolRec(GetSymbolRec(Arg2).TerminalTypeId).PatternId; + if not SymbolTable.Inherits(T2, T1) then + begin + T1 := GetSymbolRec(Arg1).TypeId; + T2 := GetSymbolRec(Arg2).TypeId; + CreateError(errIncompatibleTypes, [GetSymbolRec(T1).Name, + GetSymbolRec(T2).Name]); + end; + if K2 = KindVAR then + R.Op := OP_ASSIGN_INT_M + else + R.Op := OP_ASSIGN_INT_I; + end + else if (T1 = typeCLASSREF) and (Arg2 = TKernel(kernel).SymbolTable.NilId) + then + begin + R.Op := OP_ASSIGN_INT_I; + end + else if (T1 = typePROC) and (Arg2 = TKernel(kernel).SymbolTable.NilId) then + begin + R.Op := OP_ASSIGN_INT_I; + end + else if (T1 = typeDYNARRAY) and (T2 = typeDYNARRAY) then + begin + R.Op := OP_DYNARRAY_ASSIGN; + + T1 := GetSymbolRec(Arg1).TypeId; + T2 := GetSymbolRec(Arg2).TypeId; + + T1 := GetSymbolRec(T1).PatternId; + T2 := GetSymbolRec(T2).PatternId; + + if T1 <> T2 then + CreateError(errIncompatibleTypesNoArgs, []); + end + else if (T1 = typeDYNARRAY) and (Arg2 = TKernel(kernel).SymbolTable.NilId) + then + begin + R.Op := OP_DYNARRAY_CLR; + end + else if (T1 = typeEVENT) and (T2 = typeEVENT) then + begin + T1 := GetSymbolRec(Arg1).TerminalTypeId; + T2 := GetSymbolRec(Arg2).TerminalTypeId; + + T1 := GetSymbolRec(T1).PatternId; + T2 := GetSymbolRec(T2).PatternId; + + if not StrEql(GetSymbolRec(T1).SignatureSimple, + GetSymbolRec(T2).SignatureSimple) then + CreateError(errIncompatibleTypesNoArgs, []); + + R.Op := OP_ASSIGN_EVENT; + end + else if (T1 = typeEVENT) and (Arg2 = TKernel(kernel).SymbolTable.NilId) then + begin + R.Op := OP_ASSIGN_EVENT; + R.Arg2 := TKernel(kernel).SymbolTable.EventNilId; + end + else if T1 = typeCURRENCY then + begin + if T2 = typeINT64 then + R.Op := OP_CURRENCY_FROM_INT64 + else if T2 = typeUINT64 then + R.Op := OP_CURRENCY_FROM_UINT64 + else if T2 in IntegerTypes then + begin + if K2 = KindCONST then + begin + R.Op := OP_CURRENCY_FROM_INT64; + R.Arg2 := CreateConst(typeINT64, GetSymbolRec(R.Arg2).value); + end + else + R.Op := OP_CURRENCY_FROM_INT; + end + else if T2 = typeCURRENCY then + R.Op := OP_ASSIGN_CURRENCY + else if T2 in RealTypes then + begin + R.Op := OP_CURRENCY_FROM_REAL; + end + else if T2 in VariantTypes then + begin + R.Op := OP_CURRENCY_FROM_VARIANT; + end + else + goto err; + end + + else if T1 = typeINTERFACE then + begin + if T2 = typeCLASS then + begin + T1 := GetSymbolRec(Arg1).TerminalTypeId; + T2 := GetSymbolRec(Arg2).TerminalTypeId; + if not SymbolTable.Supports(T2, T1) then + CreateError(errIncompatibleTypesNoArgs, []); + + R.Op := OP_INTERFACE_FROM_CLASS; + end + else if T2 = typeINTERFACE then + begin + T1 := GetSymbolRec(Arg1).TerminalTypeId; + T2 := GetSymbolRec(Arg2).TerminalTypeId; + if not SymbolTable.Supports(T2, T1) then + CreateError(errIncompatibleTypesNoArgs, []); + + R.Op := OP_ASSIGN_INTERFACE; + end + else if Arg2 = SymbolTable.NilId then + R.Op := OP_INTERFACE_CLR + else + goto err; + end + else if (T2 = typeINTERFACE) and (K2 = KindTYPE) then + begin + if GetSymbolRec(Arg1).TerminalTypeId = H_TGUID then + begin + R.Op := OP_ASSIGN_RECORD; + R.Arg2 := GetSymbolRec(Arg2).TerminalTypeId + 1; + end + else + goto err; + end + else + begin + if SignTypeCast1 then + begin + if (T1 = typeENUM) and (T2 in VariantTypes) then + begin + R.Op := OP_BYTE_FROM_VARIANT; + end + else + R.Op := OP_ASSIGN_INT_M; + Exit; + end; + + if (T1 = typePOINTER) and (T2 = typePOINTER) then + begin + T1 := GetSymbolRec(Arg1).TypeId; + T2 := GetSymbolRec(Arg2).TypeId; + + T1 := GetSymbolRec(T1).PatternId; + T2 := GetSymbolRec(T2).PatternId; + + if (T1 = T2) or (T1 = typeVOID) or + (Arg2 = TKernel(kernel).SymbolTable.NilId) or +{$IFNDEF PAXARM} + (GetSymbolRec(Arg1).HasPAnsiCharType and (T2 = typeSHORTSTRING)) or +{$ENDIF} + (PrevRec(N).Op = OP_TYPEINFO) or StrEql(GetSymbolRec(T1).Name, + GetSymbolRec(T2).Name) then + begin + if (K1 = KindVAR) and (K2 = KindVAR) then + R.Op := OP_ASSIGN_INT_M +{$IFNDEF PAXARM} + else if GetSymbolRec(Arg1).HasPAnsiCharType and GetSymbolRec(Arg2).HasPAnsiCharType + then + R.Op := OP_ASSIGN_PANSICHAR +{$ENDIF} + else if GetSymbolRec(Arg1).HasPWideCharType and GetSymbolRec(Arg2).HasPWideCharType + then + R.Op := OP_ASSIGN_PWIDECHAR + else if (K1 = KindVAR) and (K2 = KindCONST) then + R.Op := OP_ASSIGN_INT_I; + Exit; + end +{$IFNDEF PAXARM} + else if GetSymbolRec(Arg1).HasPWideCharType and GetSymbolRec(Arg2).HasPAnsiCharType + then + begin + R.Op := OP_ASSIGN_PWIDECHAR; + if K2 = KindCONST then + GetSymbolRec(Arg2).TypeId := typePWIDECHAR; + + Exit; + end + else if GetSymbolRec(Arg1).HasPAnsiCharType and GetSymbolRec(Arg2).HasPWideCharType + then + begin + R.Op := OP_ASSIGN_PANSICHAR; + if K2 = KindCONST then + GetSymbolRec(Arg2).TypeId := typePANSICHAR; + + Exit; + end; +{$ENDIF} + end + else if (T1 = typePROC) and (T2 = typePROC) then + begin + T1 := GetSymbolRec(Arg1).TypeId; + T2 := GetSymbolRec(Arg2).TypeId; + + if T1 = T2 then + R.Op := OP_ASSIGN_INT_M + else + CreateError(errIncompatibleTypesNoArgs, []); + Exit; + end + else if (T1 = typePROC) and (T2 = typePOINTER) then + begin + R.Op := OP_ASSIGN_INT_M; + Exit; + end + else if (T1 = typeSET) and (T2 = typeSET) then + begin + T1 := GetSymbolRec(Arg1).TerminalTypeId; + T2 := GetSymbolRec(Arg2).TerminalTypeId; + + if SymbolTable.CheckSetTypes(T1, T2) then + begin + R.Op := OP_SET_ASSIGN; + GetSymbolRec(Arg1).value := GetSymbolRec(Arg2).value; + Exit; + end; + end + else if (T1 = typeRECORD) and (T2 = typeRECORD) then + begin + R.Op := OP_ASSIGN_RECORD; + GetSymbolRec(Arg1).value := GetSymbolRec(Arg2).value; + Exit; + end + else if (T1 = typeARRAY) and (T2 = typeARRAY) then + begin + R.Op := OP_ASSIGN_ARRAY; + GetSymbolRec(Arg1).value := GetSymbolRec(Arg2).value; + Exit; + end + else if (GetSymbolRec(Arg1).TerminalTypeId = H_TVarRec) and + (T2 in OrdinalTypes + StringTypes + RealTypes + [typeVARIANT, + typeOLEVARIANT, typePOINTER, typeCLASS]) then + begin + if SymbolTable[R.Arg2].Kind = KindCONST then + SymbolTable[R.Arg2].MustBeAllocated := true; + R.Op := OP_ASSIGN_TVarRec; + Exit; + end + else if T1 = typePROC then + begin + if K2 = KindSUB then + begin + T1 := GetSymbolRec(Arg1).TypeId; + SubId1 := TKernel(kernel).SymbolTable.GetPatternSubId(T1); + SubId2 := R.Arg2; + + if TKernel(kernel).SymbolTable.EqualHeaders(SubId1, SubId2) then + begin + R.Op := OP_ADDRESS; + R.Arg1 := R.Arg2; + R.Arg2 := 0; + Exit; + end + else + begin + OverList := SymbolTable.LookUpSub(SymbolTable[SubId2].Name, + SymbolTable[SubId2].Level, GetUpcase(N)); + try + for I := 0 to OverList.Count - 1 do + begin + SubId2 := OverList[I]; + if TKernel(kernel).SymbolTable.EqualHeaders(SubId1, SubId2) then + begin + R.Arg2 := SubId2; + R.Op := OP_ADDRESS; + R.Arg1 := R.Arg2; + R.Arg2 := 0; + Exit; + end; + end; + finally + FreeAndNil(OverList); + end; + end; + + end + else + CreateError(errIncompatibleTypesNoArgs, []); + end + else if (T1 = typeDYNARRAY) and (T2 = typeSET) then + begin + T1 := GetSymbolRec(Arg1).TypeId; + Arg2 := ConvertSetLiteralToDynarrayLiteral(GetSymbolRec(R.Arg1).Level, + T1, R.Arg2); + if Arg2 = 0 then + CreateError(errIncompatibleTypesNoArgs, []) + else + R.Arg2 := Arg2; + Dec(N); + Exit; + end; + + err: + + if (GetSymbolRec(Arg1).FinalTypeId = typeSET) and + (GetSymbolRec(Arg2).FinalTypeId = typeSET) then + CreateError(errIncompatibleTypesNoArgs, []) + else + begin + T1 := GetSymbolRec(Arg1).TypeId; + T2 := GetSymbolRec(Arg2).TypeId; +{$IFNDEF PAXARM} + if (T1 = H_TGUID) and (T2 = typePANSICHAR) then + begin + R.Op := OP_NOP; + GetSymbolRec(R.Arg1).value := GetSymbolRec(R.Arg2).value; + end + else +{$ENDIF} + if (T1 = H_TGUID) and (T2 = typePWIDECHAR) then + begin + R.Op := OP_NOP; + GetSymbolRec(R.Arg1).value := GetSymbolRec(R.Arg2).value; + end + else if GetSymbolRec(Arg1).FinalTypeId = typeRECORD then + begin + T1 := GetSymbolRec(Arg1).TerminalTypeId; + T2 := GetSymbolRec(Arg2).TerminalTypeId; + + R.Op := OP_ASSIGN_RECORD; + + if T1 <> T2 then + if T1 <> H_TVarRec then + begin + InsertConversionToRecord(N, 2, GetSymbolRec(R.Arg1) + .TerminalTypeId, R.Arg2); + Inc(N); + end; + + Exit; + end + else + begin + if T2 = H_TValue then + begin + R.Op := OP_VAR_FROM_TVALUE; + end + else + begin + if GetSymbolRec(Arg2).FinalTypeId = typeRECORD then + begin + SubId2 := FindImplicitConversion + (GetSymbolRec(Arg2).TerminalTypeId, Arg2, Arg1); + if SubId2 > 0 then + begin + NoOverloadSearch := true; + + T2 := SymbolTable.GetResultId(SubId2); + T2 := GetSymbolRec(T2).TypeId; + + RC := TCodeRec.Create(OP_PUSH, Self); + RC.Arg1 := Arg2; + RC.Arg2 := 0; + RC.Res := SubId2; + Insert(N, RC); + Inc(N); + + RC := TCodeRec.Create(OP_CALL, Self); + RC.Arg1 := SubId2; + RC.Arg2 := 1; + RC.Res := NewTempVar(GetLevel(N), T2); + Insert(N, RC); + Inc(N); + + R.Arg2 := RC.Res; + + Dec(N, 2); + + Exit; + end; + end; + + if Records[N].Language = JS_LANGUAGE then + begin + if TKernel(kernel).SymbolTable.IsResultId(Arg1) then + begin + R.Op := OP_ASSIGN_VARIANT; + if K2 = KindCONST then + R.Arg2 := CreateConst(typeVARIANT, + GetSymbolRec(R.Arg2).value, T2) + else + begin + InsertConversionToVariant(N, 2); + Inc(N); + end; + end + else + begin + R.Arg1 := NewTempVar(TKernel(kernel).SymbolTable[Arg1].Level, + TKernel(kernel).SymbolTable[Arg2].TypeId); + ReplaceIdEx(Arg1, R.Arg1, N + 1, Card, false); + TKernel(kernel).SymbolTable[R.Arg1].Name := TKernel(kernel) + .SymbolTable[Arg1].Name; + Dec(N); + end; + Exit; + end + else if IsExplicitOff then + begin + R.Arg1 := NewTempVar(TKernel(kernel).SymbolTable[Arg1].Level, + TKernel(kernel).SymbolTable[Arg2].TypeId); + ReplaceIdEx(Arg1, R.Arg1, N + 1, Card, false); + TKernel(kernel).SymbolTable[R.Arg1].Name := TKernel(kernel) + .SymbolTable[Arg1].Name; + Dec(N); + Exit; + end; + + CreateError(errIncompatibleTypes, [GetSymbolRec(T1).NameEx, + GetSymbolRec(T2).NameEx]); + end; + end; + end; + end; +end; + +function TCode.ConvertSetLiteralToDynarrayLiteral(CurrLevel, DynarrayTypeId, + SetId: Integer): Integer; +var + I, J: Integer; + RC: TCodeRec; + SubId: Integer; + ElemTypeId: Integer; + ElemSizeId: Integer; + FinalElemTypeId: Integer; + L: Integer; + DynArrayId: Integer; + + Op, tempN, K1, K2: Integer; +begin + J := -1; + + for I := 1 to N do + begin + if Records[I].Op = OP_SET_INCLUDE then + if Records[I].Arg1 = SetId then + begin + J := I; + break; + end; + if Records[I].Op = OP_SET_INCLUDE_INTERVAL then + if Records[I].Arg1 = SetId then + begin + result := 0; + Exit; + end; + end; + + if J = -1 then + begin + result := 0; + Exit; + end; + + L := 0; + for I := 1 to N do + if Records[I].Op = OP_SET_INCLUDE then + if Records[I].Arg1 = SetId then + Inc(L); + + SubId := Id_DynarraySetLength; + + RC := TCodeRec.Create(OP_BEGIN_CALL, Self); + RC.Arg1 := SubId; + RC.Arg2 := 0; + RC.Res := 0; + + Insert(J, RC); + Inc(J); + Inc(N); + + DynArrayId := NewTempVar(CurrLevel, DynarrayTypeId); + GetSymbolRec(DynArrayId).Name := '@'; + ElemTypeId := GetSymbolRec(DynarrayTypeId).PatternId; + + RC := TCodeRec.Create(OP_DECLARE_TEMP_VAR, Self); + RC.Arg1 := CurrLevel; + RC.Arg2 := DynArrayId; + RC.Res := 0; + + Insert(J, RC); + Inc(J); + Inc(N); + + ElemSizeId := NewTempVar(CurrLevel, typeINTEGER); + RC := TCodeRec.Create(OP_SIZEOF, Self); + RC.Arg1 := ElemTypeId; + RC.Arg2 := 0; + RC.Res := ElemSizeId; + + Insert(J, RC); + Inc(J); + Inc(N); + + RC := TCodeRec.Create(OP_PUSH_INT, Self); + RC.Arg1 := ElemSizeId; + RC.Arg2 := 4; + RC.Res := SubId; + + Insert(J, RC); + Inc(J); + Inc(N); + + RC := TCodeRec.Create(OP_PUSH_INT_IMM, Self); + RC.Arg1 := CreateConst(typeINTEGER, ElemTypeId); + RC.Arg2 := 3; + RC.Res := SubId; + + Insert(J, RC); + Inc(J); + Inc(N); + + FinalElemTypeId := GetSymbolRec(ElemTypeId).FinalTypeId; + + RC := TCodeRec.Create(OP_PUSH_INT_IMM, Self); + RC.Arg1 := CreateConst(typeINTEGER, FinalElemTypeId); + RC.Arg2 := 2; + RC.Res := SubId; + + Insert(J, RC); + Inc(J); + Inc(N); + + RC := TCodeRec.Create(OP_PUSH_INT_IMM, Self); + RC.Arg1 := CreateConst(typeINTEGER, L); + RC.Arg2 := 1; + RC.Res := SubId; + + Insert(J, RC); + Inc(J); + Inc(N); + + RC := TCodeRec.Create(OP_PUSH_ADDRESS, Self); + RC.Arg1 := DynArrayId; + RC.Arg2 := 0; + RC.Res := SubId; + + Insert(J, RC); + Inc(J); + Inc(N); + + RC := TCodeRec.Create(OP_CALL, Self); + RC.Arg1 := SubId; + RC.Arg2 := 5; + RC.Res := 0; + + Insert(J, RC); + // Inc(J); + Inc(N); + + for I := N downto 1 do + begin + Op := Records[I].Op; + if Op = OP_SET_INCLUDE then + begin + if Records[I].Arg1 = SetId then + begin + Dec(L); + + J := Records[I].Arg2; + + Records[I].Op := OP_ELEM; + Records[I].Arg1 := DynArrayId; + Records[I].Arg2 := CreateConst(typeINTEGER, L); + Records[I].Res := NewTempVar(CurrLevel, ElemTypeId); + + RC := TCodeRec.Create(OP_ASSIGN, Self); + RC.Arg1 := Records[I].Res; + RC.Arg2 := J; + RC.Res := Records[I].Res; + Insert(I + 1, RC); + Inc(N); + end; + end + else if Op = OP_BEGIN_MODULE then + break; + end; + + result := DynArrayId; + + GetSymbolRec(result).Count := GetSymbolRec(SetId).Count; + + tempN := N; + + for I := N downto 1 do + begin + if Records[I].Op = OP_ELEM then + begin + if Records[I].Arg1 = DynArrayId then + begin + K1 := Card; + N := I + 1; + Op := Records[N].Op; + ProcList[-Op]; + K2 := Card; + Inc(tempN, K2 - K1); + + K1 := Card; + N := I; + Op := Records[N].Op; + ProcList[-Op]; + K2 := Card; + Inc(tempN, K2 - K1); + end; + end + else if Records[I].Op = OP_BEGIN_MODULE then + break; + end; + + N := tempN; +end; + +procedure TCode.OperSetInclude; +var + Arg1, T1, K1, L: Integer; + Arg2, T2: Integer; + R: TCodeRec; + SymbolTable: TSymbolTable; + SetTypeId, BaseTypeId: Integer; + SetTypeName: String; +begin + R := Records[N]; + SymbolTable := TKernel(kernel).SymbolTable; + + Arg1 := R.Arg1; + T1 := GetSymbolRec(Arg1).FinalTypeId; + K1 := GetSymbolRec(Arg1).Kind; + + Arg2 := R.Arg2; + T2 := GetSymbolRec(Arg2).FinalTypeId; + + if K1 in [KindVAR, KindCONST] then + begin + if T1 = 0 then + begin + SetTypeName := SetTypeName + 'type_Set_' + IntToStr(SymbolTable.Card + 1); + + L := GetSymbolRec(Arg1).Level; + + SetTypeId := SymbolTable.RegisterSetType(L, SetTypeName, + GetSymbolRec(Arg2).TerminalTypeId); + + AddTypeInfo(SetTypeId, SetTypeId); + + GetSymbolRec(Arg1).TypeId := SetTypeId; + T1 := typeSET; + end + else + begin + SetTypeId := GetSymbolRec(Arg1).TypeId; + end; + + if T1 <> typeSET then + begin + CreateError(errSetTypeRequired, []); + Exit; + end; + + if SetTypeId = typeSET then + Exit; + + BaseTypeId := GetSymbolRec(SetTypeId).PatternId; + + if GetSymbolRec(BaseTypeId).FinalTypeId <> T2 then + begin + if not((GetSymbolRec(BaseTypeId).FinalTypeId in IntegerTypes) and + (T2 in IntegerTypes)) then + begin + // T2 := GetSymbolRec(Arg2).TypeID; + // CreateError(errIncompatibleTypes, + // [GetSymbolRec(BaseTypeId).Name, GetSymbolRec(T2).Name]); + // Exit; + end; + end; + end + else + begin + CreateError(errIncompatibleTypesNoArgs, []); + end; +end; + +procedure TCode.OperSetExclude; +begin +end; + +procedure TCode.OperInc; +var + T1, T2, K1, K2, PatternId: Integer; + R: TCodeRec; +begin + R := Records[N]; + + T1 := GetSymbolRec(R.Arg1).FinalTypeId; + K1 := GetSymbolRec(R.Arg1).Kind; + + if T1 = typeENUM then + T1 := typeINTEGER; + + if T1 in [typeINT64, typeUINT64, typeVARIANT, typeOLEVARIANT] then + begin + R.Op := OP_PLUS; + Dec(N); + end + else if T1 in OrdinalTypes then + begin + GetSymbolRec(R.Res).TypeId := GetSymbolRec(R.Arg1).TypeId; + if K1 = KindCONST then + begin + GetSymbolRec(R.Arg1).value := GetSymbolRec(R.Arg1).value + 1; + R.Op := OP_NOP; + end + else if K1 = KindVAR then + begin + PatternId := GetSymbolRec(R.Res).PatternId; + if PatternId <> 0 then + if GetSymbolRec(PatternId).Kind = KindPROP then + CreateError(errYouCannotUseIncOnProperties, []); + + T2 := GetSymbolRec(R.Arg2).FinalTypeId; + K2 := GetSymbolRec(R.Arg2).Kind; + if not(T2 in IntegerTypes) then + begin + CreateError(errIncompatibleTypesNoArgs, []); + Exit; + end; + if K2 = KindCONST then + R.Op := OP_ADD_INT_MI + else if K2 = KindVAR then + R.Op := OP_ADD_INT_MM + else + CreateError(errIncompatibleTypesNoArgs, []); + end + else + CreateError(errIncompatibleTypesNoArgs, []); + end + else if T1 = typeRECORD then + begin + InsertUnaryOperator(GetSymbolRec(R.Arg1).TerminalTypeId, gen_Inc); + Inc(N); + end + else + CreateError(errIncompatibleTypesNoArgs, []); +end; + +procedure TCode.OperDec; +var + T1, T2, K1, K2, PatternId: Integer; + R: TCodeRec; +begin + R := Records[N]; + + T1 := GetSymbolRec(R.Arg1).FinalTypeId; + K1 := GetSymbolRec(R.Arg1).Kind; + + if T1 = typeENUM then + T1 := typeINTEGER; + + if T1 in [typeINT64, typeUINT64, typeVARIANT, typeOLEVARIANT] then + begin + R.Op := OP_MINUS; + Dec(N); + end + else if T1 in OrdinalTypes then + begin + GetSymbolRec(R.Res).TypeId := GetSymbolRec(R.Arg1).TypeId; + if K1 = KindCONST then + begin + GetSymbolRec(R.Arg1).value := GetSymbolRec(R.Arg1).value - 1; + R.Op := OP_NOP; + end + else if K1 = KindVAR then + begin + PatternId := GetSymbolRec(R.Res).PatternId; + if PatternId <> 0 then + if GetSymbolRec(PatternId).Kind = KindPROP then + CreateError(errYouCannotUseDecOnProperties, []); + + T2 := GetSymbolRec(R.Arg2).FinalTypeId; + K2 := GetSymbolRec(R.Arg2).Kind; + if not(T2 in IntegerTypes) then + begin + CreateError(errIncompatibleTypesNoArgs, []); + Exit; + end; + if K2 = KindCONST then + R.Op := OP_SUB_INT_MI + else if K2 = KindVAR then + R.Op := OP_SUB_INT_MM + else + CreateError(errIncompatibleTypesNoArgs, []); + end + else + CreateError(errIncompatibleTypesNoArgs, []); + end + else if T1 = typeRECORD then + begin + InsertUnaryOperator(GetSymbolRec(R.Arg1).TerminalTypeId, gen_Dec); + Inc(N); + end + else + CreateError(errIncompatibleTypesNoArgs, []); +end; + +procedure TCode.OperSetLength; +var + T1, T2, K1, L1, ArrayId, ElementTypeId, ElementFinalTypeId, + ElementSizeId: Integer; + R, RC: TCodeRec; +begin + R := Records[N]; + + T1 := GetSymbolRec(R.Arg1).FinalTypeId; + T2 := GetSymbolRec(R.Arg2).FinalTypeId; + K1 := GetSymbolRec(R.Arg1).Kind; + + if T1 = typeDYNARRAY then + begin + if not(K1 = KindVAR) then + CreateError(errIncompatibleTypesNoArgs, []); + if not(T2 in IntegerTypes) then + CreateError(errIncompatibleTypesNoArgs, []); + + ArrayId := R.Arg1; + L1 := R.Arg2; + T1 := GetSymbolRec(R.Arg1).TerminalTypeId; + ElementTypeId := GetSymbolRec(T1).PatternId; + ElementFinalTypeId := GetSymbolRec(ElementTypeId).FinalTypeId; + ElementSizeId := NewTempVar(0, typeINTEGER); + + R.Op := OP_CALL; + R.Arg1 := Id_DynarraySetLength; + R.Arg2 := 3; + R.Res := 0; + + RC := TCodeRec.Create(OP_PUSH, Self); + RC.Arg1 := ArrayId; + RC.Arg2 := 0; + RC.Res := R.Arg1; + Insert(N, RC); + Inc(N); + + RC := TCodeRec.Create(OP_PUSH, Self); + RC.Arg1 := L1; + RC.Arg2 := 1; + RC.Res := R.Arg1; + Insert(N, RC); + Inc(N); + + RC := TCodeRec.Create(OP_PUSH, Self); + RC.Arg1 := CreateConst(typeINTEGER, ElementFinalTypeId); + RC.Arg2 := 2; + RC.Res := R.Arg1; + Insert(N, RC); + Inc(N); + + RC := TCodeRec.Create(OP_PUSH, Self); + RC.Arg1 := CreateConst(typeINTEGER, ElementTypeId); + RC.Arg2 := 3; + RC.Res := R.Arg1; + Insert(N, RC); + Inc(N); + + RC := TCodeRec.Create(OP_SIZEOF, Self); + RC.Arg1 := ElementTypeId; + RC.Arg2 := 0; + RC.Res := ElementSizeId; + Insert(N, RC); + Inc(N); + + RC := TCodeRec.Create(OP_PUSH, Self); + RC.Arg1 := ElementSizeId; + RC.Arg2 := 4; + RC.Res := R.Arg1; + Insert(N, RC); + Inc(N); + + Dec(N); + end + else if T1 in StringTypes then + begin + // ok + end + else if T1 in VariantTypes then + begin + // ok + end + else + CreateError(errIncompatibleTypesNoArgs, []); +end; + +procedure TCode.OperAbs; +var + Arg1, T1, K1: Integer; + R: TCodeRec; + I64: Int64; +begin + R := Records[N]; + + Arg1 := R.Arg1; + T1 := GetSymbolRec(Arg1).FinalTypeId; + K1 := GetSymbolRec(Arg1).Kind; + + if not(K1 in [KindVAR, KindCONST]) then + begin + CreateError(errIncompatibleTypesNoArgs, []); + Exit; + end; + + GetSymbolRec(R.Res).TypeId := GetSymbolRec(Arg1).TypeId; + + if T1 in INT64Types then + begin + if K1 = KindCONST then + begin + if GetSymbolRec(R.Res).IsGlobalVar then + begin + GetSymbolRec(R.Res).Kind := KindCONST; +{$IFDEF VARIANTS} + I64 := GetSymbolRec(Arg1).value; + GetSymbolRec(R.Res).value := Abs(I64); +{$ELSE} + I64 := Integer(GetSymbolRec(Arg1).value); + GetSymbolRec(R.Res).value := Abs(Integer(I64)); +{$ENDIF} + R.Op := OP_NOP; + end + else + begin + R.Op := OP_ASSIGN_INT64; + R.Arg1 := R.Res; +{$IFDEF VARIANTS} + I64 := GetSymbolRec(Arg1).value; + R.Arg2 := CreateConst(typeINT64, Abs(I64)); +{$ELSE} + I64 := Integer(GetSymbolRec(Arg1).value); + R.Arg2 := CreateConst(typeINT64, Integer(Abs(I64))); +{$ENDIF} + end; + end + else + R.Op := OP_ABS_INT64; + end + else if T1 in IntegerTypes then + begin + if K1 = KindCONST then + begin + if GetSymbolRec(R.Res).IsGlobalVar then + begin + GetSymbolRec(R.Res).Kind := KindCONST; + GetSymbolRec(R.Res).value := Abs(Integer(GetSymbolRec(Arg1).value)); + R.Op := OP_NOP; + end + else + begin + R.Op := OP_ASSIGN_INT_I; + R.Arg1 := R.Res; + R.Arg2 := CreateConst(typeINTEGER, + Abs(Integer(GetSymbolRec(Arg1).value))); + end; + end + else + R.Op := OP_ABS_INT; + end + else if T1 = typeDOUBLE then + begin + if K1 = KindCONST then + begin + + if GetSymbolRec(R.Res).IsGlobalVar then + begin + GetSymbolRec(R.Res).Kind := KindCONST; + GetSymbolRec(R.Res).value := Abs(Double(GetSymbolRec(Arg1).value)); + R.Op := OP_NOP; + end + else + begin + R.Op := OP_ASSIGN_DOUBLE; + R.Arg1 := R.Res; + R.Arg2 := CreateConst(typeDOUBLE, + Abs(Double(GetSymbolRec(Arg1).value))); + end; + + end + else + R.Op := OP_ABS_DOUBLE + end + else if T1 = typeSINGLE then + begin + if K1 = KindCONST then + begin + if GetSymbolRec(R.Res).IsGlobalVar then + begin + GetSymbolRec(R.Res).Kind := KindCONST; + GetSymbolRec(R.Res).value := Abs(Single(GetSymbolRec(Arg1).value)); + R.Op := OP_NOP; + end + else + begin + R.Op := OP_ASSIGN_SINGLE; + R.Arg1 := R.Res; + R.Arg2 := CreateConst(typeSINGLE, + Abs(Single(GetSymbolRec(Arg1).value))); + end; + end + else + R.Op := OP_ABS_SINGLE + end + else if T1 = typeEXTENDED then + begin + if K1 = KindCONST then + begin + if GetSymbolRec(R.Res).IsGlobalVar then + begin + GetSymbolRec(R.Res).Kind := KindCONST; + GetSymbolRec(R.Res).value := Abs(Extended(GetSymbolRec(Arg1).value)); + R.Op := OP_NOP; + end + else + begin + R.Op := OP_ASSIGN_EXTENDED; + R.Arg1 := R.Res; + R.Arg2 := CreateConst(typeEXTENDED, + Abs(Extended(GetSymbolRec(Arg1).value))); + end; + end + else + R.Op := OP_ABS_EXTENDED + end + else if T1 = typeCURRENCY then + begin + if K1 = KindCONST then + begin + if GetSymbolRec(R.Res).IsGlobalVar then + begin + GetSymbolRec(R.Res).Kind := KindCONST; + GetSymbolRec(R.Res).value := Abs(Currency(GetSymbolRec(Arg1).value)); + R.Op := OP_NOP; + end + else + begin + R.Op := OP_ASSIGN_CURRENCY; + R.Arg1 := R.Res; + R.Arg2 := CreateConst(typeCURRENCY, + Abs(Currency(GetSymbolRec(Arg1).value))); + end; + end + else + R.Op := OP_ABS_CURRENCY; + end + else if T1 in VariantTypes then + begin + if K1 = KindCONST then + begin + if GetSymbolRec(R.Res).IsGlobalVar then + begin + GetSymbolRec(R.Res).Kind := KindCONST; + if GetSymbolRec(Arg1).value >= 0 then + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value + else + GetSymbolRec(R.Res).value := -GetSymbolRec(Arg1).value; + R.Op := OP_NOP; + end + else + begin + R.Op := OP_ASSIGN_VARIANT; + R.Arg1 := R.Res; + if GetSymbolRec(Arg1).value >= 0 then + R.Arg2 := CreateConst(typeVARIANT, GetSymbolRec(Arg1).value) + else + R.Arg2 := CreateConst(typeVARIANT, GetSymbolRec(Arg1).value); + end; + end + else + R.Op := OP_ABS_VARIANT + end + else + CreateError(errIncompatibleTypesNoArgs, []); +end; + +procedure TCode.OperPred; +var + Arg1, T1, K1: Integer; + R: TCodeRec; +begin + R := Records[N]; + + Arg1 := R.Arg1; + T1 := GetSymbolRec(Arg1).FinalTypeId; + K1 := GetSymbolRec(Arg1).Kind; + + if T1 = typeENUM then + T1 := typeINTEGER; + + if T1 in OrdinalTypes then + begin + GetSymbolRec(R.Res).TypeId := GetSymbolRec(Arg1).TypeId; + if K1 = KindCONST then + begin + if GetSymbolRec(R.Res).IsGlobalVar then + begin + GetSymbolRec(R.Res).Kind := KindCONST; + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value - 1; + R.Op := OP_NOP; + end + else + begin + R.Op := OP_SUB_INT_MI; + R.Arg2 := CreateConst(typeINTEGER, 1); + end; + end + else if K1 = KindVAR then + begin + R.Op := OP_ADD_INT_MI; + R.Arg2 := CreateConst(typeINTEGER, -1); + end + else + CreateError(errIncompatibleTypesNoArgs, []); + end + else + CreateError(errIncompatibleTypesNoArgs, []); +end; + +procedure TCode.OperSucc; +var + Arg1, T1, K1: Integer; + R: TCodeRec; +begin + R := Records[N]; + + Arg1 := R.Arg1; + T1 := GetSymbolRec(Arg1).FinalTypeId; + K1 := GetSymbolRec(Arg1).Kind; + + if T1 = typeENUM then + T1 := typeINTEGER; + + if T1 in OrdinalTypes then + begin + GetSymbolRec(R.Res).TypeId := GetSymbolRec(Arg1).TypeId; + if K1 = KindCONST then + begin + if GetSymbolRec(R.Res).IsGlobalVar then + begin + GetSymbolRec(R.Res).Kind := KindCONST; + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value + 1; + R.Op := OP_NOP; + end + else + begin + R.Op := OP_ADD_INT_MI; + R.Arg2 := CreateConst(typeINTEGER, 1); + end; + end + else if K1 = KindVAR then + begin + R.Op := OP_ADD_INT_MI; + R.Arg2 := CreateConst(typeINTEGER, 1); + end + else + CreateError(errIncompatibleTypesNoArgs, []); + end + else + CreateError(errIncompatibleTypesNoArgs, []); +end; + +procedure TCode.OperOrd; +var + Arg1, T1, K1: Integer; + R: TCodeRec; +begin + R := Records[N]; + + Arg1 := R.Arg1; + T1 := GetSymbolRec(Arg1).FinalTypeId; + K1 := GetSymbolRec(Arg1).Kind; + + if T1 = typeENUM then + T1 := typeINTEGER; + + if T1 in OrdinalTypes then + begin + GetSymbolRec(R.Res).TypeId := typeINTEGER; + if K1 = KindCONST then + begin + if GetSymbolRec(R.Res).IsGlobalVar then + begin + GetSymbolRec(R.Res).Kind := KindCONST; + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value; + R.Op := OP_NOP; + end + else + begin + R.Op := OP_ASSIGN_INT_I; + R.Arg1 := R.Res; + R.Arg2 := Arg1; + end; + end + else if K1 = KindVAR then + begin + R.Op := OP_ASSIGN_INT_M; + R.Arg1 := R.Res; + R.Arg2 := Arg1; + end + else + CreateError(errInternalError, []); + end + else + CreateError(errIncompatibleTypesNoArgs, []); +end; + +procedure TCode.OperChr; +var + Arg1, T1, K1: Integer; + R: TCodeRec; +begin + R := Records[N]; + + Arg1 := R.Arg1; + T1 := GetSymbolRec(Arg1).FinalTypeId; + K1 := GetSymbolRec(Arg1).Kind; + + if T1 in IntegerTypes then + begin + GetSymbolRec(R.Res).TypeId := typeCHAR; + if K1 = KindCONST then + begin + if GetSymbolRec(R.Res).IsGlobalVar then + begin + GetSymbolRec(R.Res).Kind := KindCONST; + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value; + R.Op := OP_NOP; + end + else + begin + R.Op := OP_ASSIGN_INT_I; + R.Arg1 := R.Res; + R.Arg2 := Arg1; + end; + end + else if K1 = KindVAR then + begin + R.Op := OP_ASSIGN_INT_M; + R.Arg1 := R.Res; + R.Arg2 := Arg1; + end + else + CreateError(errIncompatibleTypesNoArgs, []); + end + else + CreateError(errIncompatibleTypesNoArgs, []); +end; + +procedure TCode.OperAssigned; +var + Arg1, T1, K1: Integer; + R: TCodeRec; +begin + R := Records[N]; + + Arg1 := R.Arg1; + T1 := GetSymbolRec(Arg1).FinalTypeId; + K1 := GetSymbolRec(Arg1).Kind; + + GetSymbolRec(R.Res).TypeId := typeBOOLEAN; + + if not K1 in [KindVAR, KindCONST] then + begin + CreateError(errIncompatibleTypesNoArgs, []); + Exit; + end; + + if T1 in [typePOINTER, typeCLASS, typeCLASSREF, typePROC, typeINTERFACE] then + begin + R.Op := OP_NE; + R.Arg2 := TKernel(kernel).SymbolTable.NilId; + Dec(N); + end + else if T1 = typeEVENT then + begin + R.Op := OP_NE; + R.Arg2 := TKernel(kernel).SymbolTable.EventNilId; + Dec(N); + end + else + CreateError(errIncompatibleTypesNoArgs, []); +end; + +procedure TCode.OperLow; +var + Arg1, Res, T1: Integer; + R: TCodeRec; + RangeTypeId, ElemTypeId: Integer; + SymbolTable: TSymbolTable; +begin + R := Records[N]; + SymbolTable := TKernel(kernel).SymbolTable; + + Arg1 := R.Arg1; + T1 := GetSymbolRec(Arg1).FinalTypeId; + Res := R.Res; + + if T1 in IntegerTypes then + begin + case T1 of + typeINTEGER, typeBYTE, typeWORD, typeSMALLINT, typeSHORTINT: + R.Res := CreateConst(typeINTEGER, + SymbolTable.GetLowBoundRec(GetSymbolRec(Arg1).TerminalTypeId).value); + typeCARDINAL, typeINT64: + R.Res := CreateConst(typeINT64, + SymbolTable.GetLowBoundRec(GetSymbolRec(Arg1).TerminalTypeId).value); + end; + R.Op := OP_NOP; + ReplaceIdEx(Res, R.Res, N, Card, true); + end + else if T1 = typeENUM then + begin + R.Res := CreateConst(typeINTEGER, + SymbolTable.GetLowBoundRec(GetSymbolRec(Arg1).TerminalTypeId).value); + GetSymbolRec(R.Res).TypeId := GetSymbolRec(Arg1).TypeId; + R.Op := OP_NOP; + ReplaceIdEx(Res, R.Res, N, Card, true); + end +{$IFNDEF PAXARM} + else if T1 = typeANSICHAR then + begin + R.Res := CreateConst(typeANSICHAR, + SymbolTable.GetLowBoundRec(GetSymbolRec(Arg1).TerminalTypeId).value); + GetSymbolRec(R.Res).TypeId := GetSymbolRec(Arg1).TypeId; + R.Op := OP_NOP; + ReplaceIdEx(Res, R.Res, N, Card, true); + end +{$ENDIF} + else if T1 = typeWIDECHAR then + begin + R.Res := CreateConst(typeWIDECHAR, + SymbolTable.GetLowBoundRec(GetSymbolRec(Arg1).TerminalTypeId).value); + GetSymbolRec(R.Res).TypeId := GetSymbolRec(Arg1).TypeId; + R.Op := OP_NOP; + ReplaceIdEx(Res, R.Res, N, Card, true); + end + else if T1 = typeBOOLEAN then + begin + R.Res := CreateConst(typeBOOLEAN, Low(Boolean)); + R.Op := OP_NOP; + ReplaceIdEx(Res, R.Res, N, Card, true); + end + else if T1 = typeBYTEBOOL then + begin + R.Res := CreateConst(typeBYTEBOOL, Low(ByteBool)); + R.Op := OP_NOP; + ReplaceIdEx(Res, R.Res, N, Card, true); + end + else if T1 = typeWORDBOOL then + begin + R.Res := CreateConst(typeWORDBOOL, Low(WordBool)); + R.Op := OP_NOP; + ReplaceIdEx(Res, R.Res, N, Card, true); + end + else if T1 = typeLONGBOOL then + begin + R.Res := CreateConst(typeLONGBOOL, Low(LongBool)); + R.Op := OP_NOP; + ReplaceIdEx(Res, R.Res, N, Card, true); + end + else if T1 = typeARRAY then + begin + SymbolTable.GetArrayTypeInfo(GetSymbolRec(Arg1).TerminalTypeId, RangeTypeId, + ElemTypeId); + R.Res := CreateConst(typeINTEGER, + SymbolTable.GetLowBoundRec(RangeTypeId).value); + R.Op := OP_NOP; + ReplaceIdEx(Res, R.Res, N, Card, true); + end + else if T1 in [typeDYNARRAY, typeOPENARRAY] then + begin + R.Res := CreateConst(typeINTEGER, 0); + R.Op := OP_NOP; + ReplaceIdEx(Res, R.Res, N, Card, true); + end +{$IFNDEF PAXARM} + else if T1 = typeSHORTSTRING then + begin + R.Res := CreateConst(typeINTEGER, 0); + R.Op := OP_NOP; + ReplaceIdEx(Res, R.Res, N, Card, true); + end +{$ENDIF} + else + CreateError(errIncompatibleTypesNoArgs, []); +end; + +procedure TCode.OperHigh; +var + Arg1, Res, T1: Integer; + R: TCodeRec; + RangeTypeId, ElemTypeId: Integer; + SymbolTable: TSymbolTable; +begin + R := Records[N]; + SymbolTable := TKernel(kernel).SymbolTable; + + Arg1 := R.Arg1; + Res := R.Res; + T1 := GetSymbolRec(Arg1).FinalTypeId; + + if T1 in IntegerTypes then + begin + case T1 of + typeINTEGER, typeBYTE, typeWORD, typeSMALLINT, typeSHORTINT: + R.Res := CreateConst(typeINTEGER, + SymbolTable.GetHighBoundRec(GetSymbolRec(Arg1).TerminalTypeId).value); + typeCARDINAL, typeINT64: + R.Res := CreateConst(typeINT64, + SymbolTable.GetHighBoundRec(GetSymbolRec(Arg1).TerminalTypeId).value); + end; + R.Op := OP_NOP; + ReplaceIdEx(Res, R.Res, N, Card, true); + end +{$IFNDEF PAXARM} + else if T1 = typeANSICHAR then + begin + R.Res := CreateConst(typeANSICHAR, + SymbolTable.GetHighBoundRec(GetSymbolRec(Arg1).TerminalTypeId).value); + GetSymbolRec(R.Res).TypeId := GetSymbolRec(Arg1).TypeId; + R.Op := OP_NOP; + ReplaceIdEx(Res, R.Res, N, Card, true); + end +{$ENDIF} + else if T1 = typeWIDECHAR then + begin + R.Res := CreateConst(typeWIDECHAR, + SymbolTable.GetHighBoundRec(GetSymbolRec(Arg1).TerminalTypeId).value); + GetSymbolRec(R.Res).TypeId := GetSymbolRec(Arg1).TypeId; + R.Op := OP_NOP; + ReplaceIdEx(Res, R.Res, N, Card, true); + end + else if T1 = typeENUM then + begin + R.Res := CreateConst(typeINTEGER, + SymbolTable.GetHighBoundRec(GetSymbolRec(Arg1).TerminalTypeId).value); + GetSymbolRec(R.Res).TypeId := GetSymbolRec(Arg1).TypeId; + R.Op := OP_NOP; + ReplaceIdEx(Res, R.Res, N, Card, true); + end + else if T1 = typeBOOLEAN then + begin + R.Res := CreateConst(typeBOOLEAN, High(Boolean)); + R.Op := OP_NOP; + ReplaceIdEx(Res, R.Res, N, Card, true); + end + else if T1 = typeBYTEBOOL then + begin + R.Res := CreateConst(typeBYTEBOOL, High(ByteBool)); + R.Op := OP_NOP; + ReplaceIdEx(Res, R.Res, N, Card, true); + end + else if T1 = typeWORDBOOL then + begin + R.Res := CreateConst(typeWORDBOOL, High(WordBool)); + R.Op := OP_NOP; + ReplaceIdEx(Res, R.Res, N, Card, true); + end + else if T1 = typeLONGBOOL then + begin + R.Res := CreateConst(typeLONGBOOL, High(LongBool)); + R.Op := OP_NOP; + ReplaceIdEx(Res, R.Res, N, Card, true); + end + else if T1 = typeARRAY then + begin + SymbolTable.GetArrayTypeInfo(GetSymbolRec(Arg1).TerminalTypeId, RangeTypeId, + ElemTypeId); + R.Res := CreateConst(typeINTEGER, + SymbolTable.GetHighBoundRec(RangeTypeId).value); + R.Op := OP_NOP; + ReplaceIdEx(Res, R.Res, N, Card, true); + end + else if T1 = typeDYNARRAY then + begin + GetSymbolRec(Res).TypeId := typeINTEGER; + + if GetSymbolRec(Arg1).Kind = KindVAR then + R.Op := OP_DYNARRAY_HIGH + else + CreateError(errIncompatibleTypesNoArgs, []); + end + else if T1 = typeOPENARRAY then + begin + GetSymbolRec(Res).TypeId := typeINTEGER; + R.Arg2 := SymbolTable.GetOpenArrayHighId(R.Arg1); + R.Arg1 := R.Res; + + R.Op := OP_ASSIGN; + Dec(N); + end +{$IFNDEF PAXARM} + else if T1 = typeSHORTSTRING then + begin + GetSymbolRec(Res).TypeId := typeINTEGER; + + if GetSymbolRec(Arg1).Kind = KindVAR then + R.Op := OP_SHORTSTRING_HIGH + else if GetSymbolRec(Arg1).Kind = KindTYPE then + begin + if Arg1 = typeSHORTSTRING then + R.Res := CreateConst(typeINTEGER, High(ShortString)) + else + R.Res := CreateConst(typeINTEGER, GetSymbolRec(Arg1).Count); + R.Op := OP_NOP; + ReplaceIdEx(Res, R.Res, N, Card, true); + end + else + CreateError(errIncompatibleTypesNoArgs, []); + end +{$ENDIF} + else + CreateError(errIncompatibleTypesNoArgs, []); +end; + +procedure TCode.OperStr; +var + R: TCodeRec; + I, SubId, Id, T: Integer; + L: TIntegerList; + RC: TCodeRec; +begin + R := Records[N]; + + SubId := R.Arg1; + + L := TIntegerList.Create; + + try + for I := 1 to N do + if Records[I].Res = SubId then + L.Add(I); + + if L.Count <> 4 then + begin + CreateError(errInternalError, []); + Exit; + end; + + Id := Records[L[0]].Arg1; + T := GetSymbolRec(Id).FinalTypeId; + + if T in IntegerTypes then + begin + SubId := Id_StrInt; + case GetSymbolRec(Id).Kind of + KindCONST: + Records[L[0]].Op := OP_PUSH_INT_IMM; + KindVAR: + Records[L[0]].Op := OP_PUSH_INT; + else + begin + N := L[0]; + CreateError(errIncompatibleTypesNoArgs, []); + end; + end; + end + else if T = typeDOUBLE then + begin + SubId := Id_StrDouble; + case GetSymbolRec(Id).Kind of + KindCONST, KindVAR: + Records[L[0]].Op := OP_PUSH_DOUBLE; + else + begin + N := L[0]; + CreateError(errIncompatibleTypesNoArgs, []); + end; + end; + end + else if T = typeSINGLE then + begin + SubId := Id_StrSingle; + case GetSymbolRec(Id).Kind of + KindCONST, KindVAR: + Records[L[0]].Op := OP_PUSH_SINGLE; + else + begin + N := L[0]; + CreateError(errIncompatibleTypesNoArgs, []); + end; + end; + end + else if T = typeEXTENDED then + begin + SubId := Id_StrExtended; + case GetSymbolRec(Id).Kind of + KindCONST, KindVAR: + Records[L[0]].Op := OP_PUSH_EXTENDED; + else + begin + N := L[0]; + CreateError(errIncompatibleTypesNoArgs, []); + end; + end; + end + else + SubId := 0; + + if SubId = 0 then + begin + N := L[0]; + CreateError(errIncompatibleTypesNoArgs, []); + Exit; + end; + + Id := Records[L[1]].Arg1; + T := GetSymbolRec(Id).FinalTypeId; + if not(T in IntegerTypes) then + begin + N := L[1]; + CreateError(errIncompatibleTypesNoArgs, []); + Exit; + end; + case GetSymbolRec(Id).Kind of + KindCONST: + Records[L[1]].Op := OP_PUSH_INT_IMM; + KindVAR: + Records[L[1]].Op := OP_PUSH_INT; + else + begin + N := L[1]; + CreateError(errIncompatibleTypesNoArgs, []); + end; + end; + + Id := Records[L[2]].Arg1; + T := GetSymbolRec(Id).FinalTypeId; + if not(T in IntegerTypes) then + begin + N := L[2]; + CreateError(errIncompatibleTypesNoArgs, []); + Exit; + end; + case GetSymbolRec(Id).Kind of + KindCONST: + Records[L[2]].Op := OP_PUSH_INT_IMM; + KindVAR: + Records[L[2]].Op := OP_PUSH_INT; + else + begin + N := L[2]; + CreateError(errIncompatibleTypesNoArgs, []); + end; + end; + + Id := Records[L[3]].Arg1; + T := GetSymbolRec(Id).FinalTypeId; + if not(T in StringTypes) then + begin + N := L[3]; + CreateError(errIncompatibleTypesNoArgs, []); + Exit; + end; + case GetSymbolRec(Id).Kind of + KindVAR: + Records[L[3]].Op := OP_PUSH_ADDRESS; + else + begin + N := L[3]; + CreateError(errIncompatibleTypesNoArgs, []); + end; + end; + + R.Op := OP_CALL; + R.Arg1 := SubId; + R.Arg2 := 4; + R.Res := 0; + + for I := 0 to L.Count - 1 do + begin + Records[L[I]].Arg2 := L.Count - I - 1; + Records[L[I]].Res := SubId; + end; + + finally + RC := TCodeRec.Create(0, Self); + RC.Op := OP_BEGIN_CALL; + RC.Arg1 := SubId; + Insert(L[0], RC); + Inc(N); + + L.Free; + end; +end; + +procedure TCode.OperSetMembership; +var + Arg1, Arg2, T1, T2, K1, K2: Integer; + R: TCodeRec; +begin + R := Records[N]; + + Arg1 := R.Arg1; + Arg2 := R.Arg2; + T1 := GetSymbolRec(Arg1).FinalTypeId; + T2 := GetSymbolRec(Arg2).FinalTypeId; + + if T2 = typeSET then + CreateSetObject(Arg2) + else + begin + CreateError(errIncompatibleTypesNoArgs, []); + Exit; + end; + + K1 := GetSymbolRec(Arg1).Kind; + K2 := GetSymbolRec(Arg2).Kind; + + T2 := GetSymbolRec(GetSymbolRec(Arg2).TypeId).PatternId; + T2 := GetSymbolRec(T2).FinalTypeId; + if not((ExistsOrdinalRelationalOperator(T1, T2) or (T2 = typeVOID))) then + begin + if (GetSymbolRec(T1).FinalTypeId = typeENUM) and + (GetSymbolRec(T2).FinalTypeId = typeENUM) then + begin + // ok + end + else if GetSymbolRec(Arg2).TerminalTypeId = H_TByteSet then + begin + // ok + end + else + begin + CreateError(errIncompatibleTypesNoArgs, []); + Exit; + end; + end; + + GetSymbolRec(R.Res).TypeId := typeBOOLEAN; + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := Integer(GetSymbolRec(Arg1).value) + in GetSymbolRec(Arg2).ValueAsByteSet; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + end; +end; + +procedure TCode.OperSetEventProp; +var + R: TCodeRec; + CodeId: Integer; +begin + R := Records[N]; + if R.Res = TKernel(kernel).SymbolTable.NilId then + Exit; + if R.Language = JS_LANGUAGE then + begin + CreateError(errIncompatibleTypesNoArgs, []); + end; + CodeId := GetSymbolRec(R.Res).PatternId; + if CodeId = 0 then + CreateError(errIncompatibleTypesNoArgs, []); + if not GetSymbolRec(CodeId).IsMethod then + CreateError(errIncompatibleTypesNoArgs, []); +end; + +procedure TCode.OperVarArrayIdx; +var + Arg2, T2, K2: Integer; + R: TCodeRec; +begin + R := Records[N]; + Arg2 := R.Arg2; + T2 := GetSymbolRec(Arg2).FinalTypeId; + + if T2 in IntegerTypes then + begin + // if R.Language = JS_LANGUAGE then + begin + R.Op := OP_PUSH_ADDRESS; + R.Arg1 := R.Arg2; + R.Arg2 := 0; + R.Res := 0; + if not(T2 in VariantTypes) then + begin + InsertConversionToVariant(N, 1); + Inc(N); + end; + Exit; + end; + + K2 := GetSymbolRec(Arg2).Kind; + if K2 = KindCONST then + R.Op := OP_PUSH_INT_IMM + else + R.Op := OP_PUSH_INT; + R.Arg1 := R.Arg2; + R.Arg2 := 0; + R.Res := 0; + end + else + begin + if R.Language = JS_LANGUAGE then + begin + if +{$IFNDEF PAXARM} + GetSymbolRec(Arg2).HasPAnsiCharType or +{$ENDIF} + GetSymbolRec(Arg2).HasPWideCharType then + begin + if Records[N + 1].Op = OP_VARARRAY_PUT then + begin + Records[N].Op := OP_NOP; + Records[N + 1].Op := OP_OLE_SET; + Records[N + 1].Arg2 := Arg2; + Exit; + end + else if Records[N + 1].Op = OP_VARARRAY_GET then + begin + Records[N].Op := OP_NOP; + Records[N + 1].Op := OP_OLE_GET; + Records[N + 1].Arg2 := Arg2; + Exit; + end; + end; + + R.Op := OP_PUSH_ADDRESS; + R.Arg1 := R.Arg2; + R.Arg2 := 0; + R.Res := 0; + if not(T2 in VariantTypes) then + begin + InsertConversionToVariant(N, 1); + Inc(N); + end; + Exit; + end; + + CreateError(errIncompatibleTypesNoArgs, []); + end; +end; + +procedure TCode.OperAddition; +var + Arg1, Arg2, T1, T2, K1, K2: Integer; + R: TCodeRec; +begin + AdjustTypes; + + R := Records[N]; + + Arg1 := R.Arg1; + Arg2 := R.Arg2; + T1 := GetSymbolRec(Arg1).FinalTypeId; + T2 := GetSymbolRec(Arg2).FinalTypeId; + + if T1 in [typePROC, typeEVENT] then + begin + if InsertSubCall(1) then + Exit; + end; + if T2 in [typePROC, typeEVENT] then + begin + if InsertSubCall(2) then + Exit; + end; + + if TKernel(kernel).InterfaceOnly then + if (T1 = 0) or (T2 = 0) then + begin + DiscardImport; + Exit; + end; + + if T1 = typeSET then + CreateSetObject(Arg1); + if T2 = typeSET then + CreateSetObject(Arg2); + + if T1 = typeOLEVARIANT then + T1 := typeVARIANT; + if T2 = typeOLEVARIANT then + T2 := typeVARIANT; + + K1 := GetSymbolRec(Arg1).Kind; + K2 := GetSymbolRec(Arg2).Kind; + + if not(K1 in [KindVAR, KindCONST]) and (K2 in [KindVAR, KindCONST]) then + begin + CreateError(errIncompatibleTypesNoArgs, []); + Exit; + end; + + if (T1 = typeINT64) and (T2 = typeINT64) then + begin + GetSymbolRec(R.Res).TypeId := typeINT64; + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value + + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + end + else + R.Op := OP_ADD_INT64; + end + else if (T1 = typeINT64) and (T2 in IntegerTypes) then + begin + GetSymbolRec(R.Res).TypeId := typeINT64; + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value + + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end + else + R.Op := OP_ADD_INT64; + if K2 = KindCONST then + R.Arg2 := CreateConst(typeINT64, GetSymbolRec(R.Arg2).value) + else + begin + InsertConversionToInt64(N, 2); + Inc(N); + end; + end + else if (T2 = typeINT64) and (T1 in IntegerTypes) then + begin + GetSymbolRec(R.Res).TypeId := typeINT64; + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value + + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end + else + R.Op := OP_ADD_INT64; + if K1 = KindCONST then + R.Arg1 := CreateConst(typeINT64, GetSymbolRec(R.Arg1).value) + else + begin + InsertConversionToInt64(N, 1); + Inc(N); + end; + end + else if (T1 = typeUINT64) and (T2 = typeUINT64) then + begin + GetSymbolRec(R.Res).TypeId := typeUINT64; + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value + + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + end + else + R.Op := OP_ADD_UINT64; + end + else if (T1 = typeUINT64) and (T2 in IntegerTypes) then + begin + GetSymbolRec(R.Res).TypeId := typeUINT64; + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value + + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end + else + R.Op := OP_ADD_UINT64; + if K2 = KindCONST then + R.Arg2 := CreateConst(typeUINT64, GetSymbolRec(R.Arg2).value) + else + begin + InsertConversionToUInt64(N, 2); + Inc(N); + end; + end + else if (T2 = typeUINT64) and (T1 in IntegerTypes) then + begin + GetSymbolRec(R.Res).TypeId := typeUINT64; + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value + + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end + else + R.Op := OP_ADD_UINT64; + if K1 = KindCONST then + R.Arg1 := CreateConst(typeUINT64, GetSymbolRec(R.Arg1).value) + else + begin + InsertConversionToUInt64(N, 1); + Inc(N); + end; + end + + else if (T1 in IntegerTypes) and (T2 in IntegerTypes) then + begin + GetSymbolRec(R.Res).TypeId := GetIntResultType(T1, T2); + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value + + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + if T1 = T2 then + GetSymbolRec(R.Res).TypeId := T1; + R.Op := OP_NOP; + end + else if (K1 = KindVAR) and (K2 = KindVAR) then + R.Op := OP_ADD_INT_MM + else if (K1 = KindVAR) and (K2 = KindCONST) then + begin + R.Op := OP_ADD_INT_MI; + // GetSymbolRec(R.Res).TypeID := T1; + end + else if (K1 = KindCONST) and (K2 = KindVAR) then + begin + R.Op := OP_ADD_INT_MI; + R.SwapArguments; + // GetSymbolRec(R.Res).TypeID := T2; + end; + end + else if (T1 = typeCURRENCY) and (T2 in NumberTypes) then + begin + GetSymbolRec(R.Res).TypeId := typeCURRENCY; + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value + + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + end + else if K2 = KindCONST then + begin + R.Op := OP_ADD_CURRENCY; + if T2 <> typeCURRENCY then + R.Arg2 := CreateConst(typeCURRENCY, GetSymbolRec(R.Arg2).value); + end + else + begin + if T2 <> typeCURRENCY then + R.SwapArguments; + R.Op := OP_ADD_CURRENCY; + end + end + else if (T1 in NumberTypes) and (T2 = typeCURRENCY) then + begin + GetSymbolRec(R.Res).TypeId := typeCURRENCY; + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value + + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + end + else if K1 = KindCONST then + begin + R.Op := OP_ADD_CURRENCY; + if T1 <> typeCURRENCY then + R.Arg1 := CreateConst(typeCURRENCY, GetSymbolRec(R.Arg1).value); + end + else + R.Op := OP_ADD_CURRENCY; + end + else if (T1 = typeDOUBLE) and (T2 = typeDOUBLE) then + begin + GetSymbolRec(R.Res).TypeId := typeDOUBLE; + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value + + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + end + else + R.Op := OP_ADD_DOUBLE; + end + else if (T1 = typeDOUBLE) and (T2 in NumberTypes) then + begin + GetSymbolRec(R.Res).TypeId := typeDOUBLE; + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value + + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end + else + R.Op := OP_ADD_DOUBLE; + if K2 = KindCONST then + R.Arg2 := CreateConst(typeDOUBLE, GetSymbolRec(R.Arg2).value) + else + begin + InsertConversionToDouble(N, 2); + Inc(N); + end; + end + else if (T1 in NumberTypes) and (T2 = typeDOUBLE) then + begin + GetSymbolRec(R.Res).TypeId := typeDOUBLE; + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value + + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end + else + R.Op := OP_ADD_DOUBLE; + if K1 = KindCONST then + R.Arg1 := CreateConst(typeDOUBLE, GetSymbolRec(R.Arg1).value) + else + begin + InsertConversionToDouble(N, 1); + Inc(N); + end; + end + else if (T1 = typeSINGLE) and (T2 = typeSINGLE) then + begin + GetSymbolRec(R.Res).TypeId := typeSINGLE; + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value + + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + end + else + R.Op := OP_ADD_SINGLE; + end + else if (T1 = typeSINGLE) and (T2 in NumberTypes) then + begin + GetSymbolRec(R.Res).TypeId := typeSINGLE; + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value + + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end + else + R.Op := OP_ADD_SINGLE; + if K2 = KindCONST then + R.Arg2 := CreateConst(typeSINGLE, GetSymbolRec(R.Arg2).value) + else + begin + InsertConversionToSingle(N, 2); + Inc(N); + end; + end + else if (T1 in NumberTypes) and (T2 = typeSINGLE) then + begin + GetSymbolRec(R.Res).TypeId := typeSINGLE; + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value + + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end + else + R.Op := OP_ADD_SINGLE; + if K1 = KindCONST then + R.Arg1 := CreateConst(typeSINGLE, GetSymbolRec(R.Arg1).value) + else + begin + InsertConversionToSingle(N, 1); + Inc(N); + end; + end + else if (T1 = typeEXTENDED) and (T2 = typeEXTENDED) then + begin + GetSymbolRec(R.Res).TypeId := typeEXTENDED; + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value + + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + end + else + R.Op := OP_ADD_EXTENDED; + end + else if (T1 = typeEXTENDED) and (T2 in NumberTypes) then + begin + GetSymbolRec(R.Res).TypeId := typeEXTENDED; + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value + + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end + else + R.Op := OP_ADD_EXTENDED; + if K2 = KindCONST then + R.Arg2 := CreateConst(typeEXTENDED, GetSymbolRec(R.Arg2).value) + else + begin + InsertConversionToExtended(N, 2); + Inc(N); + end; + end + else if (T1 in NumberTypes) and (T2 = typeEXTENDED) then + begin + GetSymbolRec(R.Res).TypeId := typeEXTENDED; + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value + + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end + else + R.Op := OP_ADD_EXTENDED; + if K1 = KindCONST then + R.Arg1 := CreateConst(typeEXTENDED, GetSymbolRec(R.Arg1).value) + else + begin + InsertConversionToExtended(N, 1); + Inc(N); + end; + end + else if (T1 = typeSET) and (T2 = typeSET) then + begin + T1 := GetSymbolRec(Arg1).TypeId; + T2 := GetSymbolRec(Arg2).TypeId; + + if not MatchSetTypes(T1, T2) then + begin + CreateError(errIncompatibleTypesNoArgs, []); + Exit; + end; + + R.Op := OP_SET_UNION; + + T1 := GetSymbolRec(T1).PatternId; + T2 := GetSymbolRec(T2).PatternId; + + if T2 = typeVOID then + GetSymbolRec(R.Res).TypeId := GetSymbolRec(Arg1).TypeId + else + GetSymbolRec(R.Res).TypeId := GetSymbolRec(Arg2).TypeId; + + if (K1 = KindVAR) and (K2 = KindVAR) then + begin + // ok + end + else if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).ValueAsByteSet := GetSymbolRec(Arg1).ValueAsByteSet + + GetSymbolRec(Arg2).ValueAsByteSet; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + end + else if (K1 = KindVAR) and (K2 = KindCONST) then + begin + if T2 = typeVOID then // empty set + begin + R.Op := OP_NOP; + ReplaceId(R.Res, R.Arg1); + end; + end + else if (K1 = KindCONST) and (K2 = KindVAR) then + begin + if T1 = typeVOID then // empty set + begin + R.Op := OP_NOP; + ReplaceId(R.Res, R.Arg2); + end; + R.SwapArguments; + end; + end + else if (T1 = typePOINTER) and (T2 = typePOINTER) then + begin + T1 := GetSymbolRec(Arg1).TypeId; + T2 := GetSymbolRec(Arg2).TypeId; +{$IFNDEF PAXARM} + if (GetSymbolRec(T1).PatternId = typeANSICHAR) and + (GetSymbolRec(T2).PatternId = typeANSICHAR) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value + + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).TypeId := GetSymbolRec(Arg1).TypeId; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + end + else + begin + CreateError(errIncompatibleTypesNoArgs, []); + Exit; + end; + end + else +{$ENDIF} + if (GetSymbolRec(T1).PatternId = typeWIDECHAR) and + (GetSymbolRec(T2).PatternId = typeWIDECHAR) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value + + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).TypeId := GetSymbolRec(Arg1).TypeId; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + end + else + begin + CreateError(errIncompatibleTypesNoArgs, []); + Exit; + end; + end + else if (GetSymbolRec(T1).PatternId in CharTypes) and + (GetSymbolRec(T2).PatternId in CharTypes) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value + + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).TypeId := GetSymbolRec(Arg1).TypeId; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + end + else + begin + CreateError(errIncompatibleTypesNoArgs, []); + Exit; + end; + end + else + CreateError(errIncompatibleTypesNoArgs, []); + end +{$IFNDEF PAXARM} + else if (T1 = typeANSISTRING) and (T2 = typeANSISTRING) then + begin + R.Op := OP_ADD_ANSISTRING; + GetSymbolRec(R.Res).TypeId := typeANSISTRING; + InsertDeclareTempVar; + end + else if (T1 = typeANSISTRING) and GetSymbolRec(Arg2).HasPAnsiCharType then + begin + InsertConversionToAnsiString(N, 2); + Inc(N); + R.Op := OP_ADD_ANSISTRING; + GetSymbolRec(R.Res).TypeId := typeANSISTRING; + InsertDeclareTempVar; + end + else if GetSymbolRec(Arg1).HasPAnsiCharType and (T2 = typeANSISTRING) then + begin + InsertConversionToAnsiString(N, 1); + Inc(N); + R.Op := OP_ADD_ANSISTRING; + GetSymbolRec(R.Res).TypeId := typeANSISTRING; + InsertDeclareTempVar; + end + + else if (T1 = typeANSISTRING) and GetSymbolRec(Arg2).HasPWideCharType then + begin + InsertConversionToUnicString(N, 1); + Inc(N); + InsertConversionToUnicString(N, 2); + Inc(N); + R.Op := OP_ADD_UNICSTRING; + GetSymbolRec(R.Res).TypeId := typeUNICSTRING; + InsertDeclareTempVar; + end + else if GetSymbolRec(Arg1).HasPWideCharType and (T2 = typeANSISTRING) then + begin + InsertConversionToUnicString(N, 1); + Inc(N); + InsertConversionToUnicString(N, 2); + Inc(N); + R.Op := OP_ADD_UNICSTRING; + GetSymbolRec(R.Res).TypeId := typeUNICSTRING; + InsertDeclareTempVar; + end + + else if (T1 = typeANSISTRING) and (T2 = typeANSICHAR) then + begin + InsertConversionToAnsiString(N, 2); + Inc(N); + R.Op := OP_ADD_ANSISTRING; + GetSymbolRec(R.Res).TypeId := typeANSISTRING; + InsertDeclareTempVar; + end + else if (T1 = typeANSICHAR) and (T2 = typeANSISTRING) then + begin + InsertConversionToAnsiString(N, 1); + Inc(N); + R.Op := OP_ADD_ANSISTRING; + GetSymbolRec(R.Res).TypeId := typeANSISTRING; + InsertDeclareTempVar; + end + else if (T1 = typeANSICHAR) and (T2 = typeANSICHAR) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := Chr(Integer(GetSymbolRec(Arg1).value)) + + Chr(Integer(GetSymbolRec(Arg2).value)); + GetSymbolRec(R.Res).TypeId := typePANSICHAR; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + InsertConversionToAnsiString(N, 1); + Inc(N); + InsertConversionToAnsiString(N, 2); + Inc(N); + R.Op := OP_ADD_ANSISTRING; + GetSymbolRec(R.Res).TypeId := typeANSISTRING; + InsertDeclareTempVar; + end + else if (T1 = typeSHORTSTRING) and (T2 = typeSHORTSTRING) then + begin + InsertConversionToAnsiString(N, 1); + Inc(N); + InsertConversionToAnsiString(N, 2); + Inc(N); + R.Op := OP_ADD_ANSISTRING; + GetSymbolRec(R.Res).TypeId := typeANSISTRING; + InsertDeclareTempVar; + end + else if (T1 = typeSHORTSTRING) and GetSymbolRec(Arg2).HasPAnsiCharType then + begin + InsertConversionToAnsiString(N, 1); + Inc(N); + InsertConversionToAnsiString(N, 2); + Inc(N); + R.Op := OP_ADD_ANSISTRING; + GetSymbolRec(R.Res).TypeId := typeANSISTRING; + InsertDeclareTempVar; + end + else if GetSymbolRec(Arg1).HasPAnsiCharType and (T2 = typeSHORTSTRING) then + begin + InsertConversionToAnsiString(N, 1); + Inc(N); + InsertConversionToAnsiString(N, 2); + Inc(N); + R.Op := OP_ADD_ANSISTRING; + GetSymbolRec(R.Res).TypeId := typeANSISTRING; + InsertDeclareTempVar; + end + + else if (T1 = typeSHORTSTRING) and GetSymbolRec(Arg2).HasPWideCharType then + begin + InsertConversionToAnsiString(N, 1); + Inc(N); + InsertConversionToAnsiString(N, 2); + Inc(N); + R.Op := OP_ADD_ANSISTRING; + GetSymbolRec(R.Res).TypeId := typeANSISTRING; + InsertDeclareTempVar; + end + else if GetSymbolRec(Arg1).HasPWideCharType and (T2 = typeSHORTSTRING) then + begin + InsertConversionToAnsiString(N, 1); + Inc(N); + InsertConversionToAnsiString(N, 2); + Inc(N); + R.Op := OP_ADD_ANSISTRING; + GetSymbolRec(R.Res).TypeId := typeANSISTRING; + InsertDeclareTempVar; + end + + else if (T1 = typeSHORTSTRING) and (T2 = typeANSICHAR) then + begin + InsertConversionToAnsiString(N, 1); + Inc(N); + InsertConversionToAnsiString(N, 2); + Inc(N); + R.Op := OP_ADD_ANSISTRING; + GetSymbolRec(R.Res).TypeId := typeANSISTRING; + InsertDeclareTempVar; + end + else if (T1 = typeANSICHAR) and (T2 = typeSHORTSTRING) then + begin + InsertConversionToAnsiString(N, 1); + Inc(N); + InsertConversionToAnsiString(N, 2); + Inc(N); + R.Op := OP_ADD_ANSISTRING; + GetSymbolRec(R.Res).TypeId := typeANSISTRING; + InsertDeclareTempVar; + end + else if (T1 = typeSHORTSTRING) and (T2 = typeANSISTRING) then + begin + InsertConversionToAnsiString(1, 2); + Inc(N); + R.Op := OP_ADD_ANSISTRING; + GetSymbolRec(R.Res).TypeId := typeANSISTRING; + InsertDeclareTempVar; + end + else if (T1 = typeANSISTRING) and (T2 = typeSHORTSTRING) then + begin + InsertConversionToAnsiString(N, 2); + Inc(N); + R.Op := OP_ADD_ANSISTRING; + GetSymbolRec(R.Res).TypeId := typeANSISTRING; + InsertDeclareTempVar; + end +{$ENDIF} + // wide string + + else if GetSymbolRec(Arg1).HasPWideCharType and (T2 in CharTypes) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value + + Chr(Integer(GetSymbolRec(Arg2).value)); + GetSymbolRec(R.Res).TypeId := typePWIDECHAR; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; +{$IFDEF UNIC} + InsertConversionToUnicString(N, 1); + Inc(N); + InsertConversionToUnicString(N, 2); + Inc(N); + R.Op := OP_ADD_UNICSTRING; + GetSymbolRec(R.Res).TypeId := typeUNICSTRING; +{$ELSE} + InsertConversionToWideString(N, 1); + Inc(N); + InsertConversionToWideString(N, 2); + Inc(N); + R.Op := OP_ADD_WIDESTRING; + GetSymbolRec(R.Res).TypeId := typeWIDESTRING; +{$ENDIF} + InsertDeclareTempVar; + end + else if (T1 in CharTypes) and GetSymbolRec(Arg2).HasPWideCharType then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := Chr(Integer(GetSymbolRec(Arg1).value)) + + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).TypeId := typePWIDECHAR; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; +{$IFDEF UNIC} + InsertConversionToUnicString(N, 1); + Inc(N); + InsertConversionToUnicString(N, 2); + Inc(N); + R.Op := OP_ADD_UNICSTRING; + GetSymbolRec(R.Res).TypeId := typeUNICSTRING; +{$ELSE} + InsertConversionToWideString(N, 1); + Inc(N); + InsertConversionToWideString(N, 2); + Inc(N); + R.Op := OP_ADD_WIDESTRING; + GetSymbolRec(R.Res).TypeId := typeWIDESTRING; +{$ENDIF} + InsertDeclareTempVar; + end +{$IFNDEF PAXARM} + else if (T1 = typeWIDESTRING) and (T2 = typeWIDESTRING) then + begin + R.Op := OP_ADD_WIDESTRING; + GetSymbolRec(R.Res).TypeId := typeWIDESTRING; + InsertDeclareTempVar; + end + else if (T1 = typeWIDESTRING) and GetSymbolRec(Arg2).HasPAnsiCharType then + begin + InsertConversionToWideString(N, 2); + Inc(N); + R.Op := OP_ADD_WIDESTRING; + GetSymbolRec(R.Res).TypeId := typeWIDESTRING; + InsertDeclareTempVar; + end + else if GetSymbolRec(Arg1).HasPAnsiCharType and (T2 = typeWIDESTRING) then + begin + InsertConversionToWideString(N, 1); + Inc(N); + R.Op := OP_ADD_WIDESTRING; + GetSymbolRec(R.Res).TypeId := typeWIDESTRING; + InsertDeclareTempVar; + end + else if (T1 = typeWIDESTRING) and GetSymbolRec(Arg2).HasPWideCharType then + begin + InsertConversionToWideString(N, 2); + Inc(N); + R.Op := OP_ADD_WIDESTRING; + GetSymbolRec(R.Res).TypeId := typeWIDESTRING; + InsertDeclareTempVar; + end + else if GetSymbolRec(Arg1).HasPWideCharType and (T2 = typeWIDESTRING) then + begin + InsertConversionToWideString(N, 1); + Inc(N); + R.Op := OP_ADD_WIDESTRING; + GetSymbolRec(R.Res).TypeId := typeWIDESTRING; + InsertDeclareTempVar; + end + else if (T1 = typeWIDESTRING) and (T2 in CharTypes) then + begin + InsertConversionToWideString(N, 2); + Inc(N); + R.Op := OP_ADD_WIDESTRING; + GetSymbolRec(R.Res).TypeId := typeWIDESTRING; + InsertDeclareTempVar; + end + else if (T1 = typeANSICHAR) and (T2 = typeWIDESTRING) then + begin + InsertConversionToWideString(N, 1); + Inc(N); + R.Op := OP_ADD_WIDESTRING; + GetSymbolRec(R.Res).TypeId := typeWIDESTRING; + InsertDeclareTempVar; + end + else if (T1 = typeWIDESTRING) and (T2 = typeANSISTRING) then + begin + InsertConversionToWideString(N, 2); + Inc(N); + R.Op := OP_ADD_WIDESTRING; + GetSymbolRec(R.Res).TypeId := typeWIDESTRING; + InsertDeclareTempVar; + end + else if (T1 = typeANSISTRING) and (T2 = typeWIDESTRING) then + begin + InsertConversionToWideString(N, 1); + Inc(N); + R.Op := OP_ADD_WIDESTRING; + GetSymbolRec(R.Res).TypeId := typeWIDESTRING; + InsertDeclareTempVar; + end +{$ENDIF} + else if (T1 = typeWIDECHAR) and (T2 = typeWIDECHAR) then + begin +{$IFDEF UNIC} + InsertConversionToUnicString(N, 1); + Inc(N); + InsertConversionToUnicString(N, 2); + Inc(N); + R.Op := OP_ADD_UNICSTRING; + GetSymbolRec(R.Res).TypeId := typeUNICSTRING; +{$ELSE} + InsertConversionToWideString(N, 1); + Inc(N); + InsertConversionToWideString(N, 2); + Inc(N); + R.Op := OP_ADD_WIDESTRING; + GetSymbolRec(R.Res).TypeId := typeWIDESTRING; +{$ENDIF} + InsertDeclareTempVar; + end + + // unic string + + else if (T1 = typeUNICSTRING) and (T2 = typeUNICSTRING) then + begin + R.Op := OP_ADD_UNICSTRING; + GetSymbolRec(R.Res).TypeId := typeUNICSTRING; + InsertDeclareTempVar; + end +{$IFNDEF PAXARM} + else if (T1 = typeUNICSTRING) and GetSymbolRec(Arg2).HasPAnsiCharType then + begin + InsertConversionToUnicString(N, 2); + Inc(N); + R.Op := OP_ADD_UNICSTRING; + GetSymbolRec(R.Res).TypeId := typeUNICSTRING; + InsertDeclareTempVar; + end + else if GetSymbolRec(Arg1).HasPAnsiCharType and (T2 = typeUNICSTRING) then + begin + InsertConversionToUnicString(N, 1); + Inc(N); + R.Op := OP_ADD_UNICSTRING; + GetSymbolRec(R.Res).TypeId := typeUNICSTRING; + InsertDeclareTempVar; + end +{$ENDIF} + else if (T1 = typeUNICSTRING) and GetSymbolRec(Arg2).HasPWideCharType then + begin + InsertConversionToUnicString(N, 2); + Inc(N); + R.Op := OP_ADD_UNICSTRING; + GetSymbolRec(R.Res).TypeId := typeUNICSTRING; + InsertDeclareTempVar; + end + else if GetSymbolRec(Arg1).HasPWideCharType and (T2 = typeUNICSTRING) then + begin + InsertConversionToUnicString(N, 1); + Inc(N); + R.Op := OP_ADD_UNICSTRING; + GetSymbolRec(R.Res).TypeId := typeUNICSTRING; + InsertDeclareTempVar; + end +{$IFNDEF PAXARM} + else if (T1 = typeUNICSTRING) and (T2 = typeANSICHAR) then + begin + InsertConversionToUnicString(N, 2); + Inc(N); + R.Op := OP_ADD_UNICSTRING; + GetSymbolRec(R.Res).TypeId := typeUNICSTRING; + InsertDeclareTempVar; + end + else if (T1 = typeANSICHAR) and (T2 = typeUNICSTRING) then + begin + InsertConversionToUnicString(N, 1); + Inc(N); + R.Op := OP_ADD_UNICSTRING; + GetSymbolRec(R.Res).TypeId := typeUNICSTRING; + InsertDeclareTempVar; + end + else if (T1 = typeUNICSTRING) and (T2 = typeANSISTRING) then + begin + InsertConversionToUnicString(N, 2); + Inc(N); + R.Op := OP_ADD_UNICSTRING; + GetSymbolRec(R.Res).TypeId := typeUNICSTRING; + InsertDeclareTempVar; + end + else if (T1 = typeANSISTRING) and (T2 = typeUNICSTRING) then + begin + InsertConversionToUnicString(N, 1); + Inc(N); + R.Op := OP_ADD_UNICSTRING; + GetSymbolRec(R.Res).TypeId := typeUNICSTRING; + InsertDeclareTempVar; + end +{$ENDIF} + else if (T1 = typeUNICSTRING) and (T2 <> typeUNICSTRING) then + begin + InsertConversionToUnicString(N, 2); + Inc(N); + R.Op := OP_ADD_UNICSTRING; + GetSymbolRec(R.Res).TypeId := typeUNICSTRING; + InsertDeclareTempVar; + end + else if (T1 <> typeUNICSTRING) and (T2 = typeUNICSTRING) then + begin + InsertConversionToUnicString(N, 1); + Inc(N); + R.Op := OP_ADD_UNICSTRING; + GetSymbolRec(R.Res).TypeId := typeUNICSTRING; + InsertDeclareTempVar; + end + + // variant + + else if (T1 = typeVARIANT) and (T2 = typeVARIANT) then + begin + R.Op := OP_ADD_VARIANT; + GetSymbolRec(R.Res).TypeId := typeVARIANT; + InsertDeclareTempVar; + end + else if (T1 = typeVARIANT) and (T2 <> typeVARIANT) then + begin + InsertConversionToVariant(N, 2); + Inc(N); + R.Op := OP_ADD_VARIANT; + GetSymbolRec(R.Res).TypeId := typeVARIANT; + InsertDeclareTempVar; + end + else if (T1 <> typeVARIANT) and (T2 = typeVARIANT) then + begin + InsertConversionToVariant(N, 1); + Inc(N); + R.Op := OP_ADD_VARIANT; + GetSymbolRec(R.Res).TypeId := typeVARIANT; + InsertDeclareTempVar; + end +{$IFNDEF PAXARM} + else if GetSymbolRec(Arg1).HasPAnsiCharType and (T2 in CharTypes) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value + + Chr(Integer(GetSymbolRec(Arg2).value)); + GetSymbolRec(R.Res).TypeId := GetSymbolRec(Arg1).TypeId; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + end + else + begin + InsertConversionToAnsiString(N, 1); + Inc(N); + InsertConversionToAnsiString(N, 2); + Inc(N); + R.Op := OP_ADD_ANSISTRING; + GetSymbolRec(R.Res).TypeId := typeANSISTRING; + InsertDeclareTempVar; + end; + end + else if (T1 in CharTypes) and GetSymbolRec(Arg2).HasPAnsiCharType then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := Chr(Integer(GetSymbolRec(Arg1).value)) + + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).TypeId := GetSymbolRec(Arg2).TypeId; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + end + else + begin + InsertConversionToAnsiString(N, 1); + Inc(N); + InsertConversionToAnsiString(N, 2); + Inc(N); + R.Op := OP_ADD_ANSISTRING; + GetSymbolRec(R.Res).TypeId := typeANSISTRING; + InsertDeclareTempVar; + end; + end +{$ENDIF} + else if (T1 = typeRECORD) and ExistsBinaryOperator + (GetSymbolRec(Arg1).TerminalTypeId, gen_Add) then + begin + InsertBinaryOperator(GetSymbolRec(Arg1).TerminalTypeId, gen_Add); + Inc(N); + end + else if (T2 = typeRECORD) and ExistsBinaryOperator + (GetSymbolRec(Arg2).TerminalTypeId, gen_Add) then + begin + InsertBinaryOperator(GetSymbolRec(Arg2).TerminalTypeId, gen_Add); + Inc(N); + end + else + begin + if R.Language = JS_LANGUAGE then + begin +{$IFNDEF PAXARM} + if T1 = typeANSISTRING then + begin + InsertConversionToAnsiString(N, 2, JS_LANGUAGE); + Inc(N); + R.Op := OP_ADD_ANSISTRING; + GetSymbolRec(R.Res).TypeId := typeANSISTRING; + InsertDeclareTempVar; + Exit; + end + else if T2 = typeANSISTRING then + begin + InsertConversionToAnsiString(N, 1, JS_LANGUAGE); + Inc(N); + R.Op := OP_ADD_ANSISTRING; + GetSymbolRec(R.Res).TypeId := typeANSISTRING; + InsertDeclareTempVar; + Exit; + end + else if GetSymbolRec(Arg1).HasPAnsiCharType and (T2 in IntegerTypes) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value + + IntToStr(Integer(GetSymbolRec(Arg2).value)); + GetSymbolRec(R.Res).TypeId := GetSymbolRec(Arg1).TypeId; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + end + else + begin + InsertConversionToAnsiString(N, 1, JS_LANGUAGE); + Inc(N); + InsertConversionToAnsiString(N, 2, JS_LANGUAGE); + Inc(N); + R.Op := OP_ADD_ANSISTRING; + GetSymbolRec(R.Res).TypeId := typeANSISTRING; + InsertDeclareTempVar; + end; + Exit; + end + else if (T1 in IntegerTypes) and GetSymbolRec(Arg2).HasPAnsiCharType then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := + IntToStr(Integer(GetSymbolRec(Arg1).value)) + + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).TypeId := GetSymbolRec(Arg2).TypeId; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + end + else + begin + InsertConversionToAnsiString(N, 1, JS_LANGUAGE); + Inc(N); + InsertConversionToAnsiString(N, 2, JS_LANGUAGE); + Inc(N); + R.Op := OP_ADD_ANSISTRING; + GetSymbolRec(R.Res).TypeId := typeANSISTRING; + InsertDeclareTempVar; + end; + Exit; + end + else +{$ENDIF} + if T1 = typeUNICSTRING then + begin + InsertConversionToUnicString(N, 2, JS_LANGUAGE); + Inc(N); + R.Op := OP_ADD_UNICSTRING; + GetSymbolRec(R.Res).TypeId := typeUNICSTRING; + InsertDeclareTempVar; + Exit; + end + else if T2 = typeUNICSTRING then + begin + InsertConversionToUnicString(N, 1, JS_LANGUAGE); + Inc(N); + R.Op := OP_ADD_UNICSTRING; + GetSymbolRec(R.Res).TypeId := typeUNICSTRING; + InsertDeclareTempVar; + Exit; + end + else if GetSymbolRec(Arg1).HasPWideCharType and (T2 in IntegerTypes) + then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value + + IntToStr(Integer(GetSymbolRec(Arg2).value)); + GetSymbolRec(R.Res).TypeId := GetSymbolRec(Arg1).TypeId; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + end + else + begin + InsertConversionToUnicString(N, 1, JS_LANGUAGE); + Inc(N); + InsertConversionToUnicString(N, 2, JS_LANGUAGE); + Inc(N); + R.Op := OP_ADD_UNICSTRING; + GetSymbolRec(R.Res).TypeId := typeUNICSTRING; + InsertDeclareTempVar; + end; + Exit; + end + else if (T1 in IntegerTypes) and GetSymbolRec(Arg2).HasPWideCharType + then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := + IntToStr(Integer(GetSymbolRec(Arg1).value)) + + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).TypeId := GetSymbolRec(Arg2).TypeId; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + end + else + begin + InsertConversionToUnicString(N, 1, JS_LANGUAGE); + Inc(N); + InsertConversionToUnicString(N, 2, JS_LANGUAGE); + Inc(N); + R.Op := OP_ADD_UNICSTRING; + GetSymbolRec(R.Res).TypeId := typeUNICSTRING; + InsertDeclareTempVar; + end; + Exit; + end; + + end // JS_LANGUAGE + else + begin + if ( +{$IFNDEF PAXARM} + GetSymbolRec(R.Arg1).HasPAnsiCharType or +{$ENDIF} + GetSymbolRec(R.Arg1).HasPWideCharType) and (T2 in IntegerTypes) then + begin + GetSymbolRec(R.Res).TypeId := GetSymbolRec(R.Arg1).TypeId; + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value + + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + if T1 = T2 then + GetSymbolRec(R.Res).TypeId := T1; + R.Op := OP_NOP; + end + else if (K1 = KindVAR) and (K2 = KindVAR) then + R.Op := OP_ADD_INT_MM + else if (K1 = KindVAR) and (K2 = KindCONST) then + begin + R.Op := OP_ADD_INT_MI; + end + else if (K1 = KindCONST) and (K2 = KindVAR) then + begin + R.Op := OP_ADD_INT_MI; + R.SwapArguments; + end; + Exit; + end; + end; + + if GetLanguage(N) = JS_LANGUAGE then + begin + GetSymbolRec(R.Res).TypeId := typeVARIANT; + InsertConversionToVariant(N, 1); + Inc(N); + InsertConversionToVariant(N, 2); + Inc(N); + R.Op := OP_ADD_VARIANT; + Exit; + end; + + T1 := GetSymbolRec(Arg1).TypeId; + T2 := GetSymbolRec(Arg2).TypeId; + CreateError(errIncompatibleTypes, [GetSymbolRec(T1).Name, + GetSymbolRec(T2).Name]); + end; +end; + +procedure TCode.OperNegation; +var + Arg1, T1, K1: Integer; + R: TCodeRec; +begin + R := Records[N]; + + Arg1 := R.Arg1; + T1 := GetSymbolRec(Arg1).FinalTypeId; + K1 := GetSymbolRec(Arg1).Kind; + + if T1 in [typePROC, typeEVENT] then + begin + if InsertSubCall(1) then + Exit; + end; + + if TKernel(kernel).InterfaceOnly then + if (T1 = 0) then + begin + DiscardImport; + Exit; + end; + + if T1 = typeOLEVARIANT then + T1 := typeVARIANT; + + if not(K1 in [KindVAR, KindCONST]) then + begin + CreateError(errIncompatibleTypesNoArgs, []); + Exit; + end; + + if T1 = typeINT64 then + begin + GetSymbolRec(R.Res).TypeId := typeINT64; + if K1 = KindCONST then + begin + GetSymbolRec(R.Res).value := -GetSymbolRec(Arg1).value; + GetSymbolRec(R.Res).Kind := KindCONST; + GetSymbolRec(R.Res).TypeId := T1; + R.Op := OP_NOP; + end + else + R.Op := OP_NEG_INT64; + end + else if T1 = typeUINT64 then + begin + GetSymbolRec(R.Res).TypeId := typeUINT64; + if K1 = KindCONST then + begin + GetSymbolRec(R.Res).value := -GetSymbolRec(Arg1).value; + GetSymbolRec(R.Res).Kind := KindCONST; + GetSymbolRec(R.Res).TypeId := T1; + R.Op := OP_NOP; + end + else + R.Op := OP_NEG_UINT64; + end + else if T1 in IntegerTypes then + begin + GetSymbolRec(R.Res).TypeId := GetIntResultType(T1, T1); + if K1 = KindCONST then + begin + GetSymbolRec(R.Res).value := -GetSymbolRec(Arg1).value; + GetSymbolRec(R.Res).Kind := KindCONST; + GetSymbolRec(R.Res).TypeId := T1; + R.Op := OP_NOP; + end + else + R.Op := OP_NEG_INT; + end + else if T1 = typeDOUBLE then + begin + GetSymbolRec(R.Res).TypeId := typeDOUBLE; + if K1 = KindCONST then + begin + GetSymbolRec(R.Res).value := -GetSymbolRec(Arg1).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + end + else + R.Op := OP_NEG_DOUBLE; + end + else if T1 = typeCURRENCY then + begin + GetSymbolRec(R.Res).TypeId := typeCURRENCY; + if K1 = KindCONST then + begin + GetSymbolRec(R.Res).value := -GetSymbolRec(Arg1).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + end + else + R.Op := OP_NEG_CURRENCY; + end + else if T1 = typeSINGLE then + begin + GetSymbolRec(R.Res).TypeId := typeSINGLE; + if K1 = KindCONST then + begin + GetSymbolRec(R.Res).value := -GetSymbolRec(Arg1).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + end + else + R.Op := OP_NEG_SINGLE; + end + else if T1 = typeEXTENDED then + begin + GetSymbolRec(R.Res).TypeId := typeEXTENDED; + if K1 = KindCONST then + begin + GetSymbolRec(R.Res).value := -GetSymbolRec(Arg1).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + end + else + R.Op := OP_NEG_EXTENDED; + end + else if T1 = typeVARIANT then + begin + GetSymbolRec(R.Res).TypeId := typeVARIANT; + R.Op := OP_NEG_VARIANT; + end + else if T1 = typeRECORD then + begin + InsertUnaryOperator(GetSymbolRec(Arg1).TerminalTypeId, gen_Negative); + Inc(N); + end + else + begin + if GetLanguage(N) = JS_LANGUAGE then + begin + GetSymbolRec(R.Res).TypeId := typeVARIANT; + InsertConversionToVariant(N, 1); + Inc(N); + R.Op := OP_NEG_VARIANT; + Exit; + end; + + T1 := GetSymbolRec(Arg1).TypeId; + CreateError(errOperatorNotApplicableToThisOperandType, + [GetSymbolRec(T1).Name]); + end; +end; + +procedure TCode.OperPositive; +var + Arg1, Res, T1, K1: Integer; + R: TCodeRec; +begin + R := Records[N]; + + Arg1 := R.Arg1; + Res := R.Res; + T1 := GetSymbolRec(Arg1).FinalTypeId; + K1 := GetSymbolRec(Arg1).Kind; + + if T1 in [typePROC, typeEVENT] then + begin + if InsertSubCall(1) then + Exit; + end; + + if TKernel(kernel).InterfaceOnly then + if (T1 = 0) then + begin + DiscardImport; + Exit; + end; + + if T1 = typeOLEVARIANT then + T1 := typeVARIANT; + + if not(K1 in [KindVAR, KindCONST]) then + begin + CreateError(errIncompatibleTypesNoArgs, []); + Exit; + end; + + if T1 = typeINT64 then + begin + R.Op := OP_NOP; + R.Res := Arg1; + ReplaceId(Res, Arg1); + end + else if T1 in IntegerTypes then + begin + R.Op := OP_NOP; + R.Res := Arg1; + ReplaceId(Res, Arg1); + end + else if T1 in RealTypes then + begin + R.Op := OP_NOP; + R.Res := Arg1; + ReplaceId(Res, Arg1); + end + else if T1 = typeVARIANT then + begin + R.Op := OP_NOP; + R.Res := Arg1; + ReplaceId(Res, Arg1); + end + else if T1 = typeRECORD then + begin + InsertUnaryOperator(GetSymbolRec(Arg1).TerminalTypeId, gen_Positive); + Inc(N); + end + else + begin + T1 := GetSymbolRec(Arg1).TypeId; + CreateError(errOperatorNotApplicableToThisOperandType, + [GetSymbolRec(T1).Name]); + end; +end; + +procedure TCode.OperNot; +var + Arg1, T1, K1: Integer; + R: TCodeRec; + S: String; +begin + R := Records[N]; + + Arg1 := R.Arg1; + T1 := GetSymbolRec(Arg1).FinalTypeId; + K1 := GetSymbolRec(Arg1).Kind; + + if T1 in [typePROC, typeEVENT] then + begin + if InsertSubCall(1) then + Exit; + end; + + if TKernel(kernel).InterfaceOnly then + if (T1 = 0) then + begin + DiscardImport; + Exit; + end; + + if T1 = typeOLEVARIANT then + T1 := typeVARIANT; + + if not(K1 in [KindVAR, KindCONST]) then + begin + CreateError(errIncompatibleTypesNoArgs, []); + Exit; + end; + + if T1 in BooleanTypes then + begin + GetSymbolRec(R.Res).TypeId := GetSymbolRec(R.Arg1).TypeId; + if K1 = KindCONST then + begin + GetSymbolRec(R.Res).value := not Boolean(GetSymbolRec(Arg1).value); + GetSymbolRec(R.Res).Kind := KindCONST; + GetSymbolRec(R.Res).TypeId := T1; + R.Op := OP_NOP; + end + else if K1 = KindVAR then + begin + case T1 of + typeBOOLEAN: + R.Op := OP_NOT_BOOL; + typeBYTEBOOL: + R.Op := OP_NOT_BYTEBOOL; + typeWORDBOOL: + R.Op := OP_NOT_WORDBOOL; + typeLONGBOOL: + R.Op := OP_NOT_LONGBOOL; + end; + end; + end + else if T1 in IntegerTypes then + begin + GetSymbolRec(R.Res).TypeId := GetSymbolRec(R.Arg1).TypeId; + if K1 = KindCONST then + begin + GetSymbolRec(R.Res).value := not GetSymbolRec(Arg1).value; + GetSymbolRec(R.Res).Kind := KindCONST; + GetSymbolRec(R.Res).TypeId := T1; + R.Op := OP_NOP; + end + else if K1 = KindVAR then + begin + // ok + end; + end + else if T1 = typeVARIANT then + begin + GetSymbolRec(R.Res).TypeId := typeVARIANT; + R.Op := OP_NOT_VARIANT; + end + else if T1 = typeRECORD then + begin + InsertUnaryOperator(GetSymbolRec(Arg1).TerminalTypeId, gen_LogicalNot); + Inc(N); + end + else + begin + if GetLanguage(N) = JS_LANGUAGE then + begin + GetSymbolRec(R.Res).TypeId := typeVARIANT; + InsertConversionToVariant(N, 1); + Inc(N); + R.Op := OP_NOT_VARIANT; + Exit; + end; + + T1 := GetSymbolRec(Arg1).TypeId; + S := GetSymbolRec(T1).Name; + if (PosCh('_', S) > 0) or (PosCh('.', S) > 0) or (S = '') then + CreateError(errOperatorNotApplicableToThisOperandTypeNoArgs, []) + else + CreateError(errOperatorNotApplicableToThisOperandType, [S]); + end; +end; + +procedure TCode.OperSubtraction; +var + Arg1, Arg2, T1, T2, K1, K2: Integer; + R: TCodeRec; +begin + AdjustTypes; + + R := Records[N]; + + Arg1 := R.Arg1; + Arg2 := R.Arg2; + T1 := GetSymbolRec(Arg1).FinalTypeId; + T2 := GetSymbolRec(Arg2).FinalTypeId; + + if T1 in [typePROC, typeEVENT] then + begin + if InsertSubCall(1) then + Exit; + end; + if T2 in [typePROC, typeEVENT] then + begin + if InsertSubCall(2) then + Exit; + end; + + if TKernel(kernel).InterfaceOnly then + if (T1 = 0) or (T2 = 0) then + begin + DiscardImport; + Exit; + end; + + if T1 = typeSET then + CreateSetObject(Arg1); + if T2 = typeSET then + CreateSetObject(Arg2); + + if T1 = typeOLEVARIANT then + T1 := typeVARIANT; + if T2 = typeOLEVARIANT then + T2 := typeVARIANT; + + K1 := GetSymbolRec(Arg1).Kind; + K2 := GetSymbolRec(Arg2).Kind; + + if not(K1 in [KindVAR, KindCONST]) and (K2 in [KindVAR, KindCONST]) then + begin + CreateError(errIncompatibleTypesNoArgs, []); + Exit; + end; + + if (T1 = typeINT64) and (T2 = typeINT64) then + begin + GetSymbolRec(R.Res).TypeId := typeINT64; + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value - + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + end + else + R.Op := OP_SUB_INT64; + end + else if (T1 = typeINT64) and (T2 in IntegerTypes) then + begin + GetSymbolRec(R.Res).TypeId := GetIntResultType(T1, T2); + + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value - + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + R.Op := OP_SUB_INT64; + + if K2 = KindCONST then + R.Arg2 := CreateConst(typeINT64, GetSymbolRec(R.Arg2).value) + else + begin + InsertConversionToInt64(N, 2); + Inc(N); + end; + end + else if (T1 in IntegerTypes) and (T2 = typeINT64) then + begin + GetSymbolRec(R.Res).TypeId := typeINT64; + + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value - + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + R.Op := OP_SUB_INT64; + + if K1 = KindCONST then + R.Arg1 := CreateConst(typeINT64, GetSymbolRec(R.Arg1).value) + else + begin + InsertConversionToInt64(N, 1); + Inc(N); + end; + end + else if (T1 in IntegerTypes) and (T2 in IntegerTypes) then + begin + GetSymbolRec(R.Res).TypeId := T1; + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value - + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + if T1 = T2 then + GetSymbolRec(R.Res).TypeId := T1; + R.Op := OP_NOP; + end + else if (K1 = KindVAR) and (K2 = KindCONST) then + begin + R.Op := OP_SUB_INT_MI; + GetSymbolRec(R.Res).TypeId := T1; + end + else + R.Op := OP_SUB_INT_MM; + end +{$IFNDEF PAXARM} + else if (GetSymbolRec(R.Arg1).HasPAnsiCharType or GetSymbolRec(R.Arg1) + .HasPWideCharType) and (T2 in IntegerTypes) then + begin + GetSymbolRec(R.Res).TypeId := GetSymbolRec(R.Arg1).TypeId; + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value - + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + end + else if (K1 = KindVAR) and (K2 = KindCONST) then + R.Op := OP_SUB_INT_MI + else + R.Op := OP_SUB_INT_MM; + end +{$ENDIF} + else if (T1 = typeCURRENCY) and (T2 in NumberTypes) then + begin + GetSymbolRec(R.Res).TypeId := typeCURRENCY; + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value - + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + end + else if K2 = KindCONST then + begin + R.Op := OP_SUB_CURRENCY; + if T2 <> typeCURRENCY then + R.Arg2 := CreateConst(typeCURRENCY, GetSymbolRec(R.Arg2).value); + end + else + begin + if T2 <> typeCURRENCY then + R.SwapArguments; + R.Op := OP_SUB_CURRENCY; + end + end + else if (T1 in NumberTypes) and (T2 = typeCURRENCY) then + begin + GetSymbolRec(R.Res).TypeId := typeCURRENCY; + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value - + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + end + else if K1 = KindCONST then + begin + R.Op := OP_SUB_CURRENCY; + if T1 <> typeCURRENCY then + R.Arg1 := CreateConst(typeCURRENCY, GetSymbolRec(R.Arg1).value); + end + else + R.Op := OP_SUB_CURRENCY; + end + else if (T1 = typeDOUBLE) and (T2 = typeDOUBLE) then + begin + GetSymbolRec(R.Res).TypeId := typeDOUBLE; + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value - + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + end + else + R.Op := OP_SUB_DOUBLE; + end + else if (T1 = typeDOUBLE) and (T2 in NumberTypes) then + begin + GetSymbolRec(R.Res).TypeId := typeDOUBLE; + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value - + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + R.Op := OP_SUB_DOUBLE; + if K2 = KindCONST then + R.Arg2 := CreateConst(typeDOUBLE, GetSymbolRec(R.Arg2).value) + else + begin + InsertConversionToDouble(N, 2); + Inc(N); + end; + end + else if (T1 in NumberTypes) and (T2 = typeDOUBLE) then + begin + GetSymbolRec(R.Res).TypeId := typeDOUBLE; + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value - + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + R.Op := OP_SUB_DOUBLE; + + if K1 = KindCONST then + R.Arg1 := CreateConst(typeDOUBLE, GetSymbolRec(R.Arg1).value) + else + begin + InsertConversionToDouble(N, 1); + Inc(N); + end; + end + + else if (T1 = typeSINGLE) and (T2 = typeSINGLE) then + begin + GetSymbolRec(R.Res).TypeId := typeSINGLE; + + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value - + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + R.Op := OP_SUB_SINGLE; + end + else if (T1 = typeSINGLE) and (T2 in NumberTypes) then + begin + GetSymbolRec(R.Res).TypeId := typeSINGLE; + + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value - + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + R.Op := OP_SUB_SINGLE; + + if K2 = KindCONST then + R.Arg2 := CreateConst(typeSINGLE, GetSymbolRec(R.Arg2).value) + else + begin + InsertConversionToSingle(N, 2); + Inc(N); + end; + end + else if (T1 in (NumberTypes)) and (T2 = typeSINGLE) then + begin + GetSymbolRec(R.Res).TypeId := typeSINGLE; + + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value - + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + R.Op := OP_SUB_SINGLE; + + if K1 = KindCONST then + R.Arg1 := CreateConst(typeSINGLE, GetSymbolRec(R.Arg1).value) + else + begin + InsertConversionToSingle(N, 1); + Inc(N); + end; + end + // + else if (T1 = typeEXTENDED) and (T2 = typeEXTENDED) then + begin + GetSymbolRec(R.Res).TypeId := typeEXTENDED; + + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value - + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + R.Op := OP_SUB_EXTENDED; + end + else if (T1 = typeEXTENDED) and (T2 in NumberTypes) then + begin + GetSymbolRec(R.Res).TypeId := typeEXTENDED; + + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value - + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + R.Op := OP_SUB_EXTENDED; + + if K2 = KindCONST then + R.Arg2 := CreateConst(typeEXTENDED, GetSymbolRec(R.Arg2).value) + else + begin + InsertConversionToExtended(N, 2); + Inc(N); + end; + end + else if (T1 in (NumberTypes)) and (T2 = typeEXTENDED) then + begin + GetSymbolRec(R.Res).TypeId := typeEXTENDED; + + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value - + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + R.Op := OP_SUB_EXTENDED; + + if K1 = KindCONST then + R.Arg1 := CreateConst(typeEXTENDED, GetSymbolRec(R.Arg1).value) + else + begin + InsertConversionToExtended(N, 1); + Inc(N); + end; + end + + else if (T1 = typeSET) and (T2 = typeSET) then + begin + T1 := GetSymbolRec(Arg1).TypeId; + T2 := GetSymbolRec(Arg2).TypeId; + + if not MatchSetTypes(T1, T2) then + begin + CreateError(errIncompatibleTypesNoArgs, []); + Exit; + end; + + T2 := GetSymbolRec(T2).PatternId; + + if T2 = typeVOID then + GetSymbolRec(R.Res).TypeId := GetSymbolRec(Arg1).TypeId + else + GetSymbolRec(R.Res).TypeId := GetSymbolRec(Arg2).TypeId; + + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).ValueAsByteSet := GetSymbolRec(Arg1).ValueAsByteSet - + GetSymbolRec(Arg2).ValueAsByteSet; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + end + else if (K1 in [KindVAR, KindCONST]) and (K2 in [KindVAR, KindCONST]) then + R.Op := OP_SET_DIFFERENCE + else + CreateError(errIncompatibleTypesNoArgs, []); + end + else if (T1 = typeVARIANT) and (T2 = typeVARIANT) then + begin + R.Op := OP_SUB_VARIANT; + GetSymbolRec(R.Res).TypeId := typeVARIANT; + end + else if (T1 = typeVARIANT) and (T2 <> typeVARIANT) then + begin + InsertConversionToVariant(N, 2); + Inc(N); + R.Op := OP_SUB_VARIANT; + GetSymbolRec(R.Res).TypeId := typeVARIANT; + end + else if (T1 <> typeVARIANT) and (T2 = typeVARIANT) then + begin + InsertConversionToVariant(N, 1); + Inc(N); + R.Op := OP_SUB_VARIANT; + GetSymbolRec(R.Res).TypeId := typeVARIANT; + end + else if (T1 = typeRECORD) and ExistsBinaryOperator + (GetSymbolRec(Arg1).TerminalTypeId, gen_Subtract) then + begin + InsertBinaryOperator(GetSymbolRec(Arg1).TerminalTypeId, gen_Subtract); + Inc(N); + end + else if (T2 = typeRECORD) and ExistsBinaryOperator + (GetSymbolRec(Arg2).TerminalTypeId, gen_Subtract) then + begin + InsertBinaryOperator(GetSymbolRec(Arg2).TerminalTypeId, gen_Subtract); + Inc(N); + end + else + begin + T1 := GetSymbolRec(Arg1).TypeId; + T2 := GetSymbolRec(Arg2).TypeId; + + if R.Language = JS_LANGUAGE then + begin + InsertConversionToVariant(N, 1); + Inc(N); + InsertConversionToVariant(N, 2); + Inc(N); + GetSymbolRec(R.Res).TypeId := typeVARIANT; + InsertDeclareTempVar; + + Dec(N); + + Exit; + end; + + CreateError(errIncompatibleTypes, [GetSymbolRec(T1).Name, + GetSymbolRec(T2).Name]); + end; +end; + +procedure TCode.OperMultiplication; +var + Arg1, Arg2, T1, T2, K1, K2: Integer; + R: TCodeRec; +begin + AdjustTypes; + + R := Records[N]; + + Arg1 := R.Arg1; + Arg2 := R.Arg2; + T1 := GetSymbolRec(Arg1).FinalTypeId; + T2 := GetSymbolRec(Arg2).FinalTypeId; + + if T1 in [typePROC, typeEVENT] then + begin + if InsertSubCall(1) then + Exit; + end; + if T2 in [typePROC, typeEVENT] then + begin + if InsertSubCall(2) then + Exit; + end; + + if TKernel(kernel).InterfaceOnly then + if (T1 = 0) or (T2 = 0) then + begin + DiscardImport; + Exit; + end; + + if T1 = typeSET then + CreateSetObject(Arg1); + if T2 = typeSET then + CreateSetObject(Arg2); + + if T1 = typeOLEVARIANT then + T1 := typeVARIANT; + if T2 = typeOLEVARIANT then + T2 := typeVARIANT; + + K1 := GetSymbolRec(Arg1).Kind; + K2 := GetSymbolRec(Arg2).Kind; + + if not(K1 in [KindVAR, KindCONST]) and (K2 in [KindVAR, KindCONST]) then + begin + CreateError(errIncompatibleTypesNoArgs, []); + Exit; + end; + + if (T1 = typeINT64) and (T2 = typeINT64) then + begin + GetSymbolRec(R.Res).TypeId := typeINT64; + R.Op := OP_MULT_INT64; + end + else if (T1 = typeINT64) and (T2 in IntegerTypes) then + begin + GetSymbolRec(R.Res).TypeId := typeINT64; + + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value * + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + R.Op := OP_MULT_INT64; + + if K2 = KindCONST then + R.Arg2 := CreateConst(typeINT64, GetSymbolRec(R.Arg2).value) + else + begin + InsertConversionToInt64(N, 2); + Inc(N); + end; + end + else if (T1 in IntegerTypes) and (T2 = typeINT64) then + begin + GetSymbolRec(R.Res).TypeId := typeINT64; + + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value * + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + R.Op := OP_MULT_INT64; + + if K1 = KindCONST then + R.Arg1 := CreateConst(typeINT64, GetSymbolRec(R.Arg1).value) + else + begin + InsertConversionToInt64(N, 1); + Inc(N); + end; + end + + else if (T1 in IntegerTypes) and (T2 in IntegerTypes) then + begin + GetSymbolRec(R.Res).TypeId := GetIntResultType(T1, T2); + + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value * + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + + if T1 = T2 then + GetSymbolRec(R.Res).TypeId := T1; + R.Op := OP_NOP; + end + else if (K1 = KindVAR) and (K2 = KindVAR) then + R.Op := OP_IMUL_INT_MM + else if (K1 = KindVAR) and (K2 = KindCONST) then + begin + R.Op := OP_IMUL_INT_MI; + // GetSymbolRec(R.Res).TypeID := T1; + end + else if (K1 = KindCONST) and (K2 = KindVAR) then + begin + R.Op := OP_IMUL_INT_MI; + R.SwapArguments; + // GetSymbolRec(R.Res).TypeID := T2; + end; + end + else if (T1 = typeCURRENCY) and (T2 in NumberTypes) then + begin + GetSymbolRec(R.Res).TypeId := typeCURRENCY; + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value * + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + end + else if K2 = KindCONST then + begin + R.Op := OP_MUL_CURRENCY; + if T2 <> typeCURRENCY then + begin + R.Arg2 := CreateConst(typeCURRENCY, GetSymbolRec(R.Arg2).value); + R.SwapArguments; + end; + end + else + begin + if T2 <> typeCURRENCY then + R.SwapArguments; + R.Op := OP_MUL_CURRENCY; + end + end + else if (T1 in NumberTypes) and (T2 = typeCURRENCY) then + begin + GetSymbolRec(R.Res).TypeId := typeCURRENCY; + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value * + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + end + else if K1 = KindCONST then + begin + R.Op := OP_MUL_CURRENCY; + if T1 <> typeCURRENCY then + R.Arg1 := CreateConst(typeCURRENCY, GetSymbolRec(R.Arg1).value); + end + else + R.Op := OP_MUL_CURRENCY; + end + else if (T1 = typeDOUBLE) and (T2 = typeDOUBLE) then + begin + GetSymbolRec(R.Res).TypeId := typeDOUBLE; + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value * + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + end + else + R.Op := OP_MUL_DOUBLE; + end + else if (T1 = typeDOUBLE) and (T2 in NumberTypes) then + begin + GetSymbolRec(R.Res).TypeId := typeDOUBLE; + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value * + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + R.Op := OP_MUL_DOUBLE; + if K2 = KindCONST then + R.Arg2 := CreateConst(typeDOUBLE, GetSymbolRec(R.Arg2).value) + else + begin + InsertConversionToDouble(N, 2); + Inc(N); + end; + end + else if (T1 in NumberTypes) and (T2 = typeDOUBLE) then + begin + GetSymbolRec(R.Res).TypeId := typeDOUBLE; + + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value * + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + R.Op := OP_MUL_DOUBLE; + + if K1 = KindCONST then + R.Arg1 := CreateConst(typeDOUBLE, GetSymbolRec(R.Arg1).value) + else + begin + InsertConversionToDouble(N, 1); + Inc(N); + end; + end + + else if (T1 = typeSINGLE) and (T2 = typeSINGLE) then + begin + GetSymbolRec(R.Res).TypeId := typeSINGLE; + + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value * + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + R.Op := OP_MUL_SINGLE; + end + else if (T1 = typeSINGLE) and (T2 in NumberTypes) then + begin + GetSymbolRec(R.Res).TypeId := typeSINGLE; + + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value * + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + R.Op := OP_MUL_SINGLE; + + if K2 = KindCONST then + R.Arg2 := CreateConst(typeSINGLE, GetSymbolRec(R.Arg2).value) + else + begin + InsertConversionToSingle(N, 2); + Inc(N); + end; + end + else if (T1 in NumberTypes) and (T2 = typeSINGLE) then + begin + GetSymbolRec(R.Res).TypeId := typeSINGLE; + + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value * + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + R.Op := OP_MUL_SINGLE; + + if K1 = KindCONST then + R.Arg1 := CreateConst(typeSINGLE, GetSymbolRec(R.Arg1).value) + else + begin + InsertConversionToSingle(N, 1); + Inc(N); + end; + end + // + else if (T1 = typeEXTENDED) and (T2 = typeEXTENDED) then + begin + GetSymbolRec(R.Res).TypeId := typeEXTENDED; + + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value * + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + R.Op := OP_MUL_EXTENDED; + end + else if (T1 = typeEXTENDED) and (T2 in NumberTypes) then + begin + GetSymbolRec(R.Res).TypeId := typeEXTENDED; + + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value * + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + R.Op := OP_MUL_EXTENDED; + + if K2 = KindCONST then + R.Arg2 := CreateConst(typeEXTENDED, GetSymbolRec(R.Arg2).value) + else + begin + InsertConversionToExtended(N, 2); + Inc(N); + end; + end + else if (T1 in NumberTypes) and (T2 = typeEXTENDED) then + begin + GetSymbolRec(R.Res).TypeId := typeEXTENDED; + + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value * + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + R.Op := OP_MUL_EXTENDED; + + if K1 = KindCONST then + R.Arg1 := CreateConst(typeEXTENDED, GetSymbolRec(R.Arg1).value) + else + begin + InsertConversionToExtended(N, 1); + Inc(N); + end; + end + + else if (T1 = typeSET) and (T2 = typeSET) then + begin + T1 := GetSymbolRec(Arg1).TypeId; + T2 := GetSymbolRec(Arg2).TypeId; + + if not MatchSetTypes(T1, T2) then + begin + CreateError(errIncompatibleTypesNoArgs, []); + Exit; + end; + + T2 := GetSymbolRec(T2).PatternId; + + if T2 = typeVOID then + GetSymbolRec(R.Res).TypeId := GetSymbolRec(Arg1).TypeId + else + GetSymbolRec(R.Res).TypeId := GetSymbolRec(Arg2).TypeId; + + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).ValueAsByteSet := GetSymbolRec(Arg1).ValueAsByteSet * + GetSymbolRec(Arg2).ValueAsByteSet; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + end + else if (K1 in [KindVAR, KindCONST]) and (K2 in [KindVAR, KindCONST]) then + R.Op := OP_SET_INTERSECTION + else + CreateError(errIncompatibleTypesNoArgs, []); + end + else if (T1 = typeVARIANT) and (T2 = typeVARIANT) then + begin + R.Op := OP_MULT_VARIANT; + GetSymbolRec(R.Res).TypeId := typeVARIANT; + end + else if (T1 = typeVARIANT) and (T2 <> typeVARIANT) then + begin + InsertConversionToVariant(N, 2); + Inc(N); + R.Op := OP_MULT_VARIANT; + GetSymbolRec(R.Res).TypeId := typeVARIANT; + end + else if (T1 <> typeVARIANT) and (T2 = typeVARIANT) then + begin + InsertConversionToVariant(N, 1); + Inc(N); + R.Op := OP_MULT_VARIANT; + GetSymbolRec(R.Res).TypeId := typeVARIANT; + end + else if (T1 = typeRECORD) and ExistsBinaryOperator + (GetSymbolRec(Arg1).TerminalTypeId, gen_Multiply) then + begin + InsertBinaryOperator(GetSymbolRec(Arg1).TerminalTypeId, gen_Multiply); + Inc(N); + end + else if (T2 = typeRECORD) and ExistsBinaryOperator + (GetSymbolRec(Arg2).TerminalTypeId, gen_Multiply) then + begin + InsertBinaryOperator(GetSymbolRec(Arg2).TerminalTypeId, gen_Multiply); + Inc(N); + end + else + begin + if GetLanguage(N) = JS_LANGUAGE then + begin + GetSymbolRec(R.Res).TypeId := typeVARIANT; + InsertConversionToVariant(N, 1); + Inc(N); + InsertConversionToVariant(N, 2); + Inc(N); + R.Op := OP_MULT_VARIANT; + Exit; + end; + + T1 := GetSymbolRec(Arg1).TypeId; + T2 := GetSymbolRec(Arg2).TypeId; + CreateError(errIncompatibleTypes, [GetSymbolRec(T1).Name, + GetSymbolRec(T2).Name]); + end; +end; + +procedure TCode.AdjustTypes; +var + Arg1, Arg2, T, K1, K2, I, Op: Integer; + R: TCodeRec; + I64: Int64; +begin + R := Records[N]; + + Arg1 := R.Arg1; + Arg2 := R.Arg2; + K1 := GetSymbolRec(Arg1).Kind; + K2 := GetSymbolRec(Arg2).Kind; + + if (K1 <> KindCONST) or (K2 <> KindCONST) then + Exit; + + I := N; + repeat + if (Records[I + 1].Op = OP_ASSIGN) and (Records[I + 1].Arg2 = R.Res) then + begin + T := GetSymbolRec(Records[I + 1].Arg1).FinalTypeId; + if T = 0 then + Exit; + if not(T in (IntegerTypes + RealTypes)) then + Exit; + + GetSymbolRec(Arg1).TypeId := T; + GetSymbolRec(Arg2).TypeId := T; + case T of + typeINT64: + begin +{$IFDEF VARIANTS} + I64 := GetSymbolRec(Arg1).value; + GetSymbolRec(Arg1).value := I64; + I64 := GetSymbolRec(Arg2).value; + GetSymbolRec(Arg2).value := I64; +{$ELSE} + I64 := Integer(GetSymbolRec(Arg1).value); + GetSymbolRec(Arg1).value := Integer(I64); + I64 := Integer(GetSymbolRec(Arg2).value); + GetSymbolRec(Arg2).value := Integer(I64); +{$ENDIF} + end; + typeSINGLE: + begin + GetSymbolRec(Arg1).value := Single(GetSymbolRec(Arg1).value); + GetSymbolRec(Arg2).value := Single(GetSymbolRec(Arg2).value); + end; + typeDOUBLE: + begin + GetSymbolRec(Arg1).value := Double(GetSymbolRec(Arg1).value); + GetSymbolRec(Arg2).value := Double(GetSymbolRec(Arg2).value); + end; + typeEXTENDED: + begin + GetSymbolRec(Arg1).value := Extended(GetSymbolRec(Arg1).value); + GetSymbolRec(Arg2).value := Extended(GetSymbolRec(Arg2).value); + end; + typeCURRENCY: + begin + GetSymbolRec(Arg1).value := Currency(GetSymbolRec(Arg1).value); + GetSymbolRec(Arg2).value := Currency(GetSymbolRec(Arg2).value); + end; + end; + Exit; + end; + + Op := Records[I].Op; + + if Op = OP_SEPARATOR then + begin + Inc(I); + continue; + end; + + if (Op = OP_PLUS) or (Op = OP_MINUS) or (Op = OP_MULT) or (Op = OP_DIV) or + (Op = OP_IDIV) or (Op = OP_MOD) or (Op = OP_SHL) or (Op = OP_SHR) or + (Op = OP_AND) or (Op = OP_OR) or (Op = OP_XOR) or (Op = OP_NOT) or + (Op = OP_GT) or (Op = OP_GE) or (Op = OP_LT) or (Op = OP_LE) or + (Op = OP_EQ) or (Op = OP_NE) then + Inc(I) + else + Exit; + + until false; +end; + +procedure TCode.OperDivision; +var + Arg1, Arg2, T1, T2, K1, K2: Integer; + R: TCodeRec; +begin + AdjustTypes; + + R := Records[N]; + + Arg1 := R.Arg1; + Arg2 := R.Arg2; + T1 := GetSymbolRec(Arg1).FinalTypeId; + T2 := GetSymbolRec(Arg2).FinalTypeId; + + if T1 in [typePROC, typeEVENT] then + begin + if InsertSubCall(1) then + Exit; + end; + if T2 in [typePROC, typeEVENT] then + begin + if InsertSubCall(2) then + Exit; + end; + + K1 := GetSymbolRec(Arg1).Kind; + K2 := GetSymbolRec(Arg2).Kind; + + if TKernel(kernel).InterfaceOnly then + if (T1 = 0) or (T2 = 0) then + begin + DiscardImport; + Exit; + end; + + if T1 = typeOLEVARIANT then + T1 := typeVARIANT; + if T2 = typeOLEVARIANT then + T2 := typeVARIANT; + + if not(K1 in [KindVAR, KindCONST]) and (K2 in [KindVAR, KindCONST]) then + begin + CreateError(errIncompatibleTypesNoArgs, []); + Exit; + end; + + if (T1 in IntegerTypes) and (T2 in IntegerTypes) then + begin + GetSymbolRec(R.Res).TypeId := typeDOUBLE; + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + if GetSymbolRec(Arg2).value = 0 then + CreateError(errDivisionByZero, []) + else + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value / + GetSymbolRec(Arg2).value; + + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + if (R.Language = JS_LANGUAGE) and (not GetSymbolRec(R.Res).FinalTypeId + in IntegerTypes) then + begin + if K1 = KindCONST then + R.Op := OP_IDIV_INT_IM + else if K2 = KindCONST then + R.Op := OP_IDIV_INT_MI + else + R.Op := OP_IDIV_INT_MM; + GetSymbolRec(R.Res).TypeId := typeINTEGER; + Exit; + end; + + R.Op := OP_DIV_DOUBLE; + + if K1 = KindCONST then + R.Arg1 := CreateConst(typeDOUBLE, GetSymbolRec(R.Arg1).value) + else + begin + InsertConversionToDouble(N, 1); + Inc(N); + end; + + if K2 = KindCONST then + R.Arg2 := CreateConst(typeDOUBLE, GetSymbolRec(R.Arg2).value) + else + begin + InsertConversionToDouble(N, 2); + Inc(N); + end; + + end + else if (T1 = typeCURRENCY) and (T2 in NumberTypes) then + begin + GetSymbolRec(R.Res).TypeId := typeCURRENCY; + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value / + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + end + else if K2 = KindCONST then + begin + R.Op := OP_DIV_CURRENCY; + if T2 <> typeCURRENCY then + R.Arg2 := CreateConst(typeDOUBLE, GetSymbolRec(R.Arg2).value); + end + else + R.Op := OP_DIV_CURRENCY; + end + else if (T1 in NumberTypes) and (T2 = typeCURRENCY) then + begin + GetSymbolRec(R.Res).TypeId := typeCURRENCY; + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value / + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + end + else if K1 = KindCONST then + begin + R.Op := OP_DIV_CURRENCY; + if T1 <> typeCURRENCY then + R.Arg1 := CreateConst(typeDOUBLE, GetSymbolRec(R.Arg1).value); + end + else + R.Op := OP_DIV_CURRENCY; + end + else if (T1 = typeDOUBLE) and (T2 = typeDOUBLE) then + begin + GetSymbolRec(R.Res).TypeId := typeDOUBLE; + + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + if GetSymbolRec(Arg2).value = 0 then + CreateError(errDivisionByZero, []) + else + GetSymbolRec(R.Res).value := Double(GetSymbolRec(Arg1).value) / + Double(GetSymbolRec(Arg2).value); + + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + R.Op := OP_DIV_DOUBLE; + end + else if (T1 = typeDOUBLE) and (T2 in NumberTypes) then + begin + GetSymbolRec(R.Res).TypeId := typeDOUBLE; + + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + if GetSymbolRec(Arg2).value = 0 then + CreateError(errDivisionByZero, []) + else + GetSymbolRec(R.Res).value := Double(GetSymbolRec(Arg1).value) / + Double(GetSymbolRec(Arg2).value); + + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + R.Op := OP_DIV_DOUBLE; + + if K2 = KindCONST then + R.Arg2 := CreateConst(typeDOUBLE, GetSymbolRec(R.Arg2).value) + else + begin + InsertConversionToDouble(N, 2); + Inc(N); + end; + end + else if (T1 in NumberTypes) and (T2 = typeDOUBLE) then + begin + GetSymbolRec(R.Res).TypeId := typeDOUBLE; + + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + if GetSymbolRec(Arg2).value = 0 then + CreateError(errDivisionByZero, []) + else + GetSymbolRec(R.Res).value := Double(GetSymbolRec(Arg1).value) / + Double(GetSymbolRec(Arg2).value); + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + R.Op := OP_DIV_DOUBLE; + + if K1 = KindCONST then + R.Arg1 := CreateConst(typeDOUBLE, GetSymbolRec(R.Arg1).value) + else + begin + InsertConversionToDouble(N, 1); + Inc(N); + end; + end + + else if (T1 = typeSINGLE) and (T2 = typeSINGLE) then + begin + GetSymbolRec(R.Res).TypeId := typeSINGLE; + + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + if GetSymbolRec(Arg2).value = 0 then + CreateError(errDivisionByZero, []) + else + GetSymbolRec(R.Res).value := Single(GetSymbolRec(Arg1).value) / + Single(GetSymbolRec(Arg2).value); + + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + R.Op := OP_DIV_SINGLE; + end + else if (T1 = typeSINGLE) and (T2 in NumberTypes) then + begin + GetSymbolRec(R.Res).TypeId := typeSINGLE; + + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + if GetSymbolRec(Arg2).value = 0 then + CreateError(errDivisionByZero, []) + else + GetSymbolRec(R.Res).value := Single(GetSymbolRec(Arg1).value) / + Single(GetSymbolRec(Arg2).value); + + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + R.Op := OP_DIV_SINGLE; + + if K2 = KindCONST then + R.Arg2 := CreateConst(typeSINGLE, GetSymbolRec(R.Arg2).value) + else + begin + InsertConversionToSingle(N, 2); + Inc(N); + end; + end + else if (T1 in NumberTypes) and (T2 = typeSINGLE) then + begin + GetSymbolRec(R.Res).TypeId := typeSINGLE; + + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + if GetSymbolRec(Arg2).value = 0 then + CreateError(errDivisionByZero, []) + else + GetSymbolRec(R.Res).value := Single(GetSymbolRec(Arg1).value) / + Single(GetSymbolRec(Arg2).value); + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + R.Op := OP_DIV_SINGLE; + + if K1 = KindCONST then + R.Arg1 := CreateConst(typeSINGLE, GetSymbolRec(R.Arg1).value) + else + begin + InsertConversionToSingle(N, 1); + Inc(N); + end; + end + // + else if (T1 = typeEXTENDED) and (T2 = typeEXTENDED) then + begin + GetSymbolRec(R.Res).TypeId := typeEXTENDED; + + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + if GetSymbolRec(Arg2).value = 0 then + CreateError(errDivisionByZero, []) + else + GetSymbolRec(R.Res).value := Extended(GetSymbolRec(Arg1).value) / + Extended(GetSymbolRec(Arg2).value); + + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + R.Op := OP_DIV_EXTENDED; + end + else if (T1 = typeEXTENDED) and (T2 in NumberTypes) then + begin + GetSymbolRec(R.Res).TypeId := typeEXTENDED; + + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + if GetSymbolRec(Arg2).value = 0 then + CreateError(errDivisionByZero, []) + else + GetSymbolRec(R.Res).value := Extended(GetSymbolRec(Arg1).value) / + Extended(GetSymbolRec(Arg2).value); + + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + R.Op := OP_DIV_EXTENDED; + + if K2 = KindCONST then + R.Arg2 := CreateConst(typeEXTENDED, GetSymbolRec(R.Arg2).value) + else + begin + InsertConversionToExtended(N, 2); + Inc(N); + end; + end + else if (T1 in NumberTypes) and (T2 = typeEXTENDED) then + begin + GetSymbolRec(R.Res).TypeId := typeEXTENDED; + + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + if GetSymbolRec(Arg2).value = 0 then + CreateError(errDivisionByZero, []) + else + GetSymbolRec(R.Res).value := Extended(GetSymbolRec(Arg1).value) / + Extended(GetSymbolRec(Arg2).value); + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + R.Op := OP_DIV_EXTENDED; + + if K1 = KindCONST then + R.Arg1 := CreateConst(typeEXTENDED, GetSymbolRec(R.Arg1).value) + else + begin + InsertConversionToExtended(N, 1); + Inc(N); + end; + end + else if (T1 = typeVARIANT) and (T2 = typeVARIANT) then + begin + R.Op := OP_DIV_VARIANT; + GetSymbolRec(R.Res).TypeId := typeVARIANT; + end + else if (T1 = typeVARIANT) and (T2 <> typeVARIANT) then + begin + InsertConversionToVariant(N, 2); + Inc(N); + R.Op := OP_DIV_VARIANT; + GetSymbolRec(R.Res).TypeId := typeVARIANT; + end + else if (T1 <> typeVARIANT) and (T2 = typeVARIANT) then + begin + InsertConversionToVariant(N, 1); + Inc(N); + R.Op := OP_DIV_VARIANT; + GetSymbolRec(R.Res).TypeId := typeVARIANT; + end + else if (T1 = typeRECORD) and ExistsBinaryOperator + (GetSymbolRec(Arg1).TerminalTypeId, gen_Divide) then + begin + InsertBinaryOperator(GetSymbolRec(Arg1).TerminalTypeId, gen_Divide); + Inc(N); + end + else if (T2 = typeRECORD) and ExistsBinaryOperator + (GetSymbolRec(Arg2).TerminalTypeId, gen_Divide) then + begin + InsertBinaryOperator(GetSymbolRec(Arg2).TerminalTypeId, gen_Divide); + Inc(N); + end + else + begin + if GetLanguage(N) = JS_LANGUAGE then + begin + GetSymbolRec(R.Res).TypeId := typeVARIANT; + InsertConversionToVariant(N, 1); + Inc(N); + InsertConversionToVariant(N, 2); + Inc(N); + R.Op := OP_DIV_VARIANT; + Exit; + end; + + T1 := GetSymbolRec(Arg1).TypeId; + T2 := GetSymbolRec(Arg2).TypeId; + CreateError(errIncompatibleTypes, [GetSymbolRec(T1).Name, + GetSymbolRec(T2).Name]); + end; +end; + +procedure TCode.OperIDivision; +var + Arg1, Arg2, T1, T2, K1, K2: Integer; + R: TCodeRec; +begin + AdjustTypes; + + R := Records[N]; + + Arg1 := R.Arg1; + Arg2 := R.Arg2; + T1 := GetSymbolRec(Arg1).FinalTypeId; + T2 := GetSymbolRec(Arg2).FinalTypeId; + + if T1 in [typePROC, typeEVENT] then + begin + if InsertSubCall(1) then + Exit; + end; + if T2 in [typePROC, typeEVENT] then + begin + if InsertSubCall(2) then + Exit; + end; + + if TKernel(kernel).InterfaceOnly then + if (T1 = 0) or (T2 = 0) then + begin + DiscardImport; + Exit; + end; + + K1 := GetSymbolRec(Arg1).Kind; + K2 := GetSymbolRec(Arg2).Kind; + + if T1 = typeOLEVARIANT then + T1 := typeVARIANT; + if T2 = typeOLEVARIANT then + T2 := typeVARIANT; + + if not(K1 in [KindVAR, KindCONST]) and (K2 in [KindVAR, KindCONST]) then + begin + CreateError(errIncompatibleTypesNoArgs, []); + Exit; + end; + + if (T1 = typeINT64) and (T2 = typeINT64) then + begin + GetSymbolRec(R.Res).TypeId := typeINT64; + R.Op := OP_IDIV_INT64; + end + else if (T1 = typeINT64) and (T2 in IntegerTypes) then + begin + GetSymbolRec(R.Res).TypeId := typeINT64; + + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + if GetSymbolRec(Arg2).value = 0 then + CreateError(errDivisionByZero, []) + else + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value div GetSymbolRec + (Arg2).value; + + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + R.Op := OP_IDIV_INT64; + + if K2 = KindCONST then + R.Arg2 := CreateConst(typeINT64, GetSymbolRec(R.Arg2).value) + else + begin + InsertConversionToInt64(N, 2); + Inc(N); + end; + end + else if (T1 in IntegerTypes) and (T2 = typeINT64) then + begin + GetSymbolRec(R.Res).TypeId := typeINT64; + + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + if GetSymbolRec(Arg2).value = 0 then + CreateError(errDivisionByZero, []) + else + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value div GetSymbolRec + (Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + R.Op := OP_IDIV_INT64; + + if K1 = KindCONST then + R.Arg1 := CreateConst(typeINT64, GetSymbolRec(R.Arg1).value) + else + begin + InsertConversionToInt64(N, 1); + Inc(N); + end; + end + else if (T1 in IntegerTypes) and (T2 in IntegerTypes) then + begin + GetSymbolRec(R.Res).TypeId := typeINTEGER; + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + if GetSymbolRec(Arg2).value = 0 then + CreateError(errDivisionByZero, []) + else + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value div GetSymbolRec + (Arg2).value; + + GetSymbolRec(R.Res).Kind := KindCONST; + + if T1 = T2 then + GetSymbolRec(R.Res).TypeId := T1; + R.Op := OP_NOP; + end + else if (K1 = KindVAR) and (K2 = KindVAR) then + R.Op := OP_IDIV_INT_MM + else if (K1 = KindVAR) and (K2 = KindCONST) then + begin + if GetSymbolRec(Arg2).value = 0 then + CreateError(errDivisionByZero, []); + + R.Op := OP_IDIV_INT_MI; + GetSymbolRec(R.Res).TypeId := T1; + end + else if (K1 = KindCONST) and (K2 = KindVAR) then + begin + R.Op := OP_IDIV_INT_IM; + GetSymbolRec(R.Res).TypeId := T2; + end; + end + else if (T1 = typeVARIANT) and (T2 = typeVARIANT) then + begin + R.Op := OP_IDIV_VARIANT; + GetSymbolRec(R.Res).TypeId := typeVARIANT; + end + else if (T1 = typeVARIANT) and (T2 <> typeVARIANT) then + begin + InsertConversionToVariant(N, 2); + Inc(N); + R.Op := OP_IDIV_VARIANT; + GetSymbolRec(R.Res).TypeId := typeVARIANT; + end + else if (T1 <> typeVARIANT) and (T2 = typeVARIANT) then + begin + InsertConversionToVariant(N, 1); + Inc(N); + R.Op := OP_IDIV_VARIANT; + GetSymbolRec(R.Res).TypeId := typeVARIANT; + end + else if (T1 = typeRECORD) and ExistsBinaryOperator + (GetSymbolRec(Arg1).TerminalTypeId, gen_IntDivide) then + begin + InsertBinaryOperator(GetSymbolRec(Arg1).TerminalTypeId, gen_IntDivide); + Inc(N); + end + else if (T2 = typeRECORD) and ExistsBinaryOperator + (GetSymbolRec(Arg2).TerminalTypeId, gen_IntDivide) then + begin + InsertBinaryOperator(GetSymbolRec(Arg2).TerminalTypeId, gen_IntDivide); + Inc(N); + end + else + begin + if GetLanguage(N) = JS_LANGUAGE then + begin + GetSymbolRec(R.Res).TypeId := typeVARIANT; + InsertConversionToVariant(N, 1); + Inc(N); + InsertConversionToVariant(N, 2); + Inc(N); + R.Op := OP_IDIV_VARIANT; + Exit; + end; + + T1 := GetSymbolRec(Arg1).TypeId; + T2 := GetSymbolRec(Arg2).TypeId; + CreateError(errIncompatibleTypes, [GetSymbolRec(T1).Name, + GetSymbolRec(T2).Name]); + end; +end; + +procedure TCode.OperModulo; +var + Arg1, Arg2, T1, T2, K1, K2: Integer; + R: TCodeRec; +begin + R := Records[N]; + + Arg1 := R.Arg1; + Arg2 := R.Arg2; + T1 := GetSymbolRec(Arg1).FinalTypeId; + T2 := GetSymbolRec(Arg2).FinalTypeId; + + if T1 in [typePROC, typeEVENT] then + begin + if InsertSubCall(1) then + Exit; + end; + if T2 in [typePROC, typeEVENT] then + begin + if InsertSubCall(2) then + Exit; + end; + + if TKernel(kernel).InterfaceOnly then + if (T1 = 0) or (T2 = 0) then + begin + DiscardImport; + Exit; + end; + + K1 := GetSymbolRec(Arg1).Kind; + K2 := GetSymbolRec(Arg2).Kind; + + if T1 = typeOLEVARIANT then + T1 := typeVARIANT; + if T2 = typeOLEVARIANT then + T2 := typeVARIANT; + + if not(K1 in [KindVAR, KindCONST]) and (K2 in [KindVAR, KindCONST]) then + begin + CreateError(errIncompatibleTypesNoArgs, []); + Exit; + end; + + if (T1 = typeINT64) and (T2 = typeINT64) then + begin + GetSymbolRec(R.Res).TypeId := typeINT64; + R.Op := OP_MOD_INT64; + end + else if (T1 = typeINT64) and (T2 in IntegerTypes) then + begin + GetSymbolRec(R.Res).TypeId := typeINT64; + + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + if GetSymbolRec(Arg2).value = 0 then + CreateError(errDivisionByZero, []) + else + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value mod GetSymbolRec + (Arg2).value; + + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + R.Op := OP_MOD_INT64; + + if K2 = KindCONST then + R.Arg2 := CreateConst(typeINT64, GetSymbolRec(R.Arg2).value) + else + begin + InsertConversionToInt64(N, 2); + Inc(N); + end; + end + else if (T1 in IntegerTypes) and (T2 = typeINT64) then + begin + GetSymbolRec(R.Res).TypeId := typeINT64; + + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + if GetSymbolRec(Arg2).value = 0 then + CreateError(errDivisionByZero, []) + else + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value mod GetSymbolRec + (Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + R.Op := OP_MOD_INT64; + + if K1 = KindCONST then + R.Arg1 := CreateConst(typeINT64, GetSymbolRec(R.Arg1).value) + else + begin + InsertConversionToInt64(N, 1); + Inc(N); + end; + end + + else if (T1 in IntegerTypes) and (T2 in IntegerTypes) then + begin + GetSymbolRec(R.Res).TypeId := typeINTEGER; + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + if GetSymbolRec(Arg2).value = 0 then + CreateError(errDivisionByZero, []) + else + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value mod GetSymbolRec + (Arg2).value; + + GetSymbolRec(R.Res).Kind := KindCONST; + + if T1 = T2 then + GetSymbolRec(R.Res).TypeId := T1; + R.Op := OP_NOP; + end + else if (K1 = KindVAR) and (K2 = KindVAR) then + R.Op := OP_MOD_INT_MM + else if (K1 = KindVAR) and (K2 = KindCONST) then + begin + if GetSymbolRec(Arg2).value = 0 then + CreateError(errDivisionByZero, []); + + R.Op := OP_MOD_INT_MI; + GetSymbolRec(R.Res).TypeId := T1; + end + else if (K1 = KindCONST) and (K2 = KindVAR) then + begin + R.Op := OP_MOD_INT_IM; + GetSymbolRec(R.Res).TypeId := T2; + end; + end + else if (T1 = typeVARIANT) and (T2 = typeVARIANT) then + begin + R.Op := OP_MOD_VARIANT; + GetSymbolRec(R.Res).TypeId := typeVARIANT; + end + else if (T1 = typeVARIANT) and (T2 <> typeVARIANT) then + begin + InsertConversionToVariant(N, 2); + Inc(N); + R.Op := OP_MOD_VARIANT; + GetSymbolRec(R.Res).TypeId := typeVARIANT; + end + else if (T1 <> typeVARIANT) and (T2 = typeVARIANT) then + begin + InsertConversionToVariant(N, 1); + Inc(N); + R.Op := OP_MOD_VARIANT; + GetSymbolRec(R.Res).TypeId := typeVARIANT; + end + else if (T1 = typeRECORD) and ExistsBinaryOperator + (GetSymbolRec(Arg1).TerminalTypeId, gen_Modulus) then + begin + InsertBinaryOperator(GetSymbolRec(Arg1).TerminalTypeId, gen_Modulus); + Inc(N); + end + else if (T2 = typeRECORD) and ExistsBinaryOperator + (GetSymbolRec(Arg2).TerminalTypeId, gen_Modulus) then + begin + InsertBinaryOperator(GetSymbolRec(Arg2).TerminalTypeId, gen_Modulus); + Inc(N); + end + else + begin + if GetLanguage(N) = JS_LANGUAGE then + begin + GetSymbolRec(R.Res).TypeId := typeVARIANT; + InsertConversionToVariant(N, 1); + Inc(N); + InsertConversionToVariant(N, 2); + Inc(N); + R.Op := OP_MOD_VARIANT; + Exit; + end; + + T1 := GetSymbolRec(Arg1).TypeId; + T2 := GetSymbolRec(Arg2).TypeId; + CreateError(errIncompatibleTypes, [GetSymbolRec(T1).Name, + GetSymbolRec(T2).Name]); + end; +end; + +procedure TCode.OperLeftShift; +var + Arg1, Arg2, T1, T2, K1, K2: Integer; + R: TCodeRec; +begin + R := Records[N]; + + Arg1 := R.Arg1; + Arg2 := R.Arg2; + T1 := GetSymbolRec(Arg1).FinalTypeId; + T2 := GetSymbolRec(Arg2).FinalTypeId; + + if T1 in [typePROC, typeEVENT] then + begin + if InsertSubCall(1) then + Exit; + end; + if T2 in [typePROC, typeEVENT] then + begin + if InsertSubCall(2) then + Exit; + end; + + if TKernel(kernel).InterfaceOnly then + if (T1 = 0) or (T2 = 0) then + begin + DiscardImport; + Exit; + end; + + K1 := GetSymbolRec(Arg1).Kind; + K2 := GetSymbolRec(Arg2).Kind; + + if T1 = typeOLEVARIANT then + T1 := typeVARIANT; + if T2 = typeOLEVARIANT then + T2 := typeVARIANT; + + if not(K1 in [KindVAR, KindCONST]) and (K2 in [KindVAR, KindCONST]) then + begin + CreateError(errIncompatibleTypesNoArgs, []); + Exit; + end; + + if (T1 = typeINT64) and (T2 = typeINT64) then + begin + GetSymbolRec(R.Res).TypeId := typeINT64; + R.Op := OP_SHL_INT64; + end + else if (T1 = typeINT64) and (T2 in IntegerTypes) then + begin + GetSymbolRec(R.Res).TypeId := typeINT64; + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value shl GetSymbolRec + (Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + R.Op := OP_SHL_INT64; + if K2 = KindCONST then + R.Arg2 := CreateConst(typeINT64, GetSymbolRec(R.Arg2).value) + else + begin + InsertConversionToInt64(N, 2); + Inc(N); + end; + end + else if (T1 in IntegerTypes) and (T2 = typeINT64) then + begin + GetSymbolRec(R.Res).TypeId := typeINTEGER; + + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value shl GetSymbolRec + (Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + R.Op := OP_SHL_INT64; + + if K1 = KindCONST then + R.Arg1 := CreateConst(typeINT64, GetSymbolRec(R.Arg1).value) + else + begin + InsertConversionToInt64(N, 1); + Inc(N); + end; + end + + else if (T1 in IntegerTypes) and (T2 in IntegerTypes) then + begin + GetSymbolRec(R.Res).TypeId := typeINTEGER; + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value shl GetSymbolRec + (Arg2).value; + + GetSymbolRec(R.Res).Kind := KindCONST; + + if T1 = T2 then + GetSymbolRec(R.Res).TypeId := T1; + R.Op := OP_NOP; + end + else if (K1 = KindVAR) and (K2 = KindVAR) then + R.Op := OP_SHL_INT_MM + else if (K1 = KindVAR) and (K2 = KindCONST) then + begin + R.Op := OP_SHL_INT_MI; + end + else if (K1 = KindCONST) and (K2 = KindVAR) then + begin + R.Op := OP_SHL_INT_IM; + end; + end + else if (T1 = typeVARIANT) and (T2 = typeVARIANT) then + begin + R.Op := OP_SHL_VARIANT; + GetSymbolRec(R.Res).TypeId := typeVARIANT; + end + else if (T1 = typeVARIANT) and (T2 <> typeVARIANT) then + begin + InsertConversionToVariant(N, 2); + Inc(N); + R.Op := OP_SHL_VARIANT; + GetSymbolRec(R.Res).TypeId := typeVARIANT; + end + else if (T1 <> typeVARIANT) and (T2 = typeVARIANT) then + begin + InsertConversionToVariant(N, 1); + Inc(N); + R.Op := OP_SHL_VARIANT; + GetSymbolRec(R.Res).TypeId := typeVARIANT; + end + else if (T1 = typeRECORD) and ExistsBinaryOperator + (GetSymbolRec(Arg1).TerminalTypeId, gen_LeftShift) then + begin + InsertBinaryOperator(GetSymbolRec(Arg1).TerminalTypeId, gen_LeftShift); + Inc(N); + end + else if (T2 = typeRECORD) and ExistsBinaryOperator + (GetSymbolRec(Arg2).TerminalTypeId, gen_LeftShift) then + begin + InsertBinaryOperator(GetSymbolRec(Arg2).TerminalTypeId, gen_LeftShift); + Inc(N); + end + else + begin + if GetLanguage(N) = JS_LANGUAGE then + begin + GetSymbolRec(R.Res).TypeId := typeVARIANT; + InsertConversionToVariant(N, 1); + Inc(N); + InsertConversionToVariant(N, 2); + Inc(N); + R.Op := OP_SHL_VARIANT; + Exit; + end; + + T1 := GetSymbolRec(Arg1).TypeId; + T2 := GetSymbolRec(Arg2).TypeId; + CreateError(errIncompatibleTypes, [GetSymbolRec(T1).Name, + GetSymbolRec(T2).Name]); + end; +end; + +procedure TCode.OperRightShift; +var + Arg1, Arg2, T1, T2, K1, K2: Integer; + R: TCodeRec; +begin + R := Records[N]; + + Arg1 := R.Arg1; + Arg2 := R.Arg2; + T1 := GetSymbolRec(Arg1).FinalTypeId; + T2 := GetSymbolRec(Arg2).FinalTypeId; + + if T1 in [typePROC, typeEVENT] then + begin + if InsertSubCall(1) then + Exit; + end; + if T2 in [typePROC, typeEVENT] then + begin + if InsertSubCall(2) then + Exit; + end; + + if TKernel(kernel).InterfaceOnly then + if (T1 = 0) or (T2 = 0) then + begin + DiscardImport; + Exit; + end; + + K1 := GetSymbolRec(Arg1).Kind; + K2 := GetSymbolRec(Arg2).Kind; + + if T1 = typeOLEVARIANT then + T1 := typeVARIANT; + if T2 = typeOLEVARIANT then + T2 := typeVARIANT; + + if not(K1 in [KindVAR, KindCONST]) and (K2 in [KindVAR, KindCONST]) then + begin + CreateError(errIncompatibleTypesNoArgs, []); + Exit; + end; + + if (T1 = typeINT64) and (T2 = typeINT64) then + begin + GetSymbolRec(R.Res).TypeId := typeINT64; + R.Op := OP_SHR_INT64; + end + else if (T1 = typeINT64) and (T2 in IntegerTypes) then + begin + GetSymbolRec(R.Res).TypeId := typeINT64; + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value shr GetSymbolRec + (Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + R.Op := OP_SHR_INT64; + + if K2 = KindCONST then + R.Arg2 := CreateConst(typeINT64, GetSymbolRec(R.Arg2).value) + else + begin + InsertConversionToInt64(N, 2); + Inc(N); + end; + end + else if (T1 in IntegerTypes) and (T2 = typeINT64) then + begin + GetSymbolRec(R.Res).TypeId := typeINTEGER; + + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value shr GetSymbolRec + (Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + R.Op := OP_SHR_INT64; + + if K1 = KindCONST then + R.Arg1 := CreateConst(typeINT64, GetSymbolRec(R.Arg1).value) + else + begin + InsertConversionToInt64(N, 1); + Inc(N); + end; + end + + else if (T1 in IntegerTypes) and (T2 in IntegerTypes) then + begin + GetSymbolRec(R.Res).TypeId := typeINTEGER; + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value shr GetSymbolRec + (Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + end + else if (K1 = KindVAR) and (K2 = KindVAR) then + R.Op := OP_SHR_INT_MM + else if (K1 = KindVAR) and (K2 = KindCONST) then + begin + R.Op := OP_SHR_INT_MI; + end + else if (K1 = KindCONST) and (K2 = KindVAR) then + begin + R.Op := OP_SHR_INT_IM; + end; + end + else if (T1 = typeVARIANT) and (T2 = typeVARIANT) then + begin + R.Op := OP_SHR_VARIANT; + GetSymbolRec(R.Res).TypeId := typeVARIANT; + end + else if (T1 = typeVARIANT) and (T2 <> typeVARIANT) then + begin + InsertConversionToVariant(N, 2); + Inc(N); + R.Op := OP_SHR_VARIANT; + GetSymbolRec(R.Res).TypeId := typeVARIANT; + end + else if (T1 <> typeVARIANT) and (T2 = typeVARIANT) then + begin + InsertConversionToVariant(N, 1); + Inc(N); + R.Op := OP_SHR_VARIANT; + GetSymbolRec(R.Res).TypeId := typeVARIANT; + end + else if (T1 = typeRECORD) and ExistsBinaryOperator + (GetSymbolRec(Arg1).TerminalTypeId, gen_RightShift) then + begin + InsertBinaryOperator(GetSymbolRec(Arg1).TerminalTypeId, gen_RightShift); + Inc(N); + end + else if (T2 = typeRECORD) and ExistsBinaryOperator + (GetSymbolRec(Arg2).TerminalTypeId, gen_RightShift) then + begin + InsertBinaryOperator(GetSymbolRec(Arg2).TerminalTypeId, gen_RightShift); + Inc(N); + end + else + begin + if GetLanguage(N) = JS_LANGUAGE then + begin + GetSymbolRec(R.Res).TypeId := typeVARIANT; + InsertConversionToVariant(N, 1); + Inc(N); + InsertConversionToVariant(N, 2); + Inc(N); + R.Op := OP_SHR_VARIANT; + Exit; + end; + + T1 := GetSymbolRec(Arg1).TypeId; + T2 := GetSymbolRec(Arg2).TypeId; + CreateError(errIncompatibleTypes, [GetSymbolRec(T1).Name, + GetSymbolRec(T2).Name]); + end; +end; + +procedure TCode.OperAnd; +var + Arg1, Arg2, T1, T2, K1, K2: Integer; + R: TCodeRec; +begin + R := Records[N]; + + Arg1 := R.Arg1; + Arg2 := R.Arg2; + T1 := GetSymbolRec(Arg1).FinalTypeId; + T2 := GetSymbolRec(Arg2).FinalTypeId; + + if T1 in [typePROC, typeEVENT] then + begin + if InsertSubCall(1) then + Exit; + end; + if T2 in [typePROC, typeEVENT] then + begin + if InsertSubCall(2) then + Exit; + end; + + if TKernel(kernel).InterfaceOnly then + if (T1 = 0) or (T2 = 0) then + begin + DiscardImport; + Exit; + end; + + K1 := GetSymbolRec(Arg1).Kind; + K2 := GetSymbolRec(Arg2).Kind; + + if T1 = typeOLEVARIANT then + T1 := typeVARIANT; + if T2 = typeOLEVARIANT then + T2 := typeVARIANT; + + if not(K1 in [KindVAR, KindCONST]) and (K2 in [KindVAR, KindCONST]) then + begin + CreateError(errIncompatibleTypesNoArgs, []); + Exit; + end; + + if (T1 = typeINT64) and (T2 = typeINT64) then + begin + GetSymbolRec(R.Res).TypeId := typeINT64; + R.Op := OP_AND_INT64; + end + else if (T1 = typeINT64) and (T2 in IntegerTypes) then + begin + GetSymbolRec(R.Res).TypeId := typeINT64; + + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value and + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + R.Op := OP_AND_INT64; + + if K2 = KindCONST then + R.Arg2 := CreateConst(typeINT64, GetSymbolRec(R.Arg2).value) + else + begin + InsertConversionToInt64(N, 2); + Inc(N); + end; + end + else if (T1 in IntegerTypes) and (T2 = typeINT64) then + begin + GetSymbolRec(R.Res).TypeId := typeINT64; + + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value and + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + R.Op := OP_AND_INT64; + + if K1 = KindCONST then + R.Arg1 := CreateConst(typeINT64, GetSymbolRec(R.Arg1).value) + else + begin + InsertConversionToInt64(N, 1); + Inc(N); + end; + end + + else if (T1 in IntegerTypes) and (T2 in IntegerTypes) then + begin + GetSymbolRec(R.Res).TypeId := typeINTEGER; + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value and + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + if T1 = T2 then + GetSymbolRec(R.Res).TypeId := T1; + R.Op := OP_NOP; + end + else if (K1 = KindVAR) and (K2 = KindVAR) then + R.Op := OP_AND_INT_MM + else if (K1 = KindVAR) and (K2 = KindCONST) then + begin + R.Op := OP_AND_INT_MI; + GetSymbolRec(R.Res).TypeId := T1; + end + else if (K1 = KindCONST) and (K2 = KindVAR) then + begin + R.SwapArguments; + R.Op := OP_AND_INT_MI; + GetSymbolRec(R.Res).TypeId := T2; + end; + end + else if (T1 in BooleanTypes) and (T2 in BooleanTypes) then + begin + GetSymbolRec(R.Res).TypeId := typeBOOLEAN; + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value and + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + if T1 = T2 then + GetSymbolRec(R.Res).TypeId := T1; + R.Op := OP_NOP; + end + else if (K1 = KindVAR) and (K2 = KindVAR) then + R.Op := OP_AND_INT_MM + else if (K1 = KindVAR) and (K2 = KindCONST) then + begin + R.Op := OP_AND_INT_MI; + GetSymbolRec(R.Res).TypeId := T1; + end + else if (K1 = KindCONST) and (K2 = KindVAR) then + begin + R.SwapArguments; + R.Op := OP_AND_INT_MI; + GetSymbolRec(R.Res).TypeId := T2; + end; + end + else if (T1 = typeVARIANT) and (T2 = typeVARIANT) then + begin + R.Op := OP_AND_VARIANT; + GetSymbolRec(R.Res).TypeId := typeVARIANT; + end + else if (T1 = typeVARIANT) and (T2 <> typeVARIANT) then + begin + InsertConversionToVariant(N, 2); + Inc(N); + R.Op := OP_AND_VARIANT; + GetSymbolRec(R.Res).TypeId := typeVARIANT; + end + else if (T1 <> typeVARIANT) and (T2 = typeVARIANT) then + begin + InsertConversionToVariant(N, 1); + Inc(N); + R.Op := OP_AND_VARIANT; + GetSymbolRec(R.Res).TypeId := typeVARIANT; + end + else if (T1 = typeRECORD) and ExistsBinaryOperator + (GetSymbolRec(Arg1).TerminalTypeId, gen_LogicalAnd) then + begin + InsertBinaryOperator(GetSymbolRec(Arg1).TerminalTypeId, gen_LogicalAnd); + Inc(N); + end + else if (T2 = typeRECORD) and ExistsBinaryOperator + (GetSymbolRec(Arg2).TerminalTypeId, gen_LogicalAnd) then + begin + InsertBinaryOperator(GetSymbolRec(Arg2).TerminalTypeId, gen_LogicalAnd); + Inc(N); + end + else + begin + if GetLanguage(N) = JS_LANGUAGE then + begin + GetSymbolRec(R.Res).TypeId := typeVARIANT; + InsertConversionToVariant(N, 1); + Inc(N); + InsertConversionToVariant(N, 2); + Inc(N); + R.Op := OP_AND_VARIANT; + Exit; + end; + + T1 := GetSymbolRec(Arg1).TypeId; + T2 := GetSymbolRec(Arg2).TypeId; + CreateError(errIncompatibleTypes, [GetSymbolRec(T1).Name, + GetSymbolRec(T2).Name]); + end; +end; + +procedure TCode.OperOr; +var + Arg1, Arg2, T1, T2, K1, K2: Integer; + R: TCodeRec; +begin + R := Records[N]; + + Arg1 := R.Arg1; + Arg2 := R.Arg2; + T1 := GetSymbolRec(Arg1).FinalTypeId; + T2 := GetSymbolRec(Arg2).FinalTypeId; + + if T1 in [typePROC, typeEVENT] then + begin + if InsertSubCall(1) then + Exit; + end; + if T2 in [typePROC, typeEVENT] then + begin + if InsertSubCall(2) then + Exit; + end; + + if TKernel(kernel).InterfaceOnly then + if (T1 = 0) or (T2 = 0) then + begin + DiscardImport; + Exit; + end; + + K1 := GetSymbolRec(Arg1).Kind; + K2 := GetSymbolRec(Arg2).Kind; + + if T1 = typeOLEVARIANT then + T1 := typeVARIANT; + if T2 = typeOLEVARIANT then + T2 := typeVARIANT; + + if not(K1 in [KindVAR, KindCONST]) and (K2 in [KindVAR, KindCONST]) then + begin + CreateError(errIncompatibleTypesNoArgs, []); + Exit; + end; + + if (T1 = typeINT64) and (T2 = typeINT64) then + begin + GetSymbolRec(R.Res).TypeId := typeINT64; + R.Op := OP_OR_INT64; + end + else if (T1 = typeINT64) and (T2 in IntegerTypes) then + begin + GetSymbolRec(R.Res).TypeId := typeINT64; + + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value or + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + R.Op := OP_OR_INT64; + + if K2 = KindCONST then + R.Arg2 := CreateConst(typeINT64, GetSymbolRec(R.Arg2).value) + else + begin + InsertConversionToInt64(N, 2); + Inc(N); + end; + end + else if (T1 in IntegerTypes) and (T2 = typeINT64) then + begin + GetSymbolRec(R.Res).TypeId := typeINT64; + + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value or + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + R.Op := OP_OR_INT64; + + if K1 = KindCONST then + R.Arg1 := CreateConst(typeINT64, GetSymbolRec(R.Arg1).value) + else + begin + InsertConversionToInt64(N, 1); + Inc(N); + end; + end + + else if (T1 in IntegerTypes) and (T2 in IntegerTypes) then + begin + GetSymbolRec(R.Res).TypeId := typeINTEGER; + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value or + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + if T1 = T2 then + GetSymbolRec(R.Res).TypeId := T1; + R.Op := OP_NOP; + end + else if (K1 = KindVAR) and (K2 = KindVAR) then + R.Op := OP_OR_INT_MM + else if (K1 = KindVAR) and (K2 = KindCONST) then + begin + R.Op := OP_OR_INT_MI; + GetSymbolRec(R.Res).TypeId := T1; + end + else if (K1 = KindCONST) and (K2 = KindVAR) then + begin + R.SwapArguments; + R.Op := OP_OR_INT_MI; + GetSymbolRec(R.Res).TypeId := T2; + end; + end + else if (T1 in BooleanTypes) and (T2 in BooleanTypes) then + begin + GetSymbolRec(R.Res).TypeId := typeBOOLEAN; + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value or + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + if T1 = T2 then + GetSymbolRec(R.Res).TypeId := T1; + R.Op := OP_NOP; + end + else if (K1 = KindVAR) and (K2 = KindVAR) then + R.Op := OP_OR_INT_MM + else if (K1 = KindVAR) and (K2 = KindCONST) then + begin + R.Op := OP_OR_INT_MI; + GetSymbolRec(R.Res).TypeId := T1; + end + else if (K1 = KindCONST) and (K2 = KindVAR) then + begin + R.SwapArguments; + R.Op := OP_OR_INT_MI; + GetSymbolRec(R.Res).TypeId := T2; + end; + end + else if (T1 = typeVARIANT) and (T2 = typeVARIANT) then + begin + R.Op := OP_OR_VARIANT; + GetSymbolRec(R.Res).TypeId := typeVARIANT; + end + else if (T1 = typeVARIANT) and (T2 <> typeVARIANT) then + begin + InsertConversionToVariant(N, 2); + Inc(N); + R.Op := OP_OR_VARIANT; + GetSymbolRec(R.Res).TypeId := typeVARIANT; + end + else if (T1 <> typeVARIANT) and (T2 = typeVARIANT) then + begin + InsertConversionToVariant(N, 1); + Inc(N); + R.Op := OP_OR_VARIANT; + GetSymbolRec(R.Res).TypeId := typeVARIANT; + end + else if (T1 = typeRECORD) and ExistsBinaryOperator + (GetSymbolRec(Arg1).TerminalTypeId, gen_LogicalOr) then + begin + InsertBinaryOperator(GetSymbolRec(Arg1).TerminalTypeId, gen_LogicalOr); + Inc(N); + end + else if (T2 = typeRECORD) and ExistsBinaryOperator + (GetSymbolRec(Arg2).TerminalTypeId, gen_LogicalOr) then + begin + InsertBinaryOperator(GetSymbolRec(Arg2).TerminalTypeId, gen_LogicalOr); + Inc(N); + end + else + begin + if GetLanguage(N) = JS_LANGUAGE then + begin + GetSymbolRec(R.Res).TypeId := typeVARIANT; + InsertConversionToVariant(N, 1); + Inc(N); + InsertConversionToVariant(N, 2); + Inc(N); + R.Op := OP_OR_VARIANT; + Exit; + end; + + T1 := GetSymbolRec(Arg1).TypeId; + T2 := GetSymbolRec(Arg2).TypeId; + CreateError(errIncompatibleTypes, [GetSymbolRec(T1).Name, + GetSymbolRec(T2).Name]); + end; +end; + +procedure TCode.OperXor; +var + Arg1, Arg2, T1, T2, K1, K2: Integer; + R: TCodeRec; +begin + R := Records[N]; + + Arg1 := R.Arg1; + Arg2 := R.Arg2; + T1 := GetSymbolRec(Arg1).FinalTypeId; + T2 := GetSymbolRec(Arg2).FinalTypeId; + + if T1 in [typePROC, typeEVENT] then + begin + if InsertSubCall(1) then + Exit; + end; + if T2 in [typePROC, typeEVENT] then + begin + if InsertSubCall(2) then + Exit; + end; + + if TKernel(kernel).InterfaceOnly then + if (T1 = 0) or (T2 = 0) then + begin + DiscardImport; + Exit; + end; + + K1 := GetSymbolRec(Arg1).Kind; + K2 := GetSymbolRec(Arg2).Kind; + + if T1 = typeOLEVARIANT then + T1 := typeVARIANT; + if T2 = typeOLEVARIANT then + T2 := typeVARIANT; + + if not(K1 in [KindVAR, KindCONST]) and (K2 in [KindVAR, KindCONST]) then + begin + CreateError(errIncompatibleTypesNoArgs, []); + Exit; + end; + + if (T1 = typeINT64) and (T2 = typeINT64) then + begin + GetSymbolRec(R.Res).TypeId := typeINT64; + R.Op := OP_XOR_INT64; + end + else if (T1 = typeINT64) and (T2 in IntegerTypes) then + begin + GetSymbolRec(R.Res).TypeId := typeINT64; + + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value xor GetSymbolRec + (Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + R.Op := OP_XOR_INT64; + + if K2 = KindCONST then + R.Arg2 := CreateConst(typeINT64, GetSymbolRec(R.Arg2).value) + else + begin + InsertConversionToInt64(N, 2); + Inc(N); + end; + end + else if (T1 in IntegerTypes) and (T2 = typeINT64) then + begin + GetSymbolRec(R.Res).TypeId := typeINT64; + + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value xor GetSymbolRec + (Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + R.Op := OP_XOR_INT64; + + if K1 = KindCONST then + R.Arg1 := CreateConst(typeINT64, GetSymbolRec(R.Arg1).value) + else + begin + InsertConversionToInt64(N, 1); + Inc(N); + end; + end + + else if (T1 in IntegerTypes) and (T2 in IntegerTypes) then + begin + GetSymbolRec(R.Res).TypeId := typeINTEGER; + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value xor GetSymbolRec + (Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + if T1 = T2 then + GetSymbolRec(R.Res).TypeId := T1; + R.Op := OP_NOP; + end + else if (K1 = KindVAR) and (K2 = KindVAR) then + R.Op := OP_XOR_INT_MM + else if (K1 = KindVAR) and (K2 = KindCONST) then + begin + R.Op := OP_XOR_INT_MI; + GetSymbolRec(R.Res).TypeId := T1; + end + else if (K1 = KindCONST) and (K2 = KindVAR) then + begin + R.SwapArguments; + R.Op := OP_XOR_INT_MI; + GetSymbolRec(R.Res).TypeId := T2; + end; + end + else if (T1 in BooleanTypes) and (T2 in BooleanTypes) then + begin + GetSymbolRec(R.Res).TypeId := typeBOOLEAN; + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value xor GetSymbolRec + (Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + if T1 = T2 then + GetSymbolRec(R.Res).TypeId := T1; + R.Op := OP_NOP; + end + else if (K1 = KindVAR) and (K2 = KindVAR) then + R.Op := OP_XOR_INT_MM + else if (K1 = KindVAR) and (K2 = KindCONST) then + begin + R.Op := OP_XOR_INT_MI; + GetSymbolRec(R.Res).TypeId := T1; + end + else if (K1 = KindCONST) and (K2 = KindVAR) then + begin + R.SwapArguments; + R.Op := OP_XOR_INT_MI; + GetSymbolRec(R.Res).TypeId := T2; + end; + end + else if (T1 = typeVARIANT) and (T2 = typeVARIANT) then + begin + R.Op := OP_XOR_VARIANT; + GetSymbolRec(R.Res).TypeId := typeVARIANT; + end + else if (T1 = typeVARIANT) and (T2 <> typeVARIANT) then + begin + InsertConversionToVariant(N, 2); + Inc(N); + R.Op := OP_XOR_VARIANT; + GetSymbolRec(R.Res).TypeId := typeVARIANT; + end + else if (T1 <> typeVARIANT) and (T2 = typeVARIANT) then + begin + InsertConversionToVariant(N, 1); + Inc(N); + R.Op := OP_XOR_VARIANT; + GetSymbolRec(R.Res).TypeId := typeVARIANT; + end + else if (T1 = typeRECORD) and ExistsBinaryOperator + (GetSymbolRec(Arg1).TerminalTypeId, gen_LogicalXor) then + begin + InsertBinaryOperator(GetSymbolRec(Arg1).TerminalTypeId, gen_LogicalXor); + Inc(N); + end + else if (T2 = typeRECORD) and ExistsBinaryOperator + (GetSymbolRec(Arg2).TerminalTypeId, gen_LogicalXor) then + begin + InsertBinaryOperator(GetSymbolRec(Arg2).TerminalTypeId, gen_LogicalXor); + Inc(N); + end + else + begin + if GetLanguage(N) = JS_LANGUAGE then + begin + GetSymbolRec(R.Res).TypeId := typeVARIANT; + InsertConversionToVariant(N, 1); + Inc(N); + InsertConversionToVariant(N, 2); + Inc(N); + R.Op := OP_XOR_VARIANT; + Exit; + end; + + T1 := GetSymbolRec(Arg1).TypeId; + T2 := GetSymbolRec(Arg2).TypeId; + CreateError(errIncompatibleTypes, [GetSymbolRec(T1).Name, + GetSymbolRec(T2).Name]); + end; +end; + +function TCode.ExistsOrdinalRelationalOperator(T1, T2: Integer): Boolean; +begin + result := (T1 in IntegerTypes) and (T2 in IntegerTypes); + if not result then + result := (T1 in CharTypes) and (T2 in CharTypes); + if not result then + result := (T1 in BooleanTypes) and (T2 in BooleanTypes); +end; + +procedure TCode.OperLessThan; +var + Arg1, Arg2, T1, T2, K1, K2: Integer; + R: TCodeRec; +begin + R := Records[N]; + + Arg1 := R.Arg1; + Arg2 := R.Arg2; + T1 := GetSymbolRec(Arg1).FinalTypeId; + T2 := GetSymbolRec(Arg2).FinalTypeId; + + if T1 in [typePROC, typeEVENT] then + begin + if InsertSubCall(1) then + Exit; + end; + if T2 in [typePROC, typeEVENT] then + begin + if InsertSubCall(2) then + Exit; + end; + + if TKernel(kernel).InterfaceOnly then + if (T1 = 0) or (T2 = 0) then + begin + DiscardImport; + Exit; + end; + + K1 := GetSymbolRec(Arg1).Kind; + K2 := GetSymbolRec(Arg2).Kind; + + if T1 = typeOLEVARIANT then + T1 := typeVARIANT; + if T2 = typeOLEVARIANT then + T2 := typeVARIANT; + + if not(K1 in [KindVAR, KindCONST]) and (K2 in [KindVAR, KindCONST]) then + begin + CreateError(errIncompatibleTypesNoArgs, []); + Exit; + end; + + if (T1 = typeENUM) and (T2 = typeENUM) then + begin + T1 := GetSymbolRec(Arg1).TypeId; + T2 := GetSymbolRec(Arg2).TypeId; + + T1 := GetSymbolRec(T1).PatternId; + T2 := GetSymbolRec(T2).PatternId; + + if GetSymbolRec(Arg1).HasSubrangeEnumType then // enum subrange type + begin + T1 := GetSymbolRec(Arg1).TypeId + 1; + T1 := GetSymbolRec(T1).TypeId; + T1 := GetSymbolRec(T1).PatternId; + end; + + if GetSymbolRec(Arg2).HasSubrangeEnumType then // enum subrange type + begin + T2 := GetSymbolRec(Arg1).TypeId + 1; + T2 := GetSymbolRec(T2).TypeId; + T2 := GetSymbolRec(T2).PatternId; + end; + end; + + GetSymbolRec(R.Res).TypeId := typeBOOLEAN; + + if (T1 = typeINT64) and (T2 = typeINT64) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value < + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + R.Op := OP_LT_INT64; + end + else if (T1 = typeINT64) and (T2 in IntegerTypes) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value < + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + R.Op := OP_LT_INT64; + + if K2 = KindCONST then + R.Arg2 := CreateConst(typeINT64, GetSymbolRec(R.Arg2).value) + else + begin + InsertConversionToInt64(N, 2); + Inc(N); + end; + end + else if (T1 in IntegerTypes) and (T2 = typeINT64) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value < + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + R.Op := OP_LT_INT64; + if K1 = KindCONST then + R.Arg1 := CreateConst(typeINT64, GetSymbolRec(R.Arg1).value) + else + begin + InsertConversionToInt64(N, 1); + Inc(N); + end; + end + else if (T1 = typeUINT64) and (T2 = typeUINT64) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value < + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + R.Op := OP_LT_UINT64; + end + else if (T1 = typeUINT64) and (T2 in IntegerTypes) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value < + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + R.Op := OP_LT_UINT64; + + if K2 = KindCONST then + R.Arg2 := CreateConst(typeUINT64, GetSymbolRec(R.Arg2).value) + else + begin + InsertConversionToUInt64(N, 2); + Inc(N); + end; + end + else if (T1 in IntegerTypes) and (T2 = typeUINT64) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value < + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + R.Op := OP_LT_UINT64; + if K1 = KindCONST then + R.Arg1 := CreateConst(typeUINT64, GetSymbolRec(R.Arg1).value) + else + begin + InsertConversionToUInt64(N, 1); + Inc(N); + end; + end + + else if ExistsOrdinalRelationalOperator(T1, T2) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value < + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + if (K1 = KindVAR) and (K2 = KindVAR) then + R.Op := OP_LT_INT_MM + else if (K1 = KindVAR) and (K2 = KindCONST) then + R.Op := OP_LT_INT_MI + else if (K1 = KindCONST) and (K2 = KindVAR) then + begin + R.SwapArguments; + R.Op := OP_GT_INT_MI; + end; + end + + else if (T1 = typeCURRENCY) and (T2 in NumberTypes) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value < + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + end + else if K2 = KindCONST then + begin + R.Op := OP_LT_CURRENCY; + if T2 <> typeCURRENCY then + R.Arg2 := CreateConst(typeCURRENCY, GetSymbolRec(R.Arg2).value); + end + else + R.Op := OP_LT_CURRENCY; + end + else if (T1 in NumberTypes) and (T2 = typeCURRENCY) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value < + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + end + else if K1 = KindCONST then + begin + R.Op := OP_LT_CURRENCY; + if T1 <> typeCURRENCY then + R.Arg1 := CreateConst(typeCURRENCY, GetSymbolRec(R.Arg1).value); + end + else + R.Op := OP_LT_CURRENCY; + end + + else if (T1 = typeDOUBLE) and (T2 = typeDOUBLE) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value < + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + R.Op := OP_LT_DOUBLE; + end + else if (T1 = typeDOUBLE) and (T2 in NumberTypes) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value < + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + R.Op := OP_LT_DOUBLE; + + if K2 = KindCONST then + R.Arg2 := CreateConst(typeDOUBLE, GetSymbolRec(R.Arg2).value) + else + begin + InsertConversionToDouble(N, 2); + Inc(N); + end; + end + else if (T1 in NumberTypes) and (T2 = typeDOUBLE) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value < + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + R.Op := OP_LT_DOUBLE; + if K1 = KindCONST then + R.Arg1 := CreateConst(typeDOUBLE, GetSymbolRec(R.Arg1).value) + else + begin + InsertConversionToDouble(N, 1); + Inc(N); + end; + end + + else if (T1 = typeSINGLE) and (T2 = typeSINGLE) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value < + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + R.Op := OP_LT_SINGLE; + end + else if (T1 = typeSINGLE) and (T2 in NumberTypes) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value < + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + R.Op := OP_LT_SINGLE; + + if K2 = KindCONST then + R.Arg2 := CreateConst(typeSINGLE, GetSymbolRec(R.Arg2).value) + else + begin + InsertConversionToSingle(N, 2); + Inc(N); + end; + end + else if (T1 in NumberTypes) and (T2 = typeSINGLE) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value < + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + R.Op := OP_LT_SINGLE; + if K1 = KindCONST then + R.Arg1 := CreateConst(typeSINGLE, GetSymbolRec(R.Arg1).value) + else + begin + InsertConversionToSingle(N, 1); + Inc(N); + end; + end + // + else if (T1 = typeEXTENDED) and (T2 = typeEXTENDED) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value < + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + R.Op := OP_LT_EXTENDED; + end + else if (T1 = typeEXTENDED) and (T2 in NumberTypes) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value < + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + R.Op := OP_LT_EXTENDED; + + if K2 = KindCONST then + R.Arg2 := CreateConst(typeEXTENDED, GetSymbolRec(R.Arg2).value) + else + begin + InsertConversionToExtended(N, 2); + Inc(N); + end; + end + else if (T1 in NumberTypes) and (T2 = typeEXTENDED) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value < + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + R.Op := OP_LT_EXTENDED; + if K1 = KindCONST then + R.Arg1 := CreateConst(typeEXTENDED, GetSymbolRec(R.Arg1).value) + else + begin + InsertConversionToExtended(N, 1); + Inc(N); + end; + end + else if (T1 = typeVARIANT) and (T2 = typeVARIANT) then + begin + R.Op := OP_LT_VARIANT; + end + else if (T1 = typeVARIANT) and (T2 <> typeVARIANT) then + begin + InsertConversionToVariant(N, 2); + Inc(N); + R.Op := OP_LT_VARIANT; + end + else if (T1 <> typeVARIANT) and (T2 = typeVARIANT) then + begin + InsertConversionToVariant(N, 1); + Inc(N); + R.Op := OP_LT_VARIANT; + end + + // string +{$IFNDEF PAXARM} + else if (T1 = typeANSISTRING) and (T2 = typeANSISTRING) then + begin + R.Op := OP_LT_ANSISTRING; + end + else if (T1 = typeANSISTRING) and (T2 <> typeANSISTRING) then + begin + InsertConversionToAnsiString(N, 2); + Inc(N); + R.Op := OP_LT_ANSISTRING; + end + else if (T1 <> typeANSISTRING) and (T2 = typeANSISTRING) then + begin + InsertConversionToAnsiString(N, 1); + Inc(N); + R.Op := OP_LT_ANSISTRING; + end + + // shortstring + + else if (T1 = typeSHORTSTRING) and (T2 = typeSHORTSTRING) then + begin + R.Op := OP_LT_SHORTSTRING; + end + else if (T1 = typeSHORTSTRING) and (T2 <> typeSHORTSTRING) then + begin + InsertConversionToShortString(N, 2); + Inc(N); + R.Op := OP_LT_SHORTSTRING; + end + else if (T1 <> typeSHORTSTRING) and (T2 = typeSHORTSTRING) then + begin + InsertConversionToShortString(N, 1); + Inc(N); + R.Op := OP_LT_SHORTSTRING; + end + + // wide string + + else if (T1 = typeWIDESTRING) and (T2 = typeWIDESTRING) then + begin + R.Op := OP_LT_WIDESTRING; + end + else if (T1 = typeWIDESTRING) and (T2 <> typeWIDESTRING) then + begin + InsertConversionToWideString(N, 2); + Inc(N); + R.Op := OP_LT_WIDESTRING; + end + else if (T1 <> typeWIDESTRING) and (T2 = typeWIDESTRING) then + begin + InsertConversionToWideString(N, 1); + Inc(N); + R.Op := OP_LT_WIDESTRING; + end +{$ENDIF} + // unic string + + else if (T1 = typeUNICSTRING) and (T2 = typeUNICSTRING) then + begin + R.Op := OP_LT_UNICSTRING; + end + else if (T1 = typeUNICSTRING) and (T2 <> typeUNICSTRING) then + begin + InsertConversionToUnicString(N, 2); + Inc(N); + R.Op := OP_LT_UNICSTRING; + end + else if (T1 <> typeUNICSTRING) and (T2 = typeUNICSTRING) then + begin + InsertConversionToUnicString(N, 1); + Inc(N); + R.Op := OP_LT_UNICSTRING; + end +{$IFNDEF PAXARM} + else if GetSymbolRec(Arg1).HasPAnsiCharType and GetSymbolRec(Arg2).HasPAnsiCharType + then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value < + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + end + else + begin + InsertConversionToAnsiString(N, 1); + Inc(N); + InsertConversionToAnsiString(N, 2); + Inc(N); + R.Op := OP_LT_ANSISTRING; + end; + end + else if GetSymbolRec(Arg1).HasPAnsiCharType and (T2 = typeANSICHAR) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value < + Chr(Integer(GetSymbolRec(Arg2).value)); + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + end + else + begin + InsertConversionToAnsiString(N, 1); + Inc(N); + InsertConversionToAnsiString(N, 2); + Inc(N); + R.Op := OP_LT_ANSISTRING; + end; + end + else if (T1 = typeANSICHAR) and GetSymbolRec(Arg2).HasPAnsiCharType then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := Chr(Integer(GetSymbolRec(Arg1).value)) < + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + end + else + begin + InsertConversionToAnsiString(N, 1); + Inc(N); + InsertConversionToAnsiString(N, 2); + Inc(N); + R.Op := OP_LT_ANSISTRING; + end; + end +{$ENDIF} + // + + else if GetSymbolRec(Arg1).HasPWideCharType and GetSymbolRec(Arg2).HasPWideCharType + then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value < + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + end + else + begin + InsertConversionToUnicString(N, 1); + Inc(N); + InsertConversionToUnicString(N, 2); + Inc(N); + R.Op := OP_LT_UNICSTRING; + end; + end + else if GetSymbolRec(Arg1).HasPWideCharType and (T2 in CharTypes) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value < + Chr(Integer(GetSymbolRec(Arg2).value)); + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + end + else + begin + InsertConversionToUnicString(N, 1); + Inc(N); + InsertConversionToUnicString(N, 2); + Inc(N); + R.Op := OP_LT_UNICSTRING; + end; + end + else if (T1 in CharTypes) and GetSymbolRec(Arg2).HasPWideCharType then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := Chr(Integer(GetSymbolRec(Arg1).value)) < + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + end + else + begin + InsertConversionToUnicString(N, 1); + Inc(N); + InsertConversionToUnicString(N, 2); + Inc(N); + R.Op := OP_LT_UNICSTRING; + end; + end + else if (T1 = typeRECORD) and ExistsBinaryOperator + (GetSymbolRec(Arg1).TerminalTypeId, gen_LessThan) then + begin + InsertBinaryOperator(GetSymbolRec(Arg1).TerminalTypeId, gen_LessThan); + Inc(N); + end + else if (T2 = typeRECORD) and ExistsBinaryOperator + (GetSymbolRec(Arg2).TerminalTypeId, gen_LessThan) then + begin + InsertBinaryOperator(GetSymbolRec(Arg2).TerminalTypeId, gen_LessThan); + Inc(N); + end + else + begin + if GetLanguage(N) = JS_LANGUAGE then + begin + InsertConversionToVariant(N, 1); + Inc(N); + InsertConversionToVariant(N, 2); + Inc(N); + R.Op := OP_LT_VARIANT; + Exit; + end; + + T1 := GetSymbolRec(Arg1).TypeId; + T2 := GetSymbolRec(Arg2).TypeId; + CreateError(errIncompatibleTypes, [GetSymbolRec(T1).Name, + GetSymbolRec(T2).Name]); + end; +end; + +procedure TCode.OperLessThanOrEqual; +var + Arg1, Arg2, T1, T2, K1, K2: Integer; + R: TCodeRec; +begin + R := Records[N]; + + Arg1 := R.Arg1; + Arg2 := R.Arg2; + T1 := GetSymbolRec(Arg1).FinalTypeId; + T2 := GetSymbolRec(Arg2).FinalTypeId; + + if T1 in [typePROC, typeEVENT] then + begin + if InsertSubCall(1) then + Exit; + end; + if T2 in [typePROC, typeEVENT] then + begin + if InsertSubCall(2) then + Exit; + end; + + if TKernel(kernel).InterfaceOnly then + if (T1 = 0) or (T2 = 0) then + begin + DiscardImport; + Exit; + end; + + if T1 = typeOLEVARIANT then + T1 := typeVARIANT; + if T2 = typeOLEVARIANT then + T2 := typeVARIANT; + + if T1 = typeSET then + CreateSetObject(Arg1); + if T2 = typeSET then + CreateSetObject(Arg2); + + K1 := GetSymbolRec(Arg1).Kind; + K2 := GetSymbolRec(Arg2).Kind; + + if not(K1 in [KindVAR, KindCONST]) and (K2 in [KindVAR, KindCONST]) then + begin + CreateError(errIncompatibleTypesNoArgs, []); + Exit; + end; + + if (T1 = typeENUM) and (T2 = typeENUM) then + begin + T1 := GetSymbolRec(Arg1).TypeId; + T2 := GetSymbolRec(Arg2).TypeId; + + T1 := GetSymbolRec(T1).PatternId; + T2 := GetSymbolRec(T2).PatternId; + + if GetSymbolRec(Arg1).HasSubrangeEnumType then // enum subrange type + begin + T1 := GetSymbolRec(Arg1).TypeId + 1; + T1 := GetSymbolRec(T1).TypeId; + T1 := GetSymbolRec(T1).PatternId; + end; + + if GetSymbolRec(Arg2).HasSubrangeEnumType then // enum subrange type + begin + T2 := GetSymbolRec(Arg1).TypeId + 1; + T2 := GetSymbolRec(T2).TypeId; + T2 := GetSymbolRec(T2).PatternId; + end; + end; + + GetSymbolRec(R.Res).TypeId := typeBOOLEAN; + + if (T1 = typeINT64) and (T2 = typeINT64) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value <= + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + R.Op := OP_LE_INT64; + end + else if (T1 = typeINT64) and (T2 in IntegerTypes) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value <= + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + R.Op := OP_LE_INT64; + + if K2 = KindCONST then + R.Arg2 := CreateConst(typeINT64, GetSymbolRec(R.Arg2).value) + else + begin + InsertConversionToInt64(N, 2); + Inc(N); + end; + end + else if (T1 in IntegerTypes) and (T2 = typeINT64) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value <= + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + R.Op := OP_LE_INT64; + if K1 = KindCONST then + R.Arg1 := CreateConst(typeINT64, GetSymbolRec(R.Arg1).value) + else + begin + InsertConversionToInt64(N, 1); + Inc(N); + end; + end + else if (T1 = typeUINT64) and (T2 = typeUINT64) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value <= + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + R.Op := OP_LE_UINT64; + end + else if (T1 = typeINT64) and (T2 in IntegerTypes) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value <= + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + R.Op := OP_LE_UINT64; + + if K2 = KindCONST then + R.Arg2 := CreateConst(typeUINT64, GetSymbolRec(R.Arg2).value) + else + begin + InsertConversionToUInt64(N, 2); + Inc(N); + end; + end + else if (T1 in IntegerTypes) and (T2 = typeUINT64) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value <= + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + R.Op := OP_LE_UINT64; + if K1 = KindCONST then + R.Arg1 := CreateConst(typeUINT64, GetSymbolRec(R.Arg1).value) + else + begin + InsertConversionToUInt64(N, 1); + Inc(N); + end; + end + + else if ExistsOrdinalRelationalOperator(T1, T2) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value <= + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + if (K1 = KindVAR) and (K2 = KindVAR) then + R.Op := OP_LE_INT_MM + else if (K1 = KindVAR) and (K2 = KindCONST) then + R.Op := OP_LE_INT_MI + else if (K1 = KindCONST) and (K2 = KindVAR) then + begin + R.SwapArguments; + R.Op := OP_GE_INT_MI; + end; + end + + else if (T1 = typeCURRENCY) and (T2 in NumberTypes) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value <= + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + end + else if K2 = KindCONST then + begin + R.Op := OP_LE_CURRENCY; + if T2 <> typeCURRENCY then + R.Arg2 := CreateConst(typeCURRENCY, GetSymbolRec(R.Arg2).value); + end + else + R.Op := OP_LE_CURRENCY; + end + else if (T1 in NumberTypes) and (T2 = typeCURRENCY) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value <= + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + end + else if K1 = KindCONST then + begin + R.Op := OP_LE_CURRENCY; + if T1 <> typeCURRENCY then + R.Arg1 := CreateConst(typeCURRENCY, GetSymbolRec(R.Arg1).value); + end + else + R.Op := OP_LE_CURRENCY; + end + + else if (T1 = typeDOUBLE) and (T2 = typeDOUBLE) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value <= + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + R.Op := OP_LE_DOUBLE; + end + else if (T1 = typeDOUBLE) and (T2 in NumberTypes) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value <= + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + R.Op := OP_LE_DOUBLE; + + if K2 = KindCONST then + R.Arg2 := CreateConst(typeDOUBLE, GetSymbolRec(R.Arg2).value) + else + begin + InsertConversionToDouble(N, 2); + Inc(N); + end; + end + else if (T1 in NumberTypes) and (T2 = typeDOUBLE) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value <= + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + R.Op := OP_LE_DOUBLE; + if K1 = KindCONST then + R.Arg1 := CreateConst(typeDOUBLE, GetSymbolRec(R.Arg1).value) + else + begin + InsertConversionToDouble(N, 1); + Inc(N); + end; + end + + else if (T1 = typeSINGLE) and (T2 = typeSINGLE) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value <= + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + R.Op := OP_LE_SINGLE; + end + else if (T1 = typeSINGLE) and (T2 in NumberTypes) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value <= + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + R.Op := OP_LE_SINGLE; + + if K2 = KindCONST then + R.Arg2 := CreateConst(typeSINGLE, GetSymbolRec(R.Arg2).value) + else + begin + InsertConversionToSingle(N, 2); + Inc(N); + end; + end + else if (T1 in NumberTypes) and (T2 = typeSINGLE) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value <= + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + R.Op := OP_LE_SINGLE; + if K1 = KindCONST then + R.Arg1 := CreateConst(typeSINGLE, GetSymbolRec(R.Arg1).value) + else + begin + InsertConversionToSingle(N, 1); + Inc(N); + end; + end + // + else if (T1 = typeEXTENDED) and (T2 = typeEXTENDED) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value <= + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + R.Op := OP_LE_EXTENDED; + end + else if (T1 = typeEXTENDED) and (T2 in NumberTypes) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value <= + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + R.Op := OP_LE_EXTENDED; + + if K2 = KindCONST then + R.Arg2 := CreateConst(typeEXTENDED, GetSymbolRec(R.Arg2).value) + else + begin + InsertConversionToExtended(N, 2); + Inc(N); + end; + end + else if (T1 in NumberTypes) and (T2 = typeEXTENDED) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value <= + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + R.Op := OP_LE_EXTENDED; + if K1 = KindCONST then + R.Arg1 := CreateConst(typeEXTENDED, GetSymbolRec(R.Arg1).value) + else + begin + InsertConversionToExtended(N, 1); + Inc(N); + end; + end + else if (T1 = typeSET) and (T2 = typeSET) then + begin + T1 := GetSymbolRec(Arg1).TypeId; + T2 := GetSymbolRec(Arg2).TypeId; + if not MatchSetTypes(T1, T2) then + CreateError(errIncompatibleTypesNoArgs, []) + else if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).ValueAsByteSet <= + GetSymbolRec(Arg2).ValueAsByteSet; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + end + else if (K1 in [KindVAR, KindCONST]) and (K2 in [KindVAR, KindCONST]) then + R.Op := OP_SET_SUBSET + else + CreateError(errIncompatibleTypesNoArgs, []) + end + else if (T1 = typeVARIANT) and (T2 = typeVARIANT) then + begin + R.Op := OP_LE_VARIANT; + end + else if (T1 = typeVARIANT) and (T2 <> typeVARIANT) then + begin + InsertConversionToVariant(N, 2); + Inc(N); + R.Op := OP_LE_VARIANT; + end + else if (T1 <> typeVARIANT) and (T2 = typeVARIANT) then + begin + InsertConversionToVariant(N, 1); + Inc(N); + R.Op := OP_LE_VARIANT; + end + + // string +{$IFNDEF PAXARM} + else if (T1 = typeANSISTRING) and (T2 = typeANSISTRING) then + begin + R.Op := OP_LE_ANSISTRING; + end + else if (T1 = typeANSISTRING) and (T2 <> typeANSISTRING) then + begin + InsertConversionToAnsiString(N, 2); + Inc(N); + R.Op := OP_LE_ANSISTRING; + end + else if (T1 <> typeANSISTRING) and (T2 = typeANSISTRING) then + begin + InsertConversionToAnsiString(N, 1); + Inc(N); + R.Op := OP_LE_ANSISTRING; + end + + // shortstring + + else if (T1 = typeSHORTSTRING) and (T2 = typeSHORTSTRING) then + begin + R.Op := OP_LE_SHORTSTRING; + end + else if (T1 = typeSHORTSTRING) and (T2 <> typeSHORTSTRING) then + begin + InsertConversionToShortString(N, 2); + Inc(N); + R.Op := OP_LE_SHORTSTRING; + end + else if (T1 <> typeSHORTSTRING) and (T2 = typeSHORTSTRING) then + begin + InsertConversionToShortString(N, 1); + Inc(N); + R.Op := OP_LE_SHORTSTRING; + end + + // wide string + + else if (T1 = typeWIDESTRING) and (T2 = typeWIDESTRING) then + begin + R.Op := OP_LE_WIDESTRING; + end + else if (T1 = typeWIDESTRING) and (T2 <> typeWIDESTRING) then + begin + InsertConversionToWideString(N, 2); + Inc(N); + R.Op := OP_LE_WIDESTRING; + end + else if (T1 <> typeWIDESTRING) and (T2 = typeWIDESTRING) then + begin + InsertConversionToWideString(N, 1); + Inc(N); + R.Op := OP_LE_WIDESTRING; + end +{$ENDIF} + // unic string + + else if (T1 = typeUNICSTRING) and (T2 = typeUNICSTRING) then + begin + R.Op := OP_LE_UNICSTRING; + end + else if (T1 = typeUNICSTRING) and (T2 <> typeUNICSTRING) then + begin + InsertConversionToUnicString(N, 2); + Inc(N); + R.Op := OP_LE_UNICSTRING; + end + else if (T1 <> typeUNICSTRING) and (T2 = typeUNICSTRING) then + begin + InsertConversionToUnicString(N, 1); + Inc(N); + R.Op := OP_LE_UNICSTRING; + end + // +{$IFNDEF PAXARM} + else if GetSymbolRec(Arg1).HasPAnsiCharType and GetSymbolRec(Arg2).HasPAnsiCharType + then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value <= + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + end + else + begin + InsertConversionToAnsiString(N, 1); + Inc(N); + InsertConversionToAnsiString(N, 2); + Inc(N); + R.Op := OP_LE_ANSISTRING; + end; + end + else if GetSymbolRec(Arg1).HasPAnsiCharType and (T2 = typeANSICHAR) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value <= + Chr(Integer(GetSymbolRec(Arg2).value)); + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + end + else + begin + InsertConversionToAnsiString(N, 1); + Inc(N); + InsertConversionToAnsiString(N, 2); + Inc(N); + R.Op := OP_LE_ANSISTRING; + end; + end + else if (T1 = typeANSICHAR) and GetSymbolRec(Arg2).HasPAnsiCharType then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := Chr(Integer(GetSymbolRec(Arg1).value)) <= + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + end + else + begin + InsertConversionToAnsiString(N, 1); + Inc(N); + InsertConversionToAnsiString(N, 2); + Inc(N); + R.Op := OP_LE_ANSISTRING; + end; + end +{$ENDIF} + // + else if GetSymbolRec(Arg1).HasPWideCharType and GetSymbolRec(Arg2).HasPWideCharType + then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value <= + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + end + else + begin + InsertConversionToUnicString(N, 1); + Inc(N); + InsertConversionToUnicString(N, 2); + Inc(N); + R.Op := OP_LE_UNICSTRING; + end; + end + else if GetSymbolRec(Arg1).HasPWideCharType and (T2 in CharTypes) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value <= + Chr(Integer(GetSymbolRec(Arg2).value)); + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + end + else + begin + InsertConversionToUnicString(N, 1); + Inc(N); + InsertConversionToUnicString(N, 2); + Inc(N); + R.Op := OP_LE_UNICSTRING; + end; + end + else if (T1 in CharTypes) and GetSymbolRec(Arg2).HasPWideCharType then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := Chr(Integer(GetSymbolRec(Arg1).value)) <= + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + end + else + begin + InsertConversionToUnicString(N, 1); + Inc(N); + InsertConversionToUnicString(N, 2); + Inc(N); + R.Op := OP_LE_UNICSTRING; + end; + end + else if (T1 = typeRECORD) and ExistsBinaryOperator + (GetSymbolRec(Arg1).TerminalTypeId, gen_LessThanOrEqual) then + begin + InsertBinaryOperator(GetSymbolRec(Arg1).TerminalTypeId, + gen_LessThanOrEqual); + Inc(N); + end + else if (T2 = typeRECORD) and ExistsBinaryOperator + (GetSymbolRec(Arg2).TerminalTypeId, gen_LessThanOrEqual) then + begin + InsertBinaryOperator(GetSymbolRec(Arg2).TerminalTypeId, + gen_LessThanOrEqual); + Inc(N); + end + // + else + begin + if GetLanguage(N) = JS_LANGUAGE then + begin + InsertConversionToVariant(N, 1); + Inc(N); + InsertConversionToVariant(N, 2); + Inc(N); + R.Op := OP_LE_VARIANT; + Exit; + end; + + T1 := GetSymbolRec(Arg1).TypeId; + T2 := GetSymbolRec(Arg2).TypeId; + CreateError(errIncompatibleTypes, [GetSymbolRec(T1).Name, + GetSymbolRec(T2).Name]); + end; +end; + +procedure TCode.OperGreaterThan; +var + Arg1, Arg2, T1, T2, K1, K2: Integer; + R: TCodeRec; +begin + R := Records[N]; + + Arg1 := R.Arg1; + Arg2 := R.Arg2; + T1 := GetSymbolRec(Arg1).FinalTypeId; + T2 := GetSymbolRec(Arg2).FinalTypeId; + + if T1 in [typePROC, typeEVENT] then + begin + if InsertSubCall(1) then + Exit; + end; + if T2 in [typePROC, typeEVENT] then + begin + if InsertSubCall(2) then + Exit; + end; + + if TKernel(kernel).InterfaceOnly then + if (T1 = 0) or (T2 = 0) then + begin + DiscardImport; + Exit; + end; + + K1 := GetSymbolRec(Arg1).Kind; + K2 := GetSymbolRec(Arg2).Kind; + + if T1 = typeOLEVARIANT then + T1 := typeVARIANT; + if T2 = typeOLEVARIANT then + T2 := typeVARIANT; + + if not(K1 in [KindVAR, KindCONST]) and (K2 in [KindVAR, KindCONST]) then + begin + CreateError(errIncompatibleTypesNoArgs, []); + Exit; + end; + + if (T1 = typeENUM) and (T2 = typeENUM) then + begin + T1 := GetSymbolRec(Arg1).TypeId; + T2 := GetSymbolRec(Arg2).TypeId; + + T1 := GetSymbolRec(T1).PatternId; + T2 := GetSymbolRec(T2).PatternId; + + if GetSymbolRec(Arg1).HasSubrangeEnumType then // enum subrange type + begin + T1 := GetSymbolRec(Arg1).TypeId + 1; + T1 := GetSymbolRec(T1).TypeId; + T1 := GetSymbolRec(T1).PatternId; + end; + + if GetSymbolRec(Arg2).HasSubrangeEnumType then // enum subrange type + begin + T2 := GetSymbolRec(Arg1).TypeId + 1; + T2 := GetSymbolRec(T2).TypeId; + T2 := GetSymbolRec(T2).PatternId; + end; + end; + + GetSymbolRec(R.Res).TypeId := typeBOOLEAN; + + if (T1 = typeINT64) and (T2 = typeINT64) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value > + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + R.Op := OP_GT_INT64; + end + else if (T1 = typeINT64) and (T2 in IntegerTypes) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value > + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + R.Op := OP_GT_INT64; + + if K2 = KindCONST then + R.Arg2 := CreateConst(typeINT64, GetSymbolRec(R.Arg2).value) + else + begin + InsertConversionToInt64(N, 2); + Inc(N); + end; + end + else if (T1 in IntegerTypes) and (T2 = typeINT64) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value > + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + R.Op := OP_GT_INT64; + if K1 = KindCONST then + R.Arg1 := CreateConst(typeINT64, GetSymbolRec(R.Arg1).value) + else + begin + InsertConversionToInt64(N, 1); + Inc(N); + end; + end + else if (T1 = typeUINT64) and (T2 = typeUINT64) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value > + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + R.Op := OP_GT_UINT64; + end + else if (T1 = typeUINT64) and (T2 in IntegerTypes) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value > + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + R.Op := OP_GT_UINT64; + + if K2 = KindCONST then + R.Arg2 := CreateConst(typeUINT64, GetSymbolRec(R.Arg2).value) + else + begin + InsertConversionToUInt64(N, 2); + Inc(N); + end; + end + else if (T1 in IntegerTypes) and (T2 = typeUINT64) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value > + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + R.Op := OP_GT_UINT64; + if K1 = KindCONST then + R.Arg1 := CreateConst(typeUINT64, GetSymbolRec(R.Arg1).value) + else + begin + InsertConversionToUInt64(N, 1); + Inc(N); + end; + end + + else if ExistsOrdinalRelationalOperator(T1, T2) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value > + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + if (K1 = KindVAR) and (K2 = KindVAR) then + R.Op := OP_GT_INT_MM + else if (K1 = KindVAR) and (K2 = KindCONST) then + R.Op := OP_GT_INT_MI + else if (K1 = KindCONST) and (K2 = KindVAR) then + begin + R.SwapArguments; + R.Op := OP_LT_INT_MI; + end; + end + + else if (T1 = typeCURRENCY) and (T2 in NumberTypes) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value > + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + end + else if K2 = KindCONST then + begin + R.Op := OP_GT_CURRENCY; + if T2 <> typeCURRENCY then + R.Arg2 := CreateConst(typeCURRENCY, GetSymbolRec(R.Arg2).value); + end + else + R.Op := OP_GT_CURRENCY; + end + else if (T1 in NumberTypes) and (T2 = typeCURRENCY) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value > + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + end + else if K1 = KindCONST then + begin + R.Op := OP_GT_CURRENCY; + if T1 <> typeCURRENCY then + R.Arg1 := CreateConst(typeCURRENCY, GetSymbolRec(R.Arg1).value); + end + else + R.Op := OP_GT_CURRENCY; + end + + else if (T1 = typeDOUBLE) and (T2 = typeDOUBLE) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value > + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + R.Op := OP_GT_DOUBLE; + end + else if (T1 = typeDOUBLE) and (T2 in NumberTypes) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value > + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + R.Op := OP_GT_DOUBLE; + + if K2 = KindCONST then + R.Arg2 := CreateConst(typeDOUBLE, GetSymbolRec(R.Arg2).value) + else + begin + InsertConversionToDouble(N, 2); + Inc(N); + end; + end + else if (T1 in NumberTypes) and (T2 = typeDOUBLE) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value > + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + R.Op := OP_GT_DOUBLE; + if K1 = KindCONST then + R.Arg1 := CreateConst(typeDOUBLE, GetSymbolRec(R.Arg1).value) + else + begin + InsertConversionToDouble(N, 1); + Inc(N); + end; + end + + else if (T1 = typeSINGLE) and (T2 = typeSINGLE) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value > + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + R.Op := OP_GT_SINGLE; + end + else if (T1 = typeSINGLE) and (T2 in NumberTypes) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value > + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + R.Op := OP_GT_SINGLE; + + if K2 = KindCONST then + R.Arg2 := CreateConst(typeSINGLE, GetSymbolRec(R.Arg2).value) + else + begin + InsertConversionToSingle(N, 2); + Inc(N); + end; + end + else if (T1 in NumberTypes) and (T2 = typeSINGLE) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value > + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + R.Op := OP_GT_SINGLE; + if K1 = KindCONST then + R.Arg1 := CreateConst(typeSINGLE, GetSymbolRec(R.Arg1).value) + else + begin + InsertConversionToSingle(N, 1); + Inc(N); + end; + end + // + else if (T1 = typeEXTENDED) and (T2 = typeEXTENDED) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value > + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + R.Op := OP_GT_EXTENDED; + end + else if (T1 = typeEXTENDED) and (T2 in NumberTypes) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value > + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + R.Op := OP_GT_EXTENDED; + + if K2 = KindCONST then + R.Arg2 := CreateConst(typeEXTENDED, GetSymbolRec(R.Arg2).value) + else + begin + InsertConversionToExtended(N, 2); + Inc(N); + end; + end + else if (T1 in NumberTypes) and (T2 = typeEXTENDED) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value > + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + R.Op := OP_GT_EXTENDED; + if K1 = KindCONST then + R.Arg1 := CreateConst(typeEXTENDED, GetSymbolRec(R.Arg1).value) + else + begin + InsertConversionToExtended(N, 1); + Inc(N); + end; + end + // + else if (T1 = typeVARIANT) and (T2 = typeVARIANT) then + begin + R.Op := OP_GT_VARIANT; + end + else if (T1 = typeVARIANT) and (T2 <> typeVARIANT) then + begin + InsertConversionToVariant(N, 2); + Inc(N); + R.Op := OP_GT_VARIANT; + end + else if (T1 <> typeVARIANT) and (T2 = typeVARIANT) then + begin + InsertConversionToVariant(N, 1); + Inc(N); + R.Op := OP_GT_VARIANT; + end + + // string +{$IFNDEF PAXARM} + else if (T1 = typeANSISTRING) and (T2 = typeANSISTRING) then + begin + R.Op := OP_GT_ANSISTRING; + end + else if (T1 = typeANSISTRING) and (T2 <> typeANSISTRING) then + begin + InsertConversionToAnsiString(N, 2); + Inc(N); + R.Op := OP_GT_ANSISTRING; + end + else if (T1 <> typeANSISTRING) and (T2 = typeANSISTRING) then + begin + InsertConversionToAnsiString(N, 1); + Inc(N); + R.Op := OP_GT_ANSISTRING; + end + + // shortstring + + else if (T1 = typeSHORTSTRING) and (T2 = typeSHORTSTRING) then + begin + R.Op := OP_GT_SHORTSTRING; + end + else if (T1 = typeSHORTSTRING) and (T2 <> typeSHORTSTRING) then + begin + InsertConversionToShortString(N, 2); + Inc(N); + R.Op := OP_GT_SHORTSTRING; + end + else if (T1 <> typeSHORTSTRING) and (T2 = typeSHORTSTRING) then + begin + InsertConversionToShortString(N, 1); + Inc(N); + R.Op := OP_GT_SHORTSTRING; + end + + // wide string + + else if (T1 = typeWIDESTRING) and (T2 = typeWIDESTRING) then + begin + R.Op := OP_GT_WIDESTRING; + end + else if (T1 = typeWIDESTRING) and (T2 <> typeWIDESTRING) then + begin + InsertConversionToWideString(N, 2); + Inc(N); + R.Op := OP_GT_WIDESTRING; + end + else if (T1 <> typeWIDESTRING) and (T2 = typeWIDESTRING) then + begin + InsertConversionToWideString(N, 1); + Inc(N); + R.Op := OP_GT_WIDESTRING; + end +{$ENDIF} + // unic string + + else if (T1 = typeUNICSTRING) and (T2 = typeUNICSTRING) then + begin + R.Op := OP_GT_UNICSTRING; + end + else if (T1 = typeUNICSTRING) and (T2 <> typeUNICSTRING) then + begin + InsertConversionToUnicString(N, 2); + Inc(N); + R.Op := OP_GT_UNICSTRING; + end + else if (T1 <> typeUNICSTRING) and (T2 = typeUNICSTRING) then + begin + InsertConversionToUnicString(N, 1); + Inc(N); + R.Op := OP_GT_UNICSTRING; + end + // +{$IFNDEF PAXARM} + else if GetSymbolRec(Arg1).HasPAnsiCharType and GetSymbolRec(Arg2).HasPAnsiCharType + then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value > + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + end + else + begin + InsertConversionToAnsiString(N, 1); + Inc(N); + InsertConversionToAnsiString(N, 2); + Inc(N); + R.Op := OP_GT_ANSISTRING; + end; + end + else if GetSymbolRec(Arg1).HasPAnsiCharType and (T2 = typeANSICHAR) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value > + Chr(Integer(GetSymbolRec(Arg2).value)); + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + end + else + begin + InsertConversionToAnsiString(N, 1); + Inc(N); + InsertConversionToAnsiString(N, 2); + Inc(N); + R.Op := OP_GT_ANSISTRING; + end; + end + else if (T1 = typeANSICHAR) and GetSymbolRec(Arg2).HasPAnsiCharType then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := Chr(Integer(GetSymbolRec(Arg1).value)) > + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + end + else + begin + InsertConversionToAnsiString(N, 1); + Inc(N); + InsertConversionToAnsiString(N, 2); + Inc(N); + R.Op := OP_GT_ANSISTRING; + end; + end +{$ENDIF} + // + else if GetSymbolRec(Arg1).HasPWideCharType and GetSymbolRec(Arg2).HasPWideCharType + then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value > + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + end + else + begin + InsertConversionToUnicString(N, 1); + Inc(N); + InsertConversionToUnicString(N, 2); + Inc(N); + R.Op := OP_GT_UNICSTRING; + end; + end + else if GetSymbolRec(Arg1).HasPWideCharType and (T2 in CharTypes) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value > + Chr(Integer(GetSymbolRec(Arg2).value)); + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + end + else + begin + InsertConversionToUnicString(N, 1); + Inc(N); + InsertConversionToUnicString(N, 2); + Inc(N); + R.Op := OP_GT_UNICSTRING; + end; + end + else if (T1 in CharTypes) and GetSymbolRec(Arg2).HasPWideCharType then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := Chr(Integer(GetSymbolRec(Arg1).value)) > + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + end + else + begin + InsertConversionToUnicString(N, 1); + Inc(N); + InsertConversionToUnicString(N, 2); + Inc(N); + R.Op := OP_GT_UNICSTRING; + end; + end + else if (T1 = typeRECORD) and ExistsBinaryOperator + (GetSymbolRec(Arg1).TerminalTypeId, gen_GreaterThan) then + begin + InsertBinaryOperator(GetSymbolRec(Arg1).TerminalTypeId, gen_GreaterThan); + Inc(N); + end + else if (T2 = typeRECORD) and ExistsBinaryOperator + (GetSymbolRec(Arg2).TerminalTypeId, gen_GreaterThan) then + begin + InsertBinaryOperator(GetSymbolRec(Arg2).TerminalTypeId, gen_GreaterThan); + Inc(N); + end + // + else + begin + if GetLanguage(N) = JS_LANGUAGE then + begin + InsertConversionToVariant(N, 1); + Inc(N); + InsertConversionToVariant(N, 2); + Inc(N); + R.Op := OP_GT_VARIANT; + Exit; + end; + + T1 := GetSymbolRec(Arg1).TypeId; + T2 := GetSymbolRec(Arg2).TypeId; + CreateError(errIncompatibleTypes, [GetSymbolRec(T1).Name, + GetSymbolRec(T2).Name]); + end; +end; + +procedure TCode.OperGreaterThanOrEqual; +var + Arg1, Arg2, T1, T2, K1, K2: Integer; + R: TCodeRec; +begin + R := Records[N]; + + Arg1 := R.Arg1; + Arg2 := R.Arg2; + T1 := GetSymbolRec(Arg1).FinalTypeId; + T2 := GetSymbolRec(Arg2).FinalTypeId; + + if T1 in [typePROC, typeEVENT] then + begin + if InsertSubCall(1) then + Exit; + end; + if T2 in [typePROC, typeEVENT] then + begin + if InsertSubCall(2) then + Exit; + end; + + if TKernel(kernel).InterfaceOnly then + if (T1 = 0) or (T2 = 0) then + begin + DiscardImport; + Exit; + end; + + if T1 = typeOLEVARIANT then + T1 := typeVARIANT; + if T2 = typeOLEVARIANT then + T2 := typeVARIANT; + + if T1 = typeSET then + CreateSetObject(Arg1); + if T2 = typeSET then + CreateSetObject(Arg2); + + K1 := GetSymbolRec(Arg1).Kind; + K2 := GetSymbolRec(Arg2).Kind; + + if not(K1 in [KindVAR, KindCONST]) and (K2 in [KindVAR, KindCONST]) then + begin + CreateError(errIncompatibleTypesNoArgs, []); + Exit; + end; + + if (T1 = typeENUM) and (T2 = typeENUM) then + begin + T1 := GetSymbolRec(Arg1).TypeId; + T2 := GetSymbolRec(Arg2).TypeId; + + T1 := GetSymbolRec(T1).PatternId; + T2 := GetSymbolRec(T2).PatternId; + + if GetSymbolRec(Arg1).HasSubrangeEnumType then // enum subrange type + begin + T1 := GetSymbolRec(Arg1).TypeId + 1; + T1 := GetSymbolRec(T1).TypeId; + T1 := GetSymbolRec(T1).PatternId; + end; + + if GetSymbolRec(Arg2).HasSubrangeEnumType then // enum subrange type + begin + T2 := GetSymbolRec(Arg1).TypeId + 1; + T2 := GetSymbolRec(T2).TypeId; + T2 := GetSymbolRec(T2).PatternId; + end; + end; + + GetSymbolRec(R.Res).TypeId := typeBOOLEAN; + + if (T1 = typeINT64) and (T2 = typeINT64) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value >= + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + R.Op := OP_GE_INT64; + end + else if (T1 = typeINT64) and (T2 in IntegerTypes) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value >= + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + R.Op := OP_GE_INT64; + + if K2 = KindCONST then + R.Arg2 := CreateConst(typeINT64, GetSymbolRec(R.Arg2).value) + else + begin + InsertConversionToInt64(N, 2); + Inc(N); + end; + end + else if (T1 in IntegerTypes) and (T2 = typeINT64) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value >= + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + R.Op := OP_GE_INT64; + if K1 = KindCONST then + R.Arg1 := CreateConst(typeINT64, GetSymbolRec(R.Arg1).value) + else + begin + InsertConversionToInt64(N, 1); + Inc(N); + end; + end + else if (T1 = typeUINT64) and (T2 = typeUINT64) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value >= + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + R.Op := OP_GE_UINT64; + end + else if (T1 = typeUINT64) and (T2 in IntegerTypes) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value >= + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + R.Op := OP_GE_UINT64; + + if K2 = KindCONST then + R.Arg2 := CreateConst(typeUINT64, GetSymbolRec(R.Arg2).value) + else + begin + InsertConversionToUInt64(N, 2); + Inc(N); + end; + end + else if (T1 in IntegerTypes) and (T2 = typeUINT64) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value >= + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + R.Op := OP_GE_UINT64; + if K1 = KindCONST then + R.Arg1 := CreateConst(typeUINT64, GetSymbolRec(R.Arg1).value) + else + begin + InsertConversionToUInt64(N, 1); + Inc(N); + end; + end + + else if ExistsOrdinalRelationalOperator(T1, T2) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value >= + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + if (K1 = KindVAR) and (K2 = KindVAR) then + R.Op := OP_GE_INT_MM + else if (K1 = KindVAR) and (K2 = KindCONST) then + R.Op := OP_GE_INT_MI + else if (K1 = KindCONST) and (K2 = KindVAR) then + begin + R.SwapArguments; + R.Op := OP_LE_INT_MI; + end; + end + + else if (T1 = typeCURRENCY) and (T2 in NumberTypes) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value >= + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + end + else if K2 = KindCONST then + begin + R.Op := OP_GE_CURRENCY; + if T2 <> typeCURRENCY then + R.Arg2 := CreateConst(typeCURRENCY, GetSymbolRec(R.Arg2).value); + end + else + R.Op := OP_GE_CURRENCY; + end + else if (T1 in NumberTypes) and (T2 = typeCURRENCY) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value >= + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + end + else if K1 = KindCONST then + begin + R.Op := OP_GE_CURRENCY; + if T1 <> typeCURRENCY then + R.Arg1 := CreateConst(typeCURRENCY, GetSymbolRec(R.Arg1).value); + end + else + R.Op := OP_GE_CURRENCY; + end + + else if (T1 = typeDOUBLE) and (T2 = typeDOUBLE) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value >= + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + R.Op := OP_GE_DOUBLE; + end + else if (T1 = typeDOUBLE) and (T2 in NumberTypes) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value >= + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + R.Op := OP_GE_DOUBLE; + + if K2 = KindCONST then + R.Arg2 := CreateConst(typeDOUBLE, GetSymbolRec(R.Arg2).value) + else + begin + InsertConversionToDouble(N, 2); + Inc(N); + end; + end + else if (T1 in NumberTypes) and (T2 = typeDOUBLE) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value >= + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + R.Op := OP_GE_DOUBLE; + if K1 = KindCONST then + R.Arg1 := CreateConst(typeDOUBLE, GetSymbolRec(R.Arg1).value) + else + begin + InsertConversionToDouble(N, 1); + Inc(N); + end; + end + + else if (T1 = typeSINGLE) and (T2 = typeSINGLE) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value >= + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + R.Op := OP_GE_SINGLE; + end + else if (T1 = typeSINGLE) and (T2 in NumberTypes) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value >= + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + R.Op := OP_GE_SINGLE; + + if K2 = KindCONST then + R.Arg2 := CreateConst(typeSINGLE, GetSymbolRec(R.Arg2).value) + else + begin + InsertConversionToSingle(N, 2); + Inc(N); + end; + end + else if (T1 in NumberTypes) and (T2 = typeSINGLE) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value >= + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + R.Op := OP_GE_SINGLE; + if K1 = KindCONST then + R.Arg1 := CreateConst(typeSINGLE, GetSymbolRec(R.Arg1).value) + else + begin + InsertConversionToSingle(N, 1); + Inc(N); + end; + end + // + else if (T1 = typeEXTENDED) and (T2 = typeEXTENDED) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value >= + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + R.Op := OP_GE_EXTENDED; + end + else if (T1 = typeEXTENDED) and (T2 in NumberTypes) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value >= + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + R.Op := OP_GE_EXTENDED; + + if K2 = KindCONST then + R.Arg2 := CreateConst(typeEXTENDED, GetSymbolRec(R.Arg2).value) + else + begin + InsertConversionToExtended(N, 2); + Inc(N); + end; + end + else if (T1 in NumberTypes) and (T2 = typeEXTENDED) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value >= + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + R.Op := OP_GE_EXTENDED; + if K1 = KindCONST then + R.Arg1 := CreateConst(typeEXTENDED, GetSymbolRec(R.Arg1).value) + else + begin + InsertConversionToExtended(N, 1); + Inc(N); + end; + end + // + else if (T1 = typeSET) and (T2 = typeSET) then + begin + T1 := GetSymbolRec(Arg1).TypeId; + T2 := GetSymbolRec(Arg2).TypeId; + if not MatchSetTypes(T1, T2) then + CreateError(errIncompatibleTypesNoArgs, []) + else if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).ValueAsByteSet >= + GetSymbolRec(Arg2).ValueAsByteSet; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + end + else if (K1 in [KindVAR, KindCONST]) and (K2 in [KindVAR, KindCONST]) then + R.Op := OP_SET_SUPERSET + else + CreateError(errIncompatibleTypesNoArgs, []) + end + else if (T1 = typeVARIANT) and (T2 = typeVARIANT) then + begin + R.Op := OP_GE_VARIANT; + end + else if (T1 = typeVARIANT) and (T2 <> typeVARIANT) then + begin + InsertConversionToVariant(N, 2); + Inc(N); + R.Op := OP_GE_VARIANT; + end + else if (T1 <> typeVARIANT) and (T2 = typeVARIANT) then + begin + InsertConversionToVariant(N, 1); + Inc(N); + R.Op := OP_GE_VARIANT; + end + + // string +{$IFNDEF PAXARM} + else if (T1 = typeANSISTRING) and (T2 = typeANSISTRING) then + begin + R.Op := OP_GE_ANSISTRING; + end + else if (T1 = typeANSISTRING) and (T2 <> typeANSISTRING) then + begin + InsertConversionToAnsiString(N, 2); + Inc(N); + R.Op := OP_GE_ANSISTRING; + end + else if (T1 <> typeANSISTRING) and (T2 = typeANSISTRING) then + begin + InsertConversionToAnsiString(N, 1); + Inc(N); + R.Op := OP_GE_ANSISTRING; + end + + // shortstring + + else if (T1 = typeSHORTSTRING) and (T2 = typeSHORTSTRING) then + begin + R.Op := OP_GE_SHORTSTRING; + end + else if (T1 = typeSHORTSTRING) and (T2 <> typeSHORTSTRING) then + begin + InsertConversionToShortString(N, 2); + Inc(N); + R.Op := OP_GE_SHORTSTRING; + end + else if (T1 <> typeSHORTSTRING) and (T2 = typeSHORTSTRING) then + begin + InsertConversionToShortString(N, 1); + Inc(N); + R.Op := OP_GE_SHORTSTRING; + end + + // wide string + + else if (T1 = typeWIDESTRING) and (T2 = typeWIDESTRING) then + begin + R.Op := OP_GE_WIDESTRING; + end + else if (T1 = typeWIDESTRING) and (T2 <> typeWIDESTRING) then + begin + InsertConversionToWideString(N, 2); + Inc(N); + R.Op := OP_GE_WIDESTRING; + end + else if (T1 <> typeWIDESTRING) and (T2 = typeWIDESTRING) then + begin + InsertConversionToWideString(N, 1); + Inc(N); + R.Op := OP_GE_WIDESTRING; + end +{$ENDIF} + // unic string + + else if (T1 = typeUNICSTRING) and (T2 = typeUNICSTRING) then + begin + R.Op := OP_GE_UNICSTRING; + end + else if (T1 = typeUNICSTRING) and (T2 <> typeUNICSTRING) then + begin + InsertConversionToUnicString(N, 2); + Inc(N); + R.Op := OP_GE_UNICSTRING; + end + else if (T1 <> typeUNICSTRING) and (T2 = typeUNICSTRING) then + begin + InsertConversionToUnicString(N, 1); + Inc(N); + R.Op := OP_GE_UNICSTRING; + end + // +{$IFNDEF PAXARM} + else if GetSymbolRec(Arg1).HasPAnsiCharType and GetSymbolRec(Arg2).HasPAnsiCharType + then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value >= + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + end + else + begin + InsertConversionToAnsiString(N, 1); + Inc(N); + InsertConversionToAnsiString(N, 2); + Inc(N); + R.Op := OP_GE_ANSISTRING; + end; + end + else if GetSymbolRec(Arg1).HasPAnsiCharType and (T2 = typeANSICHAR) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value >= + Chr(Integer(GetSymbolRec(Arg2).value)); + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + end + else + begin + InsertConversionToAnsiString(N, 1); + Inc(N); + InsertConversionToAnsiString(N, 2); + Inc(N); + R.Op := OP_GE_ANSISTRING; + end; + end + else if (T1 = typeANSICHAR) and GetSymbolRec(Arg2).HasPAnsiCharType then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := Chr(Integer(GetSymbolRec(Arg1).value)) >= + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + end + else + begin + InsertConversionToAnsiString(N, 1); + Inc(N); + InsertConversionToAnsiString(N, 2); + Inc(N); + R.Op := OP_GE_ANSISTRING; + end; + end +{$ENDIF} + // + else if GetSymbolRec(Arg1).HasPWideCharType and GetSymbolRec(Arg2).HasPWideCharType + then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value >= + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + end + else + begin + InsertConversionToUnicString(N, 1); + Inc(N); + InsertConversionToUnicString(N, 2); + Inc(N); + R.Op := OP_GE_UNICSTRING; + end; + end + else if GetSymbolRec(Arg1).HasPWideCharType and (T2 in CharTypes) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value >= + Chr(Integer(GetSymbolRec(Arg2).value)); + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + end + else + begin + InsertConversionToUnicString(N, 1); + Inc(N); + InsertConversionToUnicString(N, 2); + Inc(N); + R.Op := OP_GE_UNICSTRING; + end; + end + else if (T1 in CharTypes) and GetSymbolRec(Arg2).HasPWideCharType then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := Chr(Integer(GetSymbolRec(Arg1).value)) >= + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + end + else + begin + InsertConversionToUnicString(N, 1); + Inc(N); + InsertConversionToUnicString(N, 2); + Inc(N); + R.Op := OP_GE_UNICSTRING; + end; + end + else if (T1 = typeRECORD) and ExistsBinaryOperator + (GetSymbolRec(Arg1).TerminalTypeId, gen_GreaterThanOrEqual) then + begin + InsertBinaryOperator(GetSymbolRec(Arg1).TerminalTypeId, + gen_GreaterThanOrEqual); + Inc(N); + end + else if (T2 = typeRECORD) and ExistsBinaryOperator + (GetSymbolRec(Arg2).TerminalTypeId, gen_GreaterThanOrEqual) then + begin + InsertBinaryOperator(GetSymbolRec(Arg2).TerminalTypeId, + gen_GreaterThanOrEqual); + Inc(N); + end + // + else + begin + if GetLanguage(N) = JS_LANGUAGE then + begin + InsertConversionToVariant(N, 1); + Inc(N); + InsertConversionToVariant(N, 2); + Inc(N); + R.Op := OP_GE_VARIANT; + Exit; + end; + + T1 := GetSymbolRec(Arg1).TypeId; + T2 := GetSymbolRec(Arg2).TypeId; + CreateError(errIncompatibleTypes, [GetSymbolRec(T1).Name, + GetSymbolRec(T2).Name]); + end; +end; + +function TCode.InsertSubCall(I: Integer): Boolean; +var + SubId, TypeId: Integer; + R, RC: TCodeRec; +begin + result := true; + + R := Records[N]; + + SubId := 0; + case I of + 1: + SubId := R.Arg1; + 2: + SubId := R.Arg2; + 3: + SubId := R.Res; + else + RaiseError(errInternalError, []); + end; + + if TKernel(kernel).SymbolTable.EventNilId = SubId then + begin + result := false; + Exit; + end; + + TypeId := GetSymbolRec(SubId).TerminalTypeId; + TypeId := GetSymbolRec(TypeId).PatternId; + + if GetSymbolRec(TypeId).Count > 0 then + begin + result := false; + Exit; + end; + + TypeId := GetSymbolRec(TypeId).TypeId; + + RC := TCodeRec.Create(OP_CALL, Self); + RC.Arg1 := SubId; + RC.Arg2 := 0; + RC.Res := NewTempVar(GetLevel(N), TypeId); + + Insert(N, RC); + + case I of + 1: + R.Arg1 := RC.Res; + 2: + R.Arg2 := RC.Res; + 3: + R.Res := RC.Res; + else + RaiseError(errInternalError, []); + end; + + Dec(N); +end; + +procedure TCode.OperEqual; +var + Arg1, Arg2, T1, T2, K1, K2: Integer; + R: TCodeRec; + SymbolTable: TSymbolTable; +begin + SymbolTable := TKernel(kernel).SymbolTable; + + R := Records[N]; + + Arg1 := R.Arg1; + Arg2 := R.Arg2; + T1 := GetSymbolRec(Arg1).FinalTypeId; + T2 := GetSymbolRec(Arg2).FinalTypeId; + + if T1 in [typePROC, typeEVENT] then + begin + if InsertSubCall(1) then + Exit; + end; + if T2 in [typePROC, typeEVENT] then + begin + if InsertSubCall(2) then + Exit; + end; + + if TKernel(kernel).InterfaceOnly then + if (T1 = 0) or (T2 = 0) then + begin + DiscardImport; + Exit; + end; + + if T1 = typeOLEVARIANT then + T1 := typeVARIANT; + if T2 = typeOLEVARIANT then + T2 := typeVARIANT; + + if T1 = typeSET then + CreateSetObject(Arg1); + if T2 = typeSET then + CreateSetObject(Arg2); + + K1 := GetSymbolRec(Arg1).Kind; + K2 := GetSymbolRec(Arg2).Kind; + + if (T1 = typeENUM) and (T2 = typeENUM) then + begin + T1 := GetSymbolRec(Arg1).TypeId; + T2 := GetSymbolRec(Arg2).TypeId; + + T1 := GetSymbolRec(T1).PatternId; + T2 := GetSymbolRec(T2).PatternId; + + if GetSymbolRec(Arg1).HasSubrangeEnumType then // enum subrange type + begin + T1 := GetSymbolRec(Arg1).TypeId + 1; + T1 := GetSymbolRec(T1).TypeId; + T1 := GetSymbolRec(T1).PatternId; + end; + + if GetSymbolRec(Arg2).HasSubrangeEnumType then // enum subrange type + begin + T2 := GetSymbolRec(Arg1).TypeId + 1; + T2 := GetSymbolRec(T2).TypeId; + T2 := GetSymbolRec(T2).PatternId; + end; + end; + + if not(K1 in [KindVAR, KindCONST]) and (K2 in [KindVAR, KindCONST]) then + begin + CreateError(errIncompatibleTypesNoArgs, []); + Exit; + end; + + GetSymbolRec(R.Res).TypeId := typeBOOLEAN; + + if (T1 in INT64Types) and (T2 in INT64Types) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1) + .value = GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + R.Op := OP_EQ_INT64; + end + else if (T1 in INT64Types) and (T2 in IntegerTypes) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1) + .value = GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + R.Op := OP_EQ_INT64; + + if K2 = KindCONST then + R.Arg2 := CreateConst(typeINT64, GetSymbolRec(R.Arg2).value) + else + begin + InsertConversionToInt64(N, 2); + Inc(N); + end; + end + else if (T1 in IntegerTypes) and (T2 in INT64Types) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1) + .value = GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + R.Op := OP_EQ_INT64; + if K1 = KindCONST then + R.Arg1 := CreateConst(typeINT64, GetSymbolRec(R.Arg1).value) + else + begin + InsertConversionToInt64(N, 1); + Inc(N); + end; + end + + else if (T1 in BooleanTypes) and (T2 in BooleanTypes) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + if (TVarData(GetSymbolRec(Arg1).value).VInteger <> 0) and + (TVarData(GetSymbolRec(Arg2).value).VInteger <> 0) then + GetSymbolRec(R.Res).value := true + else if (TVarData(GetSymbolRec(Arg1).value).VInteger = 0) and + (TVarData(GetSymbolRec(Arg2).value).VInteger = 0) then + GetSymbolRec(R.Res).value := true + else + GetSymbolRec(R.Res).value := false; + + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + if (K1 = KindVAR) and (K2 = KindVAR) then + begin + if T1 <> T2 then + begin + if T1 <> typeBOOLEAN then + begin + InsertConversionToBoolean(N, 1); + Inc(N); + end; + if T2 <> typeBOOLEAN then + begin + InsertConversionToBoolean(N, 2); + Inc(N); + end; + end; + R.Op := OP_EQ_INT_MM; + end + else if (K1 = KindVAR) and (K2 = KindCONST) then + begin + if T1 <> T2 then + begin + if T1 <> typeBOOLEAN then + begin + InsertConversionToBoolean(N, 1); + Inc(N); + end; + if T2 <> typeBOOLEAN then + begin + if TVarData(GetSymbolRec(Arg2).value).VInteger <> 0 then + R.Arg2 := SymbolTable.TrueId + else + R.Arg2 := SymbolTable.FalseId + end; + end; + R.Op := OP_EQ_INT_MI; + end + else if (K1 = KindCONST) and (K2 = KindVAR) then + begin + R.Op := OP_EQ_INT_MI; + R.SwapArguments; + if T1 <> T2 then + begin + if T2 <> typeBOOLEAN then + begin + InsertConversionToBoolean(N, 1); + Inc(N); + end; + if T1 <> typeBOOLEAN then + begin + if TVarData(GetSymbolRec(Arg2).value).VInteger <> 0 then + R.Arg2 := SymbolTable.TrueId + else + R.Arg2 := SymbolTable.FalseId + end; + end; + R.Op := OP_EQ_INT_MI; + end; + end + + else if ExistsOrdinalRelationalOperator(T1, T2) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1) + .value = GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + if (K1 = KindVAR) and (K2 = KindVAR) then + R.Op := OP_EQ_INT_MM + else if (K1 = KindVAR) and (K2 = KindCONST) then + R.Op := OP_EQ_INT_MI + else if (K1 = KindCONST) and (K2 = KindVAR) then + begin + R.Op := OP_EQ_INT_MI; + R.SwapArguments; + end; + end + else if (T1 = typeCLASS) and (Arg2 = SymbolTable.NilId) then + begin + if K1 = KindTYPE then + Inc(R.Arg1); + R.Op := OP_EQ_INT_MI; + end + else if (Arg1 = SymbolTable.NilId) and (T2 = typeCLASS) then + begin + if K2 = KindTYPE then + Inc(R.Arg2); + R.Op := OP_EQ_INT_MI; + R.SwapArguments; + end + else if (T1 = typeCLASS) and (T2 = typeCLASS) then + begin + if K1 = KindTYPE then + Inc(R.Arg1); + if K2 = KindTYPE then + Inc(R.Arg2); + R.Op := OP_EQ_INT_MM; + end + else if (T1 = typeINTERFACE) and (Arg2 = SymbolTable.NilId) then + begin + R.Op := OP_EQ_INT_MI; + end + else if (T1 = typeINTERFACE) and (T2 = typeINTERFACE) then + begin + R.Op := OP_EQ_INT_MM; + end + else if (Arg1 = SymbolTable.NilId) and (T2 = typeINTERFACE) then + begin + R.Op := OP_EQ_INT_MI; + R.SwapArguments; + end + else if (T1 in [typePOINTER, typeCLASS, typeCLASSREF, typePROC, typeINTERFACE] + ) and (Arg2 = SymbolTable.NilId) then + begin + R.Op := OP_EQ_INT_MI; + end + else if (Arg1 = SymbolTable.NilId) and + (T2 in [typePOINTER, typeCLASS, typeCLASSREF, typePROC, typeINTERFACE]) then + begin + R.Op := OP_EQ_INT_MI; + R.SwapArguments; + end + else if (T1 = typePOINTER) and (T2 = typePOINTER) then + begin +{$IFNDEF PAXARM} + if (GetSymbolRec(Arg1).HasPAnsiCharType or GetSymbolRec(Arg1) + .HasPWideCharType) and (GetSymbolRec(Arg2).HasPAnsiCharType or + GetSymbolRec(Arg2).HasPWideCharType) then + begin + InsertConversionToUnicString(N, 1); + Inc(N); + InsertConversionToUnicString(N, 2); + Inc(N); + R.Op := OP_EQ_WIDESTRING; + Exit; + end; +{$ENDIF} + R.Op := OP_EQ_INT_MM; + end + else if (T1 = typeCLASSREF) and (T2 = typeCLASSREF) then + begin + R.Op := OP_EQ_INT_MM; + end + else if (T1 = typeCLASS) and (T2 = typeCLASSREF) then + begin + if K1 = KindTYPE then + Inc(R.Arg1); + R.Op := OP_EQ_INT_MM; + end + else if (T1 = typeCLASSREF) and (T2 = typeCLASS) then + begin + if K2 = KindTYPE then + Inc(R.Arg2); + R.Op := OP_EQ_INT_MM; + end + + else if (T1 = typeCURRENCY) and (T2 in NumberTypes) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1) + .value = GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + end + else if K2 = KindCONST then + begin + R.Op := OP_EQ_CURRENCY; + if T2 <> typeCURRENCY then + R.Arg2 := CreateConst(typeCURRENCY, GetSymbolRec(R.Arg2).value); + end + else + R.Op := OP_EQ_CURRENCY; + end + else if (T1 in NumberTypes) and (T2 = typeCURRENCY) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1) + .value = GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + end + else if K1 = KindCONST then + begin + R.Op := OP_EQ_CURRENCY; + if T1 <> typeCURRENCY then + R.Arg1 := CreateConst(typeCURRENCY, GetSymbolRec(R.Arg1).value); + end + else + R.Op := OP_EQ_CURRENCY; + end + + else if (T1 = typeDOUBLE) and (T2 = typeDOUBLE) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1) + .value = GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + R.Op := OP_EQ_DOUBLE; + end + else if (T1 = typeDOUBLE) and (T2 in NumberTypes) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1) + .value = GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + R.Op := OP_EQ_DOUBLE; + + if K2 = KindCONST then + R.Arg2 := CreateConst(typeDOUBLE, GetSymbolRec(R.Arg2).value) + else + begin + InsertConversionToDouble(N, 2); + Inc(N); + end; + end + else if (T1 in NumberTypes) and (T2 = typeDOUBLE) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1) + .value = GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + R.Op := OP_EQ_DOUBLE; + if K1 = KindCONST then + R.Arg1 := CreateConst(typeDOUBLE, GetSymbolRec(R.Arg1).value) + else + begin + InsertConversionToDouble(N, 1); + Inc(N); + end; + end + + else if (T1 = typeSINGLE) and (T2 = typeSINGLE) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1) + .value = GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + R.Op := OP_EQ_SINGLE; + end + else if (T1 = typeSINGLE) and (T2 in NumberTypes) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1) + .value = GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + R.Op := OP_EQ_SINGLE; + + if K2 = KindCONST then + R.Arg2 := CreateConst(typeSINGLE, GetSymbolRec(R.Arg2).value) + else + begin + InsertConversionToSingle(N, 2); + Inc(N); + end; + end + else if (T1 in NumberTypes) and (T2 = typeSINGLE) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1) + .value = GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + R.Op := OP_EQ_SINGLE; + if K1 = KindCONST then + R.Arg1 := CreateConst(typeSINGLE, GetSymbolRec(R.Arg1).value) + else + begin + InsertConversionToSingle(N, 1); + Inc(N); + end; + end + // + else if (T1 = typeEXTENDED) and (T2 = typeEXTENDED) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1) + .value = GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + R.Op := OP_EQ_EXTENDED; + end + else if (T1 = typeEXTENDED) and (T2 in NumberTypes) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1) + .value = GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + R.Op := OP_EQ_EXTENDED; + + if K2 = KindCONST then + R.Arg2 := CreateConst(typeEXTENDED, GetSymbolRec(R.Arg2).value) + else + begin + InsertConversionToExtended(N, 2); + Inc(N); + end; + end + else if (T1 in NumberTypes) and (T2 = typeEXTENDED) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1) + .value = GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + R.Op := OP_EQ_EXTENDED; + if K1 = KindCONST then + R.Arg1 := CreateConst(typeEXTENDED, GetSymbolRec(R.Arg1).value) + else + begin + InsertConversionToExtended(N, 1); + Inc(N); + end; + end + // + else if (T1 = typeSET) and (T2 = typeSET) then + begin + T1 := GetSymbolRec(Arg1).TypeId; + T2 := GetSymbolRec(Arg2).TypeId; + if not MatchSetTypes(T1, T2) then + CreateError(errIncompatibleTypesNoArgs, []) + else if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1) + .ValueAsByteSet = GetSymbolRec(Arg2).ValueAsByteSet; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + end + else if (K1 in [KindVAR, KindCONST]) and (K2 in [KindVAR, KindCONST]) then + R.Op := OP_SET_EQUALITY + else + CreateError(errIncompatibleTypesNoArgs, []) + end +{$IFNDEF PAXARM} + else if (T1 = typeANSISTRING) and (T2 = typeANSISTRING) then + begin + R.Op := OP_EQ_ANSISTRING; + end + else if (T1 = typeANSISTRING) and (T2 <> typeANSISTRING) then + begin + InsertConversionToAnsiString(N, 2); + Inc(N); + R.Op := OP_EQ_ANSISTRING; + end + else if (T1 <> typeANSISTRING) and (T2 = typeANSISTRING) then + begin + InsertConversionToAnsiString(N, 1); + Inc(N); + R.Op := OP_EQ_ANSISTRING; + end + // + else if GetSymbolRec(Arg1).HasPAnsiCharType and GetSymbolRec(Arg2).HasPAnsiCharType + then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1) + .value = GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + end + else + begin + InsertConversionToAnsiString(N, 1); + Inc(N); + InsertConversionToAnsiString(N, 2); + Inc(N); + R.Op := OP_EQ_ANSISTRING; + end; + end + else if GetSymbolRec(Arg1).HasPAnsiCharType and (T2 = typeANSICHAR) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1) + .value = Chr(Integer(GetSymbolRec(Arg2).value)); + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + end + else + begin + InsertConversionToAnsiString(N, 1); + Inc(N); + InsertConversionToAnsiString(N, 2); + Inc(N); + R.Op := OP_EQ_ANSISTRING; + end; + end + else if (T1 = typeANSICHAR) and GetSymbolRec(Arg2).HasPAnsiCharType then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := Chr(Integer(GetSymbolRec(Arg1).value)) + = GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + end + else + begin + InsertConversionToAnsiString(N, 1); + Inc(N); + InsertConversionToAnsiString(N, 2); + Inc(N); + R.Op := OP_EQ_ANSISTRING; + end; + end +{$ENDIF} + // + else if GetSymbolRec(Arg1).HasPWideCharType and GetSymbolRec(Arg2).HasPWideCharType + then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1) + .value = GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + end + else + begin + InsertConversionToUnicString(N, 1); + Inc(N); + InsertConversionToUnicString(N, 2); + Inc(N); + R.Op := OP_EQ_UNICSTRING; + end; + end + else if (GetSymbolRec(Arg1).HasPWideCharType +{$IFNDEF PAXARM} + or GetSymbolRec(Arg1).HasPAnsiCharType +{$ENDIF} + ) and (T2 in CharTypes) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1) + .value = Chr(Integer(GetSymbolRec(Arg2).value)); + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + end + else + begin + InsertConversionToUnicString(N, 1); + Inc(N); + InsertConversionToUnicString(N, 2); + Inc(N); + R.Op := OP_EQ_UNICSTRING; + end; + end + else if (T1 in CharTypes) and (GetSymbolRec(Arg2).HasPWideCharType +{$IFNDEF PAXARM} + or GetSymbolRec(Arg2).HasPAnsiCharType +{$ENDIF} + ) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := Chr(Integer(GetSymbolRec(Arg1).value)) + = GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + end + else + begin + InsertConversionToUnicString(N, 1); + Inc(N); + InsertConversionToUnicString(N, 2); + Inc(N); + R.Op := OP_EQ_UNICSTRING; + end; + end +{$IFNDEF PAXARM} + // + else if (T1 = typeSHORTSTRING) and (T2 = typeSHORTSTRING) then + begin + R.Op := OP_EQ_SHORTSTRING; + end + else if (T1 = typeSHORTSTRING) and (T2 <> typeSHORTSTRING) then + begin + InsertConversionToShortString(N, 2); + Inc(N); + R.Op := OP_EQ_SHORTSTRING; + end + else if (T1 <> typeSHORTSTRING) and (T2 = typeSHORTSTRING) then + begin + InsertConversionToShortString(N, 1); + Inc(N); + R.Op := OP_EQ_SHORTSTRING; + end + + // wide string + + else if (T1 = typeWIDESTRING) and (T2 = typeWIDESTRING) then + begin + R.Op := OP_EQ_WIDESTRING; + end + else if (T1 = typeWIDESTRING) and (T2 <> typeWIDESTRING) then + begin + InsertConversionToWideString(N, 2); + Inc(N); + R.Op := OP_EQ_WIDESTRING; + end + else if (T1 <> typeWIDESTRING) and (T2 = typeWIDESTRING) then + begin + InsertConversionToWideString(N, 1); + Inc(N); + R.Op := OP_EQ_WIDESTRING; + end +{$ENDIF} + // unic string + + else if (T1 = typeUNICSTRING) and (T2 = typeUNICSTRING) then + begin + R.Op := OP_EQ_UNICSTRING; + end + else if (T1 = typeUNICSTRING) and (T2 <> typeUNICSTRING) then + begin + InsertConversionToUnicString(N, 2); + Inc(N); + R.Op := OP_EQ_UNICSTRING; + end + else if (T1 <> typeUNICSTRING) and (T2 = typeUNICSTRING) then + begin + InsertConversionToUnicString(N, 1); + Inc(N); + R.Op := OP_EQ_UNICSTRING; + end + + // variant + + else if (T1 = typeVARIANT) and (T2 = typeVARIANT) then + begin + R.Op := OP_EQ_VARIANT; + end + else if (T1 = typeVARIANT) and (T2 <> typeVARIANT) then + begin + InsertConversionToVariant(N, 2); + Inc(N); + R.Op := OP_EQ_VARIANT; + end + else if (T1 <> typeVARIANT) and (T2 = typeVARIANT) then + begin + InsertConversionToVariant(N, 1); + Inc(N); + R.Op := OP_EQ_VARIANT; + end + else if (T1 = typeEVENT) and (T2 = typeEVENT) then + begin + R.Op := OP_EQ_EVENT; + end + else if (T1 = typeEVENT) and (Arg2 = SymbolTable.NilId) then + begin + R.Op := OP_EQ_EVENT; + R.Arg2 := SymbolTable.EventNilId; + end + else if (Arg1 = SymbolTable.NilId) and (T2 = typeEVENT) then + begin + R.Op := OP_EQ_EVENT; + R.Arg1 := SymbolTable.EventNilId; + end + else if (T1 = typeARRAY) and (T2 = typeARRAY) and + (GetSymbolRec(Arg1).TypeId = GetSymbolRec(Arg2).TypeId) then + begin + R.Op := OP_EQ_STRUCT; + end + else if (T1 = typeRECORD) and ExistsBinaryOperator + (GetSymbolRec(Arg1).TerminalTypeId, gen_Equal) then + begin + InsertBinaryOperator(GetSymbolRec(Arg1).TerminalTypeId, gen_Equal); + Inc(N); + end + else if (T2 = typeRECORD) and ExistsBinaryOperator + (GetSymbolRec(Arg2).TerminalTypeId, gen_Equal) then + begin + InsertBinaryOperator(GetSymbolRec(Arg2).TerminalTypeId, gen_Equal); + Inc(N); + end + else if (T1 = typePOINTER) and (T2 = typePOINTER) then + begin + R.Op := OP_EQ_INT_MM; + end + else + begin + if GetLanguage(N) = JS_LANGUAGE then + begin + InsertConversionToVariant(N, 1); + Inc(N); + InsertConversionToVariant(N, 2); + Inc(N); + R.Op := OP_EQ_VARIANT; + Exit; + end; + + T1 := GetSymbolRec(Arg1).TypeId; + T2 := GetSymbolRec(Arg2).TypeId; + CreateError(errIncompatibleTypes, [GetSymbolRec(T1).Name, + GetSymbolRec(T2).Name]); + end; +end; + +procedure TCode.OperNotEqual; +var + Arg1, Arg2, T1, T2, K1, K2: Integer; + R: TCodeRec; + SymbolTable: TSymbolTable; +begin + SymbolTable := TKernel(kernel).SymbolTable; + + R := Records[N]; + + Arg1 := R.Arg1; + Arg2 := R.Arg2; + T1 := GetSymbolRec(Arg1).FinalTypeId; + T2 := GetSymbolRec(Arg2).FinalTypeId; + + if T1 in [typePROC, typeEVENT] then + begin + if InsertSubCall(1) then + Exit; + end; + if T2 in [typePROC, typeEVENT] then + begin + if InsertSubCall(2) then + Exit; + end; + + if TKernel(kernel).InterfaceOnly then + if (T1 = 0) or (T2 = 0) then + begin + DiscardImport; + Exit; + end; + + if T1 = typeOLEVARIANT then + T1 := typeVARIANT; + if T2 = typeOLEVARIANT then + T2 := typeVARIANT; + + if T1 = typeSET then + CreateSetObject(Arg1); + if T2 = typeSET then + CreateSetObject(Arg2); + + K1 := GetSymbolRec(Arg1).Kind; + K2 := GetSymbolRec(Arg2).Kind; + + if (T1 = typeENUM) and (T2 = typeENUM) then + begin + T1 := GetSymbolRec(Arg1).TypeId; + T2 := GetSymbolRec(Arg2).TypeId; + + T1 := GetSymbolRec(T1).PatternId; + T2 := GetSymbolRec(T2).PatternId; + + if GetSymbolRec(Arg1).HasSubrangeEnumType then // enum subrange type + begin + T1 := GetSymbolRec(Arg1).TypeId + 1; + T1 := GetSymbolRec(T1).TypeId; + T1 := GetSymbolRec(T1).PatternId; + end; + + if GetSymbolRec(Arg2).HasSubrangeEnumType then // enum subrange type + begin + T2 := GetSymbolRec(Arg1).TypeId + 1; + T2 := GetSymbolRec(T2).TypeId; + T2 := GetSymbolRec(T2).PatternId; + end; + end; + + if not(K1 in [KindVAR, KindCONST]) and (K2 in [KindVAR, KindCONST]) then + begin + CreateError(errIncompatibleTypesNoArgs, []); + Exit; + end; + + GetSymbolRec(R.Res).TypeId := typeBOOLEAN; + + if (T1 in INT64Types) and (T2 in INT64Types) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value <> + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + R.Op := OP_NE_INT64; + end + else if (T1 in INT64Types) and (T2 in IntegerTypes) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value <> + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + R.Op := OP_NE_INT64; + + if K2 = KindCONST then + R.Arg2 := CreateConst(typeINT64, GetSymbolRec(R.Arg2).value) + else + begin + InsertConversionToInt64(N, 2); + Inc(N); + end; + end + else if (T1 in IntegerTypes) and (T2 in INT64Types) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value <> + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + R.Op := OP_NE_INT64; + if K1 = KindCONST then + R.Arg1 := CreateConst(typeINT64, GetSymbolRec(R.Arg1).value) + else + begin + InsertConversionToInt64(N, 1); + Inc(N); + end; + end + + else if (T1 in BooleanTypes) and (T2 in BooleanTypes) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + if (TVarData(GetSymbolRec(Arg1).value).VInteger <> 0) and + (TVarData(GetSymbolRec(Arg2).value).VInteger <> 0) then + GetSymbolRec(R.Res).value := false + else if (TVarData(GetSymbolRec(Arg1).value).VInteger = 0) and + (TVarData(GetSymbolRec(Arg2).value).VInteger = 0) then + GetSymbolRec(R.Res).value := false + else + GetSymbolRec(R.Res).value := false; + + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + if (K1 = KindVAR) and (K2 = KindVAR) then + begin + if T1 <> T2 then + begin + if T1 <> typeBOOLEAN then + begin + InsertConversionToBoolean(N, 1); + Inc(N); + end; + if T2 <> typeBOOLEAN then + begin + InsertConversionToBoolean(N, 2); + Inc(N); + end; + end; + R.Op := OP_NE_INT_MM; + end + else if (K1 = KindVAR) and (K2 = KindCONST) then + begin + if T1 <> T2 then + begin + if T1 <> typeBOOLEAN then + begin + InsertConversionToBoolean(N, 1); + Inc(N); + end; + if T2 <> typeBOOLEAN then + begin + if TVarData(GetSymbolRec(Arg2).value).VInteger <> 0 then + R.Arg2 := SymbolTable.TrueId + else + R.Arg2 := SymbolTable.FalseId + end; + end; + R.Op := OP_NE_INT_MI; + end + else if (K1 = KindCONST) and (K2 = KindVAR) then + begin + R.SwapArguments; + if T1 <> T2 then + begin + if T2 <> typeBOOLEAN then + begin + InsertConversionToBoolean(N, 1); + Inc(N); + end; + if T1 <> typeBOOLEAN then + begin + if TVarData(GetSymbolRec(Arg2).value).VInteger <> 0 then + R.Arg2 := SymbolTable.TrueId + else + R.Arg2 := SymbolTable.FalseId + end; + end; + R.Op := OP_NE_INT_MI; + end; + end + + else if ExistsOrdinalRelationalOperator(T1, T2) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value <> + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + if (K1 = KindVAR) and (K2 = KindVAR) then + R.Op := OP_NE_INT_MM + else if (K1 = KindVAR) and (K2 = KindCONST) then + R.Op := OP_NE_INT_MI + else if (K1 = KindCONST) and (K2 = KindVAR) then + begin + R.Op := OP_NE_INT_MI; + R.SwapArguments; + end; + end + else if (T1 = typeCLASS) and (Arg2 = SymbolTable.NilId) then + begin + if K1 = KindTYPE then + Inc(R.Arg1); + R.Op := OP_NE_INT_MI; + end + else if (Arg1 = SymbolTable.NilId) and (T2 = typeCLASS) then + begin + if K2 = KindTYPE then + Inc(R.Arg2); + R.Op := OP_NE_INT_MI; + R.SwapArguments; + end + else if (T1 = typeCLASS) and (T2 = typeCLASS) then + begin + if K1 = KindTYPE then + Inc(R.Arg1); + if K2 = KindTYPE then + Inc(R.Arg2); + R.Op := OP_NE_INT_MM; + end + else if (T1 in [typePOINTER, typeCLASS, typeCLASSREF, typePROC, typeINTERFACE] + ) and (Arg2 = SymbolTable.NilId) then + begin + R.Op := OP_NE_INT_MI; + end + else if (Arg1 = SymbolTable.NilId) and + (T2 in [typePOINTER, typeCLASS, typeCLASSREF, typePROC, typeINTERFACE]) then + begin + R.Op := OP_NE_INT_MI; + R.SwapArguments; + end + else if (T1 = typeINTERFACE) and (T2 = typeINTERFACE) then + begin + R.Op := OP_NE_INT_MM; + end + else if (T1 = typePOINTER) and (Arg2 = SymbolTable.NilId) then + begin + R.Op := OP_NE_INT_MI; + end + else if (Arg1 = SymbolTable.NilId) and (T2 = typePOINTER) then + begin + R.Op := OP_NE_INT_MI; + R.SwapArguments; + end + else if (T1 = typePOINTER) and (T2 = typePOINTER) then + begin +{$IFNDEF PAXARM} + if (GetSymbolRec(Arg1).HasPAnsiCharType or GetSymbolRec(Arg1) + .HasPWideCharType) and (GetSymbolRec(Arg2).HasPAnsiCharType or + GetSymbolRec(Arg2).HasPWideCharType) then + begin + InsertConversionToUnicString(N, 1); + Inc(N); + InsertConversionToUnicString(N, 2); + Inc(N); + R.Op := OP_NE_WIDESTRING; + Exit; + end; +{$ENDIF} + R.Op := OP_NE_INT_MM; + end + else if (T1 = typeCLASSREF) and (T2 = typeCLASSREF) then + begin + R.Op := OP_NE_INT_MM; + end + else if (T1 = typeCLASS) and (T2 = typeCLASSREF) then + begin + if K1 = KindTYPE then + Inc(R.Arg1); + R.Op := OP_NE_INT_MM; + end + else if (T1 = typeCLASSREF) and (T2 = typeCLASS) then + begin + if K2 = KindTYPE then + Inc(R.Arg2); + R.Op := OP_NE_INT_MM; + end + + else if (T1 = typeCURRENCY) and (T2 in NumberTypes) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value <> + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + end + else if K2 = KindCONST then + begin + R.Op := OP_NE_CURRENCY; + if T2 <> typeCURRENCY then + R.Arg2 := CreateConst(typeCURRENCY, GetSymbolRec(R.Arg2).value); + end + else + R.Op := OP_NE_CURRENCY; + end + else if (T1 in NumberTypes) and (T2 = typeCURRENCY) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value <> + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + end + else if K1 = KindCONST then + begin + R.Op := OP_NE_CURRENCY; + if T1 <> typeCURRENCY then + R.Arg1 := CreateConst(typeCURRENCY, GetSymbolRec(R.Arg1).value); + end + else + R.Op := OP_NE_CURRENCY; + end + + else if (T1 = typeDOUBLE) and (T2 = typeDOUBLE) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value <> + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + R.Op := OP_NE_DOUBLE; + end + else if (T1 = typeDOUBLE) and (T2 in NumberTypes) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value <> + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + R.Op := OP_NE_DOUBLE; + + if K2 = KindCONST then + R.Arg2 := CreateConst(typeDOUBLE, GetSymbolRec(R.Arg2).value) + else + begin + InsertConversionToDouble(N, 2); + Inc(N); + end; + end + else if (T1 in NumberTypes) and (T2 = typeDOUBLE) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value <> + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + R.Op := OP_NE_DOUBLE; + if K1 = KindCONST then + R.Arg1 := CreateConst(typeDOUBLE, GetSymbolRec(R.Arg1).value) + else + begin + InsertConversionToDouble(N, 1); + Inc(N); + end; + end + + else if (T1 = typeSINGLE) and (T2 = typeSINGLE) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value <> + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + R.Op := OP_NE_SINGLE; + end + else if (T1 = typeSINGLE) and (T2 in NumberTypes) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value <> + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + R.Op := OP_NE_SINGLE; + + if K2 = KindCONST then + R.Arg2 := CreateConst(typeSINGLE, GetSymbolRec(R.Arg2).value) + else + begin + InsertConversionToSingle(N, 2); + Inc(N); + end; + end + else if (T1 in NumberTypes) and (T2 = typeSINGLE) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value <> + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + R.Op := OP_NE_SINGLE; + if K1 = KindCONST then + R.Arg1 := CreateConst(typeSINGLE, GetSymbolRec(R.Arg1).value) + else + begin + InsertConversionToSingle(N, 1); + Inc(N); + end; + end + // + else if (T1 = typeEXTENDED) and (T2 = typeEXTENDED) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value <> + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + R.Op := OP_NE_EXTENDED; + end + else if (T1 = typeEXTENDED) and (T2 in NumberTypes) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value <> + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + + R.Op := OP_NE_EXTENDED; + + if K2 = KindCONST then + R.Arg2 := CreateConst(typeEXTENDED, GetSymbolRec(R.Arg2).value) + else + begin + InsertConversionToExtended(N, 2); + Inc(N); + end; + end + else if (T1 in NumberTypes) and (T2 = typeEXTENDED) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value <> + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + Exit; + end; + R.Op := OP_NE_EXTENDED; + if K1 = KindCONST then + R.Arg1 := CreateConst(typeEXTENDED, GetSymbolRec(R.Arg1).value) + else + begin + InsertConversionToExtended(N, 1); + Inc(N); + end; + end + // + else if (T1 = typeSET) and (T2 = typeSET) then + begin + T1 := GetSymbolRec(Arg1).TypeId; + T2 := GetSymbolRec(Arg2).TypeId; + if not MatchSetTypes(T1, T2) then + CreateError(errIncompatibleTypesNoArgs, []) + else if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).ValueAsByteSet <> + GetSymbolRec(Arg2).ValueAsByteSet; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + end + else if (K1 in [KindVAR, KindCONST]) and (K2 in [KindVAR, KindCONST]) then + R.Op := OP_SET_INEQUALITY + else + CreateError(errIncompatibleTypesNoArgs, []) + end +{$IFNDEF PAXARM} + else if (T1 = typeANSISTRING) and (T2 = typeANSISTRING) then + begin + R.Op := OP_NE_ANSISTRING; + end + else if (T1 = typeANSISTRING) and (T2 <> typeANSISTRING) then + begin + InsertConversionToAnsiString(N, 2); + Inc(N); + R.Op := OP_NE_ANSISTRING; + end + else if (T1 <> typeANSISTRING) and (T2 = typeANSISTRING) then + begin + InsertConversionToAnsiString(N, 1); + Inc(N); + R.Op := OP_NE_ANSISTRING; + end + + else if (T1 = typeSHORTSTRING) and (T2 = typeSHORTSTRING) then + begin + R.Op := OP_NE_SHORTSTRING; + end + else if (T1 = typeSHORTSTRING) and (T2 <> typeSHORTSTRING) then + begin + InsertConversionToShortString(N, 2); + Inc(N); + R.Op := OP_NE_SHORTSTRING; + end + else if (T1 <> typeSHORTSTRING) and (T2 = typeSHORTSTRING) then + begin + InsertConversionToShortString(N, 1); + Inc(N); + R.Op := OP_NE_SHORTSTRING; + end + + // wide string + + else if (T1 = typeWIDESTRING) and (T2 = typeWIDESTRING) then + begin + R.Op := OP_NE_WIDESTRING; + end + else if (T1 = typeWIDESTRING) and (T2 <> typeWIDESTRING) then + begin + InsertConversionToWideString(N, 2); + Inc(N); + R.Op := OP_NE_WIDESTRING; + end + else if (T1 <> typeWIDESTRING) and (T2 = typeWIDESTRING) then + begin + InsertConversionToWideString(N, 1); + Inc(N); + R.Op := OP_NE_WIDESTRING; + end +{$ENDIF} + // unic string + + else if (T1 = typeUNICSTRING) and (T2 = typeUNICSTRING) then + begin + R.Op := OP_NE_UNICSTRING; + end + else if (T1 = typeUNICSTRING) and (T2 <> typeUNICSTRING) then + begin + InsertConversionToUnicString(N, 2); + Inc(N); + R.Op := OP_NE_UNICSTRING; + end + else if (T1 <> typeUNICSTRING) and (T2 = typeUNICSTRING) then + begin + InsertConversionToUnicString(N, 1); + Inc(N); + R.Op := OP_NE_UNICSTRING; + end + + // variant + + else if (T1 = typeVARIANT) and (T2 = typeVARIANT) then + begin + R.Op := OP_NE_VARIANT; + end + else if (T1 = typeVARIANT) and (T2 <> typeVARIANT) then + begin + InsertConversionToVariant(N, 2); + Inc(N); + R.Op := OP_NE_VARIANT; + end + else if (T1 <> typeVARIANT) and (T2 = typeVARIANT) then + begin + InsertConversionToVariant(N, 1); + Inc(N); + R.Op := OP_NE_VARIANT; + end + else if (T1 = typeEVENT) and (T2 = typeEVENT) then + begin + R.Op := OP_NE_EVENT; + end + else if (T1 = typeEVENT) and (Arg2 = SymbolTable.NilId) then + begin + R.Op := OP_NE_EVENT; + R.Arg2 := SymbolTable.EventNilId; + end + else if (Arg1 = SymbolTable.NilId) and (T2 = typeEVENT) then + begin + R.Op := OP_NE_EVENT; + R.Arg1 := SymbolTable.EventNilId; + end + // +{$IFNDEF PAXARM} + else if GetSymbolRec(Arg1).HasPAnsiCharType and GetSymbolRec(Arg2).HasPAnsiCharType + then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value <> + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + end + else + begin + InsertConversionToAnsiString(N, 1); + Inc(N); + InsertConversionToAnsiString(N, 2); + Inc(N); + R.Op := OP_NE_ANSISTRING; + end; + end + else if GetSymbolRec(Arg1).HasPAnsiCharType and (T2 = typeANSICHAR) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value <> + Chr(Integer(GetSymbolRec(Arg2).value)); + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + end + else + begin + InsertConversionToAnsiString(N, 1); + Inc(N); + InsertConversionToAnsiString(N, 2); + Inc(N); + R.Op := OP_NE_ANSISTRING; + end; + end + else if (T1 = typeANSICHAR) and GetSymbolRec(Arg2).HasPAnsiCharType then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := Chr(Integer(GetSymbolRec(Arg1).value)) <> + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + end + else + begin + InsertConversionToAnsiString(N, 1); + Inc(N); + InsertConversionToAnsiString(N, 2); + Inc(N); + R.Op := OP_NE_ANSISTRING; + end; + end + // +{$ENDIF} + else if GetSymbolRec(Arg1).HasPWideCharType and GetSymbolRec(Arg2).HasPWideCharType + then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value <> + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + end + else + begin + InsertConversionToUnicString(N, 1); + Inc(N); + InsertConversionToUnicString(N, 2); + Inc(N); + R.Op := OP_NE_UNICSTRING; + end; + end + else if (GetSymbolRec(Arg1).HasPWideCharType +{$IFNDEF PAXARM} + or GetSymbolRec(Arg1).HasPAnsiCharType +{$ENDIF} + ) and (T2 in CharTypes) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := GetSymbolRec(Arg1).value <> + Chr(Integer(GetSymbolRec(Arg2).value)); + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + end + else + begin + InsertConversionToUnicString(N, 1); + Inc(N); + InsertConversionToUnicString(N, 2); + Inc(N); + R.Op := OP_NE_UNICSTRING; + end; + end + else if (T1 in CharTypes) and (GetSymbolRec(Arg2).HasPWideCharType +{$IFNDEF PAXARM} + or GetSymbolRec(Arg2).HasPAnsiCharType +{$ENDIF} + ) then + begin + if (K1 = KindCONST) and (K2 = KindCONST) then + begin + GetSymbolRec(R.Res).value := Chr(Integer(GetSymbolRec(Arg1).value)) <> + GetSymbolRec(Arg2).value; + GetSymbolRec(R.Res).Kind := KindCONST; + R.Op := OP_NOP; + end + else + begin + InsertConversionToUnicString(N, 1); + Inc(N); + InsertConversionToUnicString(N, 2); + Inc(N); + R.Op := OP_NE_UNICSTRING; + end; + end + else if (T1 = typePOINTER) and (T2 = typePOINTER) then + begin + R.Op := OP_NE_INT_MM; + end + // + else if (T1 = typeARRAY) and (T2 = typeARRAY) and + (GetSymbolRec(Arg1).TypeId = GetSymbolRec(Arg2).TypeId) then + begin + R.Op := OP_NE_STRUCT; + end + else if (T1 = typeRECORD) and ExistsBinaryOperator + (GetSymbolRec(Arg1).TerminalTypeId, gen_NotEqual) then + begin + InsertBinaryOperator(GetSymbolRec(Arg1).TerminalTypeId, gen_NotEqual); + Inc(N); + end + else if (T2 = typeRECORD) and ExistsBinaryOperator + (GetSymbolRec(Arg2).TerminalTypeId, gen_NotEqual) then + begin + InsertBinaryOperator(GetSymbolRec(Arg2).TerminalTypeId, gen_NotEqual); + Inc(N); + end + else + begin + if GetLanguage(N) = JS_LANGUAGE then + begin + InsertConversionToVariant(N, 1); + Inc(N); + InsertConversionToVariant(N, 2); + Inc(N); + R.Op := OP_NE_VARIANT; + Exit; + end; + + T1 := GetSymbolRec(Arg1).TypeId; + T2 := GetSymbolRec(Arg2).TypeId; + CreateError(errIncompatibleTypes, [GetSymbolRec(T1).Name, + GetSymbolRec(T2).Name]); + end; +end; + +procedure TCode.OperRaise; +var + R: TCodeRec; +begin + R := Records[N]; + if R.Arg1 > 0 then + if GetSymbolRec(R.Arg1).FinalTypeId <> typeCLASS then + CreateError(errClassTypeExpected, []); +end; + +procedure TCode.OperTypeInfo; +var + R: TCodeRec; + S: String; +begin + R := Records[N]; + if GetSymbolRec(R.Arg1).Kind <> KindTYPE then + CreateError(errIncompatibleTypesNoArgs, []); + S := GetSymbolRec(R.Arg1).FullName; + R.Arg2 := CreateConst(typeSTRING, S); +end; + +procedure TCode.OperAddTypeInfo; +var + R: TCodeRec; + SourceTypeId: Integer; +begin + R := Records[N]; + if GetSymbolRec(R.Arg1).Kind <> KindTYPE then + begin + CreateError(errIncompatibleTypesNoArgs, []); + end; + + if GetSymbolRec(R.Arg1).Kind = KindTYPE then + SourceTypeId := R.Arg1 + else + SourceTypeId := GetSymbolRec(R.Arg1).TypeId; + + AddTypeInfo(GetSymbolRec(R.Arg1).TerminalTypeId, SourceTypeId); +end; + +procedure TCode.OperIs; +var + Arg1, Arg2, T1, T2, K1, K2: Integer; + R: TCodeRec; +begin + R := Records[N]; + + Arg1 := R.Arg1; + Arg2 := R.Arg2; + T1 := GetSymbolRec(Arg1).FinalTypeId; + T2 := GetSymbolRec(Arg2).FinalTypeId; + + if TKernel(kernel).InterfaceOnly then + if (T1 = 0) or (T2 = 0) then + begin + DiscardImport; + Exit; + end; + + K1 := GetSymbolRec(Arg1).Kind; + K2 := GetSymbolRec(Arg2).Kind; + + GetSymbolRec(R.Res).TypeId := typeBOOLEAN; + + if (T1 = typeCLASS) and (T2 = typeCLASS) and (K1 = KindVAR) and (K2 = KindTYPE) + then + begin + // ok + end + else + CreateError(errIncompatibleTypesNoArgs, []); +end; + +procedure TCode.OperAs; +var + Arg1, Arg2, T1, T2, K1, K2: Integer; + R: TCodeRec; +begin + R := Records[N]; + + Arg1 := R.Arg1; + Arg2 := R.Arg2; + T1 := GetSymbolRec(Arg1).FinalTypeId; + T2 := GetSymbolRec(Arg2).FinalTypeId; + + if TKernel(kernel).InterfaceOnly then + if (T1 = 0) or (T2 = 0) then + begin + DiscardImport; + Exit; + end; + + K1 := GetSymbolRec(Arg1).Kind; + K2 := GetSymbolRec(Arg2).Kind; + + map_list.Add(Arg2); + + if (T1 = typeCLASS) and (T2 = typeCLASS) and (K1 = KindVAR) and (K2 = KindTYPE) + then + begin + R.Op := OP_ASSIGN_INT_M; + R.Arg1 := R.Res; + R.Arg2 := Arg1; + GetSymbolRec(R.Res).TypeId := Arg2; + end + else if (T1 = typeINTERFACE) and (T2 = typeINTERFACE) and (K1 = KindVAR) and + (K2 = KindTYPE) then + begin + R.Op := OP_INTERFACE_CAST; + GetSymbolRec(R.Res).TypeId := Arg2; + end + else if (T1 = typeCLASS) and (T2 = typeINTERFACE) and (K1 = KindVAR) and + (K2 = KindTYPE) then + begin + R.Op := OP_INTERFACE_FROM_CLASS; + R.Arg1 := R.Res; + R.Arg2 := Arg1; + GetSymbolRec(R.Res).TypeId := Arg2; + end + else + CreateError(errIncompatibleTypesNoArgs, []); +end; + +procedure TCode.OperGoTrue; +var + Arg2, T2: Integer; + V: Variant; +begin + Arg2 := Records[N].Arg2; + T2 := GetSymbolRec(Arg2).FinalTypeId; + if not(T2 in BooleanTypes) then + begin + if Records[N].Language = JS_LANGUAGE then + begin + if GetSymbolRec(Arg2).Kind = KindCONST then + begin + if T2 in IntegerTypes then + begin + V := GetSymbolRec(Arg2).value; + Records[N].Arg2 := CreateConst(typeBOOLEAN, V = 0); + Exit; + end +{$IFNDEF PAXARM} + else if GetSymbolRec(Arg2).HasPAnsiCharType then + begin + V := GetSymbolRec(Arg2).value; + Records[N].Arg2 := CreateConst(typeBOOLEAN, V = ''); + Exit; + end; +{$ENDIF} + end + else + begin + InsertConversionToBoolean(N, 2); + Inc(N); + Exit; + end; + end + else if T2 in VariantTypes then + begin + InsertConversionToBoolean(N, 2); + Inc(N); + Exit; + end; + + CreateError(errTypeOfExpressionMustBe, ['BOOLEAN']); + end; +end; + +procedure TCode.OperGoFalse; +var + Arg2, T2: Integer; + V: Variant; +begin + Arg2 := Records[N].Arg2; + T2 := GetSymbolRec(Arg2).FinalTypeId; + if not(T2 in BooleanTypes) then + begin + if Records[N].Language = JS_LANGUAGE then + begin + if GetSymbolRec(Arg2).Kind = KindCONST then + begin + if T2 in IntegerTypes then + begin + V := GetSymbolRec(Arg2).value; + Records[N].Arg2 := CreateConst(typeBOOLEAN, V <> 0); + Exit; + end +{$IFNDEF PAXARM} + else if GetSymbolRec(Arg2).HasPAnsiCharType then + begin + V := GetSymbolRec(Arg2).value; + Records[N].Arg2 := CreateConst(typeBOOLEAN, V <> ''); + Exit; + end +{$ENDIF} + else if GetSymbolRec(Arg2).HasPWideCharType then + begin + V := GetSymbolRec(Arg2).value; + Records[N].Arg2 := CreateConst(typeBOOLEAN, V <> ''); + Exit; + end; + end + else + begin + InsertConversionToBoolean(N, 2); + Inc(N); + Exit; + end; + end + else if T2 in VariantTypes then + begin + InsertConversionToBoolean(N, 2); + Inc(N); + Exit; + end; + + CreateError(errTypeOfExpressionMustBe, ['BOOLEAN']); + end; +end; + +procedure TCode.OperGoTrueBool; +var + Arg2, T2: Integer; +begin + Arg2 := Records[N].Arg2; + T2 := GetSymbolRec(Arg2).FinalTypeId; + if T2 in (BooleanTypes + VariantTypes) then + begin + Records[N].Op := OP_GO_TRUE; + Dec(N); + end + else + Records[N].Op := OP_NOP; +end; + +procedure TCode.OperGoFalseBool; +var + Arg2, T2: Integer; +begin + Arg2 := Records[N].Arg2; + T2 := GetSymbolRec(Arg2).FinalTypeId; + if T2 in (BooleanTypes + VariantTypes) then + begin + Records[N].Op := OP_GO_FALSE; + Dec(N); + end + else + Records[N].Op := OP_NOP; +end; + +procedure TCode.RemoveEvalOpForTypes; + +var + using_stack: TIntegerStack; + EndOfImport: Boolean; + + function CheckNamespace(Arg1: Integer): Boolean; + var + I, Id: Integer; + S, Q: String; + begin + if not EndOfImport then + begin + result := true; + Exit; + end; + + result := using_stack.IndexOf(Arg1) >= 0; + if result then + Exit; + + S := UpperCase(GetSymbolRec(Arg1).FullName); + for I := 0 to using_stack.Count - 1 do + begin + Id := using_stack[I]; + if Id = 0 then + continue; + Q := UpperCase(GetSymbolRec(Id).FullName); + result := pos(S, Q) = SLow(S); + if result then + Exit; + end; + end; + +var + Id, Op, Arg1, Arg2, K, K1: Integer; + sub_stack: TIntegerStack; + SymbolTable: TSymbolTable; + Upcase: Boolean; + S: String; + RN: TCodeRec; + WithCount: Integer; +begin + SymbolTable := TKernel(kernel).SymbolTable; + + using_stack := TIntegerStack.Create; + sub_stack := TIntegerStack.Create; + WithCount := 0; + EndOfImport := false; + + try + N := 0; + while N < Card do + begin + Inc(N); + + RN := Records[N]; + Op := RN.Op; + + if Op = OP_BEGIN_USING then + using_stack.Push(RN.Arg1) + else if Op = OP_END_USING then + using_stack.Pop + else if Op = OP_BEGIN_WITH then + Inc(WithCount) + else if Op = OP_END_WITH then + Dec(WithCount) + else if Op = OP_END_IMPORT then + EndOfImport := true + else if Op = OP_BEGIN_MODULE then + EndOfImport := false + { + else if Op = OP_BEGIN_MODULE then + using_stack.Clear + } + else if Op = OP_END_MODULE then + using_stack.Clear + + else if Op = OP_BEGIN_SUB then + sub_stack.Push(RN.Arg1) + else if Op = OP_END_SUB then + sub_stack.Pop + + else if Op = OP_EVAL then + begin + if RN.Res <= Types.Count then + begin + RN.Op := OP_NOP; + continue; + end; + + S := GetSymbolRec(RN.Res).Name; + + if S = DummyName then + begin + RN.Op := OP_NOP; + continue; + end; + + if S = '' then + begin + RN.Op := OP_NOP; + GetSymbolRec(RN.Res).Kind := KindNONE; + continue; + end; + + if WithCount > 0 then + continue; + + Upcase := GetUpcase(N); + + // try to find in the sub list + + K := GetSymbolRec(RN.Res).Kind; + GetSymbolRec(RN.Res).Kind := KindNONE; + + Id := SymbolTable.LookUps(S, sub_stack, Upcase); + + if Id > 0 then + if GetSymbolRec(Id).Kind = KindTYPE then + begin + GetSymbolRec(RN.Res).Name := ''; + ReplaceId(RN.Res, Id); + RN.Op := OP_NOP; + continue; + end; + + // try to find in the using list + Id := SymbolTable.LookUps(S, using_stack, Upcase); + if Id = 0 then + Id := SymbolTable.LookUp(S, 0, Upcase); + + if Id > 0 then + if GetSymbolRec(Id).Kind in [KindTYPE, KindNAMESPACE] then + begin + if GetSymbolRec(Id).FinalTypeId in [typeCLASS, typeRECORD] then + continue; + + if Id > RN.Res then + if GetLanguage(N) in [PASCAL_LANGUAGE] then + if TKernel(kernel).Modules.IndexOfModuleById(RN.Res) + = TKernel(kernel).Modules.IndexOfModuleById(Id) then + begin + if TKernel(kernel).Modules.IsDefinedInPCU(Id) then + begin + // ok + end + else if GetSymbolRec(Id).Host then + begin + // ok + end + else + CreateError(errUndeclaredIdentifier, [S]); + end; + + GetSymbolRec(RN.Res).Name := ''; + ReplaceId(RN.Res, Id); + RN.Op := OP_NOP; + + continue; + end; + + GetSymbolRec(RN.Res).Kind := K; + end + else if Op = OP_FIELD then + begin + Arg1 := RN.Arg1; + Arg2 := RN.Arg2; + K1 := GetSymbolRec(Arg1).Kind; + + if K1 = KindNAMESPACE then + begin + if GetLanguage(N) = PASCAL_LANGUAGE then + if not CheckNamespace(Arg1) then + begin + S := GetSymbolRec(Arg1).Name; + CreateError(errUndeclaredIdentifier, [S]); + TKernel(kernel).SymbolTable.AddUndeclaredIdent(S, + TKernel(kernel).UndeclaredIdents, TKernel(kernel).Errors.Count + - 1, true); + end; + + Id := SymbolTable.LookUp(GetSymbolRec(Arg2).Name, Arg1, GetUpcase(N)); + if Id <> 0 then + if GetSymbolRec(Id).Kind in [KindTYPE, KindNAMESPACE] then + begin + ReplaceId(Arg2, Id); + GetSymbolRec(Arg2).Name := ''; + GetSymbolRec(Arg2).Kind := KindNONE; + RN.Op := OP_NOP; + + end; + end; + end + + // set types + else if Op = OP_ASSIGN_TYPE then + begin + if GetSymbolRec(RN.Arg2).Kind <> KindTYPE then + continue; + + GetSymbolRec(RN.Arg1).TypeId := RN.Arg2; + + RN.Op := OP_NOP; + end + else if Op = OP_ASSIGN_THE_SAME_TYPE then + begin + GetSymbolRec(RN.Arg1).TypeId := GetSymbolRec(RN.Arg2).TypeId; + RN.Op := OP_NOP; + end + else if Op = OP_ASSIGN_TYPE_ALIAS then + begin + if GetSymbolRec(RN.Arg2).Kind <> KindTYPE then + begin + continue; + end; + + GetSymbolRec(RN.Arg1).PatternId := RN.Arg2; + RN.Op := OP_NOP; + end + + else if Op = OP_CREATE_POINTER_TYPE then + begin + if GetSymbolRec(RN.Arg2).Kind <> KindTYPE then + begin + continue; + end; + + GetSymbolRec(RN.Arg1).PatternId := RN.Arg2; + RN.Op := OP_NOP; + end + else if Op = OP_CREATE_CLASSREF_TYPE then + begin + if GetSymbolRec(RN.Arg2).Kind <> KindTYPE then + begin + continue; + end; + + GetSymbolRec(RN.Arg1).PatternId := RN.Arg2; + RN.Op := OP_NOP; + end + else if Op = OP_BEGIN_HELPER_TYPE then + begin + if GetSymbolRec(RN.Arg2).Kind <> KindTYPE then + begin + continue; + end; + GetSymbolRec(RN.Arg1).PatternId := RN.Arg2; + if SymbolTable.TypeHelpers.Keys.IndexOf(RN.Arg1) = -1 then + SymbolTable.TypeHelpers.Add(RN.Arg1, RN.Arg2); + end + else if Op = OP_CALL then + begin + if GetSymbolRec(RN.Arg1).Kind = KindTYPE then + if Records[N - 1].Op = OP_PUSH then + if Records[N - 1].Arg1 = SymbolTable.NilId then + if Records[N + 1].Op = OP_FIELD then + if Records[N + 1].Arg1 = RN.Res then + begin + RN.Op := OP_NOP; + RN.GenOp := OP_NOP; + Records[N - 1].Op := OP_NOP; + Records[N - 1].GenOp := OP_NOP; + Records[N + 1].Arg1 := RN.Arg1; + GetSymbolRec(Records[N + 1].Arg2).OwnerId := RN.Arg1; + end; + end + else if Op = OP_CREATE_DYNAMIC_ARRAY_TYPE then + begin + if GetSymbolRec(RN.Arg2).Kind <> KindTYPE then + begin + continue; + end; + + GetSymbolRec(RN.Arg1).PatternId := RN.Arg2; + RN.Op := OP_NOP; + end + else if Op = OP_ADD_ANCESTOR then + begin + if GetSymbolRec(RN.Arg2).Kind <> KindTYPE then + begin + continue; + end; + + GetSymbolRec(RN.Arg1).AncestorId := RN.Arg2; + + // RN.Op := OP_NOP; + end + else if Op = OP_ADD_INTERFACE then + begin + if RN.Arg2 = 0 then + RN.Arg2 := SymbolTable.LookupAnonymousInterface(RN.Arg1); + if GetSymbolRec(RN.Arg2).Kind <> KindTYPE then + begin + if TKernel(kernel).InterfaceOnly then + RN.Op := OP_NOP; + continue; + end; + + if GetSymbolRec(RN.Arg2).FinalTypeId <> typeINTERFACE then + CreateError(errIncompatibleTypesNoArgs, []); + + SymbolTable.RegisterSupportedInterface(RN.Arg1, RN.Arg2); + RN.Op := OP_NOP; + end; + end; // while + + finally + FreeAndNil(using_stack); + FreeAndNil(sub_stack); + end; +end; + +procedure TCode.ProcessImplements; + +var + PropId, IntfTypeId, ClassTypeId, LanguageId, CurrModule: Integer; + Upcase: Boolean; + SymbolTable: TSymbolTable; + L: Integer; + + procedure Gen(Op, Arg1, Arg2, Res: Integer); + begin + Add(Op, Arg1, Arg2, Res, L, Upcase, LanguageId, CurrModule, 0); + end; + + procedure AddMethod(IntfSubId: Integer); + var + I, SubId, LabelId, ResId, SelfId, ParamId, IntfParamId, IntfResTypeId, + TempPropId, NameId, TempId, NP: Integer; + IsFunction: Boolean; + begin + IntfResTypeId := SymbolTable[IntfSubId].TypeId; + IsFunction := (IntfResTypeId <> 0) and (IntfResTypeId <> typeVOID); + NP := GetSymbolRec(IntfSubId).Count; + + LabelId := SymbolTable.AddLabel.Id; + + SubId := NewTempVar(ClassTypeId, IntfResTypeId); + + L := SubId; + + GetSymbolRec(SubId).Name := GetSymbolRec(IntfSubId).Name; + GetSymbolRec(SubId).Kind := KindSUB; + GetSymbolRec(SubId).CallConv := GetSymbolRec(IntfSubId).CallConv; + GetSymbolRec(SubId).Count := GetSymbolRec(IntfSubId).Count; + + ResId := NewTempVar(SubId, IntfResTypeId); + if not IsFunction then + GetSymbolRec(ResId).Kind := KindNONE; + + SelfId := NewTempVar(SubId, ClassTypeId); + GetSymbolRec(SelfId).Param := true; + + for I := 0 to NP - 1 do + begin + IntfParamId := SymbolTable.GetParamId(IntfSubId, I); + ParamId := NewTempVar(SubId, GetSymbolRec(IntfParamId).TypeId); + GetSymbolRec(ParamId).Param := true; + GetSymbolRec(ParamId).Name := GetSymbolRec(IntfParamId).Name; + GetSymbolRec(ParamId).ByRef := GetSymbolRec(IntfParamId).ByRef; + GetSymbolRec(ParamId).IsConst := GetSymbolRec(IntfParamId).IsConst; + GetSymbolRec(ParamId).Optional := GetSymbolRec(IntfParamId).Optional; + GetSymbolRec(ParamId).value := GetSymbolRec(IntfParamId).value; + end; + + TempPropId := NewTempVar(SubId, GetSymbolRec(PropId).TypeId); + GetSymbolRec(TempPropId).OwnerId := SelfId; + GetSymbolRec(TempPropId).Name := GetSymbolRec(PropId).Name; + + NameId := NewTempVar(SubId, GetSymbolRec(SubId).TypeId); + GetSymbolRec(NameId).OwnerId := TempPropId; + GetSymbolRec(NameId).Name := GetSymbolRec(SubId).Name; + + Gen(OP_GO, LabelId, 0, 0); + Gen(OP_BEGIN_SUB, SubId, 0, 0); + Gen(OP_LABEL, SubId, 0, 0); + Gen(OP_INIT_SUB, SubId, 0, 0); + // reserved for prologue + Gen(OP_NOP, 0, 0, 0); + + if IsFunction then + begin + TempId := NewTempVar(SubId, GetSymbolRec(ResId).TypeId); + + Gen(OP_LVALUE, ResId, 0, 0); + Gen(OP_FIELD, SelfId, TempPropId, TempPropId); + Gen(OP_FIELD, TempPropId, NameId, NameId); + for I := 0 to NP - 1 do + Gen(OP_PUSH, SymbolTable.GetParamId(SubId, I), I, NameId); + Gen(OP_CALL, NameId, NP, TempId); + Gen(OP_ASSIGN, ResId, TempId, ResId); + end + else + begin + Gen(OP_FIELD, SelfId, TempPropId, TempPropId); + Gen(OP_FIELD, TempPropId, NameId, NameId); + for I := 0 to NP - 1 do + Gen(OP_PUSH, SymbolTable.GetParamId(SubId, I), I, NameId); + Gen(OP_CALL, NameId, NP, 0); + end; + + Gen(OP_EPILOGUE_SUB, SubId, 0, 0); + // reserved for epilogue + Gen(OP_NOP, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + + // reserved for epilogue + Gen(OP_NOP, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + Gen(OP_END_SUB, SubId, 0, 0); + Gen(OP_FIN_SUB, SubId, 0, 0); + Gen(OP_LABEL, LabelId, 0, 0); + end; + +var + I, J: Integer; + SI: TSymbolRec; +begin + SymbolTable := TKernel(kernel).SymbolTable; + + for I := 1 to Card do + if Records[I].Op = OP_IMPLEMENTS then + begin + N := I; + + PropId := Records[N].Arg1; + IntfTypeId := Records[N].Arg2; + + ClassTypeId := GetSymbolRec(PropId).Level; + + if GetSymbolRec(IntfTypeId).FinalTypeId <> typeINTERFACE then + RaiseError(errInternalError, []); + + LanguageId := GetLanguage(N); + Upcase := GetUpcase(N); + CurrModule := GetModuleNumber(N); + + for J := IntfTypeId + 1 to SymbolTable.Card do + begin + SI := SymbolTable[J]; + if SI.Kind = KindSUB then + if SI.Level = IntfTypeId then + begin + AddMethod(J); + end; + + if SI = SymbolTable.SR0 then + break; + end; + end; +end; + +function TCode.IsExplicitOff: Boolean; +var + I: Integer; + R: TCodeRec; +begin + result := false; + for I := N downto 1 do + begin + R := Records[I]; + if R.Op = OP_BEGIN_MODULE then + Exit; + if R.Op = OP_OPTION_EXPLICIT then + if R.Arg1 = 0 then + begin + result := true; + Exit; + end; + end; +end; + +function TCode.EvalFrameworkType(const S: String): Integer; +begin + result := 0; + if S = 'Object' then + result := H_TFW_Object + else if S = 'String' then + begin +{$IFDEF UNIC} + result := H_TFW_UnicString; +{$ELSE} + result := H_TFW_AnsiString; +{$ENDIF} + end + else if S = 'Integer' then + result := H_TFW_Integer + else if S = 'Byte' then + result := H_TFW_Byte + else if S = 'Short' then + result := H_TFW_ShortInt + else if S = 'Long' then + result := H_TFW_Int64 + else if S = 'Float' then + result := H_TFW_Single + else if S = 'Double' then + result := H_TFW_Double + else if S = 'Boolean' then + result := H_TFW_Boolean + else if S = 'Char' then + begin +{$IFDEF UNIC} + result := H_TFW_AnsiChar; +{$ELSE} + result := H_TFW_WideChar; +{$ENDIF} + end; +end; + +procedure TCode.CreateEvalError(const VarName: String; + using_stack: TIntegerStack); +var + I, Id, L, TypeId, K1, K2: Integer; + S, Scope, TypeName: String; + SymbolTable: TSymbolTable; + Upcase, ok: Boolean; +begin + if GetLanguage(N) in [JAVA_LANGUAGE] then + begin + Id := EvalFrameworkType(VarName); + if Id <> 0 then + begin + Records[N].Op := OP_NOP; + ReplaceId(Records[N].Res, Id); + Exit; + end; + end; + + SymbolTable := TKernel(kernel).SymbolTable; + Upcase := GetUpcase(N); + Id := Records[N].Res; + Records[N].Op := OP_NOP; + if Assigned(TKernel(kernel).OnUndeclaredIdentifier) then + begin + L := GetSymbolRec(Id).Level; + if L = 0 then + Scope := '' + else + Scope := GetSymbolRec(L).FullName; + + S := Scope; + TypeName := ''; + + K1 := TKernel(kernel).SymbolTable.Card; + if TKernel(kernel).OnUndeclaredIdentifier(TKernel(kernel).Owner, VarName, + Scope, TypeName) then + if TypeName <> '' then + begin + K2 := TKernel(kernel).SymbolTable.Card; + for I := K1 + 1 to K2 do + begin + + if Upcase then + ok := StrEql(GetSymbolRec(I).Name, VarName) + else + ok := GetSymbolRec(I).Name = VarName; + + if ok then + begin + ReplaceId(Id, I); + Exit; + end; + end; + + if S <> Scope then + begin + if Scope = '' then + L := 0 + else + begin + L := SymbolTable.LookupFullName(Scope, GetUpcase(N)); + if L = 0 then + CreateError(errUndeclaredIdentifier, [Scope]); + end; + end; + + TypeId := SymbolTable.LookupFullName(TypeName, GetUpcase(N)); + if TypeId = 0 then + begin + CreateError(errUndeclaredIdentifier, [TypeName]); + SymbolTable.AddUndeclaredIdent(TypeName, + TKernel(kernel).UndeclaredIdents, TKernel(kernel).Errors.Count + - 1, true); + end + else if GetSymbolRec(TypeId).Kind = KindTYPE then + begin + GetSymbolRec(Id).Kind := KindVAR; + GetSymbolRec(Id).TypeId := TypeId; + GetSymbolRec(Id).Level := L; + end; + + Exit; + end; + end; + + I := N; + S := GetSymbolRec(Records[I].Res).Name; + while (Records[I + 1].Op = OP_FIELD) and + (Records[I + 1].Arg1 = Records[I].Res) do + begin + S := S + '.' + GetSymbolRec(Records[I + 1].Res).Name; + Id := SymbolTable.LookUps(S, using_stack, Upcase); + if Id > 0 then + begin + Inc(I); + ReplaceId(Records[I].Res, Id); + while I > N do + begin + Records[I].Op := OP_NOP; + if Records[I].Arg1 > 0 then + if GetSymbolRec(Records[I].Arg1).Kind = KindNONE then + GetSymbolRec(Records[I].Arg1).Name := ''; + + Dec(I); + end; + + Exit; + end; + + Inc(I); + end; + + if IsExplicitOff then + begin + GetSymbolRec(Id).Kind := KindVAR; + GetSymbolRec(Id).Level := GetLevel(N); + Exit; + end; + + if TKernel(kernel).Errors.Count > 10 then + RaiseError(errUndeclaredIdentifier, [VarName]) + else + begin + CreateError(errUndeclaredIdentifier, [VarName]); + SymbolTable.AddUndeclaredIdent(VarName, TKernel(kernel).UndeclaredIdents, + TKernel(kernel).Errors.Count - 1, true); + end; +end; + +procedure TCode.RemoveEvalOp; +var + SubId, ParamId, I, J, Id, Op, Arg1, Arg2, K, K1, TypeId, + PatternFieldId: Integer; + using_stack, with_stack, sub_stack, block_stack: TIntegerStack; + SymbolTable: TSymbolTable; + Upcase: Boolean; + S: String; + Modules: TModuleList; + I1, I2: Integer; + B1, B2: Boolean; + UpperBoundId: Integer; + NS_ID: Integer; + RC: TCodeRec; + RJ, RN: TCodeRec; + eval_helper_name: TStringList; + eval_helper_id, eval_helper_PatternFieldId: TIntegerList; + temp_id: Integer; + IsExport: Boolean; +label + Next, NextTime; +begin + IsExport := false; + + SymbolTable := TKernel(kernel).SymbolTable; + Modules := TKernel(kernel).Modules; + + using_stack := TIntegerStack.Create; + block_stack := TIntegerStack.Create; + with_stack := TIntegerStack.Create; + sub_stack := TIntegerStack.Create; + eval_helper_name := TStringList.Create; + eval_helper_id := TIntegerList.Create; + eval_helper_PatternFieldId := TIntegerList.Create; + + try + N := 1; + while N <= Card do + begin + + NextTime: + + RN := Records[N]; + Op := RN.Op; + + if Op = OP_NOP then + goto Next + else if Op = OP_BEGIN_USING then + using_stack.Push(RN.Arg1) + else if Op = OP_END_USING then + using_stack.Pop + { + else if Op = OP_BEGIN_MODULE then + using_stack.Clear + } + else if Op = OP_BEGIN_EXPORT then + IsExport := true + else if Op = OP_END_MODULE then + begin + IsExport := false; + using_stack.Clear; + end + + else if Op = OP_BEGIN_BLOCK then + block_stack.Push(RN.Arg1) + else if Op = OP_END_BLOCK then + block_stack.Pop + + else if Op = OP_BEGIN_WITH then + begin + // RN.Op := OP_NOP; + eval_helper_name.Clear; + eval_helper_id.Clear; + eval_helper_PatternFieldId.Clear; + with_stack.Push(RN.Arg1); + if not SymbolTable[with_stack.Top].FinalTypeId in [typeRECORD, typeCLASS] + then + begin + CreateError(errRecordRequired, []); + break; + end; + end + else if Op = OP_END_WITH then + begin + eval_helper_name.Clear; + eval_helper_id.Clear; + eval_helper_PatternFieldId.Clear; + with_stack.Pop; + // RN.Op := OP_NOP; + end + else if Op = OP_BEGIN_SUB then + begin + sub_stack.Push(RN.Arg1); + + K := GetSymbolRec(RN.Arg1).Level; + if K > 0 then + if GetSymbolRec(K).FinalTypeId = typeHELPER then + begin + TypeId := GetSymbolRec(K).PatternId; + Id := SymbolTable.GetSelfId(RN.Arg1); + if TypeId = 0 then + RaiseError(errInternalError, []); + GetSymbolRec(Id).TypeId := TypeId; + end; + end + else if Op = OP_END_SUB then + sub_stack.Pop + + else if Op = OP_EVAL_OUTER then + begin + I1 := GetCurrSelfId(N); + I2 := SymbolTable.GetOuterThisId(RN.Arg1); + + if (I1 = 0) or (I2 = 0) then + begin + RN.Op := OP_NOP; + Records[N + 1].Op := OP_NOP; + Records[N + 2].Op := OP_NOP; + end + else + begin + + if GetSymbolRec(I1).TerminalTypeId = GetSymbolRec(I2).TerminalTypeId + then + begin + RN.Op := OP_NOP; + ReplaceId(RN.Res, I1); + end + else + begin + RN.Op := OP_FIELD; + RN.Arg1 := I1; + RN.Arg2 := NewField(StrOuterThis, GetSymbolRec(I2).TypeId, I1); + ReplaceId(RN.Res, RN.Arg2); + RN.Res := RN.Arg2; + end; + end; + end + + else if Op = OP_EVAL then + begin + if RN.Res <= Types.Count then + begin + RN.Op := OP_NOP; + continue; + end; + + if GetSymbolRec(RN.Res).Kind = KindTYPE then + begin + RN.Op := OP_NOP; + continue; + end; + + S := GetSymbolRec(RN.Res).Name; + + if GetLanguage(N) in [PASCAL_LANGUAGE, BASIC_LANGUAGE] then + begin + if StrEql(S, 'System') then + begin + S := StrPascalNamespace; + GetSymbolRec(RN.Res).Name := S; + + if NextRec(N).Op = OP_FIELD then + if NextRec(N).Arg1 = RN.Res then + begin + if StrEql(GetSymbolRec(NextRec(N).Arg2).Name, GetPrintKeyword) + then + begin + Id := NextRec(N).Res; + GetSymbolRec(RN.Res).Name := ''; + GetSymbolRec(RN.Res).Kind := KindNONE; + RN.Op := OP_NOP; + NextRec(N).Op := OP_NOP; + for J := N + 1 to Card do + begin + if Records[J].Op = OP_PUSH then + if Records[J].Res = Id then + begin + Records[J].Op := OP_PRINT_EX; + Records[J].Arg2 := 0; + Records[J].Res := 0; + end; + + if Records[J].Op = OP_CALL then + if Records[J].Arg1 = Id then + begin + Records[J].Op := OP_NOP; + Records[J].Arg2 := 0; + Records[J].Res := 0; + break; + end; + + end; + continue; + end + else if StrEql(GetSymbolRec(NextRec(N).Arg2).Name, + GetPrintlnKeyword) then + begin + Id := NextRec(N).Res; + GetSymbolRec(RN.Res).Name := ''; + GetSymbolRec(RN.Res).Kind := KindNONE; + RN.Op := OP_NOP; + NextRec(N).Op := OP_NOP; + for J := N + 1 to Card do + begin + if Records[J].Op = OP_PUSH then + if Records[J].Res = Id then + begin + Records[J].Op := OP_PRINT_EX; + Records[J].Arg2 := 0; + Records[J].Res := 0; + end; + + if Records[J].Op = OP_CALL then + if Records[J].Arg1 = Id then + begin + Records[J].Op := OP_PRINT_EX; + Records[J].Arg1 := CreateConst(typeSTRING, ''); + Records[J].Arg2 := 0; + Records[J].Res := 0; + break; + end; + end; + continue; + end + else if StrEql(GetSymbolRec(NextRec(N).Arg2).Name, 'write') then + begin + Id := NextRec(N).Res; + GetSymbolRec(RN.Res).Name := ''; + GetSymbolRec(RN.Res).Kind := KindNONE; + RN.Op := OP_NOP; + NextRec(N).Op := OP_NOP; + for J := N + 1 to Card do + begin + if Records[J].Op = OP_PUSH then + if Records[J].Res = Id then + begin + Records[J].Op := OP_PRINT; + Records[J].Arg2 := 0; + Records[J].Res := 0; + end; + + if Records[J].Op = OP_CALL then + if Records[J].Arg1 = Id then + begin + Records[J].Op := OP_NOP; + break; + end; + + end; + continue; + end + else if StrEql(GetSymbolRec(NextRec(N).Arg2).Name, 'writeln') + then + begin + Id := NextRec(N).Res; + GetSymbolRec(RN.Res).Name := ''; + GetSymbolRec(RN.Res).Kind := KindNONE; + RN.Op := OP_NOP; + NextRec(N).Op := OP_NOP; + for J := N + 1 to Card do + begin + if Records[J].Op = OP_PUSH then + if Records[J].Res = Id then + begin + Records[J].Op := OP_PRINT_EX; + Records[J].Arg2 := 0; + Records[J].Res := 0; + end; + + if Records[J].Op = OP_CALL then + if Records[J].Arg1 = Id then + begin + Records[J].Op := OP_PRINT_EX; + Records[J].Arg1 := CreateConst(typeSTRING, ''); + Records[J].Arg2 := 0; + Records[J].Res := 0; + break; + end; + end; + continue; + end; + end; + end; // System + end; + + UpperBoundId := RN.Res; + + if RN.Language = JS_LANGUAGE then + begin + + if with_stack.Count > 0 then + begin + Inc(N); + continue; + end; + + if S = 'arguments' then + begin + Id := GetSymbolRec(RN.Res).Level; + if Id > 0 then + if GetSymbolRec(Id).Kind = KindSUB then + begin + RN.Op := OP_FIELD; + RN.Arg1 := TKernel(kernel).SymbolTable.GetSelfId(Id); + RN.Arg2 := RN.Res; + GetSymbolRec(RN.Res).OwnerId := TKernel(kernel) + .SymbolTable.GetSelfId(Id); + GetSymbolRec(RN.Res).Kind := KindVAR; + + goto Next; + end; + end; + end; + + if S = '' then + begin + RN.Op := OP_NOP; + GetSymbolRec(RN.Res).Kind := KindNONE; + continue; + end; + + Upcase := GetUpcase(N); + + Id := 0; + + if block_stack.Count > 0 then + begin + Id := SymbolTable.LookUps(S, block_stack, Upcase, UpperBoundId); + if Id > 0 then + begin + GetSymbolRec(RN.Res).Name := ''; + ReplaceId(RN.Res, Id); + RN.Op := OP_NOP; + goto Next; + end; + end; + + // try to find in the with list + + if Id = 0 then + begin + RC := GetNextRec(N); + if (RC.Op = OP_SET_READ_ID) or (RC.Op = OP_SET_WRITE_ID) then + begin + I := GetSymbolRec(RN.Res).Level; + while GetSymbolRec(I).Kind <> KindTYPE do + I := GetSymbolRec(I).Level; + Id := SymbolTable.LookUp(S, I, Upcase); + end; + end; + + if Id = 0 then + begin + if GetUpcase(N) then + J := eval_helper_name.IndexOf(UpperCase(S)) + else + J := eval_helper_name.IndexOf(S); + + if J >= 0 then + begin + Id := eval_helper_id[J]; + PatternFieldId := eval_helper_PatternFieldId[J]; + + if GetSymbolRec(PatternFieldId).Kind = KindTYPE then + begin + GetSymbolRec(RN.Res).Name := ''; + ReplaceId(RN.Res, PatternFieldId); + RN.Op := OP_NOP; + goto Next; + end; + + if GetSymbolRec(PatternFieldId).Kind = KindVAR then + if GetSymbolRec(PatternFieldId).IsFinal then + begin + GetSymbolRec(RN.Res).Name := ''; + ReplaceId(RN.Res, PatternFieldId); + RN.Op := OP_NOP; + goto Next; + end; + + RN.Op := OP_FIELD; + RN.PatternFieldId := PatternFieldId; + RN.Arg1 := Id; + RN.Arg2 := RN.Res; + GetSymbolRec(RN.Res).OwnerId := Id; + GetSymbolRec(RN.Res).Kind := KindVAR; + if GetSymbolRec(RN.Res).TypeId = 0 then + GetSymbolRec(RN.Res).TypeId := + GetSymbolRec(PatternFieldId).TypeId; + + goto Next; + end; + end; + + if Id = 0 then + for J := with_stack.Count - 1 downto 0 do + begin + Id := with_stack[J]; + TypeId := SymbolTable[Id].TypeId; + + if TypeId < Types.Count then + begin + Inc(N); + goto NextTime; // for such cases as WITH TMyClass.Create DO ...... + end; + + PatternFieldId := SymbolTable.LookUp(S, TypeId, Upcase); + if PatternFieldId <> 0 then + begin + if StrEql(S, GetPrintKeyword) then + begin + if (GetSymbolRec(PatternFieldId).Kind = KindSUB) and + (GetSymbolRec(PatternFieldId).Count = 0) then + begin + RN.Op := OP_NOP; + goto Next; + end; + + // remove OP_PRINT_EX + for K := N + 1 to Card do + if Records[K].Op = OP_PRINT_EX then + begin + Records[K].Op := OP_NOP; + break; + end; + end; + + if GetUpcase(N) then + S := UpperCase(S); + if eval_helper_name.IndexOf(S) = -1 then + begin + eval_helper_name.Add(S); + eval_helper_id.Add(Id); + eval_helper_PatternFieldId.Add(PatternFieldId); + end; + + if GetSymbolRec(PatternFieldId).Kind = KindTYPE then + begin + GetSymbolRec(RN.Res).Name := ''; + ReplaceId(RN.Res, PatternFieldId); + RN.Op := OP_NOP; + goto Next; + end; + + if GetSymbolRec(PatternFieldId).Kind = KindVAR then + if GetSymbolRec(PatternFieldId).IsFinal then + begin + GetSymbolRec(RN.Res).Name := ''; + ReplaceId(RN.Res, PatternFieldId); + RN.Op := OP_NOP; + goto Next; + end; + + RN.Op := OP_FIELD; + RN.PatternFieldId := PatternFieldId; + RN.Arg1 := Id; + RN.Arg2 := RN.Res; + GetSymbolRec(RN.Res).OwnerId := Id; + GetSymbolRec(RN.Res).Kind := KindVAR; + if GetSymbolRec(RN.Res).TypeId = 0 then + GetSymbolRec(RN.Res).TypeId := + GetSymbolRec(PatternFieldId).TypeId; + + goto Next; + end + else + Id := 0; + end; + + // try to find in parameters of the sub list + + if Id = 0 then + for J := sub_stack.Count - 1 downto 0 do + begin + SubId := sub_stack[J]; + for I := 0 to SymbolTable[SubId].Count - 1 do + begin + ParamId := SymbolTable.GetParamId(SubId, I); + if Upcase then + begin + if StrEql(S, GetSymbolRec(ParamId).Name) then + begin + Id := ParamId; + break; + end; + end + else + begin + if S = GetSymbolRec(ParamId).Name then + begin + Id := ParamId; + break; + end; + end; + end; + + if Id > 0 then + begin + ReplaceId(RN.Res, Id); + RN.Op := OP_NOP; + goto Next; + end; + end; + + // try to find in the sub list + + for J := sub_stack.Count - 1 downto 0 do + begin + Id := GetDeclaredVar(S, sub_stack[J], Upcase, N); + + if Id = 0 then + begin + if Upcase then + begin + if StrEql(S, GetSymbolRec(SymbolTable.GetResultId(sub_stack[J])) + .Name) then + Id := SymbolTable.GetResultId(sub_stack[J]); + end + else + begin + if S = GetSymbolRec(SymbolTable.GetResultId(sub_stack[J])).Name + then + Id := SymbolTable.GetResultId(sub_stack[J]); + end; + end; + + if Id > 0 then + begin + ReplaceId(RN.Res, Id); + RN.Op := OP_NOP; + goto Next; + end; + end; + + if (Id = 0) and (sub_stack.Count > 0) then + // try to find nested function + begin + GetSymbolRec(RN.Res).Name := ''; + Id := SymbolTable.LookUps(S, sub_stack, Upcase, UpperBoundId); + end; + + // try to find in nested class + if RN.Language in [BASIC_LANGUAGE, JAVA_LANGUAGE] then + if Id = 0 then + if GetCurrSelfId(N) > 0 then + begin + temp_id := RN.Res; + + NS_ID := GetSymbolRec(temp_id).Level; + if NS_ID > 0 then + begin + repeat + if GetSymbolRec(NS_ID).Kind in kindSUBS then + NS_ID := GetSymbolRec(NS_ID).Level + else + break; + if NS_ID = 0 then + break; + until false; + + if NS_ID > 0 then + if GetSymbolRec(NS_ID).Kind = KindTYPE then + if GetSymbolRec(NS_ID).FinalTypeId = typeCLASS then + begin + TypeId := NS_ID; + + NS_ID := GetSymbolRec(NS_ID).Level; + if GetSymbolRec(NS_ID).Kind = KindTYPE then + if GetSymbolRec(NS_ID).FinalTypeId = typeCLASS then + begin + temp_id := SymbolTable.LookUp(S, NS_ID, Upcase); + if temp_id > 0 then + begin + + if GetSymbolRec(temp_id).Kind = KindTYPE then + begin + GetSymbolRec(RN.Res).Name := ''; + ReplaceId(RN.Res, temp_id); + RN.Op := OP_NOP; + end + else + begin + RC := TCodeRec.Create(OP_FIELD, Self); + RC.Arg1 := GetCurrSelfId(N); + RC.Res := NewField(StrOuterThis, + SymbolTable.GetOuterThisId(TypeId), RC.Arg1); + RC.Arg2 := RC.Res; + + Insert(N, RC); + + RN.Op := OP_FIELD; + RN.Arg1 := RC.Res; + RN.Arg2 := RN.Res; + GetSymbolRec(RN.Res).Name := S; + GetSymbolRec(RN.Res).OwnerId := RN.Arg1; + GetSymbolRec(RN.Res).Kind := KindVAR; + GetSymbolRec(RN.Res).TypeId := + GetSymbolRec(temp_id).TypeId; + end; + + goto Next; + end; + end; + end; + end; + end; + + NS_ID := -1; + + if (Id = 0) then + // try to find in the using list + begin + GetSymbolRec(RN.Res).Name := ''; + + Id := LookupInExtraUnitList(S); + if Id = 0 then + Id := SymbolTable.LookUpsEx(S, using_stack, NS_ID, Upcase); + + if Id = 0 then + Id := SymbolTable.LookUp(S, 0, Upcase); + end; + + if Id = 0 then + begin + if RN.Language = JS_LANGUAGE then + begin + Id := GetSymbolRec(RN.Res).Level; + if Id > 0 then + begin + if GetSymbolRec(Id).Kind = KindSUB then + begin + RN.Op := OP_FIELD; + RN.Arg1 := TKernel(kernel).SymbolTable.GetSelfId(Id); + RN.Arg2 := RN.Res; + GetSymbolRec(RN.Res).Name := S; + GetSymbolRec(RN.Res).OwnerId := TKernel(kernel) + .SymbolTable.GetSelfId(Id); + GetSymbolRec(RN.Res).Kind := KindVAR; + + goto Next; + end + else + begin + GetSymbolRec(RN.Res).Name := S; + GetSymbolRec(RN.Res).Kind := KindVAR; + GetSymbolRec(RN.Res).TypeId := typeVARIANT; + RN.Op := OP_NOP; + goto Next; + end; + end + else + begin + GetSymbolRec(RN.Res).Name := S; + GetSymbolRec(RN.Res).Kind := KindVAR; + GetSymbolRec(RN.Res).TypeId := typeVARIANT; + RN.Op := OP_NOP; + goto Next; + end; + end; + + if TKernel(kernel).InterfaceOnly then + begin + TKernel(kernel).UndeclaredIdentifiers.Add(S); + RN.Op := OP_NOP; + if Records[N + 1].Op = OP_ASSIGN_TYPE then + if Records[N + 1].Arg2 = RN.Res then + Records[N + 1].Op := OP_NOP; + if Records[N + 2].Op = OP_ASSIGN_TYPE then + if Records[N + 2].Arg2 = RN.Res then + Records[N + 2].Op := OP_NOP; + goto Next; + end; + + GetSymbolRec(RN.Res).Name := S; + if StrEql(S, 'ExitCode') then + begin + RC := TCodeRec.Create(Op, Self); + RC.Op := OP_GET_PROG; + RC.Arg1 := 0; + RC.Arg2 := 0; + RC.Res := NewTempVar(GetLevel(N), Id_Prog); + Insert(N, RC); + + Inc(N); + + RN.Op := OP_FIELD; + RN.Arg1 := RC.Res; + RN.Arg2 := RN.Res; + GetSymbolRec(RN.Res).OwnerId := RC.Res; + GetSymbolRec(RN.Res).Kind := KindVAR; + end + else if StrEql(S, GetPrintKeyword) then + begin + RN.Op := OP_NOP; + end + else if StrEql(S, GetPrintlnKeyword) then + begin + RN.Op := OP_NOP; + end + else + begin + if GetSymbolRec(RN.Res).Kind = KindLABEL then + RN.Op := OP_NOP + else + begin + CreateEvalError(S, using_stack); + end; + end; + end + else + begin + I1 := Modules.IndexOfModuleById(RN.Res); + I2 := Modules.IndexOfModuleById(Id); + + if (I1 >= 0) and (I2 >= 0) and (I1 <> I2) then + begin + with Modules[I2] do + if StrEql(LanguageName, 'Pascal') then + if not((Id >= S1) and (Id <= S2)) then + begin + GetSymbolRec(RN.Res).Name := S; + CreateEvalError(S, using_stack); + goto Next; + end; + end; + + if (Id > RN.Res) and (GetSymbolRec(Id).Kind in [KindVAR, KindCONST]) + and (I1 = I2) then + begin + if RN.Language = JS_LANGUAGE then + begin + ReplaceId(RN.Res, Id); + RN.Op := OP_NOP; + goto Next; + end; + + Id := SymbolTable.LookUpsExcept(S, using_stack, NS_ID, Upcase); + if Id = 0 then + begin + GetSymbolRec(RN.Res).Name := S; + CreateEvalError(S, using_stack); + goto Next; + end; + end; + + B1 := (SymbolTable[Id].Kind = KindSUB) and + (SymbolTable[Id].FinalTypeId <> typeVOID); + + B2 := false; + for J := N + 1 to Card do + begin + RJ := Records[J]; + if RJ.Op = OP_END_MODULE then + break; + + if (RJ.Op = OP_ASSIGN) and (RJ.Arg2 = RN.Res) then + if GetSymbolRec(RJ.Arg1).FinalTypeId = typePROC then + begin + B2 := true; + break; + end; + + if (RJ.Op = OP_CALL) and (RJ.Arg1 = RN.Res) then + begin + B2 := true; + break; + end; + end; + + if B1 and (not B2) and (RN.Language <> JS_LANGUAGE) and (not IsExport) + then + begin + RN.Op := OP_CALL; + RN.Arg1 := Id; + RN.Arg2 := 0; + + if RN.Res > 0 then + begin + GetSymbolRec(RN.Res).Kind := KindVAR; + GetSymbolRec(RN.Res).TypeId := GetSymbolRec(RN.Arg1).TypeId; + end; + end + else + begin + ReplaceId(RN.Res, Id); + RN.Op := OP_NOP; + end; + end; + + end + else if Op = OP_FIELD then + begin + Arg1 := RN.Arg1; + Arg2 := RN.Arg2; + K1 := GetSymbolRec(Arg1).Kind; + + if K1 = KindNAMESPACE then + begin + Id := SymbolTable.LookUp(GetSymbolRec(Arg2).Name, Arg1, GetUpcase(N)); + if Id = 0 then + if Arg1 = H_PascalNamespace then + Id := SymbolTable.LookUp(GetSymbolRec(Arg2).Name, 0, + GetUpcase(N)); + + if Id <> 0 then + begin + GetSymbolRec(Id).NSOwnerId := Arg1; + + if (GetSymbolRec(Id).Kind in kindSUBS) and + (GetSymbolRec(Id).Count = 0) and (not CallExpected(Arg2)) then + begin + RN.Op := OP_CALL; + RN.Arg1 := Id; + RN.Arg2 := 0; + RN.Res := Arg2; + GetSymbolRec(RN.Res).TypeId := GetSymbolRec(Id).TypeId; + end + else + begin + ReplaceId(Arg2, Id); + GetSymbolRec(Arg2).Name := ''; + GetSymbolRec(Arg2).Kind := KindNONE; + + RN.Op := OP_NOP; + end; + end; + end + else if K1 = KindTYPE then + begin + Id := SymbolTable.LookUp(GetSymbolRec(Arg2).Name, Arg1, GetUpcase(N)); + if Id > 0 then + if GetSymbolRec(Id).Kind = KindTYPE then + begin + ReplaceId(Arg2, Id); + RN.Op := OP_NOP; + end; + end + else + begin + TypeId := GetSymbolRec(Arg1).TerminalTypeId; + Id := SymbolTable.LookUp(GetSymbolRec(Arg2).Name, TypeId, + GetUpcase(N)); + if Id > 0 then + if GetSymbolRec(Id).Kind in [KindTYPE_FIELD, KindPROP] then + begin + GetSymbolRec(Arg2).TypeId := GetSymbolRec(Id).TypeId; + end; + end; + end + + // set types + else if Op = OP_ASSIGN_TYPE then + begin + if GetSymbolRec(RN.Arg2).Kind <> KindTYPE then + begin + S := GetSymbolRec(RN.Arg2).Name; + + if TKernel(kernel).InterfaceOnly then + begin + TKernel(kernel).UndeclaredIdentifiers.Add(S); + RN.Op := OP_NOP; + goto Next; + end; + + CreateError(errUndeclaredType, [S]); + + SymbolTable.AddTypes(S, TKernel(kernel).UndeclaredTypes, + TKernel(kernel).Errors.Count - 1, true); + end; + + GetSymbolRec(RN.Arg1).TypeId := RN.Arg2; + RN.Op := OP_NOP; + end + else if Op = OP_ASSIGN_THE_SAME_TYPE then + begin + GetSymbolRec(RN.Arg1).TypeId := GetSymbolRec(RN.Arg2).TypeId; + RN.Op := OP_NOP; + end + else if Op = OP_ASSIGN_TYPE_ALIAS then + begin + if GetSymbolRec(RN.Arg2).Kind <> KindTYPE then + begin + S := GetSymbolRec(RN.Arg2).Name; + + if TKernel(kernel).InterfaceOnly then + begin + TKernel(kernel).UndeclaredIdentifiers.Add(S); + RN.Op := OP_NOP; + goto Next; + end; + + CreateError(errUndeclaredType, [S]); + end; + + GetSymbolRec(RN.Arg1).PatternId := RN.Arg2; + RN.Op := OP_NOP; + end + else if Op = OP_CREATE_POINTER_TYPE then + begin + if GetSymbolRec(RN.Arg2).Kind <> KindTYPE then + begin + S := GetSymbolRec(RN.Arg2).Name; + + if TKernel(kernel).InterfaceOnly then + begin + TKernel(kernel).UndeclaredIdentifiers.Add(S); + RN.Op := OP_NOP; + goto Next; + end; + + CreateError(errUndeclaredType, [S]); + end; + + GetSymbolRec(RN.Arg1).PatternId := RN.Arg2; + RN.Op := OP_NOP; + end + else if Op = OP_CREATE_CLASSREF_TYPE then + begin + if GetSymbolRec(RN.Arg2).Kind <> KindTYPE then + begin + S := GetSymbolRec(RN.Arg2).Name; + + if TKernel(kernel).InterfaceOnly then + begin + TKernel(kernel).UndeclaredIdentifiers.Add(S); + RN.Op := OP_NOP; + goto Next; + end; + + CreateError(errUndeclaredType, [S]); + end; + + GetSymbolRec(RN.Arg1).PatternId := RN.Arg2; + RN.Op := OP_NOP; + end + else if Op = OP_BEGIN_HELPER_TYPE then + begin + if GetSymbolRec(RN.Arg2).Kind <> KindTYPE then + begin + S := GetSymbolRec(RN.Arg2).Name; + + if TKernel(kernel).InterfaceOnly then + begin + TKernel(kernel).UndeclaredIdentifiers.Add(S); + RN.Op := OP_NOP; + goto Next; + end; + + CreateError(errUndeclaredType, [S]); + end; + + GetSymbolRec(RN.Arg1).PatternId := RN.Arg2; + if SymbolTable.TypeHelpers.Keys.IndexOf(RN.Arg1) = -1 then + SymbolTable.TypeHelpers.Add(RN.Arg1, RN.Arg2); + end + else if Op = OP_CREATE_DYNAMIC_ARRAY_TYPE then + begin + if GetSymbolRec(RN.Arg2).Kind <> KindTYPE then + begin + S := GetSymbolRec(RN.Arg2).Name; + + if TKernel(kernel).InterfaceOnly then + begin + TKernel(kernel).UndeclaredIdentifiers.Add(S); + RN.Op := OP_NOP; + goto Next; + end; + + CreateError(errUndeclaredType, [S]); + end; + + GetSymbolRec(RN.Arg1).PatternId := RN.Arg2; + RN.Op := OP_NOP; + end + else if Op = OP_ADD_ANCESTOR then + begin + if GetSymbolRec(RN.Arg2).Kind <> KindTYPE then + begin + CreateError(errClassTypeRequired, []); + end; + + GetSymbolRec(RN.Arg1).AncestorId := RN.Arg2; + // RN.Op := OP_NOP; + end + else if Op = OP_ADD_INTERFACE then + begin + if RN.Arg2 = 0 then + RN.Arg2 := SymbolTable.LookupAnonymousInterface(RN.Arg1); + if GetSymbolRec(RN.Arg2).Kind <> KindTYPE then + goto Next; + + SymbolTable.RegisterSupportedInterface(RN.Arg1, + GetSymbolRec(RN.Arg2).Name, IUnknown); + RN.Op := OP_NOP; + end + else if Op = OP_ADDRESS then + begin + if not(GetSymbolRec(RN.Arg1).Kind in [KindVAR, KindSUB]) then + goto Next; + + TypeId := TKernel(kernel).SymbolTable.AddPointerType + (GetSymbolRec(RN.Arg1).TypeId).Id; + GetSymbolRec(RN.Res).TypeId := TypeId; + end + else if Op = OP_TERMINAL then + begin + TypeId := GetSymbolRec(RN.Arg1).TypeId; + TypeId := GetSymbolRec(TypeId).PatternId; + GetSymbolRec(RN.Res).TypeId := TypeId; + GetSymbolRec(RN.Res).ByRef := true; + end + else if Op = OP_SIZEOF then + begin + GetSymbolRec(RN.Res).TypeId := typeINTEGER; + end + else if Op = OP_FIND_CONSTRUCTOR then + begin + TypeId := RN.Arg1; + if RN.Language = JS_LANGUAGE then + if GetSymbolRec(TypeId).Kind = KindTYPE then + begin + Id := TKernel(kernel).SymbolTable.FindConstructorId(TypeId); + if Id > 0 then + begin + TypeId := GetSymbolRec(Id).TerminalTypeId; + if Records[N - 1].Op = OP_LVALUE then + begin + Id := Records[N - 1].Arg1; + if GetSymbolRec(Id).TypeId = 0 then + GetSymbolRec(Id).TypeId := TypeId; + end; + + end; + end; + end + else if Op = OP_CALL then + begin + if RN.Res > 0 then + if GetSymbolRec(RN.Arg1).TypeId > 0 then + if GetSymbolRec(RN.Res).TypeId = 0 then + begin + GetSymbolRec(RN.Res).TypeId := GetSymbolRec(RN.Arg1).TypeId; + end; + end; + + Next: + + Inc(N); + end; // while + + finally + FreeAndNil(using_stack); + FreeAndNil(block_stack); + FreeAndNil(with_stack); + FreeAndNil(sub_stack); + FreeAndNil(eval_helper_name); + FreeAndNil(eval_helper_id); + FreeAndNil(eval_helper_PatternFieldId); + + end; +end; + +procedure TCode.UpdateDefaultConstructors; +var + R, RC: TCodeRec; + SubId, ClassId, AncestorClassId, ConstructorId: Integer; + SymbolTable: TSymbolTable; + I, ParamId, ParamTypeId, Res: Integer; + S: String; + SR: TSymbolRec; + ByRef, IsConst: Boolean; + value: Variant; +begin + SymbolTable := TKernel(kernel).SymbolTable; + + N := Card; + while N > 1 do + begin + R := Records[N]; + if R.Op = OP_UPDATE_DEFAULT_CONSTRUCTOR then + begin + SubId := R.Arg1; + Res := R.Res; + + if not GetSymbolRec(SubId).IsDefault then + RaiseError(errInternalError, []); + + R.Op := OP_NOP; + + ClassId := GetSymbolRec(SubId).Level; + + AncestorClassId := GetSymbolRec(ClassId).AncestorId; + if GetSymbolRec(AncestorClassId).FinalTypeId = typeINTERFACE then + begin + SymbolTable.RegisterSupportedInterface(ClassId, AncestorClassId); + + AncestorClassId := H_TInterfacedObject; + GetSymbolRec(ClassId).AncestorId := H_TInterfacedObject; + end; + + repeat + ConstructorId := SymbolTable.FindConstructorId(AncestorClassId); + + if ConstructorId > 0 then + begin + if GetSymbolRec(ConstructorId).IsDefault then + AncestorClassId := GetSymbolRec(AncestorClassId).AncestorId + else // ok + break; + end + else + AncestorClassId := GetSymbolRec(AncestorClassId).AncestorId; + + until false; + + GetSymbolRec(SubId).Count := GetSymbolRec(ConstructorId).Count; + + for I := 0 to GetSymbolRec(SubId).Count - 1 do + begin + ParamId := SymbolTable.GetParamId(ConstructorId, I); + SR := GetSymbolRec(ParamId); + ParamTypeId := SR.TypeId; + S := SR.Name; + ByRef := SR.ByRef; + value := SR.value; + IsConst := SR.IsConst; + + ParamId := NewTempVar(SubId, ParamTypeId); + SR := GetSymbolRec(ParamId); + SR.Param := true; + SR.Name := S; + SR.ByRef := ByRef; + SR.value := value; + SR.IsConst := IsConst; + + RC := TCodeRec.Create(OP_PUSH, Self); + RC.Arg1 := ParamId; + RC.Arg2 := I; + RC.Res := Res; // ImmConstructorId; + + Insert(N, RC); + Inc(N); + end; + + end; + Dec(N); + end; +end; + +procedure TCode.OperAddress; +var + TypeId: Integer; +begin + if not(GetSymbolRec(Records[N].Arg1).Kind in [KindVAR, KindSUB]) then + CreateError(errVariableRequired, []); + + if GetSymbolRec(Records[N].Res).TypeId = 0 then + begin + TypeId := TKernel(kernel).SymbolTable.AddPointerType + (GetSymbolRec(Records[N].Arg1).TypeId).Id; + GetSymbolRec(Records[N].Res).TypeId := TypeId; + end; +end; + +procedure TCode.OperEval; +var + SubId, ParamId, J, K, Id, Op, TypeId, PatternFieldId: Integer; + using_stack, with_stack, sub_stack, block_stack: TIntegerStack; + SymbolTable: TSymbolTable; + Upcase: Boolean; + S: String; + Modules: TModuleList; + I1, I2: Integer; + B1, B2: Boolean; + I: Integer; + RC: TCodeRec; +begin + SymbolTable := TKernel(kernel).SymbolTable; + Modules := TKernel(kernel).Modules; + + using_stack := TIntegerStack.Create; + block_stack := TIntegerStack.Create; + with_stack := TIntegerStack.Create; + sub_stack := TIntegerStack.Create; + + try + for I := 1 to N do + begin + Op := Records[I].Op; + + if Op = OP_BEGIN_USING then + using_stack.Push(Records[I].Arg1) + else if Op = OP_END_USING then + using_stack.Pop + else if Op = OP_BEGIN_MODULE then + using_stack.Clear + else if Op = OP_END_MODULE then + using_stack.Clear + + else if Op = OP_BEGIN_BLOCK then + block_stack.Push(Records[I].Arg1) + else if Op = OP_END_BLOCK then + block_stack.Pop + + else if Op = OP_BEGIN_WITH then + begin + with_stack.Push(Records[I].Arg1); + end + else if Op = OP_END_WITH then + begin + with_stack.Pop; + end + else if Op = OP_BEGIN_SUB then + sub_stack.Push(Records[I].Arg1) + else if Op = OP_END_SUB then + sub_stack.Pop + end; + + S := GetSymbolRec(Records[N].Res).Name; + + Upcase := GetUpcase(N); + + Id := 0; + + // try to find in the with list + + if Id = 0 then + for J := with_stack.Count - 1 downto 0 do + begin + Id := with_stack[J]; + TypeId := SymbolTable[Id].TypeId; + + PatternFieldId := SymbolTable.LookUp(S, TypeId, Upcase); + if PatternFieldId <> 0 then + begin + Records[N].Op := OP_FIELD; + Records[N].PatternFieldId := PatternFieldId; + Records[N].Arg1 := Id; + Records[N].Arg2 := Records[N].Res; + GetSymbolRec(Records[N].Res).OwnerId := Id; + GetSymbolRec(Records[N].Res).Kind := KindVAR; + if GetSymbolRec(Records[N].Res).TypeId = 0 then + GetSymbolRec(Records[N].Res).TypeId := + GetSymbolRec(PatternFieldId).TypeId; + Dec(N); + Exit; + end + else + Id := 0; + end; + + // try to find in parameters of the sub list + + if Id = 0 then + for J := sub_stack.Count - 1 downto 0 do + begin + SubId := sub_stack[J]; + for K := 0 to SymbolTable[SubId].Count - 1 do + begin + ParamId := SymbolTable.GetParamId(SubId, K); + if Upcase then + begin + if StrEql(S, GetSymbolRec(ParamId).Name) then + begin + Id := ParamId; + break; + end; + end + else + begin + if S = GetSymbolRec(ParamId).Name then + begin + Id := ParamId; + break; + end; + end; + end; + + if Id > 0 then + begin + ReplaceId(Records[N].Res, Id); + Records[N].Op := OP_NOP; + Exit; + end; + end; + + // try to find in the sub list + + if Id = 0 then + for J := sub_stack.Count - 1 downto 0 do + begin + Id := GetDeclaredVar(S, sub_stack[J], Upcase, N); + + if Id = 0 then + begin + if Upcase then + begin + if StrEql(S, GetSymbolRec(SymbolTable.GetResultId(sub_stack[J])) + .Name) then + Id := SymbolTable.GetResultId(sub_stack[J]); + end + else + begin + if S = GetSymbolRec(SymbolTable.GetResultId(sub_stack[J])).Name then + Id := SymbolTable.GetResultId(sub_stack[J]); + end; + end; + + if Id > 0 then + begin + ReplaceId(Records[N].Res, Id); + Records[N].Op := OP_NOP; + Exit; + end; + end; + + if (Id = 0) and (sub_stack.Count > 0) then + // try to find nested function + begin + GetSymbolRec(Records[N].Res).Name := ''; + Id := SymbolTable.LookUps(S, sub_stack, Upcase); + end; + + if (Id = 0) then + // try to find in the using list + begin + GetSymbolRec(Records[N].Res).Name := ''; + Id := SymbolTable.LookUps(S, using_stack, Upcase); + end; + + if Id = 0 then + begin + GetSymbolRec(Records[N].Res).Name := S; + + if StrEql(S, 'ExitCode') then + begin + RC := TCodeRec.Create(OP_GET_PROG, Self); + RC.Arg1 := 0; + RC.Arg2 := 0; + RC.Res := NewTempVar(GetLevel(N), Id_Prog); + Insert(N, RC); + + Inc(N); + + Records[N].Op := OP_FIELD; + Records[N].Arg1 := RC.Res; + Records[N].Arg2 := Records[N].Res; + GetSymbolRec(Records[N].Res).OwnerId := RC.Res; + GetSymbolRec(Records[N].Res).Kind := KindVAR; + end + else + begin + if GetLanguage(N) = JS_LANGUAGE then + begin + Records[N].Op := OP_FIND_CONTEXT; + Records[N].Arg1 := CreateConst(typeSTRING, S); + Records[N].Arg2 := CreateVariantVar(GetLevel(N)); + GetSymbolRec(Records[N].Res).Kind := KindVAR; + GetSymbolRec(Records[N].Res).TypeId := typeVARIANT; + + GetSymbolRec(Records[N].Res).Name := '@'; + + RC := TCodeRec.Create(OP_DECLARE_TEMP_VAR, Self); + RC.Arg1 := GetLevel(N); + RC.Arg2 := Records[N].Res; + RC.Res := 0; + Insert(N, RC); + + Inc(N); + + Exit; + end; + + CreateEvalError(S, using_stack); + end; + end + else + begin + + if GetSymbolRec(Id).Kind = KindVAR then + if GetSymbolRec(Id).TypeId <> 0 then + if GetLanguage(N) = JS_LANGUAGE then + begin + GetSymbolRec(Records[N].Res).Name := S; + begin + Records[N].Op := OP_FIND_CONTEXT; + Records[N].Arg1 := CreateConst(typeSTRING, S); + Records[N].Arg2 := Id; + GetSymbolRec(Records[N].Res).Kind := KindVAR; + GetSymbolRec(Records[N].Res).TypeId := typeVARIANT; + GetSymbolRec(Records[N].Res).Name := '@'; + + RC := TCodeRec.Create(OP_DECLARE_TEMP_VAR, Self); + RC.Arg1 := GetLevel(N); + RC.Arg2 := Records[N].Res; + RC.Res := 0; + Insert(N, RC); + + Inc(N); + + Exit; + end; + end; + + I1 := Modules.IndexOfModuleById(Records[N].Res); + I2 := Modules.IndexOfModuleById(Id); + + if (I1 >= 0) and (I2 >= 0) and (I1 <> I2) then + begin + with Modules[I2] do + if not((Id >= S1) and (Id <= S2)) then + begin + GetSymbolRec(Records[N].Res).Name := S; + CreateError(errUndeclaredIdentifier, [S]); + Exit; + end; + end; + + if (Id > Records[N].Res) and + (GetSymbolRec(Id).Kind in [KindVAR, KindCONST]) and (I1 = I2) then + begin + GetSymbolRec(Records[N].Res).Name := S; + CreateError(errUndeclaredIdentifier, [S]); + Exit; + end; + + B1 := (SymbolTable[Id].Kind = KindSUB) and (SymbolTable[Id].Count = 0) and + (SymbolTable[Id].FinalTypeId <> typeVOID); + + B2 := false; + for J := N + 1 to Card do + if (Records[J].Op = OP_CALL) and (Records[J].Arg1 = Records[N].Res) then + begin + B2 := true; + break; + end; + + if B1 and (not B2) then + begin + Records[N].Op := OP_CALL; + Records[N].Arg1 := Id; + Records[N].Arg2 := 0; + + if Records[N].Res > 0 then + begin + GetSymbolRec(Records[N].Res).Kind := KindVAR; + GetSymbolRec(Records[N].Res).TypeId := + GetSymbolRec(Records[N].Arg1).TypeId; + end; + Dec(N); + end + else + begin + ReplaceId(Records[N].Res, Id); + Records[N].Op := OP_NOP; + end; + end; + + finally + FreeAndNil(using_stack); + FreeAndNil(block_stack); + FreeAndNil(with_stack); + FreeAndNil(sub_stack); + end; +end; + +procedure TCode.OperImplements; +begin + Records[N].Op := OP_NOP; +end; + +procedure TCode.OperPushContext; +begin + context_list.Push(Records[N].Arg1); +end; + +procedure TCode.OperPopContext; +begin + context_list.Pop; +end; + +procedure TCode.OperEvalConstructor; +var + SubId, ClassId: Integer; +begin + ClassId := Records[N].Arg1; + if GetSymbolRec(ClassId).Kind <> KindTYPE then + CreateError(errClassTypeExpected, []); + if GetSymbolRec(ClassId).FinalTypeId <> typeCLASS then + CreateError(errClassTypeExpected, []); + SubId := TKernel(kernel).SymbolTable.FindConstructorIdEx(ClassId); + ReplaceId(Records[N].Res, SubId); + Records[N].Op := OP_NOP; + + Records[N].Op := OP_PUSH_CLASSREF; + Records[N].Arg1 := ClassId + 1; + Records[N].Arg2 := 0; + Records[N].Res := SubId; +end; + +procedure TCode.OperEvalInherited; +var + Op, Res, I, SubId, AncestorClassId, T, L, CurrSubId: Integer; + S: String; + RC, RN: TCodeRec; + ncase: Integer; + ReadProp: Boolean; +begin + S := GetSymbolRec(Records[N].Arg1).Name; + + CurrSubId := Records[N].Arg1; + ncase := 1; + if not(GetSymbolRec(CurrSubId).Kind in kindSUBS) then + begin + CurrSubId := GetSymbolRec(CurrSubId).Level; + ncase := 2; + end + else + begin + I := N; + while Records[I].Op <> OP_INIT_SUB do + Dec(I); + CurrSubId := Records[I].Arg1; + end; + + L := GetSymbolRec(CurrSubId).Level; + T := GetSymbolRec(L).FinalTypeId; + if T <> typeCLASS then + begin + CreateError(errThisFormOfMethodCallOnlyAllowedInMethodsOfDerivedTypes, []); + Exit; + end; + AncestorClassId := GetSymbolRec(L).AncestorId; + + SubId := 0; + + if S = '' then + begin + if GetSymbolRec(CurrSubId).Kind = KindCONSTRUCTOR then + begin + SubId := TKernel(kernel).SymbolTable.FindConstructorIdEx(AncestorClassId); + GetSymbolRec(CurrSubId).Name := 'Create'; + end + else if GetSymbolRec(CurrSubId).Kind = KindDESTRUCTOR then + begin + SubId := TKernel(kernel).SymbolTable.FindDestructorIdEx(AncestorClassId); + GetSymbolRec(CurrSubId).Name := 'Destroy'; + end + else + RaiseError(errInternalError, []); + end + else + begin + SubId := TKernel(kernel).SymbolTable.LookUp(S, AncestorClassId, + GetUpcase(N)); + end; + + if SubId = 0 then + begin + CreateError(errUndeclaredIdentifier, [S]); + Exit; + end; + + // if GetSymbolRec(SubId).Kind = KindDESTRUCTOR then + // SubId := Id_DestroyInherited; + + if GetSymbolRec(SubId).Kind = KindPROP then + begin + ReadProp := false; + for I := N downto GetStmt(N) do + if Records[I].Op = OP_LVALUE then + ReadProp := true; + + if ReadProp then + begin + SubId := TKernel(kernel).SymbolTable[SubId].ReadId; + if SubId = 0 then + RaiseError(errCannotReadWriteOnlyProperty, [S]); + end + else + begin + SubId := TKernel(kernel).SymbolTable[SubId].WriteId; + if SubId = 0 then + RaiseError(errCannotAssignToReadOnlyProperty, [S]); + end; + end; + + AncestorClassId := GetSymbolRec(SubId).Level; + + if GetSymbolRec(SubId).OverCount = 0 then + NoOverloadSearch := true; + + if Records[N - 1].Op = OP_PUSH_CLASSREF then + begin + Records[N - 1].Op := OP_PUSH_INSTANCE; + Records[N - 1].Res := SubId; + Records[N - 1].CodeRecTag := TAG_DISCARD_VIRTUAL_CALL; + end + else if Records[N - 1].Op = OP_PUSH_INSTANCE then + begin + Records[N - 1].Res := SubId; + Records[N - 1].CodeRecTag := TAG_DISCARD_VIRTUAL_CALL; + end; + + Records[N].Op := OP_NOP; + Res := Records[N].Res; + GetSymbolRec(Res).Kind := KindNONE; + + I := N + 1; + + while I < Card do + begin + Op := Records[I].Op; + + if (Op = OP_PUSH) and (Records[I].Res = Res) then + Records[I].Res := SubId + else if (Op = OP_PUSH_INSTANCE) and (Records[I].Res = Res) then + Records[I].Res := SubId + else if (Op = OP_PUSH_CLASSREF) and (Records[I].Res = Res) then + Records[I].Res := SubId; + + if Op = OP_CALL then + if Records[I].Arg1 = Res then + begin + Records[I].IsStatic := true; + Records[I].Arg1 := SubId; + + if ncase = 2 then + begin + if GetSymbolRec(SubId).IsSharedMethod then + begin + RC := TCodeRec.Create(OP_PUSH_CLASSREF, Self); + RC.CodeRecTag := TAG_DISCARD_VIRTUAL_CALL; + RC.Arg1 := AncestorClassId + 1; + RC.Arg2 := 0; + RC.Res := SubId; + Insert(N, RC); + end + else if GetSymbolRec(SubId).Kind = KindTYPE_FIELD then + begin + Records[I].Op := OP_NOP; + + RN := Records[I]; + + RN.Op := OP_FIELD; + RN.Arg1 := GetCurrSelfId(N); + RN.Arg2 := RN.Res; + GetSymbolRec(RN.Res).Name := GetSymbolRec(SubId).Name; + GetSymbolRec(RN.Res).TypeId := GetSymbolRec(SubId).TypeId; + end + else + begin + RC := TCodeRec.Create(OP_PUSH_INSTANCE, Self); + RC.CodeRecTag := TAG_DISCARD_VIRTUAL_CALL; + RC.Arg1 := TKernel(kernel).SymbolTable.GetSelfId(CurrSubId); + RC.Arg2 := 0; + RC.Res := SubId; + Insert(N, RC); + + if ((GetSymbolRec(SubId).Kind = KindCONSTRUCTOR) and + GetSymbolRec(SubId).Host) or + ((GetSymbolRec(SubId).Kind = KindSUB) and + (GetSymbolRec(SubId).IsSharedMethod)) then + begin + Inc(I); + + Records[I].Res := 0; + + RC := TCodeRec.Create(OP_UPDATE_INSTANCE, Self); + RC.Arg1 := TKernel(kernel).SymbolTable.GetSelfId(CurrSubId); + RC.Arg2 := 0; + RC.Res := 0; + Insert(I + 1, RC); + end; + end; + + Exit; + end; + + if ((GetSymbolRec(SubId).Kind = KindCONSTRUCTOR) and GetSymbolRec(SubId) + .Host) or ((GetSymbolRec(SubId).Kind = KindSUB) and + (GetSymbolRec(SubId).IsSharedMethod)) then + begin + Records[I].Res := 0; + + RC := TCodeRec.Create(OP_UPDATE_INSTANCE, Self); + RC.Arg1 := TKernel(kernel).SymbolTable.GetSelfId(CurrSubId); + RC.Arg2 := 0; + RC.Res := 0; + Insert(I + 1, RC); + end + else if GetSymbolRec(SubId).Kind = KindDESTRUCTOR then + begin + RC := TCodeRec.Create(OP_CLEAR_EDX, Self); + RC.Arg1 := 0; + RC.Arg2 := 0; + RC.Res := 0; + Insert(I, RC); + end; + + Exit; + end; + + Inc(I); + end; + + RN := Records[N]; + + RN.Op := OP_FIELD; + RN.Arg1 := GetCurrSelfId(N); + RN.Arg2 := RN.Res; + GetSymbolRec(RN.Res).TypeId := GetSymbolRec(SubId).TypeId; + GetSymbolRec(RN.Res).PatternId := SubId; + GetSymbolRec(RN.Res).ByRef := true; +end; + +procedure TCode.CreateUsingList(J: Integer); +var + R: TCodeRec; +begin + using_list.Clear; + while J > 1 do + begin + R := Records[J]; + if R.Op = OP_BEGIN_MODULE then + Exit; + if R.Op = OP_BEGIN_USING then + if R.Arg1 > 0 then + using_list.Add(R.Arg1); + Dec(J); + end; +end; + +procedure TCode.CheckTypes; + + procedure ProcessAnotherModules; + var + Op: Integer; + begin + repeat + Inc(N); + Op := Records[N].Op; + until Op = OP_END_MODULE; + if N >= Card then + Exit; + repeat + Inc(N); + Op := Records[N].Op; + if IsValidOP(Op) then + ProcList[-Op]; + until N >= Card; + end; + +var + Op, I, J, K: Integer; + M: TModule; + LoadOrder: TIntegerList; + HasExtraByteCode: Boolean; + HasInterfaceSection: Boolean; +begin + LoadOrder := TKernel(kernel).Modules.LoadOrder; + + // process interface sections + for I := 0 to LoadOrder.Count - 1 do + begin + J := LoadOrder[I]; + M := TKernel(kernel).Modules[J]; + + M.Recalc; + + // if M.LanguageName = strJavaScriptLanguage then + // continue; + + HasInterfaceSection := false; + for K := M.P1 to M.P2 do + if Records[K].Op = OP_END_INTERFACE_SECTION then + begin + HasInterfaceSection := true; + break; + end; + + if not HasInterfaceSection then + continue; + + Op := 0; + + N := M.P1 - 1; + repeat + Inc(N); + if N > Card then + break; + + Op := Records[N].Op; + + if IsValidOP(Op) then + ProcList[-Op]; + + if HasError then + begin + if TKernel(kernel).SignCodeCompletion then + ProcessAnotherModules; + Exit; + end; + until Op = OP_END_INTERFACE_SECTION; + end; + + // process implementation sections + for I := 0 to LoadOrder.Count - 1 do + begin + J := LoadOrder[I]; + M := TKernel(kernel).Modules[J]; + + M.Recalc; + + N := M.P2; + if N = 0 then + N := 1; + + CreateUsingList(N); + + Op := Records[N].Op; + repeat + Inc(N); + if N > Card then + break; + + Op := Records[N].Op; + if IsValidOP(Op) then + ProcList[-Op] + else + begin + // RaiseError(errInternalError, []); + end; + + if HasError then + begin + if TKernel(kernel).SignCodeCompletion then + ProcessAnotherModules; + Exit; + end; + until Op = OP_END_MODULE; + end; + + HasExtraByteCode := false; + + for I := N + 1 to Card do + if Records[I].Op = OP_EXTRA_BYTECODE then + begin + N := I; + HasExtraByteCode := true; + break; + end; + + if not HasExtraByteCode then + Exit; + + repeat + Inc(N); + if N > Card then + break; + + Op := Records[N].Op; + if IsValidOP(Op) then + ProcList[-Op] + else + begin + RaiseError(errInternalError, []); + end; + + if HasError then + Exit; + until false; +end; + +function TCode.IsValidOP(Op: Integer): Boolean; +begin + Op := -Op; + result := (Op >= 0) and (Op < System.Length(ProcList)); +end; + +procedure TCode.CreateError(const Message: string; params: array of Const); +begin + TKernel(kernel).CreateError(Message, params); +end; + +procedure TCode.RaiseError(const Message: string; params: array of Const); +begin + TKernel(kernel).RaiseError(Message, params); +end; + +function TCode.HasError: Boolean; +begin + result := TKernel(kernel).HasError; +end; + +function TCode.GetModule(I: Integer): TModule; +begin + if I <= 0 then + result := nil + else + result := TKernel(kernel).Modules[Records[I].ModuleNum]; +end; + +function TCode.GetSourceLineNumber(I: Integer): Integer; +begin + result := 0; + if I <= 0 then + Exit; + while Records[I].Op <> OP_SEPARATOR do + begin + Dec(I); + if I <= 0 then + Exit; + end; + result := Records[I].Arg2; +end; + +function TCode.GetCurrSourceLineNumber: Integer; +begin + result := GetSourceLineNumber(N); +end; + +function TCode.GetLinePos(I: Integer): Integer; +begin + result := 0; + if I <= 0 then + Exit; + while Records[I].Op <> OP_SEPARATOR do + begin + if Records[I].LinePos >= 0 then + begin + result := Records[I].LinePos; + Exit; + end; + + Dec(I); + if I <= 0 then + Exit; + end; +end; + +function TCode.GetSourceLine(I: Integer): String; +var + Lines: TStringList; + K: Integer; +begin + result := ''; + if I <= 0 then + Exit; + while Records[I].Op <> OP_SEPARATOR do + begin + Dec(I); + if I <= 0 then + Exit; + end; + Lines := GetModule(I).Lines; + K := Records[I].Arg2; + if K < Lines.Count then + result := Lines[K] + else + result := ''; +end; + +function TCode.GetIncludedFileName(I: Integer): String; +var + M: TModule; +begin + result := ''; + if I <= 0 then + Exit; + repeat + Dec(I); + if I <= 0 then + Exit; + if Records[I].Op = OP_BEGIN_MODULE then + Exit; + if Records[I].Op = OP_END_INCLUDED_FILE then + Exit; + if Records[I].Op = OP_BEGIN_INCLUDED_FILE then + begin + M := GetModule(I); + I := Records[I].Arg1; + if I < M.IncludedFiles.Count then + result := M.IncludedFiles[I]; + Exit; + end; + until false; +end; + +procedure TCode.ProcessSizeOf; + + function GetMemExpected: Boolean; + var + I, Op: Integer; + begin + result := false; + for I := N + 1 to Card do + begin + Op := Records[I].GenOp; + if Op = OP_STMT then + break; + if Op = OP_CALL then + if StrEql(GetSymbolRec(Records[I].Arg1).Name, 'GetMem') then + begin + result := true; + Exit; + end; + end; + end; + +var + R: TCodeRec; + ConstId: Integer; + SZ, T: Integer; + SymbolRec: TSymbolRec; +begin + N := 1; + while N < Card do + begin + R := Records[N]; + if R.Op = OP_SIZEOF then + begin + SymbolRec := GetSymbolRec(R.Arg1); + + if SymbolRec.Kind = KindCONST then + begin +{$IFNDEF PAXARM} + if SymbolRec.HasPAnsiCharType then + SZ := System.Length(SymbolRec.value) + 1 + else +{$ENDIF} + if SymbolRec.HasPWideCharType then + SZ := System.Length(SymbolRec.value) * 2 + 1 + else + SZ := SymbolRec.Size; + end + else + begin + if (GetSymbolRec(R.Arg1).FinalTypeId = typePOINTER) and GetMemExpected + then + begin + T := GetSymbolRec(GetSymbolRec(R.Arg1).TerminalTypeId).PatternId; + SZ := GetSymbolRec(T).Size; + end + else + SZ := GetSymbolRec(R.Arg1).PtrSize; + end; + + ConstId := CreateConst(typeINTEGER, SZ, 0); + R.Op := OP_ASSIGN_INT_I; + R.Arg1 := R.Res; + R.Arg2 := ConstId; + end; + Inc(N); + end; +end; + +procedure TCode.ChangeOrderOfActualParams; +var + L: TCodeRecList; + need_relocate: Boolean; + J, SubId, TrueSubId, ParamId: Integer; + R: TCodeRec; + SymbolTable: TSymbolTable; + K, N1, T: Integer; +begin + SymbolTable := TKernel(kernel).SymbolTable; + L := TCodeRecList.Create; + + try + + N := Card + 1; + repeat + Dec(N); + if N <= 1 then + break; + + R := Records[N]; + if R.Op = OP_CALL then + begin + SubId := R.Arg1; + TrueSubId := SubId; + if SymbolTable[SubId].Kind = KindVAR then + begin + T := GetSymbolRec(SubId).TerminalTypeId; + if GetSymbolRec(T).FinalTypeId in [typePROC, typeEVENT] then + begin + TrueSubId := GetSymbolRec(T).PatternId; + end + else + continue; + end; + + if GetSymbolRec(TrueSubId).CallConv in [ccREGISTER, ccMSFASTCALL] then + if GetSymbolRec(TrueSubId).Count > 0 then + begin + L.Clear; + need_relocate := false; + + K := 0; + + for J := N - 1 downto 1 do + begin + R := Records[J]; + if R.Op = OP_BEGIN_MODULE then + break; + + if (K = 0) and (R.GenOp = OP_PUSH) and (R.Res = TrueSubId) then + begin + ParamId := SymbolTable.GetParamId(TrueSubId, R.Arg2); + if GetSymbolRec(ParamId).Register > 0 then + begin + if GetSymbolRec(ParamId).FinalTypeId + in [typeDYNARRAY, typeOPENARRAY] then + if GetSymbolRec(ParamId).Register = _ECX then + continue; + + L.Add(R); + need_relocate := true; + end + else + begin + need_relocate := true; + end; + end + else if (R.Op = OP_CALL) and (R.Arg1 = SubId) then + begin + Inc(K); + end + else if (R.Op = OP_BEGIN_CALL) and (R.Arg1 = SubId) then + begin + if K = 0 then + break + else + Dec(K); + end; + end; + + if L.Count = 0 then + need_relocate := false; + + if need_relocate then + begin + N1 := N; + if (Records[N1 - 1].Op = OP_PUSH_INST) or + (Records[N1 - 1].Op = OP_PUSH_CLSREF) or + (Records[N1 - 1].Op = OP_PUSH_DATA) then + Dec(N1); + for J := L.Count - 1 downto 0 do + begin + R := TCodeRec(L[J]); + Insert(N1, R.Clone); + R.Op := OP_NOP; + end; + end; + end; + end; + until false; + + finally + FreeAndNil(L); + end; +end; + +procedure TCode.Optimization; +var + I, FT, FT1: Integer; + ok: Boolean; + GenOp: Integer; + R, R1: TCodeRec; +begin + for I := 1 to Card - 1 do + begin + R := Records[I]; + R1 := Records[I + 1]; + + if (R.Op = OP_NOP) or (R1.Op = OP_NOP) then + continue; + + ok := R1.GenOp = OP_ASSIGN; + if ok then + ok := R.Op <> OP_NOP; + + if R.Op = OP_INTERFACE_FROM_CLASS then + begin + if R1.Op = OP_PUSH_INT then + ok := false; + if R1.Op = OP_PUSH_INST then + ok := false; + + if ok then + begin + R.Res := R1.Res; + R1.Op := OP_NOP; + R1.GenOp := OP_NOP; + end; + end; + if R.Op = OP_INTERFACE_CAST then + begin + if R1.Op = OP_PUSH_INT then + ok := false; + if R1.Op = OP_PUSH_INST then + ok := false; + + if ok then + begin + R.Res := R1.Res; + R1.Op := OP_NOP; + R1.GenOp := OP_NOP; + end; + end; + + if ok then + if R.Res = R1.Arg2 then + begin + if generic_binary_operators.IndexOf(R.GenOp) >= 0 then + begin + FT := GetSymbolRec(R.Res).FinalTypeId; + FT1 := GetSymbolRec(R1.Arg1).FinalTypeId; + if FT = FT1 then + if not(GetSymbolRec(R.Res).FinalTypeId in DynamicTypes) then + begin + R.Res := R1.Res; + R1.Op := OP_NOP; + R1.GenOp := OP_NOP; + end; + end + else if generic_unary_operators.IndexOf(R.GenOp) >= 0 then + begin + if GetSymbolRec(R.Res).FinalTypeId = GetSymbolRec(R1.Arg1).FinalTypeId + then + begin + R.Res := R1.Res; + R1.Op := OP_NOP; + R1.GenOp := OP_NOP; + end; + end + end; + + if (R.Op = OP_SAVE_REGS) and (R1.Op = OP_RESTORE_REGS) then + begin + R.Op := OP_NOP; + R1.Op := OP_NOP; + end; + + GenOp := R.GenOp; + + if (GenOp = OP_PLUS) or (GenOp = OP_MINUS) or (GenOp = OP_MULT) or + (GenOp = OP_DIV) then + begin + if (R.Arg1 = 0) or (GetSymbolRec(R.Arg1).FinalTypeId = typeCURRENCY) then + if GetSymbolRec(R.Arg2).FinalTypeId = typeCURRENCY then + begin + if R1.Arg1 = R.Res then + begin + if GetSymbolRec(R1.Arg1).FinalTypeId = typeCURRENCY then + if (R1.GenOp = OP_PLUS) or (R1.GenOp = OP_MINUS) or + (R1.GenOp = OP_MULT) or (R1.GenOp = OP_DIV) then + begin + R.Res := 0; + R1.Arg1 := 0; + end; + end + else if R1.Arg2 = R.Res then + begin + if GetSymbolRec(R1.Arg2).FinalTypeId = typeCURRENCY then + if (R1.GenOp = OP_PLUS) or (R1.GenOp = OP_MULT) then + begin + R.Res := 0; + R1.Arg2 := 0; + R1.SwapArguments; + end; + end; + end; + end; + end; + RemovePause; + RemoveNOP; +end; + +procedure TCode.Optimization2; +var + I: Integer; + ok: Boolean; + R, R1: TCodeRec; +begin + for I := 1 to Card - 1 do + begin + R := Records[I]; + R1 := Records[I + 1]; + + if R1.Op = OP_ONCREATE_HOST_OBJECT then + R1 := Records[I + 2]; + + if (R.Op = OP_NOP) or (R1.Op = OP_NOP) then + continue; + + ok := (R1.GenOp = OP_ASSIGN); + if ok then + ok := R.Op <> OP_NOP; + + if ok then + if R.Res = R1.Arg2 then + begin + if generic_binary_operators.IndexOf(R.GenOp) >= 0 then + begin + R.Res := R1.Res; + R1.Op := OP_NOP; + R1.GenOp := OP_NOP; + end + else if generic_unary_operators.IndexOf(R.GenOp) >= 0 then + begin + R.Res := R1.Res; + R1.Op := OP_NOP; + R1.GenOp := OP_NOP; + end + else if R.Op = OP_CALL then + begin + if Records[I + 2].Op = OP_GO_TRUE then + if Records[I + 2].Arg2 = R.Res then + continue; + + if Records[I + 2].Op = OP_GO_FALSE then + if Records[I + 2].Arg2 = R.Res then + continue; + + if R.Res <> 0 then + begin + R.Res := R1.Res; + R1.Op := OP_NOP; + R1.GenOp := OP_NOP; + end; + end; + end; + end; +end; + +procedure TCode.RemovePause; +var + I, L: Integer; +begin + I := 0; + while I <= Card do + begin + Inc(I); + if I >= Card - 4 then + break; + if Records[I].Op = OP_SEPARATOR then + if Records[I + 1].Op = OP_SET_CODE_LINE then + if Records[I + 2].Op = OP_CHECK_PAUSE then + if Records[I + 3].Op = OP_LABEL then + if Records[I + 4].Op = OP_SEPARATOR then + begin + Records[I + 1].Op := OP_NOP; + Records[I + 2].Op := OP_NOP; + Records[I + 2].Op := OP_NOP; + L := Records[I + 3].Arg1; + TKernel(kernel).SymbolTable[L].Kind := KindNONE; + Inc(I, 3); + end; + end; +end; + +procedure TCode.RemoveNOP; +var + I, L, Op: Integer; +begin + for I := Card downto 1 do + begin + Op := Records[I].Op; + if (Op = OP_NOP) or (Op = OP_LVALUE) or (Op = OP_POSTFIX_EXPRESSION) or + (Op = OP_PRINT_KWD) or (Op = OP_PRINTLN_KWD) or + (Op = OP_OPTION_EXPLICIT) or + // (Op = OP_STMT) or + (Op = OP_MYCLASS) or (Op = OP_MYBASE) or (Op = OP_CHECK_FINAL) or + + // (Op = OP_DECLARE_TEMP_VAR) or + // (Op = OP_DECLARE_LOCAL_VAR) or + + (Op = OP_END_IMPORT) or (Op = OP_EPILOGUE_GLOBAL_BLOCK2) then + DeleteRecord(I) + else if Op = OP_DECLARE_LOCAL_VAR then + begin + L := GetSymbolRec(Records[I].Arg2).Level; + if L > 0 then + if GetSymbolRec(L).Kind in kindSUBS then + DeleteRecord(I); + end + else if Op = OP_ONCREATE_HOST_OBJECT then + begin + if GetSymbolRec(Records[I].Arg1).FinalTypeId <> typeCLASS then + DeleteRecord(I); + end; + + // (Op = OP_BEGIN_USING) or + // (Op = OP_END_USING) or + // (Op = OP_BEGIN_BLOCK) or + // (Op = OP_END_BLOCK) or + // (Op = OP_BEGIN_WITH) or + // (Op = OP_END_WITH) or + // (Op = OP_BEGIN_SUB) or + // (Op = OP_DECLARE_TEMP_VAR) then + end; +end; + +function TCode.GetDeclaredVar(const VarName: String; SubId: Integer; + Upcase: Boolean; CurrPos: Integer): Integer; +var + I, Op: Integer; + R: TCodeRec; +begin + result := 0; + for I := CurrPos + 1 downto 1 do + begin + R := Records[I]; + Op := R.Op; + + if Op = OP_BEGIN_MODULE then + break; + + if R.Arg1 <> SubId then + continue; + + if Op = OP_DECLARE_LOCAL_VAR then + begin + if GetSymbolRec(R.Arg2).Kind = KindNONE then + continue; + + if Upcase then + begin + if StrEql(VarName, GetSymbolRec(R.Arg2).Name) then + begin + result := R.Arg2; + Exit; + end; + end + else + begin + if VarName = GetSymbolRec(R.Arg2).Name then + begin + result := R.Arg2; + Exit; + end; + end; + end + else if Op = OP_BEGIN_SUB then + Exit; + end; +end; + +function TCode.ExistsImplicitNumericConversion(type_id_source, + type_id_dest: Integer): Boolean; +begin + if type_id_source in IntegerTypes then + if type_id_dest in (IntegerTypes + RealTypes) then + begin + result := true; + Exit; + end; + + if type_id_source in RealTypes then + if type_id_dest in RealTypes then + begin + result := true; + Exit; + end; + + result := false; +end; + +function TCode.ExistsImplicitConversion(id_source, id_dest: Integer): Boolean; +var + symbol_table: TSymbolTable; + T1, T2: Integer; +begin + symbol_table := TKernel(kernel).SymbolTable; + + if symbol_table[id_source].TerminalTypeId = symbol_table[id_dest].TerminalTypeId + then + begin + result := true; + Exit; + end; + + if symbol_table[id_dest].TerminalTypeId = typePVOID then + begin + result := true; + Exit; + end; + + T1 := symbol_table[id_source].FinalTypeId; + T2 := symbol_table[id_dest].FinalTypeId; + + if (T2 = typeOPENARRAY) and (T1 = typeSET) then + begin + result := true; + Exit; + end; + + if T1 in VariantTypes then + if T2 in (IntegerTypes + RealTypes + [typeCURRENCY] + BooleanTypes + + StringTypes) then + begin + result := true; + Exit; + end; + + if T1 in (IntegerTypes + RealTypes + BooleanTypes + StringTypes) then + if T2 in VariantTypes then + begin + result := true; + Exit; + end; + + if T1 in StringTypes then + if T2 in StringTypes then + begin + result := true; + Exit; + end; + + if T1 in CharTypes then + if T2 in (CharTypes + StringTypes) then + begin + result := true; + Exit; + end; + + if (T1 = typeINTERFACE) and (T2 = typeINTERFACE) then + begin + result := true; + Exit; + end; + + if (T1 = typeCLASS) and (T2 = typeCLASS) then + begin + result := true; + Exit; + end; + +{$IFNDEF PAXARM} + if symbol_table[id_source].HasPAnsiCharType and (T2 in StringTypes) then + begin + result := true; + Exit; + end; +{$ENDIF} + if symbol_table[id_source].HasPWideCharType and (T2 in StringTypes) then + begin + result := true; + Exit; + end; + + if (id_source = symbol_table.NilId) and + (T2 in [typeCLASS, typeCLASSREF, typeINTERFACE]) then + begin + result := true; + Exit; + end; + + result := ExistsImplicitNumericConversion(T1, T2); +end; + +/// +/// Returns 1 or 2, if conversion between types of id and id1 is better than +/// conversion between types of id and id2. +/// Returns -1 or -2, if conversion between types of id and id2 is better than +/// conversion between types of id and id1. +/// Returns 0, if there is no better conversion. +/// +function TCode.CompareConversions(Id, id1, id2: Integer): Integer; +var + symbol_table: TSymbolTable; + S, T1, T2, K: Integer; + B1, B2: Boolean; +begin + symbol_table := TKernel(kernel).SymbolTable; + S := symbol_table[Id].FinalTypeId; + + K := symbol_table[Id].Kind; + if K = KindTYPE then + if symbol_table[Id].FinalTypeId = typeCLASS then + begin + Inc(Id); + S := symbol_table[Id].FinalTypeId; + end; + + T1 := symbol_table[id1].FinalTypeId; + T2 := symbol_table[id2].FinalTypeId; + + result := 0; + + if T1 = T2 then + begin + if T1 = typeENUM then + begin + T1 := symbol_table[id1].TerminalTypeId; + T2 := symbol_table[id2].TerminalTypeId; + S := symbol_table[Id].TerminalTypeId; + + if T1 = T2 then + Exit; + B1 := S = T1; + B2 := S = T2; + if B1 then + Inc(result, 2); + if B2 then + Dec(result, 2); + Exit; + end + else if T1 = typeCLASS then + begin + T1 := symbol_table[id1].TerminalTypeId; + T2 := symbol_table[id2].TerminalTypeId; + + if T1 = T2 then + Exit; + + S := symbol_table[Id].TerminalTypeId; + + B1 := symbol_table.Inherits(S, T1); + B2 := symbol_table.Inherits(S, T2); + + if B1 and B2 then + begin + B1 := S = T1; + B2 := S = T2; + if B1 then + Inc(result, 2); + if B2 then + Dec(result, 2); + end + else if B1 then + begin + result := 2; + end + else if B2 then + begin + result := -2; + end; + Exit; + end + else if T1 = typeINTERFACE then + begin + T1 := symbol_table[id1].TerminalTypeId; + T2 := symbol_table[id2].TerminalTypeId; + + if T1 = T2 then + Exit; + + S := symbol_table[Id].TerminalTypeId; + + B1 := symbol_table.Supports(S, T1); + B2 := symbol_table.Supports(S, T2); + + if B1 and B2 then + begin + B1 := S = T1; + B2 := S = T2; + if B1 then + Inc(result, 2); + if B2 then + Dec(result, 2); + end + else if B1 then + begin + result := 2; + end + else if B2 then + begin + result := -2; + end; + end; + Exit; + end; + + if S = T1 then + begin + result := 1; + if not ExistsImplicitConversion(Id, id2) then + Inc(result); + Exit; + end; + + if S = T2 then + begin + result := -1; + if not ExistsImplicitConversion(Id, id1) then + Dec(result); + Exit; + end; + + if ExistsImplicitConversion(Id, id1) then + begin + if ExistsImplicitConversion(Id, id2) then + result := 0 + else + result := 2; + Exit; + end; + + if ExistsImplicitConversion(Id, id2) then + begin + if ExistsImplicitConversion(Id, id1) then + result := 0 + else + result := -2; + Exit; + end; + result := 0; +end; + +procedure TCode.RemoveInstruction(Op, Arg1, Arg2, Res: Integer); +var + I: Integer; +begin + for I := Card downto 1 do + if Records[I].Op = Op then + begin + if not((Arg1 = -1) or (Arg1 = Records[I].Arg1)) then + continue; + if not((Arg2 = -1) or (Arg2 = Records[I].Arg2)) then + continue; + if not((Res = -1) or (Res = Records[I].Res)) then + continue; + Records[I].Op := OP_NOP; + Exit; + end; +end; + +function TCode.RemoveLastEvalInstruction(const S: String; + Upcase: Boolean = true): Integer; +var + I, Id, K: Integer; + Q: String; + b: Boolean; +begin + result := 0; + K := 0; + for I := Card downto 1 do + begin + if Records[I].Op = OP_STMT then + begin + Inc(K); + if K > 1 then + break; + end + else if Records[I].Op = OP_EVAL then + begin + Id := Records[I].Res; + Q := GetSymbolRec(Id).Name; + if Upcase then + b := StrEql(S, Q) + else + b := S = Q; + if b then + begin + result := Id; + Records[I].Op := OP_NOP; + Exit; + end; + end; + end; +end; + +procedure TCode.CreateMapping(result: TMapTable; Host: Boolean; + HostMapTable, ScriptMapTable: TMapTable); + +var + CurrN: Integer; + + procedure AddSubDesc(MapRec: TMapRec; SubId: Integer); + var + I, SelfId, ParamId, ResTypeId, ParamTypeId, L, ElemTypeId: Integer; + R: TSymbolRec; + SymbolTable: TSymbolTable; + SubParamRec: TSubParamRec; + SubLocalVarRec: TSubLocalVarRec; + S: String; + CR: TCodeRec; + begin + R := GetSymbolRec(SubId); + if not(R.Kind in kindSUBS) then + Exit; + + SymbolTable := TKernel(kernel).SymbolTable; + +{$IFDEF PCU_EX} + if not Host then + for I := 1 to Card do + begin + CR := Records[I]; + + if CR.Arg1 = SubId then + begin + if CR.Op = OP_INIT_SUB then + MapRec.SubDesc.N1 := I + else if CR.Op = OP_FIN_SUB then + MapRec.SubDesc.N2 := I; + end; + end; +{$ENDIF} + MapRec.SubDesc.Sid := SubId; + MapRec.SubDesc.CallConv := R.CallConv; + MapRec.SubDesc.RetSize := SymbolTable.GetSizeOfParams(SubId); + MapRec.SubDesc.ResTypeId := R.FinalTypeId; + ResTypeId := R.TypeId; + MapRec.SubDesc.ResTypeName := GetSymbolRec(ResTypeId).Name; + MapRec.Vis := R.Vis; + MapRec.SubDesc.IsShared := R.IsSharedMethod; + + L := R.Level; + if L = 0 then + MapRec.SubDesc.IsMethod := false + else if GetSymbolRec(L).Kind = KindTYPE then + MapRec.SubDesc.IsMethod := true + else + MapRec.SubDesc.IsMethod := false; + + if MapRec.SubDesc.IsMethod then + begin + SelfId := SymbolTable.GetSelfId(SubId); + MapRec.SubDesc.SelfOffset := GetSymbolRec(SelfId).Shift; + end; + + if Records[CurrN].Op = OP_LOAD_PROC then + begin + S := GetSymbolRec(Records[CurrN].Res).value; + if not StrEql(ExtractFileExt(S), '.' + PCU_FILE_EXT) then + begin + MapRec.SubDesc.DllName := S; + MapRec.SubDesc.AliasName := GetSymbolRec(Records[CurrN].Arg2).value; + end; + end; + + for I := 0 to R.Count - 1 do + begin + ParamId := SymbolTable.GetParamId(SubId, I); + SubParamRec := MapRec.SubDesc.ParamList.AddRecord; + SubParamRec.FinTypeId := SymbolTable[ParamId].FinalTypeId; + SubParamRec.ParamSize := SymbolTable[ParamId].FinSize; + SubParamRec.ParamName := SymbolTable[ParamId].Name; + SubParamRec.ParamOffset := SymbolTable[ParamId].Shift; + ParamTypeId := SymbolTable[ParamId].TypeId; + SubParamRec.ParamTypeName := SymbolTable[ParamTypeId].Name; + if SymbolTable[ParamId].FinalTypeId in [typeDYNARRAY, typeOPENARRAY] then + if SymbolTable[ParamId].IsOpenArray then + begin + ParamTypeId := SymbolTable[ParamId].TerminalTypeId; + ElemTypeId := SymbolTable[ParamTypeId].PatternId; + SubParamRec.ParamTypeName := 'array of ' + SymbolTable + [ElemTypeId].Name; + end; + + if SymbolTable[ParamId].ByRef then + SubParamRec.ParamMod := PM_BYREF + else if SymbolTable[ParamId].IsConst then + SubParamRec.ParamMod := PM_CONST + else + SubParamRec.ParamMod := PM_BYVAL; + + if SymbolTable[ParamId].Optional then + SubParamRec.OptValue := + VariantToString(SymbolTable[ParamId].FinalTypeId, + SymbolTable[ParamId].value); + end; + +{$IFDEF PCU_EX} + if not Host then + for I := SubId + 1 to SymbolTable.Card do + if SymbolTable.IsLocalOf(I, SubId) then + begin + SubLocalVarRec := MapRec.SubDesc.LocalVarList.AddRecord; + SubLocalVarRec.LocalVarName := SymbolTable[I].Name; + SubLocalVarRec.LocalVarOffset := SymbolTable[I].Shift; + SubLocalVarRec.IsByRef := SymbolTable[I].ByRef; + ParamTypeId := SymbolTable[I].TypeId; + SubLocalVarRec.LocalVarTypeName := SymbolTable[ParamTypeId].Name; + end + else if GetSymbolRec(I).Kind = KindNAMESPACE then + break; +{$ENDIF} + end; + +procedure TryMap(Id: Integer); forward; + + procedure AddDescendats(Id: Integer); + var + SymbolTable: TSymbolTable; + I, J, T: Integer; + List: TIntegerList; + S: String; + begin + SymbolTable := TKernel(kernel).SymbolTable; + S := SymbolTable[Id].Name; + T := SymbolTable[Id].Level; + List := SymbolTable.HashArray.GetList(S); + + for J := List.Count - 1 downto 0 do + begin + I := List[J]; + if I <> Id then + with SymbolTable[I] do + if Kind = KindSUB then + if SymbolTable[Level].Kind = KindTYPE then + if SymbolTable[Level].FinalTypeId = typeCLASS then + if StrEql(Name, S) then + if SymbolTable.Inherits(Level, T) then + begin + SymbolTable.InCode[I] := true; + TryMap(I); + end; + end; + end; + + procedure AddIUnknownMethods(Id: Integer); + var + SymbolTable: TSymbolTable; + I, J, L, KK: Integer; + List: TIntegerList; + S: String; + MapRec: TMapRec; + R: TSymbolRec; + begin + if Host then + Exit; + + SymbolTable := TKernel(kernel).SymbolTable; + + for KK := 1 to 3 do + begin + S := ''; + case KK of + 1: + S := 'QueryInterface'; + 2: + S := '_AddRef'; + 3: + S := '_Release'; + end; + + List := SymbolTable.HashArray.GetList(S); + + for J := List.Count - 1 downto 0 do + begin + I := List[J]; + if I <> Id then + if SymbolTable[I].Kind = KindSUB then + begin + L := SymbolTable[I].Level; + if SymbolTable[L].Kind = KindTYPE then + if SymbolTable[L].FinalTypeId = typeCLASS then + if StrEql(SymbolTable[I].Name, S) then + begin + if SymbolTable.Inherits(Id, L) then + begin + R := SymbolTable[I]; + + SymbolTable.InCode[I] := true; + if R.Host then + begin + MapRec := HostMapTable.AddRec(R.FullName, R.Shift, -1, + KindSUB, false, 0, 0); + end + else + MapRec := ScriptMapTable.AddRec(R.FullName, R.value, -1, + KindSUB, false, 0, 0); + + AddSubDesc(MapRec, Id); + + break; + end; + end; + end; + end; + end; + end; + + procedure TryMap(Id: Integer); + var + SymbolTable: TSymbolTable; + Global: Boolean; + R, R1: TSymbolRec; + T: Integer; + MapRec: TMapRec; + Lst: TIntegerList; + J: Integer; + begin + SymbolTable := TKernel(kernel).SymbolTable; + + if Id > SymbolTable.Card then + Exit; + + if Id <= StdCard then + Exit; + + R := SymbolTable[Id]; + + if R.FullName = '' then + begin + if R.FinalTypeId = typeCLASS then + begin + T := R.TerminalTypeId; + if GetSymbolRec(T).Name <> '' then + TryMap(T); + end; + + if R.FinalTypeId = typeCLASSREF then + begin + T := R.TerminalTypeId; + T := GetSymbolRec(T).PatternId; + if GetSymbolRec(T).Name <> '' then + TryMap(T); + end; + + if R.FinalTypeId = typeINTERFACE then + begin + T := R.TerminalTypeId; + SymbolTable.InCode[T] := true; + end; + + Exit; + end; + + if ExtractName(R.FullName) = '' then + begin + if R.FinalTypeId = typeCLASS then + begin + T := R.TerminalTypeId; + if GetSymbolRec(T).Name <> '' then + TryMap(T); + end; + + if R.FinalTypeId = typeINTERFACE then + begin + T := R.TerminalTypeId; + SymbolTable.InCode[T] := true; + end; + + Exit; + end; + + if R.TypedConst and (Host = false) then + begin + // Exit; + end; + + if Id <= TKernel(kernel).GT.Card then + Global := true + else + Global := false; + + if result.LookUpEx(R.FullName, R.OverCount) <> nil then + Exit; + + if R.Kind = KindNAMESPACE then + begin + if R.Host <> Host then + Exit; + + result.AddRec(R.FullName, 0, -1, R.Kind, Global, 0, 0); + Exit; + end; + + if R.ClassIndex <> -1 then + begin + if R.Host <> Host then + Exit; + + R1 := SymbolTable[Id + 1]; + MapRec := result.AddRec(R.FullName, R1.Shift, R.ClassIndex, KindTYPE, + Global, 0, 0); + + if not Host then + SymbolTable.AddScriptFields(Id, MapRec.FieldList); + + SymbolTable.InCode[Id] := true; + + if R.SupportedInterfaces <> nil then + if R.SupportedInterfaces.Count > 0 then + AddIUnknownMethods(Id); + { + if not R.Host then + if GetSymbolRec(R.AncestorId).Host then + if HostMapTable <> nil then + if R.AncestorId <> H_TObject then + begin + R := GetSymbolRec(R.AncestorId); + if HostMapTable.Lookup(R.FullName) <> nil then + Exit; + + Id := R.Id; + SymbolTable.InCode[Id] := true; + R1 := GetSymbolRec(Id + 1); + HostMapTable.AddRec(R.FullName, R1.Shift, R.ClassIndex, KindTYPE, Global, 0, 0); + end; + } + Exit; + end; + + if R.IsGlobalVarEx then + begin + if R.FinalTypeId = typeCLASS then + begin + T := R.TerminalTypeId; + if GetSymbolRec(T).Name <> '' then + TryMap(T); + end; + + if R.FinalTypeId = typeINTERFACE then + begin + T := R.TerminalTypeId; + SymbolTable.InCode[T] := true; + end; + + if R.Host <> Host then + Exit; + + MapRec := result.AddRec(R.FullName, R.Shift, -1, R.Kind, Global, 0, 0); + MapRec.TypedConst := R.TypedConst; + MapRec.FullTypeName := GetSymbolRec(R.TypeId).FullName; + end + else if R.Kind in kindSUBS then + begin + if not(R.IsSubPartOfEventType or R.IsSubPartOfProcType) then + if not R.IsNestedSub then + if R.Name <> '' then + begin + if R.Level > 0 then + begin + if GetSymbolRec(R.Level).FinalTypeId = typeINTERFACE then + Exit; + + if GetSymbolRec(R.Level).FinalTypeId = typeCLASS then + TryMap(R.Level); + end; + + if R.Host <> Host then + begin + if not R.IsExternal then + Exit; + if Host then + Exit; + end; + + if R.IsExternal then + begin + MapRec := result.AddRec(R.FullName, 0, -1, R.Kind, Global, + R.OverCount, R.CallMode); + MapRec.IsExternal := true; + end + else if Host then + begin + MapRec := result.AddRec(R.FullName, R.Shift, -1, R.Kind, Global, + R.OverCount, R.CallMode); + end + else + MapRec := result.AddRec(R.FullName, R.value, -1, R.Kind, Global, + R.OverCount, R.CallMode); + + AddSubDesc(MapRec, Id); + + if R.IsVirtual and Host then + begin + // AddDescendats(Id); + end; + + if R.OverCount > 0 then + begin + Lst := SymbolTable.LookUpAll(SymbolTable[Id].Name, + SymbolTable[Id].Level, true); + try + for J := 0 to Lst.Count - 1 do + if Lst[J] <> Id then + begin + SymbolTable.InCode[Lst[J]] := true; + TryMap(Lst[J]); + end; + finally + FreeAndNil(Lst); + end; + end; + end + end + else if R.FinalTypeId = typeCLASS then + begin + T := R.TerminalTypeId; + if GetSymbolRec(T).Name <> '' then + TryMap(T); + end + else if R.FinalTypeId = typeINTERFACE then + begin + T := R.TerminalTypeId; + SymbolTable.InCode[T] := true; + end + else if R.Level > 0 then + begin + if GetSymbolRec(R.Level).FinalTypeId = typeCLASS then + begin + T := GetSymbolRec(R.Level).TerminalTypeId; + if GetSymbolRec(T).Name <> '' then + TryMap(T); + end + else if R.FinalTypeId = typeEVENT then + begin + Id := R.PatternId; + if Id > 0 then + begin + R := GetSymbolRec(Id); + if R.Kind <> KindSUB then + Exit; + + if R.Host then + Exit; + + SymbolTable.InCode[Id] := true; + if R.Host then + begin + MapRec := HostMapTable.AddRec(R.FullName, R.Shift, -1, KindSUB, + false, 0, 0); + end + else + begin + if ScriptMapTable = nil then + Exit; + MapRec := ScriptMapTable.AddRec(R.FullName, R.value, -1, KindSUB, + false, 0, 0); + end; + + AddSubDesc(MapRec, Id); + end; + end; + end; + end; + +var + I, T: Integer; + R: TCodeRec; +begin + result.Clear; + + for I := 1 to Card do + begin + CurrN := I; + R := Records[I]; + + if R.Op = OP_SET_CODE_LINE then + continue; + if R.Op = OP_SEPARATOR then + continue; + + TryMap(R.Arg1); + TryMap(R.Arg2); + TryMap(R.Res); + + if R.Op = OP_PUSH_CLSREF then + TryMap(R.Arg1 - 1) + else if R.Op = OP_IS then + begin + T := GetSymbolRec(R.Arg1).TypeId; + TryMap(T); + end; + end; + + for I := 0 to map_list.Count - 1 do + TryMap(map_list[I]); +end; + +procedure TCode.CreateExportList(MapTable: TMapTable); +var + I: Integer; + S: String; + MR: TMapRec; +begin + for I := 1 to Card do + if Records[I].Op = OP_EXPORTS then + begin + S := GetSymbolRec(Records[I].Arg1).FullName; + MR := MapTable.LookUp(S); + if MR = nil then + RaiseError(errInternalError, []); + S := ExtractName(S); + with TKernel(kernel).ExportList.Add do + begin + Name := S; + Offset := MR.Offset; + Ordinal := TKernel(kernel).ExportList.Count - 1; + end; + end; +end; + +procedure TCode.GenHostStructConst; + +var + ModuleNum: Integer; + Language: Integer; + Upcase: Boolean; + SymbolTable: TSymbolTable; + + procedure Gen(Op, Arg1, Arg2, Res, Lev: Integer); + begin + Add(Op, Arg1, Arg2, Res, Lev, Upcase, Language, ModuleNum, -1); + end; + +var + InCode: array of Boolean; + + procedure SetInCode; + var + I, K, Id: Integer; + begin + K := TKernel(kernel).SymbolTable.Card; + + SetLength(InCode, K + K); + + for I := 1 to Card do + begin + + Id := Self[I].Arg1; + if Id > 0 then + if Id <= K then + InCode[Id] := true; + + Id := Self[I].Arg2; + if Id > 0 then + if Id <= K then + InCode[Id] := true; + + Id := Self[I].Res; + if Id > 0 then + if Id <= K then + InCode[Id] := true; + + end; + end; + + procedure Init(I: Integer; const V: Variant); + var + ArrObject: TArrObject; + VarObject: TVarObject; + SimpleObject: TSimpleObject; + NameId: Integer; + ItemId: Integer; + ValId: Integer; + value: Variant; + ValueTypeId: Integer; + J: Integer; + FT: Integer; + begin + FT := SymbolTable[I].FinalTypeId; + SymbolTable[I].Kind := KindVAR; + SymbolTable[I].TypedConst := true; + + Gen(OP_BEGIN_INIT_CONST, I, 0, 0, 0); + ArrObject := VariantToVarObject(V) as TArrObject; + for J := 0 to ArrObject.Count - 1 do + begin + VarObject := ArrObject[J]; + if VarObject is TSimpleObject then + begin + SimpleObject := VarObject as TSimpleObject; + ItemId := NewTempVar(0, 0); + value := SimpleObject.value; + ValueTypeId := 0; + case VarType(value) of + varByte, varInteger: + ValueTypeId := typeINTEGER; +{$IFDEF VARIANTS} + varInt64: + ValueTypeId := typeINT64; + varLongWord: + ValueTypeId := typeCARDINAL; +{$ENDIF} +{$IFNDEF PAXARM} + varString: + ValueTypeId := typeANSISTRING; +{$ENDIF} + varBoolean: + ValueTypeId := typeBOOLEAN; + varDouble: + ValueTypeId := typeDOUBLE; + else + RaiseError(errInternalError, []); + end; + ValId := CreateConst(ValueTypeId, value); + + if FT = typeRECORD then + begin + NameId := CreateConst(typeSTRING, SimpleObject.Name); + Gen(OP_RECORD_ITEM, I, NameId, ItemId, 0); + end + else + Gen(OP_ITEM, I, J, ItemId, 0); + + Gen(OP_ASSIGN, ItemId, ValId, ItemId, 0); + end + else if VarObject is TArrObject then + begin + ItemId := NewTempVar(0, 0); + Init(ItemId, VarObjectToVariant(VarObject as TArrObject)); + Gen(OP_ASSIGN_SHIFT, 0, J, ItemId, 0); + end; + end; + Gen(OP_END_INIT_CONST, I, 0, 0, 0); + end; + +var + I, FT: Integer; + SymbolRec: TSymbolRec; + V: Variant; + K: Integer; + K1, K2, KK: Integer; +begin + ModuleNum := GetModuleNumber(Card); + Language := GetLanguage(Card); + Upcase := GetUpcase(Card); + + SetInCode; + + K := Card; + while Records[K].Op <> OP_END_MODULE do + Dec(K); + + SymbolTable := TKernel(kernel).SymbolTable; + + for KK := 1 to 2 do + begin + if KK = 1 then + begin + K1 := Types.Count; + K2 := TKernel(kernel).GT.Card; + end + else + begin + K1 := FirstLocalId + 1; + K2 := Card; + end; + + for I := K1 to K2 do + begin + SymbolRec := SymbolTable[I]; + + if SymbolRec.Kind = KindCONST then + begin + FT := SymbolRec.FinalTypeId; + if FT in [typeRECORD, typeARRAY] then + begin + V := SymbolRec.value; + if VarType(V) <> PAXCOMP_VAROBJECT.VarObject then + continue; + + if not InCode[I] then + continue; + + Init(I, V); + end + else if I <= SymbolTable.CompileCard then + begin +{$IFNDEF PAXARM} + if FT = typeSHORTSTRING then + begin + if not InCode[I] then + continue; + + SymbolTable[I].Kind := KindVAR; + SymbolTable[I].TypedConst := true; + Gen(OP_BEGIN_INIT_CONST, I, 0, 0, 0); + Gen(OP_ASSIGN, I, SymbolTable.AddPAnsiCharConst + (AnsiString(SymbolTable[I].value)).Id, I, 0); + Gen(OP_END_INIT_CONST, I, 0, 0, 0); + end; +{$ENDIF} + end; + end; + end; + end; + + Records[K].Op := OP_NOP; + Gen(OP_END_MODULE, ModuleNum, 0, 0, 0); +end; + +function TCode.PrevN(J: Integer): Integer; +begin + result := 0; + + J := J - 1; + if Records[J].Op <> OP_SEPARATOR then + begin + result := J; + Exit; + end; + + while J > 1 do + begin + Dec(J); + if Records[J].Op <> OP_SEPARATOR then + begin + result := J; + Exit; + end; + end; +end; + +function TCode.PrevPrevRec(J: Integer): TCodeRec; +begin + result := PrevRec(PrevN(J)); +end; + +function TCode.PrevRec(J: Integer): TCodeRec; +begin + result := nil; + + J := J - 1; + if Records[J].Op <> OP_SEPARATOR then + begin + result := Records[J]; + Exit; + end; + + while J > 1 do + begin + Dec(J); + if Records[J].Op <> OP_SEPARATOR then + begin + result := Records[J]; + Exit; + end; + end; + +end; + +function TCode.NextRec(J: Integer): TCodeRec; +begin + result := nil; + + J := J + 1; + if Records[J].Op <> OP_SEPARATOR then + begin + result := Records[J]; + Exit; + end; + + while J < Card do + begin + Inc(J); + if Records[J].Op <> OP_SEPARATOR then + begin + result := Records[J]; + Exit; + end; + end; +end; + +function TCode.GetCurrSubId(CurrN: Integer): Integer; +var + I, K, Op: Integer; + R: TCodeRec; +begin + result := 0; + K := 0; + for I := CurrN downto 1 do + begin + R := Records[I]; + Op := R.Op; + if Op = OP_INIT_SUB then + begin + if K = 0 then + begin + result := R.Arg1; + Exit; + end + else + Dec(K); + end + else if Op = OP_END_SUB then + Inc(K) + else if Op = OP_BEGIN_MODULE then + Exit; + end; +end; + +function TCode.GetCurrSelfId(CurrN: Integer): Integer; +var + SubId, L: Integer; +begin + result := 0; + SubId := GetCurrSubId(CurrN); + if SubId = 0 then + Exit; + if GetSymbolRec(SubId).IsJSFunction then + begin + result := TKernel(kernel).SymbolTable.GetSelfId(SubId); + Exit; + end; + + L := SubId; + repeat + L := GetSymbolRec(L).Level; + if L = 0 then + Exit; + if GetSymbolRec(L).Kind = KindTYPE then + begin + result := TKernel(kernel).SymbolTable.GetSelfId(SubId); + Exit; + end + else if not(GetSymbolRec(L).Kind in kindSUBS) then // nested sub + Exit; + until false; +end; + +procedure TCode.LocateDummyName(var NN: Integer); +var + I, J, SubId: Integer; + R, RJ: TCodeRec; +begin + NN := -1; + for I := Card downto 1 do + begin + R := Records[I]; + + if R.GenOp = OP_PUSH then + begin + if GetSymbolRec(R.Arg1).Name = DummyName then + begin + SubId := R.Res; + + for J := I + 1 to Card do + begin + RJ := Records[J]; + if (RJ.Op = OP_CALL) or (RJ.Op = OP_STR) then + if RJ.Arg1 = SubId then + begin + NN := J; + Exit; + end; + end; + + for J := I - 1 downto 1 do + begin + RJ := Records[J]; + if RJ.Op = OP_BEGIN_CALL then + if RJ.Arg1 = SubId then + begin + NN := J; + Exit; + end; + end; + end; + end + else if R.GenOp = OP_FIELD then + begin + if GetSymbolRec(R.Arg2).Name = DummyName then + begin + NN := I; + Exit; + end; + end + else if R.GenOp = OP_EVAL then + begin + if GetSymbolRec(R.Res).Name = DummyName then + begin + R.Op := OP_EVAL; + NN := I; + Exit; + end; + end + else if (R.GenOp = OP_ABS) or (R.GenOp = OP_INC) or (R.GenOp = OP_DEC) or + (R.GenOp = OP_PRED) or (R.GenOp = OP_SUCC) or (R.GenOp = OP_ORD) or + (R.GenOp = OP_SIZEOF) or (R.GenOp = OP_CHR) or (R.GenOp = OP_LOW) or + (R.GenOp = OP_HIGH) or (R.GenOp = OP_ASSIGNED) or (R.GenOp = OP_STR) or + (R.GenOp = OP_PRINT) or (R.GenOp = OP_PRINT_EX) then + begin + if GetSymbolRec(R.Arg1).Name = DummyName then + begin + NN := I; + Exit; + end; + end; + end; +end; + +function TCode.FindRecord1(Op, Arg1: Integer): Integer; +var + I: Integer; + R: TCodeRec; +begin + result := 0; + for I := 1 to Card do + begin + R := Records[I]; + if R.Op = Op then + if R.Arg1 = Arg1 then + begin + result := I; + Exit; + end; + end; +end; + +procedure TCode.InsertDynamicTypeDestructors; +var + I, IStart, J, T, TypeId, Id, Level, Op: Integer; + R: TCodeRec; + WasInsertion: Boolean; + Upcase: Boolean; + Language, ModuleNum: Integer; +begin + dmp; + for I := 1 to Card do + begin + R := Records[I]; + if R.Op = OP_DESTROY_LOCAL_VAR then + begin + if not GetSymbolRec(R.Arg1).IsExternal then + begin + T := GetSymbolRec(R.Arg1).FinalTypeId; + case T of + typeVARIANT, typeOLEVARIANT: + R.Op := OP_VARIANT_CLR; +{$IFNDEF PAXARM} + typeANSISTRING: + R.Op := OP_ANSISTRING_CLR; + typeWIDESTRING: + R.Op := OP_WIDESTRING_CLR; +{$ENDIF} + typeUNICSTRING: + R.Op := OP_UNICSTRING_CLR; + typeINTERFACE: + R.Op := OP_INTERFACE_CLR; + typeDYNARRAY: + R.Op := OP_DYNARRAY_CLR; + typeRECORD, typeARRAY: + begin + TypeId := GetSymbolRec(R.Arg1).TerminalTypeId; + if TKernel(kernel).SymbolTable.HasDynamicFields(TypeId) then + R.Op := OP_STRUCTURE_CLR + else + R.Op := OP_NOP; + end; + typeCLASS: + begin +{$IFDEF PAXARM} + R.Op := OP_CLASS_CLR; +{$ELSE} + TypeId := GetSymbolRec(R.Arg1).TerminalTypeId; + if IsJSType(TypeId, TKernel(kernel).SymbolTable) then + R.Op := OP_CLASS_CLR + else + R.Op := OP_NOP; +{$ENDIF} + end + else + R.Op := OP_NOP; + end; + end + else + R.Op := OP_NOP; + end; + end; + + IStart := 1; + repeat + WasInsertion := false; + + I := IStart - 1; + while I < Card do + begin + Inc(I); + + R := Records[I]; + if (R.Op = OP_DECLARE_TEMP_VAR) or (R.Op = OP_OLE_GET) then + begin + if not GetSymbolRec(R.Arg2).IsExternal then + begin + if R.Op = OP_OLE_GET then + Id := R.Res + else + Id := R.Arg2; + Level := GetSymbolRec(Id).Level; + Op := OP_NOP; + + T := GetSymbolRec(Id).FinalTypeId; + case T of + typeVARIANT, typeOLEVARIANT: + Op := OP_VARIANT_CLR; +{$IFNDEF PAXARM} + typeANSISTRING: + Op := OP_ANSISTRING_CLR; + typeWIDESTRING: + Op := OP_WIDESTRING_CLR; +{$ENDIF} + typeUNICSTRING: + Op := OP_UNICSTRING_CLR; + typeINTERFACE: + Op := OP_INTERFACE_CLR; +{$IFDEF PAXARM} + typeCLASS: + Op := OP_CLASS_CLR; +{$ENDIF} + typeDYNARRAY: + Op := OP_DYNARRAY_CLR; + typeRECORD, typeARRAY: + begin + TypeId := GetSymbolRec(Id).TerminalTypeId; + if TKernel(kernel).SymbolTable.HasDynamicFields(TypeId) then + Op := OP_STRUCTURE_CLR + else + Op := OP_NOP; + end; + end; + + if Op = OP_NOP then + begin + // break; + Inc(I); + continue; + end; + + // find insertion point + + if (Level = 0) or (GetSymbolRec(Level).Kind in [KindNONE, KindVAR, + KindNAMESPACE]) then + begin + J := I - 1; + while J < Card do + begin + Inc(J); + + R := Records[J]; + if R.Op = OP_EPILOGUE_GLOBAL_BLOCK2 then + begin + if Records[J - 1].Op = OP_RET then + Dec(J); + + Upcase := R.Upcase; + Language := R.Language; + ModuleNum := R.ModuleNum; + R := TCodeRec.Create(Op, Self); + R.Upcase := Upcase; + R.Language := Language; + R.ModuleNum := ModuleNum; + + R.Arg1 := Id; + R.Arg2 := 0; + R.Res := 0; + Insert(J, R); + + WasInsertion := true; + break; + end; + end; + end + else + begin + J := I; + while J < Card do + begin + Inc(J); + + R := Records[J]; + if R.Op = OP_END_SUB then + begin + if Level <> R.Arg1 then + begin + if GetSymbolRec(R.Arg1).IsNestedSub then + continue; + + RaiseError(errInternalError, []); + end; + + while Records[J - 1].Op = OP_NOP do + Dec(J); + if Records[J - 1].Op = OP_EPILOGUE_SUB then + Inc(J, 3); + + Upcase := R.Upcase; + Language := R.Language; + ModuleNum := R.ModuleNum; + R := TCodeRec.Create(Op, Self); + R.Upcase := Upcase; + R.Language := Language; + R.ModuleNum := ModuleNum; + + R.Arg1 := Id; + R.Arg2 := 0; + R.Res := 0; + Insert(J, R); + + WasInsertion := true; + + break; + end; + end; + end; + end; + end; + end; + + if not WasInsertion then + break; + + IStart := I + 1; + + until false; +end; + +procedure TCode.InsertFinalizators; +var + I, J, K, ClassId, FT, Op, TypeId, DestructorId, SelfId, FieldId: Integer; + SymbolTable: TSymbolTable; + RJ: TSymbolRec; + RC: TCodeRec; +begin + SymbolTable := TKernel(kernel).SymbolTable; + + I := Card; + while I > 1 do + begin + Dec(I); + if Self[I].Op = OP_BEGIN_CLASS_TYPE then + begin + ClassId := Self[I].Arg1; + DestructorId := SymbolTable.FindDestructorId(ClassId); + SelfId := SymbolTable.GetSelfId(DestructorId); + + K := 0; + + for J := I + 1 to Card do + begin + RC := Self[J]; + if RC.Op = OP_END_SUB then + if RC.Arg1 = DestructorId then + begin + K := J - 1; + while not((Self[K].Op = OP_END_WITH) and (Self[K].Arg1 = SelfId)) do + Dec(K); + end; + end; + + if K = 0 then + continue; + // RaiseError(errInternalError, []); + + for J := ClassId + 1 to SymbolTable.Card do + begin + RJ := SymbolTable[J]; + if RJ.Kind = KindTYPE_FIELD then + if RJ.Level = ClassId then + begin + FT := RJ.FinalTypeId; + TypeId := RJ.TerminalTypeId; + Op := OP_NOP; + case FT of + typeVARIANT, typeOLEVARIANT: + Op := OP_VARIANT_CLR; +{$IFNDEF PAXARM} + typeANSISTRING: + Op := OP_ANSISTRING_CLR; + typeWIDESTRING: + Op := OP_WIDESTRING_CLR; +{$ENDIF} + typeUNICSTRING: + Op := OP_UNICSTRING_CLR; + typeINTERFACE: + Op := OP_INTERFACE_CLR; + typeDYNARRAY: + Op := OP_DYNARRAY_CLR; + typeRECORD, typeARRAY: + if SymbolTable.HasDynamicFields(TypeId) then + Op := OP_STRUCTURE_CLR; + typeCLASS: +{$IFDEF PAXARM} + Op := OP_CLASS_CLR; +{$ELSE} + if SymbolTable.Inherits(TypeId, H_TFW_Array) then + begin + Op := OP_CLASS_CLR; + end; +{$ENDIF} + end; + + if Op <> OP_NOP then + begin + FieldId := NewTempVar(DestructorId, TypeId); + + GetSymbolRec(FieldId).OwnerId := SelfId; + GetSymbolRec(FieldId).PatternId := J; + GetSymbolRec(FieldId).Name := RJ.Name; + GetSymbolRec(FieldId).ByRef := true; + + RC := TCodeRec.Create(OP_FIELD, Self); + RC.Upcase := GetUpcase(I); + RC.Language := GetLanguage(I); + RC.ModuleNum := GetModuleNumber(I); + RC.Arg1 := SelfId; + RC.Arg2 := FieldId; + RC.Res := FieldId; + + Insert(K, RC); + + RC := TCodeRec.Create(Op, Self); + RC.Upcase := GetUpcase(I); + RC.Language := GetLanguage(I); + RC.ModuleNum := GetModuleNumber(I); + RC.Arg1 := FieldId; + + Insert(K + 1, RC); + end; + end; + end; + end; + end; +end; + +procedure TCode.InsertTryFinally; + + procedure TestNOP(J: Integer); + begin + if Records[J].Op <> OP_NOP then + RaiseError(errInternalError, []); + end; + +var + I, J, K, Op, SubId, I1, I2, I3, L1, L2, L3, L: Integer; + HasDynVars, HasTryOn: Boolean; + + SymbolTable: TSymbolTable; + T: Integer; + LoopLabel, BreakLabel, ContinueLabel: Integer; +begin + if not TKernel(kernel).SupportedSEH then + Exit; + + SymbolTable := TKernel(kernel).SymbolTable; + + I := 0; + while I < Card do + begin + Inc(I); + Op := Records[I].Op; + if Op = OP_EPILOGUE_SUB then + begin + SubId := Records[I].Arg1; + T := GetSymbolRec(SubId).Level; + if T > 0 then + if GetSymbolRec(T).FinalTypeId = typeINTERFACE then + continue; + + J := I + 1; + HasDynVars := false; + while not((Records[J].Op = OP_END_SUB) and (Records[J].Arg1 = SubId)) do + begin + if IsDynDestr(Records[J].Op) then + HasDynVars := true; + Inc(J); + end; + + if not HasDynVars then + begin + K := J; + HasTryOn := false; + + L := GetSymbolRec(SubId).Level; + if L > 0 then + if GetSymbolRec(SubId).Kind = KindSUB then + if GetSymbolRec(L).Kind = KindTYPE then + begin + HasDynVars := true; + HasTryOn := true; + end; + + while not((Records[K].Op = OP_INIT_SUB) and + (Records[K].Arg1 = SubId)) do + begin + if Records[K].Op = OP_EXIT then + begin + if HasTryOn then + begin + HasDynVars := true; + end + else + Records[K].Op := OP_GO; + end + else if Records[K].Op = OP_RAISE then + HasDynVars := true + else if Records[K].Op = OP_TRY_OFF then + HasTryOn := true; + + Dec(K); + if K = 1 then + break; + end; + end; + + if HasDynVars then + begin + Inc(TKernel(kernel).TryCount); + + I2 := I; + I3 := J; + J := I - 1; + while not((Records[J].Op = OP_INIT_SUB) and + (Records[J].Arg1 = SubId)) do + Dec(J); + I1 := J; + + L1 := SymbolTable.AddLabel.Id; + L2 := SymbolTable.AddLabel.Id; + L3 := SymbolTable.AddLabel.Id; + + // I1 + + J := I1 + 1; + TestNOP(J); + Records[J].Op := OP_TRY_ON; + Records[J].Arg1 := TKernel(kernel).TryCount; + Records[J].Res := SubId; + + // I3, 2 nops are reserved + + J := I2; + + Inc(J); + TestNOP(J); + Records[J].Op := OP_EXCEPT_SEH; + + Inc(J); + TestNOP(J); + Records[J].Op := OP_LABEL; + Records[J].Arg1 := L1; + + Inc(J); + TestNOP(J); + Records[J].Op := OP_FINALLY; + Records[J].Arg1 := TKernel(kernel).TryCount; + Records[J].Arg2 := L1; + Records[J].Res := SubId; + + // I3, 4 nops are reserved + + J := I3 - 4; + TestNOP(J); + Records[J].Arg1 := L3; + Records[J].Res := CreateBooleanVar(SubId); + Records[J].Op := OP_COND_RAISE; + + Inc(J); + TestNOP(J); + Records[J].Op := OP_LABEL; + Records[J].Arg1 := L2; + + Inc(J); + TestNOP(J); + Records[J].Op := OP_TRY_OFF; + Records[J].Arg1 := TKernel(kernel).TryCount; + + Inc(J); + TestNOP(J); + Records[J].Op := OP_LABEL; + Records[J].Arg1 := L3; + + end + else + begin + Records[I].Op := OP_NOP; + continue; + end; + end + // loop + else if Records[I].Op = OP_EPILOGUE_LOOP then + begin + if Records[I].LoopLabel = 0 then + continue; + + Inc(TKernel(kernel).TryCount); + + LoopLabel := Records[I].LoopLabel; + BreakLabel := Records[I].BreakLabel; + ContinueLabel := Records[I].ContinueLabel; + + SubId := Records[I].Arg1; + + J := I + 1; + while not((Records[J].Op = OP_END_LOOP) and (Records[J].Arg1 = SubId)) do + Inc(J); + I3 := J; + + I2 := I; + J := I - 1; + while not((Records[J].Op = OP_BEGIN_LOOP) and + (Records[J].Arg1 = SubId)) do + Dec(J); + I1 := J; + + L1 := SymbolTable.AddLabel.Id; + L2 := SymbolTable.AddLabel.Id; + L3 := SymbolTable.AddLabel.Id; + + // I1 + + J := I1 + 1; + TestNOP(J); + Records[J].Op := OP_TRY_ON; + Records[J].Arg1 := TKernel(kernel).TryCount; + Records[J].Res := GetLevel(J); + + // I3, 2 nops are reserved + + J := I2; + + Inc(J); + TestNOP(J); + Records[J].Op := OP_EXCEPT_SEH; + + Inc(J); + TestNOP(J); + Records[J].Op := OP_LABEL; + Records[J].Arg1 := L1; + + Inc(J); + TestNOP(J); + Records[J].Op := OP_FINALLY; + Records[J].Arg1 := TKernel(kernel).TryCount; + Records[J].Arg2 := L1; + + Records[J].LoopLabel := LoopLabel; + Records[J].BreakLabel := BreakLabel; + Records[J].ContinueLabel := ContinueLabel; + + // I3, 4 nops are reserved + + J := I3 - 4; + TestNOP(J); + Records[J].Op := OP_COND_RAISE; + Records[J].Arg1 := L3; + Records[J].Res := CreateBooleanVar(0); + + Inc(J); + TestNOP(J); + Records[J].Op := OP_LABEL; + Records[J].Arg1 := L2; + + Inc(J); + TestNOP(J); + Records[J].Op := OP_TRY_OFF; + Records[J].Arg1 := TKernel(kernel).TryCount; + + Inc(J); + TestNOP(J); + Records[J].Op := OP_LABEL; + Records[J].Arg1 := L3; + + end // loop + + else if Records[I].Op = OP_EPILOGUE_GLOBAL_BLOCK then + begin + SubId := 0; + J := I + 1; + HasDynVars := false; + while not((Records[J].Op = OP_END_GLOBAL_BLOCK) and + (Records[J].Arg1 = SubId)) do + begin + if IsDynDestr(Records[J].Op) then + HasDynVars := true; + Inc(J); + end; + + if HasDynVars then + begin + Inc(TKernel(kernel).TryCount); + + I2 := I; + I3 := J; + J := I - 1; + while not((Records[J].Op = OP_BEGIN_GLOBAL_BLOCK) and + (Records[J].Arg1 = SubId)) do + Dec(J); + I1 := J; + + L1 := SymbolTable.AddLabel.Id; + L2 := SymbolTable.AddLabel.Id; + L3 := SymbolTable.AddLabel.Id; + + // I1 + + J := I1 + 1; + TestNOP(J); + Records[J].Op := OP_TRY_ON; + Records[J].Arg1 := TKernel(kernel).TryCount; + Records[J].Res := GetLevel(J); + + // I3, 2 nops are reserved + + J := I2; + + Inc(J); + TestNOP(J); + Records[J].Op := OP_EXCEPT_SEH; + + Inc(J); + TestNOP(J); + Records[J].Op := OP_LABEL; + Records[J].Arg1 := L1; + + Inc(J); + TestNOP(J); + Records[J].Op := OP_FINALLY; + Records[J].Arg1 := TKernel(kernel).TryCount; + Records[J].Arg2 := L1; + + // I3, 4 nops are reserved + + J := I3 - 4; + TestNOP(J); + Records[J].Op := OP_COND_RAISE; + Records[J].Arg1 := L3; + Records[J].Res := CreateBooleanVar(0); + + Inc(J); + TestNOP(J); + Records[J].Op := OP_LABEL; + Records[J].Arg1 := L2; + + Inc(J); + TestNOP(J); + Records[J].Op := OP_TRY_OFF; + Records[J].Arg1 := TKernel(kernel).TryCount; + + Inc(J); + TestNOP(J); + Records[J].Op := OP_LABEL; + Records[J].Arg1 := L3; + end + else + begin + Records[I].Op := OP_NOP; + continue; + end; + end; + end; +end; + +procedure TCode.AdjustTryList; +var + I, J, K, Op, OldBlockId, NewBlockId: Integer; +begin + K := 0; + for I := 1 to Card do + if Self[I].Op = OP_TRY_ON then + begin + OldBlockId := Self[I].Arg1; + NewBlockId := K; + + Inc(K); + + Self[I].Arg1 := NewBlockId; + for J := I + 1 to Card do + begin + Op := Self[J].Op; + if (Op = OP_FINALLY) or (Op = OP_EXCEPT) or (Op = OP_EXCEPT_ON) then + begin + if Self[J].Arg1 = OldBlockId then + Self[J].Arg1 := NewBlockId; + end + else if Op = OP_TRY_OFF then + begin + if Self[J].Arg1 = OldBlockId then + begin + Self[J].Arg1 := NewBlockId; + break; + end; + end; + end; + end; +end; + +procedure TCode.DiscardImport; +var + I, OpEnd: Integer; + R: TCodeRec; + Processed: Boolean; + S: String; +begin + OpEnd := 0; + + Processed := false; + Records[N].Op := OP_NOP; + + for I := N downto 1 do + begin + R := Records[I]; + if R.Op = OP_BEGIN_CONST then + begin + R.Op := OP_NOP; + Processed := true; + OpEnd := OP_END_CONST; + break; + end + else if R.Op = OP_BEGIN_VAR then + begin + R.Op := OP_NOP; + Processed := true; + OpEnd := OP_END_VAR; + break; + end + else if R.Op = OP_BEGIN_TYPE then + begin + R.Op := OP_NOP; + Processed := true; + OpEnd := OP_END_TYPE; + break; + end + else if R.Op = OP_BEGIN_SUB then + begin + R.Op := OP_NOP; + S := GetSymbolRec(R.Arg1).Name; + if PosCh('#', S) > 0 then + continue; // belongs to a procedural type declaration + + Processed := true; + OpEnd := OP_END_SUB; + break; + end + else + R.Op := OP_NOP; + end; + + if Processed then + for I := N to Card do + begin + R := Records[I]; + if R.Op = OpEnd then + begin + R.Op := OP_NOP; + break; + end + else + R.Op := OP_NOP; + end; +end; + +function TCode.AddTypeInfo(TypeId, SourceTypeId: Integer): TTypeInfoContainer; +var + SymbolTable: TBaseSymbolTable; + + LanguageId: Integer; + Upcase: Boolean; + CurrModule: Integer; + Lev: Integer; + + procedure Gen(Op, Arg1, Arg2, Res: Integer); + begin + Add(Op, Arg1, Arg2, Res, Lev, Upcase, LanguageId, CurrModule, 0); + end; + + function CreatePropReader(TypeFieldId: Integer): Integer; + var + SubId, LabelId, ResId, SelfId, ResTypeId, TempPropId, PropTypeId, + ClassTypeId: Integer; + begin + ClassTypeId := GetSymbolRec(TypeFieldId).Level; + PropTypeId := GetSymbolRec(TypeFieldId).TypeId; + ResTypeId := PropTypeId; // function + LabelId := SymbolTable.AddLabel.Id; + SubId := NewTempVar(ClassTypeId, ResTypeId); + GetSymbolRec(SubId).Name := READ_PREFIX + GetSymbolRec(TypeFieldId).Name; + GetSymbolRec(SubId).Kind := KindSUB; + GetSymbolRec(SubId).CallConv := ccREGISTER; + + ResId := NewTempVar(SubId, ResTypeId); + + SelfId := NewTempVar(SubId, ClassTypeId); + GetSymbolRec(SelfId).Param := true; + + TempPropId := NewTempVar(SubId, TypeFieldId); + GetSymbolRec(TempPropId).OwnerId := SelfId; + GetSymbolRec(TempPropId).Name := GetSymbolRec(TypeFieldId).Name; + + Gen(OP_EXTRA_BYTECODE, CurrModule, 0, 0); + + Gen(OP_GO, LabelId, 0, 0); + Gen(OP_BEGIN_SUB, SubId, 0, 0); + Gen(OP_LABEL, SubId, 0, 0); + Gen(OP_INIT_SUB, SubId, 0, 0); + // reserved for prologue + Gen(OP_NOP, 0, 0, 0); + + Gen(OP_FIELD, SelfId, TempPropId, TempPropId); + Gen(OP_ASSIGN, ResId, TempPropId, ResId); + + Gen(OP_EPILOGUE_SUB, SubId, 0, 0); + // reserved for epilogue + Gen(OP_NOP, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + + // reserved for epilogue + Gen(OP_NOP, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + Gen(OP_END_SUB, SubId, 0, 0); + Gen(OP_FIN_SUB, SubId, 0, 0); + Gen(OP_LABEL, LabelId, 0, 0); + + result := SubId; + end; + + function CreatePropWriter(TypeFieldId: Integer): Integer; + var + SubId, LabelId, ResId, SelfId, ParamId, ResTypeId, TempPropId, PropTypeId, + ClassTypeId, NP: Integer; + begin + ClassTypeId := GetSymbolRec(TypeFieldId).Level; + PropTypeId := GetSymbolRec(TypeFieldId).TypeId; + NP := 1; + ResTypeId := typeVOID; // procedure + LabelId := SymbolTable.AddLabel.Id; + SubId := NewTempVar(ClassTypeId, ResTypeId); // procedure + GetSymbolRec(SubId).Name := WRITE_PREFIX + GetSymbolRec(TypeFieldId).Name; + GetSymbolRec(SubId).Kind := KindSUB; + GetSymbolRec(SubId).CallConv := ccREGISTER; + GetSymbolRec(SubId).Count := NP; + + ResId := NewTempVar(SubId, ResTypeId); + GetSymbolRec(ResId).Kind := KindNONE; + + SelfId := NewTempVar(SubId, ClassTypeId); + GetSymbolRec(SelfId).Param := true; + + ParamId := NewTempVar(SubId, PropTypeId); + GetSymbolRec(ParamId).Param := true; + GetSymbolRec(ParamId).Name := 'value'; + GetSymbolRec(ParamId).IsConst := true; + + TempPropId := NewTempVar(SubId, TypeFieldId); + GetSymbolRec(TempPropId).OwnerId := SelfId; + GetSymbolRec(TempPropId).Name := GetSymbolRec(TypeFieldId).Name; + + Gen(OP_EXTRA_BYTECODE, CurrModule, 0, 0); + + Gen(OP_GO, LabelId, 0, 0); + Gen(OP_BEGIN_SUB, SubId, 0, 0); + Gen(OP_LABEL, SubId, 0, 0); + Gen(OP_INIT_SUB, SubId, 0, 0); + // reserved for prologue + Gen(OP_NOP, 0, 0, 0); + + Gen(OP_FIELD, SelfId, TempPropId, TempPropId); + Gen(OP_ASSIGN, TempPropId, ParamId, TempPropId); + + Gen(OP_EPILOGUE_SUB, SubId, 0, 0); + // reserved for epilogue + Gen(OP_NOP, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + + // reserved for epilogue + Gen(OP_NOP, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + Gen(OP_END_SUB, SubId, 0, 0); + Gen(OP_FIN_SUB, SubId, 0, 0); + Gen(OP_LABEL, LabelId, 0, 0); + + result := SubId; + end; + +var + TypeInfoList: TPaxTypeInfoList; + S: String; + FullName: String; + FinTypeId: Integer; + tk: TTypeKind; + ClassTypeInfoContainer: TClassTypeInfoContainer; + ClassTypeDataContainer: TClassTypeDataContainer; + MethodTypeInfoContainer: TMethodTypeInfoContainer; + MethodTypeDataContainer: TMethodTypeDataContainer; + InterfaceTypeInfoContainer: TInterfaceTypeInfoContainer; + InterfaceTypeDataContainer: TInterfaceTypeDataContainer; + SetTypeDataContainer: TSetTypeDataContainer; + EnumTypeDataContainer: TEnumTypeDataContainer; + + I, J, Id, PropId, Level, K, SubId, ResTypeId, ParamId, ParamTypeId, + NP: Integer; + RI: TSymbolRec; + AncestorTypeId: Integer; + FieldTypeId: Integer; + PatternId: Integer; + NS_ID: Integer; + b: Boolean; + pti: PTypeInfo; + val, Min_Value, Max_Value: Cardinal; + + ArrayTypeDataContainer: TArrayTypeDataContainer; + RecordTypeDataContainer: TRecordTypeDataContainer; + ProceduralTypeDataContainer: TProceduralTypeDataContainer; + RangeTypeId, ElemTypeId: Integer; + SubDesc: TSubDesc; + DGUID: packed record D1, D2: Double; +end; + +label update; +begin + result := nil; + LanguageId := GetLanguage(N); + Upcase := GetUpcase(N); + CurrModule := GetModuleNumber(N); + + SymbolTable := TKernel(kernel).SymbolTable; + TypeInfoList := TKernel(kernel).TypeInfoList; + + S := SymbolTable[TypeId].Name; + FullName := SymbolTable[TypeId].FullName; + + if TypeId <> SourceTypeId then + begin + result := TAliasTypeInfoContainer.Create(SymbolTable[SourceTypeId].Name); + result.FullName := SymbolTable[SourceTypeId].FullName; + (result.TypeDataContainer as TAliasTypeDataContainer).FullSourceTypeName + := FullName; + TypeInfoList.Add(result); + end; + + { + result := TypeInfoList.LookupFullName(FullName); + if result <> nil then + begin + Exit; + end; + } + I := TypeInfoList.IndexOf(FullName); + if I >= 0 then + TypeInfoList.RemoveAt(I); + + FinTypeId := SymbolTable[TypeId].FinalTypeId; + tk := FinTypeToTypeKind(FinTypeId); + + case tk of + tkArray: + begin + SymbolTable.GetArrayTypeInfo(TypeId, RangeTypeId, ElemTypeId); + // if (GetSymbolRec(RangeTypeId).FinalTypeId <> typeTYPEPARAM) and + // (GetSymbolRec(ElemTypeId).FinalTypeId <> typeTYPEPARAM) then + begin + AddTypeInfo(RangeTypeId, RangeTypeId); + AddTypeInfo(ElemTypeId, ElemTypeId); + + result := TArrayTypeInfoContainer.Create(S); + result.FullName := FullName; + TypeInfoList.Add(result); + + ArrayTypeDataContainer := + result.TypeDataContainer as TArrayTypeDataContainer; + ArrayTypeDataContainer.FullRangeTypeName := + GetSymbolRec(RangeTypeId).FullName; + ArrayTypeDataContainer.FullElemTypeName := + GetSymbolRec(ElemTypeId).FullName; + ArrayTypeDataContainer.FinRangeTypeId := GetSymbolRec(RangeTypeId) + .FinalTypeId; + ArrayTypeDataContainer.B1 := SymbolTable.GetLowBoundRec + (RangeTypeId).value; + ArrayTypeDataContainer.B2 := SymbolTable.GetHighBoundRec + (RangeTypeId).value; + end; + end; + tkDynarray: + begin + PatternId := GetSymbolRec(TypeId).PatternId; + + result := TDynArrayTypeInfoContainer.Create(SymbolTable[TypeId].Name); + result.FullName := FullName; + S := GetSymbolRec(PatternId).FullName; + (result.TypeDataContainer as TDynArrayTypeDataContainer) + .FullElementTypeName := S; + TypeInfoList.Add(result); + end; + tkRecord: + begin + result := TRecordTypeInfoContainer.Create(S); + TKernel(kernel).TypeDefList.CreateConainer(TypeId, + result.GenericTypeContainer); + + result.FullName := FullName; + TypeInfoList.Add(result); + + RecordTypeDataContainer := + result.TypeDataContainer as TRecordTypeDataContainer; + RecordTypeDataContainer.IsPacked := SymbolTable[TypeId].IsPacked; + for I := TypeId + 1 to SymbolTable.Card do + begin + RI := SymbolTable[I]; + if RI.Level = TypeId then + if RI.Kind = KindTYPE_FIELD then + begin + FieldTypeId := RI.TerminalTypeId; + with RecordTypeDataContainer.FieldListContainer.Add do + begin + Id := I; + // Offset := ; + // ClassIndex := ; + PShortStringFromString(@Name, RI.Name); + FullFieldTypeName := GetSymbolRec(FieldTypeId).FullName; + end; + end; + end; + end; + tkEnumeration: + begin + result := TEnumTypeInfoContainer.Create(S); + result.FullName := FullName; + TypeInfoList.Add(result); + + EnumTypeDataContainer := + result.TypeDataContainer as TEnumTypeDataContainer; + + NS_ID := GetSymbolRec(TypeId).GetNamespaceId; + if NS_ID > 0 then + PShortStringFromString(@EnumTypeDataContainer.EnumUnitName, + GetSymbolRec(NS_ID).Name) + else + PShortStringFromString(@EnumTypeDataContainer.EnumUnitName, ''); + + if FinTypeId in BooleanTypes then + begin + EnumTypeDataContainer.TypeData.OrdType := otUByte; + EnumTypeDataContainer.TypeData.MinValue := 0; + EnumTypeDataContainer.TypeData.MaxValue := 1; + SetLength(EnumTypeDataContainer.NameList, 2); + PShortStringFromString(@EnumTypeDataContainer.NameList[0], 'false'); + PShortStringFromString(@EnumTypeDataContainer.NameList[1], 'true'); + SetLength(EnumTypeDataContainer.ValueList, 2); + EnumTypeDataContainer.ValueList[0] := 0; + EnumTypeDataContainer.ValueList[1] := 1; + Exit; + end; + + EnumTypeDataContainer.TypeData.OrdType := otSLong; + + SetLength(EnumTypeDataContainer.NameList, GetSymbolRec(TypeId).Count); + SetLength(EnumTypeDataContainer.ValueList, GetSymbolRec(TypeId).Count); + + Min_Value := MaxInt; + Max_Value := 0; + + K := 0; + for I := TypeId + 1 to SymbolTable.Card do + if SymbolTable[I].Kind = KindCONST then + if SymbolTable[I].OwnerId = TypeId then + begin + PShortStringFromString(@EnumTypeDataContainer.NameList[K], + SymbolTable[I].Name); + val := SymbolTable[I].value; + EnumTypeDataContainer.ValueList[K] := val; + + if val < Min_Value then + Min_Value := val; + if val > Max_Value then + Max_Value := val; + + Inc(K); + if K >= System.Length(EnumTypeDataContainer.NameList) then + break; + end; + + EnumTypeDataContainer.TypeData.MinValue := Min_Value; + EnumTypeDataContainer.TypeData.MaxValue := Max_Value; + end; + tkSet: + begin + result := TSetTypeInfoContainer.Create(S); + result.FullName := FullName; + TypeInfoList.Add(result); + + PatternId := GetSymbolRec(TypeId).PatternId; + + if PatternId = 0 then + RaiseError(errInternalError, []); + + SetTypeDataContainer := + result.TypeDataContainer as TSetTypeDataContainer; + SetTypeDataContainer.FullCompName := GetSymbolRec(PatternId).FullName; + AddTypeInfo(PatternId, PatternId); + end; + tkInteger, tkChar, tkWChar: + begin + result := TTypeInfoContainer.Create(FinTypeId); + result.FullName := FullName; + result.TypeInfo.Kind := tk; + PShortStringFromString(@result.TypeInfo.Name, S); + TypeInfoList.Add(result); + + pti := nil; + + case FinTypeId of + typeSHORTINT: + begin + result.TypeDataContainer.TypeData.OrdType := otSByte; + pti := TypeInfo(ShortInt); + end; +{$IFNDEF PAXARM} + typeANSICHAR, +{$ENDIF} + typeBYTE: + begin + result.TypeDataContainer.TypeData.OrdType := otUByte; + pti := TypeInfo(Byte); + end; + typeSMALLINT: + begin + result.TypeDataContainer.TypeData.OrdType := otSWord; + pti := TypeInfo(SmallInt); + end; + typeWORD, typeWIDECHAR: + begin + result.TypeDataContainer.TypeData.OrdType := otUWord; + pti := TypeInfo(Word); + end; + typeINTEGER: + begin + result.TypeDataContainer.TypeData.OrdType := otSLong; + pti := TypeInfo(Integer); + end; + typeCARDINAL: + begin + result.TypeDataContainer.TypeData.OrdType := otULong; + pti := TypeInfo(Cardinal); + end; + end; + + if pti <> nil then + begin + result.TypeDataContainer.TypeData.MinValue := + GetTypeData(pti).MinValue; + result.TypeDataContainer.TypeData.MaxValue := + GetTypeData(pti).MaxValue; + end; + end; + tkString: + begin + result := TTypeInfoContainer.Create(FinTypeId); + result.FullName := FullName; + result.TypeInfo.Kind := tk; + PShortStringFromString(@result.TypeInfo.Name, S); + TypeInfoList.Add(result); + +{$IFDEF PAXARM} + RIE; +{$ELSE} + result.TypeDataContainer.TypeData.MaxLength := + SymbolTable[TypeId].Count; +{$ENDIF} + end; + tkInt64: + begin + result := TTypeInfoContainer.Create(FinTypeId); + result.FullName := FullName; + result.TypeInfo.Kind := tk; + PShortStringFromString(@result.TypeInfo.Name, S); + TypeInfoList.Add(result); + + pti := TypeInfo(Int64); + result.TypeDataContainer.TypeData.MinInt64Value := GetTypeData(pti) + ^.MinInt64Value; + result.TypeDataContainer.TypeData.MaxInt64Value := GetTypeData(pti) + ^.MaxInt64Value; + end; + tkFloat: + begin + result := TTypeInfoContainer.Create(FinTypeId); + result.FullName := FullName; + result.TypeInfo.Kind := tk; + PShortStringFromString(@result.TypeInfo.Name, S); + TypeInfoList.Add(result); + + case FinTypeId of + typeSINGLE: + result.TypeDataContainer.TypeData.FloatType := ftSingle; + typeDOUBLE: + result.TypeDataContainer.TypeData.FloatType := ftDouble; + typeEXTENDED: + result.TypeDataContainer.TypeData.FloatType := ftExtended; + typeCURRENCY: + result.TypeDataContainer.TypeData.FloatType := ftCurr; + end; + end; + tkMethod: + begin + result := TMethodTypeInfoContainer.Create(S); + result.FullName := FullName; + TypeInfoList.Add(result); + + MethodTypeInfoContainer := TMethodTypeInfoContainer(result); + SubId := GetSymbolRec(TypeId).PatternId; + + if GetSymbolRec(SubId).Kind <> KindSUB then + RaiseError(errInternalError, []); + + MethodTypeDataContainer := TMethodTypeDataContainer + (MethodTypeInfoContainer.TypeDataContainer); + MethodTypeDataContainer.ResultTypeId := GetSymbolRec(SubId).TypeId; + MethodTypeDataContainer.CallConv := GetSymbolRec(SubId).CallConv; + MethodTypeDataContainer.OverCount := GetSymbolRec(SubId).OverCount; + + if GetSymbolRec(SubId).TypeId = typeVOID then + begin + if GetSymbolRec(SubId).IsSharedMethod then + MethodTypeDataContainer.MethodKind := mkClassProcedure + else + MethodTypeDataContainer.MethodKind := mkProcedure; + end + else + begin + if GetSymbolRec(SubId).IsSharedMethod then + MethodTypeDataContainer.MethodKind := mkClassFunction + else + MethodTypeDataContainer.MethodKind := mkFunction; + end; + + NP := GetSymbolRec(SubId).Count; + MethodTypeDataContainer.ParamCount := NP; + + ResTypeId := GetSymbolRec(SubId).TypeId; + if ResTypeId = typeVOID then + PShortStringFromString(@MethodTypeDataContainer.ResultType, '') + else + PShortStringFromString(@MethodTypeDataContainer.ResultType, + GetSymbolRec(ResTypeId).Name); + + SetLength(MethodTypeDataContainer.ParamListContainer.ParamList, NP); + + for I := 0 to NP - 1 do + begin + ParamId := SymbolTable.GetParamId(SubId, I); + ParamTypeId := GetSymbolRec(ParamId).TypeId; + PShortStringFromString + (@MethodTypeDataContainer.ParamListContainer.ParamList[I].ParamName, + GetSymbolRec(ParamId).Name); + PShortStringFromString + (@MethodTypeDataContainer.ParamListContainer.ParamList[I].TypeName, + GetSymbolRec(ParamTypeId).Name); + MethodTypeDataContainer.ParamListContainer.ParamList[I].Flags := []; + if GetSymbolRec(ParamId).ByRef then + MethodTypeDataContainer.ParamListContainer.ParamList[I].Flags := + MethodTypeDataContainer.ParamListContainer.ParamList[I].Flags + + [pfVar]; + if GetSymbolRec(ParamId).IsConst then + MethodTypeDataContainer.ParamListContainer.ParamList[I].Flags := + MethodTypeDataContainer.ParamListContainer.ParamList[I].Flags + + [pfConst]; + end; + end; + tkInterface: + begin + result := TInterfaceTypeInfoContainer.Create(S); + result.FullName := FullName; + TypeInfoList.Add(result); + InterfaceTypeInfoContainer := TInterfaceTypeInfoContainer(result); + + Level := SymbolTable[TypeId].Level; + if Level > 0 then + PShortStringFromString + (@InterfaceTypeInfoContainer.TypeDataContainer.TypeData.IntfUnit, + SymbolTable[Level].Name); + + InterfaceTypeDataContainer := + InterfaceTypeInfoContainer.TypeDataContainer as + TInterfaceTypeDataContainer; + + DGUID.D1 := SymbolTable[TypeId + 1].value; + DGUID.D2 := SymbolTable[TypeId + 2].value; + Move(DGUID, InterfaceTypeDataContainer.GUID, SizeOf(TGUID)); + + InterfaceTypeDataContainer.TypeData.IntfFlags := [ifHasGuid]; + + b := SymbolTable[TypeId].SupportedInterfaces <> nil; + if b then + b := SymbolTable[TypeId].SupportedInterfaces.Count > 0; + + if b then + begin + AncestorTypeId := SymbolTable[TypeId].SupportedInterfaces[0].Id; + InterfaceTypeDataContainer.FullParentName := SymbolTable[AncestorTypeId].FullName; + InterfaceTypeDataContainer.TypeData.GUID := SymbolTable[TypeId].SupportedInterfaces[0].GUID; + + end + else + begin + if StrEql(SymbolTable[TypeId].Name, 'IUnknown') then + begin + InterfaceTypeDataContainer.FullParentName := ''; + end + else + begin + InterfaceTypeDataContainer.FullParentName := 'IUnknown'; + InterfaceTypeDataContainer.TypeData.GUID := IUnknown; + end; + end; + + for I := TypeId + 1 to SymbolTable.Card do + begin + RI := SymbolTable[I]; + // if RI.IsPublished then + if RI.Level = TypeId then + begin + if RI.Kind = KindPROP then + begin + PropId := I; + + Inc(InterfaceTypeDataContainer.PropDataContainer.PropData. + PropCount); + K := InterfaceTypeDataContainer.PropDataContainer. + PropData.PropCount; + SetLength(InterfaceTypeDataContainer.PropDataContainer. + PropList, K); + SetLength(InterfaceTypeDataContainer.PropDataContainer. + PropTypeIds, K); + PShortStringFromString + (@InterfaceTypeDataContainer.PropDataContainer.PropList[K - 1] + .Name, SymbolTable[PropId].Name); + + Id := SymbolTable[PropId].ReadId; + + if Id > 0 then + S := SymbolTable[Id].FullName + else + S := ''; + InterfaceTypeDataContainer.PropDataContainer.ReadNames.Add(S); + + Id := SymbolTable[PropId].WriteId; + + if Id > 0 then + S := SymbolTable[Id].FullName + else + S := ''; + InterfaceTypeDataContainer.PropDataContainer.WriteNames.Add(S); + + Id := SymbolTable[PropId].TypeId; + if Id > 0 then + S := SymbolTable[Id].FullName + else + S := ''; + InterfaceTypeDataContainer.PropDataContainer.PropTypeNames.Add(S); + end // add interface property + else if RI.Kind = KindSUB then + begin + PatternId := I; + SubDesc := InterfaceTypeDataContainer.SubDescList.AddRecord; + SubDesc.CallConv := GetSymbolRec(PatternId).CallConv; + SubDesc.ResTypeName := + GetSymbolRec(GetSymbolRec(PatternId).TypeId).Name; + SubDesc.ResTypeId := GetSymbolRec(PatternId).FinalTypeId; + SubDesc.SubName := GetSymbolRec(PatternId).Name; + NP := GetSymbolRec(PatternId).Count; + for J := 0 to NP - 1 do + begin + ParamId := SymbolTable.GetParamId(PatternId, J); + with SubDesc.ParamList.AddRecord do + begin + ParamName := GetSymbolRec(ParamId).Name; + ParamTypeName := + GetSymbolRec(GetSymbolRec(ParamId).TypeId).Name; + + if SymbolTable[ParamId].FinalTypeId + in [typeDYNARRAY, typeOPENARRAY] then + if SymbolTable[ParamId].IsOpenArray then + begin + ParamTypeId := SymbolTable[ParamId].TerminalTypeId; + ElemTypeId := SymbolTable[ParamTypeId].PatternId; + ParamTypeName := 'array of ' + SymbolTable + [ElemTypeId].Name; + end; + + if SymbolTable[ParamId].ByRef then + ParamMod := PM_BYREF + else if SymbolTable[ParamId].IsConst then + ParamMod := PM_CONST + else + ParamMod := PM_BYVAL; + + if SymbolTable[ParamId].Optional then + OptValue := + VariantToString(SymbolTable[ParamId].FinalTypeId, + SymbolTable[ParamId].value); + end; + end; + end; // RI.Kind = kindSUB + end; + end; + end; + tkClass: + begin + if GetSymbolRec(TypeId).Host then + Exit; + + result := TClassTypeInfoContainer.Create(S); + TKernel(kernel).TypeDefList.CreateConainer(TypeId, + result.GenericTypeContainer); + + result.FullName := FullName; + TypeInfoList.Add(result); + ClassTypeInfoContainer := TClassTypeInfoContainer(result); + + Level := SymbolTable[TypeId].Level; + if Level > 0 then + PShortStringFromString + (@ClassTypeInfoContainer.TypeDataContainer.TypeData.UnitName, + SymbolTable[Level].Name); + ClassTypeDataContainer := ClassTypeInfoContainer.TypeDataContainer as + TClassTypeDataContainer; + + if GetSymbolRec(TypeId).SupportedInterfaces <> nil then + for I := 0 to GetSymbolRec(TypeId).SupportedInterfaces.Count - 1 do + begin + Id := GetSymbolRec(TypeId).SupportedInterfaces[I].Id; + ClassTypeDataContainer.SupportedInterfaces.Add + (GetSymbolRec(Id).Name); + end; + + ClassTypeDataContainer.FieldTableCount := 0; + ClassTypeDataContainer.FieldTableSize := SizeOf(Word); + +{$IFDEF ARC} + Inc(ClassTypeDataContainer.FieldTableSize, SizeOfPointer); +{$ELSE} +{$IFDEF WIN32} + Inc(ClassTypeDataContainer.FieldTableSize, SizeOfPointer); +{$ELSE} + Inc(ClassTypeDataContainer.FieldTableSize, SizeOf(Word)); +{$ENDIF}; + +{$ENDIF} + ClassTypeDataContainer.MethodTableCount := 0; + ClassTypeDataContainer.MethodTableSize := SizeOf(TVmtMethodCount); + + AncestorTypeId := SymbolTable[TypeId].AncestorId; + + ClassTypeDataContainer.FullParentName := + SymbolTable[AncestorTypeId].FullName; + + for I := TypeId + 1 to SymbolTable.Card do + begin + RI := SymbolTable[I]; + update: + if RI.IsPublished then + begin + if RI.Level = TypeId then + if RI.Kind = KindPROP then + begin + PropId := I; + + Inc(ClassTypeInfoContainer.TypeDataContainer.TypeData. + PropCount); + Inc(ClassTypeDataContainer.PropDataContainer.PropData. + PropCount); + K := ClassTypeDataContainer.PropDataContainer.PropData. + PropCount; + SetLength(ClassTypeDataContainer.PropDataContainer.PropList, K); + SetLength(ClassTypeDataContainer.PropDataContainer. + PropTypeIds, K); + PShortStringFromString + (@ClassTypeDataContainer.PropDataContainer.PropList[K - 1] + .Name, SymbolTable[PropId].Name); + + Id := SymbolTable[PropId].ReadId; + + if SymbolTable[Id].Kind = KindTYPE_FIELD then + Id := CreatePropReader(Id); + + if Id > 0 then + S := SymbolTable[Id].FullName + else + S := ''; + ClassTypeDataContainer.PropDataContainer.ReadNames.Add(S); + + Id := SymbolTable[PropId].WriteId; + + if SymbolTable[Id].Kind = KindTYPE_FIELD then + Id := CreatePropWriter(Id); + + if Id > 0 then + S := SymbolTable[Id].FullName + else + S := ''; + ClassTypeDataContainer.PropDataContainer.WriteNames.Add(S); + + Id := SymbolTable[PropId].TerminalTypeId; + if Id > 0 then + S := SymbolTable[Id].FullName + else + S := ''; + ClassTypeDataContainer.PropDataContainer.PropTypeNames.Add(S); + end // add published property + else if RI.Kind in kindSUBS then + begin + Inc(ClassTypeDataContainer.MethodTableCount); +{$IFDEF FPC} + Inc(ClassTypeDataContainer.MethodTableSize, SizeOf(TVmtMethod)); +{$ELSE} + Inc(ClassTypeDataContainer.MethodTableSize, SizeOf(Word)); + // Size + Inc(ClassTypeDataContainer.MethodTableSize, SizeOfPointer + + // Address + Length(RI.Name) + 1); // Name +{$ENDIF} + MethodTypeInfoContainer := + TMethodTypeInfoContainer.Create(RI.Name); + MethodTypeInfoContainer.FullName := RI.FullName; + TypeInfoList.Add(MethodTypeInfoContainer); + + SubId := I; + + MethodTypeDataContainer := + TMethodTypeDataContainer + (MethodTypeInfoContainer.TypeDataContainer); + MethodTypeDataContainer.MethodTableIndex := + ClassTypeDataContainer.MethodTableCount - 1; + + MethodTypeDataContainer.OwnerTypeName := + GetSymbolRec(TypeId).FullName; + + MethodTypeDataContainer.OverCount := GetSymbolRec(SubId) + .OverCount; + + if GetSymbolRec(SubId).TypeId = typeVOID then + begin + if GetSymbolRec(SubId).IsSharedMethod then + MethodTypeDataContainer.MethodKind := mkClassProcedure + else + MethodTypeDataContainer.MethodKind := mkProcedure; + end + else + begin + if GetSymbolRec(SubId).IsSharedMethod then + MethodTypeDataContainer.MethodKind := mkClassFunction + else + MethodTypeDataContainer.MethodKind := mkFunction; + end; + + NP := GetSymbolRec(SubId).Count; + MethodTypeDataContainer.ParamCount := NP; + + ResTypeId := GetSymbolRec(SubId).TypeId; + if ResTypeId = typeVOID then + PShortStringFromString + (@MethodTypeDataContainer.ResultType, '') + else + PShortStringFromString(@MethodTypeDataContainer.ResultType, + GetSymbolRec(ResTypeId).Name); + + SetLength(MethodTypeDataContainer.ParamListContainer. + ParamList, NP); + + for J := 0 to NP - 1 do + begin + ParamId := SymbolTable.GetParamId(SubId, J); + ParamTypeId := GetSymbolRec(ParamId).TypeId; + PShortStringFromString + (@MethodTypeDataContainer.ParamListContainer.ParamList[J] + .ParamName, GetSymbolRec(ParamId).Name); + PShortStringFromString + (@MethodTypeDataContainer.ParamListContainer.ParamList[J] + .TypeName, GetSymbolRec(ParamTypeId).Name); + MethodTypeDataContainer.ParamListContainer.ParamList[J] + .Flags := []; + if GetSymbolRec(ParamId).ByRef then + MethodTypeDataContainer.ParamListContainer.ParamList[J] + .Flags := MethodTypeDataContainer.ParamListContainer. + ParamList[J].Flags + [pfVar]; + if GetSymbolRec(ParamId).IsConst then + MethodTypeDataContainer.ParamListContainer.ParamList[J] + .Flags := MethodTypeDataContainer.ParamListContainer. + ParamList[J].Flags + [pfConst]; + end; + end // add published method + else if RI.Kind = KindTYPE_FIELD then + begin + if RI.FinalTypeId <> typeCLASS then + begin + RI.Vis := cvPublic; + goto update; + // continue; + end; + Inc(ClassTypeDataContainer.FieldTableCount); + + Inc(ClassTypeDataContainer.FieldTableSize, SizeOf(Cardinal) + + // Offset + SizeOf(Word) + // ClassIndex + Length(RI.Name) + 1); // Name + + FieldTypeId := RI.TerminalTypeId; + + with ClassTypeDataContainer.FieldListContainer.Add do + begin + Id := I; + // Offset := ; + ClassIndex := ClassTypeDataContainer.FieldTableCount - 1; + PShortStringFromString(@Name, RI.Name); + FullFieldTypeName := GetSymbolRec(FieldTypeId).FullName; + end; + end; + end // published members + else if RI.Vis in [cvPrivate, cvStrictPrivate, cvProtected, + cvStrictProtected, cvPublic] then + begin + if RI.Level = TypeId then + begin + if RI.Kind = KindTYPE_FIELD then + begin + FieldTypeId := RI.TerminalTypeId; + with ClassTypeDataContainer.AnotherFieldListContainer.Add do + begin + Vis := RI.Vis; // PCU only + Id := I; + // Offset := ; + // ClassIndex := ; + PShortStringFromString(@Name, RI.Name); + FullFieldTypeName := GetSymbolRec(FieldTypeId).FullName; + end; + end // another fields + else if RI.Kind = KindPROP then + begin + // PCU only + with ClassTypeDataContainer.AnotherPropList.Add do + begin + PropId := I; + Vis := RI.Vis; + PropName := RI.Name; + if GetSymbolRec(PropId).Count > 0 then + for J := 0 to GetSymbolRec(PropId).Count - 1 do + begin + ParamId := SymbolTable.GetParamId(PropId, J); + ParamNames.Add(GetSymbolRec(ParamId).Name); + ParamTypes.Add + (GetSymbolRec(GetSymbolRec(ParamId).TypeId).Name); + end; + PropType := GetSymbolRec(RI.TypeId).Name; + ReadName := GetSymbolRec(RI.ReadId).Name; + WriteName := GetSymbolRec(RI.WriteId).Name; + IsDefault := RI.IsDefault; + end; + end; + end; + end; // another members + end; // for-loop + end // tkClass + else + begin + case FinTypeId of + typePOINTER: + begin + PatternId := GetSymbolRec(TypeId).PatternId; + + result := TPointerTypeInfoContainer.Create + (SymbolTable[TypeId].Name); + result.FullName := FullName; + (result.TypeDataContainer as TPointerTypeDataContainer) + .FullOriginTypeName := GetSymbolRec(PatternId).FullName; + TypeInfoList.Add(result); + end; + typeCLASSREF: + begin + PatternId := GetSymbolRec(TypeId).PatternId; + + result := TClassRefTypeInfoContainer.Create + (SymbolTable[TypeId].Name); + result.FullName := FullName; + S := GetSymbolRec(PatternId).FullName; + (result.TypeDataContainer as TClassRefTypeDataContainer) + .FullOriginTypeName := S; + TypeInfoList.Add(result); + end; + typePROC: + begin + PatternId := GetSymbolRec(TypeId).PatternId; + + result := TProceduralTypeInfoContainer.Create + (SymbolTable[TypeId].Name); + result.FullName := FullName; + ProceduralTypeDataContainer := + result.TypeDataContainer as TProceduralTypeDataContainer; + with ProceduralTypeDataContainer do + begin + SubDesc.CallConv := GetSymbolRec(PatternId).CallConv; + SubDesc.ResTypeName := + GetSymbolRec(GetSymbolRec(PatternId).TypeId).Name; + SubDesc.ResTypeId := GetSymbolRec(PatternId).FinalTypeId; + NP := GetSymbolRec(PatternId).Count; + for J := 0 to NP - 1 do + begin + ParamId := SymbolTable.GetParamId(PatternId, J); + with SubDesc.ParamList.AddRecord do + begin + ParamName := GetSymbolRec(ParamId).Name; + ParamTypeName := + GetSymbolRec(GetSymbolRec(ParamId).TypeId).Name; + + if SymbolTable[ParamId].FinalTypeId + in [typeDYNARRAY, typeOPENARRAY] then + if SymbolTable[ParamId].IsOpenArray then + begin + ParamTypeId := SymbolTable[ParamId].TerminalTypeId; + ElemTypeId := SymbolTable[ParamTypeId].PatternId; + ParamTypeName := 'array of ' + SymbolTable + [ElemTypeId].Name; + end; + + if SymbolTable[ParamId].ByRef then + ParamMod := PM_BYREF + else if SymbolTable[ParamId].IsConst then + ParamMod := PM_CONST + else + ParamMod := PM_BYVAL; + + if SymbolTable[ParamId].Optional then + OptValue := + VariantToString(SymbolTable[ParamId].FinalTypeId, + SymbolTable[ParamId].value); + end; + end; + end; + + TypeInfoList.Add(result); + end; // typePROC + else + begin + result := TTypeInfoContainer.Create(FinTypeId); + result.FullName := FullName; + result.TypeInfo.Kind := tk; + PShortStringFromString(@result.TypeInfo.Name, S); + TypeInfoList.Add(result); + end; + end; // case + end; + end; +end; + +procedure TCode.OperDetermineProp; +var + Id, PropId, ReadId, WriteId, ClassId, TypeId: Integer; + SymbolTable: TSymbolTable; + S: String; +begin + SymbolTable := TKernel(kernel).SymbolTable; + PropId := Records[N].Arg1; + S := GetSymbolRec(PropId).Name; + + ClassId := GetSymbolRec(PropId).Level; + + repeat + ClassId := GetSymbolRec(ClassId).AncestorId; + if ClassId = 0 then + RaiseError(errInternalError, []); + + Id := SymbolTable.LookUp(S, ClassId, GetUpcase(N)); + if Id > 0 then + begin + TypeId := GetSymbolRec(Id).TypeId; + ReadId := GetSymbolRec(Id).ReadId; + WriteId := GetSymbolRec(Id).WriteId; + if (ReadId > 0) or (WriteId > 0) then + begin + GetSymbolRec(PropId).ReadId := ReadId; + GetSymbolRec(PropId).WriteId := WriteId; + if GetSymbolRec(TypeId).Kind = KindTYPE then + begin + GetSymbolRec(PropId).TypeId := TypeId; + Records[N].Op := OP_NOP; + end + else + RaiseError(errInternalError, []); + + // GetSymbolRec(PropId).PatternId := Id; + break; + end; + end; + until false; +end; + +procedure TCode.OperSetReadId; +var + PropId, ReadId: Integer; + SymbolTable: TSymbolTable; + I, K, ParamId1, ParamId2, T1, T2: Integer; +begin + SymbolTable := TKernel(kernel).SymbolTable; + PropId := Records[N].Arg1; + ReadId := Records[N].Arg2; + T1 := SymbolTable[PropId].TypeId; + T2 := SymbolTable[ReadId].TypeId; + + GetSymbolRec(PropId).ReadId := ReadId; + + if GetSymbolRec(ReadId).Kind = KindTYPE_FIELD then + begin + if T1 <> T2 then + RaiseError(errIncompatibleTypesNoArgs, []); + Records[N].Op := OP_NOP; + Exit; + end; + + if GetSymbolRec(ReadId).Kind <> KindSUB then + RaiseError(errIncompatibleTypesNoArgs, []); + + K := GetSymbolRec(PropId).Count; + if K <> GetSymbolRec(ReadId).Count then + RaiseError(errIncompatibleTypesNoArgs, []); + + if T1 <> T2 then + RaiseError(errIncompatibleTypesNoArgs, []); + + for I := 0 to K - 1 do + begin + ParamId1 := SymbolTable.GetParamId(PropId, I); + ParamId2 := SymbolTable.GetParamId(ReadId, I); + T1 := SymbolTable[ParamId1].TypeId; + T2 := SymbolTable[ParamId2].TypeId; + if T1 <> T2 then + RaiseError(errIncompatibleTypesNoArgs, []); + end; + Records[N].Op := OP_NOP; +end; + +procedure TCode.OperSetWriteId; +var + PropId, WriteId: Integer; + SymbolTable: TSymbolTable; + I, K, ParamId1, ParamId2, T1, T2: Integer; +begin + SymbolTable := TKernel(kernel).SymbolTable; + PropId := Records[N].Arg1; + WriteId := Records[N].Arg2; + + GetSymbolRec(PropId).WriteId := WriteId; + + if GetSymbolRec(WriteId).Kind = KindTYPE_FIELD then + begin + T1 := SymbolTable[PropId].TypeId; + T2 := SymbolTable[WriteId].TypeId; + if T1 <> T2 then + RaiseError(errIncompatibleTypesNoArgs, []); + Records[N].Op := OP_NOP; + Exit; + end; + + if GetSymbolRec(WriteId).Kind <> KindSUB then + RaiseError(errIncompatibleTypesNoArgs, []); + + K := GetSymbolRec(PropId).Count; + if K + 1 <> GetSymbolRec(WriteId).Count then + RaiseError(errIncompatibleTypesNoArgs, []); + + T1 := typeVOID; + T2 := SymbolTable[WriteId].TypeId; + if T1 <> T2 then + RaiseError(errIncompatibleTypesNoArgs, []); + + for I := 0 to K - 1 do + begin + ParamId1 := SymbolTable.GetParamId(PropId, I); + ParamId2 := SymbolTable.GetParamId(WriteId, I); + T1 := SymbolTable[ParamId1].TypeId; + T2 := SymbolTable[ParamId2].TypeId; + if T1 <> T2 then + RaiseError(errIncompatibleTypesNoArgs, []); + end; + + T1 := SymbolTable[PropId].TypeId; + ParamId2 := SymbolTable.GetParamId(WriteId, K); + T2 := SymbolTable[ParamId2].TypeId; + if T1 <> T2 then + RaiseError(errIncompatibleTypesNoArgs, []); + + Records[N].Op := OP_NOP; +end; + +procedure TCode.OperFrameworkOn; +begin + TKernel(kernel).IsFramework := true; +end; + +procedure TCode.OperFrameworkOff; +begin + TKernel(kernel).IsFramework := false; +end; + +procedure TCode.OperToFWObject; +var + FinTypeId, ClassId: Integer; + R: TCodeRec; + aSymb: TSymbolRec; +begin + R := Records[N]; + aSymb := GetSymbolRec(R.Arg1); + FinTypeId := aSymb.FinalTypeId; + ClassId := 0; + + case FinTypeId of + typeBOOLEAN: + ClassId := H_TFW_Boolean; + typeBYTEBOOL: + ClassId := H_TFW_ByteBool; + typeWORDBOOL: + ClassId := H_TFW_WordBool; + typeLONGBOOL: + ClassId := H_TFW_LongBool; + typeBYTE: + ClassId := H_TFW_Byte; + typeSMALLINT: + ClassId := H_TFW_SmallInt; + typeSHORTINT: + ClassId := H_TFW_ShortInt; + typeWORD: + ClassId := H_TFW_Word; + typeCARDINAL: + ClassId := H_TFW_Cardinal; + typeDOUBLE: + begin + if aSymb.TypeId = Id_TDateTime then + ClassId := H_TFW_DateTime + else + ClassId := H_TFW_Double; + end; + typeSINGLE: + ClassId := H_TFW_Single; + typeEXTENDED: + ClassId := H_TFW_Extended; + typeCURRENCY: + ClassId := H_TFW_Currency; +{$IFNDEF PAXARM} + typeANSICHAR: + ClassId := H_TFW_AnsiChar; + typeANSISTRING: + ClassId := H_TFW_AnsiString; +{$ENDIF} + typeWIDECHAR: + ClassId := H_TFW_WideChar; + typeINTEGER: + ClassId := H_TFW_Integer; + typeINT64: + ClassId := H_TFW_Int64; + typeVARIANT: + ClassId := H_TFW_Variant; + typeUNICSTRING: + ClassId := H_TFW_UnicString; + else + begin +{$IFNDEF PAXARM} + if aSymb.HasPAnsiCharType then + ClassId := H_TFW_AnsiString + else +{$ENDIF} + if aSymb.HasPWideCharType then + ClassId := H_TFW_UnicString + else + RaiseError(errRecordRequired, []); + end; + end; + + if ClassId = 0 then + RaiseError(errRecordRequired, []); + + GetSymbolRec(R.Res).TypeId := ClassId; +end; + +procedure TCode.OperGetEnumerator; +var + SymbolTable: TSymbolTable; + I, break_label_id, continue_label_id, collection_id, enumerator_id, + element_id, element_TypeId, bool_id, collection_TypeId, + collection_FinTypeId, RangeTypeId, ElemTypeId, ForInCounter, B1, B2, T, + temp, element_count, ElemSizeId, PointerTypeId, PointerVarId, N_MOVE_NEXT, + N_CURRENT, N_LOCK_VARRAY, N_UNLOCK_VARRAY: Integer; + S: String; +begin + SymbolTable := TKernel(kernel).SymbolTable; + continue_label_id := 0; + break_label_id := 0; + collection_id := Records[N].Arg1; + enumerator_id := 0; + element_id := 0; + bool_id := 0; + collection_FinTypeId := GetSymbolRec(collection_id).FinalTypeId; + collection_TypeId := GetSymbolRec(collection_id).TerminalTypeId; + element_TypeId := GetSymbolRec(element_id).TerminalTypeId; + ForInCounter := Records[N].Arg2; + N_MOVE_NEXT := 0; + N_CURRENT := 0; + N_LOCK_VARRAY := 0; + N_UNLOCK_VARRAY := 0; + for I := N - 1 to Card do + if (Records[I].Op = OP_MOVE_NEXT) and (Records[I].Arg2 = ForInCounter) then + begin + N_MOVE_NEXT := I; + bool_id := Records[I].Res; + GetSymbolRec(bool_id).TypeId := typeBOOLEAN; + end + else if (Records[I].Op = OP_CURRENT) and (Records[I].Arg2 = ForInCounter) + then + begin + enumerator_id := Records[I].Arg1; + element_id := Records[I].Res; + N_CURRENT := I; + end + else if (Records[I].Op = OP_LABEL) and (Records[I].Arg2 = ForInCounter) then + begin + continue_label_id := Records[I].Arg1; + end + else if (Records[I].Op = OP_LABEL) and (Records[I].Res = ForInCounter) then + begin + break_label_id := Records[I].Arg1; + end + else if (Records[I].Op = OP_LOCK_VARRAY) and (Records[I].Arg2 = ForInCounter) + then + begin + N_LOCK_VARRAY := I; + if not(collection_FinTypeId in [typeVARIANT, typeOLEVARIANT]) then + Records[I].Op := OP_NOP; + end + else if (Records[I].Op = OP_UNLOCK_VARRAY) and + (Records[I].Arg2 = ForInCounter) then + begin + N_UNLOCK_VARRAY := I; + if not(collection_FinTypeId in [typeVARIANT, typeOLEVARIANT]) then + Records[I].Op := OP_NOP; + break; + end; + + if (N_MOVE_NEXT = 0) or (N_CURRENT = 0) then + RaiseError(errInternalError, []); + + if (break_label_id = 0) or (continue_label_id = 0) then + RaiseError(errInternalError, []); + + if collection_FinTypeId = typeCLASS then + if GetSymbolRec(collection_id).IsFWArrayVar then + collection_FinTypeId := typeDYNARRAY; + + case collection_FinTypeId of + typeCLASS: + begin + temp := NewField('GetEnumerator', 0, collection_id); + + Records[N].Op := OP_FIELD; + Records[N].Arg1 := collection_id; + Records[N].Arg2 := temp; + Records[N].Res := temp; + + Records[N + 1].Op := OP_ASSIGN; + Records[N + 1].GenOp := OP_ASSIGN; + Records[N + 1].Arg1 := enumerator_id; + Records[N + 1].Arg2 := temp; + Records[N + 1].Res := enumerator_id; + + temp := NewField('MoveNext', typeBOOLEAN, enumerator_id); + + Records[N + 2].Op := OP_FIELD; + Records[N + 2].Arg1 := enumerator_id; + Records[N + 2].Arg2 := temp; + Records[N + 2].Res := temp; + + Records[N + 3].Op := OP_GO_FALSE; + Records[N + 3].Arg1 := break_label_id; + Records[N + 3].Arg2 := temp; + Records[N + 3].Res := 0; + + temp := NewField('Current', ElemTypeId, enumerator_id); + + Records[N_CURRENT].Op := OP_FIELD; + Records[N_CURRENT].Arg1 := enumerator_id; + Records[N_CURRENT].Arg2 := temp; + Records[N_CURRENT].Res := temp; + + Records[N_CURRENT + 1].Op := OP_ASSIGN; + Records[N_CURRENT + 1].GenOp := OP_ASSIGN; + Records[N_CURRENT + 1].Arg1 := element_id; + Records[N_CURRENT + 1].Arg2 := temp; + Records[N_CURRENT + 1].Res := element_id; + + temp := NewField('MoveNext', typeBOOLEAN, enumerator_id); + + Records[N_MOVE_NEXT].Op := OP_FIELD; + Records[N_MOVE_NEXT].Arg1 := enumerator_id; + Records[N_MOVE_NEXT].Arg2 := temp; + Records[N_MOVE_NEXT].Res := temp; + + Records[N_MOVE_NEXT + 1].Op := OP_ASSIGN; + Records[N_MOVE_NEXT + 1].GenOp := OP_ASSIGN; + Records[N_MOVE_NEXT + 1].Arg1 := bool_id; + Records[N_MOVE_NEXT + 1].Arg2 := temp; + Records[N_MOVE_NEXT + 1].Res := bool_id; + + Dec(N); + end; + typeVARIANT, typeOLEVARIANT: + begin + if (N_LOCK_VARRAY = 0) or (N_UNLOCK_VARRAY = 0) then + RaiseError(errInternalError, []); + + RangeTypeId := typeINTEGER; + GetSymbolRec(enumerator_id).TypeId := RangeTypeId; + B1 := CreateConst(typeINTEGER, 0); + B2 := CreateIntegerVar(GetLevel(N)); + + ElemSizeId := CreateConst(typeINTEGER, SizeOf(Variant)); + + temp := NewTempVar(GetLevel(N), typeVARIANT); + PointerVarId := NewTempVar(GetLevel(N), H_PVARIANT); + + Records[N_LOCK_VARRAY].Res := PointerVarId; + Records[N_UNLOCK_VARRAY].Res := PointerVarId; + + Records[N].Op := OP_ASSIGN; + Records[N].GenOp := OP_ASSIGN; + Records[N].Arg1 := enumerator_id; + Records[N].Arg2 := B1; + Records[N].Res := enumerator_id; + + Records[N + 1].Op := OP_PUSH; + Records[N + 1].Arg1 := collection_id; + Records[N + 1].Arg2 := 0; + Records[N + 1].Res := Id_VariantArrayLength; + + Records[N + 2].Op := OP_CALL; + Records[N + 2].Arg1 := Id_VariantArrayLength; + Records[N + 2].Arg2 := 1; + Records[N + 2].Res := B2; + + Records[N + 3].Op := OP_MINUS; + Records[N + 3].Arg1 := B2; + Records[N + 3].Arg2 := CreateConst(typeINTEGER, 1); + Records[N + 3].Res := B2; + + Records[N_CURRENT].Op := OP_TERMINAL; + Records[N_CURRENT].Arg1 := PointerVarId; + Records[N_CURRENT].Arg2 := 0; + Records[N_CURRENT].Res := temp; + + Records[N_CURRENT + 1].Op := OP_ASSIGN; + Records[N_CURRENT + 1].GenOp := OP_ASSIGN; + Records[N_CURRENT + 1].Arg1 := element_id; + Records[N_CURRENT + 1].Arg2 := temp; + Records[N_CURRENT + 1].Res := element_id; + + Records[N_MOVE_NEXT].Op := OP_INC; + Records[N_MOVE_NEXT].Arg1 := enumerator_id; + Records[N_MOVE_NEXT].Arg2 := CreateConst(typeINTEGER, 1); + Records[N_MOVE_NEXT].Res := enumerator_id; + + Records[N_MOVE_NEXT + 1].Op := OP_LE; + Records[N_MOVE_NEXT + 1].Arg1 := enumerator_id; + Records[N_MOVE_NEXT + 1].Arg2 := B2; + Records[N_MOVE_NEXT + 1].Res := bool_id; + + Records[N_MOVE_NEXT + 2].Op := OP_ADD_INT_MM; + Records[N_MOVE_NEXT + 2].Arg1 := PointerVarId; + Records[N_MOVE_NEXT + 2].Arg2 := ElemSizeId; + Records[N_MOVE_NEXT + 2].Res := PointerVarId; + + Dec(N); + end; + typeARRAY: + begin + SymbolTable.GetArrayTypeInfo(collection_TypeId, RangeTypeId, + ElemTypeId); + if GetSymbolRec(ElemTypeId).FinalTypeId = typeARRAY then + begin + // multi-dimensional array + element_count := SymbolTable.GetHighBoundRec(RangeTypeId).value - + SymbolTable.GetLowBoundRec(RangeTypeId).value + 1; + + while GetSymbolRec(ElemTypeId).FinalTypeId = typeARRAY do + begin + SymbolTable.GetArrayTypeInfo(ElemTypeId, RangeTypeId, ElemTypeId); + element_count := element_count * + (SymbolTable.GetHighBoundRec(RangeTypeId).value - + SymbolTable.GetLowBoundRec(RangeTypeId).value + 1); + end; + + ElemSizeId := CreateIntegerVar(GetLevel(N)); + + S := GetSymbolRec(ElemTypeId).Name; + S := '__P' + Copy(S, 2, Length(S) - 1); + + PointerTypeId := SymbolTable.RegisterPointerType(0, S, ElemTypeId); + PointerVarId := NewTempVar(GetLevel(N), PointerTypeId); + temp := NewTempVar(GetLevel(N), ElemTypeId); + B1 := CreateConst(typeINTEGER, 1); + B2 := CreateConst(typeINTEGER, element_count); + + Records[N].Op := OP_ASSIGN; + Records[N].GenOp := OP_ASSIGN; + Records[N].Arg1 := enumerator_id; + Records[N].Arg2 := B1; + Records[N].Res := enumerator_id; + + Records[N + 1].Op := OP_ADDRESS; + Records[N + 1].Arg1 := collection_id; + Records[N + 1].Arg2 := 0; + Records[N + 1].Res := PointerVarId; + + Records[N + 2].Op := OP_SIZEOF; + Records[N + 2].Arg1 := ElemTypeId; + Records[N + 2].Arg2 := 0; + Records[N + 2].Res := ElemSizeId; + + Records[N_CURRENT].Op := OP_TERMINAL; + Records[N_CURRENT].Arg1 := PointerVarId; + Records[N_CURRENT].Arg2 := 0; + Records[N_CURRENT].Res := temp; + + Records[N_CURRENT + 1].Op := OP_ASSIGN; + Records[N_CURRENT + 1].GenOp := OP_ASSIGN; + Records[N_CURRENT + 1].Arg1 := element_id; + Records[N_CURRENT + 1].Arg2 := temp; + Records[N_CURRENT + 1].Res := element_id; + + Records[N_MOVE_NEXT].Op := OP_INC; + Records[N_MOVE_NEXT].Arg1 := enumerator_id; + Records[N_MOVE_NEXT].Arg2 := CreateConst(typeINTEGER, 1); + Records[N_MOVE_NEXT].Res := enumerator_id; + + Records[N_MOVE_NEXT + 1].Op := OP_LE; + Records[N_MOVE_NEXT + 1].Arg1 := enumerator_id; + Records[N_MOVE_NEXT + 1].Arg2 := B2; + Records[N_MOVE_NEXT + 1].Res := bool_id; + + Records[N_MOVE_NEXT + 2].Op := OP_ADD_INT_MM; + Records[N_MOVE_NEXT + 2].Arg1 := PointerVarId; + Records[N_MOVE_NEXT + 2].Arg2 := ElemSizeId; + Records[N_MOVE_NEXT + 2].Res := PointerVarId; + + Dec(N); + + Exit; + end; + + GetSymbolRec(enumerator_id).TypeId := RangeTypeId; + T := GetSymbolRec(RangeTypeId).FinalTypeId; + B1 := CreateConst(T, SymbolTable.GetLowBoundRec(RangeTypeId).value); + B2 := CreateConst(T, SymbolTable.GetHighBoundRec(RangeTypeId).value); + temp := NewTempVar(GetLevel(N), element_TypeId); + + Records[N].Op := OP_ASSIGN; + Records[N].GenOp := OP_ASSIGN; + Records[N].Arg1 := enumerator_id; + Records[N].Arg2 := B1; + Records[N].Res := enumerator_id; + + Records[N_CURRENT].Op := OP_ELEM; + Records[N_CURRENT].Arg1 := collection_id; + Records[N_CURRENT].Arg2 := enumerator_id; + Records[N_CURRENT].Res := temp; + + Records[N_CURRENT + 1].Op := OP_ASSIGN; + Records[N_CURRENT + 1].GenOp := OP_ASSIGN; + Records[N_CURRENT + 1].Arg1 := element_id; + Records[N_CURRENT + 1].Arg2 := temp; + Records[N_CURRENT + 1].Res := element_id; + + Records[N_MOVE_NEXT].Op := OP_INC; + Records[N_MOVE_NEXT].Arg1 := enumerator_id; + Records[N_MOVE_NEXT].Arg2 := CreateConst(typeINTEGER, 1); + Records[N_MOVE_NEXT].Res := enumerator_id; + + Records[N_MOVE_NEXT + 1].Op := OP_LE; + Records[N_MOVE_NEXT + 1].Arg1 := enumerator_id; + Records[N_MOVE_NEXT + 1].Arg2 := B2; + Records[N_MOVE_NEXT + 1].Res := bool_id; + + Dec(N); + end; + typeDYNARRAY: + begin + RangeTypeId := typeINTEGER; + GetSymbolRec(enumerator_id).TypeId := RangeTypeId; + B1 := CreateConst(typeINTEGER, 0); + B2 := CreateIntegerVar(GetLevel(N)); + temp := NewTempVar(GetLevel(N), element_TypeId); + + Records[N].Op := OP_ASSIGN; + Records[N].GenOp := OP_ASSIGN; + Records[N].Arg1 := enumerator_id; + Records[N].Arg2 := B1; + Records[N].Res := enumerator_id; + + if GetSymbolRec(collection_id).IsFWArrayVar then + Records[N + 1].Op := OP_PUSH_INSTANCE + else + Records[N + 1].Op := OP_PUSH; + + Records[N + 1].Arg1 := collection_id; + Records[N + 1].Arg2 := 0; + + if GetSymbolRec(collection_id).IsFWArrayVar then + Records[N + 1].Res := Id_FWArray_GetLength + else + Records[N + 1].Res := Id_DynArrayLength; + + Records[N + 2].Op := OP_CALL; + if GetSymbolRec(collection_id).IsFWArrayVar then + Records[N + 2].Arg1 := Id_FWArray_GetLength + else + Records[N + 2].Arg1 := Id_DynArrayLength; + Records[N + 2].Arg2 := 1; + Records[N + 2].Res := B2; + + Records[N + 3].Op := OP_MINUS; + Records[N + 3].Arg1 := B2; + Records[N + 3].Arg2 := CreateConst(typeINTEGER, 1); + Records[N + 3].Res := B2; + + Records[N_CURRENT].Op := OP_ELEM; + Records[N_CURRENT].Arg1 := collection_id; + Records[N_CURRENT].Arg2 := enumerator_id; + Records[N_CURRENT].Res := temp; + + Records[N_CURRENT + 1].Op := OP_ASSIGN; + Records[N_CURRENT + 1].GenOp := OP_ASSIGN; + Records[N_CURRENT + 1].Arg1 := element_id; + Records[N_CURRENT + 1].Arg2 := temp; + Records[N_CURRENT + 1].Res := element_id; + + Records[N_MOVE_NEXT].Op := OP_INC; + Records[N_MOVE_NEXT].Arg1 := enumerator_id; + Records[N_MOVE_NEXT].Arg2 := CreateConst(typeINTEGER, 1); + Records[N_MOVE_NEXT].Res := enumerator_id; + + Records[N_MOVE_NEXT + 1].Op := OP_LE; + Records[N_MOVE_NEXT + 1].Arg1 := enumerator_id; + Records[N_MOVE_NEXT + 1].Arg2 := B2; + Records[N_MOVE_NEXT + 1].Res := bool_id; + + Dec(N); + end; + typeOPENARRAY: + begin + RangeTypeId := typeINTEGER; + GetSymbolRec(enumerator_id).TypeId := RangeTypeId; + B1 := CreateConst(typeINTEGER, 0); + B2 := CreateIntegerVar(GetLevel(N)); + temp := NewTempVar(GetLevel(N), element_TypeId); + + Records[N].Op := OP_ASSIGN; + Records[N].GenOp := OP_ASSIGN; + Records[N].Arg1 := enumerator_id; + Records[N].Arg2 := B1; + Records[N].Res := enumerator_id; + + Records[N + 1].Op := OP_HIGH; + Records[N + 1].Arg1 := collection_id; + Records[N + 1].Arg2 := 0; + Records[N + 1].Res := B2; + + Records[N_CURRENT].Op := OP_ELEM; + Records[N_CURRENT].Arg1 := collection_id; + Records[N_CURRENT].Arg2 := enumerator_id; + Records[N_CURRENT].Res := temp; + + Records[N_CURRENT + 1].Op := OP_ASSIGN; + Records[N_CURRENT + 1].GenOp := OP_ASSIGN; + Records[N_CURRENT + 1].Arg1 := element_id; + Records[N_CURRENT + 1].Arg2 := temp; + Records[N_CURRENT + 1].Res := element_id; + + Records[N_MOVE_NEXT].Op := OP_INC; + Records[N_MOVE_NEXT].Arg1 := enumerator_id; + Records[N_MOVE_NEXT].Arg2 := CreateConst(typeINTEGER, 1); + Records[N_MOVE_NEXT].Res := enumerator_id; + + Records[N_MOVE_NEXT + 1].Op := OP_LE; + Records[N_MOVE_NEXT + 1].Arg1 := enumerator_id; + Records[N_MOVE_NEXT + 1].Arg2 := B2; + Records[N_MOVE_NEXT + 1].Res := bool_id; + + Dec(N); + end; +{$IFNDEF PAXARM} + typeANSISTRING, typeSHORTSTRING, typeWIDESTRING, +{$ENDIF} + typeUNICSTRING: + begin + RangeTypeId := typeINTEGER; + GetSymbolRec(enumerator_id).TypeId := RangeTypeId; + B1 := CreateConst(typeINTEGER, 1); + B2 := CreateIntegerVar(GetLevel(N)); + temp := NewTempVar(GetLevel(N), element_TypeId); + + Records[N].Op := OP_ASSIGN; + Records[N].GenOp := OP_ASSIGN; + Records[N].Arg1 := enumerator_id; + Records[N].Arg2 := B1; + Records[N].Res := enumerator_id; + + Records[N + 1].Op := OP_PUSH; + Records[N + 1].Arg1 := collection_id; + Records[N + 1].Arg2 := 0; + Records[N + 1].Res := Id_AnsiStringLength; // will seek overloaded + + Records[N + 2].Op := OP_CALL; + Records[N + 2].Arg1 := Id_AnsiStringLength; // will seek overloaded + Records[N + 2].Arg2 := 1; + Records[N + 2].Res := B2; + + Records[N_CURRENT].Op := OP_ELEM; + Records[N_CURRENT].Arg1 := collection_id; + Records[N_CURRENT].Arg2 := enumerator_id; + Records[N_CURRENT].Res := temp; + + Records[N_CURRENT + 1].Op := OP_ASSIGN; + Records[N_CURRENT + 1].GenOp := OP_ASSIGN; + Records[N_CURRENT + 1].Arg1 := element_id; + Records[N_CURRENT + 1].Arg2 := temp; + Records[N_CURRENT + 1].Res := element_id; + + Records[N_MOVE_NEXT].Op := OP_INC; + Records[N_MOVE_NEXT].Arg1 := enumerator_id; + Records[N_MOVE_NEXT].Arg2 := CreateConst(typeINTEGER, 1); + Records[N_MOVE_NEXT].Res := enumerator_id; + + Records[N_MOVE_NEXT + 1].Op := OP_LE; + Records[N_MOVE_NEXT + 1].Arg1 := enumerator_id; + Records[N_MOVE_NEXT + 1].Arg2 := B2; + Records[N_MOVE_NEXT + 1].Res := bool_id; + + Dec(N); + end; + typeSET: + begin + if continue_label_id = 0 then + RaiseError(errInternalError, []); + + RangeTypeId := typeINTEGER; + GetSymbolRec(enumerator_id).TypeId := RangeTypeId; + B1 := CreateConst(RangeTypeId, 0); + B2 := NewTempVar(GetLevel(N), RangeTypeId); + + temp := NewTempVar(GetLevel(N), H_TByteSet); + + Records[N].Op := OP_ASSIGN; + Records[N].GenOp := OP_ASSIGN; + Records[N].Arg1 := enumerator_id; + Records[N].Arg2 := B1; + Records[N].Res := enumerator_id; + + Records[N + 1].Op := OP_SET_ASSIGN; + Records[N + 1].GenOp := OP_SET_ASSIGN; + Records[N + 1].Arg1 := temp; + Records[N + 1].Arg2 := collection_id; + Records[N + 1].Res := temp; + + Records[N + 2].Op := OP_SET_COUNTER_ASSIGN; + Records[N + 2].GenOp := OP_ASSIGN; + Records[N + 2].Arg1 := B2; + Records[N + 2].Arg2 := collection_id; + Records[N + 2].Res := B2; + + collection_id := temp; + + Records[N_CURRENT].Op := OP_ASSIGN_INT_M; + Records[N_CURRENT].GenOp := OP_ASSIGN; + Records[N_CURRENT].Arg1 := element_id; + Records[N_CURRENT].Arg2 := enumerator_id; + Records[N_CURRENT].Res := element_id; + + Records[N_CURRENT + 1].Op := OP_SET_MEMBERSHIP; + Records[N_CURRENT + 1].Arg1 := enumerator_id; + Records[N_CURRENT + 1].Arg2 := collection_id; + Records[N_CURRENT + 1].Res := bool_id; + + Records[N_CURRENT + 2].Op := OP_GO_FALSE; + Records[N_CURRENT + 2].Arg1 := continue_label_id; + Records[N_CURRENT + 2].Arg2 := bool_id; + Records[N_CURRENT + 2].Res := 0; + + Records[N_MOVE_NEXT].Op := OP_INC; + Records[N_MOVE_NEXT].Arg1 := enumerator_id; + Records[N_MOVE_NEXT].Arg2 := CreateConst(typeINTEGER, 1); + Records[N_MOVE_NEXT].Res := enumerator_id; + + Records[N_MOVE_NEXT + 1].Op := OP_LE; + Records[N_MOVE_NEXT + 1].Arg1 := enumerator_id; + Records[N_MOVE_NEXT + 1].Arg2 := B2; + Records[N_MOVE_NEXT + 1].Res := bool_id; + + Dec(N); + end + else + begin + RaiseError(errTypeHasNotEnumerator, + [GetSymbolRec(collection_TypeId).Name]); + end; + end; +end; + +procedure TCode.OperAddAncestor; +var + I, ClassId: Integer; + R: TCodeRec; + SymbolTable: TSymbolTable; +begin + SymbolTable := TKernel(kernel).SymbolTable; + ClassId := Records[N].Arg1; + + if SymbolTable.HasAbstractAncestor(ClassId) then + begin + I := N; + repeat + Inc(I); + if I >= Card then + RaiseError(errInternalError, []); + + R := Records[I]; + if R.Op = OP_END_CLASS_TYPE then + if R.Arg1 = ClassId then + break; + + if R.Op = OP_BEGIN_SUB then + if SymbolTable[R.Arg1].Level = ClassId then + if SymbolTable[R.Arg1].Kind = KindSUB then + SymbolTable[R.Arg1].CallMode := cmOVERRIDE; + until false; + end; +end; + +procedure TCode.DestroyExpressionTempVars(ResultId: Integer); +var + I, J, K, Id, T, TypeId: Integer; + RC: TCodeRec; +begin + K := Card; + + J := -1; + for I := 1 to K do + if Records[I].GenOp = OP_ASSIGN then + if Records[I].Arg1 = ResultId then + begin + J := I + 1; + break; + end; + + if J = -1 then + RaiseError(errInternalError, []); + + for I := 1 to K do + if Records[I].Op = OP_DECLARE_TEMP_VAR then + begin + Id := Records[I].Arg2; + RC := TCodeRec.Create(0, Self); + RC.Upcase := GetUpcase(I); + RC.Language := GetLanguage(I); + RC.ModuleNum := GetModuleNumber(I); + T := GetSymbolRec(Id).FinalTypeId; + case T of + typeVARIANT, typeOLEVARIANT: + RC.Op := OP_VARIANT_CLR; +{$IFNDEF PAXARM} + typeANSISTRING: + RC.Op := OP_ANSISTRING_CLR; + typeWIDESTRING: + RC.Op := OP_WIDESTRING_CLR; +{$ENDIF} + typeUNICSTRING: + RC.Op := OP_UNICSTRING_CLR; + typeINTERFACE: + RC.Op := OP_INTERFACE_CLR; +{$IFDEF PAXARM} + typeCLASS: + RC.Op := OP_CLASS_CLR; +{$ENDIF} + typeDYNARRAY: + RC.Op := OP_DYNARRAY_CLR; + typeRECORD, typeARRAY: + begin + TypeId := GetSymbolRec(Id).TerminalTypeId; + if TKernel(kernel).SymbolTable.HasDynamicFields(TypeId) then + RC.Op := OP_STRUCTURE_CLR + else + RC.Op := OP_NOP; + end; + else + begin + FreeAndNil(RC); + continue; + end; + end; + RC.Arg1 := Id; + Insert(J, RC); + end; +end; + +procedure TCode.InsertHostMonitoring; +var + I, J, SubId, Id, TypeId: Integer; + R, RC: TCodeRec; +begin + for I := Card downto 1 do + begin + R := Self[I]; + if R.Op = OP_CALL then + begin + SubId := R.Arg1; + if GetSymbolRec(SubId).Kind = KindCONSTRUCTOR then + begin + for J := I - 1 downto 1 do + if Self[J].Op = OP_PUSH_CLSREF then + begin + Id := Self[J].Arg1; + if GetSymbolRec(Id).Kind = KindVAR then + begin + TypeId := GetSymbolRec(Id).TerminalTypeId; + TypeId := GetSymbolRec(TypeId).PatternId; + end + else + TypeId := Id; + + if GetSymbolRec(TypeId).Host then + if R.Res > 0 then + begin + RC := TCodeRec.Create(OP_ONCREATE_HOST_OBJECT, Self); + RC.Upcase := GetUpcase(I); + RC.Language := GetLanguage(I); + RC.ModuleNum := GetModuleNumber(I); + RC.Arg1 := R.Res; + Insert(I + 1, RC); + end; + + break; + end; + end + else if SubId = Id_TObject_Free then + begin + for J := I - 1 downto 1 do + if Self[J].Op = OP_PUSH_INST then + begin + Id := Self[J].Arg1; + TypeId := GetSymbolRec(Id).TerminalTypeId; + + if GetSymbolRec(TypeId).Host then + begin + RC := TCodeRec.Create(OP_ONDESTROY_HOST_OBJECT, Self); + RC.Upcase := GetUpcase(I); + RC.Language := GetLanguage(I); + RC.ModuleNum := GetModuleNumber(I); + RC.Arg1 := Id; + Insert(J, RC); + end; + + break; + end; + end; + end; + end; +end; + +procedure TCode.SetLastCondRaise; +var + I: Integer; + b: Boolean; + R: TCodeRec; +begin + b := false; + for I := Card downto 1 do + begin + R := Self[I]; + if R.Op = OP_END_SUB then + b := true + else if R.Op = OP_INIT_SUB then + b := false + else if R.Op = OP_END_GLOBAL_BLOCK then + b := true + else if R.Op = OP_BEGIN_GLOBAL_BLOCK then + b := false + else if R.Op = OP_COND_RAISE then + begin + if b then + R.Arg2 := 1; + b := false; + end; + end; +end; + +function TCode.ParamHasBeenChanged(I, Id: Integer): Boolean; +var + R: TCodeRec; + SubId: Integer; +begin + result := false; + if I <= 0 then + Exit; + SubId := GetSymbolRec(Id).Level; + if SubId <= 0 then + Exit; + if not(GetSymbolRec(SubId).Kind in kindSUBS) then + Exit; + repeat + R := Records[I]; + if R.Op = OP_PARAM_CHANGED then + begin + if R.Arg1 = Id then + begin + result := true; + Exit; + end; + end + else if R.Op = OP_INIT_SUB then + if R.Arg1 = SubId then + Exit; + Dec(I); + until I = 0; +end; + +procedure TCode.CreateExecLines(MR: TModuleRec); +var + I, J, SourceLine: Integer; +begin + for I := MR.P1 to MR.P3 do + if Self[I].Op = OP_SEPARATOR then + begin + SourceLine := Self[I].Arg2; + J := I; + repeat + Inc(J); + if J > Card then + break; + if Self[J].Op = OP_SEPARATOR then + break; + if Self[J].Op = OP_SET_CODE_LINE then + begin + MR.ExecutableLines.Add(SourceLine); + break; + end; + until false; + end; +end; + +procedure TCode.AddWarnings; +var + I, J, Id, SubId, PosUsed, ParamId, OwnerId: Integer; + R, RJ: TCodeRec; + NeverUsed, NotInit: Boolean; + S1, S2: String; + SymbolTable: TSymbolTable; + ok, b: Boolean; +begin + + ok := false; + SymbolTable := TKernel(kernel).SymbolTable; + for I := 1 to Card do + begin + R := Records[I]; + + if R.Op = OP_WARNINGS_ON then + ok := true + else if R.Op = OP_WARNINGS_OFF then + ok := false; + + if not ok then + continue; + + if R.Op = OP_DECLARE_MEMBER then + begin + Id := R.Arg2; + if GetSymbolRec(Id).Vis in [cvPrivate, cvStrictPrivate] then + if used_private_members.IndexOf(Id) = -1 then + begin + b := false; + for J := 1 to Card do + begin + RJ := Records[J]; + if (RJ.Op = OP_CALL) or (RJ.Op = OP_ADDRESS) then + begin + if RJ.Arg1 = Id then + begin + b := true; + break; + end; + end + else if RJ.Op = OP_CREATE_EVENT then + begin + if RJ.Arg2 = Id then + begin + b := true; + break; + end; + end + else if RJ.Op = OP_SET_EVENT_PROP then + begin + if GetSymbolRec(RJ.Res).PatternId = Id then + begin + b := true; + break; + end; + end; + end; + if not b then + begin + N := I; + S2 := GetSymbolRec(Id).Name; + if IsValidName(S2) then + TKernel(kernel).CreateWarning(wrnPrivateNeverUsed, [S2]); + end; + end; + end + else if (R.Op = OP_DECLARE_LOCAL_VAR) or (R.Op = OP_INIT_SUB) then + begin + NeverUsed := true; + NotInit := true; + SubId := R.Arg1; + if R.Op = OP_INIT_SUB then + begin + Id := TKernel(kernel).SymbolTable.GetResultId(SubId); + if GetSymbolRec(SubId).FinalTypeId = typeVOID then + continue; + end + else + begin + Id := R.Arg2; + end; + + if GetSymbolRec(Id).Param then + continue; + if GetSymbolRec(Id).Kind in [KindNONE, KindCONST] then + continue; + if not IsValidName(GetSymbolRec(Id).Name) then + continue; + + PosUsed := 0; + + J := I; + repeat + Inc(J); + RJ := Records[J]; + if RJ.Op = OP_NOP then + continue; + + if (RJ.Op = OP_END_SUB) and (RJ.Arg1 = SubId) then + break; + if RJ.Op = OP_END_MODULE then + break; + if (RJ.Arg1 = Id) or (RJ.Arg2 = Id) or (RJ.Res = Id) then + if RJ.Op <> OP_DESTROY_LOCAL_VAR then + begin + PosUsed := J; + NeverUsed := false; + end; + + if RJ.Arg1 > 0 then + begin + OwnerId := GetSymbolRec(RJ.Arg1).OwnerId; + if OwnerId = Id then + begin + PosUsed := J; + NeverUsed := false; + end; + end; + + if RJ.Arg2 > 0 then + begin + OwnerId := GetSymbolRec(RJ.Arg2).OwnerId; + if OwnerId = Id then + begin + PosUsed := J; + NeverUsed := false; + end; + end; + + if RJ.Res > 0 then + begin + OwnerId := GetSymbolRec(RJ.Res).OwnerId; + if OwnerId = Id then + begin + PosUsed := J; + NeverUsed := false; + end; + end; + + if RJ.GenOp = OP_ERR_ABSTRACT then + if R.Op = OP_INIT_SUB then + begin + NotInit := false; + PosUsed := J; + NeverUsed := false; + end; + + if (RJ.GenOp = OP_ASSIGN) or (RJ.GenOp = OP_ABSOLUTE) or + (RJ.GenOp = OP_SET_LENGTH) or (RJ.GenOp = OP_SET_LENGTH_EX) then + if RJ.Arg1 = Id then + NotInit := false; + if RJ.GenOp = OP_PUSH then + if RJ.Arg1 = Id then + if GetSymbolRec(RJ.Res).Kind in kindSUBS then + if RJ.Res <> JS_FunctionCallId then + begin + ParamId := SymbolTable.GetParamId(RJ.Res, RJ.Arg2); + if GetSymbolRec(ParamId).ByRef or GetSymbolRec(ParamId).ByRefEx + then + NotInit := false; + end; + until J = Card; + + if NeverUsed then + begin + S1 := GetSymbolRec(Id).Name; + if SubId = 0 then + begin + N := I; + TKernel(kernel).CreateWarning(wrnNeverUsed, [S1]); + end + else + begin + S2 := GetSymbolRec(SubId).Name; + + N := I; + if R.Op = OP_INIT_SUB then + begin + while (N > 0) do + begin + Dec(N); + if Records[N].Op = OP_BEGIN_SUB then + if Records[N].Arg1 = SubId then + break; + end; + + if GetSymbolRec(SubId).FinalTypeId <> typeRECORD then + if IsValidName(GetSymbolRec(SubId).Name) then + TKernel(kernel).CreateWarning(wrnReturnValue, [S2]); + end + else + TKernel(kernel).CreateWarning(wrnNeverUsedIn, [S1, S2]); + end; + end + else if NotInit then + begin + N := I; + if R.Op = OP_INIT_SUB then + begin + while (N > 0) do + begin + Dec(N); + if Records[N].Op = OP_BEGIN_SUB then + if Records[N].Arg1 = SubId then + break; + end; + + S2 := GetSymbolRec(SubId).Name; + if GetSymbolRec(SubId).FinalTypeId <> typeRECORD then + if IsValidName(S2) then + TKernel(kernel).CreateWarning(wrnReturnValue, [S2]); + end + else + begin + if PosUsed > 0 then + N := PosUsed + else + N := I; + S1 := GetSymbolRec(Id).Name; + if not(GetSymbolRec(Id).FinalTypeId in [typeRECORD, typeARRAY]) then + TKernel(kernel).CreateWarning(wrnNotInit, [S1]); + end; + end; + end; + end; +end; + +function TCode.GetCompletionVisibility(Id: Integer; NN: Integer) + : TMemberVisibilitySet; +var + TypeId, I1, I2, SubId, L, Lang: Integer; +begin + Lang := GetLanguage(NN); + result := [cvPublic, cvPublished]; + + TypeId := GetSymbolRec(Id).TypeId; + + if TypeId = 0 then + Exit; + + if not GetSymbolRec(TypeId).Host then + if Lang = PASCAL_LANGUAGE then + begin + I1 := TKernel(kernel).Modules.IndexOfModuleById(Id); + I2 := TKernel(kernel).Modules.IndexOfModuleById(TypeId); + + if I1 = I2 then // the same module + begin + result := [cvPrivate, cvProtected, cvPublic, cvPublished]; + Exit; + end; + end; + + // different modules + + SubId := GetCurrSubId(NN); + if SubId = 0 then + Exit; + + L := GetSymbolRec(SubId).Level; + + if L = 0 then + Exit; + + if GetSymbolRec(L).Kind = KindNAMESPACE then + Exit; + + if GetSymbolRec(L).Kind <> KindTYPE then + Exit; + + if GetSymbolRec(L).FinalTypeId <> typeCLASS then + Exit; + + if (L = TypeId) or GetSymbolRec(L).Inherits(TypeId) then + result := [cvProtected, cvPublic, cvPublished] + else + result := [cvPublic, cvPublished]; +end; + +procedure TCode.RemoveDeclaredVar(Id: Integer); +var + I: Integer; + R: TCodeRec; +begin + for I := N + 1 to Card do + begin + R := Records[I]; + if R.Op = OP_STMT then + break; + if R.Op = OP_DECLARE_LOCAL_VAR then + if R.Arg2 = Id then + begin + R.Op := OP_NOP; + R.GenOp := OP_NOP; + Exit; + end; + end; +end; + +function TCode.LookupTempVarId(Level, FinTypeId: Integer): Integer; + + function GetStmtEx(I: Integer; Id: Integer): Integer; + var + R: TCodeRec; + begin + result := I; + + repeat + R := Records[result]; + + if R.Res = Id then + begin + result := -100; + Exit; + end; + + if R.Op = OP_STMT then + begin + Exit; + end + else + begin + Dec(result); + + if R.Op = OP_BEGIN_MODULE then + break; + if R.Op = OP_INIT_SUB then + break; + + if result = 1 then + Exit; + end; + until false; + end; + +var + I, Id, NN, NN2: Integer; + R: TSymbolRec; +begin + result := 0; + if temp_var_list.Count = 0 then + Exit; + + NN2 := -1; + + for I := temp_var_list.Count - 1 downto 0 do + begin + Id := temp_var_list.Keys[I]; + R := GetSymbolRec(Id); + if R.Level = Level then + begin + if R.FinalTypeId = FinTypeId then + begin + if NN2 = -1 then + begin + NN2 := GetStmtEx(N, Id); + if NN2 = -100 then + Exit; + end; + + NN := temp_var_list.Values[I]; + if NN2 = NN then + Exit; + + result := Id; + Exit; + end; + end + else + break; + end; +end; + +procedure TCode.RemoveLoadProc; +var + L: TIntegerList; + R: TCodeRec; + + procedure Proc(Id: Integer); + begin + L.Add(Id); + end; + +var + I, K, Op: Integer; + b: Boolean; +begin + b := TKernel(kernel).BuildWithRuntimePackages; + + if b then + Exit; + + L := TIntegerList.Create; + + try + K := 0; + for I := 1 to Card do + begin + R := Records[I]; + Op := R.Op; + + if Op = OP_LOAD_PROC then + continue; + if Op = OP_SET_CODE_LINE then + continue; + if Op = OP_SEPARATOR then + continue; + + if b then + if Op = OP_END_MODULE then + begin + K := I; + break; + end; + + Proc(R.Arg1); + Proc(R.Arg2); + Proc(R.Res); + end; + L.QuickSort; + for I := K + 1 to Card do + begin + R := Records[I]; + if R.Op = OP_LOAD_PROC then + if L.BinSearch(R.Arg1) = -1 then + R.Op := OP_NOP; + end; + + finally + FreeAndNil(L); + end; +end; + +function TCode.LookupInExtraUnitList(const S: String): Integer; +var + I: Integer; + Upcase: Boolean; +begin + result := 0; + Upcase := GetUpcase(N); + for I := extra_using_list.Count - 1 downto 0 do + begin + result := TKernel(kernel).SymbolTable.LookUp(S, extra_using_list[I], + Upcase, MaxInt); + if result > 0 then + Exit; + end; +end; + +procedure TCode.CheckExpansions; +var + I, J, K, FTD, FTE, TypeD, TypeE: Integer; + TD: TTypeDefRec; + TE: TTypeExpRec; + TRD, TRE: TTypeRestrictionRec; + S: String; +begin + for K := 0 to TKernel(kernel).TypeDefList.Expansions.Count - 1 do + begin + I := TKernel(kernel).TypeDefList.Expansions.Keys[K]; + J := TKernel(kernel).TypeDefList.Expansions.Values[K]; + + TD := TKernel(kernel).TypeDefList[J]; + TE := TKernel(kernel).TypeDefList.TypeExpList[I]; + + for I := 0 to TD.ParamList.Count - 1 do + begin + TRD := TTypeRestrictionRec(TD.ParamList.Objects[I]); + if TRD = nil then + continue; + FTD := GetSymbolRec(TRD.Id).FinalTypeId; + if not(FTD in [typeCLASS, typeINTERFACE]) then + begin + N := TRD.N; + S := GetSymbolRec(TRD.Id).Name; + RaiseError(errTypeIsNotValidConstraint, [S]); + end; + TRE := TTypeRestrictionRec(TE.ParamList.Objects[I]); + FTE := GetSymbolRec(TRE.Id).FinalTypeId; + if FTD <> FTE then + begin + N := TRE.N; + RaiseError(errIncompatibleTypes, [GetSymbolRec(TRD.Id).Name, + GetSymbolRec(TRE.Id).Name]); + Exit; + end; + if (FTD = typeCLASS) and (FTE = typeCLASS) then + begin + TypeD := GetSymbolRec(TRD.Id).TerminalTypeId; + TypeE := GetSymbolRec(TRE.Id).TerminalTypeId; + if TypeD = TypeE then + Exit; + if TKernel(kernel).SymbolTable.Inherits(TypeE, TypeD) then + Exit; + N := TRE.N; + RaiseError(errIncompatibleTypes, [GetSymbolRec(TRD.Id).Name, + GetSymbolRec(TRE.Id).Name]); + Exit; + end; + if FTD = typeRECORD then + begin + if FTE <> typeRECORD then + begin + N := TRE.N; + RaiseError(errIncompatibleTypesNoArgs, []); + end; + Exit; + end; + end; + end; +end; + +procedure TCode.RemoveUnusedLabels; +var + I, Op: Integer; + L: TIntegerList; +begin + L := TIntegerList.Create; + try + for I := 1 to Card do + begin + Op := Records[I].Op; + if (Op = OP_GO) or (Op = OP_GO_FALSE) or (Op = OP_GO_TRUE) or + (Op = OP_GO_TRUE_BOOL) or (Op = OP_GO_FALSE_BOOL) or (Op = OP_GO_DL) + then + L.Add(Records[I].Arg1); + + end; + for I := 1 to Card do + begin + Op := Records[I].Op; + if Op = OP_LABEL then + if L.IndexOf(Records[I].Arg1) = -1 then + begin + Records[I].Op := OP_NOP; + Records[I].GenOp := OP_NOP; + end; + end; + finally + FreeAndNil(L); + end; +end; + +function TCode.GetPAX64: Boolean; +begin + result := TKernel(kernel).PAX64; +end; + +function TCode.GetSizeOfPointer: Integer; +begin + if PAX64 then + result := 8 + else + result := 4; +end; + +procedure TCode.CheckOverride; +var + I, J: Integer; + List: TIntegerList; +begin + List := TIntegerList.Create; + try + for I := 1 to Card do + if Records[I].Op = OP_CHECK_OVERRIDE then + List.Add(I); + for J := 0 to List.Count - 1 do + begin + I := List[J]; + if Records[I].Op = OP_CHECK_OVERRIDE then + begin + N := I; + OperCheckOverride(List); + end; + end; + finally + FreeAndNil(List); + end; +end; + +procedure TCode.OperAssignLambdaTypes; + +var + SubId, ClassId: Integer; + SymbolTable: TSymbolTable; + + function AssignTypes(T: Integer): Boolean; + var + I, SubId2, id1, id2, K: Integer; + begin + result := false; + if GetSymbolRec(T).FinalTypeId <> typeINTERFACE then + Exit; + SubId2 := SymbolTable.LookupAnonymousMethod(T); + if SubId2 = 0 then + Exit; + K := GetSymbolRec(SubId2).Count; + if K <> GetSymbolRec(SubId).Count then + Exit; + id1 := SymbolTable.GetResultId(SubId); + id2 := SymbolTable.GetResultId(SubId2); + GetSymbolRec(id1).TypeId := GetSymbolRec(id2).TypeId; + GetSymbolRec(SubId).TypeId := GetSymbolRec(id2).TypeId; + for I := 0 to K - 1 do + begin + id1 := SymbolTable.GetParamId(SubId, I); + id2 := SymbolTable.GetParamId(SubId2, I); + GetSymbolRec(id1).TypeId := GetSymbolRec(id2).TypeId; + end; + SymbolTable.RegisterSupportedInterface(ClassId, T); + result := true; + end; + +var + I, ResId, ParamId: Integer; + RI: TCodeRec; +begin + SymbolTable := TKernel(kernel).SymbolTable; + + Records[N].Op := OP_NOP; + + SubId := Records[N].Arg1; + I := N; + repeat + Inc(I); + RI := Records[I]; + if RI.Op = OP_ASSIGN_LAMBDA_TYPES then + if RI.Arg1 = SubId then + break; + until false; + + ClassId := Records[I].Arg2; + ResId := Records[I].Res; + + Records[I].Op := OP_NOP; + + for I := I + 1 to Card do + begin + RI := Records[I]; + if RI.Op = OP_ASSIGN then + begin + if RI.Arg2 = ResId then + begin + if AssignTypes(GetSymbolRec(RI.Arg1).TerminalTypeId) then + Exit + else + break; + end; + end + else if RI.Op = OP_PUSH then + begin + if RI.Arg1 = ResId then + begin + ParamId := SymbolTable.GetParamId(RI.Res, RI.Arg2); + if AssignTypes(GetSymbolRec(ParamId).TerminalTypeId) then + Exit + else + break; + end; + end; + end; + RaiseError(errIncompatibleTypesNoArgs, []); +end; + +procedure TCode.RestoreFieldType(J: Integer); +var + OwnerId, Id, TypeId, PatternId, SubId, N1: Integer; + S: String; + SymbolTable: TSymbolTable; +begin + SymbolTable := TKernel(kernel).SymbolTable; + if Records[J - 1].Op = OP_FIELD then + begin + if Records[J - 1].Res = Records[J].Arg1 then + begin + OwnerId := Records[J - 1].Arg1; + TypeId := SymbolTable[OwnerId].TypeId; + + if TypeId = 0 then + RestoreFieldType(J - 1); + + TypeId := SymbolTable[OwnerId].TypeId; + + if TypeId = 0 then + Exit; + + if SymbolTable[TypeId].Kind <> KindTYPE then + Exit; + + Id := Records[J].Arg1; + S := SymbolTable[Id].Name; + PatternId := SymbolTable.LookUp(S, TypeId, GetUpcase(J)); + if PatternId > 0 then + SymbolTable[Id].TypeId := SymbolTable[PatternId].TypeId; + end; + end + else if Records[J - 1].Op = OP_CALL then + begin + if Records[J - 1].Res = Records[J].Arg1 then + begin + SubId := Records[J - 1].Arg1; + TypeId := SymbolTable[SubId].TypeId; + + if TypeId = 0 then + begin + N1 := J - 1; + repeat + Dec(N1); + if N1 = 0 then + Exit; + if Records[N1].Op = OP_FIELD then + if Records[N1].Res = SubId then + break; + until false; + + RestoreFieldType(N1); + TypeId := GetSymbolRec(Records[N1].Arg1).TypeId; + S := SymbolTable[SubId].Name; + PatternId := SymbolTable.LookUp(S, TypeId, GetUpcase(J)); + if PatternId > 0 then + TypeId := SymbolTable[PatternId].TypeId; + end; + + Id := Records[J].Arg1; + SymbolTable[Id].TypeId := TypeId; + end; + end; +end; + +function TCode.GetTrueSubId: Integer; +var + T, K: Integer; + R: TCodeRec; +begin + R := Records[N]; + result := R.Arg1; + if GetSymbolRec(result).Kind in kindSUBS then + Exit; + + T := GetSymbolRec(R.Arg1).TerminalTypeId; + result := GetSymbolRec(T).PatternId; + + if not(GetSymbolRec(result).Kind in kindSUBS) then + begin + K := N - 1; + repeat + if Self[K].Op = OP_GET_VMT_ADDRESS then + if Self[K].Res = R.Arg1 then + begin + result := Self[K].Arg2; + break; + end; + + if Self[K].Op = OP_SEPARATOR then + break; + + Dec(K); + until false; + end; +end; + +procedure TCode.CreateMethodEntryLists; +var + ClassList: TClassList; + CR, CA: TClassRec; + I, J, K, SubId, L, ClassIndex, V, CountGlobal, AncestorIndex, MethodIndex, + ClassId, AncestorId: Integer; + R: TCodeRec; + L1, L2: TIntegerList; + b: Boolean; +begin + ClassList := TKernel(kernel).prog.ClassList; + L1 := TIntegerList.Create; + L2 := TIntegerList.Create; + try + for I := 1 to Card do + begin + R := Records[I]; + if R.Op = OP_BEGIN_CLASS_TYPE then + begin + ClassId := R.Arg1; + AncestorId := GetSymbolRec(ClassId).AncestorId; + if GetSymbolRec(AncestorId).Host then + L1.Add(ClassId) + else + L2.Add(ClassId); + end; + end; + + while L2.Count > 0 do + begin + for I := L2.Count - 1 downto 0 do + begin + ClassId := L2[I]; + AncestorId := GetSymbolRec(ClassId).AncestorId; + if L1.IndexOf(AncestorId) >= 0 then + begin + L1.Add(ClassId); + L2.RemoveAt(I); + break; + end; + end; + end; + + for I := 0 to L1.Count - 1 do + begin + ClassId := L1[I]; + AncestorId := GetSymbolRec(ClassId).AncestorId; + ClassIndex := GetSymbolRec(ClassId).ClassIndex; + AncestorIndex := GetSymbolRec(AncestorId).ClassIndex; + CR := ClassList[ClassIndex]; + if CR = nil then + RaiseError(errInternalError, []); + CA := ClassList[AncestorIndex]; + if CA = nil then + RaiseError(errInternalError, []); + + b := GetSymbolRec(AncestorId).Host; + + K := 0; + + if not b then + begin + for J := 0 to System.Length(CA.ByteCodeMethodEntryList) - 1 do + begin + V := CA.ByteCodeMethodEntryList[J]; + if V = 0 then + begin + K := J; + break; + end; + SetLength(CR.ByteCodeMethodEntryList, J + 1); + CR.ByteCodeMethodEntryList[J] := V; + end; + end; + + for J := 1 to Card do + begin + R := Records[J]; + if R.Op = OP_INIT_SUB then + begin + SubId := R.Arg1; + + MethodIndex := GetSymbolRec(SubId).MethodIndex; + + if MethodIndex > 0 then + CR.VirtualMethodEntryList[MethodIndex] := J; + + SetLength(CR.ByteCodeMethodEntryList, K + 1); + CR.ByteCodeMethodEntryList[K] := J; + Inc(K); + end; + end; + end; + + CountGlobal := 0; + for J := 1 to Card do + begin + R := Records[J]; + if R.Op = OP_INIT_SUB then + begin + SubId := R.Arg1; + L := GetSymbolRec(SubId).Level; + if L = 0 then + begin + SetLength(TKernel(kernel).prog.ByteCodeGlobalEntryList, + CountGlobal + 1); + TKernel(kernel).prog.ByteCodeGlobalEntryList[CountGlobal] := J; + Inc(CountGlobal); + end + else if GetSymbolRec(L).FinalTypeId <> typeCLASS then + begin + SetLength(TKernel(kernel).prog.ByteCodeGlobalEntryList, + CountGlobal + 1); + TKernel(kernel).prog.ByteCodeGlobalEntryList[CountGlobal] := J; + Inc(CountGlobal); + end; + end + else if R.Op = OP_JUMP_SUB then + begin + SetLength(TKernel(kernel).prog.ByteCodeGlobalEntryList, + CountGlobal + 1); + TKernel(kernel).prog.ByteCodeGlobalEntryList[CountGlobal] := J; + Inc(CountGlobal); + end; + end; + + finally + FreeAndNil(L1); + FreeAndNil(L2); + end; +end; + +procedure TCode.CreateEvalList(L: TStringList); +var + I: Integer; + R: TCodeRec; + S: String; +begin + L.Add('Create'); + for I := 1 to Card do + begin + R := Records[I]; + S := ''; + if R.Op = OP_EVAL then + S := GetSymbolRec(R.Res).Name + else if R.Op = OP_ASSIGN_TYPE then + S := GetSymbolRec(R.Arg2).Name + else if R.Op = OP_FIELD then + S := GetSymbolRec(R.Res).Name + else if (R.Op = OP_BEGIN_SUB) or (R.Op = OP_CALL) then + S := GetSymbolRec(R.Arg1).Name; + if S <> '' then + if L.IndexOf(S) = -1 then + L.Add(S); + end; +end; + +procedure TCode.InsertCallHostEvents; +var + I: Integer; + RI, RC: TCodeRec; +begin + I := 0; + repeat + Inc(I); + if I > Card then + break; + RI := Records[I]; + if RI.Op = OP_BEGIN_CALL then + begin + if GetSymbolRec(RI.Arg1).Kind in kindSUBS then + if GetSymbolRec(RI.Arg1).Host then + begin + RC := TCodeRec.Create(OP_BEFORE_CALL_HOST, Self); + RC.Arg1 := RI.Arg1; + Insert(I, RC); + Inc(I); + end; + end + else if RI.Op = OP_CALL then + begin + if GetSymbolRec(RI.Arg1).Kind in kindSUBS then + if GetSymbolRec(RI.Arg1).Host then + begin + RC := TCodeRec.Create(OP_AFTER_CALL_HOST, Self); + RC.Arg1 := RI.Arg1; + Insert(I + 1, RC); + Inc(I); + end; + end; + until false; +end; + +// TCodeRec -------------------------------------------------------------------- + +constructor TCodeRec.Create(i_OP: Integer; Code: TCode); +begin + OwnerObject := Code; + + Op := i_OP; + GenOp := i_OP; + + Arg1 := 0; + Arg2 := 0; + Res := 0; + + LinePos := -1; + SavedLevel := -1; + + if Code = nil then + Exit; + + with Code do + begin + Upcase := GetUpcase(N); + Language := GetLanguage(N); + ModuleNum := GetModuleNumber(N); + SavedLevel := GetLevel(N); + end; +end; + +procedure TCodeRec.SwapArguments; +var + temp: Integer; +begin + temp := Arg1; + Arg1 := Arg2; + Arg2 := temp; + + SwappedArgs := not SwappedArgs; +end; + +function TCodeRec.Clone: TCodeRec; +begin + result := TCodeRec.Create(Op, OwnerObject); + result.Arg1 := Arg1; + result.Arg2 := Arg2; + result.Res := Res; + result.Upcase := Upcase; + result.Language := Language; + result.IsStatic := IsStatic; + result.SavedSubId := SavedSubId; + result.SwappedArgs := SwappedArgs; + result.LinePos := LinePos; + result.CodeRecTag := CodeRecTag; + result.SavedLevel := SavedLevel; + result.IsInherited := IsInherited; +end; + +procedure TCodeRec.SaveToStream(S: TStream); +begin + S.Write(Op, SizeOf(Op)); + S.Write(Arg1, SizeOf(Arg1)); + S.Write(Arg2, SizeOf(Arg2)); + S.Write(Res, SizeOf(Res)); + S.Write(GenOp, SizeOf(GenOp)); + S.Write(IsStatic, SizeOf(IsStatic)); + S.Write(SwappedArgs, SizeOf(SwappedArgs)); + S.Write(SavedSubId, SizeOf(SavedSubId)); + S.Write(CodeRecTag, SizeOf(CodeRecTag)); + S.Write(SavedLevel, SizeOf(SavedLevel)); + S.Write(IsInherited, SizeOf(IsInherited)); +end; + +procedure TCodeRec.LoadFromStream(S: TStream); +begin + S.Read(Op, SizeOf(Op)); + S.Read(Arg1, SizeOf(Arg1)); + S.Read(Arg2, SizeOf(Arg2)); + S.Read(Res, SizeOf(Res)); + S.Read(GenOp, SizeOf(GenOp)); + S.Read(IsStatic, SizeOf(IsStatic)); + S.Read(SwappedArgs, SizeOf(SwappedArgs)); + S.Read(SavedSubId, SizeOf(SavedSubId)); + S.Read(CodeRecTag, SizeOf(CodeRecTag)); + S.Read(SavedLevel, SizeOf(SavedLevel)); + S.Read(IsInherited, SizeOf(IsInherited)); +end; + +end. diff --git a/Sources/PAXCOMP_Basic.pas b/Sources/PAXCOMP_Basic.pas new file mode 100644 index 0000000..2bd2641 --- /dev/null +++ b/Sources/PAXCOMP_Basic.pas @@ -0,0 +1,1281 @@ +//////////////////////////////////////////////////////////////////////////// +// PaxCompiler +// Site: http://www.paxcompiler.com +// Author: Alexander Baranovsky (paxscript@gmail.com) +// ======================================================================== +// Copyright (c) Alexander Baranovsky, 2006-2014. All rights reserved. +// Code Version: 4.2 +// ======================================================================== +// Unit: PAXCOMP_Basic.pas +// ======================================================================== +//////////////////////////////////////////////////////////////////////////// + +{$I PaxCompiler.def} +{$O-} +{$Q-} +{$B-} +{$R-} +unit PAXCOMP_Basic; +interface + +{$IFNDEF LINUX} // Just to compile PASCAL only (using FPC on Mac) +{$IFDEF UNIX} // Just to compile PASCAL only (using FPC on Mac) +implementation + +end. +{$ENDIF} +{$ENDIF} + +uses {$I uses.def} + SysUtils, + Classes, + Math, +{$IFDEF VARIANTS} + DateUtils, +{$ENDIF} + PAXCOMP_CONSTANTS, + PAXCOMP_SYS, + PAXCOMP_STDLIB, + PAXCOMP_BASESYMBOL_TABLE; + +procedure Register_StdBasic(st: TBaseSymbolTable); + +var + H_Namespace, H_Sub: Integer; +const + ByRef = true; + +implementation + +uses + PAXCOMP_JavaScript; + +const + vbEmpty = 0; + vbNull = 1; + vbInteger = 2; + vbLong = 3; + vbSingle = 4; + vbDouble = 5; + vbCurrency = 6; + vbDate = 7; + vbString = 8; + vbObject = 9; + vbError = 10; + vbBoolean = 11; + vbVariant = 12; + vbDataObject = 13; + vbByte = 17; + vbArray = 8192; + + vbGeneralDate = 0; + vbLongDate = 1; + vbShortDate = 2; + vbLongTime = 3; + vbShortTime = 4; + + MonthNames: array [1..12] of string = + ( + 'January', + 'February', + 'March', + 'April', + 'May', + 'June', + 'July', + 'August', + 'September', + 'October', + 'November', + 'December' + ); + + WeekDayNames: array [1..7] of string = + ( + 'Sunday', + 'Monday', + 'Tuesday', + 'Wednesday', + 'Thursday', + 'Friday', + 'Saturday' + ); + +function TestVar(P: PVariant): Boolean; +begin + result := P <> nil; + if result then + result := VarType(P^) <> varEmpty; +end; + +function _Tan(const X: Extended): Extended; +begin + result := ArcTan(X); +end; + +function _Atn(const X: Extended): Extended; +begin + result := ArcTan(X); +end; + +function _Sin(const X: Extended): Extended; +begin + result := Sin(X); +end; + +function _Cos(const X: Extended): Extended; +begin + result := Cos(X); +end; + +function _Exp(const X: Extended): Extended; +begin + result := Exp(X); +end; + +function _Sqr(const X: Extended): Extended; +begin + result := Sqr(X); +end; + +function _CBool(const X: Variant): Boolean; +begin + result := X; +end; + +function _CByte(const X: Variant): Byte; +begin + result := X; +end; + +function _CCurr(const X: Variant): Currency; +begin + result := X; +end; + +function _CDate(const X: Variant): TDateTime; +begin + result := X; +end; + +function _CDbl(const X: Variant): Double; +begin + result := X; +end; + +function _CInt(const X: Variant): Integer; +begin + result := X; +end; + +function _CLong(const X: Variant): Integer; +begin + result := X; +end; + +{$IFNDEF PAXARM} +{$IFNDEF MACOS32} +{$IFNDEF LINUX} +function _CreateObject(const ClassName: String): Variant; +begin + result := CreateOleObject(ClassName); +end; + +function _GetObject(const ClassName: String): Variant; +begin + result := GetActiveOleObject(ClassName); +end; +{$ENDIF} +{$ENDIF} +{$ENDIF} + +function _Date(): TDateTime; +begin + result := Date; +end; + +function _DateSerial(Y, M, D: Word): TDateTime; +begin + result := EncodeDate(Y,M,D); +end; + +function _TimeSerial(Hour, Min, Sec: Word; MSec: Word = 0): TDateTime; +begin + result := EncodeTime(Hour, Min, Sec, MSec); +end; + +function _Day(const V: Variant): Integer; +var + Y, M, D: Word; + ADate: Double; +begin + ADate := VariantToDate(V); + DecodeDate(ADate, Y, M, D); + result := D; +end; + +function _Month(const V: Variant): Integer; +var + Y, M, D: Word; + ADate: Double; +begin + ADate := VariantToDate(V); + DecodeDate(ADate, Y, M, D); + result := M; +end; + +function _MonthName(const V: Variant; abbreviate: Boolean = false): String; +var + M: Integer; +begin + M := V; + if (M < 1) or (M > 12) then + begin + result := 'Undefined'; + Exit; + end; + result := MonthNames[M]; + if abbreviate then + result := SCopy(result, SLow(result), 3); +end; + +function _WeekDayName(const V: Variant; abbreviate: Boolean = false): String; +var + D: Integer; +begin + D := V; + if (D < 1) or (D > 7) then + begin + result := 'Undefined'; + Exit; + end; + result := WeekDayNames[D]; + if abbreviate then + result := SCopy(result, SLow(result), 3); +end; + +function _WeekDay(const V: Variant): Integer; +var + ADate: Double; +begin + ADate := VariantToDate(V); + result := DayOfWeek(ADate); +end; + +function _Year(const V: Variant): Integer; +var + Y, M, D: Word; + ADate: Double; +begin + ADate := VariantToDate(V); + DecodeDate(ADate, Y, M, D); + result := Y; +end; + +{$IFDEF VARIANTS} +function _DateAdd(const Interval: String; Number: Integer; const V: Variant): TDateTime; +var + ADate: TDateTime; +begin + ADate := VariantToDate(V); + if Interval = 'yyyy' then + result := IncYear(ADate, Number) + else if Interval = 'm' then + result := IncMonth(ADate, Number) + else if Interval = 'q' then + result := IncMonth(ADate, Number * 4) + else if Interval = 'd' then + result := IncDay(ADate, Number) + else if Interval = 'h' then + result := IncHour(ADate, Number) + else if Interval = 'n' then + result := IncMinute(ADate, Number) + else if Interval = 's' then + result := IncSecond(ADate, Number) + else if Interval = 'd' then + begin + ADate := StartOfTheYear(ADate); + result := IncDay(ADate, Number); + end + else if Interval = 'w' then + begin + ADate := StartOfTheWeek(ADate); + result := IncDay(ADate, Number); + end + else if Interval = 'ww' then + begin + ADate := StartOfTheYear(ADate); + result := IncDay(ADate, Number * 7); + end + else + raise Exception.Create('Wrong Interval parameter'); +end; + +function _DateDiff(const Interval: String; const V1, V2: Variant): Integer; +var + ADate1, ADate2: TDateTime; +begin + ADate1 := VariantToDate(V1); + ADate2 := VariantToDate(V2); + if Interval = 'yyyy' then + result := YearOf(ADate2) - YearOf(ADate1) + else if Interval = 'm' then + result := MonthOf(ADate2) - MonthOf(ADate1) + else if Interval = 'q' then + result := (MonthOf(ADate2) - MonthOf(ADate1)) mod 4 + else if Interval = 'd' then + result := DayOf(ADate2) - DayOf(ADate1) + else if Interval = 'h' then + result := HourOf(ADate2) - HourOf(ADate1) + else if Interval = 'n' then + result := MinuteOf(ADate2) - MinuteOf(ADate1) + else if Interval = 's' then + result := SecondOf(ADate2) - SecondOf(ADate1) + else if Interval = 'd' then + result := DayOf(ADate2) - DayOf(ADate1) + else if Interval = 'w' then + result := WeekOf(ADate2) - WeekOf(ADate1) + else if Interval = 'ww' then + result := WeekOfTheYear(ADate2) - WeekOfTheYear(ADate1) + else + raise Exception.Create('Wrong Interval parameter'); +end; + +function _DatePart(const Interval: String; const V: Variant): Integer; +var + ADate: TDateTime; +begin + ADate := VariantToDate(V); + if Interval = 'yyyy' then + result := YearOf(ADate) + else if Interval = 'm' then + result := MonthOf(ADate) + else if Interval = 'q' then + result := MonthOf(ADate) mod 4 + 1 + else if Interval = 'd' then + result := DayOf(ADate) + else if Interval = 'h' then + result := HourOf(ADate) + else if Interval = 'n' then + result := MinuteOf(ADate) + else if Interval = 's' then + result := SecondOf(ADate) + else if Interval = 'd' then + result := DayOfTheYear(ADate) + else if Interval = 'w' then + result := WeekOf(ADate) + else if Interval = 'ww' then + result := WeekOfTheYear(ADate) + else + raise Exception.Create('Wrong Interval parameter'); +end; +{$ENDIF} + +function _Hour(const V: Variant): Integer; +var + Hour, Min, Sec, MSec: Word; + ADate: Double; +begin + ADate := VariantToDate(V); + DecodeTime(ADate, Hour, Min, Sec, MSec); + result := Hour; +end; + +function _Minute(const V: Variant): Integer; +var + Hour, Min, Sec, MSec: Word; + ADate: Double; +begin + ADate := VariantToDate(V); + DecodeTime(ADate, Hour, Min, Sec, MSec); + result := Min; +end; + +function _Second(const V: Variant): Integer; +var + Hour, Min, Sec, MSec: Word; + ADate: Double; +begin + ADate := VariantToDate(V); + DecodeTime(ADate, Hour, Min, Sec, MSec); + result := Sec; +end; + +function _Filter(const Source: Variant; const Match: String; + Include: Boolean = true): Variant; +var + L: TStringList; + I: Integer; + S: String; +begin + L := TStringList.Create; + try + for I:=0 to VarArrayHighBound(Source, 1) do + begin + S := Source[I]; + if Include then + begin + if Pos(Match, S) > 0 then + L.Add(S); + end + else + begin + if Pos(Match, S) = 0 then + L.Add(S); + end; + end; + result := VarArrayCreate([0, L.Count - 1], varVariant); + for I:=0 to L.Count - 1 do + result[I] := L[I]; + finally + FreeAndNil(L); + end; +end; + +function _Join(const Source: Variant; const Delimiter: String = ' '): String; +var + I, K: Integer; +begin + result := ''; + K := VarArrayHighBound(Source, 1); + for I:=0 to K do + begin + result := result + Source[I]; + if I < K then + result := result + Delimiter; + end; +end; + +function _Split(const Expression: String; + const Delimiter: String = ' '; + Limit: Integer = -1): Variant; +var + L: TStringList; + I: Integer; + S: String; +begin + L := TStringList.Create; + S := Expression; + try + I := Pos(Delimiter, S); + while I > 0 do + begin + L.Add(Copy(S, 1, I - 1)); + Delete(S, I, Length(Delimiter)); + I := Pos(Delimiter, S); + end; + result := VarArrayCreate([0, L.Count - 1], varVariant); + for I:=0 to L.Count - 1 do + result[I] := L[I]; + finally + FreeAndNil(L); + end; +end; + +function _UCase(const S: String): String; +begin + result := UpperCase(S); +end; + +function _LCase(const S: String): String; +begin + result := LowerCase(S); +end; + +function _LBound(const V: Variant): Integer; +begin + result := 0; +end; + +function _UBound(const V: Variant; D: Integer = 1): Integer; +begin + result := VarArrayHighBound(V, D) +end; + +function _CStr(const V: Variant): Variant; +begin + result := VarToStr(V); +end; + +function _InList(P1: PVariant = nil; P2: PVariant = nil): Boolean; +var + sParam1, sParam2 : String; + lsParam2 : TStringList; +begin + result := False; + if (not TestVar(P1)) or (not TestVar(P2)) then Exit; + sParam1 := VarToStr(P1^); + sParam2 := VarToStr(P2^); + lsParam2 := TStringList.Create; + try + lsParam2.CommaText := sParam2; + result := lsParam2.IndexOf(sParam1) > -1; + finally + FreeAndNil(lsParam2); + end; +end; + +function _AtLeastOneInList(P1: PVariant = nil; P2: PVariant = nil): Boolean; +var + sParam1, sParam2, sParam : String; + lsParam1, lsParam2 : TStringList; + iItem, iIndex : Integer; +begin + result := False; + if (not TestVar(P1)) or (not TestVar(P2)) then Exit; + sParam1 := VarToStr(P1^); + sParam2 := VarToStr(P2^); + + lsParam1 := TStringList.Create; + lsParam2 := TStringList.Create; + try + lsParam1.Sorted := True; + lsParam1.Duplicates := dupIgnore; + lsParam1.CommaText := sParam1; + + lsParam2.Sorted := True; + lsParam2.Duplicates := dupIgnore; + lsParam2.CommaText := sParam2; + + for iItem := 0 to Pred(lsParam1.Count) do + begin + sParam := lsParam1[iItem]; + if lsParam2.Find(sParam, iIndex) then + begin + result := True; + Exit; + end; + end; + finally + FreeAndNil(lsParam1); + FreeAndNil(lsParam2); + end; +end; + +function _StrReverse(const S: String): String; +var + I: Integer; +begin + result := ''; + for I := SLow(S) to SHigh(S) do + result := S[I] + result; +end; + +function _InStr(const S1, S2: string): Integer; +begin + result := Pos(S2, S1); +end; + +function _InStrRev(const P0, P1: string; P2: PVariant = nil): Integer; +var + V1, V2: Variant; + S1, S2: String; + ParamCount, start, I: Integer; +begin + start := 0; + ParamCount := 2; + if TestVar(P2) then + ParamCount := 3; + case ParamCount of + 2: + begin + start := 0; + V1 := P0; + V2 := P1; + end; + 3: + begin + V1 := P0; + V2 := P1; + start := P2^; + end; + end; + + S1 := VarToStr(V1); + S2 := VarToStr(V2); + + if Length(S1) = 0 then + result := 0 + else if Length(S2) = 0 then + result := start + else if start > Length(S1) then + result := 0 + else if Length(S2) > Length(S1) then + result := 0 + else if Length(S2) = Length(S1) then + begin + if S1 = S2 then + result := 1 + else + result := 0; + end + else + begin + if Start > 0 then + S1 := Copy(S1, 1, Start); + for I:= Length(S1) - Length(S2) + 1 downto 1 do + if S2 = Copy(S1, I, Length(S2)) then + begin + result := I; + Exit; + end; + result := 0; + end; +end; + +function _Len(const S: String): Integer; +begin + result := Length(S); +end; + +function _Replace(const S, OldPattern, NewPattern: string): String; +begin + result := StringReplace(S, OldPattern, NewPattern, [rfReplaceAll, rfIgnoreCase]); +end; + +function _RGB(red, green, blue: Integer): Integer; +begin + result := red + (green * 256) + (blue * 65536); +end; + +function _FormatNumber(const V: Variant; P2: PVariant = nil; P3: PVariant = nil): Variant; +var + D: Double; + Fmt: String; + NumDigitsAfterDecimal: Integer; +begin + if (not TestVar(P2)) and (not TestVar(P3)) then + begin + result := VarToStr(V); + Exit; + end; + if TestVar(P2) then + begin + D := V; + NumDigitsAfterDecimal := P2^; + Fmt := '%*.' + IntToStr(NumDigitsAfterDecimal) + 'f'; + result := Format(Fmt, [D]); + end; +end; + +function _FormatPercent(const V: Variant; P2: PVariant = nil; P3: PVariant = nil): Variant; +var + D: Double; + Fmt: String; + NumDigitsAfterDecimal: Integer; +begin + if (not TestVar(P2)) and (not TestVar(P3)) then + begin + result := VarToStr(V * 100) + '%'; + Exit; + end; + if TestVar(P2) then + begin + D := V * 100; + NumDigitsAfterDecimal := P2^; + Fmt := '%*.' + IntToStr(NumDigitsAfterDecimal) + 'f'; + result := Format(Fmt, [D]) + '%'; + end; +end; + +function _Rnd(const V: Variant; P2: PVariant = nil): Variant; +begin + if TestVar(P2) then + result := Random(Integer(P2^ - V)) + V + else + result := Random(Integer(V)); +end; + +function _Round(const V: Variant; P2: PVariant = nil): Variant; +var + D: Double; + L, P: Integer; + S: String; +begin + if not TestVar(P2) then +{$IFDEF VARIANTS} + result := Round(Double(V)) +{$ELSE} + result := Integer(Round(V)) +{$ENDIF} + else + begin + L := P2^; + D := V; + S := FloatToStr(D); + S := _Replace(S, ',', '.'); + P := Pos('.', S); + if P > 0 then + begin + S := Copy(S, 1, P + L); + D := StrToFloat(S); + result := D; + end + else +{$IFDEF VARIANTS} + result := Round(Double(V)); +{$ELSE} + result := Integer(Round(V)); +{$ENDIF} + end; +end; + +function _Log(const V: Extended): Extended; +begin + result := Ln(V); +end; + +function _TimeToStr(const DateTime: TDateTime): string; +begin + result := TimeToStr(DateTime); +end; + +function _DateToStr(const DateTime: TDateTime): string; +begin + result := DateToStr(DateTime); +end; + +function _TypeName(const V: Variant): String; +var + S: String; +begin + S := ''; + case VarType(V) of + varEmpty: S := 'Empty'; + varNull: S := 'Null'; + varSmallInt: S := 'Integer'; + varInteger: S := 'Long'; + varSingle: S := 'Single'; + varDouble: S := 'Double'; + varCurrency: S := 'Currency'; + varDate: S := 'Date'; + varString, +{$IFDEF UNIC} + varUString, +{$ENDIF} + varOleStr: S := 'String'; + varBoolean: S := 'Boolean'; + varVariant: S := 'Variant'; + varDispatch: S := 'Dispatch'; + varByte: S := 'Byte'; + end; + + if VarType(V) >= varArray then + S := 'Array'; + + result := S; +end; + +function IsNumericString(const S: String): Boolean; +var + I: Integer; +begin + if S = '' then + begin + result := false; + Exit; + end; + + result := true; + for I:=1 to Length(S) do + if not ByteInSet(S[I], [Ord('0')..Ord('9'), + Ord('.'),Ord('+'),Ord('-'),Ord('e'),Ord('E')]) then + begin + result := false; + Exit; + end; +end; + +function _IsNumeric(const V: Variant): Boolean; +begin + result := false; + case VarType(V) of + varInteger, varByte, varDouble: result := true; + varString: result := IsNumericString(V); + end; +end; + +function _Int(D: Double): Integer; +begin + if D >= 0 then + result := Trunc(D) + else + begin + if Frac(D) <> 0.0 then + result := Trunc(D) - 1 + else + result := Trunc(D); + end; +end; + +function _Fix(D: Double): Integer; +begin + if D >= 0 then + result := _Int(D) + else + result := -1 * _Int(Abs(D)); +end; + +function _Chr(I: Integer): Char; +begin + result := Chr(I); +end; + +function _Left(const S: String; L: Integer): String; +begin + result := SCopy(S, SLow(S), L); +end; + +function _Right(const S: String; L: Integer): String; +var + I: Integer; +begin + if L > Length(S) then + L := Length(S); + + result := ''; + + for I:=Length(S) downto Length(S) - L + 1 do + result := S[I] + result; +end; + +function _Sgn(V: Integer): Integer; +begin + if V > 0 then + result := 1 + else if V < 0 then + result := -1 + else + result := 0; +end; + +function _Mid(const P0: String; P1: Integer; P2: PVariant = nil): String; +var + L: Integer; +begin + if TestVar(P2) then + L := P2^ + else + L := Length(P0); + result := Copy(P0, P1, L); +end; + +function _CLng(const X: Variant): Variant; +begin + result := JS_ToInt32(X); +end; + +function _CSng(const X: Variant): Variant; +begin + result := JS_ToNumber(X); +end; + +function _Hex(const X: Variant): String; +var + I: Integer; +begin + I := JS_ToInt32(X); + result := Format('%x', [I]); +end; + +function _IsEmpty(const X: Variant): Boolean; +begin + result := VarType(X) = varEmpty; +end; + +function _IsArray(const X: Variant): Boolean; +begin + result := VarType(X) = varArray; +end; + +procedure Register_StdBasic(st: TBaseSymbolTable); +begin +{$IFNDEF PAXARM} +{$IFNDEF MACOS32} +{$IFNDEF LINUX} + CoInitialize(nil); +{$ENDIF} +{$ENDIF} +{$ENDIF} + + with st do + begin + H_Namespace := RegisterNamespace(0, StrBasicNamespace); + H_BasicNamespace := H_Namespace; + + RegisterConstant(H_Namespace, 'vbEmpty', 0); + RegisterConstant(H_Namespace, 'vbNull', 1); + RegisterConstant(H_Namespace, 'vbInteger', 2); + RegisterConstant(H_Namespace, 'vbLong', 3); + RegisterConstant(H_Namespace, 'vbSingle', 4); + RegisterConstant(H_Namespace, 'vbDouble', 5); + RegisterConstant(H_Namespace, 'vbCurrency', 6); + RegisterConstant(H_Namespace, 'vbDate', 7); + RegisterConstant(H_Namespace, 'vbString', 8); + RegisterConstant(H_Namespace, 'vbObject', 9); + RegisterConstant(H_Namespace, 'vbError', 10); + RegisterConstant(H_Namespace, 'vbBoolean', 11); + RegisterConstant(H_Namespace, 'vbVariant', 12); + RegisterConstant(H_Namespace, 'vbDataObject', 13); + RegisterConstant(H_Namespace, 'vbByte', 17); + RegisterConstant(H_Namespace, 'vbArray', 8192); + + H_Sub := RegisterRoutine(H_Namespace, 'Abs', typeVOID, ccSTDCALL, nil); + RegisterParameter(H_Sub, typeVOID, Unassigned, ByRef, 'X'); + + RegisterRoutine(H_Namespace, 'Asc', typeVOID, ccSTDCALL, nil); + + H_Sub := RegisterRoutine(H_Namespace, 'Tan', typeEXTENDED, ccREGISTER, + @_Tan); + RegisterParameter(H_Sub, typeEXTENDED, Unassigned, false, 'X'); + + H_Sub := RegisterRoutine(H_Namespace, 'Atn', typeEXTENDED, ccREGISTER, + @_Atn); + RegisterParameter(H_Sub, typeEXTENDED, Unassigned, false, 'X'); + + H_Sub := RegisterRoutine(H_Namespace, 'Sin', typeEXTENDED, ccREGISTER, + @_Sin); + RegisterParameter(H_Sub, typeEXTENDED, Unassigned, false, 'X'); + + H_Sub := RegisterRoutine(H_Namespace, 'Cos', typeEXTENDED, ccREGISTER, + @_Cos); + RegisterParameter(H_Sub, typeEXTENDED, Unassigned, false, 'X'); + + H_Sub := RegisterRoutine(H_Namespace, 'Exp', typeEXTENDED, ccREGISTER, + @_Exp); + RegisterParameter(H_Sub, typeEXTENDED, Unassigned, false, 'X'); + + H_Sub := RegisterRoutine(H_Namespace, 'Sqr', typeEXTENDED, ccREGISTER, + @_Sqr); + RegisterParameter(H_Sub, typeEXTENDED, Unassigned, false, 'X'); + + H_Sub := RegisterRoutine(H_Namespace, 'Log', typeEXTENDED, ccREGISTER, + @_Log); + RegisterParameter(H_Sub, typeEXTENDED, Unassigned, false, 'X'); + + H_Sub := RegisterRoutine(H_Namespace, 'CBool', typeBOOLEAN, ccREGISTER, + @_CBool); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, false, 'X'); + + H_Sub := RegisterRoutine(H_Namespace, 'CByte', typeBYTE, ccREGISTER, + @_CByte); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, false, 'X'); + + H_Sub := RegisterRoutine(H_Namespace, 'CCurr', typeCURRENCY, ccREGISTER, + @_CCurr); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, false, 'X'); + + H_Sub := RegisterRoutine(H_Namespace, 'CDate', typeDOUBLE, ccREGISTER, + @_CDate); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, false, 'X'); + + H_Sub := RegisterRoutine(H_Namespace, 'CDbl', typeDOUBLE, ccREGISTER, + @_CDbl); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, false, 'X'); + + RegisterRoutine(H_Namespace, 'CChar', typeVOID, ccSTDCALL, nil); + + H_Sub := RegisterRoutine(H_Namespace, 'CInt', typeINTEGER, ccREGISTER, + @_CInt); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, false, 'X'); + + H_Sub := RegisterRoutine(H_Namespace, 'CLong', typeINTEGER, ccREGISTER, + @_CLong); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, false, 'X'); + +{$IFNDEF PAXARM} +{$IFNDEF TAB} + +{$IFDEF MSWINDOWS} + H_Sub := RegisterRoutine(H_Namespace, 'CreateObject', typeVARIANT, ccREGISTER, + @_CreateObject); +{$ELSE} + H_Sub := RegisterRoutine(H_Namespace, '', typeVARIANT, ccREGISTER, + nil); +{$ENDIF} + RegisterParameter(H_Sub, typeSTRING, Unassigned, false, 'X'); + + +{$IFDEF MSWINDOWS} + H_Sub := RegisterRoutine(H_Namespace, 'GetObject', typeVARIANT, ccREGISTER, + @_GetObject); +{$ELSE} + H_Sub := RegisterRoutine(H_Namespace, '', typeVARIANT, ccREGISTER, + nil); +{$ENDIF} + RegisterParameter(H_Sub, typeSTRING, Unassigned, false, 'X'); + +{$ENDIF} +{$ENDIF} + +{$IFNDEF TAB} + H_Sub := RegisterRoutine(H_Namespace, 'Date', typeDOUBLE, ccREGISTER, + @_Date); +{$ENDIF} + H_Sub := RegisterRoutine(H_Namespace, 'Now', typeDOUBLE, ccREGISTER, + @_Date); + + RegisterHeader(H_Namespace, + 'function StrToDate(const S: string): TDateTime;', + @ StrToDate); + + H_Sub := RegisterRoutine(H_Namespace, 'DateSerial', typeDOUBLE, ccREGISTER, + @_DateSerial); + RegisterParameter(H_Sub, typeWORD, Unassigned, false, 'D'); + RegisterParameter(H_Sub, typeWORD, Unassigned, false, 'M'); + RegisterParameter(H_Sub, typeWORD, Unassigned, false, 'Y'); + + RegisterHeader(H_Namespace, + 'function TimeSerial(Hour, Min, Sec: Word; MSec: Word = 0): TDateTime;', + @ _TimeSerial); + + H_Sub := RegisterRoutine(H_Namespace, 'Day', typeINTEGER, ccREGISTER, + @_Day); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, false, 'ADate'); + + H_Sub := RegisterRoutine(H_Namespace, 'Month', typeINTEGER, ccREGISTER, + @_Month); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, false, 'ADate'); + + RegisterHeader(H_Namespace, + 'function MonthName(const V: Variant; abbreviate: Boolean = false): String;', + @_MonthName); + + RegisterHeader(H_Namespace, + 'function WeekDayName(const V: Variant; abbreviate: Boolean = false): String;', + @_WeekDayName); + + H_Sub := RegisterRoutine(H_Namespace, 'WeekDay', typeINTEGER, ccREGISTER, + @_WeekDay); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, false, 'ADate'); + +{$IFDEF MSWINDOWS} + RegisterRoutine(H_Namespace, 'Timer', typeINTEGER, ccREGISTER, + @GetTickCount); +{$ELSE} + RegisterRoutine(H_Namespace, '', typeINTEGER, ccREGISTER, + nil); +{$ENDIF} + + H_Sub := RegisterRoutine(H_Namespace, 'Year', typeINTEGER, ccREGISTER, + @_Year); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, false, 'ADate'); + + H_Sub := RegisterRoutine(H_Namespace, 'Hour', typeINTEGER, ccREGISTER, + @_Hour); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, false, 'ADate'); + + H_Sub := RegisterRoutine(H_Namespace, 'Minute', typeINTEGER, ccREGISTER, + @_Minute); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, false, 'ADate'); + + H_Sub := RegisterRoutine(H_Namespace, 'Second', typeINTEGER, ccREGISTER, + @_Second); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, false, 'ADate'); + + RegisterHeader(H_Namespace, 'function Filter(const Source: Variant;' + + 'const Match: String;' + + 'Include: Boolean = true): Variant;', + @ _Filter); + + RegisterHeader(H_Namespace, 'function Join(const Source: Variant;' + + 'const Delimiter: String = '' ''): String;', + @ _Join); + + RegisterHeader(H_Namespace, 'function Split(const Expression: String;' + + 'const Delimiter: String = '' '';' + + 'Limit: Integer = -1): Variant;', + @ _Split); + + RegisterHeader(H_Namespace, 'function LBound(const V: Variant): Integer;', + @ _LBound); + + RegisterHeader(H_Namespace, 'function UBound(const V: Variant; D: Integer = 1): Integer;', + @ _UBound); + + RegisterHeader(H_Namespace, 'function UCase(const S: String): String;', + @ _UCase); + RegisterHeader(H_Namespace, 'function LCase(const S: String): String;', + @ _LCase); + + RegisterConstant(H_Namespace, 'Nothing', typeVARIANT, Null); + RegisterRoutine(H_Namespace, 'IsNull', typeVOID, ccSTDCALL, nil); + RegisterRoutine(H_Namespace, 'IsNothing', typeVOID, ccSTDCALL, nil); + + RegisterHeader(H_Namespace, + 'function InStr(const S1, S2: string): Integer;', + @ _InStr); + + RegisterHeader(H_Namespace, + 'function _InStrRev(const P0, P1: string; const P2: Variant = Undefined): Integer;', + @ _InStrRev); + + RegisterHeader(H_Namespace, + 'function Len(const S: String): Integer;', + @ _Len); + + RegisterHeader(H_Namespace, + 'function Replace(const S, OldPattern, NewPattern: string): String;', + @ _Replace); + + RegisterHeader(H_Namespace, + 'function LTrim(const S: string): string;', + @ TrimLeft); + + RegisterHeader(H_Namespace, + 'function RTrim(const S: string): string;', + @ TrimRight); + + RegisterHeader(H_Namespace, + 'function Trim(const S: string): string;', + @ Trim); + + RegisterHeader(H_Namespace, + 'function Substr(const S: String; Index, Length: Integer): String;', + @ SCopy); + + RegisterHeader(H_Namespace, + 'function StrComp(const S1, S2: string): Boolean;', + @ SameText); + + RegisterHeader(H_Namespace, + 'function StrReverse(const S: String): String;', + @ _StrReverse); + + RegisterHeader(H_Namespace, + 'function Space(K: Integer): String;', + @ PAXCOMP_SYS.Space); + + RegisterHeader(H_Namespace, + 'function CStr(const V: Variant): Variant;', + @ _CStr); + +{$IFNDEF TAB} + RegisterHeader(H_Namespace, + 'function _RGB(red, green, blue: Integer): Integer;', + @ _RGB); +{$ENDIF} + + RegisterHeader(H_Namespace, + 'function DateValue(const DateTime: TDateTime): string;', + @ _DateToStr); + + RegisterHeader(H_Namespace, + 'function TimeValue(const DateTime: TDateTime): string;', + @ _TimeToStr); + + RegisterHeader(H_Namespace, + 'function FormatCurrency(Value: Currency): string;', + @ CurrToStr); + + RegisterHeader(H_Namespace, + 'function FormatDateTime(const DateTime: TDateTime): string;', + @ DateTimeToStr); + + RegisterHeader(H_Namespace, + 'function FormatNumber(const V: Variant; const P2, P3: Variant = Undefined): Variant;', + @ _FormatNumber); + + RegisterHeader(H_Namespace, + 'function FormatPercent(const V: Variant; const P2, P3: Variant = Undefined): Variant;', + @ _FormatPercent); + + RegisterHeader(H_Namespace, + 'function Rnd(const V: Variant; const P2: Variant = Undefined): Variant;', + @ _Rnd); + + RegisterHeader(H_Namespace, + 'function Round(const V: Variant; const P2: Variant = Undefined): Variant;', + @ _Round); + + RegisterHeader(H_Namespace, + 'function VarType(const V: Variant): Word;', + @ VarType); + + RegisterHeader(H_Namespace, + 'function TypeName(const V: Variant): String;', + @ _TypeName); + + RegisterHeader(H_Namespace, + 'function IsNumeric(const V: Variant): Boolean;', + @ _IsNumeric); + + RegisterHeader(H_Namespace, + 'function IsNull(const V: Variant): Boolean;', + @ VarIsNull); + + RegisterHeader(H_Namespace, + 'function _Int(D: Double): Integer;', + @ _Int); + + RegisterHeader(H_Namespace, + 'function _Fix(D: Double): Integer;', + @ _Fix); + + RegisterHeader(H_Namespace, + 'function Chr(I: Integer): Char;', + @ _Chr); + + RegisterHeader(H_Namespace, + 'function Left(const S: String; L: Integer): String;', + @ _Left); + + RegisterHeader(H_Namespace, + 'function Right(const S: String; L: Integer): String;', + @ _Right); + + RegisterHeader(H_Namespace, + 'function Sgn(V: Integer): Integer;', + @ _Sgn); + + RegisterHeader(H_Namespace, + 'function _Mid(const P0: String; P1: Integer; const P2: Variant = Undefined): String;', + @ _Mid); + + RegisterHeader(H_Namespace, + 'function CLng(const X: Variant): Variant;', + @ _CLng); + + RegisterHeader(H_Namespace, + 'function CSng(const X: Variant): Variant;', + @ _CSng); + + RegisterHeader(H_Namespace, + 'function _Hex(const X: Variant): String;', + @ _Hex); + + RegisterHeader(H_Namespace, + 'function _IsEmpty(const X: Variant): Boolean;', + @ _IsEmpty); + + RegisterHeader(H_Namespace, + 'function _IsArray(const X: Variant): Boolean;', + @ _IsArray); + +{$IFDEF VARIANTS} + RegisterHeader(H_Namespace, + 'function DateAdd(const Interval: String; Number: Integer; const Date: Variant): TDateTime;', + @ _DateAdd); + + RegisterHeader(H_Namespace, + 'function _DateDiff(const Interval: String; const V1, V2: Variant): Integer;', + @ _DateDiff); + + RegisterHeader(H_Namespace, + 'function _DatePart(const Interval: String; const V: Variant): Integer;', + @ _DatePart); +{$ENDIF} + +{$IFDEF TAB} + RegisterHeader(H_Namespace, + 'function InList(const P1, P2: Variant = Undefined): Boolean;', + @ _InList); + + RegisterHeader(H_Namespace, + 'function AtLeastOneInList(const P1, P2: Variant = Undefined): Boolean;', + @ _AtLeastOneInList); +{$ENDIF} + end; +end; + +end. diff --git a/Sources/PAXCOMP_CLASSFACT.pas b/Sources/PAXCOMP_CLASSFACT.pas new file mode 100644 index 0000000..552c4b2 --- /dev/null +++ b/Sources/PAXCOMP_CLASSFACT.pas @@ -0,0 +1,765 @@ +//////////////////////////////////////////////////////////////////////////// +// PaxCompiler +// Site: http://www.paxcompiler.com +// Author: Alexander Baranovsky (paxscript@gmail.com) +// ======================================================================== +// Copyright (c) Alexander Baranovsky, 2006-2014. All rights reserved. +// Code Version: 4.2 +// ======================================================================== +// Unit: PAXCOMP_CLASSFACT.pas +// ======================================================================== +//////////////////////////////////////////////////////////////////////////// + +{$I PaxCompiler.def} +unit PAXCOMP_CLASSFACT; +interface +uses {$I uses.def} + SysUtils, + Classes, + TypInfo, + PAXCOMP_CONSTANTS, + PAXCOMP_TYPES, + PAXCOMP_SYS, + PAXCOMP_MAP, + PAXCOMP_CLASSLST; +type + TPaxClassFactoryRec = class + private + PaxClassRec: TPaxClassRec; + fClassName: ShortString; + fParentClass: TClass; + Processed: Boolean; + fMethodTableSize: Integer; + fIntfTableSize: Integer; + function GetDelphiClass: TClass; + function GetVMTPtr: PVMT; + procedure SetMethodTableSize(value: Integer); + public + pti_parent: PTypeInfo; + FieldTableSize: Integer; + FieldClassTable: PFieldClassTable; + DmtTableSize: Integer; + FullClassName: String; + + constructor Create(const AFullClassName: String); + destructor Destroy; override; + procedure RenameClass(const NewFullClassName: String); + procedure SetInstanceSize(value: Integer); + procedure SetParentClass(AClass: TClass); + property DelphiClass: TClass read GetDelphiClass; + property VMTPtr: PVMT read GetVMTPtr; + property MethodTableSize: Integer read fMethodTableSize + write SetMethodTableSize; + property IntfTableSize: Integer read fIntfTableSize write + fIntfTableSize; + end; + + TPaxClassFactory = class(TTypedList) + private + function GetRecord(I: Integer): TPaxClassFactoryRec; + procedure Reset; + public + ForceCreate: Boolean; + constructor Create; + function CreatePaxClass(const AFullClassName: String; + AnInstanceSize: Integer; + ParentClass: TClass; + PDestroyObject: Pointer): TClass; + function CreateCloneClass(const AFullClassName: String; + ParentClass: TClass): TClass; + function RenameClass(const OldFullClassName, + NewFullClassName: String): Boolean; + function FindRecord(AClass: TClass): TPaxClassFactoryRec; + function FindRecordByFullName(const AFullClassName: String): TPaxClassFactoryRec; + function LookupFullName(const AFullClassName: String): TClass; + procedure SetupParents(Prog: Pointer; ClassList: TClassList); + procedure SetupStdVirtuals(ClassList: TClassList; CodePtr: Pointer); + procedure AddInheritedMethods; overload; + procedure AddInheritedMethods(SourceClass: TClass); overload; + procedure AddOverridenMethods(AProg: Pointer; ScriptMapTable: TMapTable); + procedure AddVirtualMethod(SourceClass: TClass; + SourceMethodAddress: Pointer); + function AddOverridenMethod(SourceClass: TClass; + SourceMethodAddress, + InheritedMethodAddress: Pointer): Boolean; + procedure RaiseError(const Message: string; params: array of Const); + property Records[I: Integer]: TPaxClassFactoryRec read GetRecord; default; + end; + +implementation + +uses + PAXCOMP_BASERUNNER; + +function _NewInstance(Self: TClass): TObject; +var + S: Integer; +begin + S := Self.InstanceSize; + result := Self.InitInstance(AllocMem(S)); +end; + +{$IFDEF ARC} +const + objDisposedFlag = Integer($40000000); +type + TMyObject = class(TObject); + +function fake_ObjRelease(Self: Pointer): Integer; +var + PRefCount: ^Integer; +begin + PRefCount := ShiftPointer(Pointer(Self), SizeOf(Pointer)); + Result := AtomicDecrement(PRefCount^) and not objDisposedFlag; + if Result = 0 then + TMyObject(Self).Destroy; +end; +{$ENDIF} + +// TPaxClassFactoryRec --------------------------------------------------------- + +constructor TPaxClassFactoryRec.Create(const AFullClassName: String); +begin + inherited Create; + FillChar(PaxClassRec, SizeOf(PaxClassRec), 0); + FieldClassTable := nil; + FullClassName := AFullClassName; + PaxClassRec.PaxInfo.ClassFactoryRec := Self; +end; + +destructor TPaxClassFactoryRec.Destroy; +begin + if MethodTableSize > 0 then + FreeMem(vmtMethodTableSlot(VMTPtr)^, MethodTableSize); + if FieldTableSize > 0 then + FreeMem(vmtFieldTableSlot(VMTPtr)^, FieldTableSize); + if DmtTableSize > 0 then + FreeMem(vmtDynamicTableSlot(VMTPtr)^, DmtTableSize); + if FieldClassTable <> nil then + DestroyFieldClassTable(FieldClassTable); + if IntfTableSize > 0 then + FreeMem(vmtIntfTableSlot(VMTPtr)^, IntfTableSize); + inherited; +end; + +{$IFDEF FPC} +function TPaxClassFactoryRec.GetDelphiClass: TClass; +begin + result := TClass(@PaxClassRec.VMT); +end; +{$ELSE} +function TPaxClassFactoryRec.GetDelphiClass: TClass; +begin + result := TClass(vmtSelfPtrSlot(@PaxClassRec.VMT)^); +end; +{$ENDIF} + + +function TPaxClassFactoryRec.GetVMTPtr: PVMT; +begin + result := @ PaxClassRec.VMT; +end; + +procedure TPaxClassFactoryRec.SetMethodTableSize(value: Integer); +begin + fMethodTableSize := value; +end; + +procedure TPaxClassFactoryRec.SetInstanceSize(value: Integer); +begin + PIntPax(vmtInstanceSizeSlot(@PaxClassRec.VMT))^ := value; +end; + +procedure TPaxClassFactoryRec.RenameClass(const NewFullClassName: string); +begin + PShortStringFromString(@fClassName, ExtractName(NewFullClassName)); + FullClassName := NewFullClassName; +end; + +procedure TPaxClassFactoryRec.SetParentClass(AClass: TClass); +var + ParentVMT: PVMT; +begin + fParentClass := AClass; + + ParentVMT := GetVmtFromClass(AClass); + +// PaxClassRec.VMT.IntfTable := ParentVMT.IntfTable; + +{$IFDEF FPC} + vmtParentSlot(@PaxClassRec.VMT)^ := AClass; +{$IFNDEF LINUX} + PaxClassRec.VMT.VToString := ParentVMT^.VToString; + PaxClassRec.VMT.VGetHashCode := ParentVMT^.VGetHashCode; + PaxClassRec.VMT.VEquals := ParentVMT^.VEquals; +{$ENDIF} +{$ELSE} + vmtParentSlot(@PaxClassRec.VMT)^ := @fParentClass; +{$ENDIF} + + vmtAutoTableSlot(@PaxClassRec.VMT)^ := vmtAutoTableSlot(ParentVMT)^; +{$IFNDEF LINUX} + vmtDispatchSlot(@PaxClassRec.VMT)^ := vmtDispatchSlot(ParentVMT)^; +{$ENDIF} + vmtInitTableSlot(@PaxClassRec.VMT)^ := vmtInitTableSlot(ParentVMT)^; + vmtTypeInfoSlot(@PaxClassRec.VMT)^ := vmtTypeInfoSlot(ParentVMT)^; + vmtFieldTableSlot(@PaxClassRec.VMT)^ := vmtFieldTableSlot(ParentVMT)^; + vmtMethodTableSlot(@PaxClassRec.VMT)^ := vmtMethodTableSlot(ParentVMT)^; + vmtDynamicTableSlot(@PaxClassRec.VMT)^ := vmtDynamicTableSlot(ParentVMT)^; + + vmtNewInstanceSlot(@PaxClassRec.VMT)^ := vmtNewInstanceSlot(ParentVMT)^; + vmtSafeCallExceptionSlot(@PaxClassRec.VMT)^ := vmtSafeCallExceptionSlot(ParentVMT)^; + vmtAfterConstructionSlot(@PaxClassRec.VMT)^ := vmtAfterConstructionSlot(ParentVMT)^; + vmtBeforeDestructionSlot(@PaxClassRec.VMT)^ := vmtBeforeDestructionSlot(ParentVMT)^; + vmtDefaultHandlerSlot(@PaxClassRec.VMT)^ := vmtDefaultHandlerSlot(ParentVMT)^; + + {$IFDEF UNIC} + vmtToStringSlot(@PaxClassRec.VMT)^ := vmtToStringSlot(ParentVMT)^; + vmtGetHashCodeSlot(@PaxClassRec.VMT)^ := vmtGetHashCodeSlot(ParentVMT)^; + vmtEqualsSlot(@PaxClassRec.VMT)^ := vmtEqualsSlot(ParentVMT)^; + {$ENDIF} + + {$IFDEF ARC} + vmt__ObjAddRefSlot(@PaxClassRec.VMT)^ := vmt__ObjAddRefSlot(ParentVMT)^; +// vmt__ObjReleaseSlot(@PaxClassRec.VMT)^ := vmt__ObjReleaseSlot(ParentVMT)^; + vmt__ObjReleaseSlot(@PaxClassRec.VMT)^ := @ fake_ObjRelease; + {$ENDIF} +end; + +// TPaxClassFactory ------------------------------------------------------------ + +constructor TPaxClassFactory.Create; +begin + inherited; + ForceCreate := false; +end; + +procedure TPaxClassFactory.RaiseError(const Message: string; params: array of Const); +begin + raise Exception.Create(Format(Message, params)); +end; + +procedure _AfterConstruction(Self: TObject); +begin +end; + +procedure _BeforeDestruction(Self: TObject); +begin +end; + +function TPaxClassFactory.RenameClass(const OldFullClassName, + NewFullClassName: String): Boolean; +var + R: TPaxClassFactoryRec; +begin + R := FindRecordByFullName(OldFullClassName); + result := R <> nil; + if result then + R.RenameClass(NewFullClassName); +end; + +function TPaxClassFactory.CreatePaxClass(const AFullClassName: String; + AnInstanceSize: Integer; + ParentClass: TClass; + PDestroyObject: Pointer): TClass; +var + PaxClassObject: TPaxClassFactoryRec; +begin + PaxClassObject := TPaxClassFactoryRec.Create(AFullClassName); + PShortStringFromString(@PaxClassObject.fClassName, ExtractName(AFullClassName)); + PaxClassObject.fParentClass := ParentClass; + + {$IFDEF FPC} + vmtParentSlot(@PaxClassObject.PaxClassRec.VMT)^ := ParentClass; + {$ELSE} + vmtSelfPtrSlot(@PaxClassObject.PaxClassRec.VMT)^ := GetClassFromVMT(@PaxClassObject.PaxClassRec.VMT); + vmtParentSlot(@PaxClassObject.PaxClassRec.VMT)^ := @ PaxClassObject.fParentClass; + {$ENDIF} + vmtClassNameSlot(@PaxClassObject.PaxClassRec.VMT)^ := @ PaxClassObject.fClassName; + PIntPax(vmtInstanceSizeSlot(@PaxClassObject.PaxClassRec.VMT))^ := AnInstanceSize; + vmtNewInstanceSlot(@PaxClassObject.PaxClassRec.VMT)^ := @ _NewInstance; + vmtAfterConstructionSlot(@PaxClassObject.PaxClassRec.VMT)^ := @ _AfterConstruction; + vmtBeforeDestructionSlot(@PaxClassObject.PaxClassRec.VMT)^ := @ _BeforeDestruction; + vmtDestroySlot(@PaxClassObject.PaxClassRec.VMT)^ := PDestroyObject; + + L.Add(PaxClassObject); + + result := PaxClassObject.DelphiClass; + + PaxClassObject.PaxClassRec.PaxInfo.PaxSignature := strPaxSignature; +end; + +function TPaxClassFactory.CreateCloneClass(const AFullClassName: String; + ParentClass: TClass): TClass; +var + PaxClassObject: TPaxClassFactoryRec; + ParentVMT: PVMT; +begin + ParentVMT := GetVmtFromClass(ParentClass); + + PaxClassObject := TPaxClassFactoryRec.Create(AFullClassName); + PShortStringFromString(@PaxClassObject.fClassName, ExtractName(AFullClassName)); + PaxClassObject.fParentClass := ParentClass; + + {$IFDEF FPC} + raise Exception.Create(errNotImplementedYet); + {$ELSE} + vmtSelfPtrSlot(@PaxClassObject.PaxClassRec.VMT)^ := GetClassFromVMT(@PaxClassObject.PaxClassRec.VMT); + vmtAutoTableSlot(@PaxClassObject.PaxClassRec.VMT)^ := vmtAutoTableSlot(ParentVMT)^; + {$ENDIF} + vmtIntfTableSlot(@PaxClassObject.PaxClassRec.VMT)^ := vmtIntfTableSlot(ParentVMT)^; + + vmtParentSlot(@PaxClassObject.PaxClassRec.VMT)^ := vmtParentSlot(ParentVMT)^; + vmtClassNameSlot(@PaxClassObject.PaxClassRec.VMT)^ := vmtClassNameSlot(ParentVMT)^; + vmtInstanceSizeSlot(@PaxClassObject.PaxClassRec.VMT)^ := vmtInstanceSizeSlot(ParentVMT)^; + vmtNewInstanceSlot(@PaxClassObject.PaxClassRec.VMT)^ := vmtNewInstanceSlot(ParentVMT)^; + vmtAfterConstructionSlot(@PaxClassObject.PaxClassRec.VMT)^ := vmtAfterConstructionSlot(ParentVMT)^; + vmtBeforeDestructionSlot(@PaxClassObject.PaxClassRec.VMT)^ := vmtBeforeDestructionSlot(ParentVMT)^; + vmtDestroySlot(@PaxClassObject.PaxClassRec.VMT)^ := vmtDestroySlot(ParentVMT)^; + + L.Add(PaxClassObject); + result := PaxClassObject.DelphiClass; + + PaxClassObject.PaxClassRec.PaxInfo.PaxSignature := strPaxSignature; +end; + +function TPaxClassFactory.GetRecord(I: Integer): TPaxClassFactoryRec; +begin + result := TPaxClassFactoryRec(L[I]); +end; + +function TPaxClassFactory.FindRecord(AClass: TClass): TPaxClassFactoryRec; +var + I: Integer; +begin + result := nil; + for I:=0 to Count - 1 do + if Records[I].DelphiClass = AClass then + begin + result := Records[I]; + break; + end; +end; + +function TPaxClassFactory.FindRecordByFullName(const AFullClassName: String): TPaxClassFactoryRec; +var + I: Integer; +begin + result := nil; + for I:=0 to Count - 1 do + if StrEql(Records[I].FullClassName, AFullClassName) then + begin + result := Records[I]; + break; + end; +end; + +function TPaxClassFactory.LookupFullName(const AFullClassName: String): TClass; +var + I: Integer; +begin + result := nil; + for I:=0 to Count - 1 do + if StrEql(Records[I].FullClassName, AFullClassName) then + begin + result := Records[I].DelphiClass; + break; + end; +end; + +procedure TPaxClassFactory.Reset; +var + I: Integer; +begin + for I:=0 to Count - 1 do + Records[I].Processed := false; +end; + +procedure TPaxClassFactory.SetupStdVirtuals(ClassList: TClassList; + CodePtr: Pointer); +var + I: Integer; + ClassRec: TClassRec; + FactoryRec: TPaxClassFactoryRec; + P: Pointer; +begin + for I:=0 to ClassList.Count - 1 do + begin + ClassRec := ClassList[I]; + if not ClassRec.Host then + begin + FactoryRec := FindRecord(ClassRec.PClass); + + if ClassRec.SafeCallExceptionProgOffset > 0 then + begin + P := ShiftPointer(CodePtr, ClassRec.SafeCallExceptionProgOffset); + vmtSafeCallExceptionSlot(FactoryRec.GetVMTPtr)^ := P; + end; + if ClassRec.AfterConstructionProgOffset > 0 then + begin + P := ShiftPointer(CodePtr, ClassRec.AfterConstructionProgOffset); + vmtAfterConstructionSlot(FactoryRec.GetVMTPtr)^ := P; + end; + if ClassRec.BeforeDestructionProgOffset > 0 then + begin + P := ShiftPointer(CodePtr, ClassRec.BeforeDestructionProgOffset); + vmtBeforeDestructionSlot(FactoryRec.GetVMTPtr)^ := P; + end; + if ClassRec.DispatchProgOffset > 0 then + begin + P := ShiftPointer(CodePtr, ClassRec.DispatchProgOffset); + vmtDispatchSlot(FactoryRec.GetVMTPtr)^ := P; + end; + if ClassRec.DefaultHandlerProgOffset > 0 then + begin + P := ShiftPointer(CodePtr, ClassRec.DefaultHandlerProgOffset); + vmtDefaultHandlerSlot(FactoryRec.GetVMTPtr)^ := P; + end; + if ClassRec.NewInstanceProgOffset > 0 then + begin + P := ShiftPointer(CodePtr, ClassRec.NewInstanceProgOffset); + vmtNewInstanceSlot(FactoryRec.GetVMTPtr)^ := P; + end; + if ClassRec.FreeInstanceProgOffset > 0 then + begin + P := ShiftPointer(CodePtr, ClassRec.FreeInstanceProgOffset); + vmtFreeInstanceSlot(FactoryRec.GetVMTPtr)^ := P; + end; + if ClassRec.DestructorProgOffset > 0 then + begin +// P := ShiftPointer(CodePtr, ClassRec.DestructorProgOffset); +// FactoryRec.GetVMTPtr^.Destroy := P; + end; + {$IFDEF UNIC} + if ClassRec.ToStringProgOffset > 0 then + begin + P := ShiftPointer(CodePtr, ClassRec.ToStringProgOffset); + vmtToStringSlot(FactoryRec.GetVMTPtr)^ := P; + end; + if ClassRec.GetHashCodeProgOffset > 0 then + begin + P := ShiftPointer(CodePtr, ClassRec.GetHashCodeProgOffset); + vmtGetHashCodeSlot(FactoryRec.GetVMTPtr)^ := P; + end; + if ClassRec.EqualsProgOffset > 0 then + begin + P := ShiftPointer(CodePtr, ClassRec.EqualsProgOffset); + vmtEqualsSlot(FactoryRec.GetVMTPtr)^ := P; + end; + {$ENDIF} + end; + end; +end; + +procedure TPaxClassFactory.SetupParents(Prog: Pointer; ClassList: TClassList); +var + I, J: Integer; + ClassFactoryRec, ParentFactoryRec: TPaxClassFactoryRec; + ClassRec, ParentClassRec: TClassRec; + C: TClass; + b: Boolean; + S: String; +begin + Reset; + + repeat + b := false; + + for I:=0 to Count - 1 do + begin + ClassFactoryRec := Records[I]; + if ClassFactoryRec.Processed then + continue; + + C := ClassFactoryRec.DelphiClass; + J := ClassList.FindClass(C); + if J = -1 then + raise Exception.Create(errInternalError); + + ClassRec := ClassList[J]; + ParentClassRec := ClassList.Lookup(ClassRec.ParentFullName); + + if ParentClassRec = nil then + begin + RaiseError(errInternalError, []); + end; + + if ParentClassRec.Host then // parent is host + begin + if ParentClassRec.PClass = nil then + begin + S := ExtractName(ClassRec.ParentFullName); + ParentClassRec.PClass := Classes.GetClass(S); + if ParentClassRec.PClass = nil then + begin + if Prog <> nil then + if Assigned(TBaseRunner(Prog).OnMapTableClassRef) then + begin + TBaseRunner(Prog).OnMapTableClassRef(TBaseRunner(Prog).Owner, + ClassRec.ParentFullName, true, ParentClassRec.PClass); + if ParentClassRec.PClass = nil then + TBaseRunner(Prog).RaiseError(errUnresolvedClassReference, + [ClassRec.ParentFullName]); + end; + if ParentClassRec.PClass = nil then + RaiseError(errClassIsNotRegistered, [ClassRec.ParentFullName]); + end; + end; + + b := true; + ClassFactoryRec.SetParentClass(ParentClassRec.PClass); + ClassFactoryRec.Processed := true; + end + else + begin + ParentFactoryRec := FindRecord(ParentClassRec.PClass); + + if ParentFactoryRec = nil then + raise Exception.Create(errInternalError); + + if ParentFactoryRec.Processed then + begin + b := true; + ClassFactoryRec.SetParentClass(ParentClassRec.PClass); + ClassFactoryRec.Processed := true; + end; + end; + end; + + if b = false then + break; + + until false; +end; + +procedure TPaxClassFactory.AddInheritedMethods; +var + I: Integer; + ClassFactoryRec, ParentFactoryRec: TPaxClassFactoryRec; + C: TClass; + b: Boolean; +begin + Reset; + + repeat + b := false; + + for I:=0 to Count - 1 do + begin + ClassFactoryRec := Records[I]; + if ClassFactoryRec.Processed then + continue; + C := ClassFactoryRec.DelphiClass; + + ParentFactoryRec := FindRecord(C.ClassParent); + if ParentFactoryRec = nil then // parent is host + begin + b := true; + AddInheritedMethods(C); + ClassFactoryRec.Processed := true; + end + else if ParentFactoryRec.Processed then + begin + b := true; + AddInheritedMethods(C); + ClassFactoryRec.Processed := true; + end; + end; + + if b = false then + break; + + until false; +end; + +procedure TPaxClassFactory.AddOverridenMethods(AProg: Pointer; ScriptMapTable: TMapTable); +var + I, J, K: Integer; + ClassFactoryRec, ParentFactoryRec: TPaxClassFactoryRec; + C: TClass; + b: Boolean; + MapRec, SomeMR: TMapRec; + P: Pointer; + PC: PPointerArray; + Prog: TBaseRunner; + S, FileName, ProcName: String; + DestProg: Pointer; +begin + Reset; + + Prog := TBaseRunner(AProg); + + repeat + b := false; + + for I:=0 to Count - 1 do + begin + ClassFactoryRec := Records[I]; + if ClassFactoryRec.Processed then + continue; + C := ClassFactoryRec.DelphiClass; + + ParentFactoryRec := FindRecord(C.ClassParent); + + if (ParentFactoryRec = nil) or ((ParentFactoryRec <> nil) and (ParentFactoryRec.Processed)) then + begin + b := true; + ClassFactoryRec.Processed := true; + + for J:=0 to ScriptMapTable.Count - 1 do + begin + MapRec := ScriptMapTable[J]; + if MapRec.SubDesc.MethodIndex > 0 then + begin + S := ExtractClassName(MapRec.FullName); + if not StrEql(S, StringFromPShortString(@ClassFactoryRec.fClassName)) then + continue; + + if MapRec.Offset = 0 then + begin + FileName := ExtractOwner(MapRec.FullName) + '.' + PCU_FILE_EXT; + ProcName := Copy(MapRec.FullName, PosCh('.', MapRec.FullName) + 1, Length(MapRec.FullName)); + P := Prog.LoadAddressEx(FileName, ProcName, false, 0, SomeMR, DestProg); + end + else + P := ShiftPointer(Prog.CodePtr, MapRec.Offset); + + C := ClassFactoryRec.DelphiClass; + PC := GetVArray(C); + PC^[MapRec.SubDesc.MethodIndex - 1] := P; + + for K:=0 to Count - 1 do + if K <> I then + if Records[K].DelphiClass.InheritsFrom(C) then + begin + PC := GetVArray(Records[K].DelphiClass); + PC^[MapRec.SubDesc.MethodIndex - 1] := P; + end; + end; + end; + end; + end; + + if b = false then + break; + + until false; +end; + +{ +procedure TPaxClassFactory.AddOverridenMethods(AProg: Pointer; ScriptMapTable: TMapTable); +var + I, J, K: Integer; + ClassFactoryRec, ParentFactoryRec: TPaxClassFactoryRec; + C: TClass; + b: Boolean; + MapRec: TMapRec; + P: Pointer; + Prog: TProgram; + S: AnsiString; +begin + Reset; + + Prog := TProgram(AProg); + + repeat + b := false; + + for I:=0 to Count - 1 do + begin + ClassFactoryRec := Records[I]; + if ClassFactoryRec.Processed then + continue; + C := ClassFactoryRec.DelphiClass; + + ParentFactoryRec := FindRecord(C.ClassParent); + if ParentFactoryRec = nil then // parent is host + begin + b := true; + ClassFactoryRec.Processed := true; + end + else if ParentFactoryRec.Processed then + begin + b := true; + ClassFactoryRec.Processed := true; + + for J:=0 to ScriptMapTable.Count - 1 do + begin + MapRec := ScriptMapTable[J]; + if MapRec.MethodIndex > 0 then + begin + S := ExtractClassName(MapRec.FullName); + if not StrEql(S, ClassFactoryRec.fClassName) then + continue; + + P := ShiftPointer(Prog.CodePtr, MapRec.Offset); + C := ClassFactoryRec.DelphiClass; + GetVArray(C)^[MapRec.MethodIndex - 1] := P; + + for K:=0 to Count - 1 do + if Records[K].DelphiClass.InheritsFrom(C) then + GetVArray(Records[K].DelphiClass)^[MapRec.MethodIndex - 1] := P; + end; + end; + end; + end; + + if b = false then + break; + + until false; +end; +} + +procedure TPaxClassFactory.AddInheritedMethods(SourceClass: TClass); +var + P, Q: PPointerArray; + I, K: Integer; +begin + if SourceClass.ClassParent = nil then + Exit; + + P := GetVArray(SourceClass.ClassParent); + + K := GetVirtualMethodCount(SourceClass.ClassParent); + + Q := GetVArray(SourceClass); + + for I:=0 to K - 1 do + Q^[I] := P^[I]; +end; + +procedure TPaxClassFactory.AddVirtualMethod(SourceClass: TClass; + SourceMethodAddress: Pointer); +var + P: PPointerArray; + K: Integer; +begin + P := GetVArray(SourceClass); + K := GetVirtualMethodCount(SourceClass); + P^[K] := SourceMethodAddress; +end; + +function TPaxClassFactory.AddOverridenMethod(SourceClass: TClass; + SourceMethodAddress, + InheritedMethodAddress: Pointer): Boolean; +var + P: PPointerArray; + I: Integer; +begin + result := false; + if SourceClass.ClassParent = nil then + Exit; + + I := VirtualMethodIndex(SourceClass.ClassParent, InheritedMethodAddress); + + if I = -1 then + Exit; + + P := GetVArray(SourceClass); + P^[I] := SourceMethodAddress; + + result := true; +end; + +end. diff --git a/Sources/PAXCOMP_CLASSLST.pas b/Sources/PAXCOMP_CLASSLST.pas new file mode 100644 index 0000000..adb9f36 --- /dev/null +++ b/Sources/PAXCOMP_CLASSLST.pas @@ -0,0 +1,851 @@ +//////////////////////////////////////////////////////////////////////////// +// PaxCompiler +// Site: http://www.paxcompiler.com +// Author: Alexander Baranovsky (paxscript@gmail.com) +// ======================================================================== +// Copyright (c) Alexander Baranovsky, 2006-2014. All rights reserved. +// Code Version: 4.2 +// ======================================================================== +// Unit: PAXCOMP_CLASSLST.pas +// ======================================================================== +//////////////////////////////////////////////////////////////////////////// + +{$I PaxCompiler.def} +unit PAXCOMP_CLASSLST; +interface +uses {$I uses.def} + TypInfo, + SysUtils, + Classes, + PAXCOMP_CONSTANTS, + PAXCOMP_TYPES, + PAXCOMP_SYS; + +type + TPropRec = class + public + PropInfo: Pointer; + PropOffset: Integer; + constructor Create; + destructor Destroy; override; + end; + + TPropList = class(TTypedList) + private + function GetInfo(I: Integer): PPropInfo; + public + procedure Add(P: Pointer; S: Integer); + function Top: TPropRec; + property Infos[I: Integer]: PPropInfo read GetInfo; default; + end; + + TIntfMethodRec = class + public + MethodOffset: IntPax; + InterfaceToObjectOffset: Integer; + FullMethodName: String; + procedure SaveToStream(S: TStream); + procedure LoadFromStream(S: TStream); + end; + + TIntfMethodList = class(TTypedList) + private + function GetRecord(I: Integer): TIntfMethodRec; + function AddRecord: TIntfMethodRec; + public + function AddMethod(const FullMethodName: String; + MethodOffset: IntPax; + InterfaceToObjectOffset: Integer): TIntfMethodRec; + procedure SaveToStream(S: TStream); + procedure LoadFromStream(S: TStream); + property Records[I: Integer]: TIntfMethodRec read GetRecord; default; + end; + + TIntfRec = class + private + fBuffSize: Integer; + public + GUID: TGUID; + Buff: PPointers; + IntfMethods: TIntfMethodList; + constructor Create; + destructor Destroy; override; + procedure AllocBuff; + procedure SetupBuff(CodePtr: Pointer); + procedure DeallocBuff; + procedure SaveToStream(P: TStream); + procedure LoadFromStream(P: TStream); + property BuffSize: Integer read fBuffSize; + end; + + TIntfList = class(TTypedList) + private + function GetRecord(I: Integer): TIntfRec; + public + function Add: TIntfRec; + procedure Setup(CodePtr: Pointer); + procedure SaveToStream(S: TStream); + procedure LoadFromStream(S: TStream); + function Lookup(const GUID: TGUID): TIntfRec; + function IndexOf(const GUID: TGUID): Integer; + property Records[I: Integer]: TIntfRec read GetRecord; default; + end; + + TClassRec = class + private + procedure AddPropInfos; + public + PClass: TClass; + PClass_pti: PTypeInfo; + PropInfos: TPropList; + + Offset: Integer; + SizeOfScriptClassFields: Integer; + Host: Boolean; + + DestructorProgOffset: Integer; + AfterConstructionProgOffset: Integer; + BeforeDestructionProgOffset: Integer; + SafeCallExceptionProgOffset: Integer; + DispatchProgOffset: Integer; + DefaultHandlerProgOffset: Integer; + NewInstanceProgOffset: Integer; + FreeInstanceProgOffset: Integer; +{$IFDEF UNIC} + ToStringProgOffset: Integer; + GetHashCodeProgOffset: Integer; + EqualsProgOffset: Integer; +{$ENDIF} + InstSize: Integer; + + FullName: String; + ParentFullName: String; + IntfList: TIntfList; + ByteCodeMethodEntryList: TIntegerDynArray; + VirtualMethodEntryList: array[1..100] of Integer; + constructor Create(i_PClass: TClass; i_Offset: Integer; i_Host: Boolean); + destructor Destroy; override; + procedure SetupInterfaces(CodePtr: Pointer); + function GetIntfOffset(const GUID: TGUID): Integer; + function GetIntfTableSize: Integer; + end; + + TClassList = class + private + L: TStringList; + function GetClassRec(I: Integer): TClassRec; + function GetName(I: Integer): String; + function GetCount: Integer; + public + constructor Create; + destructor Destroy; override; + procedure Clear; + function IndexOf(const S: String): Integer; + function FindClass(C: TClass): Integer; + function Add(const FullName: String; Host: Boolean): TClassRec; + function AddEx(const FullName: String; ClassIndex: Integer): TClassRec; + function AddClass(C: TClass; const FullName: String; + Host: Boolean; Offset: Integer): TClassRec; + function AddClassEx(C: TClass; + const FullName: String; + Host: Boolean; + Offset: Integer; + ClassIndex: Integer): TClassRec; + procedure SaveToStream(S: TStream); + procedure LoadFromStream(S: TStream; Version: Integer); + function GetSize: Integer; + procedure SetupInterfaces(CodePtr: Pointer); + function Lookup(const FullName: String): TClassRec; + function LookupClassRec(C: TClass): TClassRec; + function GetByteCodeMethodEntryIndex(N: Integer): Integer; + property Count: Integer read GetCount; + property Names[I: Integer]: String read GetName; + property Records[I: Integer]: TClassRec read GetClassRec; default; + end; + +var + AddPropInfosDRTTI: procedure(C: TClass; PropInfos: TPropList) = nil; + +implementation + +// TIntfMethodRec -------------------------------------------------------------- + +procedure TIntfMethodRec.SaveToStream(S: TStream); +begin + S.Write(MethodOffset, SizeOf(MethodOffset)); + S.Write(InterfaceToObjectOffset, SizeOf(InterfaceToObjectOffset)); + SaveStringToStream(FullMethodName, S); +end; + +procedure TIntfMethodRec.LoadFromStream(S: TStream); +begin + S.Read(MethodOffset, SizeOf(MethodOffset)); + S.Read(InterfaceToObjectOffset, SizeOf(InterfaceToObjectOffset)); + FullMethodName := LoadStringFromStream(S); +end; + +// TIntfMethodList ------------------------------------------------------------- + +function TIntfMethodList.GetRecord(I: Integer): TIntfMethodRec; +begin + result := TIntfMethodRec(L[I]); +end; + +function TIntfMethodList.AddRecord: TIntfMethodRec; +begin + result := TIntfMethodRec.Create; + L.Add(result); +end; + +function TIntfMethodList.AddMethod(const FullMethodName: String; + MethodOffset: IntPax; + InterfaceToObjectOffset: Integer): TIntfMethodRec; +begin + result := AddRecord; + result.FullMethodName := FullMethodName; + result.MethodOffset := MethodOffset; + result.InterfaceToObjectOffset := InterfaceToObjectOffset; +end; + +procedure TIntfMethodList.SaveToStream(S: TStream); +var + I, K: Integer; +begin + K := Count; + S.Write(K, SizeOf(Integer)); + for I := 0 to K - 1 do + Records[I].SaveToStream(S); +end; + +procedure TIntfMethodList.LoadFromStream(S: TStream); +var + I, K: Integer; +begin + S.Read(K, SizeOf(Integer)); + for I := 0 to K - 1 do + AddRecord.LoadFromStream(S); +end; + +// -- TIntfRec ----------------------------------------------------------------- + +constructor TIntfRec.Create; +begin + inherited; + IntfMethods := TIntfMethodList.Create; + fBuffSize := 0; +end; + +destructor TIntfRec.Destroy; +begin + FreeAndNil(IntfMethods); + if Buff <> nil then + DeallocBuff; + inherited; +end; + +procedure TIntfRec.SaveToStream(P: TStream); +begin + P.Write(GUID, SizeOf(GUID)); + IntfMethods.SaveToStream(P); +end; + +procedure TIntfRec.LoadFromStream(P: TStream); +begin + P.Read(GUID, SizeOf(GUID)); + IntfMethods.LoadFromStream(P); +end; + +procedure TIntfRec.AllocBuff; +begin + if Buff <> nil then + DeallocBuff; + fBuffSize := MAX_INTERFACE_IMPLEMENT_METHODS * SizeOf(Pointer) * 2; + Buff := AllocMem(fBuffSize); +end; + +procedure TIntfRec.SetupBuff(CodePtr: Pointer); +var + I, Offset, InterfaceToObjectOffset: Integer; + Adr: Pointer; +begin + for I:=0 to IntfMethods.Count - 1 do + begin + Offset := IntfMethods[I].MethodOffset; + InterfaceToObjectOffset := IntfMethods[I].InterfaceToObjectOffset; + if CodePtr <> nil then + begin + Adr := ShiftPointer(CodePtr, Offset); + end + else + begin + Adr := Pointer(Offset); + end; + Buff^[I] := Adr; + Buff^[MAX_INTERFACE_IMPLEMENT_METHODS + I] := Pointer(InterfaceToObjectOffset); + end; +end; + +procedure TIntfRec.DeallocBuff; +begin + if Buff <> nil then + FreeMem(Buff, fBuffSize); +end; + +// -- TIntfList ---------------------------------------------------------------- + +function TIntfList.Lookup(const GUID: TGUID): TIntfRec; +var + I: Integer; +begin + result := nil; + for I:=0 to Count - 1 do + if GuidsAreEqual(Records[I].GUID, GUID) then + begin + result := Records[I]; + Exit; + end; +end; + +function TIntfList.IndexOf(const GUID: TGUID): Integer; +var + I: Integer; +begin + result := -1; + for I:=0 to Count - 1 do + if GuidsAreEqual(Records[I].GUID, GUID) then + begin + result := I; + Exit; + end; +end; + +procedure TIntfList.SaveToStream(S: TStream); +var + I, K: Integer; +begin + K := Count; + S.Write(K, SizeOf(Integer)); + for I:=0 to K - 1 do + Records[I].SaveToStream(S); +end; + +procedure TIntfList.LoadFromStream(S: TStream); +var + I, K: Integer; + IntfRec: TIntfRec; +begin + S.Read(K, SizeOf(Integer)); + for I:=0 to K - 1 do + begin + IntfRec := TIntfRec.Create; + IntfRec.LoadFromStream(S); + L.Add(IntfRec); + end; +end; + +procedure TIntfList.Setup(CodePtr: Pointer); +var + I: Integer; + R: TIntfRec; +begin + for I:=0 to Count - 1 do + begin + R := Records[I]; + + R.AllocBuff; + R.SetupBuff(CodePtr); + end; +end; + +function TIntfList.GetRecord(I: Integer): TIntfRec; +begin + result := TIntfRec(L[I]); +end; + +function TIntfList.Add: TIntfRec; +begin + result := TIntfRec.Create; + L.Add(result); +end; + +// -- TPropRec ----------------------------------------------------------------- + +constructor TPropRec.Create; +begin + inherited; +end; + +destructor TPropRec.Destroy; +begin + inherited; +end; + +// -- TPropList ---------------------------------------------------------------- + + +procedure TPropList.Add(P: Pointer; S: Integer); +var + R: TPropRec; +begin + R := TPropRec.Create; + R.PropInfo := P; + R.PropOffset := S; + L.Add(R); +end; + +function TPropList.GetInfo(I: Integer): PPropInfo; +begin + result := TPropRec(L[I]).PropInfo; +end; + +function TPropList.Top: TPropRec; +begin + if Count = 0 then + result := nil + else + result := TPropRec(L[Count - 1]); +end; + +// -- TClassRec ---------------------------------------------------------------- + +constructor TClassRec.Create(i_PClass: TClass; i_Offset: Integer; i_Host: Boolean); +begin + inherited Create; + PClass := i_PClass; + Offset := i_Offset; + PropInfos := TPropList.Create; + Host := i_Host; + if PClass <> nil then + begin + PClass_pti := PClass.ClassInfo; + AddPropInfos; + end; + IntfList := TIntfList.Create; +end; + +destructor TClassRec.Destroy; +begin + FreeAndNil(PropInfos); + FreeAndNil(IntfList); + inherited; +end; + +procedure TClassRec.SetupInterfaces(CodePtr: Pointer); +begin + IntfList.Setup(CodePtr); +end; + +procedure TClassRec.AddPropInfos; +var + pti: PTypeInfo; + ptd: PTypeData; + Loop, nProps: Integer; + pProps: PPropList; + ppi: PPropInfo; + PropOffset: Integer; +begin + PropInfos.Clear; + + pti := PClass.ClassInfo; + if pti = nil then Exit; + ptd := GetTypeData(pti); + nProps := ptd^.PropCount; + + if nProps > 0 then + begin + GetMem(pProps, SizeOf(PPropInfo) * nProps); + try + GetPropInfos(pti, pProps); + for Loop:=0 to nProps - 1 do + begin + {$ifdef fpc} + ppi := pProps^[Loop]; + {$else} + ppi := pProps[Loop]; + {$endif} + PropOffset := Offset + (Loop + 1) * SizeOf(Pointer); + PropInfos.Add(ppi, PropOffset); + end; + finally + FreeMem(pProps, SizeOf(PPropInfo) * nProps); + end; + end; + + if Assigned(AddPropInfosDRTTI) then + AddPropInfosDRTTI(PClass, PropInfos); +end; + +function TClassRec.GetIntfOffset(const GUID: TGUID): Integer; +var + I: Integer; +begin + result := 0; + I := IntfList.IndexOf(GUID); + if I = -1 then + Exit; + result := InstSize - SizeOf(Pointer) - IntfList.Count * SizeOf(Pointer) + + I * SizeOf(Pointer); +end; + +function TClassRec.GetIntfTableSize: Integer; +begin + result := SizeOf(Integer) + // EntryCount + IntfList.Count * SizeOf(TInterfaceEntry); +end; + +// -- TClassList --------------------------------------------------------------- + +constructor TClassList.Create; +begin + inherited; + L := TStringList.Create; +end; + +function TClassList.GetCount: Integer; +begin + result := L.Count; +end; + +function TClassList.GetClassRec(I: Integer): TClassRec; +begin + result := TClassRec(L.Objects[I]); +end; + +function TClassList.GetName(I: Integer): String; +begin + result := L[I]; +end; + +function TClassList.IndexOf(const S: String): Integer; +begin + result := L.IndexOf(S); +end; + +function TClassList.Add(const FullName: String; Host: Boolean): TClassRec; +begin + result := TClassRec.Create(nil, 0, false); + result.FullName := FullName; + result.Host := Host; + L.AddObject(ExtractName(FullName), result); +end; + +function TClassList.AddEx(const FullName: String; ClassIndex: Integer): TClassRec; +begin + while L.Count < ClassIndex + 1 do + L.Add(''); + + if Assigned(L.Objects[ClassIndex]) then +{$IFDEF ARC} + L.Objects[ClassIndex] := nil; +{$ELSE} + L.Objects[ClassIndex].Free; +{$ENDIF} + + result := TClassRec.Create(nil, 0, false); + result.FullName := FullName; + L.Objects[ClassIndex] := result; +end; + +function TClassList.AddClass(C: TClass; const FullName: String; + Host: Boolean; Offset: Integer): TClassRec; +var + I: Integer; + S: String; +begin + S := C.ClassName; + + I := L.IndexOf(S); + if I = -1 then + begin + result := TClassRec.Create(C, Offset, Host); + L.AddObject(S, result); + end + else + begin + result := TClassRec(L.Objects[I]); + + if Assigned(result) then + begin + if result.PClass = nil then + begin + FreeAndNil(result); + result := TClassRec.Create(C, Offset, Host); + end + else + result.AddPropInfos; + end + else + result := TClassRec.Create(C, Offset, Host); + + L.Objects[I] := result; + end; + result.FullName := FullName; +end; + +function TClassList.AddClassEx(C: TClass; + const FullName: String; + Host: Boolean; + Offset: Integer; + ClassIndex: Integer): TClassRec; +begin + while L.Count < ClassIndex + 1 do + L.AddObject('', nil); + + result := TClassRec(L.Objects[ClassIndex]); + + if Assigned(result) then + begin + if result.PClass = nil then + begin + FreeAndNil(result); + result := TClassRec.Create(C, Offset, Host); + end + else + result.AddPropInfos; + end + else + result := TClassRec.Create(C, Offset, Host); + + L.Objects[ClassIndex] := result; + result.FullName := FullName; +end; + +procedure TClassList.SetupInterfaces(CodePtr: Pointer); +var + I: Integer; +begin + for I:=0 to Count - 1 do + Records[I].SetupInterfaces(CodePtr); +end; + +procedure TClassList.Clear; +var + I: Integer; +begin + for I:=0 to L.Count - 1 do + begin + if L.Objects[I] <> nil then +{$IFDEF ARC} + L.Objects[I] := nil; +{$ELSE} + L.Objects[I].Free; +{$ENDIF} + end; + L.Clear; +end; + +destructor TClassList.Destroy; +begin + Clear; + FreeAndNil(L); + inherited; +end; + +function TClassList.FindClass(C: TClass): Integer; +var + I: Integer; +begin + result := -1; + for I:=0 to L.Count - 1 do + if Records[I].PClass = C then + begin + result := I; + Exit; + end; +end; + +function TClassList.Lookup(const FullName: String): TClassRec; +var + I: Integer; + ClassRec: TClassRec; +begin + result := nil; + for I:=0 to Count - 1 do + begin + ClassRec := Records[I]; + if StrEql(ClassRec.FullName, FullName) then + begin + result := ClassRec; + Exit; + end; + end; +end; + +function TClassList.LookupClassRec(C: TClass): TClassRec; +var + I: Integer; + ClassRec: TClassRec; +begin + result := nil; + for I:=0 to Count - 1 do + begin + ClassRec := Records[I]; + if StrEql(ClassRec.PClass.ClassName, C.ClassName) then + begin + result := ClassRec; + Exit; + end; + end; +end; + +function TClassList.GetSize: Integer; +var + S: TMemoryStream; +begin + S := TMemoryStream.Create; + try + SaveToStream(S); + result := S.Size; + finally + FreeAndNil(S); + end; +end; + +type + TSaveClassRec = packed record + Offset: Integer; + SizeOfScriptClassFields: Integer; + DestructorProgOffset: Integer; + AfterConstructionProgOffset: Integer; + BeforeDestructionProgOffset: Integer; + SafeCallExceptionProgOffset: Integer; + DispatchProgOffset: Integer; + DefaultHandlerProgOffset: Integer; + NewInstanceProgOffset: Integer; + FreeInstanceProgOffset: Integer; + InstSize: Integer; + +{$IFDEF UNIC} + ToStringProgOffset: Integer; + GetHashCodeProgOffset: Integer; + EqualsProgOffset: Integer; +{$ENDIF} + + Host: Boolean; + end; + +procedure PackRec(var S: TSaveClassRec; const R: TClassRec); +begin + S.Offset := R.Offset; + S.InstSize := R.InstSize; + S.DestructorProgOffset := R.DestructorProgOffset; + S.AfterConstructionProgOffset := R.AfterConstructionProgOffset; + S.BeforeDestructionProgOffset := R.BeforeDestructionProgOffset; + S.SafeCallExceptionProgOffset := R.SafeCallExceptionProgOffset; + S.DispatchProgOffset := R.DispatchProgOffset; + S.DefaultHandlerProgOffset := R.DefaultHandlerProgOffset; + S.NewInstanceProgOffset := R.NewInstanceProgOffset; + S.FreeInstanceProgOffset := R.FreeInstanceProgOffset; + S.SizeOfScriptClassFields := R.SizeOfScriptClassFields; + S.Host := R.Host; + +{$IFDEF UNIC} + S.ToStringProgOffset := R.ToStringProgOffset; + S.GetHashCodeProgOffset := R.GetHashCodeProgOffset; + S.EqualsProgOffset := R.EqualsProgOffset; +{$ENDIF} +end; + +procedure UnPackRec(S: TClassRec; const R: TSaveClassRec); +begin + S.Offset := R.Offset; + S.InstSize := R.InstSize; + S.DestructorProgOffset := R.DestructorProgOffset; + S.AfterConstructionProgOffset := R.AfterConstructionProgOffset; + S.BeforeDestructionProgOffset := R.BeforeDestructionProgOffset; + S.SafeCallExceptionProgOffset := R.SafeCallExceptionProgOffset; + S.DispatchProgOffset := R.DispatchProgOffset; + S.DefaultHandlerProgOffset := R.DefaultHandlerProgOffset; + S.NewInstanceProgOffset := R.NewInstanceProgOffset; + S.FreeInstanceProgOffset := R.FreeInstanceProgOffset; + S.SizeOfScriptClassFields := R.SizeOfScriptClassFields; + S.Host := R.Host; + +{$IFDEF UNIC} + S.ToStringProgOffset := R.ToStringProgOffset; + S.GetHashCodeProgOffset := R.GetHashCodeProgOffset; + S.EqualsProgOffset := R.EqualsProgOffset; +{$ENDIF} +end; + +procedure TClassList.SaveToStream(S: TStream); +var + I: Integer; + SR: TSaveClassRec; +begin + SaveStringListToStream(L, S); + for I:=0 to L.Count - 1 do + begin + PackRec(SR, Records[I]); + + with Records[I] do + begin + SaveStringToStream(FullName, S); + SaveStringToStream(ParentFullName, S); + S.Write(SR, SizeOf(SR)); + IntfList.SaveToStream(S); + if not Host then + begin + SaveIntDynarrayToStream(BytecodeMethodEntryList, S); + S.Write(VirtualMethodEntryList, SizeOf(VirtualMethodEntryList)); + end; + end; + end; +end; + +procedure TClassList.LoadFromStream(S: TStream; Version: Integer); +var + I: Integer; + RI: TClassRec; + SR: TSaveClassRec; +begin + Clear; + + LoadStringListFromStream(L, S); + for I:=0 to L.Count - 1 do + begin + L.Objects[I] := TClassRec.Create(nil, 0, false); + RI := Records[I]; + with RI do + begin + FullName := LoadStringFromStream(S); + ParentFullName := LoadStringFromStream(S); + S.Read(SR, SizeOf(SR)); + UnPackRec(RI, SR); + IntfList.LoadFromStream(S); + if not Host then + begin + BytecodeMethodEntryList := LoadIntDynarrayFromStream(S); + S.Read(VirtualMethodEntryList, SizeOf(VirtualMethodEntryList)); + end; + PClass := nil; + end; + end; +end; + +function TClassList.GetByteCodeMethodEntryIndex(N: Integer): Integer; +var + I, J, V, L: Integer; + R: TClassRec; +begin + result := -1; + for I := Count - 1 downto 0 do + begin + R := Records[I]; + L := System.Length(R.ByteCodeMethodEntryList); + for J := 0 to L - 1 do + begin + V := R.ByteCodeMethodEntryList[J]; + if V = 0 then + break; + + if V = N then + begin + result := J; + Exit; + end; + end; + end; +end; + +end. diff --git a/Sources/PAXCOMP_CONSTANTS.pas b/Sources/PAXCOMP_CONSTANTS.pas new file mode 100644 index 0000000..7d7f5a2 --- /dev/null +++ b/Sources/PAXCOMP_CONSTANTS.pas @@ -0,0 +1,569 @@ +//////////////////////////////////////////////////////////////////////////// +// PaxCompiler +// Site: http://www.paxcompiler.com +// Author: Alexander Baranovsky (paxscript@gmail.com) +// ======================================================================== +// Copyright (c) Alexander Baranovsky, 2006-2014. All rights reserved. +// Code Version: 4.2 +// ======================================================================== +// Unit: PAXCOMP_CONSTANTS.pas +// ======================================================================== +//////////////////////////////////////////////////////////////////////////// + +{$I PaxCompiler.def} +unit PAXCOMP_CONSTANTS; +interface + +type + TTargetPlatform = (tpNONE, + tpWin32, + tpWin64, + tpOSX32, + tpIOSSim, + tpIOSDEv, + tpANDROID, + tpLINUX32); + + TRunnerKind = (rkNONE, rkPROGRAM, rkINTERPRETER); + +const + MaxHash = 9973; //199; //99991; + PaxSignatureLength = 19; + MaxInsertPoints = 30; + +{$IFDEF ARC} +type + TPaxSignature = array[0..PaxSignatureLength] of Byte; + ShortString = array[0..255] of Byte; + PShortString = ^ShortString; + +function Length(const S: ShortString): Integer; overload; +function Length(const S: String): Integer; overload; + +const + strPaxSignature: TPaxSignature = (19, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, + 11, 12, 13, 14, 15, 16, 17, 18, 19); +{$ELSE} +const + strPaxSignature = 'This is a pax class'; +type + TPaxSignature = String[PaxSignatureLength]; +{$ENDIF} + +type +{$IFDEF UNIC} + UnicString = UnicodeString; +{$ELSE} + UnicString = WideString; +{$ENDIF} + +{$IFDEF PAX64} + IntPax = Int64; +{$ELSE} + IntPax = Integer; +{$ENDIF} + PIntPax = ^IntPax; + + PUnicString = ^UnicString; + + TPaxLang = (lngPascal, lngC, lngBasic, lngJS); + + TIPoint = record + Line, Indent: Integer; + end; + + TParamMode = (parNone, parVar, parOut, parConst); + +var + IsDump: Boolean = false; + DUMP_PATH: String = ''; +{$IFDEF GENERICS} + GENERICS_ALLOWED: Boolean = true; +{$ELSE} + GENERICS_ALLOWED: Boolean = false; +{$ENDIF} + Id_TObject_ClassName: Integer = 0; + + typeNATIVEINT: Integer; + +const + IdsSet = [Ord('a')..Ord('z'), Ord('A')..Ord('Z'), Ord('0')..Ord('9'), Ord('_')]; + WhiteSpaces = [32, 8, 9, 11, 12]; + + ANONYMOUS_METHOD_NAME = '__ANONYM_MTD_'; + ANONYMOUS_CLASS_PREFIX = '__ANONYM_CLS_'; + ANONYMOUS_OBJECT_PREFIX = '__ANONYM_OBJ_'; + + EXTRA_KEYWORD = '__extra__'; + + PAX_SEH = 17177; + + VARIANT_SIZE = SizeOf(Variant); + + StrExprResult = '__result'; + StrOuterThis = '_outer_this_'; // keeps instance of outer class + + MAX_COMMENTED_TOKENS: Integer = 7; + + MAX_INTERFACE_IMPLEMENT_METHODS = 1000; + + PM_BYVAL = 0; + PM_BYREF = 1; + PM_CONST = 2; + PM_OUT = 3; + + PCU_FILE_EXT = 'PCU'; + + PRM_FILE_EXT = 'PRM'; + PRR_FILE_EXT = 'PRR'; + + LOC_FILE_EXT = 'LOC'; + LOR_FILE_EXT = 'LOR'; + + SLF_FILE_EXT = 'SLF'; + FLD_FILE_EXT = 'FLD'; + + MAGIC_INITIALIZATION_JMP_COUNT = 5; + MAGIC_FINALIZATION_JMP_COUNT = 7; + + TAG_DISCARD_VIRTUAL_CALL = 1; + TAG_DISCARD_STMT = 2; + + DummyName = '__DummyName'; + PARAMS_DELIMITER = '-'; + + DUMMYPROC_PREFIX = 'DummyProc_'; + + READ_PREFIX = '_Read_'; + WRITE_PREFIX = '_Write_'; + + IntMaxArgs = 20; + + ccSTDCALL = 1; + ccREGISTER = 2; + ccCDECL = 3; + ccPASCAL = 4; + ccSAFECALL = 5; + ccMSFASTCALL = 6; + cc64 = 7; + + typeVOID = 1; + typeBOOLEAN = 2; + typeBYTE = 3; +{$IFNDEF PAXARM} + typeANSICHAR = 4; + typeANSISTRING = 5; +{$ENDIF} + typeWORD = 6; + typeINTEGER = 7; + typeDOUBLE = 8; + typePOINTER = 9; + typeRECORD = 10; + typeARRAY = 11; + typeALIAS = 12; + typeENUM = 13; + typePROC = 14; + typeSET = 15; +{$IFNDEF PAXARM} + typeSHORTSTRING = 16; +{$ENDIF} + typeSINGLE = 17; + typeEXTENDED = 18; + typeCLASS = 19; + typeCLASSREF = 20; + typeWIDECHAR = 21; +{$IFNDEF PAXARM} + typeWIDESTRING = 22; +{$ENDIF} + typeVARIANT = 23; + typeDYNARRAY = 24; + typeINT64 = 25; + typeINTERFACE = 26; + typeCARDINAL = 27; + typeEVENT = 28; + typeCURRENCY = 29; + typeSMALLINT = 30; + typeSHORTINT = 31; + typeWORDBOOL = 32; + typeLONGBOOL = 33; + typeBYTEBOOL = 34; + typeOLEVARIANT = 35; + typeUNICSTRING = 36; + typeOPENARRAY = 37; + typeTYPEPARAM = 38; + typeUINT64 = 39; + typeVOBJECT = 40; + typeHELPER = 41; +{$IFNDEF PAXARM} + typePANSICHAR = 49; +{$ENDIF} + typePVOID = 50; + typePWIDECHAR = 51; + +{$IFDEF UNIC} + typeSTRING = typeUNICSTRING; + typeCHAR = typeWIDECHAR; + typePCHAR = typePWIDECHAR; +{$ELSE} + typeSTRING = typeANSISTRING; + typeCHAR = typeANSICHAR; + typePCHAR = typePANSICHAR; +{$ENDIF} + + CURR_MUL = 10000; + + rmRUN = 0; + rmTRACE_INTO = 1; + rmSTEP_OVER = 2; + rmRUN_TO_CURSOR = 3; + rmNEXT_SOURCE_LINE = 4; + + PASCAL_LANGUAGE = 0; + C_LANGUAGE = 1; + BASIC_LANGUAGE = 2; + JS_LANGUAGE = 3; + JAVA_LANGUAGE = 4; + + CHAR_EOF = #255; + CHAR_REMOVE = #254; + CHAR_AP = ''''; + CHAR_DOUBLE_AP = '"'; + + cmNONE = 0; + cmVIRTUAL = 1; + cmOVERRIDE = 2; + cmDYNAMIC = 3; + cmSTATIC = 4; + + _NOREG = 0; + _EAX = _NOREG + 1; + _ECX = _NOREG + 2; + _EDX = _NOREG + 3; + _EBX = _NOREG + 4; + _ESP = _NOREG + 5; + _EBP = _NOREG + 6; + _ESI = _NOREG + 7; + _EDI = _NOREG + 8; + _R8 = _NOREG + 9; + _R9 = _NOREG + 10; + _R10 = _NOREG + 11; + _R11 = _NOREG + 12; + _R12 = _NOREG + 13; + _R13 = _NOREG + 14; + _R14 = _NOREG + 15; + _R15 = _NOREG + 16; + + R32 = [_EAX.._EDI]; + R64 = [_R8.._R15]; + + _XMM0 = 100; + _XMM1 = 101; + _XMM2 = 102; + _XMM3 = 103; + _XMM4 = 104; + + CommonRegisters = [_EAX.._EBX, _R8, _R9]; + + strExtraPascalUnit = '__extra_pascal__'; + strExtraBasicUnit = '__extra_basic__'; + strExtraJavaUnit = '__extra_java__'; + + strPascalLanguage = 'Pascal'; + strPascalNamespace = 'PascalNamespace'; + + strBasicLanguage = 'Basic'; + strBasicNamespace = 'BasicNamespace'; + + strJavaScriptLanguage = 'JavaScript'; + strJavaScriptNamespace = 'JavaScriptNamespace'; + strJavaScriptTempNamespace = 'JavaScriptTempNamespace'; + + strWrite = 'write'; + strWriteln = 'writeln'; + strGetTickCount = 'GetTickCount'; + strUnassigned = 'Unassigned'; + +//------------------ Dynamic array support routines ---------------------------- + + _strGetOLEProperty = '_GetOleProperty'; + _strSetOLEProperty = '_SetOleProperty'; + +//------ JS -------- + + strCreate = 'Create'; + strInternalFuncAddr = 'InternalFuncAddr'; + strInternalCreate = 'InternalCreate'; + strInternalLength = 'InternalLength'; + strInternalCall = 'InternalCall'; + strInternalConstructor = 'InternalConstructor'; + str__this = '__this'; + strProgram = 'aprogram'; + + strInternalFWArrayCreate = '__FWArrayCreate'; + +{$IFDEF MACOS32} + MEM_COMMIT = 0; + PAGE_EXECUTE_READWRITE = 0; +{$ENDIF} + +{$IFDEF FPC} +const +{$ELSE} +resourcestring +{$ENDIF} + + errInternalError = 'Internal error'; + errInternalErrorMethodIndex = 'Internal error - method index is not set correctly'; + errWrongCall = 'Wrong call - instance is not created.'; + + errEmptyModuleList = 'Empty module list. Use AddModule to add modules.'; + errUnregisteredLanguage = 'Unregistered language %s'; + errSyntaxError = 'Syntax error'; + errUnterminatedString = 'Unterminated string'; + errTokenExpected = '"%s" expected but "%s" found'; + errIdentifierExpected = 'Identifier expected but "%s" found'; + errIdentifierExpectedNoArgs = 'Identifier expected'; + errLabelExpected = 'Label expected'; + errPCharLiteralExpected = 'PChar literal expected'; + errIncompatibleTypesNoArgs = 'Incompatible types'; + errIncompatibleTypes = 'Incompatible types "%s" and "%s"'; + errOperatorNotApplicableToThisOperandType = 'Operator not applicable to "%s" type'; + errOperatorNotApplicableToThisOperandTypeNoArgs = 'Operator not applicable to this type'; + errLeftSideCannotBeAssignedTo = 'Left side cannot be assigned to'; + errUndeclaredIdentifier = 'Undeclared identifier "%s"'; + errUndeclaredType = 'Undeclared type "%s"'; + errRedeclaredIdentifier = 'Redeclared identifier "%s"'; + errModuleNotFound = 'Module "%s" not found'; + errLanguageNotRegistered = 'Language "%s" not registered'; + errFileNotFound = 'File "%s" not found'; + errTooManyActualParameters = 'Too many actual parameters'; + errNotEnoughActualParameters = 'Not enough actual parameters'; + errLabelIsDeclaredButNeverUsed = 'Label "%s" is declared but never used'; + errThereIsNoOverloaded = 'There is no overloaded version of "%s" that can be called with these arguments'; + errAmbiguousOverloadedCall = 'Ambiguous overloaded call to "%s"'; + errDefaultParameterMustBeByValueOrConst = 'Default parameter "%s" must be by-value or const'; + errParameterNotAllowedHere = 'Parameter "%s" not allowed here due to default value'; + errConstantExpressionExpected = 'Constant expression expected'; + errCannotInitializeLocalVariables = 'Cannot initialize local variables'; + errRecordRequired = 'Record required'; + errClassTypeRequired = 'Class type required'; + errArrayTypeRequired = 'Array type required'; + errSetTypeRequired = 'Set type required'; + errOrdinalTypeRequired = 'Ordinal type required'; + errIllegalTypeInWriteStatememt = 'Illegal type in Write/Writeln statement'; + errConstantExpressionViolatesSubrangeBounds = 'Constant expression violates subrange bounds'; + errLowBoundExceedsHighBound = 'Low bound exceeds high bound'; + errPACKEDNotAllowedHere = 'PACKED not allowed here'; + errVariableRequired = 'Variable required'; + errLineTerminatorExpected = 'Line terminator expected'; + errStatementTerminatorExpected = 'Statement terminator expected'; + errTypeOfExpressionMustBe = 'Type of expression must be %s'; + errBreakOrContinueOutsideOfLoop = 'BREAK or CONTINUE outside of loop'; + errNextControlVariableDoesNotMatchForLoopControlVariable = 'Next control variable does not match For loop control variable %s'; + errDivisionByZero = 'Division by zero'; + errCannotApplyCall = 'Cannot apply () to "%s"'; + errUnsatisfiedForwardOrExternalDeclaration = 'Unsatisfied forward or external declaration: "%s"'; + errCircularUnitReference = 'Circular unit reference to "%s"'; + errTypesOfActualAndFormalVarParametersMustBeIdentical = 'Types of actual and formal var parameters must be identical'; + errClassNotFound = 'Class "%s" not found'; + errTypeNotFound = 'Type "%s" not found'; + errThisFormOfMethodCanOnlyAllowedForClassMethod = 'This form of method can only allowed for class methods'; + errCannotAssignToReadOnlyProperty = 'Cannot assign to read-only property'; + errCannotReadWriteOnlyProperty = 'Cannot read a write-only property'; + errClassDoesNotHaveDefaultProperty = 'Class "%s" does not have a default property'; + errCannotRegisterClass = 'Cannot register class "%s"'; + errIMPORT_ActiveX = 'Error. You have to add "IMPORT_ActiveX.pas" to your project'; + errIntegerOverflow = 'Integer overflow'; + errRangeCheckError = 'Range check error'; + errThisFormOfMethodCallOnlyAllowedInMethodsOfDerivedTypes = 'This form of method call only allowed in methods of derived types'; + errYouCannotUseIncOnProperties = 'You can''t use Inc on properties because it modifies the parameter.'; + errYouCannotUseDecOnProperties = 'You can''t use Dec on properties because it modifies the parameter.'; + errDefaultValueRequired = 'Default value required for "%s".'; + errClassIsNotRegistered = 'Class "%s" is not registered.'; + errAbstractMethodsMustBeVirtual = 'Abstract methods must be virtual.'; + errAbstractMethodCall = 'Abstract method call.'; + errDebugModeIsRequred = 'Debug mode is required.'; + errProgramIsNotPaused = 'Program is not paused.'; + errInvalidId = 'Invalid id "%d"'; + errInvalidIndex = 'Invalid index "%d"'; + errInvalidValue = 'Invalid value'; + errMemoryNotInitialized = 'Memory not initialized'; + errNotValidObject = 'Not a valid object'; + errDllNotFound = 'This script has failed to start because %s was not found.'; + errProcNotFound = 'The procedure entry point %s could not be located in the' + + ' dynamic link library %s.'; + errProcNotFoundInPCU = 'The procedure entry point %s could not be located in the' + + ' pcu %s.'; + errEntryPointNotFoundInPCU = 'The entry point %s could not be located in the' + + ' pcu %s.'; + errConstructorNotFoundInClass = 'Constructor not found in class "%s"'; + errPropertyIsForbidden = 'Property "%s" of class "%s" is forbidden.'; + errHostMemberIsNotDefined = 'Host member "%s" is not defined.'; + errCannotRegisterHostMember = 'Cannot register host member "%s".'; + errInvalidAlignmentValue = '"%d" is invalid alignment value. Must be 1, 2, 4 or 8.'; + errInvalidCompilerDirective = 'Invalid compiler directive "%s".'; + errTooManyNestedCaseBlocks = 'Too many nested case blocks.'; + errProtectionLevel = ' "%s" is inaccessible due to its protection level.'; + errMissingENDIFdirective = 'Missing ENDIF directive.'; + errPropertyDoesNotExistsInTheBaseClass = 'Property "%s" does not exist in the base class.'; + errMethodDoesNotExistsInTheBaseClass = 'Method "%s" does not exist in the base class.'; + errIncorrectValue = 'Incorrect value.'; + errUnresolvedClassReference = 'Unresolved class reference "%s".'; + errUnresolvedAddress = 'Unresolved address "%s".'; + errIncorrectStreamVersion = 'Incorrect stream version.'; + errIncorrectCompiledScriptVersion = 'Incorrect compiled script version'; + errInvalidVariantType = 'Variant type not safe on debugger or invalid variant type'; + errClassTypeExpected = 'Class type expected'; + errUndeclaredInterface = 'Undeclared interface "%s"'; + errDeclarationDiffersFromPreviousDeclaration = 'Declaration of "%s" differs from previous declaration'; + errTheCallOfInheritedConstructorIsMandatory = 'The Call of inherited constructor is mandatory'; + errFieldDefinitionNotAllowedAfter = 'Field definition not allowed after methods or properties.'; + errKeywordNotAllowedInInterfaceDeclaration = '"%s" not allowed in interface declaration.'; + errUnknownDirective = 'Unknown directive "%s"'; + errUnknownLanguage = 'Unknown language "%s"'; + errCannotOverrideStaticMethod = 'Cannot override a static method'; + errNoDefinitionForAbstractMethodAllowed = 'No definition for abstract method "%s" allowed.'; + errWrongRegistration = 'Wrong registration'; + errConstantObjectCannotBePassedAsVarParameter = 'Constant object cannot be passed as var parameter'; + errError = 'error'; + errCanceled = 'Canceled'; + errPropertyInaccessibleHere = 'Property "%s" inaccessible here'; + + STooManyParams = 'Dispatch methods do not support more than 64 parameters'; + errLabelNotFound = 'Label not found'; + errRoutineNotFound = 'Routine "%s" not found'; + errPropertyNotFound = 'Property "%s" not found'; + errUnknownStreamFormat = 'Unknown stream format'; + errTypeHasNotEnumerator = 'Type "%s" has not enumerator'; + errParameterCannotHaveDefaultValue = 'Parameters of this type cannot have default values'; + + errE2015 = 'Operator not applicable to this operand type'; + errE2376 = 'STATIC can only be used on non-virtual class methods'; + errE2379 = 'Virtual methods not allowed in record types'; + errE2393 = 'Invalid operator declaration'; + errE2398 = 'Class methods in record types must be static'; + errE2517 = 'Operator "%s" must take "%d" parameter'; + + errE2072 = 'Number of elements "%d" differs from declaration "%d" '; + + errOverloadExpected = 'Overloaded procedure "%s" must be marked with "overload" directive'; + + errCannotImport = 'Cannot import "%s"'; + errTypeWasNotImported = 'Type was not imported for "%s"'; + + errIncorrectCustomDataSize = 'Incorrect size of custom data'; + + strNBounds = 'NBounds'; + strElFinalTypeId = 'ElFinTypeId'; + strElTypeId = 'ElTypeId'; + strElSize = 'ElSize'; + + pascal_Implicit = 'Implicit'; + pascal_Explicit = 'Explicit'; + pascal_Add = 'Add'; + pascal_Divide = 'Divide'; + pascal_IntDivide = 'IntDivide'; + pascal_Modulus = 'Modulus'; + pascal_Multiply = 'Multiply'; + pascal_Subtract = 'Subtract'; + pascal_Negative = 'Negative'; + pascal_Positive = 'Positive'; + pascal_LogicalNot = 'LogicalNot'; + pascal_LeftShift = 'LeftShift'; + pascal_RightShift = 'RightShift'; + pascal_LogicalAnd = 'LogicalAnd'; + pascal_LogicalOr = 'LogicalOr'; + pascal_LogicalXor = 'LogicalXor'; + pascal_LessThan = 'LessThan'; + pascal_LessThanOrEqual = 'LessThanOrEqual'; + pascal_GreaterThan = 'GreaterThan'; + pascal_GreaterThanOrEqual = 'GreaterThanOrEqual'; + pascal_Equal = 'Equal'; + pascal_NotEqual = 'NotEqual'; + pascal_Inc = 'Inc'; + pascal_Dec = 'Inc'; + + gen_Implicit = '&op_Implicit'; + gen_Explicit = '&op_Explicit'; + gen_Add = '&op_Addition'; + gen_Divide = '&op_Division'; + gen_IntDivide = '&op_IntDivide'; + gen_Modulus = '&op_Modulus'; + gen_Multiply = '&op_Multiply'; + gen_Subtract = '&op_Subtraction'; + gen_Negative = '&op_UnaryNegation'; + gen_Positive = '&op_UnaryPlus'; + gen_LogicalNot = '&op_LogicalNot'; + gen_LeftShift = '&op_LeftShift'; + gen_RightShift = '&op_RightShift'; + gen_LogicalAnd = '&op_LogicalAnd'; + gen_LogicalOr = '&op_LogicalOr'; + gen_LogicalXor = '&op_LogicalXor'; + gen_LessThan = '&op_LessThan'; + gen_LessThanOrEqual = '&op_LessThanOrEqual'; + gen_GreaterThan = '&op_GreaterThan'; + gen_GreaterThanOrEqual = '&op_GreaterThanOrEqual'; + gen_Equal = '&op_Equality'; + gen_NotEqual = '&op_Inequality'; + gen_Inc = '&op_Increment'; + gen_Dec = '&op_Decrement'; + +//Basic + errThisWayOfCallIsAllowedOnlyForProcedures = 'This way of call is allowed only for procedures'; + +//JS + errCannotConvertToFunctionObject = 'Cannot convert to Function Object'; +// errJSUnitHasBeenNotIncluded = 'JavaScript unit has been not included in current project'; + errCannotConvertToJS_Object = 'Cannot convert to JavaScript object'; + errReferenceError = 'Reference error'; + + errNotImplementedYet = 'Not implemented yet'; + + wrnNeverUsedIn = 'Variable "%s" is declared but never used in "%s"'; + wrnNeverUsed = 'Variable "%s" is declared but never used'; + wrnPrivateNeverUsed = 'Private symbol "%s" is declared but never used'; + wrnNotInit = 'Variable "%s" might not have been initialized'; + wrnReturnValue = 'Return value of function "%s" might be undefined'; + + errExplicitTypeDeclarationRequired = 'Explicit declaration of type required'; + errOverridenMethodIsFinal = 'Overriden method "%s" is final.'; + errCannotInheritFromFinalClass = 'Cannot inherit from final class "%s".'; + errCannotInheritFromSealedClass = 'Cannot inherit from sealed class "%s".'; + + errTypeParameterNotAllowed = 'Type parameters not allowed on this type'; + errTypeIsNotValidConstraint = 'Type "%s" is not a valid constraint'; + errInvalidTypeCast = 'Invalid typecast'; + errInvalidSet = 'Sets may have at most 256 elements'; + + errVirtualObjectMethodCallEventNotAssigned = 'OnVirtualObjectMethodCall event is not assigned'; + errVirtualObjectPutPropertyEventNotAssigned = 'OnVirtualObjectPutProperty event is not assigned'; + + errProtectedNotValid = 'PROTECTED section valid only in class types'; + errTryExceptNotImplemented = 'Try-except statement is not implemented for this platform.'#13#10 + + 'Use TPaxInterpreter instead of TPaxProgram to provide exception handling.'; + errRaiseNotImplemented = 'Raise statement is not implemented for this platform.#13#10' + + 'Use TPaxInterpreter instead of TPaxProgram to provide exception handling.'; + + // C + errDeclarationSyntaxError = 'Declaration syntax error'; + errUnknownPreprocessorDirective = 'Unknown preprocessor directive'; + errParameterNameMissing = 'Parameter "%d" name missing'; + +implementation + +{$IFDEF ARC} + +function Length(const S: ShortString): Integer; +begin + result := S[0]; +end; + +function Length(const S: String): Integer; overload; +begin + result := System.Length(S); +end; + +{$ENDIF} + +end. + diff --git a/Sources/PAXCOMP_DISASM.pas b/Sources/PAXCOMP_DISASM.pas new file mode 100644 index 0000000..0e06b69 --- /dev/null +++ b/Sources/PAXCOMP_DISASM.pas @@ -0,0 +1,5630 @@ +//////////////////////////////////////////////////////////////////////////// +// PaxCompiler +// Site: http://www.paxcompiler.com +// Author: Alexander Baranovsky (paxscript@gmail.com) +// ======================================================================== +// Copyright (c) Alexander Baranovsky, 2006-2014. All rights reserved. +// Code Version: 4.2 +// ======================================================================== +// Unit: PAXCOMP_DISASM.pas +// ======================================================================== +//////////////////////////////////////////////////////////////////////////// + +{$I PaxCompiler.def} +unit PAXCOMP_DISASM; +interface +uses {$I uses.def} + SysUtils, + PAXCOMP_CONSTANTS, + PAXCOMP_SYS; + +type + TArg = packed record + valid: Boolean; + Reg: Byte; + Ptr: Boolean; + sz: Byte; + val: Int64; + FS: Boolean; + end; + +procedure Decomp(P: Pointer; var Length: Integer; var op: Integer; + var Arg1: TArg; + var Arg2: TArg; + PAX64: Boolean); +procedure ClearArg(var Arg: TArg); +function EqualArgs(const Arg1, Arg2: TArg): Boolean; + +procedure SaveDecompiledCode(P: Pointer; + CodeSize: Integer; const FileName: String; PAX64: Boolean); +function ArgToString(const Arg: TArg; PAX64: Boolean): String; + +procedure DiscardDebugMode(P: Pointer; CodeSize: Integer; PAX64: Boolean); +function GetInitializationOffset(P: Pointer; CodeSize: Integer; PAX64: Boolean): Integer; +function GetFinalizationOffset(P: Pointer; CodeSize: Integer; PAX64: Boolean): Integer; + +implementation + +procedure RaiseError(const Message: string; params: array of Const); +begin + raise Exception.Create(Format(Message, params)); +end; + +function GetNextByte(var P: Pointer): Byte; +begin + P := ShiftPointer(P, 1); + result := Byte(P^); +end; + +function AssignXMM_RegPtr(B: Byte; var Arg1: TArg; var Arg2: TArg): Boolean; +begin + result := true; + case B of + $00: + begin + Arg1.Reg := _XMM0; + Arg2.Reg := _EAX; + end; + $01: + begin + Arg1.Reg := _XMM0; + Arg2.Reg := _ECX; + end; + $02: + begin + Arg1.Reg := _XMM0; + Arg2.Reg := _EDX; + end; + $03: + begin + Arg1.Reg := _XMM0; + Arg2.Reg := _EBX; + end; + $08: + begin + Arg1.Reg := _XMM1; + Arg2.Reg := _EAX; + end; + $09: + begin + Arg1.Reg := _XMM1; + Arg2.Reg := _ECX; + end; + $0A: + begin + Arg1.Reg := _XMM1; + Arg2.Reg := _EDX; + end; + $0B: + begin + Arg1.Reg := _XMM1; + Arg2.Reg := _EBX; + end; + $10: + begin + Arg1.Reg := _XMM2; + Arg2.Reg := _EAX; + end; + $11: + begin + Arg1.Reg := _XMM2; + Arg2.Reg := _ECX; + end; + $12: + begin + Arg1.Reg := _XMM2; + Arg2.Reg := _EDX; + end; + $13: + begin + Arg1.Reg := _XMM2; + Arg2.Reg := _EBX; + end; + $18: + begin + Arg1.Reg := _XMM3; + Arg2.Reg := _EAX; + end; + $19: + begin + Arg1.Reg := _XMM3; + Arg2.Reg := _ECX; + end; + $1A: + begin + Arg1.Reg := _XMM3; + Arg2.Reg := _EDX; + end; + $1B: + begin + Arg1.Reg := _XMM3; + Arg2.Reg := _EBX; + end; + $20: + begin + Arg1.Reg := _XMM4; + Arg2.Reg := _EAX; + end; + $21: + begin + Arg1.Reg := _XMM4; + Arg2.Reg := _ECX; + end; + $22: + begin + Arg1.Reg := _XMM4; + Arg2.Reg := _EDX; + end; + $23: + begin + Arg1.Reg := _XMM4; + Arg2.Reg := _EBX; + end; + else + begin + result := false; + end; + end; +end; + +function AssignRegMovESIPtr(B: Byte; var Arg: TArg): Boolean; +begin + result := true; + case B of + $86: Arg.Reg := _EAX; + $8E: Arg.Reg := _ECX; + $96: Arg.Reg := _EDX; + $9E: Arg.Reg := _EBX; + $A6: Arg.Reg := _ESP; + $AE: Arg.Reg := _EBP; + $B6: Arg.Reg := _ESI; + $BE: Arg.Reg := _EDI; + else + result := false; + end; +end; + +function AssignRegMovEBPPtr(B: Byte; var Arg: TArg): Boolean; +begin + result := true; + case B of + $85: Arg.Reg := _EAX; + $8D: Arg.Reg := _ECX; + $95: Arg.Reg := _EDX; + $9D: Arg.Reg := _EBX; + $A5: Arg.Reg := _ESP; + $AD: Arg.Reg := _EBP; + $B5: Arg.Reg := _ESI; + $BD: Arg.Reg := _EDI; + else + result := false; + end; +end; + +function AssignRegMovRSIPtr(B: Byte; var Arg: TArg): Boolean; +begin + result := true; + case B of + $86: Arg.Reg := _R8; + $8E: Arg.Reg := _R9; + $96: Arg.Reg := _R10; + $9E: Arg.Reg := _R11; + $A6: Arg.Reg := _R12; + $AE: Arg.Reg := _R13; + $B6: Arg.Reg := _R14; + $BE: Arg.Reg := _R15; + else + result := false; + end; +end; + +function AssignRegMovRBPPtr(B: Byte; var Arg: TArg): Boolean; +begin + result := true; + case B of + $85: Arg.Reg := _R8; + $8D: Arg.Reg := _R9; + $95: Arg.Reg := _R10; + $9D: Arg.Reg := _R11; + $A5: Arg.Reg := _R12; + $AD: Arg.Reg := _R13; + $B5: Arg.Reg := _R14; + $BD: Arg.Reg := _R15; + else + result := false; + end; +end; + +function AssignMovR32_R64(B: Byte; var Arg1, Arg2: TArg): Boolean; +begin + result := true; + case B of + $C0: begin Arg1.Reg := _EAX; Arg2.Reg := _R8; end; + $C8: begin Arg1.Reg := _EAX; Arg2.Reg := _R9; end; + $D0: begin Arg1.Reg := _EAX; Arg2.Reg := _R10; end; + $D8: begin Arg1.Reg := _EAX; Arg2.Reg := _R11; end; + $E0: begin Arg1.Reg := _EAX; Arg2.Reg := _R12; end; + $E8: begin Arg1.Reg := _EAX; Arg2.Reg := _R13; end; + $F0: begin Arg1.Reg := _EAX; Arg2.Reg := _R14; end; + $F8: begin Arg1.Reg := _EAX; Arg2.Reg := _R15; end; + + $C1: begin Arg1.Reg := _ECX; Arg2.Reg := _R8; end; + $C9: begin Arg1.Reg := _ECX; Arg2.Reg := _R9; end; + $D1: begin Arg1.Reg := _ECX; Arg2.Reg := _R10; end; + $D9: begin Arg1.Reg := _ECX; Arg2.Reg := _R11; end; + $E1: begin Arg1.Reg := _ECX; Arg2.Reg := _R12; end; + $E9: begin Arg1.Reg := _ECX; Arg2.Reg := _R13; end; + $F1: begin Arg1.Reg := _ECX; Arg2.Reg := _R14; end; + $F9: begin Arg1.Reg := _ECX; Arg2.Reg := _R15; end; + + $C2: begin Arg1.Reg := _EDX; Arg2.Reg := _R8; end; + $CA: begin Arg1.Reg := _EDX; Arg2.Reg := _R9; end; + $D2: begin Arg1.Reg := _EDX; Arg2.Reg := _R10; end; + $DA: begin Arg1.Reg := _EDX; Arg2.Reg := _R11; end; + $E2: begin Arg1.Reg := _EDX; Arg2.Reg := _R12; end; + $EA: begin Arg1.Reg := _EDX; Arg2.Reg := _R13; end; + $F2: begin Arg1.Reg := _EDX; Arg2.Reg := _R14; end; + $FA: begin Arg1.Reg := _EDX; Arg2.Reg := _R15; end; + + $C3: begin Arg1.Reg := _EBX; Arg2.Reg := _R8; end; + $CB: begin Arg1.Reg := _EBX; Arg2.Reg := _R9; end; + $D3: begin Arg1.Reg := _EBX; Arg2.Reg := _R10; end; + $DB: begin Arg1.Reg := _EBX; Arg2.Reg := _R11; end; + $E3: begin Arg1.Reg := _EBX; Arg2.Reg := _R12; end; + $EB: begin Arg1.Reg := _EBX; Arg2.Reg := _R13; end; + $F3: begin Arg1.Reg := _EBX; Arg2.Reg := _R14; end; + $FB: begin Arg1.Reg := _EBX; Arg2.Reg := _R15; end; + + $C4: begin Arg1.Reg := _ESP; Arg2.Reg := _R8; end; + $CC: begin Arg1.Reg := _ESP; Arg2.Reg := _R9; end; + $D4: begin Arg1.Reg := _ESP; Arg2.Reg := _R10; end; + $DC: begin Arg1.Reg := _ESP; Arg2.Reg := _R11; end; + $E4: begin Arg1.Reg := _ESP; Arg2.Reg := _R12; end; + $EC: begin Arg1.Reg := _ESP; Arg2.Reg := _R13; end; + $F4: begin Arg1.Reg := _ESP; Arg2.Reg := _R14; end; + $FC: begin Arg1.Reg := _ESP; Arg2.Reg := _R15; end; + + $C5: begin Arg1.Reg := _EBP; Arg2.Reg := _R8; end; + $CD: begin Arg1.Reg := _EBP; Arg2.Reg := _R9; end; + $D5: begin Arg1.Reg := _EBP; Arg2.Reg := _R10; end; + $DD: begin Arg1.Reg := _EBP; Arg2.Reg := _R11; end; + $E5: begin Arg1.Reg := _EBP; Arg2.Reg := _R12; end; + $ED: begin Arg1.Reg := _EBP; Arg2.Reg := _R13; end; + $F5: begin Arg1.Reg := _EBP; Arg2.Reg := _R14; end; + $FD: begin Arg1.Reg := _EBP; Arg2.Reg := _R15; end; + + $C6: begin Arg1.Reg := _ESI; Arg2.Reg := _R8; end; + $CE: begin Arg1.Reg := _ESI; Arg2.Reg := _R9; end; + $D6: begin Arg1.Reg := _ESI; Arg2.Reg := _R10; end; + $DE: begin Arg1.Reg := _ESI; Arg2.Reg := _R11; end; + $E6: begin Arg1.Reg := _ESI; Arg2.Reg := _R12; end; + $EE: begin Arg1.Reg := _ESI; Arg2.Reg := _R13; end; + $F6: begin Arg1.Reg := _ESI; Arg2.Reg := _R14; end; + $FE: begin Arg1.Reg := _ESI; Arg2.Reg := _R15; end; + + $C7: begin Arg1.Reg := _EDI; Arg2.Reg := _R8; end; + $CF: begin Arg1.Reg := _EDI; Arg2.Reg := _R9; end; + $D7: begin Arg1.Reg := _EDI; Arg2.Reg := _R10; end; + $DF: begin Arg1.Reg := _EDI; Arg2.Reg := _R11; end; + $E7: begin Arg1.Reg := _EDI; Arg2.Reg := _R12; end; + $EF: begin Arg1.Reg := _EDI; Arg2.Reg := _R13; end; + $F7: begin Arg1.Reg := _EDI; Arg2.Reg := _R14; end; + $FF: begin Arg1.Reg := _EDI; Arg2.Reg := _R15; end; + else + result := false; + end; +end; + +function AssignMovR64_R32(B: Byte; var Arg1, Arg2: TArg): Boolean; +begin + result := true; + case B of + $C0: begin Arg1.Reg := _R8; Arg2.Reg := _EAX; end; + $C8: begin Arg1.Reg := _R8; Arg2.Reg := _ECX; end; + $D0: begin Arg1.Reg := _R8; Arg2.Reg := _EDX; end; + $D8: begin Arg1.Reg := _R8; Arg2.Reg := _EBX; end; + $E0: begin Arg1.Reg := _R8; Arg2.Reg := _ESP; end; + $E8: begin Arg1.Reg := _R8; Arg2.Reg := _EBP; end; + $F0: begin Arg1.Reg := _R8; Arg2.Reg := _ESI; end; + $F8: begin Arg1.Reg := _R8; Arg2.Reg := _EDI; end; + + $C1: begin Arg1.Reg := _R9; Arg2.Reg := _EAX; end; + $C9: begin Arg1.Reg := _R9; Arg2.Reg := _ECX; end; + $D1: begin Arg1.Reg := _R9; Arg2.Reg := _EDX; end; + $D9: begin Arg1.Reg := _R9; Arg2.Reg := _EBX; end; + $E1: begin Arg1.Reg := _R9; Arg2.Reg := _ESP; end; + $E9: begin Arg1.Reg := _R9; Arg2.Reg := _EBP; end; + $F1: begin Arg1.Reg := _R9; Arg2.Reg := _ESI; end; + $F9: begin Arg1.Reg := _R9; Arg2.Reg := _EDI; end; + + $C2: begin Arg1.Reg := _R10; Arg2.Reg := _EAX; end; + $CA: begin Arg1.Reg := _R10; Arg2.Reg := _ECX; end; + $D2: begin Arg1.Reg := _R10; Arg2.Reg := _EDX; end; + $DA: begin Arg1.Reg := _R10; Arg2.Reg := _EBX; end; + $E2: begin Arg1.Reg := _R10; Arg2.Reg := _ESP; end; + $EA: begin Arg1.Reg := _R10; Arg2.Reg := _EBP; end; + $F2: begin Arg1.Reg := _R10; Arg2.Reg := _ESI; end; + $FA: begin Arg1.Reg := _R10; Arg2.Reg := _EDI; end; + + $C3: begin Arg1.Reg := _R11; Arg2.Reg := _EAX; end; + $CB: begin Arg1.Reg := _R11; Arg2.Reg := _ECX; end; + $D3: begin Arg1.Reg := _R11; Arg2.Reg := _EDX; end; + $DB: begin Arg1.Reg := _R11; Arg2.Reg := _EBX; end; + $E3: begin Arg1.Reg := _R11; Arg2.Reg := _ESP; end; + $EB: begin Arg1.Reg := _R11; Arg2.Reg := _EBP; end; + $F3: begin Arg1.Reg := _R11; Arg2.Reg := _ESI; end; + $FB: begin Arg1.Reg := _R11; Arg2.Reg := _EDI; end; + + $C6: begin Arg1.Reg := _R14; Arg2.Reg := _EAX; end; + $CE: begin Arg1.Reg := _R14; Arg2.Reg := _ECX; end; + $D6: begin Arg1.Reg := _R14; Arg2.Reg := _EDX; end; + $DE: begin Arg1.Reg := _R14; Arg2.Reg := _EBX; end; + $E6: begin Arg1.Reg := _R14; Arg2.Reg := _ESP; end; + $EE: begin Arg1.Reg := _R14; Arg2.Reg := _EBP; end; + $F6: begin Arg1.Reg := _R14; Arg2.Reg := _ESI; end; + $FE: begin Arg1.Reg := _R14; Arg2.Reg := _EDI; end; + + $C7: begin Arg1.Reg := _R15; Arg2.Reg := _EAX; end; + $CF: begin Arg1.Reg := _R15; Arg2.Reg := _ECX; end; + $D7: begin Arg1.Reg := _R15; Arg2.Reg := _EDX; end; + $DF: begin Arg1.Reg := _R15; Arg2.Reg := _EBX; end; + $E7: begin Arg1.Reg := _R15; Arg2.Reg := _ESP; end; + $EF: begin Arg1.Reg := _R15; Arg2.Reg := _EBP; end; + $F7: begin Arg1.Reg := _R15; Arg2.Reg := _ESI; end; + $FF: begin Arg1.Reg := _R15; Arg2.Reg := _EDI; end; + else + result := false; + end; +end; + +function AssignMovR64_R64(B: Byte; var Arg1, Arg2: TArg): Boolean; +begin + result := true; + case B of + $C0: begin Arg1.Reg := _R8; Arg2.Reg := _R8; end; + $C8: begin Arg1.Reg := _R8; Arg2.Reg := _R9; end; + $D0: begin Arg1.Reg := _R8; Arg2.Reg := _R10; end; + $D8: begin Arg1.Reg := _R8; Arg2.Reg := _R11; end; + $E0: begin Arg1.Reg := _R8; Arg2.Reg := _R12; end; + $E8: begin Arg1.Reg := _R8; Arg2.Reg := _R13; end; + $F0: begin Arg1.Reg := _R8; Arg2.Reg := _R14; end; + $F8: begin Arg1.Reg := _R8; Arg2.Reg := _R15; end; + + $C1: begin Arg1.Reg := _R9; Arg2.Reg := _R8; end; + $C9: begin Arg1.Reg := _R9; Arg2.Reg := _R9; end; + $D1: begin Arg1.Reg := _R9; Arg2.Reg := _R10; end; + $D9: begin Arg1.Reg := _R9; Arg2.Reg := _R11; end; + $E1: begin Arg1.Reg := _R9; Arg2.Reg := _R12; end; + $E9: begin Arg1.Reg := _R9; Arg2.Reg := _R13; end; + $F1: begin Arg1.Reg := _R9; Arg2.Reg := _R14; end; + $F9: begin Arg1.Reg := _R9; Arg2.Reg := _R15; end; + + $C2: begin Arg1.Reg := _R10; Arg2.Reg := _R8; end; + $CA: begin Arg1.Reg := _R10; Arg2.Reg := _R9; end; + $D2: begin Arg1.Reg := _R10; Arg2.Reg := _R10; end; + $DA: begin Arg1.Reg := _R10; Arg2.Reg := _R11; end; + $E2: begin Arg1.Reg := _R10; Arg2.Reg := _R12; end; + $EA: begin Arg1.Reg := _R10; Arg2.Reg := _R13; end; + $F2: begin Arg1.Reg := _R10; Arg2.Reg := _R14; end; + $FA: begin Arg1.Reg := _R10; Arg2.Reg := _R15; end; + + $C3: begin Arg1.Reg := _R11; Arg2.Reg := _R8; end; + $CB: begin Arg1.Reg := _R11; Arg2.Reg := _R9; end; + $D3: begin Arg1.Reg := _R11; Arg2.Reg := _R10; end; + $DB: begin Arg1.Reg := _R11; Arg2.Reg := _R11; end; + $E3: begin Arg1.Reg := _R11; Arg2.Reg := _R12; end; + $EB: begin Arg1.Reg := _R11; Arg2.Reg := _R13; end; + $F3: begin Arg1.Reg := _R11; Arg2.Reg := _R14; end; + $FB: begin Arg1.Reg := _R11; Arg2.Reg := _R15; end; + + $C6: begin Arg1.Reg := _R14; Arg2.Reg := _R8; end; + $CE: begin Arg1.Reg := _R14; Arg2.Reg := _R9; end; + $D6: begin Arg1.Reg := _R14; Arg2.Reg := _R10; end; + $DE: begin Arg1.Reg := _R14; Arg2.Reg := _R11; end; + $E6: begin Arg1.Reg := _R14; Arg2.Reg := _R12; end; + $EE: begin Arg1.Reg := _R14; Arg2.Reg := _R13; end; + $F6: begin Arg1.Reg := _R14; Arg2.Reg := _R14; end; + $FE: begin Arg1.Reg := _R14; Arg2.Reg := _R15; end; + + $C7: begin Arg1.Reg := _R15; Arg2.Reg := _R8; end; + $CF: begin Arg1.Reg := _R15; Arg2.Reg := _R9; end; + $D7: begin Arg1.Reg := _R15; Arg2.Reg := _R10; end; + $DF: begin Arg1.Reg := _R15; Arg2.Reg := _R11; end; + $E7: begin Arg1.Reg := _R15; Arg2.Reg := _R12; end; + $EF: begin Arg1.Reg := _R15; Arg2.Reg := _R13; end; + $F7: begin Arg1.Reg := _R15; Arg2.Reg := _R14; end; + $FF: begin Arg1.Reg := _R15; Arg2.Reg := _R15; end; + else + result := false; + end; +end; + +function AssignMovR32(B: Byte; var Arg1, Arg2: TArg): Boolean; +begin + result := true; + case B of + $C0: begin Arg1.Reg := _EAX; Arg2.Reg := _EAX; end; + $C8: begin Arg1.Reg := _EAX; Arg2.Reg := _ECX; end; + $D0: begin Arg1.Reg := _EAX; Arg2.Reg := _EDX; end; + $D8: begin Arg1.Reg := _EAX; Arg2.Reg := _EBX; end; + $E0: begin Arg1.Reg := _EAX; Arg2.Reg := _ESP; end; + $E8: begin Arg1.Reg := _EAX; Arg2.Reg := _EBP; end; + $F0: begin Arg1.Reg := _EAX; Arg2.Reg := _ESI; end; + $F8: begin Arg1.Reg := _EAX; Arg2.Reg := _EDI; end; + + $C1: begin Arg1.Reg := _ECX; Arg2.Reg := _EAX; end; + $C9: begin Arg1.Reg := _ECX; Arg2.Reg := _ECX; end; + $D1: begin Arg1.Reg := _ECX; Arg2.Reg := _EDX; end; + $D9: begin Arg1.Reg := _ECX; Arg2.Reg := _EBX; end; + $E1: begin Arg1.Reg := _ECX; Arg2.Reg := _ESP; end; + $E9: begin Arg1.Reg := _ECX; Arg2.Reg := _EBP; end; + $F1: begin Arg1.Reg := _ECX; Arg2.Reg := _ESI; end; + $F9: begin Arg1.Reg := _ECX; Arg2.Reg := _EDI; end; + + $C2: begin Arg1.Reg := _EDX; Arg2.Reg := _EAX; end; + $CA: begin Arg1.Reg := _EDX; Arg2.Reg := _ECX; end; + $D2: begin Arg1.Reg := _EDX; Arg2.Reg := _EDX; end; + $DA: begin Arg1.Reg := _EDX; Arg2.Reg := _EBX; end; + $E2: begin Arg1.Reg := _EDX; Arg2.Reg := _ESP; end; + $EA: begin Arg1.Reg := _EDX; Arg2.Reg := _EBP; end; + $F2: begin Arg1.Reg := _EDX; Arg2.Reg := _ESI; end; + $FA: begin Arg1.Reg := _EDX; Arg2.Reg := _EDI; end; + + $C3: begin Arg1.Reg := _EBX; Arg2.Reg := _EAX; end; + $CB: begin Arg1.Reg := _EBX; Arg2.Reg := _ECX; end; + $D3: begin Arg1.Reg := _EBX; Arg2.Reg := _EDX; end; + $DB: begin Arg1.Reg := _EBX; Arg2.Reg := _EBX; end; + $E3: begin Arg1.Reg := _EBX; Arg2.Reg := _ESP; end; + $EB: begin Arg1.Reg := _EBX; Arg2.Reg := _EBP; end; + $F3: begin Arg1.Reg := _EBX; Arg2.Reg := _ESI; end; + $FB: begin Arg1.Reg := _EBX; Arg2.Reg := _EDI; end; + + $C4: begin Arg1.Reg := _ESP; Arg2.Reg := _EAX; end; + $CC: begin Arg1.Reg := _ESP; Arg2.Reg := _ECX; end; + $D4: begin Arg1.Reg := _ESP; Arg2.Reg := _EDX; end; + $DC: begin Arg1.Reg := _ESP; Arg2.Reg := _EBX; end; + $E4: begin Arg1.Reg := _ESP; Arg2.Reg := _ESP; end; + $EC: begin Arg1.Reg := _ESP; Arg2.Reg := _EBP; end; + $F4: begin Arg1.Reg := _ESP; Arg2.Reg := _ESI; end; + $FC: begin Arg1.Reg := _ESP; Arg2.Reg := _EDI; end; + + $C5: begin Arg1.Reg := _EBP; Arg2.Reg := _EAX; end; + $CD: begin Arg1.Reg := _EBP; Arg2.Reg := _ECX; end; + $D5: begin Arg1.Reg := _EBP; Arg2.Reg := _EDX; end; + $DD: begin Arg1.Reg := _EBP; Arg2.Reg := _EBX; end; + $E5: begin Arg1.Reg := _EBP; Arg2.Reg := _ESP; end; + $ED: begin Arg1.Reg := _EBP; Arg2.Reg := _EBP; end; + $F5: begin Arg1.Reg := _EBP; Arg2.Reg := _ESI; end; + $FD: begin Arg1.Reg := _EBP; Arg2.Reg := _EDI; end; + + $C6: begin Arg1.Reg := _ESI; Arg2.Reg := _EAX; end; + $CE: begin Arg1.Reg := _ESI; Arg2.Reg := _ECX; end; + $D6: begin Arg1.Reg := _ESI; Arg2.Reg := _EDX; end; + $DE: begin Arg1.Reg := _ESI; Arg2.Reg := _EBX; end; + $E6: begin Arg1.Reg := _ESI; Arg2.Reg := _ESP; end; + $EE: begin Arg1.Reg := _ESI; Arg2.Reg := _EBP; end; + $F6: begin Arg1.Reg := _ESI; Arg2.Reg := _ESI; end; + $FE: begin Arg1.Reg := _ESI; Arg2.Reg := _EDI; end; + + $C7: begin Arg1.Reg := _EDI; Arg2.Reg := _EAX; end; + $CF: begin Arg1.Reg := _EDI; Arg2.Reg := _ECX; end; + $D7: begin Arg1.Reg := _EDI; Arg2.Reg := _EDX; end; + $DF: begin Arg1.Reg := _EDI; Arg2.Reg := _EBX; end; + $E7: begin Arg1.Reg := _EDI; Arg2.Reg := _ESP; end; + $EF: begin Arg1.Reg := _EDI; Arg2.Reg := _EBP; end; + $F7: begin Arg1.Reg := _EDI; Arg2.Reg := _ESI; end; + $FF: begin Arg1.Reg := _EDI; Arg2.Reg := _EDI; end; + else + result := false; + end; +end; + +function AssignR32_R32(B: Byte; var Arg1, Arg2: TArg): Boolean; +begin + result := true; + case B of + $00: begin Arg1.Reg := _EAX; Arg2.Reg := _EAX; end; + $01: begin Arg1.Reg := _EAX; Arg2.Reg := _ECX; end; + $02: begin Arg1.Reg := _EAX; Arg2.Reg := _EDX; end; + $03: begin Arg1.Reg := _EAX; Arg2.Reg := _EBX; end; + $04: begin Arg1.Reg := _EAX; Arg2.Reg := _ESP; end; + $05: begin Arg1.Reg := _EAX; Arg2.Reg := _EBP; end; + $06: begin Arg1.Reg := _EAX; Arg2.Reg := _ESI; end; + $07: begin Arg1.Reg := _EAX; Arg2.Reg := _EDI; end; + + $08: begin Arg1.Reg := _ECX; Arg2.Reg := _EAX; end; + $09: begin Arg1.Reg := _ECX; Arg2.Reg := _ECX; end; + $0A: begin Arg1.Reg := _ECX; Arg2.Reg := _EDX; end; + $0B: begin Arg1.Reg := _ECX; Arg2.Reg := _EBX; end; + $0C: begin Arg1.Reg := _ECX; Arg2.Reg := _ESP; end; + $0D: begin Arg1.Reg := _ECX; Arg2.Reg := _EBP; end; + $0E: begin Arg1.Reg := _ECX; Arg2.Reg := _ESI; end; + $0F: begin Arg1.Reg := _ECX; Arg2.Reg := _EDI; end; + + $10: begin Arg1.Reg := _EDX; Arg2.Reg := _EAX; end; + $11: begin Arg1.Reg := _EDX; Arg2.Reg := _ECX; end; + $12: begin Arg1.Reg := _EDX; Arg2.Reg := _EDX; end; + $13: begin Arg1.Reg := _EDX; Arg2.Reg := _EBX; end; + $14: begin Arg1.Reg := _EDX; Arg2.Reg := _ESP; end; + $15: begin Arg1.Reg := _EDX; Arg2.Reg := _EBP; end; + $16: begin Arg1.Reg := _EDX; Arg2.Reg := _ESI; end; + $17: begin Arg1.Reg := _EDX; Arg2.Reg := _EDI; end; + + $18: begin Arg1.Reg := _EBX; Arg2.Reg := _EAX; end; + $19: begin Arg1.Reg := _EBX; Arg2.Reg := _ECX; end; + $1A: begin Arg1.Reg := _EBX; Arg2.Reg := _EDX; end; + $1B: begin Arg1.Reg := _EBX; Arg2.Reg := _EBX; end; + $1C: begin Arg1.Reg := _EBX; Arg2.Reg := _ESP; end; + $1D: begin Arg1.Reg := _EBX; Arg2.Reg := _EBP; end; + $1E: begin Arg1.Reg := _EBX; Arg2.Reg := _ESI; end; + $1F: begin Arg1.Reg := _EBX; Arg2.Reg := _EDI; end; + + $20: begin Arg1.Reg := _ESP; Arg2.Reg := _EAX; end; + $21: begin Arg1.Reg := _ESP; Arg2.Reg := _ECX; end; + $22: begin Arg1.Reg := _ESP; Arg2.Reg := _EDX; end; + $23: begin Arg1.Reg := _ESP; Arg2.Reg := _EBX; end; + $24: begin Arg1.Reg := _ESP; Arg2.Reg := _ESP; end; + $25: begin Arg1.Reg := _ESP; Arg2.Reg := _EBP; end; + $26: begin Arg1.Reg := _ESP; Arg2.Reg := _ESI; end; + $27: begin Arg1.Reg := _ESP; Arg2.Reg := _EDI; end; + + $28: begin Arg1.Reg := _EBP; Arg2.Reg := _EAX; end; + $29: begin Arg1.Reg := _EBP; Arg2.Reg := _ECX; end; + $2A: begin Arg1.Reg := _EBP; Arg2.Reg := _EDX; end; + $2B: begin Arg1.Reg := _EBP; Arg2.Reg := _EBX; end; + $2C: begin Arg1.Reg := _EBP; Arg2.Reg := _ESP; end; + $2D: begin Arg1.Reg := _EBP; Arg2.Reg := _EBP; end; + $2E: begin Arg1.Reg := _EBP; Arg2.Reg := _ESI; end; + $2F: begin Arg1.Reg := _EBP; Arg2.Reg := _EDI; end; + + $30: begin Arg1.Reg := _ESI; Arg2.Reg := _EAX; end; + $31: begin Arg1.Reg := _ESI; Arg2.Reg := _ECX; end; + $32: begin Arg1.Reg := _ESI; Arg2.Reg := _EDX; end; + $33: begin Arg1.Reg := _ESI; Arg2.Reg := _EBX; end; + $34: begin Arg1.Reg := _ESI; Arg2.Reg := _ESP; end; + $35: begin Arg1.Reg := _ESI; Arg2.Reg := _EBP; end; + $36: begin Arg1.Reg := _ESI; Arg2.Reg := _ESI; end; + $37: begin Arg1.Reg := _ESI; Arg2.Reg := _EDI; end; + + $38: begin Arg1.Reg := _EDI; Arg2.Reg := _EAX; end; + $39: begin Arg1.Reg := _EDI; Arg2.Reg := _ECX; end; + $3A: begin Arg1.Reg := _EDI; Arg2.Reg := _EDX; end; + $3B: begin Arg1.Reg := _EDI; Arg2.Reg := _EBX; end; + $3C: begin Arg1.Reg := _EDI; Arg2.Reg := _ESP; end; + $3D: begin Arg1.Reg := _EDI; Arg2.Reg := _EBP; end; + $3E: begin Arg1.Reg := _EDI; Arg2.Reg := _ESI; end; + $3F: begin Arg1.Reg := _EDI; Arg2.Reg := _EDI; end; + else + result := false; + end; +end; + +function AssignR64_R32(B: Byte; var Arg1, Arg2: TArg): Boolean; +begin + result := true; + case B of + $00: begin Arg1.Reg := _R8; Arg2.Reg := _EAX; end; + $01: begin Arg1.Reg := _R8; Arg2.Reg := _ECX; end; + $02: begin Arg1.Reg := _R8; Arg2.Reg := _EDX; end; + $03: begin Arg1.Reg := _R8; Arg2.Reg := _EBX; end; + $04: begin Arg1.Reg := _R8; Arg2.Reg := _ESP; end; + $05: begin Arg1.Reg := _R8; Arg2.Reg := _EBP; end; + $06: begin Arg1.Reg := _R8; Arg2.Reg := _ESI; end; + $07: begin Arg1.Reg := _R8; Arg2.Reg := _EDI; end; + + $08: begin Arg1.Reg := _R9; Arg2.Reg := _EAX; end; + $09: begin Arg1.Reg := _R9; Arg2.Reg := _ECX; end; + $0A: begin Arg1.Reg := _R9; Arg2.Reg := _EDX; end; + $0B: begin Arg1.Reg := _R9; Arg2.Reg := _EBX; end; + $0C: begin Arg1.Reg := _R9; Arg2.Reg := _ESP; end; + $0D: begin Arg1.Reg := _R8; Arg2.Reg := _EBP; end; + $0E: begin Arg1.Reg := _R9; Arg2.Reg := _ESI; end; + $0F: begin Arg1.Reg := _R9; Arg2.Reg := _EDI; end; + + $10: begin Arg1.Reg := _R10; Arg2.Reg := _EAX; end; + $11: begin Arg1.Reg := _R10; Arg2.Reg := _ECX; end; + $12: begin Arg1.Reg := _R10; Arg2.Reg := _EDX; end; + $13: begin Arg1.Reg := _R10; Arg2.Reg := _EBX; end; + $14: begin Arg1.Reg := _R10; Arg2.Reg := _ESP; end; + $15: begin Arg1.Reg := _R10; Arg2.Reg := _EBP; end; + $16: begin Arg1.Reg := _R10; Arg2.Reg := _ESI; end; + $17: begin Arg1.Reg := _R10; Arg2.Reg := _EDI; end; + + $18: begin Arg1.Reg := _R11; Arg2.Reg := _EAX; end; + $19: begin Arg1.Reg := _R11; Arg2.Reg := _ECX; end; + $1A: begin Arg1.Reg := _R11; Arg2.Reg := _EDX; end; + $1B: begin Arg1.Reg := _R11; Arg2.Reg := _EBX; end; + $1C: begin Arg1.Reg := _R11; Arg2.Reg := _ESP; end; + $1D: begin Arg1.Reg := _R11; Arg2.Reg := _EBP; end; + $1E: begin Arg1.Reg := _R11; Arg2.Reg := _ESI; end; + $1F: begin Arg1.Reg := _R11; Arg2.Reg := _EDI; end; + + $20: begin Arg1.Reg := _R12; Arg2.Reg := _EAX; end; + $21: begin Arg1.Reg := _R12; Arg2.Reg := _ECX; end; + $22: begin Arg1.Reg := _R12; Arg2.Reg := _EDX; end; + $23: begin Arg1.Reg := _R12; Arg2.Reg := _EBX; end; + $24: begin Arg1.Reg := _R12; Arg2.Reg := _ESP; end; + $25: begin Arg1.Reg := _R12; Arg2.Reg := _EBP; end; + $26: begin Arg1.Reg := _R12; Arg2.Reg := _ESI; end; + $27: begin Arg1.Reg := _R12; Arg2.Reg := _EDI; end; + + $28: begin Arg1.Reg := _R13; Arg2.Reg := _EAX; end; + $29: begin Arg1.Reg := _R13; Arg2.Reg := _ECX; end; + $2A: begin Arg1.Reg := _R13; Arg2.Reg := _EDX; end; + $2B: begin Arg1.Reg := _R13; Arg2.Reg := _EBX; end; + $2C: begin Arg1.Reg := _R13; Arg2.Reg := _ESP; end; + $2D: begin Arg1.Reg := _R13; Arg2.Reg := _EBP; end; + $2E: begin Arg1.Reg := _R13; Arg2.Reg := _ESI; end; + $2F: begin Arg1.Reg := _R13; Arg2.Reg := _EDI; end; + + $30: begin Arg1.Reg := _R14; Arg2.Reg := _EAX; end; + $31: begin Arg1.Reg := _R14; Arg2.Reg := _ECX; end; + $32: begin Arg1.Reg := _R14; Arg2.Reg := _EDX; end; + $33: begin Arg1.Reg := _R14; Arg2.Reg := _EBX; end; + $34: begin Arg1.Reg := _R14; Arg2.Reg := _ESP; end; + $35: begin Arg1.Reg := _R14; Arg2.Reg := _EBP; end; + $36: begin Arg1.Reg := _R14; Arg2.Reg := _ESI; end; + $37: begin Arg1.Reg := _R14; Arg2.Reg := _EDI; end; + + $38: begin Arg1.Reg := _R15; Arg2.Reg := _EAX; end; + $39: begin Arg1.Reg := _R15; Arg2.Reg := _ECX; end; + $3A: begin Arg1.Reg := _R15; Arg2.Reg := _EDX; end; + $3B: begin Arg1.Reg := _R15; Arg2.Reg := _EBX; end; + $3C: begin Arg1.Reg := _R15; Arg2.Reg := _ESP; end; + $3D: begin Arg1.Reg := _R15; Arg2.Reg := _EBP; end; + $3E: begin Arg1.Reg := _R15; Arg2.Reg := _ESI; end; + $3F: begin Arg1.Reg := _R15; Arg2.Reg := _EDI; end; + else + result := false; + end; +end; + +function AssignR64_R64(B: Byte; var Arg1, Arg2: TArg): Boolean; +begin + result := true; + case B of + $00: begin Arg1.Reg := _R8; Arg2.Reg := _R8; end; + $01: begin Arg1.Reg := _R8; Arg2.Reg := _R9; end; + $02: begin Arg1.Reg := _R8; Arg2.Reg := _R10; end; + $03: begin Arg1.Reg := _R8; Arg2.Reg := _R11; end; + $04: begin Arg1.Reg := _R8; Arg2.Reg := _R12; end; + $05: begin Arg1.Reg := _R8; Arg2.Reg := _R13; end; + $06: begin Arg1.Reg := _R8; Arg2.Reg := _R14; end; + $07: begin Arg1.Reg := _R8; Arg2.Reg := _R15; end; + + $08: begin Arg1.Reg := _R9; Arg2.Reg := _R8; end; + $09: begin Arg1.Reg := _R9; Arg2.Reg := _R9; end; + $0A: begin Arg1.Reg := _R9; Arg2.Reg := _R10; end; + $0B: begin Arg1.Reg := _R9; Arg2.Reg := _R11; end; + $0C: begin Arg1.Reg := _R9; Arg2.Reg := _R12; end; + $0D: begin Arg1.Reg := _R9; Arg2.Reg := _R13; end; + $0E: begin Arg1.Reg := _R9; Arg2.Reg := _R14; end; + $0F: begin Arg1.Reg := _R9; Arg2.Reg := _R15; end; + + $10: begin Arg1.Reg := _R10; Arg2.Reg := _R8; end; + $11: begin Arg1.Reg := _R10; Arg2.Reg := _R9; end; + $12: begin Arg1.Reg := _R10; Arg2.Reg := _R10; end; + $13: begin Arg1.Reg := _R10; Arg2.Reg := _R11; end; + $14: begin Arg1.Reg := _R10; Arg2.Reg := _R12; end; + $15: begin Arg1.Reg := _R10; Arg2.Reg := _R13; end; + $16: begin Arg1.Reg := _R10; Arg2.Reg := _R14; end; + $17: begin Arg1.Reg := _R10; Arg2.Reg := _R15; end; + + $18: begin Arg1.Reg := _R11; Arg2.Reg := _R8; end; + $19: begin Arg1.Reg := _R11; Arg2.Reg := _R9; end; + $1A: begin Arg1.Reg := _R11; Arg2.Reg := _R10; end; + $1B: begin Arg1.Reg := _R11; Arg2.Reg := _R11; end; + $1C: begin Arg1.Reg := _R11; Arg2.Reg := _R12; end; + $1D: begin Arg1.Reg := _R11; Arg2.Reg := _R13; end; + $1E: begin Arg1.Reg := _R11; Arg2.Reg := _R14; end; + $1F: begin Arg1.Reg := _R11; Arg2.Reg := _R15; end; + + $20: begin Arg1.Reg := _R12; Arg2.Reg := _R8; end; + $21: begin Arg1.Reg := _R12; Arg2.Reg := _R9; end; + $22: begin Arg1.Reg := _R12; Arg2.Reg := _R10; end; + $23: begin Arg1.Reg := _R12; Arg2.Reg := _R11; end; + $24: begin Arg1.Reg := _R12; Arg2.Reg := _R12; end; + $25: begin Arg1.Reg := _R12; Arg2.Reg := _R13; end; + $26: begin Arg1.Reg := _R12; Arg2.Reg := _R14; end; + $27: begin Arg1.Reg := _R12; Arg2.Reg := _R15; end; + + $28: begin Arg1.Reg := _R13; Arg2.Reg := _R8; end; + $29: begin Arg1.Reg := _R13; Arg2.Reg := _R9; end; + $2A: begin Arg1.Reg := _R13; Arg2.Reg := _R10; end; + $2B: begin Arg1.Reg := _R13; Arg2.Reg := _R11; end; + $2C: begin Arg1.Reg := _R13; Arg2.Reg := _R12; end; + $2D: begin Arg1.Reg := _R13; Arg2.Reg := _R13; end; + $2E: begin Arg1.Reg := _R13; Arg2.Reg := _R14; end; + $2F: begin Arg1.Reg := _R13; Arg2.Reg := _R15; end; + + $30: begin Arg1.Reg := _R14; Arg2.Reg := _R8; end; + $31: begin Arg1.Reg := _R14; Arg2.Reg := _R9; end; + $32: begin Arg1.Reg := _R14; Arg2.Reg := _R10; end; + $33: begin Arg1.Reg := _R14; Arg2.Reg := _R11; end; + $34: begin Arg1.Reg := _R14; Arg2.Reg := _R12; end; + $35: begin Arg1.Reg := _R14; Arg2.Reg := _R13; end; + $36: begin Arg1.Reg := _R14; Arg2.Reg := _R14; end; + $37: begin Arg1.Reg := _R14; Arg2.Reg := _R15; end; + + $38: begin Arg1.Reg := _R15; Arg2.Reg := _R8; end; + $39: begin Arg1.Reg := _R15; Arg2.Reg := _R9; end; + $3A: begin Arg1.Reg := _R15; Arg2.Reg := _R10; end; + $3B: begin Arg1.Reg := _R15; Arg2.Reg := _R11; end; + $3C: begin Arg1.Reg := _R15; Arg2.Reg := _R12; end; + $3D: begin Arg1.Reg := _R15; Arg2.Reg := _R13; end; + $3E: begin Arg1.Reg := _R15; Arg2.Reg := _R14; end; + $3F: begin Arg1.Reg := _R15; Arg2.Reg := _R15; end; + else + result := false; + end; +end; + +function AssignR32_R64(B: Byte; var Arg1, Arg2: TArg): Boolean; +begin + result := true; + case B of + $00: begin Arg1.Reg := _EAX; Arg2.Reg := _R8; end; + $01: begin Arg1.Reg := _EAX; Arg2.Reg := _R9; end; + $02: begin Arg1.Reg := _EAX; Arg2.Reg := _R10; end; + $03: begin Arg1.Reg := _EAX; Arg2.Reg := _R11; end; + $04: begin Arg1.Reg := _EAX; Arg2.Reg := _R12; end; + $05: begin Arg1.Reg := _EAX; Arg2.Reg := _R13; end; + $06: begin Arg1.Reg := _EAX; Arg2.Reg := _R14; end; + $07: begin Arg1.Reg := _EAX; Arg2.Reg := _R15; end; + + $08: begin Arg1.Reg := _ECX; Arg2.Reg := _R8; end; + $09: begin Arg1.Reg := _ECX; Arg2.Reg := _R9; end; + $0A: begin Arg1.Reg := _ECX; Arg2.Reg := _R10; end; + $0B: begin Arg1.Reg := _ECX; Arg2.Reg := _R11; end; + $0C: begin Arg1.Reg := _ECX; Arg2.Reg := _R12; end; + $0D: begin Arg1.Reg := _ECX; Arg2.Reg := _R13; end; + $0E: begin Arg1.Reg := _ECX; Arg2.Reg := _R14; end; + $0F: begin Arg1.Reg := _ECX; Arg2.Reg := _R15; end; + + $10: begin Arg1.Reg := _EDX; Arg2.Reg := _R8; end; + $11: begin Arg1.Reg := _EDX; Arg2.Reg := _R9; end; + $12: begin Arg1.Reg := _EDX; Arg2.Reg := _R10; end; + $13: begin Arg1.Reg := _EDX; Arg2.Reg := _R11; end; + $14: begin Arg1.Reg := _EDX; Arg2.Reg := _R12; end; + $15: begin Arg1.Reg := _EDX; Arg2.Reg := _R13; end; + $16: begin Arg1.Reg := _EDX; Arg2.Reg := _R14; end; + $17: begin Arg1.Reg := _EDX; Arg2.Reg := _R15; end; + + $18: begin Arg1.Reg := _EBX; Arg2.Reg := _R8; end; + $19: begin Arg1.Reg := _EBX; Arg2.Reg := _R9; end; + $1A: begin Arg1.Reg := _EBX; Arg2.Reg := _R10; end; + $1B: begin Arg1.Reg := _EBX; Arg2.Reg := _R11; end; + $1C: begin Arg1.Reg := _EBX; Arg2.Reg := _R12; end; + $1D: begin Arg1.Reg := _EBX; Arg2.Reg := _R13; end; + $1E: begin Arg1.Reg := _EBX; Arg2.Reg := _R14; end; + $1F: begin Arg1.Reg := _EBX; Arg2.Reg := _R15; end; + else + result := false; + end; +end; + +function ValToStr(val: Integer): String; +begin +// result := IntToStr(val); + + if val = 0 then + result := '0' + else if val > 0 then + begin + result := Format('%x', [val]); + while Length(result) < 4 do + result := '0' + result; + result := '$' + result; + end + else + begin + result := Format('%x', [-val]); + while Length(result) < 4 do + result := '0' + result; + result := '-$' + result; + end; +end; + +function ArgToString(const Arg: TArg; PAX64: Boolean): String; +var + I: Integer; +begin + with Arg do + begin + if not valid then + begin + result := ''; + Exit; + end; + if Reg = 0 then // imm + begin + result := ValToStr(val); + Exit; + end; + if not Ptr then + begin + case sz of + 1: + case Reg of + _EAX: result := 'AL'; + _ECX: result := 'CL'; + _EDX: result := 'DL'; + _EBX: result := 'BL'; + _ESP: result := 'SP'; + _EBP: result := 'BP'; + _ESI: result := 'SI'; + _EDI: result := 'DI'; + + _R8: result := 'R8B'; + _R9: result := 'R9B'; + _R10: result := 'R10B'; + _R11: result := 'R11B'; + _R12: result := 'R12B'; + _R13: result := 'R13B'; + _R14: result := 'R14B'; + _R15: result := 'R15B'; + else + RaiseError(errInternalError, []); + end; + 2: + case Reg of + _EAX: result := 'AX'; + _ECX: result := 'CX'; + _EDX: result := 'DX'; + _EBX: result := 'BX'; + _ESP: result := 'SP'; + _EBP: result := 'BP'; + _ESI: result := 'SI'; + _EDI: result := 'DI'; + + _R8: result := 'R8W'; + _R9: result := 'R9W'; + _R10: result := 'R10W'; + _R11: result := 'R11W'; + _R12: result := 'R12W'; + _R13: result := 'R13W'; + _R14: result := 'R14W'; + _R15: result := 'R15W'; + else + RaiseError(errInternalError, []); + end; + 4: + case Reg of + _EAX: result := 'EAX'; + _ECX: result := 'ECX'; + _EDX: result := 'EDX'; + _EBX: result := 'EBX'; + _ESI: result := 'ESI'; + _EDI: result := 'EDI'; + _EBP: result := 'EBP'; + _ESP: result := 'ESP'; + _R8: result := 'R8D'; + _R9: result := 'R9D'; + _R10: result := 'R10D'; + _R11: result := 'R11D'; + _R12: result := 'R12D'; + _R13: result := 'R13D'; + _R14: result := 'R14D'; + _R15: result := 'R15D'; + end; + 8: + case Reg of + _EAX: result := 'RAX'; + _ECX: result := 'RCX'; + _EDX: result := 'RDX'; + _EBX: result := 'RBX'; + _ESI: result := 'RSI'; + _EDI: result := 'RDI'; + _EBP: result := 'RBP'; + _ESP: result := 'RSP'; + _R8: result := 'R8'; + _R9: result := 'R9'; + _R10: result := 'R10'; + _R11: result := 'R11'; + _R12: result := 'R12'; + _R13: result := 'R13'; + _R14: result := 'R14'; + _R15: result := 'R15'; + + _XMM0: result := 'XMM0'; + _XMM1: result := 'XMM1'; + _XMM2: result := 'XMM2'; + _XMM3: result := 'XMM3'; + _XMM4: result := 'XMM4'; + end; + end; + end + else // Ptr + begin + if PAX64 then + case Reg of + _EAX: result := '[RAX]'; + _ECX: result := '[RCX]'; + _EDX: result := '[RDX]'; + _EBX: result := '[RBX]'; + _ESI: result := '[RSI]'; + _EDI: result := '[RDI]'; + _EBP: result := '[RBP]'; + _ESP: result := '[RSP]'; + _R8: result := '[R8]'; + _R9: result := '[R9]'; + _R10: result := '[R10]'; + _R11: result := '[R11]'; + _R12: result := '[R12]'; + _R13: result := '[R13]'; + _R14: result := '[R14]'; + _R15: result := '[R15]'; + end + else + case Reg of + _EAX: result := '[EAX]'; + _ECX: result := '[ECX]'; + _EDX: result := '[EDX]'; + _EBX: result := '[EBX]'; + _ESI: result := '[ESI]'; + _EDI: result := '[EDI]'; + _EBP: result := '[EBP]'; + _ESP: result := '[ESP]'; + end; + + if FS then + result := 'FS:' + result; + + if val <> 0 then + begin + Delete(result, Length(result), 1); + if val > 0 then + result := result + '+' + ValToStr(val) + ']' + else + result := result + ValToStr(val) + ']' + end; + + case sz of + 1: result := 'BYTE PTR ' + result; + 2: result := 'WORD PTR ' + result; + 4: result := 'DWORD PTR ' + result; + 8: result := 'QWORD PTR ' + result; + 10: result := 'TBYTE PTR ' + result; + else + RaiseError(errInternalError, []); + end; + + I := Pos('+-', result); + if I > 0 then + Delete(result, I, 1); + end; + end; +end; + +procedure ClearArg(var Arg: TArg); +begin + FillChar(Arg, SizeOf(Arg), 0); +end; + +function EqualArgs(const Arg1, Arg2: TArg): Boolean; +begin + result := (Arg1.Reg = Arg2.Reg) and + (Arg1.Ptr = Arg2.Ptr) and + (Arg1.sz = Arg2.sz) and + (Arg1.val = Arg2.val); +end; + +procedure SaveDecompiledCode(P: Pointer; + CodeSize: Integer; + const FileName: String; PAX64: Boolean); +var + buff: array[1..20] of byte; + L: Integer; + +function HexCode: String; +var + I: Integer; +begin + result := ''; + for I:=1 to L do + result := result + ByteToHex(buff[I]); +end; + +var + T: TextFile; + K, Line: Integer; + Op: Integer; + Arg1, Arg2: TArg; + S, S1, S2: String; +begin + Line := 0; + K := 0; + + AssignFile(T, FileName); + Rewrite(T); + try + repeat + Inc(Line); + Decomp(P, L, Op, Arg1, Arg2, PAX64); + Move(P^, buff, L); + + S := AsmOperators[Op]; + S1 := ArgToString(Arg1, PAX64); + S2 := ArgToString(Arg2, PAX64); + + if not Arg2.valid then + writeln(T, Line:6, HexCode:20, S:10, ' ', S1:20) + else + writeln(T, Line:6, HexCode:20, S:10, ' ', S1:20, ',', S2); + + P := ShiftPointer(P, L); + Inc(K, L); + if K >= CodeSize then + Break; + until false; + finally + Close(T); + end; +end; + +procedure DiscardDebugMode(P: Pointer; + CodeSize: Integer; + PAX64: Boolean); +var + buff: array[1..11] of byte; + L: Integer; + Value: Cardinal; +var + K: Integer; + Op: Integer; + Arg1, Arg2: TArg; +begin + Value := 58; + + K := 0; + + repeat + Decomp(P, L, Op, Arg1, Arg2, PAX64); + Move(P^, buff, L); + + if Op = ASM_NOP then + begin + Move(P^, Buff, 5); + if Buff[2] = $90 then + if Buff[3] = $90 then + if Buff[4] = $90 then + if Buff[5] = $90 then + begin + Buff[1] := $E9; + Move(value, Buff[2], 4); + Move(Buff, P^, 5); + + P := ShiftPointer(P, 5); + Inc(K, 5); + end; + end + else + begin + P := ShiftPointer(P, L); + Inc(K, L); + end; + + if K >= CodeSize then + Break; + + until false; +end; + +function GetMagicOffset(P: Pointer; + CodeSize: Integer; MAGIC_COUNT: Integer; PAX64: Boolean): Integer; +var + K, L, Op, Count: Integer; + Arg1, Arg2: TArg; +begin + K := 0; + + Count := 0; + + result := -1; + + repeat + Decomp(P, L, Op, Arg1, Arg2, PAX64); + + if Op = ASM_JMP then + begin + if Arg1.val = 0 then + begin + Inc(Count); + if Count = MAGIC_COUNT then + begin + result := K; + Exit; + end; + end + else + Count := 0; + end + else + Count := 0; + + P := ShiftPointer(P, L); + Inc(K, L); + + if K >= CodeSize then + Break; + + until false; +end; + +function GetFinalizationOffset(P: Pointer; CodeSize: Integer; PAX64: Boolean): Integer; +begin + result := GetMagicOffset(P, CodeSize, MAGIC_FINALIZATION_JMP_COUNT, PAX64); +end; + +function GetInitializationOffset(P: Pointer; CodeSize: Integer; PAX64: Boolean): Integer; +begin + result := GetMagicOffset(P, CodeSize, MAGIC_INITIALIZATION_JMP_COUNT, PAX64); +end; + +procedure Decomp(P: Pointer; var Length: Integer; var op: Integer; + var Arg1: TArg; + var Arg2: TArg; PAX64: Boolean); +var + B: Byte; +begin + ClearArg(Arg1); + Arg1.valid := true; + if PAX64 then + Arg1.sz := 8 + else + Arg1.sz := 4; + ClearArg(Arg2); + Arg2.valid := true; + if PAX64 then + Arg2.sz := 8 + else + Arg2.sz := 4; + + B := Byte(P^); + case B of + $FE: + begin + P := ShiftPointer(P, 1); + B := Byte(P^); + case B of + $44: + begin + P := ShiftPointer(P, 1); + B := Byte(P^); + case B of + $24: + begin + P := ShiftPointer(P, 1); + B := Byte(P^); + case B of + $F4: + begin + op := ASM_INC; + Length := 4; + Arg1.Reg := _ESP; + Arg1.Ptr := true; + Arg1.sz := 1; + Arg1.Val := -12; + Arg2.valid := false; + end; + else + RaiseError(errInternalError, []); + end; + end; + else + RaiseError(errInternalError, []); + end; + end; + else + RaiseError(errInternalError, []); + end; + end; + + $C2: + begin + op := ASM_RET; + Length := 3; + + P := ShiftPointer(P, 1); + Arg1.val := 0; + Move(P^, Arg1.val, 2); + + Arg2.valid := false; + end; + + $C3: + begin + op := ASM_RET; + Length := 1; + + Arg1.valid := false; + Arg2.valid := false; + end; + + $90: + begin + op := ASM_NOP; + Length := 1; + + Arg1.valid := false; + Arg2.valid := false; + end; + + $9B: + begin + op := ASM_WAIT; + Length := 1; + + Arg1.valid := false; + Arg2.valid := false; + end; + + $91..$97: + begin + op := ASM_XCHG; + Length := 1; + + Arg1.Reg := _EAX; + case B of + $91: Arg2.Reg := _ECX; + $92: Arg2.Reg := _EDX; + $93: Arg2.Reg := _EBX; + $94: Arg2.Reg := _ESP; + $95: Arg2.Reg := _EBP; + $96: Arg2.Reg := _ESI; + $97: Arg2.Reg := _EDI; + else + RaiseError(errInternalError, []); + end; + end; + + $F8: + begin + op := ASM_CLC; + Length := 1; + + Arg1.valid := false; + Arg2.valid := false; + end; + + $9C: + begin + op := ASM_PUSHFD; + Length := 1; + + Arg1.valid := false; + Arg2.valid := false; + end; + + $9D: + begin + op := ASM_POPFD; + Length := 1; + + Arg1.valid := false; + Arg2.valid := false; + end; + + $F3: + begin + P := ShiftPointer(P, 1); + B := Byte(P^); + + if B = $0F then + begin + P := ShiftPointer(P, 1); + B := Byte(P^); + if B <> $5A then + RaiseError(errInternalError, []); + P := ShiftPointer(P, 1); + B := Byte(P^); + Op := ASM_CVTSS2SD; + Length := 4; + Arg2.Ptr := true; + Arg2.sz := 4; + if not AssignXMM_RegPtr(B, Arg1, Arg2) then + RaiseError(errInternalError, []); + end + else + begin + Length := 2; + Arg1.valid := false; + Arg2.valid := false; + case B of + $A4: op := ASM_REP_MOVSB; + $A5: op := ASM_REP_MOVSD; + else + RaiseError(errInternalError, []); + end; + end; + end; + + $71: + begin + op := ASM_JNO; + Length := 2; + P := ShiftPointer(P, 1); + B := Byte(P^); + Arg1.val := B; + Arg2.valid := false; + end; + + $73: + begin + op := ASM_JNC; + Length := 2; + P := ShiftPointer(P, 1); + B := Byte(P^); + Arg1.val := B; + Arg2.valid := false; + end; + + $74: + begin + op := ASM_JZ; + Length := 2; + P := ShiftPointer(P, 1); + B := Byte(P^); + Arg1.val := B; + Arg2.valid := false; + end; + + $75: + begin + op := ASM_JNZ; + Length := 2; + P := ShiftPointer(P, 1); + B := Byte(P^); + Arg1.val := B; + Arg2.valid := false; + end; + + $76: + begin + op := ASM_JBE; + Length := 2; + P := ShiftPointer(P, 1); + B := Byte(P^); + Arg1.val := B; + Arg2.valid := false; + end; + + $7F: + begin + op := ASM_JNLE; + Length := 2; + P := ShiftPointer(P, 1); + B := Byte(P^); + Arg1.val := B; + Arg2.valid := false; + end; + + // Mov EAX, Imm + $B8: + begin + Op := ASM_MOV; + Length := 5; + + Arg1.Reg := _EAX; + + P := ShiftPointer(P, 1); + Move(P^, Arg2.Val, 4); + end; + + // Mov ECX, Imm + $B9: + begin + Op := ASM_MOV; + Length := 5; + + Arg1.Reg := _ECX; + P := ShiftPointer(P, 1); + Move(P^, Arg2.Val, 4); + end; + + // Mov EDX, Imm + $BA: + begin + Op := ASM_MOV; + Length := 5; + + Arg1.Reg := _EDX; + P := ShiftPointer(P, 1); + Move(P^, Arg2.Val, 4); + end; + + // Mov EBX, Imm + $BB: + begin + Op := ASM_MOV; + Length := 5; + + Arg1.Reg := _EBX; + P := ShiftPointer(P, 1); + Move(P^, Arg2.Val, 4); + end; + + // Mov EBX, Imm + $BC: + begin + Op := ASM_MOV; + Length := 5; + + Arg1.Reg := _ESP; + P := ShiftPointer(P, 1); + Move(P^, Arg2.Val, 4); + end; + + // Mov EBX, Imm + $BD: + begin + Op := ASM_MOV; + Length := 5; + + Arg1.Reg := _EBP; + P := ShiftPointer(P, 1); + Move(P^, Arg2.Val, 4); + end; + + // Mov EBX, Imm + $BE: + begin + Op := ASM_MOV; + Length := 5; + + Arg1.Reg := _ESI; + P := ShiftPointer(P, 1); + Move(P^, Arg2.Val, 4); + end; + + // Mov EBX, Imm + $BF: + begin + Op := ASM_MOV; + Length := 5; + + Arg1.Reg := _EDI; + P := ShiftPointer(P, 1); + Move(P^, Arg2.Val, 4); + end; + + // Add REG, REG + $01: + begin + Op := ASM_ADD; + Length := 2; + + P := ShiftPointer(P, 1); + B := Byte(P^); + + case B of + $C0: begin Arg1.Reg := _EAX; Arg2.Reg := _EAX; end; + $C8: begin Arg1.Reg := _EAX; Arg2.Reg := _ECX; end; + $D0: begin Arg1.Reg := _EAX; Arg2.Reg := _EDX; end; + $D8: begin Arg1.Reg := _EAX; Arg2.Reg := _EBX; end; + $F0: begin Arg1.Reg := _EAX; Arg2.Reg := _ESI; end; + $F8: begin Arg1.Reg := _EAX; Arg2.Reg := _EDI; end; + + $C1: begin Arg1.Reg := _ECX; Arg2.Reg := _EAX; end; + $C9: begin Arg1.Reg := _ECX; Arg2.Reg := _ECX; end; + $D1: begin Arg1.Reg := _ECX; Arg2.Reg := _EDX; end; + $D9: begin Arg1.Reg := _ECX; Arg2.Reg := _EBX; end; + $F1: begin Arg1.Reg := _ECX; Arg2.Reg := _ESI; end; + $F9: begin Arg1.Reg := _ECX; Arg2.Reg := _EDI; end; + + $C2: begin Arg1.Reg := _EDX; Arg2.Reg := _EAX; end; + $CA: begin Arg1.Reg := _EDX; Arg2.Reg := _ECX; end; + $D2: begin Arg1.Reg := _EDX; Arg2.Reg := _EDX; end; + $DA: begin Arg1.Reg := _EDX; Arg2.Reg := _EBX; end; + $F2: begin Arg1.Reg := _EDX; Arg2.Reg := _ESI; end; + $FA: begin Arg1.Reg := _EDX; Arg2.Reg := _EDI; end; + + $C3: begin Arg1.Reg := _EBX; Arg2.Reg := _EAX; end; + $CB: begin Arg1.Reg := _EBX; Arg2.Reg := _ECX; end; + $D3: begin Arg1.Reg := _EBX; Arg2.Reg := _EDX; end; + $DB: begin Arg1.Reg := _EBX; Arg2.Reg := _EBX; end; + $F3: begin Arg1.Reg := _EBX; Arg2.Reg := _ESI; end; + $FB: begin Arg1.Reg := _EBX; Arg2.Reg := _EDI; end; + else + RaiseError(errInternalError, []); + end; + end; + + // Adc REG, REG + $11: + begin + Op := ASM_ADC; + Length := 2; + + P := ShiftPointer(P, 1); + B := Byte(P^); + + case B of + $C0: begin Arg1.Reg := _EAX; Arg2.Reg := _EAX; end; + $C8: begin Arg1.Reg := _EAX; Arg2.Reg := _ECX; end; + $D0: begin Arg1.Reg := _EAX; Arg2.Reg := _EDX; end; + $D8: begin Arg1.Reg := _EAX; Arg2.Reg := _EBX; end; + $F0: begin Arg1.Reg := _EAX; Arg2.Reg := _ESI; end; + $F8: begin Arg1.Reg := _EAX; Arg2.Reg := _EDI; end; + + $C1: begin Arg1.Reg := _ECX; Arg2.Reg := _EAX; end; + $C9: begin Arg1.Reg := _ECX; Arg2.Reg := _ECX; end; + $D1: begin Arg1.Reg := _ECX; Arg2.Reg := _EDX; end; + $D9: begin Arg1.Reg := _ECX; Arg2.Reg := _EBX; end; + $F1: begin Arg1.Reg := _ECX; Arg2.Reg := _ESI; end; + $F9: begin Arg1.Reg := _ECX; Arg2.Reg := _EDI; end; + + $C2: begin Arg1.Reg := _EDX; Arg2.Reg := _EAX; end; + $CA: begin Arg1.Reg := _EDX; Arg2.Reg := _ECX; end; + $D2: begin Arg1.Reg := _EDX; Arg2.Reg := _EDX; end; + $DA: begin Arg1.Reg := _EDX; Arg2.Reg := _EBX; end; + $F2: begin Arg1.Reg := _EDX; Arg2.Reg := _ESI; end; + $FA: begin Arg1.Reg := _EDX; Arg2.Reg := _EDI; end; + + $C3: begin Arg1.Reg := _EBX; Arg2.Reg := _EAX; end; + $CB: begin Arg1.Reg := _EBX; Arg2.Reg := _ECX; end; + $D3: begin Arg1.Reg := _EBX; Arg2.Reg := _EDX; end; + $DB: begin Arg1.Reg := _EBX; Arg2.Reg := _EBX; end; + $F3: begin Arg1.Reg := _EBX; Arg2.Reg := _ESI; end; + $FB: begin Arg1.Reg := _EBX; Arg2.Reg := _EDI; end; + else + RaiseError(errInternalError, []); + end; + end; + + // Sbb REG, REG + $19: + begin + Op := ASM_SBB; + Length := 2; + + P := ShiftPointer(P, 1); + B := Byte(P^); + + case B of + $C0: begin Arg1.Reg := _EAX; Arg2.Reg := _EAX; end; + $C8: begin Arg1.Reg := _EAX; Arg2.Reg := _ECX; end; + $D0: begin Arg1.Reg := _EAX; Arg2.Reg := _EDX; end; + $D8: begin Arg1.Reg := _EAX; Arg2.Reg := _EBX; end; + $F0: begin Arg1.Reg := _EAX; Arg2.Reg := _ESI; end; + $F8: begin Arg1.Reg := _EAX; Arg2.Reg := _EDI; end; + + $C1: begin Arg1.Reg := _ECX; Arg2.Reg := _EAX; end; + $C9: begin Arg1.Reg := _ECX; Arg2.Reg := _ECX; end; + $D1: begin Arg1.Reg := _ECX; Arg2.Reg := _EDX; end; + $D9: begin Arg1.Reg := _ECX; Arg2.Reg := _EBX; end; + $F1: begin Arg1.Reg := _ECX; Arg2.Reg := _ESI; end; + $F9: begin Arg1.Reg := _ECX; Arg2.Reg := _EDI; end; + + $C2: begin Arg1.Reg := _EDX; Arg2.Reg := _EAX; end; + $CA: begin Arg1.Reg := _EDX; Arg2.Reg := _ECX; end; + $D2: begin Arg1.Reg := _EDX; Arg2.Reg := _EDX; end; + $DA: begin Arg1.Reg := _EDX; Arg2.Reg := _EBX; end; + $F2: begin Arg1.Reg := _EDX; Arg2.Reg := _ESI; end; + $FA: begin Arg1.Reg := _EDX; Arg2.Reg := _EDI; end; + + $C3: begin Arg1.Reg := _EBX; Arg2.Reg := _EAX; end; + $CB: begin Arg1.Reg := _EBX; Arg2.Reg := _ECX; end; + $D3: begin Arg1.Reg := _EBX; Arg2.Reg := _EDX; end; + $DB: begin Arg1.Reg := _EBX; Arg2.Reg := _EBX; end; + $F3: begin Arg1.Reg := _EBX; Arg2.Reg := _ESI; end; + $FB: begin Arg1.Reg := _EBX; Arg2.Reg := _EDI; end; + else + RaiseError(errInternalError, []); + end; + end; + + // Add EAX, Imm + $05: + begin + Op := ASM_ADD; + Length := 5; + + Arg1.Reg := _EAX; + P := ShiftPointer(P, 1); + Move(P^, Arg2.val, 4); + end; + + $81: + begin + P := ShiftPointer(P, 1); + B := Byte(P^); + + case B of + $C1..$C6: // ADD Reg, Imm + begin + Op := ASM_ADD; + Length := 6; + case B of + $C1: Arg1.Reg := _ECX; + $C2: Arg1.Reg := _EDX; + $C3: Arg1.Reg := _EBX; + $C4: Arg1.Reg := _ESP; + $C5: Arg1.Reg := _EBP; + $C6: Arg1.Reg := _ESI; + end; + P := ShiftPointer(P, 1); + Move(P^, Arg2.val, 4); + end; + + $80..$86: // ADD DWORD PTR Shift[Reg], Imm + begin + Op := ASM_ADD; + Length := 10; + case B of + $80: Arg1.Reg := _EAX; + $81: Arg1.Reg := _ECX; + $82: Arg1.Reg := _EDX; + $83: Arg1.Reg := _EBX; + $84: Arg1.Reg := _ESP; + $85: Arg1.Reg := _EBP; + $86: Arg1.Reg := _ESI; + end; + Arg1.Ptr := true; + P := ShiftPointer(P, 1); + Move(P^, Arg1.val, 4); + P := ShiftPointer(P, 4); + Move(P^, Arg2.val, 4); + end; + + $F9..$FF: // CMP Reg, Imm + begin + Op := ASM_CMP; + Length := 6; + case B of + $F9: Arg1.Reg := _ECX; + $FA: Arg1.Reg := _EDX; + $FB: Arg1.Reg := _EBX; + $FC: Arg1.Reg := _ESP; + $FD: Arg1.Reg := _EBP; + $FE: Arg1.Reg := _ESI; + $FF: Arg1.Reg := _EDI; + end; + P := ShiftPointer(P, 1); + Move(P^, Arg2.val, 4); + end; + + $E9..$EF: // SUB Reg, Imm + begin + Op := ASM_SUB; + Length := 6; + case B of + $E9: Arg1.Reg := _ECX; + $EA: Arg1.Reg := _EDX; + $EB: Arg1.Reg := _EBX; + $EC: Arg1.Reg := _ESP; + $ED: Arg1.Reg := _EBP; + $EE: Arg1.Reg := _ESI; + $EF: Arg1.Reg := _EDI; + end; + P := ShiftPointer(P, 1); + Move(P^, Arg2.val, 4); + end; + + $B8..$BE: // CMP DWORD PTR Shift[Reg], Imm + begin + Op := ASM_CMP; + Length := 10; + case B of + $B8: Arg1.Reg := _EAX; + $B9: Arg1.Reg := _ECX; + $BA: Arg1.Reg := _EDX; + $BB: Arg1.Reg := _EBX; + $BC: Arg1.Reg := _ESP; + $BD: Arg1.Reg := _EBP; + $BE: Arg1.Reg := _ESI; + end; + Arg1.Ptr := true; + P := ShiftPointer(P, 1); + Move(P^, Arg1.val, 4); + P := ShiftPointer(P, 4); + Move(P^, Arg2.val, 4); + end; + else + RaiseError(errInternalError, []); + end; + end; + + $F7: + begin + P := ShiftPointer(P, 1); + B := Byte(P^); + + case B of + $E0..$E3: // mul reg + begin + Op := ASM_MUL; + Length := 2; + case B of + $E0: Arg1.Reg := _EAX; + $E1: Arg1.Reg := _ECX; + $E2: Arg1.Reg := _EDX; + $E3: Arg1.Reg := _EBX; + end; + Arg2.valid := false; + end; + $E8..$EB: // imul reg + begin + Op := ASM_IMUL; + Length := 2; + case B of + $E8: Arg1.Reg := _EAX; + $E9: Arg1.Reg := _ECX; + $EA: Arg1.Reg := _EDX; + $EB: Arg1.Reg := _EBX; + end; + Arg2.valid := false; + end; + $F0..$F3: // div reg + begin + Op := ASM_DIV; + Length := 2; + case B of + $F0: Arg1.Reg := _EAX; + $F1: Arg1.Reg := _ECX; + $F2: Arg1.Reg := _EDX; + $F3: Arg1.Reg := _EBX; + end; + Arg2.valid := false; + end; + $F8..$FB: // idiv reg + begin + Op := ASM_IDIV; + Length := 2; + case B of + $F8: Arg1.Reg := _EAX; + $F9: Arg1.Reg := _ECX; + $FA: Arg1.Reg := _EDX; + $FB: Arg1.Reg := _EBX; + end; + Arg2.valid := false; + end; + $D0..$D3: // not reg + begin + Op := ASM_NOT; + Length := 2; + case B of + $D0: Arg1.Reg := _EAX; + $D1: Arg1.Reg := _ECX; + $D2: Arg1.Reg := _EDX; + $D3: Arg1.Reg := _EBX; + end; + Arg2.valid := false; + end; + $D8..$DB: // neg reg + begin + Op := ASM_NEG; + Length := 2; + case B of + $D8: Arg1.Reg := _EAX; + $D9: Arg1.Reg := _ECX; + $DA: Arg1.Reg := _EDX; + $DB: Arg1.Reg := _EBX; + end; + Arg2.valid := false; + end; + $98..$9E: // neg dword ptr [reg] + begin + Op := ASM_NEG; + Length := 6; + case B of + $98: Arg1.Reg := _EAX; + $99: Arg1.Reg := _ECX; + $9A: Arg1.Reg := _EDX; + $9B: Arg1.Reg := _EBX; + $9C: Arg1.Reg := _ESP; + $9D: Arg1.Reg := _EBP; + $9E: Arg1.Reg := _ESI; + end; + P := ShiftPointer(P, 1); + Move(P^, Arg1.val, 4); + Arg1.Ptr := true; + Arg2.valid := false; + end; + else + RaiseError(errInternalError, []); + end; + end; + + $D3: + begin + P := ShiftPointer(P, 1); + B := Byte(P^); + + Arg2.Reg := _ECX; + Arg2.sz := 1; + Length := 2; + + case B of + $E0..$E3: // shl reg, cl + begin + Op := ASM_SHL; + case B of + $E0: Arg1.Reg := _EAX; + $E1: Arg1.Reg := _ECX; + $E2: Arg1.Reg := _EDX; + $E3: Arg1.Reg := _EBX; + end; + end; + $E8..$EB: // shr reg, cl + begin + Op := ASM_SHR; + case B of + $E8: Arg1.Reg := _EAX; + $E9: Arg1.Reg := _ECX; + $EA: Arg1.Reg := _EDX; + $EB: Arg1.Reg := _EBX; + end; + end; + else + RaiseError(errInternalError, []); + end; + end; + + //GET REG, BYTE PTR ESI or EBP + $8A: + begin + Op := ASM_MOV; + Arg1.sz := 1; + Arg2.sz := 1; + + P := ShiftPointer(P, 1); + B := Byte(P^); + + if AssignRegMovESIPtr(B, Arg1) then + begin + Length := 6; + Arg2.Reg := _ESI; + Arg2.Ptr := true; + P := ShiftPointer(P, 1); + Move(P^, Arg2.val, 4); + end + else if AssignRegMovEBPPtr(B, Arg1) then + begin + Length := 6; + Arg2.Reg := _EBP; + Arg2.Ptr := true; + P := ShiftPointer(P, 1); + Move(P^, Arg2.val, 4); + end + else + begin + Length := 2; + Arg2.Ptr := true; + if not AssignR32_R32(B, Arg1, Arg2) then + RaiseError(errInternalError, []); +// case B of +// $00: begin Arg1.Reg := _EAX; Arg2.Reg := _EAX; end; + end; + end; + + //GET REG, ESI or EDI or EBP + $8B: + begin + Op := ASM_MOV; + + P := ShiftPointer(P, 1); + B := Byte(P^); + + Arg1.sz := 4; + Arg2.sz := 4; + if AssignRegMovESIPtr(B, Arg1) then + begin + Length := 6; + Arg2.Reg := _ESI; + Arg2.Ptr := true; + P := ShiftPointer(P, 1); + Move(P^, Arg2.Val, 4); + end + else if AssignRegMovEBPPtr(B, Arg1) then + begin + Length := 6; + Arg2.Reg := _EBP; + Arg2.Ptr := true; + P := ShiftPointer(P, 1); + Move(P^, Arg2.Val, 4); + end + else if B = $B4 then + begin + Length := 7; + P := ShiftPointer(P, 1); + B := Byte(P^); + if B <> $24 then + RaiseError(errInternalError, []); + Arg1.Reg := _ESI; + Arg2.Reg := _ESP; + Arg2.Ptr := true; + P := ShiftPointer(P, 1); + Move(P^, Arg2.Val, 4); + end + else if B = $BC then + begin + Length := 7; + P := ShiftPointer(P, 1); + B := Byte(P^); + if B <> $24 then + RaiseError(errInternalError, []); + Arg1.Reg := _EDI; + Arg2.Reg := _ESP; + Arg2.Ptr := true; + P := ShiftPointer(P, 1); + Move(P^, Arg2.Val, 4); + end + else + begin + Length := 2; + Arg2.Ptr := true; + if not AssignR32_R32(B, Arg1, Arg2) then + RaiseError(errInternalError, []); + +// case B of +// $00: begin Arg1.Reg := _EAX; Arg2.Reg := _EAX; end; +// $01: begin Arg1.Reg := _EAX; Arg2.Reg := _ECX; end; + end; + end; // $8B //GET REG, ESI or EDI or EBP + + // Put BYTE PTR [ESI]| BYTE PTR [EBP], REG + $88: + begin + Op := ASM_MOV; + + P := ShiftPointer(P, 1); + B := Byte(P^); + + Arg1.sz := 1; + Arg2.sz := 1; + + if AssignRegMovESIPtr(B, Arg2) then + begin + Length := 6; + Arg1.Ptr := true; + Arg1.Reg := _ESI; + P := ShiftPointer(P, 1); + Move(P^, Arg1.val, 4); + end + else if AssignRegMovEBPPtr(B, Arg2) then + begin + Length := 6; + Arg1.Ptr := true; + Arg1.Reg := _EBP; + P := ShiftPointer(P, 1); + Move(P^, Arg1.val, 4); + end + else + begin + Length := 2; + if AssignR32_R32(B, Arg2, Arg1) then + Arg1.Ptr := true + else + RaiseError(errInternalError, []); + end; + end; + + // Put [ESI] REG or MOV REGPtr, REG + $89: + begin + Op := ASM_MOV; + Arg1.sz := 4; + Arg2.sz := 4; + + P := ShiftPointer(P, 1); + B := Byte(P^); + + if AssignRegMovESIPtr(B, Arg2) then + begin + Length := 6; + Arg1.Ptr := true; + Arg1.Reg := _ESI; + P := ShiftPointer(P, 1); + Move(P^, Arg1.val, 4); + end + else if AssignRegMovEBPPtr(B, Arg2) then + begin + Length := 6; + Arg1.Ptr := true; + Arg1.Reg := _EBP; + P := ShiftPointer(P, 1); + Move(P^, Arg1.val, 4); + end + else + begin + Length := 2; + + if not AssignMovR32(B, Arg1, Arg2) then + if AssignR32_R32(B, Arg2, Arg1) then + Arg1.Ptr := true + else + RaiseError(errInternalError, []); + end; + end; + + //LEA REG32, [REG32 + Shift] + $8D: + begin + Op := ASM_LEA; + Length := 6; + + P := ShiftPointer(P, 1); + B := Byte(P^); + + case B of + $80: begin Arg1.Reg := _EAX; Arg2.Reg := _EAX; end; + $81: begin Arg1.Reg := _EAX; Arg2.Reg := _ECX; end; + $82: begin Arg1.Reg := _EAX; Arg2.Reg := _EDX; end; + $83: begin Arg1.Reg := _EAX; Arg2.Reg := _EBX; end; + $85: begin Arg1.Reg := _EAX; Arg2.Reg := _EBP; end; + $86: begin Arg1.Reg := _EAX; Arg2.Reg := _ESI; end; + $87: begin Arg1.Reg := _EAX; Arg2.Reg := _EDI; end; + + $88: begin Arg1.Reg := _ECX; Arg2.Reg := _EAX; end; + $89: begin Arg1.Reg := _ECX; Arg2.Reg := _ECX; end; + $8A: begin Arg1.Reg := _ECX; Arg2.Reg := _EDX; end; + $8B: begin Arg1.Reg := _ECX; Arg2.Reg := _EBX; end; + $8D: begin Arg1.Reg := _ECX; Arg2.Reg := _EBP; end; + $8E: begin Arg1.Reg := _ECX; Arg2.Reg := _ESI; end; + $8F: begin Arg1.Reg := _ECX; Arg2.Reg := _EDI; end; + + $90: begin Arg1.Reg := _EDX; Arg2.Reg := _EAX; end; + $91: begin Arg1.Reg := _EDX; Arg2.Reg := _ECX; end; + $92: begin Arg1.Reg := _EDX; Arg2.Reg := _EDX; end; + $93: begin Arg1.Reg := _EDX; Arg2.Reg := _EBX; end; + $95: begin Arg1.Reg := _EDX; Arg2.Reg := _EBP; end; + $96: begin Arg1.Reg := _EDX; Arg2.Reg := _ESI; end; + $97: begin Arg1.Reg := _EDX; Arg2.Reg := _EDI; end; + + $98: begin Arg1.Reg := _EBX; Arg2.Reg := _EAX; end; + $99: begin Arg1.Reg := _EBX; Arg2.Reg := _ECX; end; + $9A: begin Arg1.Reg := _EBX; Arg2.Reg := _EDX; end; + $9B: begin Arg1.Reg := _EBX; Arg2.Reg := _EBX; end; + $9D: begin Arg1.Reg := _EBX; Arg2.Reg := _EBP; end; + $9E: begin Arg1.Reg := _EBX; Arg2.Reg := _ESI; end; + $9F: begin Arg1.Reg := _EBX; Arg2.Reg := _EDI; end; + else + RaiseError(errInternalError, []); + end; + + Arg2.Ptr := true; + P := ShiftPointer(P, 1); + Move(P^, Arg2.Val, 4); + end; + + // (SUB|XOR|CMP|OR|AND) REG, REG + $29, $31, $39, $09, $21: + begin + + case B of + $29: Op := ASM_SUB; + $31: Op := ASM_XOR; + $39: Op := ASM_CMP; + $09: Op := ASM_OR; + $21: Op := ASM_AND; + end; + + P := ShiftPointer(P, 1); + B := Byte(P^); + + Length := 2; + + case B of + $C0: begin Arg1.Reg := _EAX; Arg2.Reg := _EAX; end; + $C8: begin Arg1.Reg := _EAX; Arg2.Reg := _ECX; end; + $D0: begin Arg1.Reg := _EAX; Arg2.Reg := _EDX; end; + $D8: begin Arg1.Reg := _EAX; Arg2.Reg := _EBX; end; + + $C1: begin Arg1.Reg := _ECX; Arg2.Reg := _EAX; end; + $C9: begin Arg1.Reg := _ECX; Arg2.Reg := _ECX; end; + $D1: begin Arg1.Reg := _ECX; Arg2.Reg := _EDX; end; + $D9: begin Arg1.Reg := _ECX; Arg2.Reg := _EBX; end; + + $C2: begin Arg1.Reg := _EDX; Arg2.Reg := _EAX; end; + $CA: begin Arg1.Reg := _EDX; Arg2.Reg := _ECX; end; + $D2: begin Arg1.Reg := _EDX; Arg2.Reg := _EDX; end; + $DA: begin Arg1.Reg := _EDX; Arg2.Reg := _EBX; end; + + $C3: begin Arg1.Reg := _EBX; Arg2.Reg := _EAX; end; + $CB: begin Arg1.Reg := _EBX; Arg2.Reg := _ECX; end; + $D3: begin Arg1.Reg := _EBX; Arg2.Reg := _EDX; end; + $DB: begin Arg1.Reg := _EBX; Arg2.Reg := _EBX; end; + else + RaiseError(errInternalError, []); + end; + end; + + $87: + begin + Op := ASM_XCHG; + + P := ShiftPointer(P, 1); + B := Byte(P^); + + Length := 2; + + case B of + $C9: begin Arg1.Reg := _ECX; Arg2.Reg := _ECX; end; + $CA: begin Arg1.Reg := _ECX; Arg2.Reg := _EDX; end; + $CB: begin Arg1.Reg := _ECX; Arg2.Reg := _EBX; end; + $CC: begin Arg1.Reg := _ECX; Arg2.Reg := _ESP; end; + $CD: begin Arg1.Reg := _ECX; Arg2.Reg := _EBP; end; + $CE: begin Arg1.Reg := _ECX; Arg2.Reg := _ESI; end; + $CF: begin Arg1.Reg := _ECX; Arg2.Reg := _EDI; end; + + $D1: begin Arg1.Reg := _EDX; Arg2.Reg := _ECX; end; + $D2: begin Arg1.Reg := _EDX; Arg2.Reg := _EDX; end; + $D3: begin Arg1.Reg := _EDX; Arg2.Reg := _EBX; end; + $D4: begin Arg1.Reg := _EDX; Arg2.Reg := _ESP; end; + $D5: begin Arg1.Reg := _EDX; Arg2.Reg := _EBP; end; + $D6: begin Arg1.Reg := _EDX; Arg2.Reg := _ESI; end; + $D7: begin Arg1.Reg := _EDX; Arg2.Reg := _EDI; end; + + $D9: begin Arg1.Reg := _EBX; Arg2.Reg := _ECX; end; + $DA: begin Arg1.Reg := _EBX; Arg2.Reg := _EDX; end; + $DB: begin Arg1.Reg := _EBX; Arg2.Reg := _EBX; end; + $DC: begin Arg1.Reg := _EBX; Arg2.Reg := _ESP; end; + $DD: begin Arg1.Reg := _EBX; Arg2.Reg := _EBP; end; + $DE: begin Arg1.Reg := _EBX; Arg2.Reg := _ESI; end; + $DF: begin Arg1.Reg := _EBX; Arg2.Reg := _EDI; end; + else + RaiseError(errInternalError, []); + end; + end; + + // FLD|FSTP REG + $DD: + begin + Length := 2; + P := ShiftPointer(P, 1); + B := Byte(P^); + + Arg1.Ptr := true; + Arg1.sz := 8; + + Arg2.valid := false; + case B of + $00: begin Op := ASM_FLD; Arg1.Reg := _EAX; end; + $01: begin Op := ASM_FLD; Arg1.Reg := _ECX; end; + $02: begin Op := ASM_FLD; Arg1.Reg := _EDX; end; + $03: begin Op := ASM_FLD; Arg1.Reg := _EBX; end; + + $18: begin Op := ASM_FSTP; Arg1.Reg := _EAX; end; + $19: begin Op := ASM_FSTP; Arg1.Reg := _ECX; end; + $1A: begin Op := ASM_FSTP; Arg1.Reg := _EDX; end; + $1B: begin Op := ASM_FSTP; Arg1.Reg := _EBX; end; + + $80: + begin + Length := 6; + Op := ASM_FLD; + Arg1.Reg := _EAX; + P := ShiftPointer(P, 1); + Move(P^, Arg1.val, 4); + end; + + $81: + begin + Length := 6; + Op := ASM_FLD; + Arg1.Reg := _ECX; + P := ShiftPointer(P, 1); + Move(P^, Arg1.val, 4); + end; + + $82: + begin + Length := 6; + Op := ASM_FLD; + Arg1.Reg := _EDX; + P := ShiftPointer(P, 1); + Move(P^, Arg1.val, 4); + end; + + $83: + begin + Length := 6; + Op := ASM_FLD; + Arg1.Reg := _EBX; + P := ShiftPointer(P, 1); + Move(P^, Arg1.val, 4); + end; + + $85: + begin + Length := 6; + Op := ASM_FLD; + Arg1.Reg := _EBP; + P := ShiftPointer(P, 1); + Move(P^, Arg1.val, 4); + end; + + $86: + begin + Length := 6; + Op := ASM_FLD; + Arg1.Reg := _ESI; + P := ShiftPointer(P, 1); + Move(P^, Arg1.val, 4); + end; + + $98: + begin + Length := 6; + Op := ASM_FSTP; + Arg1.Reg := _EAX; + P := ShiftPointer(P, 1); + Move(P^, Arg1.val, 4); + end; + + $99: + begin + Length := 6; + Op := ASM_FSTP; + Arg1.Reg := _ECX; + P := ShiftPointer(P, 1); + Move(P^, Arg1.val, 4); + end; + + $9A: + begin + Length := 6; + Op := ASM_FSTP; + Arg1.Reg := _EDX; + P := ShiftPointer(P, 1); + Move(P^, Arg1.val, 4); + end; + + $9B: + begin + Length := 6; + Op := ASM_FSTP; + Arg1.Reg := _EBX; + P := ShiftPointer(P, 1); + Move(P^, Arg1.val, 4); + end; + + $9D: + begin + Length := 6; + Op := ASM_FSTP; + Arg1.Reg := _EBP; + P := ShiftPointer(P, 1); + Move(P^, Arg1.val, 4); + end; + + $9E: + begin + Length := 6; + Op := ASM_FSTP; + Arg1.Reg := _ESI; + P := ShiftPointer(P, 1); + Move(P^, Arg1.val, 4); + end; + + else + RaiseError(errInternalError, []); + end; + end; + + // FILD REG PTR32 + $DB: + begin + P := ShiftPointer(P, 1); + B := Byte(P^); + + if B in [$00..$03] then + begin + Op := ASM_FILD; + Length := 2; + Arg1.Ptr := true; + Arg1.sz := 4; + + Arg2.valid := false; + case B of + $00: Arg1.Reg := _EAX; + $01: Arg1.Reg := _ECX; + $02: Arg1.Reg := _EDX; + $03: Arg1.Reg := _EBX; + end; + end + else if B in [$28..$2B] then // Fld TBYTE PTR [REG] + begin + Op := ASM_FLD; + Length := 2; + Arg1.Ptr := true; + Arg1.sz := 10; + case B of + $28: Arg1.Reg := _EAX; + $29: Arg1.Reg := _ECX; + $2A: Arg1.Reg := _EDX; + $2B: Arg1.Reg := _EBX; + end; + Arg2.valid := false; + end + else if B in [$38..$3B] then // FStp TBYTE PTR [REG] + begin + Op := ASM_FSTP; + Length := 2; + Arg1.Ptr := true; + Arg1.sz := 10; + case B of + $38: Arg1.Reg := _EAX; + $39: Arg1.Reg := _ECX; + $3A: Arg1.Reg := _EDX; + $3B: Arg1.Reg := _EBX; + end; + Arg2.valid := false; + end + else if B in [$A8..$AE] then + begin + Op := ASM_FLD; // Fld TBYTE PTR [REG + Shift] + Length := 6; + Arg1.Ptr := true; + Arg1.sz := 10; + case B of + $A8: Arg1.Reg := _EAX; + $A9: Arg1.Reg := _ECX; + $AA: Arg1.Reg := _EDX; + $AB: Arg1.Reg := _EBX; + $AD: Arg1.Reg := _EBP; + $AE: Arg1.Reg := _ESP; + end; + P := ShiftPointer(P, 1); + Move(P^, Arg1.val, 4); + + Arg2.valid := false; + end + else if B in [$B8..$BE] then + begin + Op := ASM_FSTP; // FSTP TBYTE PTR [REG + Shift] + Length := 6; + Arg1.Ptr := true; + Arg1.sz := 10; + case B of + $B8: Arg1.Reg := _EAX; + $B9: Arg1.Reg := _ECX; + $BA: Arg1.Reg := _EDX; + $BB: Arg1.Reg := _EBX; + $BD: Arg1.Reg := _EBP; + $BE: Arg1.Reg := _ESP; + end; + P := ShiftPointer(P, 1); + Move(P^, Arg1.val, 4); + + Arg2.valid := false; + end + else + RaiseError(errInternalError, []); + end; + + // FADD, DSUB, FMUL, FDIV REG + $DC: + begin + Length := 2; + P := ShiftPointer(P, 1); + B := Byte(P^); + + Arg1.Ptr := true; + Arg1.sz := 8; + + Arg2.valid := false; + case B of + $00: begin Op := ASM_FADD; Arg1.Reg := _EAX; end; + $01: begin Op := ASM_FADD; Arg1.Reg := _ECX; end; + $02: begin Op := ASM_FADD; Arg1.Reg := _EDX; end; + $03: begin Op := ASM_FADD; Arg1.Reg := _EBX; end; + + $20: begin Op := ASM_FSUB; Arg1.Reg := _EAX; end; + $21: begin Op := ASM_FSUB; Arg1.Reg := _ECX; end; + $22: begin Op := ASM_FSUB; Arg1.Reg := _EDX; end; + $23: begin Op := ASM_FSUB; Arg1.Reg := _EBX; end; + + $08: begin Op := ASM_FMUL; Arg1.Reg := _EAX; end; + $09: begin Op := ASM_FMUL; Arg1.Reg := _ECX; end; + $0A: begin Op := ASM_FMUL; Arg1.Reg := _EDX; end; + $0B: begin Op := ASM_FMUL; Arg1.Reg := _EBX; end; + + $30: begin Op := ASM_FDIV; Arg1.Reg := _EAX; end; + $31: begin Op := ASM_FDIV; Arg1.Reg := _ECX; end; + $32: begin Op := ASM_FDIV; Arg1.Reg := _EDX; end; + $33: begin Op := ASM_FDIV; Arg1.Reg := _EBX; end; + else + RaiseError(errInternalError, []); + end; + end; + + // FCOMP + $D8: + begin + Op := ASM_FCOMP; + Length := 2; + P := ShiftPointer(P, 1); + B := Byte(P^); + + Arg1.Ptr := true; + Arg1.sz := 8; + + Arg2.valid := false; + + if B = $8E then + begin + Length := 6; + P := ShiftPointer(P, 1); + Op := ASM_FMUL; + Arg1.sz := 4; + Arg1.Reg := _ESI; + Move(P^, Arg1.val, 4); + Exit; + end + else if B = $B6 then + begin + Length := 6; + P := ShiftPointer(P, 1); + Op := ASM_FDIV; + Arg1.sz := 4; + Arg1.Reg := _ESI; + Move(P^, Arg1.val, 4); + Exit; + end; + + case B of + $18: Arg1.Reg := _EAX; + $19: Arg1.Reg := _ECX; + $1A: Arg1.Reg := _EDX; + $1B: Arg1.Reg := _EBX; + else + RaiseError(errInternalError, []); + end; + end; + + // FSTSV + $DF: + begin + Length := 2; + P := ShiftPointer(P, 1); + B := Byte(P^); + + if B in [$00..$03] then + begin + Op := ASM_FILD; + Length := 2; + Arg1.Ptr := true; + Arg1.sz := 2; + + Arg2.valid := false; + case B of + $00: Arg1.Reg := _EAX; + $01: Arg1.Reg := _ECX; + $02: Arg1.Reg := _EDX; + $03: Arg1.Reg := _EBX; + end; + Exit; + end + else if B in [$28..$2B] then + begin + Op := ASM_FILD; + Arg1.Ptr := true; + Arg1.sz := 8; + Arg2.valid := false; + case B of + $28: Arg1.Reg := _EAX; + $29: Arg1.Reg := _ECX; + $2A: Arg1.Reg := _EDX; + $2B: Arg1.Reg := _EBX; + else + RaiseError(errInternalError, []); + end; + Exit; + end + else if B in [$38..$3B] then + begin + Op := ASM_FISTP; + Arg1.Ptr := true; + Arg1.sz := 8; + Arg2.valid := false; + case B of + $38: Arg1.Reg := _EAX; + $39: Arg1.Reg := _ECX; + $3A: Arg1.Reg := _EDX; + $3B: Arg1.Reg := _EBX; + else + RaiseError(errInternalError, []); + end; + Exit; + end; + + Op := ASM_FSTSV; + Arg1.sz := 2; + Arg2.valid := false; + case B of + $E0: Arg1.Reg := _EAX; + else + RaiseError(errInternalError, []); + end; + end; // $DF + + $9E: //SAHF + begin + op := ASM_SAHF; + Length := 1; + Arg1.valid := false; + Arg2.valid := false; + end; + + $99: //CDQ + begin + op := ASM_CDQ; + Length := 1; + Arg1.valid := false; + Arg2.valid := false; + end; + + // FADD, FSUB, FMUL, FDIV, FCOMPP + $DE: + begin + Length := 2; + P := ShiftPointer(P, 1); + B := Byte(P^); + case B of + $C1: op := ASM_FADD; + $C9: op := ASM_FMUL; + $D9: op := ASM_FCOMPP; + $E9: op := ASM_FSUB; + $F9: op := ASM_FDIV; + else + RaiseError(errInternalError, []); + end; + + Arg1.valid := false; + Arg2.valid := false; + end; + + // FCHS + $D9: + begin + Length := 2; + P := ShiftPointer(P, 1); + B := Byte(P^); + case B of + $E0: op := ASM_FCHS; + $E1: op := ASM_FABS; + else + begin + // FLD|FSTP (Single) REG + Arg1.Ptr := true; + Arg1.sz := 4; + Arg2.valid := false; + case B of + $00: begin Op := ASM_FLD; Arg1.Reg := _EAX; end; + $01: begin Op := ASM_FLD; Arg1.Reg := _ECX; end; + $02: begin Op := ASM_FLD; Arg1.Reg := _EDX; end; + $03: begin Op := ASM_FLD; Arg1.Reg := _EBX; end; + + $18: begin Op := ASM_FSTP; Arg1.Reg := _EAX; end; + $19: begin Op := ASM_FSTP; Arg1.Reg := _ECX; end; + $1A: begin Op := ASM_FSTP; Arg1.Reg := _EDX; end; + $1B: begin Op := ASM_FSTP; Arg1.Reg := _EBX; end; + + $80: + begin + Length := 6; + Op := ASM_FLD; + Arg1.Reg := _EAX; + P := ShiftPointer(P, 1); + Move(P^, Arg1.val, 4); + end; + + $81: + begin + Length := 6; + Op := ASM_FLD; + Arg1.Reg := _ECX; + P := ShiftPointer(P, 1); + Move(P^, Arg1.val, 4); + end; + + $82: + begin + Length := 6; + Op := ASM_FLD; + Arg1.Reg := _EDX; + P := ShiftPointer(P, 1); + Move(P^, Arg1.val, 4); + end; + + $83: + begin + Length := 6; + Op := ASM_FLD; + Arg1.Reg := _EBX; + P := ShiftPointer(P, 1); + Move(P^, Arg1.val, 4); + end; + + $85: + begin + Length := 6; + Op := ASM_FLD; + Arg1.Reg := _EBP; + P := ShiftPointer(P, 1); + Move(P^, Arg1.val, 4); + end; + + $86: + begin + Length := 6; + Op := ASM_FLD; + Arg1.Reg := _ESI; + P := ShiftPointer(P, 1); + Move(P^, Arg1.val, 4); + end; + + $98: + begin + Length := 6; + Op := ASM_FSTP; + Arg1.Reg := _EAX; + P := ShiftPointer(P, 1); + Move(P^, Arg1.val, 4); + end; + + $99: + begin + Length := 6; + Op := ASM_FSTP; + Arg1.Reg := _ECX; + P := ShiftPointer(P, 1); + Move(P^, Arg1.val, 4); + end; + + $9A: + begin + Length := 6; + Op := ASM_FSTP; + Arg1.Reg := _EDX; + P := ShiftPointer(P, 1); + Move(P^, Arg1.val, 4); + end; + + $9B: + begin + Length := 6; + Op := ASM_FSTP; + Arg1.Reg := _EBX; + P := ShiftPointer(P, 1); + Move(P^, Arg1.val, 4); + end; + + $9D: + begin + Length := 6; + Op := ASM_FSTP; + Arg1.Reg := _EBP; + P := ShiftPointer(P, 1); + Move(P^, Arg1.val, 4); + end; + + $9E: + begin + Length := 6; + Op := ASM_FSTP; + Arg1.Reg := _ESI; + P := ShiftPointer(P, 1); + Move(P^, Arg1.val, 4); + end; + else + RaiseError(errInternalError, []); + end; + Exit; + end; + end; + + Arg1.valid := false; + Arg2.valid := false; + end; + + // SETL, SETLE, SETNLE, SETNL, + // SETB, SETBE, SETNBE, SETNB, SETZ, SETNZ + $0F: + begin + Length := 3; + P := ShiftPointer(P, 1); + B := Byte(P^); + + case B of + $92: Op := ASM_SETB; + $93: Op := ASM_SETNB; + $94: Op := ASM_SETZ; + $95: Op := ASM_SETNZ; + $96: Op := ASM_SETBE; + $97: Op := ASM_SETNBE; + $9C: Op := ASM_SETL; + $9D: Op := ASM_SETNL; + $9E: Op := ASM_SETLE; + $9F: Op := ASM_SETNLE; + else + RaiseError(errInternalError, []); + end; + + P := ShiftPointer(P, 1); + B := Byte(P^); + + Arg1.Ptr := true; + Arg1.sz := 1; + + Arg2.valid := false; + case B of + $00: Arg1.Reg := _EAX; + $01: Arg1.Reg := _ECX; + $02: Arg1.Reg := _EDX; + $03: Arg1.Reg := _EBX; + + $80..$86: + begin + case B of + $80: Arg1.Reg := _EAX; + $81: Arg1.Reg := _ECX; + $82: Arg1.Reg := _EDX; + $83: Arg1.Reg := _EBX; + $84: Arg1.Reg := _ESP; + $85: Arg1.Reg := _EBP; + $86: Arg1.Reg := _ESI; + end; + + Length := 7; + P := ShiftPointer(P, 1); + Move(P^, Arg1.val, 4); + end; + else + RaiseError(errInternalError, []); + end; + end; + + $80: + begin + Arg1.sz := 1; + Arg1.Ptr := true; + + P := ShiftPointer(P, 1); + B := Byte(P^); + + case B of + $80..$86: // ADD BYTE PTR [REG + Shift], imm + begin + Op := ASM_ADD; + Length := 7; + + case B of + $80: Arg1.Reg := _EAX; + $81: Arg1.Reg := _ECX; + $82: Arg1.Reg := _EDX; + $83: Arg1.Reg := _EBX; + $84: Arg1.Reg := _ESP; + $85: Arg1.Reg := _EBP; + $86: Arg1.Reg := _ESI; + end; + + P := ShiftPointer(P, 1); + Move(P^, Arg1.val, 4); + + P := ShiftPointer(P, 4); + B := Byte(P^); + Arg2.val := B; + end; + + $B8..$BE: // CMP BYTE PTR [REG + Shift], imm + begin + Op := ASM_CMP; + Length := 7; + + case B of + $B8: Arg1.Reg := _EAX; + $B9: Arg1.Reg := _ECX; + $BA: Arg1.Reg := _EDX; + $BB: Arg1.Reg := _EBX; + $BC: Arg1.Reg := _ESP; + $BD: Arg1.Reg := _EBP; + $BE: Arg1.Reg := _ESI; + end; + + P := ShiftPointer(P, 1); + Move(P^, Arg1.val, 4); + + P := ShiftPointer(P, 4); + B := Byte(P^); + Arg2.val := B; + end; + + $38..$3B: // CMP BYTE PTR [REG], imm + begin + op := ASM_CMP; + Length := 3; + case B of + $38: Arg1.Reg := _EAX; + $39: Arg1.Reg := _ECX; + $3A: Arg1.Reg := _EDX; + $3B: Arg1.Reg := _EBX; + end; + + P := ShiftPointer(P, 1); + B := Byte(P^); + Arg2.val := B; + end; + else + RaiseError(errInternalError, []); + end; + end; + + $E9: + begin + op := ASM_JMP; + Length := 5; + Arg2.valid := false; + P := ShiftPointer(P, 1); + Move(P^, Arg1.val, 4); + end; + + $2D: + begin + op := ASM_SUB; + Length := 5; + Arg1.Reg := _EAX; + P := ShiftPointer(P, 1); + Move(P^, Arg2.val, 4); + end; + + $3D: + begin + op := ASM_CMP; + Length := 5; + Arg1.Reg := _EAX; + P := ShiftPointer(P, 1); + Move(P^, Arg2.val, 4); + end; + + // CALL REG| JMP REG| PUSH REGPtr| Inc REGPtr, Dec REGPtr + $FF: + begin + Length := 2; + Arg2.valid := false; + P := ShiftPointer(P, 1); + B := Byte(P^); + + case B of + $E0: begin Op := ASM_JMP; Arg1.Reg := _EAX; end; + $E1: begin Op := ASM_JMP; Arg1.Reg := _ECX; end; + $E2: begin Op := ASM_JMP; Arg1.Reg := _EDX; end; + $E3: begin Op := ASM_JMP; Arg1.Reg := _EBX; end; + + $D0: begin Op := ASM_CALL; Arg1.Reg := _EAX; end; + $D1: begin Op := ASM_CALL; Arg1.Reg := _ECX; end; + $D2: begin Op := ASM_CALL; Arg1.Reg := _EDX; end; + $D3: begin Op := ASM_CALL; Arg1.Reg := _EBX; end; + $D4: begin Op := ASM_CALL; Arg1.Reg := _ESP; end; + $D5: begin Op := ASM_CALL; Arg1.Reg := _EBP; end; + $D6: begin Op := ASM_CALL; Arg1.Reg := _ESI; end; + $D7: begin Op := ASM_CALL; Arg1.Reg := _EDI; end; + + $30: begin Op := ASM_PUSH; Arg1.Ptr := true; Arg1.sz := 4; Arg1.Reg := _EAX; end; + $31: begin Op := ASM_PUSH; Arg1.Ptr := true; Arg1.sz := 4; Arg1.Reg := _ECX; end; + $32: begin Op := ASM_PUSH; Arg1.Ptr := true; Arg1.sz := 4; Arg1.Reg := _EDX; end; + $33: begin Op := ASM_PUSH; Arg1.Ptr := true; Arg1.sz := 4; Arg1.Reg := _EBX; end; + + $80..$8F: // INC, DEC + begin + Length := 6; + Arg1.Ptr := true; + Arg1.sz := 4; + if B in [$80..$87] then + Op := ASM_INC + else + Op := ASM_DEC; + case B of + $80: Arg1.Reg := _EAX; + $81: Arg1.Reg := _ECX; + $82: Arg1.Reg := _EDX; + $83: Arg1.Reg := _EBX; + $84: RaiseError(errInternalError, []); + $85: Arg1.Reg := _EBP; + $86: Arg1.Reg := _ESI; + $87: Arg1.Reg := _EDI; + + $88: Arg1.Reg := _EAX; + $89: Arg1.Reg := _ECX; + $8A: Arg1.Reg := _EDX; + $8B: Arg1.Reg := _EBX; + $8C: RaiseError(errInternalError, []); + $8D: Arg1.Reg := _EBP; + $8E: Arg1.Reg := _ESI; + $8F: Arg1.Reg := _EDI; + end; + P := ShiftPointer(P, 1); + Move(P^, Arg1.val, 4); + end + else + RaiseError(errInternalError, []); + end; + end; + + // PUSH Imm + $68: + begin + Op := ASM_PUSH; + Length := 5; + + P := ShiftPointer(P, 1); + Move(P^, Arg1.val, 4); + + Arg2.valid := false; + end; + + $84: + begin + Op := ASM_TEST; + Length := 2; + Arg1.sz := 1; + Arg1.sz := 1; + P := ShiftPointer(P, 1); + B := Byte(P^); + case B of + $D2: begin Arg1.Reg := _EDX; Arg2.Reg := _EDX; end; + else + RaiseError(errInternalError, []); + end; + end; + + // PUSH REG | POP REG + $50..$57, $58..$5F: + begin + Length := 1; + Arg2.valid := false; + + case B of + $50: begin Op := ASM_PUSH; Arg1.Reg := _EAX; end; + $51: begin Op := ASM_PUSH; Arg1.Reg := _ECX; end; + $52: begin Op := ASM_PUSH; Arg1.Reg := _EDX; end; + $53: begin Op := ASM_PUSH; Arg1.Reg := _EBX; end; + $54: begin Op := ASM_PUSH; Arg1.Reg := _ESP; end; + $55: begin Op := ASM_PUSH; Arg1.Reg := _EBP; end; + $56: begin Op := ASM_PUSH; Arg1.Reg := _ESI; end; + $57: begin Op := ASM_PUSH; Arg1.Reg := _EDI; end; + + $58: begin Op := ASM_POP; Arg1.Reg := _EAX; end; + $59: begin Op := ASM_POP; Arg1.Reg := _ECX; end; + $5A: begin Op := ASM_POP; Arg1.Reg := _EDX; end; + $5B: begin Op := ASM_POP; Arg1.Reg := _EBX; end; + $5C: begin Op := ASM_POP; Arg1.Reg := _ESP; end; + $5D: begin Op := ASM_POP; Arg1.Reg := _EBP; end; + $5E: begin Op := ASM_POP; Arg1.Reg := _ESI; end; + $5F: begin Op := ASM_POP; Arg1.Reg := _EDI; end; + else + RaiseError(errInternalError, []); + end; + end; + + $C6: + begin + Arg1.sz := 1; + Arg1.Ptr := true; + + P := ShiftPointer(P, 1); + B := Byte(P^); + + case B of + $00..$06: // MOV BYTE PTR [REG], imm + begin + Op := ASM_MOV; + Length := 3; + case B of + $00: Arg1.Reg := _EAX; + $01: Arg1.Reg := _ECX; + $02: Arg1.Reg := _EDX; + $03: Arg1.Reg := _EBX; + $04: Arg1.Reg := _ESP; + $05: Arg1.Reg := _EBP; + $06: Arg1.Reg := _ESI; + end; + P := ShiftPointer(P, 1); + B := Byte(P^); + + Arg2.val := B; + end; + + $80..$86: // MOV BYTE PTR [REG + Shift], imm + begin + Op := ASM_MOV; + Length := 7; + + case B of + $80: Arg1.Reg := _EAX; + $81: Arg1.Reg := _ECX; + $82: Arg1.Reg := _EDX; + $83: Arg1.Reg := _EBX; + $84: Arg1.Reg := _ESP; + $85: Arg1.Reg := _EBP; + $86: Arg1.Reg := _ESI; + end; + + P := ShiftPointer(P, 1); + Move(P^, Arg1.val, 4); + + P := ShiftPointer(P, 4); + B := Byte(P^); + Arg2.val := B; + end; + else + RaiseError(errInternalError, []); + end; + end; + + $C7: + begin + Arg1.sz := 4; + Arg1.Ptr := true; + + P := ShiftPointer(P, 1); + B := Byte(P^); + + case B of + $00..$06: // MOV DWORD PTR [REG], imm + begin + Op := ASM_MOV; + + case B of + $00: Arg1.Reg := _EAX; + $01: Arg1.Reg := _ECX; + $02: Arg1.Reg := _EDX; + $03: Arg1.Reg := _EBX; + $04: Arg1.Reg := _ESP; + $05: Arg1.Reg := _EBP; + $06: Arg1.Reg := _ESI; + else + RaiseError(errInternalError, []); + end; + + Length := 6; + + P := ShiftPointer(P, 1); + Move(P^, Arg2.val, 4); + end; + + $80..$86: // MOV DWORD PTR [REG + Shift], imm + begin + Op := ASM_MOV; + Length := 10; + + case B of + $80: Arg1.Reg := _EAX; + $81: Arg1.Reg := _ECX; + $82: Arg1.Reg := _EDX; + $83: Arg1.Reg := _EBX; + $84: Arg1.Reg := _ESP; + $85: Arg1.Reg := _EBP; + $86: Arg1.Reg := _ESI; + end; + + P := ShiftPointer(P, 1); + Move(P^, Arg1.val, 4); + + P := ShiftPointer(P, 4); + Move(P^, Arg2.val, 4); + end; + else + RaiseError(errInternalError, []); + end; + end; + + $64: + begin + P := ShiftPointer(P, 1); + B := Byte(P^); + case B of + $FF: + begin + P := ShiftPointer(P, 1); + B := Byte(P^); + case B of + $30: Arg1.Reg := _EAX; + $31: Arg1.Reg := _ECX; + $32: Arg1.Reg := _EDX; + $33: Arg1.Reg := _EBX; + else + RaiseError(errInternalError, []); + end; + Op := ASM_PUSH; + Length := 3; + Arg1.Ptr := true; + Arg1.FS := true; + Arg2.valid := false; + end; + $89: + begin + P := ShiftPointer(P, 1); + B := Byte(P^); + Op := ASM_MOV; + Length := 3; + Arg1.Ptr := true; + Arg1.FS := true; + Arg2.valid := true; + case B of + $00: begin Arg1.Reg := _EAX; Arg2.Reg := _EAX; end; + $08: begin Arg1.Reg := _EAX; Arg2.Reg := _ECX; end; + $10: begin Arg1.Reg := _EAX; Arg2.Reg := _EDX; end; + $18: begin Arg1.Reg := _EAX; Arg2.Reg := _EBX; end; + $20: begin Arg1.Reg := _EAX; Arg2.Reg := _ESP; end; + $28: begin Arg1.Reg := _EAX; Arg2.Reg := _EBP; end; + $30: begin Arg1.Reg := _EAX; Arg2.Reg := _ESI; end; + $38: begin Arg1.Reg := _EAX; Arg2.Reg := _EDI; end; + + $01: begin Arg1.Reg := _ECX; Arg2.Reg := _EAX; end; + $09: begin Arg1.Reg := _ECX; Arg2.Reg := _ECX; end; + $11: begin Arg1.Reg := _ECX; Arg2.Reg := _EDX; end; + $19: begin Arg1.Reg := _ECX; Arg2.Reg := _EBX; end; + $21: begin Arg1.Reg := _ECX; Arg2.Reg := _ESP; end; + $29: begin Arg1.Reg := _ECX; Arg2.Reg := _EBP; end; + $31: begin Arg1.Reg := _ECX; Arg2.Reg := _ESI; end; + $39: begin Arg1.Reg := _ECX; Arg2.Reg := _EDI; end; + + $02: begin Arg1.Reg := _EDX; Arg2.Reg := _EAX; end; + $0A: begin Arg1.Reg := _EDX; Arg2.Reg := _ECX; end; + $12: begin Arg1.Reg := _EDX; Arg2.Reg := _EDX; end; + $1A: begin Arg1.Reg := _EDX; Arg2.Reg := _EBX; end; + $22: begin Arg1.Reg := _EDX; Arg2.Reg := _ESP; end; + $2A: begin Arg1.Reg := _EDX; Arg2.Reg := _EBP; end; + $32: begin Arg1.Reg := _EDX; Arg2.Reg := _ESI; end; + $3A: begin Arg1.Reg := _EDX; Arg2.Reg := _EDI; end; + + $03: begin Arg1.Reg := _EBX; Arg2.Reg := _EAX; end; + $0B: begin Arg1.Reg := _EBX; Arg2.Reg := _ECX; end; + $13: begin Arg1.Reg := _EBX; Arg2.Reg := _EDX; end; + $1B: begin Arg1.Reg := _EBX; Arg2.Reg := _EBX; end; + $23: begin Arg1.Reg := _EBX; Arg2.Reg := _ESP; end; + $2B: begin Arg1.Reg := _EBX; Arg2.Reg := _EBP; end; + $33: begin Arg1.Reg := _EBX; Arg2.Reg := _ESI; end; + $3B: begin Arg1.Reg := _EBX; Arg2.Reg := _EDI; end; + else + RaiseError(errInternalError, []); + end; + end; + else + RaiseError(errInternalError, []); + end; + end; + + $66: + begin + P := ShiftPointer(P, 1); + B := Byte(P^); + case B of + $41: + begin + P := ShiftPointer(P, 1); + B := Byte(P^); + case B of + $89: + begin + P := ShiftPointer(P, 1); + B := Byte(P^); + Op := ASM_MOV; + Length := 4; + Arg1.sz := 2; + Arg2.sz := 2; + Arg1.Ptr := true; + if not AssignR32_R64(B, Arg2, Arg1) then + RaiseError(errInternalError, []); + end; + $8B: + begin + P := ShiftPointer(P, 1); + B := Byte(P^); + Op := ASM_MOV; + Length := 4; + Arg1.sz := 2; + Arg2.sz := 2; + Arg2.Ptr := true; + if not AssignR32_R64(B, Arg1, Arg2) then + RaiseError(errInternalError, []); +// case B of +// $00: begin Arg1.Reg := _EAX; Arg2.Reg := _R8; end; + end; + else + RaiseError(errInternalError, []); + end; + end; + $45: + begin + P := ShiftPointer(P, 1); + B := Byte(P^); + case B of + $89: + begin + P := ShiftPointer(P, 1); + B := Byte(P^); + Op := ASM_MOV; + Length := 4; + Arg1.sz := 2; + Arg2.sz := 2; + Arg1.Ptr := true; + if not AssignR64_R64(B, Arg2, Arg1) then + RaiseError(errInternalError, []); +// case B of +// $00: begin Arg1.Reg := _R8; Arg2.Reg := _R8; end; + end; + $8B: + begin + P := ShiftPointer(P, 1); + B := Byte(P^); + Op := ASM_MOV; + Length := 4; + Arg1.sz := 2; + Arg2.sz := 2; + Arg2.Ptr := true; + if not AssignR64_R64(B, Arg1, Arg2) then + RaiseError(errInternalError, []); +// case B of +// $00: begin Arg1.Reg := _R8; Arg2.Reg := _R8; end; + end; + else + RaiseError(errInternalError, []); + end; + end; + $44: + begin + P := ShiftPointer(P, 1); + B := Byte(P^); + case B of + $89: + begin + P := ShiftPointer(P, 1); + B := Byte(P^); + Arg1.sz := 2; + Arg2.sz := 2; + if AssignRegMovRBPPtr(B, Arg2) then + begin + Op := ASM_MOV; + Length := 8; + Arg1.Reg := _EBP; + Arg1.Ptr := true; + P := ShiftPointer(P, 1); + Move(P^, Arg1.val, 4); + end + else if AssignRegMovRSIPtr(B, Arg2) then + begin + Op := ASM_MOV; + Length := 8; + Arg1.Reg := _ESI; + Arg1.Ptr := true; + P := ShiftPointer(P, 1); + Move(P^, Arg1.val, 4); + end + else + begin + Op := ASM_MOV; + Length := 4; + if AssignR64_R32(B, Arg2, Arg1) then + Arg1.Ptr := true + else + RaiseError(errInternalError, []); + end; + end; + $8B: + begin + P := ShiftPointer(P, 1); + B := Byte(P^); + Arg1.sz := 2; + Arg2.sz := 2; + if AssignRegMovRBPPtr(B, Arg1) then + begin + Op := ASM_MOV; + Length := 8; + Arg2.Reg := _EBP; + Arg2.Ptr := true; + P := ShiftPointer(P, 1); + Move(P^, Arg2.val, 4); + end + else if AssignRegMovRSIPtr(B, Arg1) then + begin + Op := ASM_MOV; + Length := 8; + Arg2.Reg := _ESI; + Arg2.Ptr := true; + P := ShiftPointer(P, 1); + Move(P^, Arg2.val, 4); + end + else + begin + Op := ASM_MOV; + Length := 4; + Arg2.Ptr := true; + if not AssignR64_R32(B, Arg1, Arg2) then + RaiseError(errInternalError, []); +// case B of +// $00: begin Arg1.Reg := _R8; Arg2.Reg := _EAX; end; + end; + end; + else + RaiseError(errInternalError, []); + end; + end; + $50..$53: // PUSH REG16 + begin + Op := ASM_PUSH; + Length := 2; + Arg1.sz := 2; + case B of + $50: Arg1.Reg := _EAX; + $51: Arg1.Reg := _ECX; + $52: Arg1.Reg := _EDX; + $53: Arg1.Reg := _EBX; + end; + Arg2.valid := false; + end; + + $C7: // MOV WORD PTR [REG], Imm + begin + Op := ASM_MOV; + Length := 9; + Arg1.Ptr := true; + Arg1.sz := 2; + + P := ShiftPointer(P, 1); + B := Byte(P^); + case B of + $80: Arg1.Reg := _EAX; + $81: Arg1.Reg := _ECX; + $82: Arg1.Reg := _EDX; + $83: Arg1.Reg := _EBX; + $84: Arg1.Reg := _ESP; + $85: Arg1.Reg := _EBP; + $86: Arg1.Reg := _ESI; + else + RaiseError(errInternalError, []); + end; + P := ShiftPointer(P, 1); + Move(P^, Arg1.val, 4); + P := ShiftPointer(P, 4); + Move(P^, Arg2.val, 2); + end; + $81: + begin + Length := 9; + Arg1.Ptr := true; + Arg1.sz := 2; + + P := ShiftPointer(P, 1); + B := Byte(P^); + + case B of + $80..$86: // ADD WORD PTR [REG], Imm + begin + Op := ASM_ADD; + case B of + $80: Arg1.Reg := _EAX; + $81: Arg1.Reg := _ECX; + $82: Arg1.Reg := _EDX; + $83: Arg1.Reg := _EBX; + $84: Arg1.Reg := _ESP; + $85: Arg1.Reg := _EBP; + $86: Arg1.Reg := _ESI; + end; + end; + $B8..$BE: // WORD PTR [REG], Imm + begin + Op := ASM_CMP; + case B of + $B8: Arg1.Reg := _EAX; + $B9: Arg1.Reg := _ECX; + $BA: Arg1.Reg := _EDX; + $BB: Arg1.Reg := _EBX; + $BC: Arg1.Reg := _ESP; + $BD: Arg1.Reg := _EBP; + $BE: Arg1.Reg := _ESI; + end; + end; + else + RaiseError(errInternalError, []); + end; + P := ShiftPointer(P, 1); + Move(P^, Arg1.val, 4); + P := ShiftPointer(P, 4); + Move(P^, Arg2.val, 2); + end; + $8B: // MOV Reg16, WORD PTR [REG] + begin + Op := ASM_MOV; + Length := 3; + Arg1.sz := 2; + Arg2.sz := 2; + + P := ShiftPointer(P, 1); + B := Byte(P^); + + if AssignRegMovESIPtr(B, Arg1) then + // MOV Reg16, WORD PTR [ESI + Shift] + begin + Length := 7; + Arg2.Reg := _ESI; + Arg2.Ptr := true; + P := ShiftPointer(P, 1); + Move(P^, Arg2.Val, 4); + end + else if AssignRegMovEBPPtr(B, Arg1) then + // MOV Reg16, WORD PTR [EBP + Shift] + begin + Length := 7; + Arg2.Reg := _EBP; + Arg2.Ptr := true; + P := ShiftPointer(P, 1); + Move(P^, Arg2.Val, 4); + end + // MOV Reg16, WORD PTR [REG] + else + begin + if not AssignR32_R32(B, Arg1, Arg2) then + RaiseError(errInternalError, []); + +// $00: begin Arg1.Reg := _EAX; Arg2.Reg := _EAX; end; +// $01: begin Arg1.Reg := _EAX; Arg2.Reg := _ECX; end; + end; + + Arg2.Ptr := true; + end; + $89: // MOVE WORD PTR [Reg], Reg16 + begin + Op := ASM_MOV; + Arg1.Ptr := true; + Arg1.sz := 2; + Arg2.sz := 2; + Length := 3; + + P := ShiftPointer(P, 1); + B := Byte(P^); + + if AssignRegMovESIPtr(B, Arg2) then + // MOV WORD PTR [ESI + Shift], Reg16 + begin + Length := 7; + Arg1.Reg := _ESI; + P := ShiftPointer(P, 1); + Move(P^, Arg1.Val, 4); + end + else if AssignRegMovEBPPtr(B, Arg2) then + // MOV WORD PTR [EBP + Shift], Reg16 + begin + Length := 7; + Arg1.Reg := _EBP; + P := ShiftPointer(P, 1); + Move(P^, Arg1.Val, 4); + end + else + begin + if not AssignR32_R32(B, Arg2, Arg1) then + RaiseError(errInternalError, []); + end; + end; + end; + end; + else + begin + if not Pax64 then + RaiseError(errInternalError, []); + case B of + $41: + begin + P := ShiftPointer(P, 1); + B := Byte(P^); + + if B in [$50..$57, $58..$5F] then + begin + Length := 2; + Arg2.valid := false; + + case B of + $50: begin Op := ASM_PUSH; Arg1.Reg := _R8; end; + $51: begin Op := ASM_PUSH; Arg1.Reg := _R9; end; + $52: begin Op := ASM_PUSH; Arg1.Reg := _R10; end; + $53: begin Op := ASM_PUSH; Arg1.Reg := _R11; end; + $54: begin Op := ASM_PUSH; Arg1.Reg := _R12; end; + $55: begin Op := ASM_PUSH; Arg1.Reg := _R13; end; + $56: begin Op := ASM_PUSH; Arg1.Reg := _R14; end; + $57: begin Op := ASM_PUSH; Arg1.Reg := _R15; end; + + $58: begin Op := ASM_POP; Arg1.Reg := _R8; end; + $59: begin Op := ASM_POP; Arg1.Reg := _R9; end; + $5A: begin Op := ASM_POP; Arg1.Reg := _R10; end; + $5B: begin Op := ASM_POP; Arg1.Reg := _R11; end; + $5C: begin Op := ASM_POP; Arg1.Reg := _R12; end; + $5D: begin Op := ASM_POP; Arg1.Reg := _R13; end; + $5E: begin Op := ASM_POP; Arg1.Reg := _R14; end; + $5F: begin Op := ASM_POP; Arg1.Reg := _R15; end; + end; + end + else if B in [$B8, $B9] then + begin + Op := ASM_MOV; + Length := 6; + + case B of + $B8: Arg1.Reg := _R8; + $B9: Arg1.Reg := _R9; + else + RaiseError(errInternalError, []); + end; + P := ShiftPointer(P, 1); + Move(P^, Arg2.Val, 4); + end + else if B = $81 then + begin + P := ShiftPointer(P, 1); + B := Byte(P^); + if B in [$C0, $C1] then + begin + Op := ASM_ADD; + Length := 7; + case B of + $C0: Arg1.Reg := _R8; + $C1: Arg1.Reg := _R9; + end; + P := ShiftPointer(P, 1); + Move(P^, Arg2.Val, 4); + end + else + RaiseError(errInternalError, []); + end + else if B = $88 then + begin + P := ShiftPointer(P, 1); + B := Byte(P^); + + Op := ASM_MOV; + Length := 3; + Arg1.sz := 1; + Arg2.sz := 1; + Arg1.Ptr := true; + if not AssignR32_R64(B, Arg2, Arg1) then + RaiseError(errInternalError, []); + end + else if B = $89 then + begin + Op := ASM_MOV; + Length := 3; + P := ShiftPointer(P, 1); + B := Byte(P^); + case B of + $C0: begin Arg1.Reg := _R8; Arg2.Reg := _EAX; end; + $C8: begin Arg1.Reg := _R8; Arg2.Reg := _ECX; end; + $D0: begin Arg1.Reg := _R8; Arg2.Reg := _EDX; end; + $D8: begin Arg1.Reg := _R8; Arg2.Reg := _EBX; end; + $E0: begin Arg1.Reg := _R8; Arg2.Reg := _ESP; end; + $E8: begin Arg1.Reg := _R8; Arg2.Reg := _EBP; end; + $F0: begin Arg1.Reg := _R8; Arg2.Reg := _ESI; end; + $F8: begin Arg1.Reg := _R8; Arg2.Reg := _EDI; end; + + $C1: begin Arg1.Reg := _R9; Arg2.Reg := _EAX; end; + $C9: begin Arg1.Reg := _R9; Arg2.Reg := _ECX; end; + $D1: begin Arg1.Reg := _R9; Arg2.Reg := _EDX; end; + $D9: begin Arg1.Reg := _R9; Arg2.Reg := _EBX; end; + $E1: begin Arg1.Reg := _R9; Arg2.Reg := _ESP; end; + $E9: begin Arg1.Reg := _R9; Arg2.Reg := _EBP; end; + $F1: begin Arg1.Reg := _R9; Arg2.Reg := _ESI; end; + $F9: begin Arg1.Reg := _R9; Arg2.Reg := _EDI; end; + + else + RaiseError(errInternalError, []); + end; + end + else if B = $8A then + begin + P := ShiftPointer(P, 1); + B := Byte(P^); + + Op := ASM_MOV; + Length := 3; + Arg1.sz := 1; + Arg2.sz := 1; + Arg2.Ptr := true; + if not AssignR32_R64(B, Arg1, Arg2) then + RaiseError(errInternalError, []); + +// case B of +// $00: begin Arg1.Reg := _EAX; Arg2.Reg := _R8; end; + end + else + RaiseError(errInternalError, []); + end; + $44: + begin + P := ShiftPointer(P, 1); + B := Byte(P^); + case B of + $88: + begin + P := ShiftPointer(P, 1); + B := Byte(P^); + Arg1.sz := 1; + Arg2.sz := 1; + if AssignRegMovRBPPtr(B, Arg2) then + begin + Op := ASM_MOV; + Length := 7; + Arg1.Reg := _EBP; + Arg1.Ptr := true; + P := ShiftPointer(P, 1); + Move(P^, Arg1.Val, 4); + end + else if AssignRegMovRSIPtr(B, Arg2) then + begin + Op := ASM_MOV; + Length := 7; + Arg1.Reg := _ESI; + Arg1.Ptr := true; + P := ShiftPointer(P, 1); + Move(P^, Arg1.Val, 4); + end + else + begin + Op := ASM_MOV; + Length := 3; + Arg1.Ptr := true; + if not AssignR64_R32(B, Arg2, Arg1) then + RaiseError(errInternalError, []); + end; + end; + $8A: + begin + P := ShiftPointer(P, 1); + B := Byte(P^); + Arg1.sz := 1; + Arg2.sz := 1; + if AssignRegMovRBPPtr(B, Arg1) then + begin + Op := ASM_MOV; + Length := 7; + Arg2.Reg := _EBP; + Arg2.Ptr := true; + P := ShiftPointer(P, 1); + Move(P^, Arg2.Val, 4); + end + else if AssignRegMovRSIPtr(B, Arg1) then + begin + Op := ASM_MOV; + Length := 7; + Arg2.Reg := _ESI; + Arg2.Ptr := true; + P := ShiftPointer(P, 1); + Move(P^, Arg2.Val, 4); + end + else + begin + Op := ASM_MOV; + Length := 3; + Arg2.Ptr := true; + if not AssignR64_R32(B, Arg1, Arg2) then + RaiseError(errInternalError, []); + end; + end; + $8B: + begin + P := ShiftPointer(P, 1); + B := Byte(P^); + Arg1.sz := 4; + Arg2.sz := 4; + if AssignRegMovRBPPtr(B, Arg1) then + begin + Op := ASM_MOV; + Length := 7; + Arg2.Reg := _EBP; + Arg2.Ptr := true; + P := ShiftPointer(P, 1); + Move(P^, Arg2.Val, 4); + end + else if AssignRegMovRSIPtr(B, Arg1) then + begin + Op := ASM_MOV; + Length := 7; + Arg2.Reg := _ESI; + Arg2.Ptr := true; + P := ShiftPointer(P, 1); + Move(P^, Arg2.Val, 4); + end + else if B in [$84, $8C] then + begin + Op := ASM_MOV; + Length := 8; + + case B of + $84: Arg1.Reg := _R8; + $8C: Arg1.Reg := _R9; + else + RaiseError(errInternalError, []); + end; + P := ShiftPointer(P, 1); + B := Byte(P^); + if B <> $24 then + RaiseError(errInternalError, []); + + Arg2.Reg := _ESP; + Arg2.Ptr := true; + P := ShiftPointer(P, 1); + Move(P^, Arg2.Val, 4); + end + else + begin + Op := ASM_MOV; + Length := 3; + Arg2.Ptr := true; + if not AssignR64_R32(B, Arg1, Arg2) then + RaiseError(errInternalError, []); + +// case B of +// $00: begin Arg1.Reg := _R8; Arg2.Reg := _EAX; end; + end; + end; + $89: + begin + P := ShiftPointer(P, 1); + B := Byte(P^); + Arg1.sz := 4; + Arg2.sz := 4; + if B in [$84, $8C] then + begin + Op := ASM_MOV; + Length := 8; + + case B of + $84: Arg2.Reg := _R8; + $8C: Arg2.Reg := _R9; + else + RaiseError(errInternalError, []); + end; + + P := ShiftPointer(P, 1); + B := Byte(P^); + if B <> $24 then + RaiseError(errInternalError, []); + + Arg1.Reg := _ESP; + Arg1.Ptr := true; + P := ShiftPointer(P, 1); + Move(P^, Arg1.Val, 4); + end + else if AssignRegMovRBPPtr(B, Arg2) then + begin + Op := ASM_MOV; + Length := 7; + Arg1.Reg := _EBP; + Arg1.Ptr := true; + P := ShiftPointer(P, 1); + Move(P^, Arg1.Val, 4); + end + else if AssignRegMovRSIPtr(B, Arg2) then + begin + Op := ASM_MOV; + Length := 7; + Arg1.Reg := _ESI; + Arg1.Ptr := true; + P := ShiftPointer(P, 1); + Move(P^, Arg1.Val, 4); + end + else + begin + Op := ASM_MOV; + Length := 3; + if AssignR64_R32(B, Arg2, Arg1) then + Arg1.Ptr := true + else + RaiseError(errInternalError, []); + end; + end; + end; + end; //$41 + $45: + begin + P := ShiftPointer(P, 1); + B := Byte(P^); + case B of + $88: + begin + P := ShiftPointer(P, 1); + B := Byte(P^); + Op := ASM_MOV; + Length := 3; + Arg1.sz := 1; + Arg2.sz := 1; + Arg1.Ptr := true; + if not AssignR64_R64(B, Arg2, Arg1) then + RaiseError(errInternalError, []); + end; + $89: + begin + P := ShiftPointer(P, 1); + B := Byte(P^); + Op := ASM_MOV; + Length := 3; + Arg1.sz := 4; + Arg2.sz := 4; + Arg1.Ptr := true; + if not AssignR64_R64(B, Arg2, Arg1) then + RaiseError(errInternalError, []); + end; + $8A: + begin + P := ShiftPointer(P, 1); + B := Byte(P^); + Op := ASM_MOV; + Length := 3; + Arg1.sz := 1; + Arg2.sz := 1; + Arg2.Ptr := true; + if not AssignR64_R64(B, Arg1, Arg2) then + RaiseError(errInternalError, []); + +// case B of +// $00: begin Arg1.Reg := _R8; Arg2.Reg := _R8; end; + end; + $8B: + begin + P := ShiftPointer(P, 1); + B := Byte(P^); + Op := ASM_MOV; + Length := 3; + Arg1.sz := 4; + Arg2.sz := 4; + Arg2.Ptr := true; + if not AssignR64_R64(B, Arg1, Arg2) then + RaiseError(errInternalError, []); + +// case B of +// $00: begin Arg1.Reg := _R8; Arg2.Reg := _R8; end; + end; + else + RaiseError(errInternalError, []); + end; + end; + $48: + begin + P := ShiftPointer(P, 1); + B := Byte(P^); + case B of + $01: + begin + Op := ASM_ADD; + Length := 3; + + P := ShiftPointer(P, 1); + B := Byte(P^); + + case B of + $C0: begin Arg1.Reg := _EAX; Arg2.Reg := _EAX; end; + $C8: begin Arg1.Reg := _EAX; Arg2.Reg := _ECX; end; + $D0: begin Arg1.Reg := _EAX; Arg2.Reg := _EDX; end; + $D8: begin Arg1.Reg := _EAX; Arg2.Reg := _EBX; end; + $F0: begin Arg1.Reg := _EAX; Arg2.Reg := _ESI; end; + $F8: begin Arg1.Reg := _EAX; Arg2.Reg := _EDI; end; + + $C1: begin Arg1.Reg := _ECX; Arg2.Reg := _EAX; end; + $C9: begin Arg1.Reg := _ECX; Arg2.Reg := _ECX; end; + $D1: begin Arg1.Reg := _ECX; Arg2.Reg := _EDX; end; + $D9: begin Arg1.Reg := _ECX; Arg2.Reg := _EBX; end; + $F1: begin Arg1.Reg := _ECX; Arg2.Reg := _ESI; end; + $F9: begin Arg1.Reg := _ECX; Arg2.Reg := _EDI; end; + + $C2: begin Arg1.Reg := _EDX; Arg2.Reg := _EAX; end; + $CA: begin Arg1.Reg := _EDX; Arg2.Reg := _ECX; end; + $D2: begin Arg1.Reg := _EDX; Arg2.Reg := _EDX; end; + $DA: begin Arg1.Reg := _EDX; Arg2.Reg := _EBX; end; + $F2: begin Arg1.Reg := _EDX; Arg2.Reg := _ESI; end; + $FA: begin Arg1.Reg := _EDX; Arg2.Reg := _EDI; end; + + $C3: begin Arg1.Reg := _EBX; Arg2.Reg := _EAX; end; + $CB: begin Arg1.Reg := _EBX; Arg2.Reg := _ECX; end; + $D3: begin Arg1.Reg := _EBX; Arg2.Reg := _EDX; end; + $DB: begin Arg1.Reg := _EBX; Arg2.Reg := _EBX; end; + $F3: begin Arg1.Reg := _EBX; Arg2.Reg := _ESI; end; + $FB: begin Arg1.Reg := _EBX; Arg2.Reg := _EDI; end; + else + RaiseError(errInternalError, []); + end; + end; + $05: + begin + Op := ASM_ADD; + Length := 6; + Arg1.Reg := _EAX; + P := ShiftPointer(P, 1); + Move(P^, Arg2.val, 4); + end; + $11: + begin + Op := ASM_ADC; + Length := 3; + + P := ShiftPointer(P, 1); + B := Byte(P^); + + case B of + $C0: begin Arg1.Reg := _EAX; Arg2.Reg := _EAX; end; + $C8: begin Arg1.Reg := _EAX; Arg2.Reg := _ECX; end; + $D0: begin Arg1.Reg := _EAX; Arg2.Reg := _EDX; end; + $D8: begin Arg1.Reg := _EAX; Arg2.Reg := _EBX; end; + $F0: begin Arg1.Reg := _EAX; Arg2.Reg := _ESI; end; + $F8: begin Arg1.Reg := _EAX; Arg2.Reg := _EDI; end; + + $C1: begin Arg1.Reg := _ECX; Arg2.Reg := _EAX; end; + $C9: begin Arg1.Reg := _ECX; Arg2.Reg := _ECX; end; + $D1: begin Arg1.Reg := _ECX; Arg2.Reg := _EDX; end; + $D9: begin Arg1.Reg := _ECX; Arg2.Reg := _EBX; end; + $F1: begin Arg1.Reg := _ECX; Arg2.Reg := _ESI; end; + $F9: begin Arg1.Reg := _ECX; Arg2.Reg := _EDI; end; + + $C2: begin Arg1.Reg := _EDX; Arg2.Reg := _EAX; end; + $CA: begin Arg1.Reg := _EDX; Arg2.Reg := _ECX; end; + $D2: begin Arg1.Reg := _EDX; Arg2.Reg := _EDX; end; + $DA: begin Arg1.Reg := _EDX; Arg2.Reg := _EBX; end; + $F2: begin Arg1.Reg := _EDX; Arg2.Reg := _ESI; end; + $FA: begin Arg1.Reg := _EDX; Arg2.Reg := _EDI; end; + + $C3: begin Arg1.Reg := _EBX; Arg2.Reg := _EAX; end; + $CB: begin Arg1.Reg := _EBX; Arg2.Reg := _ECX; end; + $D3: begin Arg1.Reg := _EBX; Arg2.Reg := _EDX; end; + $DB: begin Arg1.Reg := _EBX; Arg2.Reg := _EBX; end; + $F3: begin Arg1.Reg := _EBX; Arg2.Reg := _ESI; end; + $FB: begin Arg1.Reg := _EBX; Arg2.Reg := _EDI; end; + else + RaiseError(errInternalError, []); + end; + end; + $19: + begin + Op := ASM_SBB; + Length := 3; + + P := ShiftPointer(P, 1); + B := Byte(P^); + + case B of + $C0: begin Arg1.Reg := _EAX; Arg2.Reg := _EAX; end; + $C8: begin Arg1.Reg := _EAX; Arg2.Reg := _ECX; end; + $D0: begin Arg1.Reg := _EAX; Arg2.Reg := _EDX; end; + $D8: begin Arg1.Reg := _EAX; Arg2.Reg := _EBX; end; + $F0: begin Arg1.Reg := _EAX; Arg2.Reg := _ESI; end; + $F8: begin Arg1.Reg := _EAX; Arg2.Reg := _EDI; end; + + $C1: begin Arg1.Reg := _ECX; Arg2.Reg := _EAX; end; + $C9: begin Arg1.Reg := _ECX; Arg2.Reg := _ECX; end; + $D1: begin Arg1.Reg := _ECX; Arg2.Reg := _EDX; end; + $D9: begin Arg1.Reg := _ECX; Arg2.Reg := _EBX; end; + $F1: begin Arg1.Reg := _ECX; Arg2.Reg := _ESI; end; + $F9: begin Arg1.Reg := _ECX; Arg2.Reg := _EDI; end; + + $C2: begin Arg1.Reg := _EDX; Arg2.Reg := _EAX; end; + $CA: begin Arg1.Reg := _EDX; Arg2.Reg := _ECX; end; + $D2: begin Arg1.Reg := _EDX; Arg2.Reg := _EDX; end; + $DA: begin Arg1.Reg := _EDX; Arg2.Reg := _EBX; end; + $F2: begin Arg1.Reg := _EDX; Arg2.Reg := _ESI; end; + $FA: begin Arg1.Reg := _EDX; Arg2.Reg := _EDI; end; + + $C3: begin Arg1.Reg := _EBX; Arg2.Reg := _EAX; end; + $CB: begin Arg1.Reg := _EBX; Arg2.Reg := _ECX; end; + $D3: begin Arg1.Reg := _EBX; Arg2.Reg := _EDX; end; + $DB: begin Arg1.Reg := _EBX; Arg2.Reg := _EBX; end; + $F3: begin Arg1.Reg := _EBX; Arg2.Reg := _ESI; end; + $FB: begin Arg1.Reg := _EBX; Arg2.Reg := _EDI; end; + else + RaiseError(errInternalError, []); + end; + end; + // (SUB|XOR|CMP|OR|AND) REG, REG + $29, $31, $39, $09, $21: + begin + case B of + $29: Op := ASM_SUB; + $31: Op := ASM_XOR; + $39: Op := ASM_CMP; + $09: Op := ASM_OR; + $21: Op := ASM_AND; + end; + + P := ShiftPointer(P, 1); + B := Byte(P^); + + Length := 3; + + case B of + $C0: begin Arg1.Reg := _EAX; Arg2.Reg := _EAX; end; + $C8: begin Arg1.Reg := _EAX; Arg2.Reg := _ECX; end; + $D0: begin Arg1.Reg := _EAX; Arg2.Reg := _EDX; end; + $D8: begin Arg1.Reg := _EAX; Arg2.Reg := _EBX; end; + + $C1: begin Arg1.Reg := _ECX; Arg2.Reg := _EAX; end; + $C9: begin Arg1.Reg := _ECX; Arg2.Reg := _ECX; end; + $D1: begin Arg1.Reg := _ECX; Arg2.Reg := _EDX; end; + $D9: begin Arg1.Reg := _ECX; Arg2.Reg := _EBX; end; + + $C2: begin Arg1.Reg := _EDX; Arg2.Reg := _EAX; end; + $CA: begin Arg1.Reg := _EDX; Arg2.Reg := _ECX; end; + $D2: begin Arg1.Reg := _EDX; Arg2.Reg := _EDX; end; + $DA: begin Arg1.Reg := _EDX; Arg2.Reg := _EBX; end; + + $C3: begin Arg1.Reg := _EBX; Arg2.Reg := _EAX; end; + $CB: begin Arg1.Reg := _EBX; Arg2.Reg := _ECX; end; + $D3: begin Arg1.Reg := _EBX; Arg2.Reg := _EDX; end; + $DB: begin Arg1.Reg := _EBX; Arg2.Reg := _EBX; end; + else + RaiseError(errInternalError, []); + end; + end; + $81: + begin + P := ShiftPointer(P, 1); + B := Byte(P^); + + case B of + $C0..$C7: // ADD Reg, Imm + begin + Op := ASM_ADD; + Length := 7; + case B of + $C0: Arg1.Reg := _EAX; + $C1: Arg1.Reg := _ECX; + $C2: Arg1.Reg := _EDX; + $C3: Arg1.Reg := _EBX; + $C4: Arg1.Reg := _ESP; + $C5: Arg1.Reg := _EBP; + $C6: Arg1.Reg := _ESI; + $C7: Arg1.Reg := _EDI; + end; + P := ShiftPointer(P, 1); + Move(P^, Arg2.val, 4); + end; + + $80..$86: // ADD DWORD PTR Shift[Reg], Imm + begin + Op := ASM_ADD; + Length := 11; + case B of + $80: Arg1.Reg := _EAX; + $81: Arg1.Reg := _ECX; + $82: Arg1.Reg := _EDX; + $83: Arg1.Reg := _EBX; + $84: Arg1.Reg := _ESP; + $85: Arg1.Reg := _EBP; + $86: Arg1.Reg := _ESI; + end; + Arg1.Ptr := true; + P := ShiftPointer(P, 1); + Move(P^, Arg1.val, 4); + P := ShiftPointer(P, 4); + Move(P^, Arg2.val, 4); + end; + + $F9..$FF: // CMP Reg, Imm + begin + Op := ASM_CMP; + Length := 7; + case B of + $F9: Arg1.Reg := _ECX; + $FA: Arg1.Reg := _EDX; + $FB: Arg1.Reg := _EBX; + $FC: Arg1.Reg := _ESP; + $FD: Arg1.Reg := _EBP; + $FE: Arg1.Reg := _ESI; + $FF: Arg1.Reg := _EDI; + end; + P := ShiftPointer(P, 1); + Move(P^, Arg2.val, 4); + end; + + $E8..$EF: // SUB Reg, Imm + begin + Op := ASM_SUB; + Length := 7; + case B of + $E8: Arg1.Reg := _EAX; + $E9: Arg1.Reg := _ECX; + $EA: Arg1.Reg := _EDX; + $EB: Arg1.Reg := _EBX; + $EC: Arg1.Reg := _ESP; + $ED: Arg1.Reg := _EBP; + $EE: Arg1.Reg := _ESI; + $EF: Arg1.Reg := _EDI; + end; + P := ShiftPointer(P, 1); + Move(P^, Arg2.val, 4); + end; + + $B8..$BE: // CMP DWORD PTR Shift[Reg], Imm + begin + Op := ASM_CMP; + Length := 11; + case B of + $B8: Arg1.Reg := _EAX; + $B9: Arg1.Reg := _ECX; + $BA: Arg1.Reg := _EDX; + $BB: Arg1.Reg := _EBX; + $BC: Arg1.Reg := _ESP; + $BD: Arg1.Reg := _EBP; + $BE: Arg1.Reg := _ESI; + end; + Arg1.Ptr := true; + P := ShiftPointer(P, 1); + Move(P^, Arg1.val, 4); + P := ShiftPointer(P, 4); + Move(P^, Arg2.val, 4); + end; + else + RaiseError(errInternalError, []); + end; + end; + $89: + begin + Op := ASM_MOV; + + P := ShiftPointer(P, 1); + B := Byte(P^); + + if AssignRegMovESIPtr(B, Arg2) then + begin + Length := 7; + Arg1.Ptr := true; + Arg1.Reg := _ESI; + P := ShiftPointer(P, 1); + Move(P^, Arg1.val, 4); + end + else if AssignRegMovEBPPtr(B, Arg2) then + begin + Length := 7; + Arg1.Ptr := true; + Arg1.Reg := _EBP; + P := ShiftPointer(P, 1); + Move(P^, Arg1.val, 4); + end + else if B in [$84, $8C, $94, $9C, $A4, $AC, $B4, $BC] then + begin + case B of + $84: Arg2.Reg := _EAX; + $8C: Arg2.Reg := _ECX; + $94: Arg2.Reg := _EDX; + $9C: Arg2.Reg := _EBX; + $A4: Arg2.Reg := _ESP; + $AC: Arg2.Reg := _EBP; + $B4: Arg2.Reg := _ESI; + $BC: Arg2.Reg := _EDI; + end; + + P := ShiftPointer(P, 1); + B := Byte(P^); + if B <> $24 then + RaiseError(errInternalError, []); + P := ShiftPointer(P, 1); + Move(P^, Arg1.val, 4); + Length := 8; + Arg1.Ptr := true; + Arg1.Reg := _ESP; + end + else + begin + Length := 3; + if not AssignMovR32(B, Arg1, Arg2) then + begin + Arg1.Ptr := true; + if not AssignR32_R32(B, Arg2, Arg1) then + RaiseError(errInternalError, []); + end; + end; + end; //$89 + + //GET REG, ESI or EDI or EBP + $8B: + begin + Op := ASM_MOV; + + P := ShiftPointer(P, 1); + B := Byte(P^); + + if B in [$84, $8C, $94, $9C, $A4, $AC, $B4, $BC] then + begin + case B of + $84: Arg1.Reg := _EAX; + $8C: Arg1.Reg := _ECX; + $94: Arg1.Reg := _EDX; + $9C: Arg1.Reg := _EBX; + $A4: Arg1.Reg := _ESP; + $AC: Arg1.Reg := _EBP; + $B4: Arg1.Reg := _ESI; + $BC: Arg1.Reg := _EDI; + end; + + P := ShiftPointer(P, 1); + B := Byte(P^); + if B <> $24 then + RaiseError(errInternalError, []); + P := ShiftPointer(P, 1); + Move(P^, Arg2.val, 4); + Length := 8; + Arg2.Ptr := true; + Arg2.Reg := _ESP; + end + else if AssignRegMovESIPtr(B, Arg1) then + begin + Length := 7; + Arg2.Reg := _ESI; + Arg2.Ptr := true; + P := ShiftPointer(P, 1); + Move(P^, Arg2.Val, 4); + end + else if AssignRegMovEBPPtr(B, Arg1) then + begin + Length := 7; + Arg2.Reg := _EBP; + Arg2.Ptr := true; + P := ShiftPointer(P, 1); + Move(P^, Arg2.Val, 4); + end + else if B = $B4 then + begin + Length := 8; + P := ShiftPointer(P, 1); + B := Byte(P^); + if B <> $24 then + RaiseError(errInternalError, []); + Arg1.Reg := _ESI; + Arg2.Reg := _ESP; + Arg2.Ptr := true; + P := ShiftPointer(P, 1); + Move(P^, Arg2.Val, 4); + end + else if B = $BC then + begin + Length := 8; + P := ShiftPointer(P, 1); + B := Byte(P^); + if B <> $24 then + RaiseError(errInternalError, []); + Arg1.Reg := _EDI; + Arg2.Reg := _ESP; + Arg2.Ptr := true; + P := ShiftPointer(P, 1); + Move(P^, Arg2.Val, 4); + end + else + begin + Length := 3; + Arg2.Ptr := true; + if not AssignR32_R32(B, Arg1, Arg2) then + RaiseError(errInternalError, []); + +// case B of +// $00: begin Arg1.Reg := _EAX; Arg2.Reg := _EAX; end; +// $01: begin Arg1.Reg := _EAX; Arg2.Reg := _ECX; end; + end; + end; // $8B //GET REG, ESI or EDI or EBP + + $8D: + begin + P := ShiftPointer(P, 1); + B := Byte(P^); + if B <> $A5 then + RaiseError(errInternalError, []); + P := ShiftPointer(P, 1); + + Op := ASM_LEA; + Length := 7; + Arg1.Reg := _ESP; + Arg2.Reg := _EBP; + Arg2.Ptr := true; + Move(P^, Arg2.val, 4); + end; + $C7: + begin + Arg1.sz := 8; + Arg1.Ptr := true; + + P := ShiftPointer(P, 1); + B := Byte(P^); + + case B of + $00..$06: // MOV DWORD PTR [REG], imm + begin + Op := ASM_MOV; + + case B of + $00: Arg1.Reg := _EAX; + $01: Arg1.Reg := _ECX; + $02: Arg1.Reg := _EDX; + $03: Arg1.Reg := _EBX; + $04: Arg1.Reg := _ESP; + $05: Arg1.Reg := _EBP; + $06: Arg1.Reg := _ESI; + else + RaiseError(errInternalError, []); + end; + + Length := 7; + + P := ShiftPointer(P, 1); + Move(P^, Arg2.val, 4); + end; + + $80..$86: // MOV DWORD PTR [REG + Shift], imm + begin + Op := ASM_MOV; + Length := 11; + + case B of + $80: Arg1.Reg := _EAX; + $81: Arg1.Reg := _ECX; + $82: Arg1.Reg := _EDX; + $83: Arg1.Reg := _EBX; + $84: Arg1.Reg := _ESP; + $85: Arg1.Reg := _EBP; + $86: Arg1.Reg := _ESI; + end; + + P := ShiftPointer(P, 1); + Move(P^, Arg1.val, 4); + + P := ShiftPointer(P, 4); + Move(P^, Arg2.val, 4); + end; + else + RaiseError(errInternalError, []); + end; + end; + $D3: + begin + P := ShiftPointer(P, 1); + B := Byte(P^); + + Arg2.Reg := _ECX; + Arg2.sz := 1; + Length := 3; + + case B of + $E0..$E3: // shl reg, cl + begin + Op := ASM_SHL; + case B of + $E0: Arg1.Reg := _EAX; + $E1: Arg1.Reg := _ECX; + $E2: Arg1.Reg := _EDX; + $E3: Arg1.Reg := _EBX; + end; + end; + $E8..$EB: // shr reg, cl + begin + Op := ASM_SHR; + case B of + $E8: Arg1.Reg := _EAX; + $E9: Arg1.Reg := _ECX; + $EA: Arg1.Reg := _EDX; + $EB: Arg1.Reg := _EBX; + end; + end; + else + RaiseError(errInternalError, []); + end; + end; + // Mov EAX, Imm + $B8..$BF: + begin + Op := ASM_MOV; + Length := 10; + + case B of + $B8: Arg1.Reg := _EAX; + $B9: Arg1.Reg := _ECX; + $BA: Arg1.Reg := _EDX; + $BB: Arg1.Reg := _EBX; + $BC: Arg1.Reg := _ESP; + $BD: Arg1.Reg := _EBP; + $BE: Arg1.Reg := _ESI; + $BF: Arg1.Reg := _EDI; + else + RaiseError(errInternalError, []); + end; + + P := ShiftPointer(P, 1); + Move(P^, Arg2.Val, 8); + end; + + // FILD REG PTR32 + $DB: + begin + P := ShiftPointer(P, 1); + B := Byte(P^); + + if B in [$00..$03] then + begin + Op := ASM_FILD; + Length := 3; + Arg1.Ptr := true; + Arg1.sz := 4; + + Arg2.valid := false; + case B of + $00: Arg1.Reg := _EAX; + $01: Arg1.Reg := _ECX; + $02: Arg1.Reg := _EDX; + $03: Arg1.Reg := _EBX; + end; + end + else if B in [$28..$2B] then // Fld TBYTE PTR [REG] + begin + Op := ASM_FLD; + Length := 3; + Arg1.Ptr := true; + Arg1.sz := 10; + case B of + $28: Arg1.Reg := _EAX; + $29: Arg1.Reg := _ECX; + $2A: Arg1.Reg := _EDX; + $2B: Arg1.Reg := _EBX; + end; + Arg2.valid := false; + end + else if B in [$38..$3B] then // FStp TBYTE PTR [REG] + begin + Op := ASM_FSTP; + Length := 3; + Arg1.Ptr := true; + Arg1.sz := 10; + case B of + $38: Arg1.Reg := _EAX; + $39: Arg1.Reg := _ECX; + $3A: Arg1.Reg := _EDX; + $3B: Arg1.Reg := _EBX; + end; + Arg2.valid := false; + end + else if B in [$A8..$AE] then + begin + Op := ASM_FLD; // Fld TBYTE PTR [REG + Shift] + Length := 7; + Arg1.Ptr := true; + Arg1.sz := 10; + case B of + $A8: Arg1.Reg := _EAX; + $A9: Arg1.Reg := _ECX; + $AA: Arg1.Reg := _EDX; + $AB: Arg1.Reg := _EBX; + $AD: Arg1.Reg := _EBP; + $AE: Arg1.Reg := _ESP; + end; + P := ShiftPointer(P, 1); + Move(P^, Arg1.val, 4); + + Arg2.valid := false; + end + else if B in [$B8..$BE] then + begin + Op := ASM_FSTP; // FSTP TBYTE PTR [REG + Shift] + Length := 7; + Arg1.Ptr := true; + Arg1.sz := 10; + case B of + $B8: Arg1.Reg := _EAX; + $B9: Arg1.Reg := _ECX; + $BA: Arg1.Reg := _EDX; + $BB: Arg1.Reg := _EBX; + $BD: Arg1.Reg := _EBP; + $BE: Arg1.Reg := _ESP; + end; + P := ShiftPointer(P, 1); + Move(P^, Arg1.val, 4); + + Arg2.valid := false; + end + else + RaiseError(errInternalError, []); + end; + + // FLD|FSTP REG + $DD: + begin + Length := 3; + P := ShiftPointer(P, 1); + B := Byte(P^); + + Arg1.Ptr := true; + Arg1.sz := 8; + + Arg2.valid := false; + case B of + $00: begin Op := ASM_FLD; Arg1.Reg := _EAX; end; + $01: begin Op := ASM_FLD; Arg1.Reg := _ECX; end; + $02: begin Op := ASM_FLD; Arg1.Reg := _EDX; end; + $03: begin Op := ASM_FLD; Arg1.Reg := _EBX; end; + + $18: begin Op := ASM_FSTP; Arg1.Reg := _EAX; end; + $19: begin Op := ASM_FSTP; Arg1.Reg := _ECX; end; + $1A: begin Op := ASM_FSTP; Arg1.Reg := _EDX; end; + $1B: begin Op := ASM_FSTP; Arg1.Reg := _EBX; end; + + $80: + begin + Length := 7; + Op := ASM_FLD; + Arg1.Reg := _EAX; + P := ShiftPointer(P, 1); + Move(P^, Arg1.val, 4); + end; + + $81: + begin + Length := 7; + Op := ASM_FLD; + Arg1.Reg := _ECX; + P := ShiftPointer(P, 1); + Move(P^, Arg1.val, 4); + end; + + $82: + begin + Length := 7; + Op := ASM_FLD; + Arg1.Reg := _EDX; + P := ShiftPointer(P, 1); + Move(P^, Arg1.val, 4); + end; + + $83: + begin + Length := 7; + Op := ASM_FLD; + Arg1.Reg := _EBX; + P := ShiftPointer(P, 1); + Move(P^, Arg1.val, 4); + end; + + $85: + begin + Length := 7; + Op := ASM_FLD; + Arg1.Reg := _EBP; + P := ShiftPointer(P, 1); + Move(P^, Arg1.val, 4); + end; + + $86: + begin + Length := 7; + Op := ASM_FLD; + Arg1.Reg := _ESI; + P := ShiftPointer(P, 1); + Move(P^, Arg1.val, 4); + end; + + $98: + begin + Length := 7; + Op := ASM_FSTP; + Arg1.Reg := _EAX; + P := ShiftPointer(P, 1); + Move(P^, Arg1.val, 4); + end; + + $99: + begin + Length := 7; + Op := ASM_FSTP; + Arg1.Reg := _ECX; + P := ShiftPointer(P, 1); + Move(P^, Arg1.val, 4); + end; + + $9A: + begin + Length := 7; + Op := ASM_FSTP; + Arg1.Reg := _EDX; + P := ShiftPointer(P, 1); + Move(P^, Arg1.val, 4); + end; + + $9B: + begin + Length := 7; + Op := ASM_FSTP; + Arg1.Reg := _EBX; + P := ShiftPointer(P, 1); + Move(P^, Arg1.val, 4); + end; + + $9D: + begin + Length := 7; + Op := ASM_FSTP; + Arg1.Reg := _EBP; + P := ShiftPointer(P, 1); + Move(P^, Arg1.val, 4); + end; + + $9E: + begin + Length := 7; + Op := ASM_FSTP; + Arg1.Reg := _ESI; + P := ShiftPointer(P, 1); + Move(P^, Arg1.val, 4); + end; + + else + RaiseError(errInternalError, []); + end; + end; + + $F7: + begin + P := ShiftPointer(P, 1); + B := Byte(P^); + + case B of + $E0..$E3: // mul reg + begin + Op := ASM_MUL; + Length := 3; + case B of + $E0: Arg1.Reg := _EAX; + $E1: Arg1.Reg := _ECX; + $E2: Arg1.Reg := _EDX; + $E3: Arg1.Reg := _EBX; + end; + Arg2.valid := false; + end; + $E8..$EB: // imul reg + begin + Op := ASM_IMUL; + Length := 3; + case B of + $E8: Arg1.Reg := _EAX; + $E9: Arg1.Reg := _ECX; + $EA: Arg1.Reg := _EDX; + $EB: Arg1.Reg := _EBX; + end; + Arg2.valid := false; + end; + $F0..$F3: // div reg + begin + Op := ASM_DIV; + Length := 3; + case B of + $F0: Arg1.Reg := _EAX; + $F1: Arg1.Reg := _ECX; + $F2: Arg1.Reg := _EDX; + $F3: Arg1.Reg := _EBX; + end; + Arg2.valid := false; + end; + $F8..$FB: // idiv reg + begin + Op := ASM_IDIV; + Length := 3; + case B of + $F8: Arg1.Reg := _EAX; + $F9: Arg1.Reg := _ECX; + $FA: Arg1.Reg := _EDX; + $FB: Arg1.Reg := _EBX; + end; + Arg2.valid := false; + end; + $D0..$D3: // not reg + begin + Op := ASM_NOT; + Length := 3; + case B of + $D0: Arg1.Reg := _EAX; + $D1: Arg1.Reg := _ECX; + $D2: Arg1.Reg := _EDX; + $D3: Arg1.Reg := _EBX; + end; + Arg2.valid := false; + end; + $D8..$DB: // neg reg + begin + Op := ASM_NEG; + Length := 3; + case B of + $D8: Arg1.Reg := _EAX; + $D9: Arg1.Reg := _ECX; + $DA: Arg1.Reg := _EDX; + $DB: Arg1.Reg := _EBX; + end; + Arg2.valid := false; + end; + $98..$9E: // neg dword ptr [reg] + begin + Op := ASM_NEG; + Length := 7; + case B of + $98: Arg1.Reg := _EAX; + $99: Arg1.Reg := _ECX; + $9A: Arg1.Reg := _EDX; + $9B: Arg1.Reg := _EBX; + $9C: Arg1.Reg := _ESP; + $9D: Arg1.Reg := _EBP; + $9E: Arg1.Reg := _ESI; + end; + P := ShiftPointer(P, 1); + Move(P^, Arg1.val, 4); + Arg1.Ptr := true; + Arg2.valid := false; + end; + else + RaiseError(errInternalError, []); + end; + end; + $FF: + begin + Op := ASM_CALL; + Length := 3; + P := ShiftPointer(P, 1); + B := Byte(P^); + case B of + $D0: Arg1.Reg := _EAX; + $D1: Arg1.Reg := _ECX; + $D2: Arg1.Reg := _EDX; + $D3: Arg1.Reg := _EBX; + $D4: Arg1.Reg := _ESP; + $D5: Arg1.Reg := _EBP; + $D6: Arg1.Reg := _ESI; + $D7: Arg1.Reg := _EDI; + $E0: Arg1.Reg := _R8; + $E1: Arg1.Reg := _R9; + else + RaiseError(errInternalError, []); + end; + Arg2.valid := false; + end; + end; + end; //$48 + $4C: + begin + P := ShiftPointer(P, 1); + B := Byte(P^); + case B of + $89: + begin + P := ShiftPointer(P, 1); + B := Byte(P^); + Op := ASM_MOV; + + if AssignRegMovRBPPtr(B, Arg2) then + begin + Op := ASM_MOV; + Length := 7; + Arg1.Reg := _EBP; + Arg1.Ptr := true; + P := ShiftPointer(P, 1); + Move(P^, Arg1.val, 4); + end + else if AssignRegMovRSIPtr(B, Arg2) then + begin + Op := ASM_MOV; + Length := 7; + Arg1.Reg := _ESI; + Arg1.Ptr := true; + P := ShiftPointer(P, 1); + Move(P^, Arg1.val, 4); + end + else if B in [$84, $8C, $94, $9C, $A4, $AC, $B4, $BC] then + begin + case B of + $84: Arg2.Reg := _R8; + $8C: Arg2.Reg := _R9; + $94: Arg2.Reg := _R10; + $9C: Arg2.Reg := _R11; + $A4: Arg2.Reg := _R12; + $AC: Arg2.Reg := _R13; + $B4: Arg2.Reg := _R14; + $BC: Arg2.Reg := _R15; + end; + + P := ShiftPointer(P, 1); + B := Byte(P^); + if B <> $24 then + RaiseError(errInternalError, []); + P := ShiftPointer(P, 1); + Move(P^, Arg1.val, 4); + Length := 8; + Arg1.Ptr := true; + Arg1.Reg := _ESP; + end + else + begin + Length := 3; + if not AssignMovR32_R64(B, Arg1, Arg2) then + begin + Arg1.Ptr := true; + if not AssignR64_R32(B, Arg2, Arg1) then + RaiseError(errInternalError, []); + end; + end; + end; + $8B: + begin + P := ShiftPointer(P, 1); + B := Byte(P^); + if AssignRegMovRBPPtr(B, Arg1) then + begin + Op := ASM_MOV; + Length := 7; + Arg2.Reg := _EBP; + Arg2.Ptr := true; + P := ShiftPointer(P, 1); + Move(P^, Arg2.val, 4); + end + else if AssignRegMovRSIPtr(B, Arg1) then + begin + Op := ASM_MOV; + Length := 7; + Arg2.Reg := _ESI; + Arg2.Ptr := true; + P := ShiftPointer(P, 1); + Move(P^, Arg2.val, 4); + end + else if B in [$84, $8C, $94, $9C, $A4, $AC, $B4, $BC] then + begin + Op := ASM_MOV; + case B of + $84: Arg1.Reg := _R8; + $8C: Arg1.Reg := _R9; + $94: Arg1.Reg := _R10; + $9C: Arg1.Reg := _R11; + $A4: Arg1.Reg := _R12; + $AC: Arg1.Reg := _R13; + $B4: Arg1.Reg := _R14; + $BC: Arg1.Reg := _R15; + end; + + P := ShiftPointer(P, 1); + B := Byte(P^); + if B <> $24 then + RaiseError(errInternalError, []); + P := ShiftPointer(P, 1); + Move(P^, Arg2.val, 4); + Length := 8; + Arg2.Ptr := true; + Arg2.Reg := _ESP; + end + else + begin + Op := ASM_MOV; + Length := 3; + Arg2.Ptr := true; + if not AssignR64_R32(B, Arg1, Arg2) then + RaiseError(errInternalError, []); + +// case B of +// $00: begin Arg1.Reg := _R8; Arg2.Reg := _EAX; end; + end; + end; + else + RaiseError(errInternalError, []); + end; + end; + $67: + begin + P := ShiftPointer(P, 1); + B := Byte(P^); + case B of + $41: + begin + P := ShiftPointer(P, 1); + B := Byte(P^); + case B of + $89: + begin + P := ShiftPointer(P, 1); + B := Byte(P^); + Op := ASM_MOV; + Length := 4; + Arg1.sz := 4; + Arg2.sz := 4; + if AssignR32_R64(B, Arg2, Arg1) then + Arg1.Ptr := true + else + RaiseError(errInternalError, []); + end; + $8B: + begin + P := ShiftPointer(P, 1); + B := Byte(P^); + Op := ASM_MOV; + Length := 4; + Arg1.sz := 4; + Arg2.sz := 4; + if AssignR32_R64(B, Arg1, Arg2) then + Arg2.Ptr := true + else + RaiseError(errInternalError, []); + +// case B of +// $00: begin Arg1.Reg := _EAX; Arg2.Reg := _R8; end; + end; + end; + end; + $48: + begin + P := ShiftPointer(P, 1); + B := Byte(P^); + case B of + $89: + begin + P := ShiftPointer(P, 1); + B := Byte(P^); + Op := ASM_MOV; + Length := 8; + if not AssignRegMovESIPtr(B, Arg2) then + RaiseError(errInternalError, []); + Arg1.Reg := _ESI; + Arg1.Ptr := true; + P := ShiftPointer(P, 1); + Move(P^, Arg2.val, 4); + end; + $8B: + begin + P := ShiftPointer(P, 1); + B := Byte(P^); + Op := ASM_MOV; + Length := 8; + if not AssignRegMovESIPtr(B, Arg1) then + RaiseError(errInternalError, []); + Arg2.Reg := _ESI; + Arg2.Ptr := true; + P := ShiftPointer(P, 1); + Move(P^, Arg2.val, 4); + end; + else + RaiseError(errInternalError, []); + end; + end; + $4C: + begin + P := ShiftPointer(P, 1); + B := Byte(P^); + case B of + $89: + begin + P := ShiftPointer(P, 1); + B := Byte(P^); + Op := ASM_MOV; + Length := 8; + if not AssignRegMovRSIPtr(B, Arg2) then + RaiseError(errInternalError, []); + Arg1.Reg := _ESI; + Arg1.Ptr := true; + P := ShiftPointer(P, 1); + Move(P^, Arg2.val, 4); + end; + $8B: + begin + P := ShiftPointer(P, 1); + B := Byte(P^); + Op := ASM_MOV; + Length := 8; + if not AssignRegMovRSIPtr(B, Arg1) then + RaiseError(errInternalError, []); + Arg2.Reg := _ESI; + Arg2.Ptr := true; + P := ShiftPointer(P, 1); + Move(P^, Arg2.val, 4); + end; + else + RaiseError(errInternalError, []); + end; + end; + $F2: + begin + P := ShiftPointer(P, 1); + B := Byte(P^); + if B <> $48 then + RaiseError(errInternalError, []); + P := ShiftPointer(P, 1); + B := Byte(P^); + if B <> $0F then + RaiseError(errInternalError, []); + P := ShiftPointer(P, 1); + B := Byte(P^); + if B = $10 then + begin + P := ShiftPointer(P, 1); + B := Byte(P^); + Op := ASM_MOVSD; + Length := 6; + Arg2.Ptr := true; + if not AssignXMM_RegPtr(B, Arg1, Arg2) then + RaiseError(errInternalError, []); + end + else if B = $11 then + begin + P := ShiftPointer(P, 1); + B := Byte(P^); + Op := ASM_MOVSD; + Length := 6; + Arg1.Ptr := true; + if not AssignXMM_RegPtr(B, Arg2, Arg1) then + RaiseError(errInternalError, []); + end + else + RaiseError(errInternalError, []); + // movsd + end; // $F2 + $F3: + begin + P := ShiftPointer(P, 1); + B := Byte(P^); + if B <> $0F then + RaiseError(errInternalError, []); + P := ShiftPointer(P, 1); + B := Byte(P^); + if B = $10 then + begin + P := ShiftPointer(P, 1); + B := Byte(P^); + Op := ASM_MOVSS; + Length := 5; + Arg2.Ptr := true; + Arg2.sz := 4; + if not AssignXMM_RegPtr(B, Arg1, Arg2) then + RaiseError(errInternalError, []); + end + else if B = $11 then + begin + P := ShiftPointer(P, 1); + B := Byte(P^); + Op := ASM_MOVSS; + Length := 5; + Arg1.Ptr := true; + Arg1.sz := 4; + if not AssignXMM_RegPtr(B, Arg2, Arg1) then + RaiseError(errInternalError, []); + end + else + RaiseError(errInternalError, []); + // movss + end; // $f3 + $66: + begin + P := ShiftPointer(P, 1); + B := Byte(P^); + case B of + + $50..$53: // PUSH REG16 + begin + Op := ASM_PUSH; + Length := 3; + Arg1.sz := 2; + case B of + $50: Arg1.Reg := _EAX; + $51: Arg1.Reg := _ECX; + $52: Arg1.Reg := _EDX; + $53: Arg1.Reg := _EBX; + end; + Arg2.valid := false; + end; + + $C7: // MOV WORD PTR [REG], Imm + begin + Op := ASM_MOV; + Length := 10; + Arg1.Ptr := true; + Arg1.sz := 2; + + P := ShiftPointer(P, 1); + B := Byte(P^); + case B of + $80: Arg1.Reg := _EAX; + $81: Arg1.Reg := _ECX; + $82: Arg1.Reg := _EDX; + $83: Arg1.Reg := _EBX; + $84: Arg1.Reg := _ESP; + $85: Arg1.Reg := _EBP; + $86: Arg1.Reg := _ESI; + else + RaiseError(errInternalError, []); + end; + P := ShiftPointer(P, 1); + Move(P^, Arg1.val, 4); + P := ShiftPointer(P, 4); + Move(P^, Arg2.val, 2); + end; + $81: + begin + Length := 10; + Arg1.Ptr := true; + Arg1.sz := 2; + + P := ShiftPointer(P, 1); + B := Byte(P^); + + case B of + $80..$86: // ADD WORD PTR [REG], Imm + begin + Op := ASM_ADD; + case B of + $80: Arg1.Reg := _EAX; + $81: Arg1.Reg := _ECX; + $82: Arg1.Reg := _EDX; + $83: Arg1.Reg := _EBX; + $84: Arg1.Reg := _ESP; + $85: Arg1.Reg := _EBP; + $86: Arg1.Reg := _ESI; + end; + end; + $B8..$BE: // WORD PTR [REG], Imm + begin + Op := ASM_CMP; + case B of + $B8: Arg1.Reg := _EAX; + $B9: Arg1.Reg := _ECX; + $BA: Arg1.Reg := _EDX; + $BB: Arg1.Reg := _EBX; + $BC: Arg1.Reg := _ESP; + $BD: Arg1.Reg := _EBP; + $BE: Arg1.Reg := _ESI; + end; + end; + else + RaiseError(errInternalError, []); + end; + P := ShiftPointer(P, 1); + Move(P^, Arg1.val, 4); + P := ShiftPointer(P, 4); + Move(P^, Arg2.val, 2); + end; + $8B: // MOV Reg16, WORD PTR [REG] + begin + Op := ASM_MOV; + Length := 4; + Arg1.sz := 2; + Arg2.sz := 2; + + P := ShiftPointer(P, 1); + B := Byte(P^); + if AssignRegMovESIPtr(B, Arg1) then + // MOV Reg16, WORD PTR [ESI + Shift] + begin + Length := 8; + Arg2.Reg := _ESI; + Arg2.Ptr := true; + P := ShiftPointer(P, 1); + Move(P^, Arg2.Val, 4); + end + else if AssignRegMovEBPPtr(B, Arg1) then + // MOV Reg16, WORD PTR [EBP + Shift] + begin + Length := 8; + Arg2.Reg := _EBP; + Arg2.Ptr := true; + P := ShiftPointer(P, 1); + Move(P^, Arg2.Val, 4); + end + // MOV Reg16, WORD PTR [REG] + else + begin + if AssignR32_R32(B, Arg1, Arg2) then + RaiseError(errInternalError, []); +// $00: begin Arg1.Reg := _EAX; Arg2.Reg := _EAX; end; +// $01: begin Arg1.Reg := _EAX; Arg2.Reg := _ECX; end; + end; + + Arg2.Ptr := true; + end; + + $89: // MOVE WORD PTR [Reg], Reg16 + begin + Op := ASM_MOV; + Arg1.Ptr := true; + Arg1.sz := 2; + Arg2.sz := 2; + Length := 4; + + P := ShiftPointer(P, 1); + B := Byte(P^); + + if AssignRegMovESIPtr(B, Arg2) then + // MOV WORD PTR [ESI + Shift], Reg16 + begin + Length := 7; + Arg1.Reg := _ESI; + P := ShiftPointer(P, 1); + Move(P^, Arg1.Val, 4); + end + else if AssignRegMovEBPPtr(B, Arg2) then + // MOV WORD PTR [EBP + Shift], Reg16 + begin + Length := 7; + Arg1.Reg := _EBP; + P := ShiftPointer(P, 1); + Move(P^, Arg1.Val, 4); + end + else + case B of + $00: begin Arg1.Reg := _EAX; Arg2.Reg := _EAX; end; + $08: begin Arg1.Reg := _EAX; Arg2.Reg := _ECX; end; + $10: begin Arg1.Reg := _EAX; Arg2.Reg := _EDX; end; + $18: begin Arg1.Reg := _EAX; Arg2.Reg := _EBX; end; + + $01: begin Arg1.Reg := _ECX; Arg2.Reg := _EAX; end; + $09: begin Arg1.Reg := _ECX; Arg2.Reg := _ECX; end; + $11: begin Arg1.Reg := _ECX; Arg2.Reg := _EDX; end; + $19: begin Arg1.Reg := _ECX; Arg2.Reg := _EBX; end; + + $02: begin Arg1.Reg := _EDX; Arg2.Reg := _EAX; end; + $0A: begin Arg1.Reg := _EDX; Arg2.Reg := _ECX; end; + $12: begin Arg1.Reg := _EDX; Arg2.Reg := _EDX; end; + $1A: begin Arg1.Reg := _EDX; Arg2.Reg := _EBX; end; + + $03: begin Arg1.Reg := _EBX; Arg2.Reg := _EAX; end; + $0B: begin Arg1.Reg := _EBX; Arg2.Reg := _ECX; end; + $13: begin Arg1.Reg := _EBX; Arg2.Reg := _EDX; end; + $1B: begin Arg1.Reg := _EBX; Arg2.Reg := _EBX; end; + else + RaiseError(errInternalError, []); + end; + end; + end; + end; + + $89: + begin + Op := ASM_MOV; + + P := ShiftPointer(P, 1); + B := Byte(P^); + + if AssignRegMovESIPtr(B, Arg2) then + begin + Length := 7; + Arg1.Ptr := true; + Arg1.Reg := _ESI; + P := ShiftPointer(P, 1); + Move(P^, Arg1.val, 4); + end + else if AssignRegMovEBPPtr(B, Arg2) then + begin + Length := 7; + Arg1.Ptr := true; + Arg1.Reg := _EBP; + P := ShiftPointer(P, 1); + Move(P^, Arg1.val, 4); + end + else + begin + Length := 3; + Arg1.sz := 4; + Arg2.sz := 4; + + case B of + $C0: begin Arg1.Reg := _EAX; Arg2.Reg := _EAX; end; + $C8: begin Arg1.Reg := _EAX; Arg2.Reg := _ECX; end; + $D0: begin Arg1.Reg := _EAX; Arg2.Reg := _EDX; end; + $D8: begin Arg1.Reg := _EAX; Arg2.Reg := _EBX; end; + $E0: begin Arg1.Reg := _EAX; Arg2.Reg := _ESP; end; + $E8: begin Arg1.Reg := _EAX; Arg2.Reg := _EBP; end; + $F0: begin Arg1.Reg := _EAX; Arg2.Reg := _ESI; end; + $F8: begin Arg1.Reg := _EAX; Arg2.Reg := _EDI; end; + + $C1: begin Arg1.Reg := _ECX; Arg2.Reg := _EAX; end; + $C9: begin Arg1.Reg := _ECX; Arg2.Reg := _ECX; end; + $D1: begin Arg1.Reg := _ECX; Arg2.Reg := _EDX; end; + $D9: begin Arg1.Reg := _ECX; Arg2.Reg := _EBX; end; + $E1: begin Arg1.Reg := _ECX; Arg2.Reg := _ESP; end; + $E9: begin Arg1.Reg := _ECX; Arg2.Reg := _EBP; end; + $F1: begin Arg1.Reg := _ECX; Arg2.Reg := _ESI; end; + $F9: begin Arg1.Reg := _ECX; Arg2.Reg := _EDI; end; + + $C2: begin Arg1.Reg := _EDX; Arg2.Reg := _EAX; end; + $CA: begin Arg1.Reg := _EDX; Arg2.Reg := _ECX; end; + $D2: begin Arg1.Reg := _EDX; Arg2.Reg := _EDX; end; + $DA: begin Arg1.Reg := _EDX; Arg2.Reg := _EBX; end; + $E2: begin Arg1.Reg := _EDX; Arg2.Reg := _ESP; end; + $EA: begin Arg1.Reg := _EDX; Arg2.Reg := _EBP; end; + $F2: begin Arg1.Reg := _EDX; Arg2.Reg := _ESI; end; + $FA: begin Arg1.Reg := _EDX; Arg2.Reg := _EDI; end; + + $C3: begin Arg1.Reg := _EBX; Arg2.Reg := _EAX; end; + $CB: begin Arg1.Reg := _EBX; Arg2.Reg := _ECX; end; + $D3: begin Arg1.Reg := _EBX; Arg2.Reg := _EDX; end; + $DB: begin Arg1.Reg := _EBX; Arg2.Reg := _EBX; end; + $E3: begin Arg1.Reg := _EBX; Arg2.Reg := _ESP; end; + $EB: begin Arg1.Reg := _EBX; Arg2.Reg := _EBP; end; + $F3: begin Arg1.Reg := _EBX; Arg2.Reg := _ESI; end; + $FB: begin Arg1.Reg := _EBX; Arg2.Reg := _EDI; end; + + $E5: begin Arg1.Reg := _EBP; Arg2.Reg := _ESP; end; + $EC: begin Arg1.Reg := _ESP; Arg2.Reg := _EBP; end; + + $C6: begin Arg1.Reg := _ESI; Arg2.Reg := _EAX; end; + $CE: begin Arg1.Reg := _ESI; Arg2.Reg := _ECX; end; + $D6: begin Arg1.Reg := _ESI; Arg2.Reg := _EDX; end; + $DE: begin Arg1.Reg := _ESI; Arg2.Reg := _EBX; end; + $E6: begin Arg1.Reg := _ESI; Arg2.Reg := _ESP; end; + $EE: begin Arg1.Reg := _ESI; Arg2.Reg := _EBP; end; + $F6: begin Arg1.Reg := _ESI; Arg2.Reg := _ESI; end; + $FE: begin Arg1.Reg := _ESI; Arg2.Reg := _EDI; end; + + $C7: begin Arg1.Reg := _EDI; Arg2.Reg := _EAX; end; + $CF: begin Arg1.Reg := _EDI; Arg2.Reg := _ECX; end; + $D7: begin Arg1.Reg := _EDI; Arg2.Reg := _EDX; end; + $DF: begin Arg1.Reg := _EDI; Arg2.Reg := _EBX; end; + $E7: begin Arg1.Reg := _EDI; Arg2.Reg := _ESP; end; + $EF: begin Arg1.Reg := _EDI; Arg2.Reg := _EBP; end; + $F7: begin Arg1.Reg := _EDI; Arg2.Reg := _ESI; end; + $FF: begin Arg1.Reg := _EDI; Arg2.Reg := _EDI; end; + + $00: begin Arg1.Ptr := true; Arg1.Reg := _EAX; Arg2.Reg := _EAX; end; + $08: begin Arg1.Ptr := true; Arg1.Reg := _EAX; Arg2.Reg := _ECX; end; + $10: begin Arg1.Ptr := true; Arg1.Reg := _EAX; Arg2.Reg := _EDX; end; + $18: begin Arg1.Ptr := true; Arg1.Reg := _EAX; Arg2.Reg := _EBX; end; + + $01: begin Arg1.Ptr := true; Arg1.Reg := _ECX; Arg2.Reg := _EAX; end; + $09: begin Arg1.Ptr := true; Arg1.Reg := _ECX; Arg2.Reg := _ECX; end; + $11: begin Arg1.Ptr := true; Arg1.Reg := _ECX; Arg2.Reg := _EDX; end; + $19: begin Arg1.Ptr := true; Arg1.Reg := _ECX; Arg2.Reg := _EBX; end; + + $02: begin Arg1.Ptr := true; Arg1.Reg := _EDX; Arg2.Reg := _EAX; end; + $0A: begin Arg1.Ptr := true; Arg1.Reg := _EDX; Arg2.Reg := _ECX; end; + $12: begin Arg1.Ptr := true; Arg1.Reg := _EDX; Arg2.Reg := _EDX; end; + $1A: begin Arg1.Ptr := true; Arg1.Reg := _EDX; Arg2.Reg := _EBX; end; + + $03: begin Arg1.Ptr := true; Arg1.Reg := _EBX; Arg2.Reg := _EAX; end; + $0B: begin Arg1.Ptr := true; Arg1.Reg := _EBX; Arg2.Reg := _ECX; end; + $13: begin Arg1.Ptr := true; Arg1.Reg := _EBX; Arg2.Reg := _EDX; end; + $1B: begin Arg1.Ptr := true; Arg1.Reg := _EBX; Arg2.Reg := _EBX; end; + else + RaiseError(errInternalError, []); + end; + end; + end; + end; + end; + $49: + begin + P := ShiftPointer(P, 1); + B := Byte(P^); + + case B of + $FF: + begin + P := ShiftPointer(P, 1); + B := Byte(P^); + + Length := 3; + Arg2.valid := false; + Op := ASM_JMP; + case B of + $E0: Arg1.Reg := _R8; + $E1: Arg1.Reg := _R9; + $E2: Arg1.Reg := _R10; + $E3: Arg1.Reg := _R11; + $E4: Arg1.Reg := _R12; + $E5: Arg1.Reg := _R13; + $E6: Arg1.Reg := _R14; + $E7: Arg1.Reg := _R15; + else + RaiseError(errInternalError, []); + end; + end; + $81: + begin + P := ShiftPointer(P, 1); + B := Byte(P^); + + if B in [$C0..$C7] then // ADD Reg, Imm + begin + Op := ASM_ADD; + Length := 7; + case B of + $C0: Arg1.Reg := _R8; + $C1: Arg1.Reg := _R9; + $C2: Arg1.Reg := _R10; + $C3: Arg1.Reg := _R11; + $C4: Arg1.Reg := _R12; + $C5: Arg1.Reg := _R13; + $C6: Arg1.Reg := _R14; + $C7: Arg1.Reg := _R15; + end; + P := ShiftPointer(P, 1); + Move(P^, Arg2.val, 4); + end + else + RaiseError(errInternalError, []); + end; + $8B: + begin + P := ShiftPointer(P, 1); + B := Byte(P^); + case B of + $FF: begin end; + else + begin + Length := 3; + + Arg2.Ptr := true; + + if not AssignR32_R64(B, Arg1, Arg2) then + RaiseError(errInternalError, []); + +// case B of +// $00: begin Arg1.Reg := _EAX; Arg2.Reg := _R8; end; + end; + end; + end; + $C7: + begin + Arg1.sz := 8; + Arg1.Ptr := true; + + P := ShiftPointer(P, 1); + B := Byte(P^); + + case B of + $00..$07: // MOV DWORD PTR [REG], imm + begin + Op := ASM_MOV; + + case B of + $00: Arg1.Reg := _R8; + $01: Arg1.Reg := _R9; + $02: Arg1.Reg := _R10; + $03: Arg1.Reg := _R11; + $04: Arg1.Reg := _R12; + $05: Arg1.Reg := _R13; + $06: Arg1.Reg := _R14; + $07: Arg1.Reg := _R15; + else + RaiseError(errInternalError, []); + end; + + Length := 7; + + P := ShiftPointer(P, 1); + Move(P^, Arg2.val, 4); + end; + + $80..$87: // MOV DWORD PTR [REG + Shift], imm + begin + Op := ASM_MOV; + Length := 11; + + case B of + $80: Arg1.Reg := _R8; + $81: Arg1.Reg := _R9; + $82: Arg1.Reg := _R10; + $83: Arg1.Reg := _R11; + $84: Arg1.Reg := _R12; + $85: Arg1.Reg := _R13; + $86: Arg1.Reg := _R14; + $87: Arg1.Reg := _R15; + end; + + P := ShiftPointer(P, 1); + Move(P^, Arg1.val, 4); + + P := ShiftPointer(P, 4); + Move(P^, Arg2.val, 4); + end; + else + RaiseError(errInternalError, []); + end; + end; + $B8..$BF: + begin + Op := ASM_MOV; + Length := 10; + + case B of + $B8: Arg1.Reg := _R8; + $B9: Arg1.Reg := _R9; + $BA: Arg1.Reg := _R10; + $BB: Arg1.Reg := _R11; + $BC: Arg1.Reg := _R12; + $BD: Arg1.Reg := _R13; + $BE: Arg1.Reg := _R14; + $BF: Arg1.Reg := _R15; + else + RaiseError(errInternalError, []); + end; + + P := ShiftPointer(P, 1); + Move(P^, Arg2.Val, 8); + end; + $89: + begin + P := ShiftPointer(P, 1); + B := Byte(P^); + Op := ASM_MOV; + Length := 3; + if not AssignMovR64_R32(B, Arg1, Arg2) then + begin + Arg1.Ptr := true; + if not AssignR32_R64(B, Arg2, Arg1) then + RaiseError(errInternalError, []); + end; + end + else + RaiseError(errInternalError, []); + end; + end; //$49 + $4D: + begin + P := ShiftPointer(P, 1); + B := Byte(P^); + case B of + $8B: + begin + Op := ASM_MOV; + Length := 3; + Arg2.Ptr := true; + P := ShiftPointer(P, 1); + B := Byte(P^); + if not AssignR64_R64(B, Arg1, Arg2) then + RaiseError(errInternalError, []); + +// case B of +// $00: begin Arg1.Reg := _R8; Arg2.Reg := _R8; end; + end; + $89: + begin + P := ShiftPointer(P, 1); + B := Byte(P^); + Op := ASM_MOV; + Length := 3; + if not AssignMovR64_R64(B, Arg1, Arg2) then + begin + Arg1.Ptr := true; + if not AssignR64_R64(B, Arg2, Arg1) then + RaiseError(errInternalError, []); + end; + end + else + RaiseError(errInternalError, []); + end; + end; // $4D + $F2: + begin + P := ShiftPointer(P, 1); + B := Byte(P^); + if B <> $0F then + RaiseError(errInternalError, []); + P := ShiftPointer(P, 1); + B := Byte(P^); + if B <> $5A then + RaiseError(errInternalError, []); + P := ShiftPointer(P, 1); + B := Byte(P^); + Op := ASM_CVTSD2SS; + Length := 4; + Arg2.Ptr := true; + Arg2.sz := 4; + if not AssignXMM_RegPtr(B, Arg1, Arg2) then + RaiseError(errInternalError, []); + end; + $F3: + begin + P := ShiftPointer(P, 1); + B := Byte(P^); + if B <> $0F then + RaiseError(errInternalError, []); + P := ShiftPointer(P, 1); + B := Byte(P^); + if B <> $5A then + RaiseError(errInternalError, []); + P := ShiftPointer(P, 1); + B := Byte(P^); + Op := ASM_CVTSS2SD; + Length := 4; + Arg2.Ptr := true; + Arg2.sz := 4; + if not AssignXMM_RegPtr(B, Arg1, Arg2) then + RaiseError(errInternalError, []); + end + else + RaiseError(errInternalError, []); + end; //$48 + end; + end; // case +end; + +end. + + diff --git a/Sources/PAXCOMP_EMIT.pas b/Sources/PAXCOMP_EMIT.pas new file mode 100644 index 0000000..37edd47 --- /dev/null +++ b/Sources/PAXCOMP_EMIT.pas @@ -0,0 +1,22047 @@ +// PaxCompiler +// Site: http://www.paxcompiler.com +// Author: Alexander Baranovsky (paxscript@gmail.com) +// ======================================================================== +// Copyright (c) Alexander Baranovsky, 2006-2014. All rights reserved. +// Code Version: 4.2 +// ======================================================================== +// Unit: PAXCOMP_EMIT.pas +// ======================================================================== +//////////////////////////////////////////////////////////////////////////// + +{$I PaxCompiler.def} +{$R-} +unit PAXCOMP_EMIT; +interface +uses {$I uses.def} + SysUtils, + Classes, + PAXCOMP_CONSTANTS, + PAXCOMP_TYPES, + PAXCOMP_SYS, + PAXCOMP_BYTECODE, + PAXCOMP_MODULE, + PAXCOMP_SYMBOL_REC, + PAXCOMP_VAROBJECT, + PAXCOMP_BASESYMBOL_TABLE, + PAXCOMP_SYMBOL_TABLE, + PAXCOMP_SYMBOL_PROGRAM; +type + TRegisters = class + private + PAX64: Boolean; + A: array[_NOREG.._R15] of Boolean; + public + constructor Create(aPAX64: Boolean); + function GetReg64: Integer; + function GetReg: Integer; overload; + procedure GetReg(Reg: Integer); overload; + procedure FreeReg(Reg: Integer); + end; + + TEmitProc = procedure of object; + + TEmitter = class + private + kernel: Pointer; + R: TCodeRec; + Prg: TSymbolProg; + + Registers: TRegisters; + + ContextStack: TIntegerStack; + + List1: TList; + List2: TList; + List3: TList; + + EmitOff: Boolean; + HandlesEvents: Boolean; + OverflowCheck: Boolean; + + EmitList: array of TEmitProc; + + procedure EmitSaveRBX; + procedure EmitRestoreRBX; + procedure EmitSaveRDI; + procedure EmitRestoreRDI; + function GetTargetPlatform: TTargetPlatform; + function GetSizeOfPointer: Integer; + procedure CheckSetElement(S: TSymbolRec); + procedure EmitPushParam(Reg: Integer); + procedure EmitPushParam_64(Reg: Integer); + function GetSaveRegAreaOffset: Integer; + procedure SaveRegisters(const A: array of Integer; + ExtraOffset: Integer = 0); + procedure RestoreRegisters(const A: array of Integer; + ExtraOffset: Integer = 0); + + procedure EmitStdCall(SubId: Integer; InitSize: Integer = - 1); + + procedure EmitCallPro(SubId: Integer; InitSize: Integer = -1); + procedure EmitCallEpi(SubId: Integer; InitSize: Integer = -1); + + procedure EmitStdCall_Adr1(SubId: Integer); + procedure EmitStdCall_Adr1_AdrR(SubId: Integer); + procedure EmitStdCall_Adr1_Adr2_AdrR(SubId: Integer); + procedure EmitStdCall_Lang_Adr1_Adr2_AdrR(SubId: Integer); + procedure EmitStdCall_Adr1_from_Int2(SubId: Integer); + procedure EmitStdCall_Adr1_from_Adr2(SubId: Integer); + procedure EmitStdCall_AdrR_from_Adr2(SubId: Integer); + + procedure CreateEmitProcList; + procedure EmitNotImpl; + procedure EmitNothing; + procedure EmitComment; + procedure EmitStartSub(SubId: Integer); + procedure EmitFinSub(SubId: Integer); + function GetSymbolRec(Id: Integer): TSymbolRec; + function SymbolTable: TSymbolTable; + function ByteCode: TCode; + function GetOperName: String; + procedure EmitPCodeOperator; + function Lookup(const S: String): Integer; + function GetLanguage: Integer; + + function IsLocalPos: Boolean; + + procedure EmitCheckOperResult(Reg: Integer); + + procedure Emit_PUSH_REGS(SubId: Integer = 0); + procedure Emit_POP_REGS(SubId: Integer = 0); + + procedure Emit_PUSH_REGS_EX; + procedure Emit_POP_REGS_EX; + + procedure EmitOP_SEPARATOR(I: Integer); + + procedure EmitOP_EMIT_ON; + procedure EmitOP_EMIT_OFF; + + procedure EmitOP_PUSH_PROG; // stdcall expected on win32 + + procedure EmitOP_EXPORTS; + procedure EmitOP_EXPORTS_64; + procedure EmitOP_PUSH_ADDRESS; + procedure EmitOP_PUSH_ADDRESS_64; + procedure EmitOP_PUSH_STRUCTURE; + procedure EmitOP_PUSH_STRUCTURE_64; + procedure EmitOP_PUSH_SET; + procedure EmitOP_PUSH_SET_64; + + procedure EmitOP_PUSH_INT_IMM; + procedure EmitOP_PUSH_INT_IMM_64; + procedure EmitOP_PUSH_INT; + procedure EmitOP_PUSH_INT_64; + procedure EmitOP_PUSH_INT64; + procedure EmitOP_PUSH_DOUBLE; + procedure EmitOP_PUSH_DOUBLE_64; + procedure EmitOP_PUSH_CURRENCY; + procedure EmitOP_PUSH_SINGLE; + procedure EmitOP_PUSH_SINGLE_64; + procedure EmitOP_PUSH_EXTENDED; + procedure EmitOP_PUSH_ANSISTRING; + procedure EmitOP_PUSH_ANSISTRING_64; + procedure EmitOP_PUSH_WIDESTRING; + procedure EmitOP_PUSH_WIDESTRING_64; + procedure EmitOP_PUSH_UNICSTRING; + procedure EmitOP_PUSH_UNICSTRING_64; + procedure EmitOP_PUSH_SHORTSTRING; + procedure EmitOP_PUSH_SHORTSTRING_64; +{$IFNDEF PAXARM} + procedure EmitOP_PUSH_PANSICHAR_IMM; + procedure EmitOP_PUSH_PANSICHAR_IMM_64; +{$ENDIF} + procedure EmitOP_PUSH_PWIDECHAR_IMM; + procedure EmitOP_PUSH_PWIDECHAR_IMM_64; + procedure EmitOP_PUSH_INST; + procedure EmitOP_PUSH_INST_64; + procedure EmitOP_PUSH_CLSREF; + procedure EmitOP_PUSH_CLSREF_64; + procedure EmitOP_UPDATE_INSTANCE; + procedure EmitOP_UPDATE_INSTANCE_64; + procedure EmitOP_CLEAR_EDX; + procedure EmitOP_CLEAR_EDX_64; + procedure EmitOP_PUSH_DYNARRAY; + procedure EmitOP_PUSH_DYNARRAY_64; + procedure EmitOP_PUSH_OPENARRAY; + procedure EmitOP_PUSH_OPENARRAY_64; + procedure EmitOP_PUSH_DATA; + procedure EmitOP_PUSH_DATA_64; + procedure EmitOP_PUSH_EVENT; + procedure EmitOP_PUSH_EVENT_64; + + procedure EmitOP_CALL; + procedure EmitOP_CALL_64; + procedure EmitOP_BEGIN_CALL; + procedure EmitOP_BEGIN_CALL_64; + + procedure EmitOP_CURRENCY_FROM_INT; + procedure EmitOP_CURRENCY_FROM_INT_64; + procedure EmitOP_CURRENCY_FROM_INT64; + procedure EmitOP_CURRENCY_FROM_INT64_64; + procedure EmitOP_CURRENCY_FROM_REAL; + procedure EmitOP_CURRENCY_FROM_REAL_64; + + procedure EmitOP_ASSIGN_INT_I; + procedure EmitOP_ASSIGN_INT_I_64; + procedure EmitOP_ASSIGN_INT_M; + procedure EmitOP_ASSIGN_INT_M_64; + procedure EmitOP_ASSIGN_PANSICHAR; + procedure EmitOP_ASSIGN_PANSICHAR_64; + procedure EmitOP_ASSIGN_PWIDECHAR; + procedure EmitOP_ASSIGN_PWIDECHAR_64; + procedure EmitOP_ASSIGN_DOUBLE; + procedure EmitOP_ASSIGN_DOUBLE_64; + procedure EmitOP_ASSIGN_CURRENCY; + procedure EmitOP_ASSIGN_CURRENCY_64; + procedure EmitOP_ASSIGN_EVENT; + procedure EmitOP_ASSIGN_EVENT_64; + procedure EmitOP_ASSIGN_SINGLE; + procedure EmitOP_ASSIGN_SINGLE_64; + procedure EmitOP_ASSIGN_EXTENDED; + procedure EmitOP_ASSIGN_EXTENDED_64; + procedure EmitOP_ASSIGN_INT64; + procedure EmitOP_ASSIGN_INT64_64; + procedure EmitOP_ASSIGN_RECORD; + procedure EmitOP_ASSIGN_RECORD_64; + procedure EmitOP_ASSIGN_RECORD_EX; + procedure EmitOP_ASSIGN_INTERFACE; + procedure EmitOP_ASSIGN_INTERFACE_64; + + procedure EmitOP_CREATE_EVENT; + procedure EmitOP_CREATE_EVENT_64; + + procedure EmitOP_INT_FROM_INT64; + procedure EmitOP_INT_FROM_INT64_64; + procedure EmitOP_BYTE_FROM_INT64; + procedure EmitOP_BYTE_FROM_INT64_64; + procedure EmitOP_WORD_FROM_INT64; + procedure EmitOP_WORD_FROM_INT64_64; + procedure EmitOP_CARDINAL_FROM_INT64; + procedure EmitOP_CARDINAL_FROM_INT64_64; + procedure EmitOP_SMALLINT_FROM_INT64; + procedure EmitOP_SMALLINT_FROM_INT64_64; + procedure EmitOP_SHORTINT_FROM_INT64; + procedure EmitOP_SHORTINT_FROM_INT64_64; + + procedure EmitOP_ADD_INT64; + procedure EmitOP_ADD_INT64_64; + procedure EmitOP_SUB_INT64; + procedure EmitOP_SUB_INT64_64; + procedure EmitOP_AND_INT64; + procedure EmitOP_AND_INT64_64; + procedure EmitOP_OR_INT64; + procedure EmitOP_OR_INT64_64; + procedure EmitOP_XOR_INT64; + procedure EmitOP_ABS_INT64; + procedure EmitOP_ABS_INT64_64; + + procedure EmitOP_ADD_UINT64; + procedure EmitOP_ADD_UINT64_64; + procedure EmitOP_SUB_UINT64; + procedure EmitOP_SUB_UINT64_64; + procedure EmitOP_AND_UINT64; + procedure EmitOP_AND_UINT64_64; + procedure EmitOP_OR_UINT64; + procedure EmitOP_OR_UINT64_64; + procedure EmitOP_XOR_UINT64; + + procedure EmitOP_LT_INT64; + procedure EmitOP_LT_INT64_64; + procedure EmitOP_LE_INT64; + procedure EmitOP_LE_INT64_64; + procedure EmitOP_GT_INT64; + procedure EmitOP_GT_INT64_64; + procedure EmitOP_GE_INT64; + procedure EmitOP_GE_INT64_64; + procedure EmitOP_EQ_INT64; + procedure EmitOP_EQ_INT64_64; + procedure EmitOP_NE_INT64; + procedure EmitOP_NE_INT64_64; + + procedure EmitOP_LT_UINT64; + procedure EmitOP_LT_UINT64_64; + procedure EmitOP_LE_UINT64; + procedure EmitOP_LE_UINT64_64; + procedure EmitOP_GT_UINT64; + procedure EmitOP_GT_UINT64_64; + procedure EmitOP_GE_UINT64; + procedure EmitOP_GE_UINT64_64; + + procedure EmitOP_EQ_STRUCT; + procedure EmitOP_EQ_STRUCT_64; + procedure EmitOP_NE_STRUCT; + procedure EmitOP_NE_STRUCT_64; + + procedure EmitOP_ADD_CURRENCY; + procedure EmitOP_ADD_CURRENCY_64; + procedure EmitOP_SUB_CURRENCY; + procedure EmitOP_SUB_CURRENCY_64; + procedure EmitOP_MUL_CURRENCY; + procedure EmitOP_MUL_CURRENCY_64; + procedure EmitOP_DIV_CURRENCY; + procedure EmitOP_DIV_CURRENCY_64; + + procedure EmitOP_ADD_INT_MI; + procedure EmitOP_ADD_INT_MI_64; + procedure EmitOP_ADD_INT_MM; + procedure EmitOP_ADD_INT_MM_64; + procedure EmitOP_ADD_DOUBLE; + procedure EmitOP_ADD_DOUBLE_64; + procedure EmitOP_ADD_SINGLE; + procedure EmitOP_ADD_SINGLE_64; + procedure EmitOP_ADD_EXTENDED; + procedure EmitOP_ADD_EXTENDED_64; + + procedure EmitOP_SUB_INT_MI; + procedure EmitOP_SUB_INT_MI_64; + procedure EmitOP_SUB_INT_MM; + procedure EmitOP_SUB_INT_MM_64; + procedure EmitOP_SUB_DOUBLE; + procedure EmitOP_SUB_DOUBLE_64; + procedure EmitOP_SUB_SINGLE; + procedure EmitOP_SUB_SINGLE_64; + procedure EmitOP_SUB_EXTENDED; + procedure EmitOP_SUB_EXTENDED_64; + + procedure EmitOP_NEG_INT; + procedure EmitOP_NEG_INT_64; + procedure EmitOP_NEG_INT64; + procedure EmitOP_NEG_INT64_64; + procedure EmitOP_NOT; + procedure EmitOP_NOT_64; + procedure EmitOP_NOT_BOOL; + procedure EmitOP_NOT_BOOL64; + procedure EmitOP_NOT_BYTEBOOL; + procedure EmitOP_NOT_BYTEBOOL64; + procedure EmitOP_NOT_WORDBOOL; + procedure EmitOP_NOT_WORDBOOL64; + procedure EmitOP_NOT_LONGBOOL; + procedure EmitOP_NOT_LONGBOOL64; + procedure EmitOP_NEG_DOUBLE; + procedure EmitOP_NEG_DOUBLE_64; + procedure EmitOP_NEG_CURRENCY; + procedure EmitOP_NEG_CURRENCY_64; + procedure EmitOP_NEG_SINGLE; + procedure EmitOP_NEG_SINGLE_64; + procedure EmitOP_NEG_EXTENDED; + procedure EmitOP_NEG_EXTENDED_64; + + procedure EmitOP_ABS_INT; + procedure EmitOP_ABS_INT_64; + procedure EmitOP_ABS_DOUBLE; + procedure EmitOP_ABS_DOUBLE_64; + procedure EmitOP_ABS_SINGLE; + procedure EmitOP_ABS_SINGLE_64; + procedure EmitOP_ABS_EXTENDED; + procedure EmitOP_ABS_EXTENDED_64; + procedure EmitOP_ABS_CURRENCY; + procedure EmitOP_ABS_CURRENCY_64; + + procedure EmitOP_IMUL_INT_MI; + procedure EmitOP_IMUL_INT_MI_64; + procedure EmitOP_IMUL_INT_MM; + procedure EmitOP_IMUL_INT_MM_64; + procedure EmitOP_MUL_DOUBLE; + procedure EmitOP_MUL_DOUBLE_64; + procedure EmitOP_MUL_SINGLE; + procedure EmitOP_MUL_SINGLE_64; + procedure EmitOP_MUL_EXTENDED; + procedure EmitOP_MUL_EXTENDED_64; + + procedure EmitOP_IDIV_INT_MI; + procedure EmitOP_IDIV_INT_MI_64; + procedure EmitOP_IDIV_INT_MM; + procedure EmitOP_IDIV_INT_MM_64; + procedure EmitOP_IDIV_INT_IM; + procedure EmitOP_IDIV_INT_IM_64; + procedure EmitOP_DIV_DOUBLE; + procedure EmitOP_DIV_DOUBLE_64; + procedure EmitOP_DIV_SINGLE; + procedure EmitOP_DIV_SINGLE_64; + procedure EmitOP_DIV_EXTENDED; + procedure EmitOP_DIV_EXTENDED_64; + + procedure EmitOP_MOD_INT_MI; + procedure EmitOP_MOD_INT_MI_64; + procedure EmitOP_MOD_INT_MM; + procedure EmitOP_MOD_INT_MM_64; + procedure EmitOP_MOD_INT_IM; + procedure EmitOP_MOD_INT_IM_64; + + procedure EmitOP_SHL_INT_MI; + procedure EmitOP_SHL_INT_MI_64; + procedure EmitOP_SHL_INT_MM; + procedure EmitOP_SHL_INT_MM_64; + procedure EmitOP_SHL_INT_IM; + procedure EmitOP_SHL_INT_IM_64; + + procedure EmitOP_SHR_INT_MI; + procedure EmitOP_SHR_INT_MI_64; + procedure EmitOP_SHR_INT_MM; + procedure EmitOP_SHR_INT_MM_64; + procedure EmitOP_SHR_INT_IM; + procedure EmitOP_SHR_INT_IM_64; + + procedure EmitOP_AND_INT_MI; + procedure EmitOP_AND_INT_MI_64; + procedure EmitOP_AND_INT_MM; + procedure EmitOP_AND_INT_MM_64; + procedure EmitOP_OR_INT_MI; + procedure EmitOP_OR_INT_MI_64; + procedure EmitOP_OR_INT_MM; + procedure EmitOP_OR_INT_MM_64; + procedure EmitOP_XOR_INT_MI; + procedure EmitOP_XOR_INT_MI_64; + procedure EmitOP_XOR_INT_MM; + procedure EmitOP_XOR_INT_MM_64; + + procedure EmitOP_LT_INT_MI; + procedure EmitOP_LT_INT_MI_64; + procedure EmitOP_LT_INT_MM; + procedure EmitOP_LT_INT_MM_64; + + procedure EmitOP_LE_INT_MI; + procedure EmitOP_LE_INT_MI_64; + procedure EmitOP_LE_INT_MM; + procedure EmitOP_LE_INT_MM_64; + + procedure EmitOP_GT_INT_MI; + procedure EmitOP_GT_INT_MI_64; + procedure EmitOP_GT_INT_MM; + procedure EmitOP_GT_INT_MM_64; + + procedure EmitOP_GE_INT_MI; + procedure EmitOP_GE_INT_MI_64; + procedure EmitOP_GE_INT_MM; + procedure EmitOP_GE_INT_MM_64; + + procedure EmitOP_EQ_INT_MI; + procedure EmitOP_EQ_INT_MI_64; + procedure EmitOP_EQ_INT_MM; + procedure EmitOP_EQ_INT_MM_64; + + procedure EmitOP_NE_INT_MI; + procedure EmitOP_NE_INT_MI_64; + procedure EmitOP_NE_INT_MM; + procedure EmitOP_NE_INT_MM_64; + + procedure EmitOP_LT_DOUBLE; + procedure EmitOP_LT_DOUBLE_64; + procedure EmitOP_LE_DOUBLE; + procedure EmitOP_LE_DOUBLE_64; + procedure EmitOP_GT_DOUBLE; + procedure EmitOP_GT_DOUBLE_64; + procedure EmitOP_GE_DOUBLE; + procedure EmitOP_GE_DOUBLE_64; + procedure EmitOP_EQ_DOUBLE; + procedure EmitOP_EQ_DOUBLE_64; + procedure EmitOP_NE_DOUBLE; + procedure EmitOP_NE_DOUBLE_64; + + procedure EmitOP_LT_CURRENCY; + procedure EmitOP_LT_CURRENCY_64; + procedure EmitOP_LE_CURRENCY; + procedure EmitOP_LE_CURRENCY_64; + procedure EmitOP_GT_CURRENCY; + procedure EmitOP_GT_CURRENCY_64; + procedure EmitOP_GE_CURRENCY; + procedure EmitOP_GE_CURRENCY_64; + procedure EmitOP_EQ_CURRENCY; + procedure EmitOP_EQ_CURRENCY_64; + procedure EmitOP_NE_CURRENCY; + procedure EmitOP_NE_CURRENCY_64; + + procedure EmitOP_LT_SINGLE; + procedure EmitOP_LT_SINGLE_64; + procedure EmitOP_LE_SINGLE; + procedure EmitOP_LE_SINGLE_64; + procedure EmitOP_GT_SINGLE; + procedure EmitOP_GT_SINGLE_64; + procedure EmitOP_GE_SINGLE; + procedure EmitOP_GE_SINGLE_64; + procedure EmitOP_EQ_SINGLE; + procedure EmitOP_EQ_SINGLE_64; + procedure EmitOP_NE_SINGLE; + procedure EmitOP_NE_SINGLE_64; + + procedure EmitOP_LT_EXTENDED; + procedure EmitOP_LT_EXTENDED_64; + procedure EmitOP_LE_EXTENDED; + procedure EmitOP_LE_EXTENDED_64; + procedure EmitOP_GT_EXTENDED; + procedure EmitOP_GT_EXTENDED_64; + procedure EmitOP_GE_EXTENDED; + procedure EmitOP_GE_EXTENDED_64; + procedure EmitOP_EQ_EXTENDED; + procedure EmitOP_EQ_EXTENDED_64; + procedure EmitOP_NE_EXTENDED; + procedure EmitOP_NE_EXTENDED_64; + + procedure EmitOP_INIT_SUB; + procedure EmitOP_INIT_SUB_64; + procedure EmitOP_END_SUB; + procedure EmitOP_END_SUB_64; + procedure EmitOP_FIN_SUB; + procedure EmitOP_FIN_SUB_64; + procedure EmitOP_RET; + procedure EmitOP_RET_64; + procedure EmitOP_PUSH_EBP; + procedure EmitOP_PUSH_EBP_64; + procedure EmitOP_POP; + procedure EmitOP_POP_64; + procedure EmitOP_SAVE_REGS; + procedure EmitOP_SAVE_REGS_64; + procedure EmitOP_RESTORE_REGS; + procedure EmitOP_RESTORE_REGS_64; + + procedure EmitOP_FIELD; + procedure EmitOP_FIELD_64; + procedure EmitOP_ELEM; + procedure EmitOP_ELEM_64; + procedure EmitOP_GET_COMPONENT; + procedure EmitOP_GET_COMPONENT_64; + + procedure EmitOP_PRINT_EX; + procedure EmitOP_PRINT_EX_64; + + procedure EmitOP_TO_FW_OBJECT; + procedure EmitOP_TO_FW_OBJECT_64; + + procedure EmitOP_INT_TO_INT64; + procedure EmitOP_INT_TO_INT64_64; + procedure EmitOP_BYTE_TO_INT64; + procedure EmitOP_BYTE_TO_INT64_64; + procedure EmitOP_WORD_TO_INT64; + procedure EmitOP_WORD_TO_INT64_64; + procedure EmitOP_CARDINAL_TO_INT64; + procedure EmitOP_CARDINAL_TO_INT64_64; + procedure EmitOP_SMALLINT_TO_INT64; + procedure EmitOP_SMALLINT_TO_INT64_64; + procedure EmitOP_SHORTINT_TO_INT64; + procedure EmitOP_SHORTINT_TO_INT64_64; + procedure EmitOP_INT_TO_DOUBLE; + procedure EmitOP_INT_TO_DOUBLE_64; + procedure EmitOP_INT64_TO_DOUBLE; + procedure EmitOP_INT64_TO_DOUBLE_64; + + procedure EmitOP_INT_TO_SINGLE; + procedure EmitOP_INT_TO_SINGLE_64; + procedure EmitOP_INT64_TO_SINGLE; + procedure EmitOP_INT64_TO_SINGLE_64; + + procedure EmitOP_INT_TO_EXTENDED; + procedure EmitOP_INT_TO_EXTENDED_64; + procedure EmitOP_INT64_TO_EXTENDED; + procedure EmitOP_INT64_TO_EXTENDED_64; + + procedure EmitOP_MULT_INT64; + procedure EmitOP_MULT_INT64_64; + procedure EmitOP_IDIV_INT64; + procedure EmitOP_IDIV_INT64_64; + procedure EmitOP_MOD_INT64; + procedure EmitOP_MOD_INT64_64; + procedure EmitOP_SHL_INT64_64; + procedure EmitOP_SHL_INT64; + procedure EmitOP_SHR_INT64_64; + procedure EmitOP_SHR_INT64; + + procedure EmitOP_CURRENCY_TO_EXTENDED; + procedure EmitOP_CURRENCY_TO_EXTENDED_64; + procedure EmitOP_CURRENCY_TO_SINGLE; + procedure EmitOP_CURRENCY_TO_SINGLE_64; + procedure EmitOP_DOUBLE_TO_SINGLE; + procedure EmitOP_DOUBLE_TO_SINGLE_64; + procedure EmitOP_DOUBLE_TO_EXTENDED; + procedure EmitOP_DOUBLE_TO_EXTENDED_64; + procedure EmitOP_SINGLE_TO_DOUBLE; + procedure EmitOP_SINGLE_TO_DOUBLE_64; + procedure EmitOP_CURRENCY_TO_DOUBLE; + procedure EmitOP_CURRENCY_TO_DOUBLE_64; + procedure EmitOP_SINGLE_TO_EXTENDED; + procedure EmitOP_SINGLE_TO_EXTENDED_64; + procedure EmitOP_EXTENDED_TO_DOUBLE; + procedure EmitOP_EXTENDED_TO_DOUBLE_64; + procedure EmitOP_EXTENDED_TO_SINGLE; + procedure EmitOP_EXTENDED_TO_SINGLE_64; + + procedure EmitOP_GO; + procedure EmitOP_GO_1; + procedure EmitOP_GO_2; + procedure EmitOP_GO_3; + procedure EmitOP_GO_TRUE; + procedure EmitOP_GO_TRUE_64; + procedure EmitOP_GO_FALSE; + procedure EmitOP_GO_FALSE_64; + procedure EmitOP_GO_DL; + procedure EmitOP_GO_DL_64; + + procedure EmitOP_SAVE_EDX; + procedure EmitOP_SAVE_EDX_64; + procedure EmitOP_RESTORE_EDX; + procedure EmitOP_RESTORE_EDX_64; + + procedure EmitOP_ADDRESS; + procedure EmitOP_ADDRESS_64; + procedure EmitOP_TERMINAL; + procedure EmitOP_TERMINAL_64; + procedure EmitOP_ADDRESS_PROG; + procedure EmitOP_ADDRESS_PROG_64; + procedure EmitOP_ASSIGN_PROG; + procedure EmitOP_ASSIGN_PROG_64; + + procedure EmitOP_SET_INCLUDE; + procedure EmitOP_SET_INCLUDE_64; + procedure EmitOP_SET_INCLUDE_INTERVAL; + procedure EmitOP_SET_INCLUDE_INTERVAL_64; + procedure EmitOP_SET_EXCLUDE; + procedure EmitOP_SET_EXCLUDE_64; + procedure EmitOP_SET_UNION; + procedure EmitOP_SET_UNION_64; + procedure EmitOP_SET_DIFFERENCE; + procedure EmitOP_SET_DIFFERENCE_64; + procedure EmitOP_SET_INTERSECTION; + procedure EmitOP_SET_INTERSECTION_64; + procedure EmitOP_SET_SUBSET; + procedure EmitOP_SET_SUBSET_64; + procedure EmitOP_SET_SUPERSET; + procedure EmitOP_SET_SUPERSET_64; + procedure EmitOP_SET_EQUALITY; + procedure EmitOP_SET_EQUALITY_64; + procedure EmitOP_SET_INEQUALITY; + procedure EmitOP_SET_INEQUALITY_64; + procedure EmitOP_SET_MEMBERSHIP; + procedure EmitOP_SET_MEMBERSHIP_64; + procedure EmitOP_SET_ASSIGN; + procedure EmitOP_SET_ASSIGN_64; + procedure EmitOP_SET_COUNTER_ASSIGN; + procedure EmitOP_SET_COUNTER_ASSIGN_64; + + procedure EmitOP_ERR_ABSTRACT; + procedure EmitOP_ERR_ABSTRACT_64; + + procedure EmitOP_LOAD_PROC; + procedure EmitOP_LOAD_PROC_64; + procedure EmitOP_ADD_MESSAGE; + procedure EmitOP_ADD_MESSAGE_64; + + procedure EmitOP_BEGIN_CRT_JS_FUNC_OBJECT; + procedure EmitOP_BEGIN_CRT_JS_FUNC_OBJECT_64; + procedure EmitOP_END_CRT_JS_FUNC_OBJECT; + procedure EmitOP_END_CRT_JS_FUNC_OBJECT_64; + + procedure EmitOP_TO_JS_OBJECT; + procedure EmitOP_TO_JS_OBJECT_64; + procedure EmitOP_JS_TYPEOF; + procedure EmitOP_JS_TYPEOF_64; + procedure EmitOP_JS_VOID; + procedure EmitOP_JS_VOID_64; + procedure EmitOP_GET_NEXTJSPROP; + procedure EmitOP_GET_NEXTJSPROP_64; + procedure EmitOP_CLEAR_REFERENCES; + procedure EmitOP_CLEAR_REFERENCES_64; + + procedure EmitOP_CREATE_METHOD; + procedure EmitOP_CREATE_METHOD_64; + + procedure EmitOP_VAR_FROM_TVALUE; + procedure EmitOP_VAR_FROM_TVALUE_64; + + procedure EmitOP_INIT_PCHAR_LITERAL; + procedure EmitOP_INIT_PWIDECHAR_LITERAL; + procedure EmitOP_ANSISTRING_FROM_PANSICHAR; + procedure EmitOP_ANSISTRING_FROM_PANSICHAR_64; + procedure EmitOP_ANSISTRING_FROM_PWIDECHAR; + procedure EmitOP_ANSISTRING_FROM_PWIDECHAR_64; + procedure EmitOP_ANSISTRING_FROM_ANSICHAR; + procedure EmitOP_ANSISTRING_FROM_ANSICHAR_64; + procedure EmitOP_ASSIGN_ANSISTRING; + procedure EmitOP_ASSIGN_ANSISTRING_64; +{$IFNDEF PAXARM} + procedure EmitOP_ASSIGN_SHORTSTRING; + procedure EmitOP_ASSIGN_SHORTSTRING_64; +{$ENDIF} + procedure EmitOP_ASSIGN_WIDESTRING; + procedure EmitOP_ASSIGN_WIDESTRING_64; + procedure EmitOP_ASSIGN_UNICSTRING; + procedure EmitOP_ASSIGN_UNICSTRING_64; + procedure EmitOP_ADD_ANSISTRING; + procedure EmitOP_ADD_ANSISTRING_64; + procedure EmitOP_ADD_SHORTSTRING; + procedure EmitOP_ADD_SHORTSTRING_64; + procedure EmitOP_ADD_WIDESTRING; + procedure EmitOP_ADD_WIDESTRING_64; + procedure EmitOP_ADD_UNICSTRING; + procedure EmitOP_ADD_UNICSTRING_64; + procedure EmitOP_SET_LENGTH; + procedure EmitOP_SET_LENGTH_64; + procedure EmitOP_SET_LENGTH_EX; + procedure EmitOP_SET_LENGTH_EX_64; + procedure EmitOP_ANSISTRING_CLR; + procedure EmitOP_ANSISTRING_CLR_64; + procedure EmitOP_WIDESTRING_CLR; + procedure EmitOP_WIDESTRING_CLR_64; + procedure EmitOP_UNICSTRING_CLR; + procedure EmitOP_UNICSTRING_CLR_64; + procedure EmitOP_INTERFACE_CLR; + procedure EmitOP_INTERFACE_CLR_64; + procedure EmitOP_STRUCTURE_CLR; + procedure EmitOP_STRUCTURE_CLR_64; + procedure EmitOP_CLASS_CLR; + procedure EmitOP_CLASS_CLR_64; + procedure EmitOP_STRUCTURE_ADDREF; + procedure EmitOP_STRUCTURE_ADDREF_64; + procedure EmitOP_ADDREF_64; + procedure EmitOP_ADDREF; + procedure EmitOP_DYNARRAY_CLR; + procedure EmitOP_DYNARRAY_CLR_64; + procedure EmitOP_DYNARRAY_HIGH; + procedure EmitOP_DYNARRAY_HIGH_64; + procedure EmitOP_DYNARRAY_ASSIGN; + procedure EmitOP_DYNARRAY_ASSIGN_64; + procedure EmitOP_CREATE_EMPTY_DYNARRAY; + procedure EmitOP_CREATE_EMPTY_DYNARRAY_64; + + procedure EmitOP_ASSIGN_TVarRec; + procedure EmitOP_ASSIGN_TVarRec_64; + +{$IFNDEF PAXARM} + procedure EmitOP_SHORTSTRING_FROM_PANSICHAR_LITERAL; + procedure EmitOP_SHORTSTRING_FROM_PANSICHAR_LITERAL_64; + procedure EmitOP_SHORTSTRING_FROM_PWIDECHAR_LITERAL; + procedure EmitOP_SHORTSTRING_FROM_PWIDECHAR_LITERAL_64; + procedure EmitOP_SHORTSTRING_FROM_ANSISTRING; + procedure EmitOP_SHORTSTRING_FROM_ANSISTRING_64; + procedure EmitOP_SHORTSTRING_FROM_WIDESTRING; + procedure EmitOP_SHORTSTRING_FROM_WIDESTRING_64; + procedure EmitOP_SHORTSTRING_FROM_UNICSTRING; + procedure EmitOP_SHORTSTRING_FROM_UNICSTRING_64; +{$ENDIF} + procedure EmitOP_SHORTSTRING_FROM_ANSICHAR; + procedure EmitOP_SHORTSTRING_FROM_ANSICHAR_64; + procedure EmitOP_SHORTSTRING_FROM_WIDECHAR; + procedure EmitOP_SHORTSTRING_FROM_WIDECHAR_64; + procedure EmitOP_UNICSTRING_FROM_WIDESTRING; + procedure EmitOP_UNICSTRING_FROM_WIDESTRING_64; + procedure EmitOP_ANSISTRING_FROM_SHORTSTRING; + procedure EmitOP_ANSISTRING_FROM_SHORTSTRING_64; + + procedure EmitOP_WIDESTRING_FROM_PANSICHAR_LITERAL; + procedure EmitOP_WIDESTRING_FROM_PANSICHAR_LITERAL_64; + procedure EmitOP_WIDESTRING_FROM_PWIDECHAR_LITERAL; + procedure EmitOP_WIDESTRING_FROM_PWIDECHAR_LITERAL_64; + procedure EmitOP_WIDESTRING_FROM_ANSICHAR; + procedure EmitOP_WIDESTRING_FROM_ANSICHAR_64; + procedure EmitOP_WIDESTRING_FROM_WIDECHAR; + procedure EmitOP_WIDESTRING_FROM_WIDECHAR_64; + procedure EmitOP_ANSISTRING_FROM_WIDECHAR; + procedure EmitOP_ANSISTRING_FROM_WIDECHAR_64; + procedure EmitOP_WIDESTRING_FROM_WIDECHAR_LITERAL; + procedure EmitOP_WIDESTRING_FROM_WIDECHAR_LITERAL_64; + procedure EmitOP_WIDESTRING_FROM_ANSISTRING; + procedure EmitOP_WIDESTRING_FROM_ANSISTRING_64; + procedure EmitOP_UNICSTRING_FROM_ANSISTRING; + procedure EmitOP_UNICSTRING_FROM_ANSISTRING_64; + procedure EmitOP_WIDESTRING_FROM_SHORTSTRING; + procedure EmitOP_WIDESTRING_FROM_SHORTSTRING_64; + procedure EmitOP_WIDESTRING_FROM_UNICSTRING; + procedure EmitOP_WIDESTRING_FROM_UNICSTRING_64; + procedure EmitOP_UNICSTRING_FROM_SHORTSTRING; + procedure EmitOP_UNICSTRING_FROM_SHORTSTRING_64; + procedure EmitOP_ANSISTRING_FROM_WIDESTRING; + procedure EmitOP_ANSISTRING_FROM_WIDESTRING_64; + procedure EmitOP_ANSISTRING_FROM_UNICSTRING; + procedure EmitOP_ANSISTRING_FROM_UNICSTRING_64; + + procedure EmitOP_UNICSTRING_FROM_PANSICHAR_LITERAL; + procedure EmitOP_UNICSTRING_FROM_PANSICHAR_LITERAL_64; + procedure EmitOP_UNICSTRING_FROM_PWIDECHAR_LITERAL; + procedure EmitOP_UNICSTRING_FROM_PWIDECHAR_LITERAL_64; + procedure EmitOP_UNICSTRING_FROM_ANSICHAR; + procedure EmitOP_UNICSTRING_FROM_ANSICHAR_64; + procedure EmitOP_UNICSTRING_FROM_WIDECHAR; + procedure EmitOP_UNICSTRING_FROM_WIDECHAR_64; + procedure EmitOP_UNICSTRING_FROM_WIDECHAR_LITERAL; + procedure EmitOP_UNICSTRING_FROM_WIDECHAR_LITERAL_64; + + procedure EmitOP_SHORTSTRING_HIGH; + procedure EmitOP_SHORTSTRING_HIGH_64; + + procedure EmitOP_EQ_ANSISTRING; + procedure EmitOP_EQ_ANSISTRING_64; + procedure EmitOP_NE_ANSISTRING; + procedure EmitOP_NE_ANSISTRING_64; + procedure EmitOP_EQ_SHORTSTRING; + procedure EmitOP_EQ_SHORTSTRING_64; + procedure EmitOP_NE_SHORTSTRING; + procedure EmitOP_NE_SHORTSTRING_64; + procedure EmitOP_EQ_WIDESTRING; + procedure EmitOP_EQ_WIDESTRING_64; + procedure EmitOP_EQ_UNICSTRING; + procedure EmitOP_EQ_UNICSTRING_64; + procedure EmitOP_NE_WIDESTRING; + procedure EmitOP_NE_WIDESTRING_64; + procedure EmitOP_NE_UNICSTRING; + procedure EmitOP_NE_UNICSTRING_64; + + procedure EmitOP_GT_ANSISTRING; + procedure EmitOP_GT_ANSISTRING_64; + procedure EmitOP_GE_ANSISTRING; + procedure EmitOP_GE_ANSISTRING_64; + procedure EmitOP_LT_ANSISTRING; + procedure EmitOP_LT_ANSISTRING_64; + procedure EmitOP_LE_ANSISTRING; + procedure EmitOP_LE_ANSISTRING_64; + + procedure EmitOP_GT_SHORTSTRING; + procedure EmitOP_GT_SHORTSTRING_64; + procedure EmitOP_GE_SHORTSTRING; + procedure EmitOP_GE_SHORTSTRING_64; + procedure EmitOP_LT_SHORTSTRING; + procedure EmitOP_LT_SHORTSTRING_64; + procedure EmitOP_LE_SHORTSTRING; + procedure EmitOP_LE_SHORTSTRING_64; + + procedure EmitOP_GT_WIDESTRING; + procedure EmitOP_GT_WIDESTRING_64; + procedure EmitOP_GE_WIDESTRING; + procedure EmitOP_GE_WIDESTRING_64; + procedure EmitOP_LT_WIDESTRING; + procedure EmitOP_LT_WIDESTRING_64; + procedure EmitOP_LE_WIDESTRING; + procedure EmitOP_LE_WIDESTRING_64; + + procedure EmitOP_GT_UNICSTRING; + procedure EmitOP_GT_UNICSTRING_64; + procedure EmitOP_GE_UNICSTRING; + procedure EmitOP_GE_UNICSTRING_64; + procedure EmitOP_LT_UNICSTRING; + procedure EmitOP_LT_UNICSTRING_64; + procedure EmitOP_LE_UNICSTRING; + procedure EmitOP_LE_UNICSTRING_64; + + procedure EmitOP_VARIANT_FROM_CLASS; // JS only + procedure EmitOP_VARIANT_FROM_CLASS_64; // JS only + procedure EmitOP_VARIANT_FROM_POINTER; //JS only + procedure EmitOP_VARIANT_FROM_POINTER_64; //JS only + procedure EmitOP_CLASS_FROM_VARIANT; // JS only + procedure EmitOP_CLASS_FROM_VARIANT_64; // JS only + + procedure EmitOP_INTERFACE_FROM_CLASS; + procedure EmitOP_INTERFACE_FROM_CLASS_64; + procedure EmitOP_INTERFACE_CAST; + procedure EmitOP_INTERFACE_CAST_64; + + procedure EmitOP_LOCK_VARRAY; + procedure EmitOP_LOCK_VARRAY_64; + procedure EmitOP_UNLOCK_VARRAY; + procedure EmitOP_UNLOCK_VARRAY_64; + + procedure EmitOP_VARIANT_CLR; + procedure EmitOP_VARIANT_CLR_64; + procedure EmitOP_ASSIGN_VARIANT; + procedure EmitOP_ASSIGN_VARIANT_64; + procedure EmitOP_ASSIGN_OLEVARIANT; + procedure EmitOP_ASSIGN_OLEVARIANT_64; + + procedure EmitOP_ASSIGN_CLASS; + procedure EmitOP_ASSIGN_CLASS_64; + + procedure EmitOP_VARIANT_FROM_PANSICHAR_LITERAL; + procedure EmitOP_VARIANT_FROM_PANSICHAR_LITERAL_64; + procedure EmitOP_VARIANT_FROM_PWIDECHAR_LITERAL; + procedure EmitOP_VARIANT_FROM_PWIDECHAR_LITERAL_64; + procedure EmitOP_VARIANT_FROM_ANSISTRING; + procedure EmitOP_VARIANT_FROM_ANSISTRING_64; + procedure EmitOP_VARIANT_FROM_WIDESTRING; + procedure EmitOP_VARIANT_FROM_WIDESTRING_64; + procedure EmitOP_VARIANT_FROM_UNICSTRING; + procedure EmitOP_VARIANT_FROM_UNICSTRING_64; + procedure EmitOP_VARIANT_FROM_SHORTSTRING; + procedure EmitOP_VARIANT_FROM_SHORTSTRING_64; + procedure EmitOP_VARIANT_FROM_ANSICHAR; + procedure EmitOP_VARIANT_FROM_ANSICHAR_64; + procedure EmitOP_VARIANT_FROM_WIDECHAR; + procedure EmitOP_VARIANT_FROM_WIDECHAR_64; + procedure EmitOP_VARIANT_FROM_WIDECHAR_LITERAL; + procedure EmitOP_VARIANT_FROM_WIDECHAR_LITERAL_64; + procedure EmitOP_VARIANT_FROM_INT; + procedure EmitOP_VARIANT_FROM_INT_64; + procedure EmitOP_VARIANT_FROM_INT64; + procedure EmitOP_VARIANT_FROM_INT64_64; + procedure EmitOP_VARIANT_FROM_BYTE; + procedure EmitOP_VARIANT_FROM_BYTE_64; + procedure EmitOP_VARIANT_FROM_BOOL; + procedure EmitOP_VARIANT_FROM_BOOL_64; + procedure EmitOP_VARIANT_FROM_WORD; + procedure EmitOP_VARIANT_FROM_WORD_64; + procedure EmitOP_VARIANT_FROM_CARDINAL; + procedure EmitOP_VARIANT_FROM_CARDINAL_64; + procedure EmitOP_VARIANT_FROM_SMALLINT; + procedure EmitOP_VARIANT_FROM_SMALLINT_64; + procedure EmitOP_VARIANT_FROM_SHORTINT; + procedure EmitOP_VARIANT_FROM_SHORTINT_64; + procedure EmitOP_VARIANT_FROM_DOUBLE; + procedure EmitOP_VARIANT_FROM_DOUBLE_64; + procedure EmitOP_VARIANT_FROM_CURRENCY; + procedure EmitOP_VARIANT_FROM_CURRENCY_64; + procedure EmitOP_VARIANT_FROM_SINGLE; + procedure EmitOP_VARIANT_FROM_SINGLE_64; + procedure EmitOP_VARIANT_FROM_EXTENDED; + procedure EmitOP_VARIANT_FROM_EXTENDED_64; + procedure EmitOP_VARIANT_FROM_INTERFACE; + procedure EmitOP_VARIANT_FROM_INTERFACE_64; + + procedure EmitOP_OLEVARIANT_FROM_VARIANT; + procedure EmitOP_OLEVARIANT_FROM_VARIANT_64; + procedure EmitOP_OLEVARIANT_FROM_PANSICHAR_LITERAL; + procedure EmitOP_OLEVARIANT_FROM_PANSICHAR_LITERAL_64; + procedure EmitOP_OLEVARIANT_FROM_PWIDECHAR_LITERAL; + procedure EmitOP_OLEVARIANT_FROM_PWIDECHAR_LITERAL_64; + procedure EmitOP_OLEVARIANT_FROM_ANSISTRING; + procedure EmitOP_OLEVARIANT_FROM_ANSISTRING_64; + procedure EmitOP_OLEVARIANT_FROM_WIDESTRING; + procedure EmitOP_OLEVARIANT_FROM_WIDESTRING_64; + procedure EmitOP_OLEVARIANT_FROM_UNICSTRING; + procedure EmitOP_OLEVARIANT_FROM_UNICSTRING_64; + procedure EmitOP_OLEVARIANT_FROM_SHORTSTRING; + procedure EmitOP_OLEVARIANT_FROM_SHORTSTRING_64; + procedure EmitOP_OLEVARIANT_FROM_ANSICHAR; + procedure EmitOP_OLEVARIANT_FROM_ANSICHAR_64; + procedure EmitOP_OLEVARIANT_FROM_WIDECHAR; + procedure EmitOP_OLEVARIANT_FROM_WIDECHAR_64; + procedure EmitOP_OLEVARIANT_FROM_WIDECHAR_LITERAL; + procedure EmitOP_OLEVARIANT_FROM_WIDECHAR_LITERAL_64; + procedure EmitOP_OLEVARIANT_FROM_INT; + procedure EmitOP_OLEVARIANT_FROM_INT_64; + procedure EmitOP_OLEVARIANT_FROM_INT64; + procedure EmitOP_OLEVARIANT_FROM_INT64_64; + procedure EmitOP_OLEVARIANT_FROM_BYTE; + procedure EmitOP_OLEVARIANT_FROM_BYTE_64; + procedure EmitOP_OLEVARIANT_FROM_BOOL; + procedure EmitOP_OLEVARIANT_FROM_BOOL_64; + procedure EmitOP_OLEVARIANT_FROM_WORD; + procedure EmitOP_OLEVARIANT_FROM_WORD_64; + procedure EmitOP_OLEVARIANT_FROM_CARDINAL; + procedure EmitOP_OLEVARIANT_FROM_CARDINAL_64; + procedure EmitOP_OLEVARIANT_FROM_SMALLINT; + procedure EmitOP_OLEVARIANT_FROM_SMALLINT_64; + procedure EmitOP_OLEVARIANT_FROM_SHORTINT; + procedure EmitOP_OLEVARIANT_FROM_SHORTINT_64; + procedure EmitOP_OLEVARIANT_FROM_DOUBLE; + procedure EmitOP_OLEVARIANT_FROM_DOUBLE_64; + procedure EmitOP_OLEVARIANT_FROM_CURRENCY; + procedure EmitOP_OLEVARIANT_FROM_CURRENCY_64; + procedure EmitOP_OLEVARIANT_FROM_SINGLE; + procedure EmitOP_OLEVARIANT_FROM_SINGLE_64; + procedure EmitOP_OLEVARIANT_FROM_EXTENDED; + procedure EmitOP_OLEVARIANT_FROM_EXTENDED_64; + procedure EmitOP_OLEVARIANT_FROM_INTERFACE; + procedure EmitOP_OLEVARIANT_FROM_INTERFACE_64; + + procedure EmitOP_ANSISTRING_FROM_INT; // JS only + procedure EmitOP_ANSISTRING_FROM_INT_64; // JS only + procedure EmitOP_ANSISTRING_FROM_DOUBLE; // JS only + procedure EmitOP_ANSISTRING_FROM_DOUBLE_64; // JS only + procedure EmitOP_ANSISTRING_FROM_SINGLE; // JS only + procedure EmitOP_ANSISTRING_FROM_SINGLE_64; // JS only + procedure EmitOP_ANSISTRING_FROM_EXTENDED; // JS only + procedure EmitOP_ANSISTRING_FROM_EXTENDED_64; // JS only + procedure EmitOP_ANSISTRING_FROM_BOOLEAN; // JS only + procedure EmitOP_ANSISTRING_FROM_BOOLEAN_64; // JS only + + procedure EmitOP_UNICSTRING_FROM_INT; // JS only + procedure EmitOP_UNICSTRING_FROM_INT_64; // JS only + procedure EmitOP_UNICSTRING_FROM_DOUBLE; // JS only + procedure EmitOP_UNICSTRING_FROM_DOUBLE_64; // JS only + procedure EmitOP_UNICSTRING_FROM_SINGLE; // JS only + procedure EmitOP_UNICSTRING_FROM_SINGLE_64; // JS only + procedure EmitOP_UNICSTRING_FROM_EXTENDED; // JS only + procedure EmitOP_UNICSTRING_FROM_EXTENDED_64; // JS only + procedure EmitOP_UNICSTRING_FROM_BOOLEAN; // JS only + procedure EmitOP_UNICSTRING_FROM_BOOLEAN_64; // JS only + + procedure EmitOP_JS_FUNC_OBJ_FROM_VARIANT; // JS only + procedure EmitOP_JS_FUNC_OBJ_FROM_VARIANT_64; // JS only + + procedure EmitOP_ANSICHAR_FROM_VARIANT; + procedure EmitOP_ANSICHAR_FROM_VARIANT_64; + procedure EmitOP_WIDECHAR_FROM_VARIANT; + procedure EmitOP_WIDECHAR_FROM_VARIANT_64; + procedure EmitOP_ANSISTRING_FROM_VARIANT; + procedure EmitOP_ANSISTRING_FROM_VARIANT_64; + procedure EmitOP_WIDESTRING_FROM_VARIANT; + procedure EmitOP_WIDESTRING_FROM_VARIANT_64; + procedure EmitOP_UNICSTRING_FROM_VARIANT; + procedure EmitOP_UNICSTRING_FROM_VARIANT_64; +{$IFNDEF PAXARM} + procedure EmitOP_SHORTSTRING_FROM_VARIANT; + procedure EmitOP_SHORTSTRING_FROM_VARIANT_64; +{$ENDIF} + procedure EmitOP_DOUBLE_FROM_VARIANT; + procedure EmitOP_DOUBLE_FROM_VARIANT_64; + procedure EmitOP_CURRENCY_FROM_VARIANT; + procedure EmitOP_CURRENCY_FROM_VARIANT_64; + procedure EmitOP_SINGLE_FROM_VARIANT; + procedure EmitOP_SINGLE_FROM_VARIANT_64; + procedure EmitOP_EXTENDED_FROM_VARIANT; + procedure EmitOP_EXTENDED_FROM_VARIANT_64; + procedure EmitOP_INT_FROM_VARIANT; + procedure EmitOP_INT_FROM_VARIANT_64; + procedure EmitOP_INT64_FROM_VARIANT; + procedure EmitOP_INT64_FROM_VARIANT_64; + procedure EmitOP_BYTE_FROM_VARIANT; + procedure EmitOP_BYTE_FROM_VARIANT_64; + procedure EmitOP_WORD_FROM_VARIANT; + procedure EmitOP_WORD_FROM_VARIANT_64; + procedure EmitOP_CARDINAL_FROM_VARIANT; + procedure EmitOP_CARDINAL_FROM_VARIANT_64; + procedure EmitOP_BOOL_FROM_VARIANT; + procedure EmitOP_BOOL_FROM_VARIANT_64; + procedure EmitOP_BYTEBOOL_FROM_VARIANT; + procedure EmitOP_BYTEBOOL_FROM_VARIANT_64; + procedure EmitOP_WORDBOOL_FROM_VARIANT; + procedure EmitOP_WORDBOOL_FROM_VARIANT_64; + procedure EmitOP_LONGBOOL_FROM_VARIANT; + procedure EmitOP_LONGBOOL_FROM_VARIANT_64; + procedure EmitOP_SMALLINT_FROM_VARIANT; + procedure EmitOP_SMALLINT_FROM_VARIANT_64; + procedure EmitOP_SHORTINT_FROM_VARIANT; + procedure EmitOP_SHORTINT_FROM_VARIANT_64; + + procedure EmitOP_BOOL_FROM_BYTEBOOL; + procedure EmitOP_BOOL_FROM_BYTEBOOL_64; + procedure EmitOP_BOOL_FROM_WORDBOOL; + procedure EmitOP_BOOL_FROM_WORDBOOL_64; + procedure EmitOP_BOOL_FROM_LONGBOOL; + procedure EmitOP_BOOL_FROM_LONGBOOL_64; + + procedure EmitOP_NEG_VARIANT; + procedure EmitOP_NEG_VARIANT_64; + procedure EmitOP_ABS_VARIANT; + procedure EmitOP_ABS_VARIANT_64; + procedure EmitOP_NOT_VARIANT; + procedure EmitOP_NOT_VARIANT_64; + procedure EmitOP_ADD_VARIANT; + procedure EmitOP_ADD_VARIANT_64; + procedure EmitOP_SUB_VARIANT; + procedure EmitOP_SUB_VARIANT_64; + procedure EmitOP_MULT_VARIANT; + procedure EmitOP_MULT_VARIANT_64; + procedure EmitOP_DIV_VARIANT; + procedure EmitOP_DIV_VARIANT_64; + procedure EmitOP_IDIV_VARIANT; + procedure EmitOP_IDIV_VARIANT_64; + procedure EmitOP_MOD_VARIANT; + procedure EmitOP_MOD_VARIANT_64; + procedure EmitOP_SHL_VARIANT; + procedure EmitOP_SHL_VARIANT_64; + procedure EmitOP_SHR_VARIANT; + procedure EmitOP_SHR_VARIANT_64; + procedure EmitOP_AND_VARIANT; + procedure EmitOP_AND_VARIANT_64; + procedure EmitOP_OR_VARIANT; + procedure EmitOP_OR_VARIANT_64; + procedure EmitOP_XOR_VARIANT; + procedure EmitOP_XOR_VARIANT_64; + procedure EmitOP_LT_VARIANT; + procedure EmitOP_LT_VARIANT_64; + procedure EmitOP_LE_VARIANT; + procedure EmitOP_LE_VARIANT_64; + procedure EmitOP_GT_VARIANT; + procedure EmitOP_GT_VARIANT_64; + procedure EmitOP_GE_VARIANT; + procedure EmitOP_GE_VARIANT_64; + procedure EmitOP_EQ_VARIANT; + procedure EmitOP_EQ_VARIANT_64; + procedure EmitOP_NE_VARIANT; + procedure EmitOP_NE_VARIANT_64; + + procedure EmitOP_VARARRAY_GET; + procedure EmitOP_VARARRAY_GET_64; + procedure EmitOP_VARARRAY_PUT; + procedure EmitOP_VARARRAY_PUT_64; + + procedure EmitOP_OLE_GET; + procedure EmitOP_OLE_GET_64; + procedure EmitOP_OLE_SET; + procedure EmitOP_OLE_SET_64; + procedure EmitOP_OLE_PARAM; + procedure EmitOP_OLE_PARAM_64; + + procedure EmitOP_GENERAL_GET; + procedure EmitOP_GENERAL_GET_64; + procedure EmitOP_GENERAL_PUT; + procedure EmitOP_GENERAL_PUT_64; + + procedure EmitOP_ONCREATE_HOST_OBJECT; + procedure EmitOP_ONCREATE_HOST_OBJECT_64; + procedure EmitOP_ONDESTROY_HOST_OBJECT; + procedure EmitOP_ONDESTROY_HOST_OBJECT_64; + + procedure EmitOP_BEFORE_CALL_HOST; + procedure EmitOP_AFTER_CALL_HOST; + procedure EmitOP_BEFORE_CALL_HOST_64; + procedure EmitOP_AFTER_CALL_HOST_64; + + procedure EmitOP_INIT_FWARRAY; + procedure EmitOP_INIT_FWARRAY_64; + + procedure EmitOP_ONCREATE_OBJECT; + procedure EmitOP_ONCREATE_OBJECT_64; + procedure EmitOP_ON_AFTER_OBJECT_CREATION; + procedure EmitOP_ON_AFTER_OBJECT_CREATION_64; + + procedure EmitOP_IS; + procedure EmitOP_IS_64; + procedure EmitOP_CLASSNAME; + procedure EmitOP_CLASSNAME_64; + procedure EmitOP_TYPEINFO; + procedure EmitOP_TYPEINFO_64; + + procedure EmitOP_PUSH_CONTEXT; + procedure EmitOP_PUSH_CONTEXT_64; + procedure EmitOP_POP_CONTEXT; + procedure EmitOP_POP_CONTEXT_64; + procedure EmitOP_FIND_CONTEXT; + procedure EmitOP_FIND_CONTEXT_64; + procedure EmitOP_FIND_JS_FUNC; + procedure EmitOP_FIND_JS_FUNC_64; + + procedure EmitOP_GET_PROG; + procedure EmitOP_GET_PROG_64; + + procedure EmitOP_GET_DRTTI_PROP; + procedure EmitOP_GET_DRTTI_PROP_64; + procedure EmitOP_SET_DRTTI_PROP; + procedure EmitOP_SET_DRTTI_PROP_64; + + procedure EmitOP_GET_ANSISTR_PROP; + procedure EmitOP_GET_ANSISTR_PROP_64; + procedure EmitOP_SET_ANSISTR_PROP; + procedure EmitOP_SET_ANSISTR_PROP_64; + + procedure EmitOP_GET_WIDESTR_PROP; + procedure EmitOP_GET_WIDESTR_PROP_64; + procedure EmitOP_SET_WIDESTR_PROP; + procedure EmitOP_SET_WIDESTR_PROP_64; + + procedure EmitOP_GET_UNICSTR_PROP; + procedure EmitOP_GET_UNICSTR_PROP_64; + procedure EmitOP_SET_UNICSTR_PROP; + procedure EmitOP_SET_UNICSTR_PROP_64; + + procedure EmitOP_GET_ORD_PROP; + procedure EmitOP_GET_ORD_PROP_64; + procedure EmitOP_SET_ORD_PROP; + procedure EmitOP_SET_ORD_PROP_64; + + procedure EmitOP_GET_INTERFACE_PROP; + procedure EmitOP_GET_INTERFACE_PROP_64; + procedure EmitOP_SET_INTERFACE_PROP; + procedure EmitOP_SET_INTERFACE_PROP_64; + + procedure EmitOP_GET_SET_PROP; + procedure EmitOP_GET_SET_PROP_64; + procedure EmitOP_SET_SET_PROP; + procedure EmitOP_SET_SET_PROP_64; + + procedure EmitOP_GET_FLOAT_PROP; + procedure EmitOP_GET_FLOAT_PROP_64; + procedure EmitOP_SET_FLOAT_PROP; + procedure EmitOP_SET_FLOAT_PROP_64; + + procedure EmitOP_GET_VARIANT_PROP; + procedure EmitOP_GET_VARIANT_PROP_64; + procedure EmitOP_SET_VARIANT_PROP; + procedure EmitOP_SET_VARIANT_PROP_64; + + procedure EmitOP_GET_INT64_PROP; + procedure EmitOP_GET_INT64_PROP_64; + procedure EmitOP_SET_INT64_PROP; + procedure EmitOP_SET_INT64_PROP_64; + + procedure EmitOP_GET_EVENT_PROP; + procedure EmitOP_GET_EVENT_PROP_64; + procedure EmitOP_SET_EVENT_PROP; + procedure EmitOP_SET_EVENT_PROP_64; + procedure EmitOP_SET_EVENT_PROP2; + procedure EmitOP_SET_EVENT_PROP2_64; + + procedure EmitOP_TRY_ON; + procedure EmitOP_TRY_ON_64; + procedure EmitOP_TRY_OFF; + procedure EmitOP_TRY_OFF_64; + + procedure EmitOP_EXCEPT_SEH; + procedure EmitOP_EXCEPT_SEH_64; + + procedure EmitOP_FINALLY; + procedure EmitOP_FINALLY_64; + procedure EmitOP_EXCEPT; + procedure EmitOP_EXCEPT_64; + procedure EmitOP_EXCEPT_ON; + procedure EmitOP_EXCEPT_ON_64; + procedure EmitOP_RAISE; + procedure EmitOP_RAISE_64; + procedure EmitOP_EXIT; + procedure EmitOP_EXIT_64; + procedure EmitOP_COND_RAISE; + procedure EmitOP_COND_RAISE_64; + procedure EmitOP_BEGIN_EXCEPT_BLOCK; + procedure EmitOP_BEGIN_EXCEPT_BLOCK_64; + procedure EmitOP_END_EXCEPT_BLOCK; + procedure EmitOP_END_EXCEPT_BLOCK_64; + + procedure EmitOP_OVERFLOW_CHECK; + procedure EmitOP_OVERFLOW_CHECK_64; + + procedure EmitOP_PAUSE; + procedure EmitOP_PAUSE_64; + procedure EmitOP_CHECK_PAUSE; + procedure EmitOP_CHECK_PAUSE_64; + procedure EmitOP_CHECK_PAUSE_LIGHT; + procedure EmitOP_CHECK_PAUSE_LIGHT_64; + procedure EmitOP_HALT; + procedure EmitOP_HALT_64; + + procedure EmitOP_CHECK_INIT_ONLY; + procedure EmitOP_CHECK_BODY_ONLY; + + procedure EmitOP_CREATE_OBJECT; + procedure EmitOP_CREATE_OBJECT_64; + procedure EmitOP_DESTROY_OBJECT; + procedure EmitOP_DESTROY_OBJECT_64; + procedure EmitOP_GET_VMT_ADDRESS; + procedure EmitOP_GET_VMT_ADDRESS_64; + + procedure EmitJmp; + procedure EmitOP_EQ_EVENT_64; + procedure EmitOP_NE_EVENT_64; + + procedure EmitFLD(S: TSymbolRec); + procedure EmitFSTP(S: TSymbolRec); + + procedure EmitFild(S: TSymbolRec); + procedure EmitFistp(S: TSymbolRec); + + procedure EmitFDiv_10000; + procedure EmitFMul_10000; + + procedure EmitLoadAddress(Reg: Integer; S: TSymbolRec); + + function HasTheSameAddressRegister(S1, S2: TSymbolRec): Boolean; // see next method + function EmitGetAddressRegister(S: TSymbolRec): Integer; // this method + // returns a register. + // If it returns ESI or EBP, true address = result + S.Shift !! + // otherwise, address = result + // Caller must free the register !! + + procedure EmitLoadIntVal(Reg: Integer; S: TSymbolRec); + procedure EmitSaveIntVal(Reg: Integer; S: TSymbolRec); + procedure EmitRestoreEBP(Reg: Integer; S: TSymbolRec); + procedure EmitRestoreEBP_64(Reg: Integer; S: TSymbolRec); + + procedure EmitPut_REG(Reg: Integer; S: TSymbolRec; ExtraShift: Integer = 0); + // Reg contains a 32-bit value + // S - destination + procedure EmitPut_REG_64(Reg: Integer; S: TSymbolRec; ExtraShift: Integer = 0); + // Reg contains a 32-bit value + // S - destination + + procedure EmitGet_REG(Reg: Integer; S: TSymbolRec; ExtraShift: Integer = 0); + // S - source + // Reg - destination + procedure EmitGet_REG_64(Reg: Integer; S: TSymbolRec; ExtraShift: Integer = 0); + // S - source + // Reg - destination + + procedure EmitLabel(LabelId: Integer; const LabelName: String); + + procedure RaiseError(const Message: string; params: array of Const); + procedure CreateError(const Message: string; params: array of Const); + + function Host1: Boolean; + function Host2: Boolean; + + function ByRef1: Boolean; + + function GetReg: Integer; overload; + function GetReg(Reg: Integer): integer; overload; + function GetRegEx: Integer; + function GetReg64: Integer; + + procedure FreeReg(Reg: Integer); + function ImmValue1: Cardinal; + function ImmValue2: Cardinal; + + function GetOffset(S: TSymbolRec): Integer; + + function SymbolRec1: TSymbolRec; + function SymbolRec2: TSymbolRec; + function SymbolRecR: TSymbolRec; + + procedure Emit(I: Integer); + + property OperName: String read GetOperName; + property Language: Integer read GetLanguage; + public + constructor Create(akernel: Pointer); + destructor Destroy; override; + function CreateSymbolProgram(i_kernel: Pointer): TSymbolProg; + procedure CopyContextStack(AStack: TIntegerStack); + property SizeOfPointer: Integer read GetSizeOfPointer; + property TargetPlatform: TTargetPlatform read GetTargetPlatform; + end; + +procedure EmitProgProc(akernel, aprog: Pointer; context: Pointer = nil); + +implementation + +uses + PAXCOMP_BASERUNNER, + PAXCOMP_PROG, + PAXCOMP_KERNEL, + PAXCOMP_STDLIB; + +{$IFDEF TRIAL} +var + _Counter: Integer = 3; +{$ENDIF} + +constructor TRegisters.Create(aPAX64: Boolean); +var + I, K: Integer; +begin + PAX64 := aPAX64; + if PAX64 then + K := _R15 + else + K := _EDI; + for I:=_NOREG to K do + FreeReg(I); + A[_ESI] := true; + A[_EDI] := true; + A[_ESP] := true; + A[_EBP] := true; + A[_R12] := true; + A[_R13] := true; +end; + +function TRegisters.GetReg: Integer; +var + I, K: Integer; +begin + if PAX64 then + K := _R9 + else + K := _EDI; + for I:=_EAX to K do + if A[I] then + begin + A[I] := false; + result := I; + Exit; + end; + raise Exception.Create(errInternalError); +end; + +function TRegisters.GetReg64: Integer; +var + I: Integer; +begin + for I := _R10 to _R15 do + if A[I] then + begin + A[I] := false; + result := I; + Exit; + end; + raise Exception.Create(errInternalError); +end; + +procedure TRegisters.GetReg(Reg: Integer); +begin + if A[Reg] then + A[Reg] := false + else + begin + raise Exception.Create(errInternalError); + end; +end; + +procedure TRegisters.FreeReg(Reg: Integer); +begin + A[Reg] := true; +end; + +constructor TEmitter.Create(akernel: Pointer); +begin + inherited Create; + kernel := akernel; + Registers := TRegisters.Create(TargetPlatform = tpWIN64); + ContextStack := TIntegerStack.Create; + List1 := TList.Create; + List2 := TList.Create; + List3 := TList.Create; + OverflowCheck := true; + + CreateEmitProcList; +end; + +destructor TEmitter.Destroy; +begin + FreeAndNil(Registers); + FreeAndNil(ContextStack); + FreeAndNil(List1); + FreeAndNil(List2); + FreeAndNil(List3); + inherited; +end; + +procedure TEmitter.EmitNotImpl; +begin + RaiseError(errInternalError, []); +end; + +procedure TEmitter.EmitNothing; +begin +end; + +procedure TEmitter.CreateEmitProcList; +var + I: Integer; +begin + SetLength(EmitList, - OP_DUMMY); + + for I:=0 to System.Length(EmitList) - 1 do + EmitList[I] := EmitNotImpl; + + EmitList[ - OP_EMIT_ON ] := EmitOP_EMIT_ON; + EmitList[ - OP_EMIT_OFF] := EmitOP_EMIT_OFF; + EmitList[ - OP_NOP ] := EmitNothing; + EmitList[ - OP_ADD_COMMENT ] := EmitComment; + EmitList[ - OP_BEGIN_NAMESPACE ] := EmitNothing; + EmitList[ - OP_END_NAMESPACE ] := EmitNothing; + EmitList[ - OP_GO ] := EmitOP_GO; + EmitList[ - OP_GO_1 ] := EmitOP_GO_1; + EmitList[ - OP_GO_2 ] := EmitOP_GO_2; + EmitList[ - OP_GO_3 ] := EmitOP_GO_3; + EmitList[ - OP_GO_TRUE ] := EmitOP_GO_TRUE; + EmitList[ - OP_GO_FALSE ] := EmitOP_GO_FALSE; + EmitList[ - OP_GO_DL ] := EmitOP_GO_DL; + EmitList[ - OP_SAVE_EDX ] := EmitOP_SAVE_EDX; + EmitList[ - OP_RESTORE_EDX ] := EmitOP_RESTORE_EDX; + EmitList[ - OP_ASSIGN_BYTE_I ] := EmitOP_ASSIGN_INT_I; + EmitList[ - OP_ASSIGN_BYTE_M ] := EmitOP_ASSIGN_INT_M; + EmitList[ - OP_ASSIGN_WORD_I ] := EmitOP_ASSIGN_INT_I; + EmitList[ - OP_ASSIGN_WORD_M ] := EmitOP_ASSIGN_INT_M; + EmitList[ - OP_ASSIGN_CARDINAL_I ] := EmitOP_ASSIGN_INT_I; + EmitList[ - OP_ASSIGN_CARDINAL_M ] := EmitOP_ASSIGN_INT_M; + EmitList[ - OP_ASSIGN_SMALLINT_I ] := EmitOP_ASSIGN_INT_I; + EmitList[ - OP_ASSIGN_SMALLINT_M ] := EmitOP_ASSIGN_INT_M; + EmitList[ - OP_ASSIGN_SHORTINT_I ] := EmitOP_ASSIGN_INT_I; + EmitList[ - OP_ASSIGN_SHORTINT_M ] := EmitOP_ASSIGN_INT_M; + EmitList[ - OP_ASSIGN_INT_I ] := EmitOP_ASSIGN_INT_I; + EmitList[ - OP_ASSIGN_INT_M ] := EmitOP_ASSIGN_INT_M; +{$IFNDEF PAXARM} + EmitList[ - OP_ASSIGN_PANSICHAR ] := EmitOP_ASSIGN_PANSICHAR; +{$ENDIF} + EmitList[ - OP_ASSIGN_PWIDECHAR ] := EmitOP_ASSIGN_PWIDECHAR; + EmitList[ - OP_ASSIGN_EVENT ] := EmitOP_ASSIGN_EVENT; + EmitList[ - OP_CREATE_EVENT ] := EmitOP_CREATE_EVENT; + EmitList[ - OP_ASSIGN_DOUBLE ] := EmitOP_ASSIGN_DOUBLE; + EmitList[ - OP_ASSIGN_CURRENCY ] := EmitOP_ASSIGN_CURRENCY; + EmitList[ - OP_ASSIGN_SINGLE ] := EmitOP_ASSIGN_SINGLE; + EmitList[ - OP_ASSIGN_EXTENDED ] := EmitOP_ASSIGN_EXTENDED; + EmitList[ - OP_ASSIGN_INT64 ] := EmitOP_ASSIGN_INT64; + EmitList[ - OP_ASSIGN_UINT64 ] := EmitOP_ASSIGN_INT64; + EmitList[ - OP_ASSIGN_RECORD ] := EmitOP_ASSIGN_RECORD; + EmitList[ - OP_ASSIGN_ARRAY ] := EmitOP_ASSIGN_RECORD; + EmitList[ - OP_ASSIGN_INTERFACE ] := EmitOP_ASSIGN_INTERFACE; + EmitList[ - OP_ADD_INT64 ] := EmitOP_ADD_INT64; + EmitList[ - OP_SUB_INT64 ] := EmitOP_SUB_INT64; + EmitList[ - OP_AND_INT64 ] := EmitOP_AND_INT64; + EmitList[ - OP_OR_INT64 ] := EmitOP_OR_INT64; + EmitList[ - OP_XOR_INT64 ] := EmitOP_XOR_INT64; + EmitList[ - OP_ADD_UINT64 ] := EmitOP_ADD_UINT64; + EmitList[ - OP_SUB_UINT64 ] := EmitOP_SUB_UINT64; + EmitList[ - OP_AND_UINT64 ] := EmitOP_AND_UINT64; + EmitList[ - OP_OR_UINT64 ] := EmitOP_OR_UINT64; + EmitList[ - OP_XOR_UINT64 ] := EmitOP_XOR_UINT64; + EmitList[ - OP_LT_INT64 ] := EmitOP_LT_INT64; + EmitList[ - OP_LE_INT64 ] := EmitOP_LE_INT64; + EmitList[ - OP_GT_INT64 ] := EmitOP_GT_INT64; + EmitList[ - OP_GE_INT64 ] := EmitOP_GE_INT64; + EmitList[ - OP_EQ_INT64 ] := EmitOP_EQ_INT64; + EmitList[ - OP_NE_INT64 ] := EmitOP_NE_INT64; + EmitList[ - OP_LT_UINT64 ] := EmitOP_LT_UINT64; + EmitList[ - OP_LE_UINT64 ] := EmitOP_LE_UINT64; + EmitList[ - OP_GT_UINT64 ] := EmitOP_GT_UINT64; + EmitList[ - OP_GE_UINT64 ] := EmitOP_GE_UINT64; + EmitList[ - OP_EQ_STRUCT ] := EmitOP_EQ_STRUCT; + EmitList[ - OP_NE_STRUCT ] := EmitOP_NE_STRUCT; + EmitList[ - OP_EQ_EVENT ] := EmitOP_EQ_INT64; + EmitList[ - OP_NE_EVENT ] := EmitOP_NE_INT64; + EmitList[ - OP_ADD_CURRENCY ] := EmitOP_ADD_CURRENCY; + EmitList[ - OP_SUB_CURRENCY ] := EmitOP_SUB_CURRENCY; + EmitList[ - OP_MUL_CURRENCY ] := EmitOP_MUL_CURRENCY; + EmitList[ - OP_DIV_CURRENCY ] := EmitOP_DIV_CURRENCY; + EmitList[ - OP_ADD_INT_MI ] := EmitOP_ADD_INT_MI; + EmitList[ - OP_ADD_INT_MM ] := EmitOP_ADD_INT_MM; + EmitList[ - OP_ADD_DOUBLE ] := EmitOP_ADD_DOUBLE; + EmitList[ - OP_ADD_SINGLE ] := EmitOP_ADD_SINGLE; + EmitList[ - OP_ADD_EXTENDED ] := EmitOP_ADD_EXTENDED; + EmitList[ - OP_NEG_INT ] := EmitOP_NEG_INT; + EmitList[ - OP_NEG_INT64 ] := EmitOP_NEG_INT64; + EmitList[ - OP_NEG_UINT64 ] := EmitOP_NEG_INT64; + EmitList[ - OP_NOT ] := EmitOP_NOT; + EmitList[ - OP_NOT_BOOL ] := EmitOP_NOT_BOOL; + EmitList[ - OP_NOT_BYTEBOOL ] := EmitOP_NOT_BYTEBOOL; + EmitList[ - OP_NOT_WORDBOOL ] := EmitOP_NOT_WORDBOOL; + EmitList[ - OP_NOT_LONGBOOL ] := EmitOP_NOT_LONGBOOL; + EmitList[ - OP_NEG_DOUBLE ] := EmitOP_NEG_DOUBLE; + EmitList[ - OP_NEG_CURRENCY ] := EmitOP_NEG_CURRENCY; + EmitList[ - OP_NEG_SINGLE ] := EmitOP_NEG_SINGLE; + EmitList[ - OP_NEG_EXTENDED ] := EmitOP_NEG_EXTENDED; + EmitList[ - OP_ABS_INT ] := EmitOP_ABS_INT; + EmitList[ - OP_ABS_DOUBLE ] := EmitOP_ABS_DOUBLE; + EmitList[ - OP_ABS_SINGLE ] := EmitOP_ABS_SINGLE; + EmitList[ - OP_ABS_EXTENDED ] := EmitOP_ABS_EXTENDED; + EmitList[ - OP_ABS_CURRENCY ] := EmitOP_ABS_CURRENCY; + EmitList[ - OP_SUB_INT_MI ] := EmitOP_SUB_INT_MI; + EmitList[ - OP_SUB_INT_MM ] := EmitOP_SUB_INT_MM; + EmitList[ - OP_SUB_DOUBLE ] := EmitOP_SUB_DOUBLE; + EmitList[ - OP_SUB_SINGLE ] := EmitOP_SUB_SINGLE; + EmitList[ - OP_SUB_EXTENDED ] := EmitOP_SUB_EXTENDED; + EmitList[ - OP_IMUL_INT_MI ] := EmitOP_IMUL_INT_MI; + EmitList[ - OP_IMUL_INT_MM ] := EmitOP_IMUL_INT_MM; + EmitList[ - OP_MUL_DOUBLE ] := EmitOP_MUL_DOUBLE; + EmitList[ - OP_MUL_SINGLE ] := EmitOP_MUL_SINGLE; + EmitList[ - OP_MUL_EXTENDED ] := EmitOP_MUL_EXTENDED; + EmitList[ - OP_IDIV_INT_MI ] := EmitOP_IDIV_INT_MI; + EmitList[ - OP_IDIV_INT_MM ] := EmitOP_IDIV_INT_MM; + EmitList[ - OP_IDIV_INT_IM ] := EmitOP_IDIV_INT_IM; + EmitList[ - OP_DIV_DOUBLE ] := EmitOP_DIV_DOUBLE; + EmitList[ - OP_DIV_SINGLE ] := EmitOP_DIV_SINGLE; + EmitList[ - OP_DIV_EXTENDED ] := EmitOP_DIV_EXTENDED; + EmitList[ - OP_MOD_INT_MI ] := EmitOP_MOD_INT_MI; + EmitList[ - OP_MOD_INT_MM ] := EmitOP_MOD_INT_MM; + EmitList[ - OP_MOD_INT_IM ] := EmitOP_MOD_INT_IM; + EmitList[ - OP_SHL_INT_MI ] := EmitOP_SHL_INT_MI; + EmitList[ - OP_SHL_INT_MM ] := EmitOP_SHL_INT_MM; + EmitList[ - OP_SHL_INT_IM ] := EmitOP_SHL_INT_IM; + EmitList[ - OP_SHR_INT_MI ] := EmitOP_SHR_INT_MI; + EmitList[ - OP_SHR_INT_MM ] := EmitOP_SHR_INT_MM; + EmitList[ - OP_SHR_INT_IM ] := EmitOP_SHR_INT_IM; + EmitList[ - OP_AND_INT_MI ] := EmitOP_AND_INT_MI; + EmitList[ - OP_AND_INT_MM ] := EmitOP_AND_INT_MM; + EmitList[ - OP_OR_INT_MI ] := EmitOP_OR_INT_MI; + EmitList[ - OP_OR_INT_MM ] := EmitOP_OR_INT_MM; + EmitList[ - OP_XOR_INT_MI ] := EmitOP_XOR_INT_MI; + EmitList[ - OP_XOR_INT_MM ] := EmitOP_XOR_INT_MM; + EmitList[ - OP_LT_INT_MI ] := EmitOP_LT_INT_MI; + EmitList[ - OP_LT_INT_MM ] := EmitOP_LT_INT_MM; + EmitList[ - OP_LE_INT_MI ] := EmitOP_LE_INT_MI; + EmitList[ - OP_LE_INT_MM ] := EmitOP_LE_INT_MM; + EmitList[ - OP_GT_INT_MI ] := EmitOP_GT_INT_MI; + EmitList[ - OP_GT_INT_MM ] := EmitOP_GT_INT_MM; + EmitList[ - OP_GE_INT_MI ] := EmitOP_GE_INT_MI; + EmitList[ - OP_GE_INT_MM ] := EmitOP_GE_INT_MM; + EmitList[ - OP_EQ_INT_MI ] := EmitOP_EQ_INT_MI; + EmitList[ - OP_EQ_INT_MM ] := EmitOP_EQ_INT_MM; + EmitList[ - OP_NE_INT_MI ] := EmitOP_NE_INT_MI; + EmitList[ - OP_NE_INT_MM ] := EmitOP_NE_INT_MM; + EmitList[ - OP_LT_DOUBLE ] := EmitOP_LT_DOUBLE; + EmitList[ - OP_LE_DOUBLE ] := EmitOP_LE_DOUBLE; + EmitList[ - OP_GT_DOUBLE ] := EmitOP_GT_DOUBLE; + EmitList[ - OP_GE_DOUBLE ] := EmitOP_GE_DOUBLE; + EmitList[ - OP_EQ_DOUBLE ] := EmitOP_EQ_DOUBLE; + EmitList[ - OP_NE_DOUBLE ] := EmitOP_NE_DOUBLE; + EmitList[ - OP_LT_CURRENCY ] := EmitOP_LT_CURRENCY; + EmitList[ - OP_LE_CURRENCY ] := EmitOP_LE_CURRENCY; + EmitList[ - OP_GT_CURRENCY ] := EmitOP_GT_CURRENCY; + EmitList[ - OP_GE_CURRENCY ] := EmitOP_GE_CURRENCY; + EmitList[ - OP_EQ_CURRENCY ] := EmitOP_EQ_CURRENCY; + EmitList[ - OP_NE_CURRENCY ] := EmitOP_NE_CURRENCY; + EmitList[ - OP_LT_SINGLE ] := EmitOP_LT_SINGLE; + EmitList[ - OP_LE_SINGLE ] := EmitOP_LE_SINGLE; + EmitList[ - OP_GT_SINGLE ] := EmitOP_GT_SINGLE; + EmitList[ - OP_GE_SINGLE ] := EmitOP_GE_SINGLE; + EmitList[ - OP_EQ_SINGLE ] := EmitOP_EQ_SINGLE; + EmitList[ - OP_NE_SINGLE ] := EmitOP_NE_SINGLE; + EmitList[ - OP_LT_EXTENDED ] := EmitOP_LT_EXTENDED; + EmitList[ - OP_LE_EXTENDED ] := EmitOP_LE_EXTENDED; + EmitList[ - OP_GT_EXTENDED ] := EmitOP_GT_EXTENDED; + EmitList[ - OP_GE_EXTENDED ] := EmitOP_GE_EXTENDED; + EmitList[ - OP_EQ_EXTENDED ] := EmitOP_EQ_EXTENDED; + EmitList[ - OP_NE_EXTENDED ] := EmitOP_NE_EXTENDED; + EmitList[ - OP_EXPORTS ] := EmitOP_EXPORTS; + EmitList[ - OP_PUSH_PROG ] := EmitOP_PUSH_PROG; + EmitList[ - OP_PUSH_ADDRESS ] := EmitOP_PUSH_ADDRESS; + EmitList[ - OP_PUSH_STRUCTURE ] := EmitOP_PUSH_STRUCTURE; + EmitList[ - OP_PUSH_SET ] := EmitOP_PUSH_SET; + EmitList[ - OP_PUSH_BYTE_IMM ] := EmitOP_PUSH_INT_IMM; + EmitList[ - OP_PUSH_BYTE ] := EmitOP_PUSH_INT; + EmitList[ - OP_PUSH_WORD_IMM ] := EmitOP_PUSH_INT_IMM; + EmitList[ - OP_PUSH_WORD ] := EmitOP_PUSH_INT; + EmitList[ - OP_PUSH_CARDINAL_IMM ] := EmitOP_PUSH_INT_IMM; + EmitList[ - OP_PUSH_CARDINAL ] := EmitOP_PUSH_INT; + EmitList[ - OP_PUSH_SMALLINT_IMM ] := EmitOP_PUSH_INT_IMM; + EmitList[ - OP_PUSH_SMALLINT ] := EmitOP_PUSH_INT; + EmitList[ - OP_PUSH_SHORTINT_IMM ] := EmitOP_PUSH_INT_IMM; + EmitList[ - OP_PUSH_SHORTINT ] := EmitOP_PUSH_INT; + EmitList[ - OP_PUSH_INT_IMM ] := EmitOP_PUSH_INT_IMM; + EmitList[ - OP_PUSH_INT ] := EmitOP_PUSH_INT; + EmitList[ - OP_PUSH_PTR ] := EmitOP_PUSH_INT; + EmitList[ - OP_PUSH_INST ] := EmitOP_PUSH_INST; + EmitList[ - OP_PUSH_CLSREF ] := EmitOP_PUSH_CLSREF; + EmitList[ - OP_UPDATE_INSTANCE ] := EmitOP_UPDATE_INSTANCE; + EmitList[ - OP_CLEAR_EDX ] := EmitOP_CLEAR_EDX; + EmitList[ - OP_PUSH_DYNARRAY ] := EmitOP_PUSH_DYNARRAY; + EmitList[ - OP_PUSH_OPENARRAY ] := EmitOP_PUSH_OPENARRAY; + EmitList[ - OP_PUSH_DATA ] := EmitOP_PUSH_DATA; + EmitList[ - OP_PUSH_EVENT ] := EmitOP_PUSH_EVENT; + EmitList[ - OP_PUSH_INT64 ] := EmitOP_PUSH_INT64; + EmitList[ - OP_PUSH_DOUBLE ] := EmitOP_PUSH_DOUBLE; + EmitList[ - OP_PUSH_CURRENCY ] := EmitOP_PUSH_CURRENCY; + EmitList[ - OP_PUSH_SINGLE ] := EmitOP_PUSH_SINGLE; + EmitList[ - OP_PUSH_EXTENDED ] := EmitOP_PUSH_EXTENDED; +{$IFNDEF PAXARM} + EmitList[ - OP_PUSH_ANSISTRING ] := EmitOP_PUSH_ANSISTRING; + EmitList[ - OP_PUSH_WIDESTRING ] := EmitOP_PUSH_WIDESTRING; + EmitList[ - OP_PUSH_SHORTSTRING ] := EmitOP_PUSH_SHORTSTRING; + EmitList[ - OP_PUSH_PANSICHAR_IMM ] := EmitOP_PUSH_PANSICHAR_IMM; +{$ENDIF} + EmitList[ - OP_PUSH_UNICSTRING ] := EmitOP_PUSH_UNICSTRING; + EmitList[ - OP_PUSH_PWIDECHAR_IMM ] := EmitOP_PUSH_PWIDECHAR_IMM; + EmitList[ - OP_BEGIN_CALL ] := EmitOP_BEGIN_CALL; + EmitList[ - OP_CALL ] := EmitOP_CALL; + EmitList[ - OP_INIT_SUB ] := EmitOP_INIT_SUB; + EmitList[ - OP_END_SUB ] := EmitOP_END_SUB; + EmitList[ - OP_FIN_SUB ] := EmitOP_FIN_SUB; + EmitList[ - OP_EPILOGUE_SUB ] := EmitPCodeOperator; + EmitList[ - OP_BEGIN_LOOP ] := EmitPCodeOperator; + EmitList[ - OP_EPILOGUE_LOOP ] := EmitPCodeOperator; + EmitList[ - OP_END_LOOP ] := EmitPCodeOperator; + EmitList[ - OP_BEGIN_GLOBAL_BLOCK ] := EmitPCodeOperator; + EmitList[ - OP_EPILOGUE_GLOBAL_BLOCK ] := EmitPCodeOperator; + EmitList[ - OP_END_GLOBAL_BLOCK ] := EmitPCodeOperator; + EmitList[ - OP_EXTRA_BYTECODE ] := EmitPCodeOperator; + EmitList[ - OP_RET ] := EmitOP_RET; + EmitList[ - OP_FIELD ] := EmitOP_FIELD; + EmitList[ - OP_GET_COMPONENT ] := EmitOP_GET_COMPONENT; + EmitList[ - OP_ELEM ] := EmitOP_ELEM; + EmitList[ - OP_PRINT_EX ] := EmitOP_PRINT_EX; + EmitList[ - OP_TO_FW_OBJECT ] := EmitOP_TO_FW_OBJECT; + EmitList[ - OP_PUSH_EBP ] := EmitOP_PUSH_EBP; + EmitList[ - OP_POP ] := EmitOP_POP; + EmitList[ - OP_SAVE_REGS ] := EmitOP_SAVE_REGS; + EmitList[ - OP_RESTORE_REGS ] := EmitOP_RESTORE_REGS; + EmitList[ - OP_INT_TO_INT64 ] := EmitOP_INT_TO_INT64; + EmitList[ - OP_BYTE_TO_INT64 ] := EmitOP_BYTE_TO_INT64; + EmitList[ - OP_WORD_TO_INT64 ] := EmitOP_WORD_TO_INT64; + EmitList[ - OP_CARDINAL_TO_INT64 ] := EmitOP_CARDINAL_TO_INT64; + EmitList[ - OP_SMALLINT_TO_INT64 ] := EmitOP_SMALLINT_TO_INT64; + EmitList[ - OP_SHORTINT_TO_INT64 ] := EmitOP_SHORTINT_TO_INT64; + EmitList[ - OP_INT_FROM_INT64 ] := EmitOP_INT_FROM_INT64; + EmitList[ - OP_BYTE_FROM_INT64 ] := EmitOP_BYTE_FROM_INT64; + EmitList[ - OP_WORD_FROM_INT64 ] := EmitOP_WORD_FROM_INT64; + EmitList[ - OP_CARDINAL_FROM_INT64 ] := EmitOP_CARDINAL_FROM_INT64; + EmitList[ - OP_SMALLINT_FROM_INT64 ] := EmitOP_SMALLINT_FROM_INT64; + EmitList[ - OP_SHORTINT_FROM_INT64 ] := EmitOP_SHORTINT_FROM_INT64; + + EmitList[ - OP_INT_TO_UINT64 ] := EmitOP_INT_TO_INT64; + EmitList[ - OP_BYTE_TO_UINT64 ] := EmitOP_BYTE_TO_INT64; + EmitList[ - OP_WORD_TO_UINT64 ] := EmitOP_WORD_TO_INT64; + EmitList[ - OP_CARDINAL_TO_UINT64 ] := EmitOP_CARDINAL_TO_INT64; + EmitList[ - OP_SMALLINT_TO_UINT64 ] := EmitOP_SMALLINT_TO_INT64; + EmitList[ - OP_SHORTINT_TO_UINT64 ] := EmitOP_SHORTINT_TO_INT64; + EmitList[ - OP_INT_FROM_UINT64 ] := EmitOP_INT_FROM_INT64; + EmitList[ - OP_BYTE_FROM_UINT64 ] := EmitOP_BYTE_FROM_INT64; + EmitList[ - OP_WORD_FROM_UINT64 ] := EmitOP_WORD_FROM_INT64; + EmitList[ - OP_CARDINAL_FROM_UINT64 ] := EmitOP_CARDINAL_FROM_INT64; + EmitList[ - OP_SMALLINT_FROM_UINT64 ] := EmitOP_SMALLINT_FROM_INT64; + EmitList[ - OP_SHORTINT_FROM_UINT64 ] := EmitOP_SHORTINT_FROM_INT64; + + EmitList[ - OP_INT_TO_DOUBLE ] := EmitOP_INT_TO_DOUBLE; + EmitList[ - OP_INT64_TO_DOUBLE ] := EmitOP_INT64_TO_DOUBLE; + EmitList[ - OP_UINT64_TO_DOUBLE ] := EmitOP_INT64_TO_DOUBLE; + EmitList[ - OP_INT_TO_SINGLE ] := EmitOP_INT_TO_SINGLE; + EmitList[ - OP_INT64_TO_SINGLE ] := EmitOP_INT64_TO_SINGLE; + EmitList[ - OP_UINT64_TO_SINGLE ] := EmitOP_INT64_TO_SINGLE; + EmitList[ - OP_INT_TO_EXTENDED ] := EmitOP_INT_TO_EXTENDED; + EmitList[ - OP_INT64_TO_EXTENDED ] := EmitOP_INT64_TO_EXTENDED; + EmitList[ - OP_UINT64_TO_EXTENDED ] := EmitOP_INT64_TO_EXTENDED; + EmitList[ - OP_MULT_INT64 ] := EmitOP_MULT_INT64; + EmitList[ - OP_IDIV_INT64 ] := EmitOP_IDIV_INT64; + EmitList[ - OP_MOD_INT64 ] := EmitOP_MOD_INT64; + EmitList[ - OP_SHL_INT64 ] := EmitOP_SHL_INT64; + EmitList[ - OP_SHR_INT64 ] := EmitOP_SHR_INT64; + EmitList[ - OP_ABS_INT64 ] := EmitOP_ABS_INT64; + EmitList[ - OP_CURRENCY_TO_EXTENDED ] := EmitOP_CURRENCY_TO_EXTENDED; + EmitList[ - OP_CURRENCY_TO_SINGLE ] := EmitOP_CURRENCY_TO_SINGLE; + EmitList[ - OP_DOUBLE_TO_SINGLE ] := EmitOP_DOUBLE_TO_SINGLE; + EmitList[ - OP_DOUBLE_TO_EXTENDED ] := EmitOP_DOUBLE_TO_EXTENDED; + EmitList[ - OP_SINGLE_TO_DOUBLE ] := EmitOP_SINGLE_TO_DOUBLE; + EmitList[ - OP_CURRENCY_TO_DOUBLE ] := EmitOP_CURRENCY_TO_DOUBLE; + EmitList[ - OP_SINGLE_TO_EXTENDED ] := EmitOP_SINGLE_TO_EXTENDED; + EmitList[ - OP_EXTENDED_TO_DOUBLE ] := EmitOP_EXTENDED_TO_DOUBLE; + EmitList[ - OP_EXTENDED_TO_SINGLE ] := EmitOP_EXTENDED_TO_SINGLE; + EmitList[ - OP_ADDRESS ] := EmitOP_ADDRESS; + EmitList[ - OP_TERMINAL ] := EmitOP_TERMINAL; + EmitList[ - OP_ADDRESS_PROG ] := EmitOP_ADDRESS_PROG; + EmitList[ - OP_ASSIGN_PROG ] := EmitOP_ASSIGN_PROG; + EmitList[ - OP_SET_INCLUDE ] := EmitOP_SET_INCLUDE; + EmitList[ - OP_SET_INCLUDE_INTERVAL ] := EmitOP_SET_INCLUDE_INTERVAL; + EmitList[ - OP_SET_EXCLUDE ] := EmitOP_SET_EXCLUDE; + EmitList[ - OP_SET_UNION ] := EmitOP_SET_UNION; + EmitList[ - OP_SET_DIFFERENCE ] := EmitOP_SET_DIFFERENCE; + EmitList[ - OP_SET_INTERSECTION ] := EmitOP_SET_INTERSECTION; + EmitList[ - OP_SET_SUBSET ] := EmitOP_SET_SUBSET; + EmitList[ - OP_SET_SUPERSET ] := EmitOP_SET_SUPERSET; + EmitList[ - OP_SET_EQUALITY ] := EmitOP_SET_EQUALITY; + EmitList[ - OP_SET_INEQUALITY ] := EmitOP_SET_INEQUALITY; + EmitList[ - OP_SET_MEMBERSHIP ] := EmitOP_SET_MEMBERSHIP; + EmitList[ - OP_SET_ASSIGN ] := EmitOP_SET_ASSIGN; + EmitList[ - OP_SET_COUNTER_ASSIGN ] := EmitOP_SET_COUNTER_ASSIGN; + EmitList[ - OP_ERR_ABSTRACT ] := EmitOP_ERR_ABSTRACT; + EmitList[ - OP_VAR_FROM_TVALUE ] := EmitOP_VAR_FROM_TVALUE; +{$IFNDEF PAXARM} + EmitList[ - OP_ANSISTRING_FROM_PANSICHAR ] := EmitOP_ANSISTRING_FROM_PANSICHAR; + EmitList[ - OP_ANSISTRING_FROM_PWIDECHAR ] := EmitOP_ANSISTRING_FROM_PWIDECHAR; + EmitList[ - OP_ANSISTRING_FROM_ANSICHAR ] := EmitOP_ANSISTRING_FROM_ANSICHAR; + EmitList[ - OP_ASSIGN_ANSISTRING ] := EmitOP_ASSIGN_ANSISTRING; + EmitList[ - OP_ASSIGN_SHORTSTRING ] := EmitOP_ASSIGN_SHORTSTRING; + EmitList[ - OP_ASSIGN_WIDESTRING ] := EmitOP_ASSIGN_WIDESTRING; + EmitList[ - OP_ASSIGN_UNICSTRING ] := EmitOP_ASSIGN_UNICSTRING; + EmitList[ - OP_ADD_ANSISTRING ] := EmitOP_ADD_ANSISTRING; + EmitList[ - OP_ADD_SHORTSTRING ] := EmitOP_ADD_SHORTSTRING; + EmitList[ - OP_ADD_WIDESTRING ] := EmitOP_ADD_WIDESTRING; + EmitList[ - OP_ANSISTRING_CLR ] := EmitOP_ANSISTRING_CLR; + EmitList[ - OP_WIDESTRING_CLR ] := EmitOP_WIDESTRING_CLR; +{$ENDIF} + EmitList[ - OP_ADD_UNICSTRING ] := EmitOP_ADD_UNICSTRING; + EmitList[ - OP_UNICSTRING_CLR ] := EmitOP_UNICSTRING_CLR; + EmitList[ - OP_INTERFACE_CLR ] := EmitOP_INTERFACE_CLR; + EmitList[ - OP_STRUCTURE_CLR ] := EmitOP_STRUCTURE_CLR; + EmitList[ - OP_CLASS_CLR ] := EmitOP_CLASS_CLR; + EmitList[ - OP_STRUCTURE_ADDREF ] := EmitOP_STRUCTURE_ADDREF; + EmitList[ - OP_ADDREF ] := EmitOP_ADDREF; + EmitList[ - OP_DYNARRAY_CLR ] := EmitOP_DYNARRAY_CLR; + EmitList[ - OP_DYNARRAY_HIGH ] := EmitOP_DYNARRAY_HIGH; + EmitList[ - OP_DYNARRAY_ASSIGN ] := EmitOP_DYNARRAY_ASSIGN; + EmitList[ - OP_CREATE_EMPTY_DYNARRAY ] := EmitOP_CREATE_EMPTY_DYNARRAY; + EmitList[ - OP_ASSIGN_TVarRec ] := EmitOP_ASSIGN_TVarRec; +{$IFNDEF PAXARM} + EmitList[ - OP_SHORTSTRING_FROM_PANSICHAR_LITERAL ] := EmitOP_SHORTSTRING_FROM_PANSICHAR_LITERAL; + EmitList[ - OP_SHORTSTRING_FROM_PWIDECHAR_LITERAL ] := EmitOP_SHORTSTRING_FROM_PWIDECHAR_LITERAL; + EmitList[ - OP_SHORTSTRING_FROM_ANSICHAR ] := EmitOP_SHORTSTRING_FROM_ANSICHAR; + EmitList[ - OP_SHORTSTRING_FROM_WIDECHAR ] := EmitOP_SHORTSTRING_FROM_WIDECHAR; + EmitList[ - OP_SHORTSTRING_FROM_ANSISTRING ] := EmitOP_SHORTSTRING_FROM_ANSISTRING; + EmitList[ - OP_SHORTSTRING_FROM_WIDESTRING ] := EmitOP_SHORTSTRING_FROM_WIDESTRING; + EmitList[ - OP_UNICSTRING_FROM_WIDESTRING ] := EmitOP_UNICSTRING_FROM_WIDESTRING; + EmitList[ - OP_SHORTSTRING_FROM_UNICSTRING ] := EmitOP_SHORTSTRING_FROM_UNICSTRING; + EmitList[ - OP_ANSISTRING_FROM_SHORTSTRING ] := EmitOP_ANSISTRING_FROM_SHORTSTRING; + EmitList[ - OP_EQ_ANSISTRING ] := EmitOP_EQ_ANSISTRING; + EmitList[ - OP_NE_ANSISTRING ] := EmitOP_NE_ANSISTRING; + EmitList[ - OP_EQ_SHORTSTRING ] := EmitOP_EQ_SHORTSTRING; + EmitList[ - OP_NE_SHORTSTRING ] := EmitOP_NE_SHORTSTRING; + EmitList[ - OP_EQ_WIDESTRING ] := EmitOP_EQ_WIDESTRING; + EmitList[ - OP_NE_WIDESTRING ] := EmitOP_NE_WIDESTRING; + EmitList[ - OP_GT_ANSISTRING ] := EmitOP_GT_ANSISTRING; + EmitList[ - OP_GE_ANSISTRING ] := EmitOP_GE_ANSISTRING; + EmitList[ - OP_LT_ANSISTRING ] := EmitOP_LT_ANSISTRING; + EmitList[ - OP_LE_ANSISTRING ] := EmitOP_LE_ANSISTRING; + EmitList[ - OP_GT_SHORTSTRING ] := EmitOP_GT_SHORTSTRING; + EmitList[ - OP_GE_SHORTSTRING ] := EmitOP_GE_SHORTSTRING; + EmitList[ - OP_LT_SHORTSTRING ] := EmitOP_LT_SHORTSTRING; + EmitList[ - OP_LE_SHORTSTRING ] := EmitOP_LE_SHORTSTRING; + EmitList[ - OP_GT_WIDESTRING ] := EmitOP_GT_WIDESTRING; + EmitList[ - OP_GE_WIDESTRING ] := EmitOP_GE_WIDESTRING; + EmitList[ - OP_LT_WIDESTRING ] := EmitOP_LT_WIDESTRING; + EmitList[ - OP_LE_WIDESTRING ] := EmitOP_LE_WIDESTRING; +{$ENDIF} + EmitList[ - OP_EQ_UNICSTRING ] := EmitOP_EQ_UNICSTRING; + EmitList[ - OP_NE_UNICSTRING ] := EmitOP_NE_UNICSTRING; + EmitList[ - OP_GT_UNICSTRING ] := EmitOP_GT_UNICSTRING; + EmitList[ - OP_GE_UNICSTRING ] := EmitOP_GE_UNICSTRING; + EmitList[ - OP_LT_UNICSTRING ] := EmitOP_LT_UNICSTRING; + EmitList[ - OP_LE_UNICSTRING ] := EmitOP_LE_UNICSTRING; + EmitList[ - OP_SHORTSTRING_HIGH ] := EmitOP_SHORTSTRING_HIGH; + EmitList[ - OP_LOCK_VARRAY ] := EmitOP_LOCK_VARRAY; + EmitList[ - OP_UNLOCK_VARRAY ] := EmitOP_UNLOCK_VARRAY; + EmitList[ - OP_VARIANT_CLR ] := EmitOP_VARIANT_CLR; +{$IFNDEF PAXARM} + EmitList[ - OP_WIDESTRING_FROM_PANSICHAR_LITERAL ] := EmitOP_WIDESTRING_FROM_PANSICHAR_LITERAL; + EmitList[ - OP_WIDESTRING_FROM_PWIDECHAR_LITERAL ] := EmitOP_WIDESTRING_FROM_PWIDECHAR_LITERAL; + EmitList[ - OP_WIDESTRING_FROM_ANSICHAR ] := EmitOP_WIDESTRING_FROM_ANSICHAR; + EmitList[ - OP_WIDESTRING_FROM_WIDECHAR ] := EmitOP_WIDESTRING_FROM_WIDECHAR; + EmitList[ - OP_ANSISTRING_FROM_WIDECHAR ] := EmitOP_ANSISTRING_FROM_WIDECHAR; + EmitList[ - OP_WIDESTRING_FROM_WIDECHAR_LITERAL ] := EmitOP_WIDESTRING_FROM_WIDECHAR_LITERAL; + EmitList[ - OP_WIDESTRING_FROM_ANSISTRING ] := EmitOP_WIDESTRING_FROM_ANSISTRING; + EmitList[ - OP_UNICSTRING_FROM_ANSISTRING ] := EmitOP_UNICSTRING_FROM_ANSISTRING; + EmitList[ - OP_WIDESTRING_FROM_SHORTSTRING ] := EmitOP_WIDESTRING_FROM_SHORTSTRING; + EmitList[ - OP_WIDESTRING_FROM_UNICSTRING ] := EmitOP_WIDESTRING_FROM_UNICSTRING; + EmitList[ - OP_UNICSTRING_FROM_SHORTSTRING ] := EmitOP_UNICSTRING_FROM_SHORTSTRING; + EmitList[ - OP_ANSISTRING_FROM_WIDESTRING ] := EmitOP_ANSISTRING_FROM_WIDESTRING; + EmitList[ - OP_ANSISTRING_FROM_UNICSTRING ] := EmitOP_ANSISTRING_FROM_UNICSTRING; + EmitList[ - OP_UNICSTRING_FROM_PANSICHAR_LITERAL ] := EmitOP_UNICSTRING_FROM_PANSICHAR_LITERAL; + EmitList[ - OP_UNICSTRING_FROM_ANSICHAR ] := EmitOP_UNICSTRING_FROM_ANSICHAR; + EmitList[ - OP_VARIANT_FROM_ANSICHAR ] := EmitOP_VARIANT_FROM_ANSICHAR; +{$ENDIF} + EmitList[ - OP_UNICSTRING_FROM_PWIDECHAR_LITERAL ] := EmitOP_UNICSTRING_FROM_PWIDECHAR_LITERAL; + EmitList[ - OP_UNICSTRING_FROM_WIDECHAR ] := EmitOP_UNICSTRING_FROM_WIDECHAR; + EmitList[ - OP_UNICSTRING_FROM_WIDECHAR_LITERAL ] := EmitOP_UNICSTRING_FROM_WIDECHAR_LITERAL; + EmitList[ - OP_VARIANT_FROM_INT ] := EmitOP_VARIANT_FROM_INT; + EmitList[ - OP_VARIANT_FROM_INT64 ] := EmitOP_VARIANT_FROM_INT64; + EmitList[ - OP_VARIANT_FROM_BYTE ] := EmitOP_VARIANT_FROM_BYTE; + EmitList[ - OP_VARIANT_FROM_BOOL ] := EmitOP_VARIANT_FROM_BOOL; + EmitList[ - OP_VARIANT_FROM_WORD ] := EmitOP_VARIANT_FROM_WORD; + EmitList[ - OP_VARIANT_FROM_CARDINAL ] := EmitOP_VARIANT_FROM_CARDINAL; + EmitList[ - OP_VARIANT_FROM_SMALLINT ] := EmitOP_VARIANT_FROM_SMALLINT; + EmitList[ - OP_VARIANT_FROM_SHORTINT ] := EmitOP_VARIANT_FROM_SHORTINT; + EmitList[ - OP_VARIANT_FROM_DOUBLE ] := EmitOP_VARIANT_FROM_DOUBLE; + EmitList[ - OP_VARIANT_FROM_CURRENCY ] := EmitOP_VARIANT_FROM_CURRENCY; + EmitList[ - OP_VARIANT_FROM_SINGLE ] := EmitOP_VARIANT_FROM_SINGLE; + EmitList[ - OP_VARIANT_FROM_EXTENDED ] := EmitOP_VARIANT_FROM_EXTENDED; + EmitList[ - OP_VARIANT_FROM_INTERFACE ] := EmitOP_VARIANT_FROM_INTERFACE; +{$IFNDEF PAXARM} + EmitList[ - OP_VARIANT_FROM_PANSICHAR_LITERAL ] := EmitOP_VARIANT_FROM_PANSICHAR_LITERAL; + EmitList[ - OP_VARIANT_FROM_ANSISTRING ] := EmitOP_VARIANT_FROM_ANSISTRING; + EmitList[ - OP_VARIANT_FROM_WIDESTRING ] := EmitOP_VARIANT_FROM_WIDESTRING; + EmitList[ - OP_VARIANT_FROM_SHORTSTRING ] := EmitOP_VARIANT_FROM_SHORTSTRING; + EmitList[ - OP_OLEVARIANT_FROM_ANSICHAR ] := EmitOP_OLEVARIANT_FROM_ANSICHAR; +{$ENDIF} + EmitList[ - OP_VARIANT_FROM_PWIDECHAR_LITERAL ] := EmitOP_VARIANT_FROM_PWIDECHAR_LITERAL; + EmitList[ - OP_VARIANT_FROM_UNICSTRING ] := EmitOP_VARIANT_FROM_UNICSTRING; + EmitList[ - OP_VARIANT_FROM_WIDECHAR ] := EmitOP_VARIANT_FROM_WIDECHAR; + EmitList[ - OP_VARIANT_FROM_WIDECHAR_LITERAL ] := EmitOP_VARIANT_FROM_WIDECHAR_LITERAL; + EmitList[ - OP_OLEVARIANT_FROM_VARIANT ] := EmitOP_OLEVARIANT_FROM_VARIANT; + EmitList[ - OP_OLEVARIANT_FROM_INT ] := EmitOP_OLEVARIANT_FROM_INT; + EmitList[ - OP_OLEVARIANT_FROM_INT64 ] := EmitOP_OLEVARIANT_FROM_INT64; + EmitList[ - OP_OLEVARIANT_FROM_BYTE ] := EmitOP_OLEVARIANT_FROM_BYTE; + EmitList[ - OP_OLEVARIANT_FROM_BOOL ] := EmitOP_OLEVARIANT_FROM_BOOL; + EmitList[ - OP_OLEVARIANT_FROM_WORD ] := EmitOP_OLEVARIANT_FROM_WORD; + EmitList[ - OP_OLEVARIANT_FROM_CARDINAL ] := EmitOP_OLEVARIANT_FROM_CARDINAL; + EmitList[ - OP_OLEVARIANT_FROM_SMALLINT ] := EmitOP_OLEVARIANT_FROM_SMALLINT; + EmitList[ - OP_OLEVARIANT_FROM_SHORTINT ] := EmitOP_OLEVARIANT_FROM_SHORTINT; + EmitList[ - OP_OLEVARIANT_FROM_DOUBLE ] := EmitOP_OLEVARIANT_FROM_DOUBLE; + EmitList[ - OP_OLEVARIANT_FROM_CURRENCY ] := EmitOP_OLEVARIANT_FROM_CURRENCY; + EmitList[ - OP_OLEVARIANT_FROM_SINGLE ] := EmitOP_OLEVARIANT_FROM_SINGLE; + EmitList[ - OP_OLEVARIANT_FROM_EXTENDED ] := EmitOP_OLEVARIANT_FROM_EXTENDED; + EmitList[ - OP_OLEVARIANT_FROM_INTERFACE ] := EmitOP_OLEVARIANT_FROM_INTERFACE; +{$IFNDEF PAXARM} + EmitList[ - OP_OLEVARIANT_FROM_PANSICHAR_LITERAL ] := EmitOP_OLEVARIANT_FROM_PANSICHAR_LITERAL; + EmitList[ - OP_OLEVARIANT_FROM_ANSISTRING ] := EmitOP_OLEVARIANT_FROM_ANSISTRING; + EmitList[ - OP_OLEVARIANT_FROM_WIDESTRING ] := EmitOP_OLEVARIANT_FROM_WIDESTRING; + EmitList[ - OP_OLEVARIANT_FROM_SHORTSTRING ] := EmitOP_OLEVARIANT_FROM_SHORTSTRING; +{$ENDIF} + EmitList[ - OP_OLEVARIANT_FROM_PWIDECHAR_LITERAL ] := EmitOP_OLEVARIANT_FROM_PWIDECHAR_LITERAL; + EmitList[ - OP_OLEVARIANT_FROM_UNICSTRING ] := EmitOP_OLEVARIANT_FROM_UNICSTRING; + EmitList[ - OP_OLEVARIANT_FROM_WIDECHAR ] := EmitOP_OLEVARIANT_FROM_WIDECHAR; + EmitList[ - OP_OLEVARIANT_FROM_WIDECHAR_LITERAL ] := EmitOP_OLEVARIANT_FROM_WIDECHAR_LITERAL; + + EmitList[ - OP_BEGIN_LIBRARY ] := EmitPCodeOperator; + EmitList[ - OP_BEGIN_EXPORT ] := EmitPCodeOperator; + + // js only +{$IFNDEF PAXARM} + EmitList[ - OP_ANSISTRING_FROM_INT ] := EmitOP_ANSISTRING_FROM_INT; + EmitList[ - OP_ANSISTRING_FROM_DOUBLE ] := EmitOP_ANSISTRING_FROM_DOUBLE; + EmitList[ - OP_ANSISTRING_FROM_SINGLE ] := EmitOP_ANSISTRING_FROM_SINGLE; + EmitList[ - OP_ANSISTRING_FROM_EXTENDED ] := EmitOP_ANSISTRING_FROM_EXTENDED; + EmitList[ - OP_ANSISTRING_FROM_BOOLEAN ] := EmitOP_ANSISTRING_FROM_BOOLEAN; +{$ENDIF} + EmitList[ - OP_UNICSTRING_FROM_INT ] := EmitOP_UNICSTRING_FROM_INT; + EmitList[ - OP_UNICSTRING_FROM_DOUBLE ] := EmitOP_UNICSTRING_FROM_DOUBLE; + EmitList[ - OP_UNICSTRING_FROM_SINGLE ] := EmitOP_UNICSTRING_FROM_SINGLE; + EmitList[ - OP_UNICSTRING_FROM_EXTENDED ] := EmitOP_UNICSTRING_FROM_EXTENDED; + EmitList[ - OP_UNICSTRING_FROM_BOOLEAN ] := EmitOP_UNICSTRING_FROM_BOOLEAN; + + EmitList[ - OP_JS_FUNC_OBJ_FROM_VARIANT ] := EmitOP_JS_FUNC_OBJ_FROM_VARIANT; +{$IFNDEF PAXARM} + EmitList[ - OP_ANSICHAR_FROM_VARIANT ] := EmitOP_ANSICHAR_FROM_VARIANT; + EmitList[ - OP_ANSISTRING_FROM_VARIANT ] := EmitOP_ANSISTRING_FROM_VARIANT; + EmitList[ - OP_WIDESTRING_FROM_VARIANT ] := EmitOP_WIDESTRING_FROM_VARIANT; + EmitList[ - OP_SHORTSTRING_FROM_VARIANT ] := EmitOP_SHORTSTRING_FROM_VARIANT; +{$ENDIF} + EmitList[ - OP_WIDECHAR_FROM_VARIANT ] := EmitOP_WIDECHAR_FROM_VARIANT; + EmitList[ - OP_UNICSTRING_FROM_VARIANT ] := EmitOP_UNICSTRING_FROM_VARIANT; + EmitList[ - OP_DOUBLE_FROM_VARIANT ] := EmitOP_DOUBLE_FROM_VARIANT; + EmitList[ - OP_CURRENCY_FROM_VARIANT ] := EmitOP_CURRENCY_FROM_VARIANT; + EmitList[ - OP_SINGLE_FROM_VARIANT ] := EmitOP_SINGLE_FROM_VARIANT; + EmitList[ - OP_EXTENDED_FROM_VARIANT ] := EmitOP_EXTENDED_FROM_VARIANT; + EmitList[ - OP_INT_FROM_VARIANT ] := EmitOP_INT_FROM_VARIANT; + EmitList[ - OP_INT64_FROM_VARIANT ] := EmitOP_INT64_FROM_VARIANT; + EmitList[ - OP_UINT64_FROM_VARIANT ] := EmitOP_INT64_FROM_VARIANT; + EmitList[ - OP_BYTE_FROM_VARIANT ] := EmitOP_BYTE_FROM_VARIANT; + EmitList[ - OP_WORD_FROM_VARIANT ] := EmitOP_WORD_FROM_VARIANT; + EmitList[ - OP_CARDINAL_FROM_VARIANT ] := EmitOP_CARDINAL_FROM_VARIANT; + EmitList[ - OP_BOOL_FROM_VARIANT ] := EmitOP_BOOL_FROM_VARIANT; + EmitList[ - OP_BYTEBOOL_FROM_VARIANT ] := EmitOP_BYTEBOOL_FROM_VARIANT; + EmitList[ - OP_WORDBOOL_FROM_VARIANT ] := EmitOP_WORDBOOL_FROM_VARIANT; + EmitList[ - OP_LONGBOOL_FROM_VARIANT ] := EmitOP_LONGBOOL_FROM_VARIANT; + EmitList[ - OP_SMALLINT_FROM_VARIANT ] := EmitOP_SMALLINT_FROM_VARIANT; + EmitList[ - OP_SHORTINT_FROM_VARIANT ] := EmitOP_SHORTINT_FROM_VARIANT; + EmitList[ - OP_BOOL_FROM_BYTEBOOL ] := EmitOP_BOOL_FROM_BYTEBOOL; + EmitList[ - OP_BOOL_FROM_WORDBOOL ] := EmitOP_BOOL_FROM_WORDBOOL; + EmitList[ - OP_BOOL_FROM_LONGBOOL ] := EmitOP_BOOL_FROM_LONGBOOL; + EmitList[ - OP_NEG_VARIANT ] := EmitOP_NEG_VARIANT; + EmitList[ - OP_ABS_VARIANT ] := EmitOP_ABS_VARIANT; + EmitList[ - OP_NOT_VARIANT ] := EmitOP_NOT_VARIANT; + EmitList[ - OP_ADD_VARIANT ] := EmitOP_ADD_VARIANT; + EmitList[ - OP_SUB_VARIANT ] := EmitOP_SUB_VARIANT; + EmitList[ - OP_MULT_VARIANT ] := EmitOP_MULT_VARIANT; + EmitList[ - OP_DIV_VARIANT ] := EmitOP_DIV_VARIANT; + EmitList[ - OP_IDIV_VARIANT ] := EmitOP_IDIV_VARIANT; + EmitList[ - OP_MOD_VARIANT ] := EmitOP_MOD_VARIANT; + EmitList[ - OP_SHL_VARIANT ] := EmitOP_SHL_VARIANT; + EmitList[ - OP_SHR_VARIANT ] := EmitOP_SHR_VARIANT; + EmitList[ - OP_AND_VARIANT ] := EmitOP_AND_VARIANT; + EmitList[ - OP_OR_VARIANT ] := EmitOP_OR_VARIANT; + EmitList[ - OP_XOR_VARIANT ] := EmitOP_XOR_VARIANT; + EmitList[ - OP_LT_VARIANT ] := EmitOP_LT_VARIANT; + EmitList[ - OP_LE_VARIANT ] := EmitOP_LE_VARIANT; + EmitList[ - OP_GT_VARIANT ] := EmitOP_GT_VARIANT; + EmitList[ - OP_GE_VARIANT ] := EmitOP_GE_VARIANT; + EmitList[ - OP_EQ_VARIANT ] := EmitOP_EQ_VARIANT; + EmitList[ - OP_NE_VARIANT ] := EmitOP_NE_VARIANT; + EmitList[ - OP_CURRENCY_FROM_INT ] := EmitOP_CURRENCY_FROM_INT; + EmitList[ - OP_CURRENCY_FROM_INT64 ] := EmitOP_CURRENCY_FROM_INT64; + EmitList[ - OP_CURRENCY_FROM_UINT64 ] := EmitOP_CURRENCY_FROM_INT64; + EmitList[ - OP_CURRENCY_FROM_REAL ] := EmitOP_CURRENCY_FROM_REAL; + EmitList[ - OP_VARIANT_FROM_CLASS ] := EmitOP_VARIANT_FROM_CLASS; + EmitList[ - OP_VARIANT_FROM_POINTER ] := EmitOP_VARIANT_FROM_POINTER; + EmitList[ - OP_CLASS_FROM_VARIANT ] := EmitOP_CLASS_FROM_VARIANT; + EmitList[ - OP_INTERFACE_FROM_CLASS ] := EmitOP_INTERFACE_FROM_CLASS; + EmitList[ - OP_INTERFACE_CAST ] := EmitOP_INTERFACE_CAST; + EmitList[ - OP_ASSIGN_VARIANT ] := EmitOP_ASSIGN_VARIANT; + EmitList[ - OP_ASSIGN_OLEVARIANT ] := EmitOP_ASSIGN_OLEVARIANT; + EmitList[ - OP_ASSIGN_CLASS ] := EmitOP_ASSIGN_CLASS; + EmitList[ - OP_VARARRAY_GET ] := EmitOP_VARARRAY_GET; + EmitList[ - OP_VARARRAY_PUT ] := EmitOP_VARARRAY_PUT; + EmitList[ - OP_OLE_GET ] := EmitOP_OLE_GET; + EmitList[ - OP_OLE_SET ] := EmitOP_OLE_SET; + EmitList[ - OP_OLE_PARAM ] := EmitOP_OLE_PARAM; + EmitList[ - OP_IS ] := EmitOP_IS; + EmitList[ - OP_TYPEINFO ] := EmitOP_TYPEINFO; + EmitList[ - OP_ADD_TYPEINFO ] := EmitPCodeOperator; + EmitList[ - OP_PUSH_CONTEXT ] := EmitOP_PUSH_CONTEXT; + EmitList[ - OP_POP_CONTEXT ] := EmitOP_POP_CONTEXT; + EmitList[ - OP_FIND_CONTEXT ] := EmitOP_FIND_CONTEXT; + EmitList[ - OP_FIND_JS_FUNC ] := EmitOP_FIND_JS_FUNC; + EmitList[ - OP_GET_PROG ] := EmitOP_GET_PROG; + EmitList[ - OP_ONCREATE_HOST_OBJECT ] := EmitOP_ONCREATE_HOST_OBJECT; + EmitList[ - OP_ONDESTROY_HOST_OBJECT ] := EmitOP_ONDESTROY_HOST_OBJECT; + EmitList[ - OP_BEFORE_CALL_HOST ] := EmitOP_BEFORE_CALL_HOST; + EmitList[ - OP_AFTER_CALL_HOST ] := EmitOP_AFTER_CALL_HOST; + EmitList[ - OP_INIT_FWARRAY ] := EmitOP_INIT_FWARRAY; + EmitList[ - OP_ONCREATE_OBJECT ] := EmitOP_ONCREATE_OBJECT; + EmitList[ - OP_ON_AFTER_OBJECT_CREATION ] := EmitOP_ON_AFTER_OBJECT_CREATION; + EmitList[ - OP_CLASSNAME ] := EmitOP_CLASSNAME; + EmitList[ - OP_GET_DRTTI_PROP ] := EmitOP_GET_DRTTI_PROP; + EmitList[ - OP_SET_DRTTI_PROP ] := EmitOP_SET_DRTTI_PROP; +{$IFNDEF PAXARM} + EmitList[ - OP_GET_ANSISTR_PROP ] := EmitOP_GET_ANSISTR_PROP; + EmitList[ - OP_SET_ANSISTR_PROP ] := EmitOP_SET_ANSISTR_PROP; + EmitList[ - OP_GET_WIDESTR_PROP ] := EmitOP_GET_WIDESTR_PROP; + EmitList[ - OP_SET_WIDESTR_PROP ] := EmitOP_SET_WIDESTR_PROP; +{$ENDIF} + EmitList[ - OP_GET_UNICSTR_PROP ] := EmitOP_GET_UNICSTR_PROP; + EmitList[ - OP_SET_UNICSTR_PROP ] := EmitOP_SET_UNICSTR_PROP; + EmitList[ - OP_GET_ORD_PROP ] := EmitOP_GET_ORD_PROP; + EmitList[ - OP_SET_ORD_PROP ] := EmitOP_SET_ORD_PROP; + EmitList[ - OP_GET_INTERFACE_PROP ] := EmitOP_GET_INTERFACE_PROP; + EmitList[ - OP_SET_INTERFACE_PROP ] := EmitOP_SET_INTERFACE_PROP; + EmitList[ - OP_GET_SET_PROP ] := EmitOP_GET_SET_PROP; + EmitList[ - OP_SET_SET_PROP ] := EmitOP_SET_SET_PROP; + EmitList[ - OP_GET_FLOAT_PROP ] := EmitOP_GET_FLOAT_PROP; + EmitList[ - OP_SET_FLOAT_PROP ] := EmitOP_SET_FLOAT_PROP; + EmitList[ - OP_GET_VARIANT_PROP ] := EmitOP_GET_VARIANT_PROP; + EmitList[ - OP_SET_VARIANT_PROP ] := EmitOP_SET_VARIANT_PROP; + EmitList[ - OP_GET_INT64_PROP ] := EmitOP_GET_INT64_PROP; + EmitList[ - OP_SET_INT64_PROP ] := EmitOP_SET_INT64_PROP; + EmitList[ - OP_GET_EVENT_PROP ] := EmitOP_GET_EVENT_PROP; + EmitList[ - OP_SET_EVENT_PROP ] := EmitOP_SET_EVENT_PROP; + EmitList[ - OP_SET_EVENT_PROP2 ] := EmitOP_SET_EVENT_PROP2; + EmitList[ - OP_TRY_ON ] := EmitOP_TRY_ON; + EmitList[ - OP_EXCEPT_SEH ] := EmitOP_EXCEPT_SEH; + EmitList[ - OP_TRY_OFF ] := EmitOP_TRY_OFF; + EmitList[ - OP_FINALLY ] := EmitOP_FINALLY; + EmitList[ - OP_EXCEPT ] := EmitOP_EXCEPT; + EmitList[ - OP_EXCEPT_ON ] := EmitOP_EXCEPT_ON; + EmitList[ - OP_RAISE ] := EmitOP_RAISE; + EmitList[ - OP_EXIT ] := EmitOP_EXIT; + EmitList[ - OP_COND_RAISE ] := EmitOP_COND_RAISE; + EmitList[ - OP_BEGIN_EXCEPT_BLOCK ] := EmitOP_BEGIN_EXCEPT_BLOCK; + EmitList[ - OP_END_EXCEPT_BLOCK ] := EmitOP_END_EXCEPT_BLOCK; + EmitList[ - OP_OVERFLOW_CHECK ] := EmitOP_OVERFLOW_CHECK; + EmitList[ - OP_PAUSE ] := EmitOP_PAUSE; + EmitList[ - OP_CHECK_PAUSE ] := EmitOP_CHECK_PAUSE; + EmitList[ - OP_CHECK_PAUSE_LIGHT ] := EmitOP_CHECK_PAUSE_LIGHT; + EmitList[ - OP_HALT ] := EmitOP_HALT; + EmitList[ - OP_CREATE_OBJECT ] := EmitOP_CREATE_OBJECT; + EmitList[ - OP_DESTROY_OBJECT ] := EmitOP_DESTROY_OBJECT; + EmitList[ - OP_GET_VMT_ADDRESS ] := EmitOP_GET_VMT_ADDRESS; + EmitList[ - OP_SET_LENGTH ] := EmitOP_SET_LENGTH; + EmitList[ - OP_SET_LENGTH_EX ] := EmitOP_SET_LENGTH_EX; + EmitList[ - OP_PUSH_LENGTH ] := EmitPCodeOperator; + EmitList[ - OP_CREATE_METHOD ] := EmitOP_CREATE_METHOD; + EmitList[ - OP_DECLARE_TEMP_VAR ] := EmitPCodeOperator; + EmitList[ - OP_BEGIN_USING ] := EmitPCodeOperator; + EmitList[ - OP_END_USING ] := EmitPCodeOperator; + EmitList[ - OP_BEGIN_BLOCK ] := EmitPCodeOperator; + EmitList[ - OP_END_BLOCK ] := EmitPCodeOperator; + EmitList[ - OP_BEGIN_WITH ] := EmitPCodeOperator; + EmitList[ - OP_END_WITH ] := EmitPCodeOperator; + EmitList[ - OP_PARAM_CHANGED ] := EmitPCodeOperator; + EmitList[ - OP_BEGIN_SUB ] := EmitPCodeOperator; + EmitList[ - OP_BEGIN_CLASS_TYPE ] := EmitPCodeOperator; + EmitList[ - OP_END_CLASS_TYPE ] := EmitPCodeOperator; + EmitList[ - OP_BEGIN_RECORD_TYPE ] := EmitPCodeOperator; + EmitList[ - OP_END_RECORD_TYPE ] := EmitPCodeOperator; + EmitList[ - OP_BEGIN_HELPER_TYPE ] := EmitPCodeOperator; + EmitList[ - OP_END_HELPER_TYPE ] := EmitPCodeOperator; + EmitList[ - OP_ADD_ANCESTOR ] := EmitNothing; +{$IFNDEF PAXARM} + EmitList[ - OP_INIT_PANSICHAR_LITERAL ] := EmitNothing; +{$ENDIF} + EmitList[ - OP_INIT_PWIDECHAR_LITERAL ] := EmitNothing; + EmitList[ - OP_BEGIN_CRT_JS_FUNC_OBJECT ] := EmitOP_BEGIN_CRT_JS_FUNC_OBJECT; + EmitList[ - OP_END_CRT_JS_FUNC_OBJECT ] := EmitOP_END_CRT_JS_FUNC_OBJECT; + EmitList[ - OP_TO_JS_OBJECT ] := EmitOP_TO_JS_OBJECT; + EmitList[ - OP_JS_TYPEOF ] := EmitOP_JS_TYPEOF; + EmitList[ - OP_JS_VOID ] := EmitOP_JS_VOID; + EmitList[ - OP_GET_NEXTJSPROP ] := EmitOP_GET_NEXTJSPROP; + EmitList[ - OP_CLEAR_REFERENCES ] := EmitOP_CLEAR_REFERENCES; + EmitList[ - OP_DECLARE_LOCAL_VAR ] := EmitPCodeOperator; + EmitList[ - OP_LOAD_PROC ] := EmitPCodeOperator; + EmitList[ - OP_ADD_MESSAGE ] := EmitPCodeOperator; + EmitList[ - OP_BEGIN_ARRAY_TYPE ] := EmitPCodeOperator; + EmitList[ - OP_END_ARRAY_TYPE ] := EmitPCodeOperator; + EmitList[ - OP_BEGIN_SET_TYPE ] := EmitPCodeOperator; + EmitList[ - OP_END_SET_TYPE ] := EmitPCodeOperator; + EmitList[ - OP_BEGIN_ENUM_TYPE ] := EmitPCodeOperator; + EmitList[ - OP_END_ENUM_TYPE ] := EmitPCodeOperator; + EmitList[ - OP_BEGIN_SUBRANGE_TYPE ] := EmitPCodeOperator; + EmitList[ - OP_END_SUBRANGE_TYPE ] := EmitPCodeOperator; + EmitList[ - OP_BEGIN_POINTER_TYPE ] := EmitPCodeOperator; + EmitList[ - OP_END_POINTER_TYPE ] := EmitPCodeOperator; + EmitList[ - OP_BEGIN_CLASSREF_TYPE ] := EmitPCodeOperator; + EmitList[ - OP_END_CLASSREF_TYPE ] := EmitPCodeOperator; + EmitList[ - OP_BEGIN_DYNARRAY_TYPE ] := EmitPCodeOperator; + EmitList[ - OP_END_DYNARRAY_TYPE ] := EmitPCodeOperator; +{$IFNDEF PAXARM} + EmitList[ - OP_BEGIN_SHORTSTRING_TYPE ] := EmitPCodeOperator; + EmitList[ - OP_END_SHORTSTRING_TYPE ] := EmitPCodeOperator; +{$ENDIF} + EmitList[ - OP_BEGIN_INTERFACE_TYPE ] := EmitPCodeOperator; + EmitList[ - OP_END_INTERFACE_TYPE ] := EmitPCodeOperator; + EmitList[ - OP_BEGIN_TEXT ] := EmitPCodeOperator; + EmitList[ - OP_END_TEXT ] := EmitPCodeOperator; + EmitList[ - OP_WARNINGS_ON ] := EmitPCodeOperator; + EmitList[ - OP_WARNINGS_OFF ] := EmitPCodeOperator; + EmitList[ - OP_FRAMEWORK_ON ] := EmitPCodeOperator; + EmitList[ - OP_FRAMEWORK_OFF ] := EmitPCodeOperator; + EmitList[ - OP_DECL_SUB ] := EmitPCodeOperator; + EmitList[ - OP_DECLARE_MEMBER ] := EmitPCodeOperator; + EmitList[ - OP_ABSOLUTE ] := EmitPCodeOperator; + + EmitList[ - OP_BEGIN_INCLUDED_FILE ] := EmitPCodeOperator; + EmitList[ - OP_END_INCLUDED_FILE ] := EmitPCodeOperator; + +/// +/// +/// +/// +{$IFNDEF PAXARM} + if TargetPlatform = tpWIN64 then + begin + EmitList[ - OP_EMIT_ON ] := EmitOP_EMIT_ON; + EmitList[ - OP_EMIT_OFF] := EmitOP_EMIT_OFF; + EmitList[ - OP_NOP ] := EmitNothing; + EmitList[ - OP_BEGIN_NAMESPACE ] := EmitNothing; + EmitList[ - OP_END_NAMESPACE ] := EmitNothing; + EmitList[ - OP_GO ] := EmitOP_GO; + EmitList[ - OP_GO_1 ] := EmitOP_GO_1; + EmitList[ - OP_GO_2 ] := EmitOP_GO_2; + EmitList[ - OP_GO_3 ] := EmitOP_GO_3; + EmitList[ - OP_GO_TRUE ] := EmitOP_GO_TRUE_64; + EmitList[ - OP_GO_FALSE ] := EmitOP_GO_FALSE_64; + EmitList[ - OP_GO_DL ] := EmitOP_GO_DL_64; + EmitList[ - OP_SAVE_EDX ] := EmitOP_SAVE_EDX_64; + EmitList[ - OP_RESTORE_EDX ] := EmitOP_RESTORE_EDX_64; + EmitList[ - OP_ASSIGN_BYTE_I ] := EmitOP_ASSIGN_INT_I_64; + EmitList[ - OP_ASSIGN_BYTE_M ] := EmitOP_ASSIGN_INT_M_64; + EmitList[ - OP_ASSIGN_WORD_I ] := EmitOP_ASSIGN_INT_I_64; + EmitList[ - OP_ASSIGN_WORD_M ] := EmitOP_ASSIGN_INT_M_64; + EmitList[ - OP_ASSIGN_CARDINAL_I ] := EmitOP_ASSIGN_INT_I_64; + EmitList[ - OP_ASSIGN_CARDINAL_M ] := EmitOP_ASSIGN_INT_M_64; + EmitList[ - OP_ASSIGN_SMALLINT_I ] := EmitOP_ASSIGN_INT_I_64; + EmitList[ - OP_ASSIGN_SMALLINT_M ] := EmitOP_ASSIGN_INT_M_64; + EmitList[ - OP_ASSIGN_SHORTINT_I ] := EmitOP_ASSIGN_INT_I_64; + EmitList[ - OP_ASSIGN_SHORTINT_M ] := EmitOP_ASSIGN_INT_M_64; + EmitList[ - OP_ASSIGN_INT_I ] := EmitOP_ASSIGN_INT_I_64; + EmitList[ - OP_ASSIGN_INT_M ] := EmitOP_ASSIGN_INT_M_64; + EmitList[ - OP_ASSIGN_PANSICHAR ] := EmitOP_ASSIGN_PANSICHAR_64; + EmitList[ - OP_ASSIGN_PWIDECHAR ] := EmitOP_ASSIGN_PWIDECHAR_64; + EmitList[ - OP_ASSIGN_EVENT ] := EmitOP_ASSIGN_EVENT_64; + EmitList[ - OP_CREATE_EVENT ] := EmitOP_CREATE_EVENT_64; + EmitList[ - OP_ASSIGN_DOUBLE ] := EmitOP_ASSIGN_DOUBLE_64; + EmitList[ - OP_ASSIGN_CURRENCY ] := EmitOP_ASSIGN_CURRENCY_64; + EmitList[ - OP_ASSIGN_SINGLE ] := EmitOP_ASSIGN_SINGLE_64; + EmitList[ - OP_ASSIGN_EXTENDED ] := EmitOP_ASSIGN_EXTENDED_64; + EmitList[ - OP_ASSIGN_INT64 ] := EmitOP_ASSIGN_INT64_64; + EmitList[ - OP_ASSIGN_UINT64 ] := EmitOP_ASSIGN_INT64_64; + EmitList[ - OP_ASSIGN_RECORD ] := EmitOP_ASSIGN_RECORD_64; + EmitList[ - OP_ASSIGN_ARRAY ] := EmitOP_ASSIGN_RECORD_64; + EmitList[ - OP_ASSIGN_INTERFACE ] := EmitOP_ASSIGN_INTERFACE_64; + EmitList[ - OP_ADD_INT64 ] := EmitOP_ADD_INT64_64; + EmitList[ - OP_SUB_INT64 ] := EmitOP_SUB_INT64_64; + EmitList[ - OP_AND_INT64 ] := EmitOP_AND_INT64_64; + EmitList[ - OP_OR_INT64 ] := EmitOP_OR_INT64_64; + EmitList[ - OP_XOR_INT64 ] := EmitOP_XOR_INT64; + EmitList[ - OP_ADD_UINT64 ] := EmitOP_ADD_UINT64_64; + EmitList[ - OP_SUB_UINT64 ] := EmitOP_SUB_UINT64_64; + EmitList[ - OP_AND_UINT64 ] := EmitOP_AND_UINT64_64; + EmitList[ - OP_OR_UINT64 ] := EmitOP_OR_UINT64_64; + EmitList[ - OP_XOR_UINT64 ] := EmitOP_XOR_UINT64; + EmitList[ - OP_LT_INT64 ] := EmitOP_LT_INT64_64; + EmitList[ - OP_LE_INT64 ] := EmitOP_LE_INT64_64; + EmitList[ - OP_GT_INT64 ] := EmitOP_GT_INT64_64; + EmitList[ - OP_GE_INT64 ] := EmitOP_GE_INT64_64; + EmitList[ - OP_EQ_INT64 ] := EmitOP_EQ_INT64_64; + EmitList[ - OP_NE_INT64 ] := EmitOP_NE_INT64_64; + EmitList[ - OP_LT_UINT64 ] := EmitOP_LT_UINT64_64; + EmitList[ - OP_LE_UINT64 ] := EmitOP_LE_UINT64_64; + EmitList[ - OP_GT_UINT64 ] := EmitOP_GT_UINT64_64; + EmitList[ - OP_GE_UINT64 ] := EmitOP_GE_UINT64_64; + EmitList[ - OP_EQ_STRUCT ] := EmitOP_EQ_STRUCT_64; + EmitList[ - OP_NE_STRUCT ] := EmitOP_NE_STRUCT_64; + EmitList[ - OP_EQ_EVENT ] := EmitOP_EQ_EVENT_64; + EmitList[ - OP_NE_EVENT ] := EmitOP_NE_EVENT_64; + EmitList[ - OP_SUB_CURRENCY ] := EmitOP_SUB_CURRENCY_64; + EmitList[ - OP_MUL_CURRENCY ] := EmitOP_MUL_CURRENCY_64; + EmitList[ - OP_DIV_CURRENCY ] := EmitOP_DIV_CURRENCY_64; + EmitList[ - OP_ADD_INT_MI ] := EmitOP_ADD_INT_MI_64; + EmitList[ - OP_ADD_INT_MM ] := EmitOP_ADD_INT_MM_64; + EmitList[ - OP_ADD_CURRENCY ] := EmitOP_ADD_CURRENCY_64; + EmitList[ - OP_ADD_DOUBLE ] := EmitOP_ADD_DOUBLE_64; + EmitList[ - OP_ADD_SINGLE ] := EmitOP_ADD_SINGLE_64; + EmitList[ - OP_ADD_EXTENDED ] := EmitOP_ADD_EXTENDED_64; + EmitList[ - OP_NEG_INT ] := EmitOP_NEG_INT_64; + EmitList[ - OP_NEG_INT64 ] := EmitOP_NEG_INT64_64; + EmitList[ - OP_NEG_UINT64 ] := EmitOP_NEG_INT64_64; + EmitList[ - OP_NOT ] := EmitOP_NOT_64; + EmitList[ - OP_NOT_BOOL ] := EmitOP_NOT_BOOL64; + EmitList[ - OP_NOT_BYTEBOOL ] := EmitOP_NOT_BYTEBOOL64; + EmitList[ - OP_NOT_WORDBOOL ] := EmitOP_NOT_WORDBOOL64; + EmitList[ - OP_NOT_LONGBOOL ] := EmitOP_NOT_LONGBOOL64; + EmitList[ - OP_NEG_DOUBLE ] := EmitOP_NEG_DOUBLE_64; + EmitList[ - OP_NEG_CURRENCY ] := EmitOP_NEG_CURRENCY_64; + EmitList[ - OP_NEG_SINGLE ] := EmitOP_NEG_SINGLE_64; + EmitList[ - OP_NEG_EXTENDED ] := EmitOP_NEG_EXTENDED_64; + EmitList[ - OP_ABS_INT ] := EmitOP_ABS_INT_64; + EmitList[ - OP_ABS_DOUBLE ] := EmitOP_ABS_DOUBLE_64; + EmitList[ - OP_ABS_SINGLE ] := EmitOP_ABS_SINGLE_64; + EmitList[ - OP_ABS_EXTENDED ] := EmitOP_ABS_EXTENDED_64; + EmitList[ - OP_ABS_CURRENCY ] := EmitOP_ABS_CURRENCY_64; + EmitList[ - OP_SUB_INT_MI ] := EmitOP_SUB_INT_MI_64; + EmitList[ - OP_SUB_INT_MM ] := EmitOP_SUB_INT_MM_64; + EmitList[ - OP_SUB_DOUBLE ] := EmitOP_SUB_DOUBLE_64; + EmitList[ - OP_SUB_SINGLE ] := EmitOP_SUB_SINGLE_64; + EmitList[ - OP_SUB_EXTENDED ] := EmitOP_SUB_EXTENDED_64; + EmitList[ - OP_IMUL_INT_MI ] := EmitOP_IMUL_INT_MI_64; + EmitList[ - OP_IMUL_INT_MM ] := EmitOP_IMUL_INT_MM_64; + EmitList[ - OP_MUL_DOUBLE ] := EmitOP_MUL_DOUBLE_64; + EmitList[ - OP_MUL_SINGLE ] := EmitOP_MUL_SINGLE_64; + EmitList[ - OP_MUL_EXTENDED ] := EmitOP_MUL_EXTENDED_64; + EmitList[ - OP_IDIV_INT_MI ] := EmitOP_IDIV_INT_MI_64; + EmitList[ - OP_IDIV_INT_MM ] := EmitOP_IDIV_INT_MM_64; + EmitList[ - OP_IDIV_INT_IM ] := EmitOP_IDIV_INT_IM_64; + EmitList[ - OP_DIV_DOUBLE ] := EmitOP_DIV_DOUBLE_64; + EmitList[ - OP_DIV_SINGLE ] := EmitOP_DIV_SINGLE_64; + EmitList[ - OP_DIV_EXTENDED ] := EmitOP_DIV_EXTENDED_64; + EmitList[ - OP_MOD_INT_MI ] := EmitOP_MOD_INT_MI_64; + EmitList[ - OP_MOD_INT_MM ] := EmitOP_MOD_INT_MM_64; + EmitList[ - OP_MOD_INT_IM ] := EmitOP_MOD_INT_IM_64; + EmitList[ - OP_SHL_INT_MI ] := EmitOP_SHL_INT_MI_64; + EmitList[ - OP_SHL_INT_MM ] := EmitOP_SHL_INT_MM_64; + EmitList[ - OP_SHL_INT_IM ] := EmitOP_SHL_INT_IM_64; + EmitList[ - OP_SHR_INT_MI ] := EmitOP_SHR_INT_MI_64; + EmitList[ - OP_SHR_INT_MM ] := EmitOP_SHR_INT_MM_64; + EmitList[ - OP_SHR_INT_IM ] := EmitOP_SHR_INT_IM_64; + EmitList[ - OP_AND_INT_MI ] := EmitOP_AND_INT_MI_64; + EmitList[ - OP_AND_INT_MM ] := EmitOP_AND_INT_MM_64; + EmitList[ - OP_OR_INT_MI ] := EmitOP_OR_INT_MI_64; + EmitList[ - OP_OR_INT_MM ] := EmitOP_OR_INT_MM_64; + EmitList[ - OP_XOR_INT_MI ] := EmitOP_XOR_INT_MI_64; + EmitList[ - OP_XOR_INT_MM ] := EmitOP_XOR_INT_MM_64; + EmitList[ - OP_LT_INT_MI ] := EmitOP_LT_INT_MI_64; + EmitList[ - OP_LT_INT_MM ] := EmitOP_LT_INT_MM_64; + EmitList[ - OP_LE_INT_MI ] := EmitOP_LE_INT_MI_64; + EmitList[ - OP_LE_INT_MM ] := EmitOP_LE_INT_MM_64; + EmitList[ - OP_GT_INT_MI ] := EmitOP_GT_INT_MI_64; + EmitList[ - OP_GT_INT_MM ] := EmitOP_GT_INT_MM_64; + EmitList[ - OP_GE_INT_MI ] := EmitOP_GE_INT_MI_64; + EmitList[ - OP_GE_INT_MM ] := EmitOP_GE_INT_MM_64; + EmitList[ - OP_EQ_INT_MI ] := EmitOP_EQ_INT_MI_64; + EmitList[ - OP_EQ_INT_MM ] := EmitOP_EQ_INT_MM_64; + EmitList[ - OP_NE_INT_MI ] := EmitOP_NE_INT_MI_64; + EmitList[ - OP_NE_INT_MM ] := EmitOP_NE_INT_MM_64; + EmitList[ - OP_LT_DOUBLE ] := EmitOP_LT_DOUBLE_64; + EmitList[ - OP_LE_DOUBLE ] := EmitOP_LE_DOUBLE_64; + EmitList[ - OP_GT_DOUBLE ] := EmitOP_GT_DOUBLE_64; + EmitList[ - OP_GE_DOUBLE ] := EmitOP_GE_DOUBLE_64; + EmitList[ - OP_EQ_DOUBLE ] := EmitOP_EQ_DOUBLE_64; + EmitList[ - OP_NE_DOUBLE ] := EmitOP_NE_DOUBLE_64; + EmitList[ - OP_LT_CURRENCY ] := EmitOP_LT_CURRENCY_64; + EmitList[ - OP_LE_CURRENCY ] := EmitOP_LE_CURRENCY_64; + EmitList[ - OP_GT_CURRENCY ] := EmitOP_GT_CURRENCY_64; + EmitList[ - OP_GE_CURRENCY ] := EmitOP_GE_CURRENCY_64; + EmitList[ - OP_EQ_CURRENCY ] := EmitOP_EQ_CURRENCY_64; + EmitList[ - OP_NE_CURRENCY ] := EmitOP_NE_CURRENCY_64; + EmitList[ - OP_LT_SINGLE ] := EmitOP_LT_SINGLE_64; + EmitList[ - OP_LE_SINGLE ] := EmitOP_LE_SINGLE_64; + EmitList[ - OP_GT_SINGLE ] := EmitOP_GT_SINGLE_64; + EmitList[ - OP_GE_SINGLE ] := EmitOP_GE_SINGLE_64; + EmitList[ - OP_EQ_SINGLE ] := EmitOP_EQ_SINGLE_64; + EmitList[ - OP_NE_SINGLE ] := EmitOP_NE_SINGLE_64; + EmitList[ - OP_LT_EXTENDED ] := EmitOP_LT_EXTENDED_64; + EmitList[ - OP_LE_EXTENDED ] := EmitOP_LE_EXTENDED_64; + EmitList[ - OP_GT_EXTENDED ] := EmitOP_GT_EXTENDED_64; + EmitList[ - OP_GE_EXTENDED ] := EmitOP_GE_EXTENDED_64; + EmitList[ - OP_EQ_EXTENDED ] := EmitOP_EQ_EXTENDED_64; + EmitList[ - OP_NE_EXTENDED ] := EmitOP_NE_EXTENDED_64; + EmitList[ - OP_EXPORTS ] := EmitOP_EXPORTS_64; + EmitList[ - OP_PUSH_ADDRESS ] := EmitOP_PUSH_ADDRESS_64; + EmitList[ - OP_PUSH_STRUCTURE ] := EmitOP_PUSH_STRUCTURE_64; + EmitList[ - OP_PUSH_SET ] := EmitOP_PUSH_SET_64; + EmitList[ - OP_PUSH_BYTE_IMM ] := EmitOP_PUSH_INT_IMM_64; + EmitList[ - OP_PUSH_BYTE ] := EmitOP_PUSH_INT_64; + EmitList[ - OP_PUSH_WORD_IMM ] := EmitOP_PUSH_INT_IMM_64; + EmitList[ - OP_PUSH_WORD ] := EmitOP_PUSH_INT_64; + EmitList[ - OP_PUSH_CARDINAL_IMM ] := EmitOP_PUSH_INT_IMM_64; + EmitList[ - OP_PUSH_CARDINAL ] := EmitOP_PUSH_INT_64; + EmitList[ - OP_PUSH_SMALLINT_IMM ] := EmitOP_PUSH_INT_IMM_64; + EmitList[ - OP_PUSH_SMALLINT ] := EmitOP_PUSH_INT_64; + EmitList[ - OP_PUSH_SHORTINT_IMM ] := EmitOP_PUSH_INT_IMM_64; + EmitList[ - OP_PUSH_SHORTINT ] := EmitOP_PUSH_INT_64; + EmitList[ - OP_PUSH_INT_IMM ] := EmitOP_PUSH_INT_IMM_64; + EmitList[ - OP_PUSH_INT ] := EmitOP_PUSH_INT_64; + EmitList[ - OP_PUSH_PTR ] := EmitOP_PUSH_INT_64; + EmitList[ - OP_PUSH_INST ] := EmitOP_PUSH_INST_64; + EmitList[ - OP_PUSH_CLSREF ] := EmitOP_PUSH_CLSREF_64; + EmitList[ - OP_UPDATE_INSTANCE ] := EmitOP_UPDATE_INSTANCE_64; + EmitList[ - OP_CLEAR_EDX ] := EmitOP_CLEAR_EDX_64; + EmitList[ - OP_PUSH_DYNARRAY ] := EmitOP_PUSH_DYNARRAY_64; + EmitList[ - OP_PUSH_OPENARRAY ] := EmitOP_PUSH_OPENARRAY_64; + EmitList[ - OP_PUSH_DATA ] := EmitOP_PUSH_DATA_64; + EmitList[ - OP_PUSH_EVENT ] := EmitOP_PUSH_EVENT_64; + EmitList[ - OP_PUSH_INT64 ] := EmitOP_PUSH_INT64; + EmitList[ - OP_PUSH_INT64 ] := EmitOP_PUSH_INT_64; + EmitList[ - OP_PUSH_DOUBLE ] := EmitOP_PUSH_DOUBLE_64; + EmitList[ - OP_PUSH_CURRENCY ] := EmitOP_PUSH_INT_64; + EmitList[ - OP_PUSH_SINGLE ] := EmitOP_PUSH_SINGLE_64; + EmitList[ - OP_PUSH_EXTENDED ] := EmitOP_PUSH_DOUBLE_64; + EmitList[ - OP_PUSH_ANSISTRING ] := EmitOP_PUSH_ANSISTRING_64; + EmitList[ - OP_PUSH_WIDESTRING ] := EmitOP_PUSH_WIDESTRING_64; + EmitList[ - OP_PUSH_UNICSTRING ] := EmitOP_PUSH_UNICSTRING_64; + EmitList[ - OP_PUSH_SHORTSTRING ] := EmitOP_PUSH_SHORTSTRING_64; + EmitList[ - OP_PUSH_PANSICHAR_IMM ] := EmitOP_PUSH_PANSICHAR_IMM_64; + EmitList[ - OP_PUSH_PWIDECHAR_IMM ] := EmitOP_PUSH_PWIDECHAR_IMM_64; + EmitList[ - OP_BEGIN_CALL ] := EmitOP_BEGIN_CALL_64; + EmitList[ - OP_CALL ] := EmitOP_CALL_64; + EmitList[ - OP_INIT_SUB ] := EmitOP_INIT_SUB_64; + EmitList[ - OP_END_SUB ] := EmitOP_END_SUB_64; + EmitList[ - OP_FIN_SUB ] := EmitOP_FIN_SUB_64; + EmitList[ - OP_EPILOGUE_SUB ] := EmitPCodeOperator; + EmitList[ - OP_BEGIN_GLOBAL_BLOCK ] := EmitPCodeOperator; + EmitList[ - OP_EPILOGUE_GLOBAL_BLOCK ] := EmitPCodeOperator; + EmitList[ - OP_END_GLOBAL_BLOCK ] := EmitPCodeOperator; + EmitList[ - OP_EXTRA_BYTECODE ] := EmitPCodeOperator; + EmitList[ - OP_RET ] := EmitOP_RET_64; + EmitList[ - OP_FIELD ] := EmitOP_FIELD_64; + EmitList[ - OP_GET_COMPONENT ] := EmitOP_GET_COMPONENT_64; + EmitList[ - OP_ELEM ] := EmitOP_ELEM_64; + EmitList[ - OP_PRINT_EX ] := EmitOP_PRINT_EX_64; + EmitList[ - OP_TO_FW_OBJECT ] := EmitOP_TO_FW_OBJECT_64; + EmitList[ - OP_PUSH_EBP ] := EmitOP_PUSH_EBP_64; + EmitList[ - OP_POP ] := EmitOP_POP_64; + EmitList[ - OP_SAVE_REGS ] := EmitOP_SAVE_REGS_64; + EmitList[ - OP_RESTORE_REGS ] := EmitOP_RESTORE_REGS_64; + + EmitList[ - OP_INT_TO_INT64 ] := EmitOP_INT_TO_INT64_64; + EmitList[ - OP_BYTE_TO_INT64 ] := EmitOP_BYTE_TO_INT64_64; + EmitList[ - OP_WORD_TO_INT64 ] := EmitOP_WORD_TO_INT64_64; + EmitList[ - OP_CARDINAL_TO_INT64 ] := EmitOP_CARDINAL_TO_INT64_64; + EmitList[ - OP_SMALLINT_TO_INT64 ] := EmitOP_SMALLINT_TO_INT64_64; + EmitList[ - OP_SHORTINT_TO_INT64 ] := EmitOP_SHORTINT_TO_INT64_64; + EmitList[ - OP_INT_FROM_INT64 ] := EmitOP_INT_FROM_INT64_64; + EmitList[ - OP_BYTE_FROM_INT64 ] := EmitOP_BYTE_FROM_INT64_64; + EmitList[ - OP_WORD_FROM_INT64 ] := EmitOP_WORD_FROM_INT64_64; + EmitList[ - OP_CARDINAL_FROM_INT64 ] := EmitOP_CARDINAL_FROM_INT64_64; + EmitList[ - OP_SMALLINT_FROM_INT64 ] := EmitOP_SMALLINT_FROM_INT64_64; + EmitList[ - OP_SHORTINT_FROM_INT64 ] := EmitOP_SHORTINT_FROM_INT64_64; + + EmitList[ - OP_INT_TO_UINT64 ] := EmitOP_INT_TO_INT64_64; + EmitList[ - OP_BYTE_TO_UINT64 ] := EmitOP_BYTE_TO_INT64_64; + EmitList[ - OP_WORD_TO_UINT64 ] := EmitOP_WORD_TO_INT64_64; + EmitList[ - OP_CARDINAL_TO_UINT64 ] := EmitOP_CARDINAL_TO_INT64_64; + EmitList[ - OP_SMALLINT_TO_UINT64 ] := EmitOP_SMALLINT_TO_INT64_64; + EmitList[ - OP_SHORTINT_TO_UINT64 ] := EmitOP_SHORTINT_TO_INT64_64; + EmitList[ - OP_INT_FROM_UINT64 ] := EmitOP_INT_FROM_INT64_64; + EmitList[ - OP_BYTE_FROM_UINT64 ] := EmitOP_BYTE_FROM_INT64_64; + EmitList[ - OP_WORD_FROM_UINT64 ] := EmitOP_WORD_FROM_INT64_64; + EmitList[ - OP_CARDINAL_FROM_UINT64 ] := EmitOP_CARDINAL_FROM_INT64_64; + EmitList[ - OP_SMALLINT_FROM_UINT64 ] := EmitOP_SMALLINT_FROM_INT64_64; + EmitList[ - OP_SHORTINT_FROM_UINT64 ] := EmitOP_SHORTINT_FROM_INT64_64; + + EmitList[ - OP_INT_TO_DOUBLE ] := EmitOP_INT_TO_DOUBLE_64; + EmitList[ - OP_INT64_TO_DOUBLE ] := EmitOP_INT64_TO_DOUBLE_64; + EmitList[ - OP_UINT64_TO_DOUBLE ] := EmitOP_INT64_TO_DOUBLE_64; + EmitList[ - OP_INT_TO_SINGLE ] := EmitOP_INT_TO_SINGLE_64; + EmitList[ - OP_INT64_TO_SINGLE ] := EmitOP_INT64_TO_SINGLE_64; + EmitList[ - OP_UINT64_TO_SINGLE ] := EmitOP_INT64_TO_SINGLE_64; + EmitList[ - OP_INT_TO_EXTENDED ] := EmitOP_INT_TO_EXTENDED_64; + EmitList[ - OP_INT64_TO_EXTENDED ] := EmitOP_INT64_TO_EXTENDED_64; + EmitList[ - OP_UINT64_TO_EXTENDED ] := EmitOP_INT64_TO_EXTENDED_64; + EmitList[ - OP_MULT_INT64 ] := EmitOP_MULT_INT64_64; + EmitList[ - OP_IDIV_INT64 ] := EmitOP_IDIV_INT64_64; + EmitList[ - OP_MOD_INT64 ] := EmitOP_MOD_INT64_64; + EmitList[ - OP_SHL_INT64 ] := EmitOP_SHL_INT64_64; + EmitList[ - OP_SHR_INT64 ] := EmitOP_SHR_INT64_64; + EmitList[ - OP_ABS_INT64 ] := EmitOP_ABS_INT64_64; + EmitList[ - OP_CURRENCY_TO_EXTENDED ] := EmitOP_CURRENCY_TO_EXTENDED_64; + EmitList[ - OP_CURRENCY_TO_SINGLE ] := EmitOP_CURRENCY_TO_SINGLE_64; + EmitList[ - OP_DOUBLE_TO_SINGLE ] := EmitOP_DOUBLE_TO_SINGLE_64; + EmitList[ - OP_DOUBLE_TO_EXTENDED ] := EmitOP_DOUBLE_TO_EXTENDED_64; + EmitList[ - OP_SINGLE_TO_DOUBLE ] := EmitOP_SINGLE_TO_DOUBLE_64; + EmitList[ - OP_CURRENCY_TO_DOUBLE ] := EmitOP_CURRENCY_TO_DOUBLE_64; + EmitList[ - OP_SINGLE_TO_EXTENDED ] := EmitOP_SINGLE_TO_EXTENDED_64; + EmitList[ - OP_EXTENDED_TO_DOUBLE ] := EmitOP_EXTENDED_TO_DOUBLE_64; + EmitList[ - OP_EXTENDED_TO_SINGLE ] := EmitOP_EXTENDED_TO_SINGLE_64; + EmitList[ - OP_ADDRESS ] := EmitOP_ADDRESS_64; + EmitList[ - OP_TERMINAL ] := EmitOP_TERMINAL_64; + EmitList[ - OP_ADDRESS_PROG ] := EmitOP_ADDRESS_PROG_64; + EmitList[ - OP_ASSIGN_PROG ] := EmitOP_ASSIGN_PROG_64; + EmitList[ - OP_SET_INCLUDE ] := EmitOP_SET_INCLUDE_64; + EmitList[ - OP_SET_INCLUDE_INTERVAL ] := EmitOP_SET_INCLUDE_INTERVAL_64; + EmitList[ - OP_SET_EXCLUDE ] := EmitOP_SET_EXCLUDE_64; + EmitList[ - OP_SET_UNION ] := EmitOP_SET_UNION_64; + EmitList[ - OP_SET_DIFFERENCE ] := EmitOP_SET_DIFFERENCE_64; + EmitList[ - OP_SET_INTERSECTION ] := EmitOP_SET_INTERSECTION_64; + EmitList[ - OP_SET_SUBSET ] := EmitOP_SET_SUBSET_64; + EmitList[ - OP_SET_SUPERSET ] := EmitOP_SET_SUPERSET_64; + EmitList[ - OP_SET_EQUALITY ] := EmitOP_SET_EQUALITY_64; + EmitList[ - OP_SET_INEQUALITY ] := EmitOP_SET_INEQUALITY_64; + EmitList[ - OP_SET_MEMBERSHIP ] := EmitOP_SET_MEMBERSHIP_64; + EmitList[ - OP_SET_ASSIGN ] := EmitOP_SET_ASSIGN_64; + EmitList[ - OP_SET_COUNTER_ASSIGN ] := EmitOP_SET_COUNTER_ASSIGN_64; + EmitList[ - OP_ERR_ABSTRACT ] := EmitOP_ERR_ABSTRACT_64; + EmitList[ - OP_VAR_FROM_TVALUE ] := EmitOP_VAR_FROM_TVALUE_64; + EmitList[ - OP_ANSISTRING_FROM_PANSICHAR ] := EmitOP_ANSISTRING_FROM_PANSICHAR_64; + EmitList[ - OP_ANSISTRING_FROM_PWIDECHAR ] := EmitOP_ANSISTRING_FROM_PWIDECHAR_64; + EmitList[ - OP_ANSISTRING_FROM_ANSICHAR ] := EmitOP_ANSISTRING_FROM_ANSICHAR_64; + EmitList[ - OP_ASSIGN_ANSISTRING ] := EmitOP_ASSIGN_ANSISTRING_64; + EmitList[ - OP_ASSIGN_SHORTSTRING ] := EmitOP_ASSIGN_SHORTSTRING_64; + EmitList[ - OP_ASSIGN_WIDESTRING ] := EmitOP_ASSIGN_WIDESTRING_64; + EmitList[ - OP_ASSIGN_UNICSTRING ] := EmitOP_ASSIGN_UNICSTRING_64; + EmitList[ - OP_ADD_ANSISTRING ] := EmitOP_ADD_ANSISTRING_64; + EmitList[ - OP_ADD_SHORTSTRING ] := EmitOP_ADD_SHORTSTRING_64; + EmitList[ - OP_ADD_WIDESTRING ] := EmitOP_ADD_WIDESTRING_64; + EmitList[ - OP_ADD_UNICSTRING ] := EmitOP_ADD_UNICSTRING_64; + EmitList[ - OP_ANSISTRING_CLR ] := EmitOP_ANSISTRING_CLR_64; + EmitList[ - OP_WIDESTRING_CLR ] := EmitOP_WIDESTRING_CLR_64; + EmitList[ - OP_UNICSTRING_CLR ] := EmitOP_UNICSTRING_CLR_64; + EmitList[ - OP_INTERFACE_CLR ] := EmitOP_INTERFACE_CLR_64; + EmitList[ - OP_STRUCTURE_CLR ] := EmitOP_STRUCTURE_CLR_64; + EmitList[ - OP_CLASS_CLR ] := EmitOP_CLASS_CLR_64; + EmitList[ - OP_STRUCTURE_ADDREF ] := EmitOP_STRUCTURE_ADDREF_64; + EmitList[ - OP_ADDREF ] := EmitOP_ADDREF_64; + EmitList[ - OP_DYNARRAY_CLR ] := EmitOP_DYNARRAY_CLR_64; + EmitList[ - OP_DYNARRAY_HIGH ] := EmitOP_DYNARRAY_HIGH_64; + EmitList[ - OP_DYNARRAY_ASSIGN ] := EmitOP_DYNARRAY_ASSIGN_64; + EmitList[ - OP_CREATE_EMPTY_DYNARRAY ] := EmitOP_CREATE_EMPTY_DYNARRAY_64; + EmitList[ - OP_ASSIGN_TVarRec ] := EmitOP_ASSIGN_TVarRec_64; + EmitList[ - OP_SHORTSTRING_FROM_PANSICHAR_LITERAL ] := EmitOP_SHORTSTRING_FROM_PANSICHAR_LITERAL_64; + EmitList[ - OP_SHORTSTRING_FROM_PWIDECHAR_LITERAL ] := EmitOP_SHORTSTRING_FROM_PWIDECHAR_LITERAL_64; + EmitList[ - OP_SHORTSTRING_FROM_ANSICHAR ] := EmitOP_SHORTSTRING_FROM_ANSICHAR_64; + EmitList[ - OP_SHORTSTRING_FROM_WIDECHAR ] := EmitOP_SHORTSTRING_FROM_WIDECHAR_64; + EmitList[ - OP_SHORTSTRING_FROM_ANSISTRING ] := EmitOP_SHORTSTRING_FROM_ANSISTRING_64; + EmitList[ - OP_SHORTSTRING_FROM_WIDESTRING ] := EmitOP_SHORTSTRING_FROM_WIDESTRING_64; + EmitList[ - OP_UNICSTRING_FROM_WIDESTRING ] := EmitOP_UNICSTRING_FROM_WIDESTRING_64; + EmitList[ - OP_SHORTSTRING_FROM_UNICSTRING ] := EmitOP_SHORTSTRING_FROM_UNICSTRING_64; + EmitList[ - OP_ANSISTRING_FROM_SHORTSTRING ] := EmitOP_ANSISTRING_FROM_SHORTSTRING_64; + EmitList[ - OP_EQ_ANSISTRING ] := EmitOP_EQ_ANSISTRING_64; + EmitList[ - OP_NE_ANSISTRING ] := EmitOP_NE_ANSISTRING_64; + EmitList[ - OP_EQ_SHORTSTRING ] := EmitOP_EQ_SHORTSTRING_64; + EmitList[ - OP_NE_SHORTSTRING ] := EmitOP_NE_SHORTSTRING_64; + EmitList[ - OP_EQ_WIDESTRING ] := EmitOP_EQ_WIDESTRING_64; + EmitList[ - OP_EQ_UNICSTRING ] := EmitOP_EQ_UNICSTRING_64; + EmitList[ - OP_NE_WIDESTRING ] := EmitOP_NE_WIDESTRING_64; + EmitList[ - OP_NE_UNICSTRING ] := EmitOP_NE_UNICSTRING_64; + EmitList[ - OP_GT_ANSISTRING ] := EmitOP_GT_ANSISTRING_64; + EmitList[ - OP_GE_ANSISTRING ] := EmitOP_GE_ANSISTRING_64; + EmitList[ - OP_LT_ANSISTRING ] := EmitOP_LT_ANSISTRING_64; + EmitList[ - OP_LE_ANSISTRING ] := EmitOP_LE_ANSISTRING_64; + EmitList[ - OP_GT_SHORTSTRING ] := EmitOP_GT_SHORTSTRING_64; + EmitList[ - OP_GE_SHORTSTRING ] := EmitOP_GE_SHORTSTRING_64; + EmitList[ - OP_LT_SHORTSTRING ] := EmitOP_LT_SHORTSTRING_64; + EmitList[ - OP_LE_SHORTSTRING ] := EmitOP_LE_SHORTSTRING_64; + EmitList[ - OP_GT_WIDESTRING ] := EmitOP_GT_WIDESTRING_64; + EmitList[ - OP_GE_WIDESTRING ] := EmitOP_GE_WIDESTRING_64; + EmitList[ - OP_LT_WIDESTRING ] := EmitOP_LT_WIDESTRING_64; + EmitList[ - OP_LE_WIDESTRING ] := EmitOP_LE_WIDESTRING_64; + EmitList[ - OP_GT_UNICSTRING ] := EmitOP_GT_UNICSTRING_64; + EmitList[ - OP_GE_UNICSTRING ] := EmitOP_GE_UNICSTRING_64; + EmitList[ - OP_LT_UNICSTRING ] := EmitOP_LT_UNICSTRING_64; + EmitList[ - OP_LE_UNICSTRING ] := EmitOP_LE_UNICSTRING_64; + EmitList[ - OP_SHORTSTRING_HIGH ] := EmitOP_SHORTSTRING_HIGH_64; + EmitList[ - OP_LOCK_VARRAY ] := EmitOP_LOCK_VARRAY_64; + EmitList[ - OP_UNLOCK_VARRAY ] := EmitOP_UNLOCK_VARRAY_64; + EmitList[ - OP_VARIANT_CLR ] := EmitOP_VARIANT_CLR_64; + EmitList[ - OP_WIDESTRING_FROM_PANSICHAR_LITERAL ] := EmitOP_WIDESTRING_FROM_PANSICHAR_LITERAL_64; + EmitList[ - OP_WIDESTRING_FROM_PWIDECHAR_LITERAL ] := EmitOP_WIDESTRING_FROM_PWIDECHAR_LITERAL_64; + EmitList[ - OP_WIDESTRING_FROM_ANSICHAR ] := EmitOP_WIDESTRING_FROM_ANSICHAR_64; + EmitList[ - OP_WIDESTRING_FROM_WIDECHAR ] := EmitOP_WIDESTRING_FROM_WIDECHAR_64; + EmitList[ - OP_ANSISTRING_FROM_WIDECHAR ] := EmitOP_ANSISTRING_FROM_WIDECHAR_64; + EmitList[ - OP_WIDESTRING_FROM_WIDECHAR_LITERAL ] := EmitOP_WIDESTRING_FROM_WIDECHAR_LITERAL_64; + EmitList[ - OP_WIDESTRING_FROM_ANSISTRING ] := EmitOP_WIDESTRING_FROM_ANSISTRING_64; + EmitList[ - OP_UNICSTRING_FROM_ANSISTRING ] := EmitOP_UNICSTRING_FROM_ANSISTRING_64; + EmitList[ - OP_WIDESTRING_FROM_SHORTSTRING ] := EmitOP_WIDESTRING_FROM_SHORTSTRING_64; + EmitList[ - OP_WIDESTRING_FROM_UNICSTRING ] := EmitOP_WIDESTRING_FROM_UNICSTRING_64; + EmitList[ - OP_UNICSTRING_FROM_SHORTSTRING ] := EmitOP_UNICSTRING_FROM_SHORTSTRING_64; + EmitList[ - OP_ANSISTRING_FROM_WIDESTRING ] := EmitOP_ANSISTRING_FROM_WIDESTRING_64; + EmitList[ - OP_ANSISTRING_FROM_UNICSTRING ] := EmitOP_ANSISTRING_FROM_UNICSTRING_64; + EmitList[ - OP_UNICSTRING_FROM_PANSICHAR_LITERAL ] := EmitOP_UNICSTRING_FROM_PANSICHAR_LITERAL_64; + EmitList[ - OP_UNICSTRING_FROM_PWIDECHAR_LITERAL ] := EmitOP_UNICSTRING_FROM_PWIDECHAR_LITERAL_64; + EmitList[ - OP_UNICSTRING_FROM_ANSICHAR ] := EmitOP_UNICSTRING_FROM_ANSICHAR_64; + EmitList[ - OP_UNICSTRING_FROM_WIDECHAR ] := EmitOP_UNICSTRING_FROM_WIDECHAR_64; + EmitList[ - OP_UNICSTRING_FROM_WIDECHAR_LITERAL ] := EmitOP_UNICSTRING_FROM_WIDECHAR_LITERAL_64; + EmitList[ - OP_VARIANT_FROM_ANSICHAR ] := EmitOP_VARIANT_FROM_ANSICHAR_64; + EmitList[ - OP_VARIANT_FROM_INT ] := EmitOP_VARIANT_FROM_INT_64; + EmitList[ - OP_VARIANT_FROM_INT64 ] := EmitOP_VARIANT_FROM_INT64_64; + EmitList[ - OP_VARIANT_FROM_BYTE ] := EmitOP_VARIANT_FROM_BYTE_64; + EmitList[ - OP_VARIANT_FROM_BOOL ] := EmitOP_VARIANT_FROM_BOOL_64; + EmitList[ - OP_VARIANT_FROM_WORD ] := EmitOP_VARIANT_FROM_WORD_64; + EmitList[ - OP_VARIANT_FROM_CARDINAL ] := EmitOP_VARIANT_FROM_CARDINAL_64; + EmitList[ - OP_VARIANT_FROM_SMALLINT ] := EmitOP_VARIANT_FROM_SMALLINT_64; + EmitList[ - OP_VARIANT_FROM_SHORTINT ] := EmitOP_VARIANT_FROM_SHORTINT_64; + EmitList[ - OP_VARIANT_FROM_DOUBLE ] := EmitOP_VARIANT_FROM_DOUBLE_64; + EmitList[ - OP_VARIANT_FROM_CURRENCY ] := EmitOP_VARIANT_FROM_CURRENCY_64; + EmitList[ - OP_VARIANT_FROM_SINGLE ] := EmitOP_VARIANT_FROM_SINGLE_64; + EmitList[ - OP_VARIANT_FROM_EXTENDED ] := EmitOP_VARIANT_FROM_EXTENDED_64; + EmitList[ - OP_VARIANT_FROM_INTERFACE ] := EmitOP_VARIANT_FROM_INTERFACE_64; + EmitList[ - OP_VARIANT_FROM_PANSICHAR_LITERAL ] := EmitOP_VARIANT_FROM_PANSICHAR_LITERAL_64; + EmitList[ - OP_VARIANT_FROM_PWIDECHAR_LITERAL ] := EmitOP_VARIANT_FROM_PWIDECHAR_LITERAL_64; + EmitList[ - OP_VARIANT_FROM_ANSISTRING ] := EmitOP_VARIANT_FROM_ANSISTRING_64; + EmitList[ - OP_VARIANT_FROM_WIDESTRING ] := EmitOP_VARIANT_FROM_WIDESTRING_64; + EmitList[ - OP_VARIANT_FROM_UNICSTRING ] := EmitOP_VARIANT_FROM_UNICSTRING_64; + EmitList[ - OP_VARIANT_FROM_SHORTSTRING ] := EmitOP_VARIANT_FROM_SHORTSTRING_64; + EmitList[ - OP_VARIANT_FROM_WIDECHAR ] := EmitOP_VARIANT_FROM_WIDECHAR_64; + EmitList[ - OP_VARIANT_FROM_WIDECHAR_LITERAL ] := EmitOP_VARIANT_FROM_WIDECHAR_LITERAL_64; + EmitList[ - OP_OLEVARIANT_FROM_VARIANT ] := EmitOP_OLEVARIANT_FROM_VARIANT_64; + EmitList[ - OP_OLEVARIANT_FROM_ANSICHAR ] := EmitOP_OLEVARIANT_FROM_ANSICHAR_64; + EmitList[ - OP_OLEVARIANT_FROM_INT ] := EmitOP_OLEVARIANT_FROM_INT_64; + EmitList[ - OP_OLEVARIANT_FROM_INT64 ] := EmitOP_OLEVARIANT_FROM_INT64_64; + EmitList[ - OP_OLEVARIANT_FROM_BYTE ] := EmitOP_OLEVARIANT_FROM_BYTE_64; + EmitList[ - OP_OLEVARIANT_FROM_BOOL ] := EmitOP_OLEVARIANT_FROM_BOOL_64; + EmitList[ - OP_OLEVARIANT_FROM_WORD ] := EmitOP_OLEVARIANT_FROM_WORD_64; + EmitList[ - OP_OLEVARIANT_FROM_CARDINAL ] := EmitOP_OLEVARIANT_FROM_CARDINAL_64; + EmitList[ - OP_OLEVARIANT_FROM_SMALLINT ] := EmitOP_OLEVARIANT_FROM_SMALLINT_64; + EmitList[ - OP_OLEVARIANT_FROM_SHORTINT ] := EmitOP_OLEVARIANT_FROM_SHORTINT_64; + EmitList[ - OP_OLEVARIANT_FROM_DOUBLE ] := EmitOP_OLEVARIANT_FROM_DOUBLE_64; + EmitList[ - OP_OLEVARIANT_FROM_CURRENCY ] := EmitOP_OLEVARIANT_FROM_CURRENCY_64; + EmitList[ - OP_OLEVARIANT_FROM_SINGLE ] := EmitOP_OLEVARIANT_FROM_SINGLE_64; + EmitList[ - OP_OLEVARIANT_FROM_EXTENDED ] := EmitOP_OLEVARIANT_FROM_EXTENDED_64; + EmitList[ - OP_OLEVARIANT_FROM_INTERFACE ] := EmitOP_OLEVARIANT_FROM_INTERFACE_64; + EmitList[ - OP_OLEVARIANT_FROM_PANSICHAR_LITERAL ] := EmitOP_OLEVARIANT_FROM_PANSICHAR_LITERAL_64; + EmitList[ - OP_OLEVARIANT_FROM_PWIDECHAR_LITERAL ] := EmitOP_OLEVARIANT_FROM_PWIDECHAR_LITERAL_64; + EmitList[ - OP_OLEVARIANT_FROM_ANSISTRING ] := EmitOP_OLEVARIANT_FROM_ANSISTRING_64; + EmitList[ - OP_OLEVARIANT_FROM_WIDESTRING ] := EmitOP_OLEVARIANT_FROM_WIDESTRING_64; + EmitList[ - OP_OLEVARIANT_FROM_UNICSTRING ] := EmitOP_OLEVARIANT_FROM_UNICSTRING_64; + EmitList[ - OP_OLEVARIANT_FROM_SHORTSTRING ] := EmitOP_OLEVARIANT_FROM_SHORTSTRING_64; + EmitList[ - OP_OLEVARIANT_FROM_WIDECHAR ] := EmitOP_OLEVARIANT_FROM_WIDECHAR_64; + EmitList[ - OP_OLEVARIANT_FROM_WIDECHAR_LITERAL ] := EmitOP_OLEVARIANT_FROM_WIDECHAR_LITERAL_64; + EmitList[ - OP_ANSISTRING_FROM_INT ] := EmitOP_ANSISTRING_FROM_INT_64; + EmitList[ - OP_ANSISTRING_FROM_DOUBLE ] := EmitOP_ANSISTRING_FROM_DOUBLE_64; + EmitList[ - OP_ANSISTRING_FROM_SINGLE ] := EmitOP_ANSISTRING_FROM_SINGLE_64; + EmitList[ - OP_ANSISTRING_FROM_EXTENDED ] := EmitOP_ANSISTRING_FROM_EXTENDED_64; + EmitList[ - OP_ANSISTRING_FROM_BOOLEAN ] := EmitOP_ANSISTRING_FROM_BOOLEAN_64; + EmitList[ - OP_UNICSTRING_FROM_INT ] := EmitOP_UNICSTRING_FROM_INT_64; + EmitList[ - OP_UNICSTRING_FROM_DOUBLE ] := EmitOP_UNICSTRING_FROM_DOUBLE_64; + EmitList[ - OP_UNICSTRING_FROM_SINGLE ] := EmitOP_UNICSTRING_FROM_SINGLE_64; + EmitList[ - OP_UNICSTRING_FROM_EXTENDED ] := EmitOP_UNICSTRING_FROM_EXTENDED_64; + EmitList[ - OP_UNICSTRING_FROM_BOOLEAN ] := EmitOP_UNICSTRING_FROM_BOOLEAN_64; + EmitList[ - OP_JS_FUNC_OBJ_FROM_VARIANT ] := EmitOP_JS_FUNC_OBJ_FROM_VARIANT_64; + EmitList[ - OP_ANSICHAR_FROM_VARIANT ] := EmitOP_ANSICHAR_FROM_VARIANT_64; + EmitList[ - OP_WIDECHAR_FROM_VARIANT ] := EmitOP_WIDECHAR_FROM_VARIANT_64; + EmitList[ - OP_ANSISTRING_FROM_VARIANT ] := EmitOP_ANSISTRING_FROM_VARIANT_64; + EmitList[ - OP_WIDESTRING_FROM_VARIANT ] := EmitOP_WIDESTRING_FROM_VARIANT_64; + EmitList[ - OP_UNICSTRING_FROM_VARIANT ] := EmitOP_UNICSTRING_FROM_VARIANT_64; + EmitList[ - OP_SHORTSTRING_FROM_VARIANT ] := EmitOP_SHORTSTRING_FROM_VARIANT_64; + EmitList[ - OP_DOUBLE_FROM_VARIANT ] := EmitOP_DOUBLE_FROM_VARIANT_64; + EmitList[ - OP_CURRENCY_FROM_VARIANT ] := EmitOP_CURRENCY_FROM_VARIANT_64; + EmitList[ - OP_SINGLE_FROM_VARIANT ] := EmitOP_SINGLE_FROM_VARIANT_64; + EmitList[ - OP_EXTENDED_FROM_VARIANT ] := EmitOP_EXTENDED_FROM_VARIANT_64; + EmitList[ - OP_INT_FROM_VARIANT ] := EmitOP_INT_FROM_VARIANT_64; + EmitList[ - OP_INT64_FROM_VARIANT ] := EmitOP_INT64_FROM_VARIANT_64; + EmitList[ - OP_UINT64_FROM_VARIANT ] := EmitOP_INT64_FROM_VARIANT_64; + EmitList[ - OP_BYTE_FROM_VARIANT ] := EmitOP_BYTE_FROM_VARIANT_64; + EmitList[ - OP_WORD_FROM_VARIANT ] := EmitOP_WORD_FROM_VARIANT_64; + EmitList[ - OP_CARDINAL_FROM_VARIANT ] := EmitOP_CARDINAL_FROM_VARIANT_64; + EmitList[ - OP_BOOL_FROM_VARIANT ] := EmitOP_BOOL_FROM_VARIANT_64; + EmitList[ - OP_BYTEBOOL_FROM_VARIANT ] := EmitOP_BYTEBOOL_FROM_VARIANT_64; + EmitList[ - OP_WORDBOOL_FROM_VARIANT ] := EmitOP_WORDBOOL_FROM_VARIANT_64; + EmitList[ - OP_LONGBOOL_FROM_VARIANT ] := EmitOP_LONGBOOL_FROM_VARIANT_64; + EmitList[ - OP_SMALLINT_FROM_VARIANT ] := EmitOP_SMALLINT_FROM_VARIANT_64; + EmitList[ - OP_SHORTINT_FROM_VARIANT ] := EmitOP_SHORTINT_FROM_VARIANT_64; + EmitList[ - OP_BOOL_FROM_BYTEBOOL ] := EmitOP_BOOL_FROM_BYTEBOOL_64; + EmitList[ - OP_BOOL_FROM_WORDBOOL ] := EmitOP_BOOL_FROM_WORDBOOL_64; + EmitList[ - OP_BOOL_FROM_LONGBOOL ] := EmitOP_BOOL_FROM_LONGBOOL_64; + EmitList[ - OP_NEG_VARIANT ] := EmitOP_NEG_VARIANT_64; + EmitList[ - OP_ABS_VARIANT ] := EmitOP_ABS_VARIANT_64; + EmitList[ - OP_NOT_VARIANT ] := EmitOP_NOT_VARIANT_64; + EmitList[ - OP_ADD_VARIANT ] := EmitOP_ADD_VARIANT_64; + EmitList[ - OP_SUB_VARIANT ] := EmitOP_SUB_VARIANT_64; + EmitList[ - OP_MULT_VARIANT ] := EmitOP_MULT_VARIANT_64; + EmitList[ - OP_DIV_VARIANT ] := EmitOP_DIV_VARIANT_64; + EmitList[ - OP_IDIV_VARIANT ] := EmitOP_IDIV_VARIANT_64; + EmitList[ - OP_MOD_VARIANT ] := EmitOP_MOD_VARIANT_64; + EmitList[ - OP_SHL_VARIANT ] := EmitOP_SHL_VARIANT_64; + EmitList[ - OP_SHR_VARIANT ] := EmitOP_SHR_VARIANT_64; + EmitList[ - OP_AND_VARIANT ] := EmitOP_AND_VARIANT_64; + EmitList[ - OP_OR_VARIANT ] := EmitOP_OR_VARIANT_64; + EmitList[ - OP_XOR_VARIANT ] := EmitOP_XOR_VARIANT_64; + EmitList[ - OP_LT_VARIANT ] := EmitOP_LT_VARIANT_64; + EmitList[ - OP_LE_VARIANT ] := EmitOP_LE_VARIANT_64; + EmitList[ - OP_GT_VARIANT ] := EmitOP_GT_VARIANT_64; + EmitList[ - OP_GE_VARIANT ] := EmitOP_GE_VARIANT_64; + EmitList[ - OP_EQ_VARIANT ] := EmitOP_EQ_VARIANT_64; + EmitList[ - OP_NE_VARIANT ] := EmitOP_NE_VARIANT_64; + EmitList[ - OP_CURRENCY_FROM_INT ] := EmitOP_CURRENCY_FROM_INT_64; + EmitList[ - OP_CURRENCY_FROM_INT64 ] := EmitOP_CURRENCY_FROM_INT64_64; + EmitList[ - OP_CURRENCY_FROM_UINT64 ] := EmitOP_CURRENCY_FROM_INT64_64; + EmitList[ - OP_CURRENCY_FROM_REAL ] := EmitOP_CURRENCY_FROM_REAL_64; + EmitList[ - OP_VARIANT_FROM_CLASS ] := EmitOP_VARIANT_FROM_CLASS_64; + EmitList[ - OP_VARIANT_FROM_POINTER ] := EmitOP_VARIANT_FROM_POINTER_64; + EmitList[ - OP_CLASS_FROM_VARIANT ] := EmitOP_CLASS_FROM_VARIANT_64; + EmitList[ - OP_INTERFACE_FROM_CLASS ] := EmitOP_INTERFACE_FROM_CLASS_64; + EmitList[ - OP_INTERFACE_CAST ] := EmitOP_INTERFACE_CAST_64; + EmitList[ - OP_ASSIGN_VARIANT ] := EmitOP_ASSIGN_VARIANT_64; + EmitList[ - OP_ASSIGN_OLEVARIANT ] := EmitOP_ASSIGN_OLEVARIANT_64; + EmitList[ - OP_ASSIGN_CLASS ] := EmitOP_ASSIGN_CLASS_64; + EmitList[ - OP_VARARRAY_GET ] := EmitOP_VARARRAY_GET_64; + EmitList[ - OP_VARARRAY_PUT ] := EmitOP_VARARRAY_PUT_64; + EmitList[ - OP_OLE_GET ] := EmitOP_OLE_GET_64; + EmitList[ - OP_OLE_SET ] := EmitOP_OLE_SET_64; + EmitList[ - OP_OLE_PARAM ] := EmitOP_OLE_PARAM_64; + EmitList[ - OP_IS ] := EmitOP_IS_64; + EmitList[ - OP_TYPEINFO ] := EmitOP_TYPEINFO_64; + EmitList[ - OP_ADD_TYPEINFO ] := EmitPCodeOperator; + EmitList[ - OP_PUSH_CONTEXT ] := EmitOP_PUSH_CONTEXT_64; + EmitList[ - OP_POP_CONTEXT ] := EmitOP_POP_CONTEXT_64; + EmitList[ - OP_FIND_CONTEXT ] := EmitOP_FIND_CONTEXT_64; + EmitList[ - OP_FIND_JS_FUNC ] := EmitOP_FIND_JS_FUNC_64; + EmitList[ - OP_GET_PROG ] := EmitOP_GET_PROG_64; + EmitList[ - OP_ONCREATE_HOST_OBJECT ] := EmitOP_ONCREATE_HOST_OBJECT_64; + EmitList[ - OP_ONDESTROY_HOST_OBJECT ] := EmitOP_ONDESTROY_HOST_OBJECT_64; + EmitList[ - OP_BEFORE_CALL_HOST ] := EmitOP_BEFORE_CALL_HOST_64; + EmitList[ - OP_AFTER_CALL_HOST ] := EmitOP_AFTER_CALL_HOST_64; + EmitList[ - OP_INIT_FWARRAY ] := EmitOP_INIT_FWARRAY_64; + EmitList[ - OP_ONCREATE_OBJECT ] := EmitOP_ONCREATE_OBJECT_64; + EmitList[ - OP_ON_AFTER_OBJECT_CREATION ] := EmitOP_ON_AFTER_OBJECT_CREATION_64; + EmitList[ - OP_CLASSNAME ] := EmitOP_CLASSNAME_64; + EmitList[ - OP_GET_DRTTI_PROP ] := EmitOP_GET_DRTTI_PROP_64; + EmitList[ - OP_SET_DRTTI_PROP ] := EmitOP_SET_DRTTI_PROP_64; + EmitList[ - OP_GET_ANSISTR_PROP ] := EmitOP_GET_ANSISTR_PROP_64; + EmitList[ - OP_SET_ANSISTR_PROP ] := EmitOP_SET_ANSISTR_PROP_64; + EmitList[ - OP_GET_WIDESTR_PROP ] := EmitOP_GET_WIDESTR_PROP_64; + EmitList[ - OP_SET_WIDESTR_PROP ] := EmitOP_SET_WIDESTR_PROP_64; + EmitList[ - OP_GET_UNICSTR_PROP ] := EmitOP_GET_UNICSTR_PROP_64; + EmitList[ - OP_SET_UNICSTR_PROP ] := EmitOP_SET_UNICSTR_PROP_64; + EmitList[ - OP_GET_ORD_PROP ] := EmitOP_GET_ORD_PROP_64; + EmitList[ - OP_SET_ORD_PROP ] := EmitOP_SET_ORD_PROP_64; + EmitList[ - OP_GET_INTERFACE_PROP ] := EmitOP_GET_INTERFACE_PROP_64; + EmitList[ - OP_SET_INTERFACE_PROP ] := EmitOP_SET_INTERFACE_PROP_64; + EmitList[ - OP_GET_SET_PROP ] := EmitOP_GET_SET_PROP_64; + EmitList[ - OP_SET_SET_PROP ] := EmitOP_SET_SET_PROP_64; + EmitList[ - OP_GET_FLOAT_PROP ] := EmitOP_GET_FLOAT_PROP_64; + EmitList[ - OP_SET_FLOAT_PROP ] := EmitOP_SET_FLOAT_PROP_64; + EmitList[ - OP_GET_VARIANT_PROP ] := EmitOP_GET_VARIANT_PROP_64; + EmitList[ - OP_SET_VARIANT_PROP ] := EmitOP_SET_VARIANT_PROP_64; + EmitList[ - OP_GET_INT64_PROP ] := EmitOP_GET_INT64_PROP_64; + EmitList[ - OP_SET_INT64_PROP ] := EmitOP_SET_INT64_PROP_64; + EmitList[ - OP_GET_EVENT_PROP ] := EmitOP_GET_EVENT_PROP_64; + EmitList[ - OP_SET_EVENT_PROP ] := EmitOP_SET_EVENT_PROP_64; + EmitList[ - OP_SET_EVENT_PROP2 ] := EmitOP_SET_EVENT_PROP2_64; + EmitList[ - OP_TRY_ON ] := EmitOP_TRY_ON_64; + EmitList[ - OP_EXCEPT_SEH ] := EmitOP_EXCEPT_SEH_64; + EmitList[ - OP_TRY_OFF ] := EmitOP_TRY_OFF_64; + EmitList[ - OP_FINALLY ] := EmitOP_FINALLY_64; + EmitList[ - OP_EXCEPT ] := EmitOP_EXCEPT_64; + EmitList[ - OP_EXCEPT_ON ] := EmitOP_EXCEPT_ON_64; + EmitList[ - OP_RAISE ] := EmitOP_RAISE_64; + EmitList[ - OP_EXIT ] := EmitOP_EXIT_64; + EmitList[ - OP_COND_RAISE ] := EmitOP_COND_RAISE_64; + EmitList[ - OP_BEGIN_EXCEPT_BLOCK ] := EmitOP_BEGIN_EXCEPT_BLOCK_64; + EmitList[ - OP_END_EXCEPT_BLOCK ] := EmitOP_END_EXCEPT_BLOCK_64; + EmitList[ - OP_OVERFLOW_CHECK ] := EmitOP_OVERFLOW_CHECK_64; + EmitList[ - OP_PAUSE ] := EmitOP_PAUSE_64; + EmitList[ - OP_CHECK_PAUSE ] := EmitOP_CHECK_PAUSE_64; + EmitList[ - OP_CHECK_PAUSE_LIGHT ] := EmitOP_CHECK_PAUSE_LIGHT_64; + EmitList[ - OP_HALT ] := EmitOP_HALT_64; + EmitList[ - OP_CREATE_OBJECT ] := EmitOP_CREATE_OBJECT_64; + EmitList[ - OP_DESTROY_OBJECT ] := EmitOP_DESTROY_OBJECT_64; + EmitList[ - OP_GET_VMT_ADDRESS ] := EmitOP_GET_VMT_ADDRESS_64; + EmitList[ - OP_SET_LENGTH ] := EmitOP_SET_LENGTH_64; + EmitList[ - OP_SET_LENGTH_EX ] := EmitOP_SET_LENGTH_EX_64; + EmitList[ - OP_PUSH_LENGTH ] := EmitPCodeOperator; + EmitList[ - OP_CREATE_METHOD ] := EmitOP_CREATE_METHOD_64; + EmitList[ - OP_DECLARE_TEMP_VAR ] := EmitPCodeOperator; + EmitList[ - OP_BEGIN_USING ] := EmitPCodeOperator; + EmitList[ - OP_END_USING ] := EmitPCodeOperator; + EmitList[ - OP_BEGIN_BLOCK ] := EmitPCodeOperator; + EmitList[ - OP_END_BLOCK ] := EmitPCodeOperator; + EmitList[ - OP_BEGIN_WITH ] := EmitPCodeOperator; + EmitList[ - OP_END_WITH ] := EmitPCodeOperator; + EmitList[ - OP_PARAM_CHANGED ] := EmitPCodeOperator; + EmitList[ - OP_BEGIN_SUB ] := EmitPCodeOperator; + EmitList[ - OP_BEGIN_CLASS_TYPE ] := EmitPCodeOperator; + EmitList[ - OP_END_CLASS_TYPE ] := EmitPCodeOperator; + EmitList[ - OP_BEGIN_RECORD_TYPE ] := EmitPCodeOperator; + EmitList[ - OP_END_RECORD_TYPE ] := EmitPCodeOperator; + EmitList[ - OP_BEGIN_HELPER_TYPE ] := EmitPCodeOperator; + EmitList[ - OP_END_HELPER_TYPE ] := EmitPCodeOperator; + EmitList[ - OP_ADD_ANCESTOR ] := EmitNothing; + EmitList[ - OP_INIT_PANSICHAR_LITERAL ] := EmitNothing; + EmitList[ - OP_INIT_PWIDECHAR_LITERAL ] := EmitNothing; + EmitList[ - OP_BEGIN_CRT_JS_FUNC_OBJECT ] := EmitOP_BEGIN_CRT_JS_FUNC_OBJECT_64; + EmitList[ - OP_END_CRT_JS_FUNC_OBJECT ] := EmitOP_END_CRT_JS_FUNC_OBJECT_64; + EmitList[ - OP_TO_JS_OBJECT ] := EmitOP_TO_JS_OBJECT_64; + EmitList[ - OP_JS_TYPEOF ] := EmitOP_JS_TYPEOF_64; + EmitList[ - OP_JS_VOID ] := EmitOP_JS_VOID_64; + EmitList[ - OP_GET_NEXTJSPROP ] := EmitOP_GET_NEXTJSPROP_64; + EmitList[ - OP_CLEAR_REFERENCES ] := EmitOP_CLEAR_REFERENCES_64; + EmitList[ - OP_DECLARE_LOCAL_VAR ] := EmitPCodeOperator; + EmitList[ - OP_LOAD_PROC ] := EmitPCodeOperator; + EmitList[ - OP_ADD_MESSAGE ] := EmitPCodeOperator; + EmitList[ - OP_BEGIN_ARRAY_TYPE ] := EmitPCodeOperator; + EmitList[ - OP_END_ARRAY_TYPE ] := EmitPCodeOperator; + EmitList[ - OP_BEGIN_SET_TYPE ] := EmitPCodeOperator; + EmitList[ - OP_END_SET_TYPE ] := EmitPCodeOperator; + EmitList[ - OP_BEGIN_ENUM_TYPE ] := EmitPCodeOperator; + EmitList[ - OP_END_ENUM_TYPE ] := EmitPCodeOperator; + EmitList[ - OP_BEGIN_SUBRANGE_TYPE ] := EmitPCodeOperator; + EmitList[ - OP_END_SUBRANGE_TYPE ] := EmitPCodeOperator; + EmitList[ - OP_BEGIN_POINTER_TYPE ] := EmitPCodeOperator; + EmitList[ - OP_END_POINTER_TYPE ] := EmitPCodeOperator; + EmitList[ - OP_BEGIN_CLASSREF_TYPE ] := EmitPCodeOperator; + EmitList[ - OP_END_CLASSREF_TYPE ] := EmitPCodeOperator; + EmitList[ - OP_BEGIN_DYNARRAY_TYPE ] := EmitPCodeOperator; + EmitList[ - OP_END_DYNARRAY_TYPE ] := EmitPCodeOperator; + EmitList[ - OP_BEGIN_SHORTSTRING_TYPE ] := EmitPCodeOperator; + EmitList[ - OP_END_SHORTSTRING_TYPE ] := EmitPCodeOperator; + EmitList[ - OP_BEGIN_INTERFACE_TYPE ] := EmitPCodeOperator; + EmitList[ - OP_END_INTERFACE_TYPE ] := EmitPCodeOperator; + EmitList[ - OP_BEGIN_TEXT ] := EmitPCodeOperator; + EmitList[ - OP_END_TEXT ] := EmitPCodeOperator; + EmitList[ - OP_WARNINGS_ON ] := EmitPCodeOperator; + EmitList[ - OP_WARNINGS_OFF ] := EmitPCodeOperator; + EmitList[ - OP_FRAMEWORK_ON ] := EmitPCodeOperator; + EmitList[ - OP_FRAMEWORK_OFF ] := EmitPCodeOperator; + EmitList[ - OP_DECL_SUB ] := EmitPCodeOperator; + EmitList[ - OP_DECLARE_MEMBER ] := EmitPCodeOperator; + EmitList[ - OP_ABSOLUTE ] := EmitPCodeOperator; + end; +{$ENDIF} +end; + +function TEmitter.IsLocalPos: Boolean; +begin + with TKernel(kernel) do + result := Code.IsLocalPos(Code.N); +end; + +function TEmitter.GetLanguage: Integer; +begin + with TKernel(kernel) do + result := Code[Code.N].Language; +end; + +function TEmitter.GetOperName: String; +begin + result := Operators[- R.Op]; +end; + +function TEmitter.Host1: Boolean; +begin + result := GetSymbolRec(R.Arg1).Host; +end; + +function TEmitter.Host2: Boolean; +begin + result := GetSymbolRec(R.Arg2).Host; +end; + +function TEmitter.ByRef1: Boolean; +begin + result := GetSymbolRec(R.Arg1).ByRef or GetSymbolRec(R.Arg1).ByRefEx; +end; + +function TEmitter.GetReg: Integer; +begin + result := registers.GetReg; +end; + +function TEmitter.GetReg(Reg: Integer): Integer; +begin + registers.GetReg(Reg); + result := Reg; +end; + +function TEmitter.GetRegEx: Integer; +begin + result := GetReg(_EBX); +end; + +function TEmitter.GetReg64: Integer; +begin + result := registers.GetReg64; +end; + +procedure TEmitter.FreeReg(Reg: Integer); +begin + Registers.FreeReg(Reg); +end; + +function TEmitter.ImmValue1: Cardinal; +begin + result := SymbolRec1.Value; +end; + +function TEmitter.ImmValue2: Cardinal; +begin + result := SymbolRec2.Value; +end; + +function TEmitter.GetOffset(S: TSymbolRec): Integer; +begin + result := TKernel(kernel).GetOffset(S); +end; + +function TEmitter.SymbolRec1: TSymbolRec; +begin + result := GetSymbolRec(R.Arg1); +end; + +function TEmitter.SymbolRec2: TSymbolRec; +begin + result := GetSymbolRec(R.Arg2); +end; + +function TEmitter.SymbolRecR: TSymbolRec; +begin + result := GetSymbolRec(R.Res); +end; + +function TEmitter.Lookup(const S: String): Integer; +begin + result := SymbolTable.LookUp(S, 0, false); +end; + +function TEmitter.CreateSymbolProgram(i_kernel: Pointer): TSymbolProg; +var + Code: TCode; + I, J, ShiftValue: Integer; + + SymbolProgRec: TSymbolProgRec; + SymbolRec: TSymbolRec; + Modules: TModuleList; + b: Boolean; + K, KK: Integer; + SZ: Integer; +begin + Self.kernel := i_kernel; + + EmitOff := false; + HandlesEvents := false; + + Prg := TSymbolProg.Create(kernel); + Prg.Clear; + + result := Prg; + + Code := TKernel(kernel).Code; + +// Prg.AsmAddREG_Imm(_ECX, $44); +// Prg.AsmAddREG_Imm(_R10, $44); +// Exit; +// Prg.AsmPutREG8_EBPPtr(_ecx, $444444); +// Prg.AsmPutREG8_EBPPtr(_r8, $444444); +// Prg.AsmMovREG8_REGPtr(_ecx, _ebx); +// Prg.AsmMovREGPtr_REG8(_ecx, _r11); +// Prg.AsmMovREGPtr_REG8(_r10, _ecx); +// Prg.AsmMovREGPtr_REG8(_r10, _r11); + +// Prg.AsmMovREG8_REGPtr(_ecx, _ebx); +// exit; +{ + Prg.AsmMovREGPtr_Imm(_R9, $80,$80); + Prg.AsmMovREGPtr_Imm(_R10, $80,$80); + Prg.AsmMovREGPtr_Imm(_R11, $80,$80); + Prg.AsmMovREGPtr_Imm(_R12, $80,$80); + Prg.AsmMovREGPtr_Imm(_R13, $80,$80); + Prg.AsmMovREGPtr_Imm(_R14, $80,$80); + Prg.AsmMovREGPtr_Imm(_R15, $80,$80); + Exit; +} +{ + Prg.AsmMovREG64_RSPPtr(_EAX, $80); + Prg.AsmMovREG64_RSPPtr(_ECX, $80); + Prg.AsmMovREG64_RSPPtr(_EDX, $80); + Prg.AsmMovREG64_RSPPtr(_EBX, $80); + Prg.AsmMovREG64_RSPPtr(_ESI, $80); + Prg.AsmMovREG64_RSPPtr(_EDI, $80); + Prg.AsmMovREG64_RSPPtr(_R8D, $80); + Prg.AsmMovREG64_RSPPtr(_R9D, $80); + Exit; +} +// Prg.AsmPutREG64_RBPPtr(_R8D, $4000); +// Exit; +// Prg.AsmCmpREGPtr_Imm(_EAX, Code.GetSymbolRec(1000014), 4000000000); +// Prg.AsmNEG_REGPtr(_EAX, Code.GetSymbolRec(1000014)); +// Prg.AsmMovREGPtr_Imm(_EAX, 4000000000, 4000000000); +// Prg.AsmFstpExtended_REGPtr(_EAX, Code.GetSymbolRec(1000014)); +// Exit; + + try + + Prg.AsmJMP_Imm(0); + + case TargetPlatform of + tpOSX32, tpIOSSim: + begin + Prg.AsmPush_REG(_EBP); + Prg.AsmPush_REG(_EBX); + Prg.AsmPush_REG(_ESI); + Prg.AsmPush_REG(_EDI); + Prg.AsmMovREG_REG(_EBP, _ESP); + Prg.AsmSubREG_Imm(_ESP, $10); + + Prg.EmitGetCallerEIP; + end; + tpWIN64: + begin + Prg.AsmPush_REG(_EBP); + Prg.AsmSubReg_Imm(_ESP, $100); + Prg.AsmMovREG_REG(_EBP, _ESP); + + end; + end; + + for I:= 1 to Code.Card do + begin + R := Code.Records[I]; +{$IFNDEF PAXARM} + if R.Op = OP_INIT_PANSICHAR_LITERAL then + begin + EmitOP_INIT_PCHAR_LITERAL; + R.Op := OP_NOP; + end + else +{$ENDIF} + if R.Op = OP_INIT_PWIDECHAR_LITERAL then + begin + EmitOP_INIT_PWIDECHAR_LITERAL; + R.Op := OP_NOP; + end; + end; + + for I:= 1 to Code.Card do + begin + R := Code.Records[I]; + if R.Op = OP_LOAD_PROC then + begin + if TargetPlatform = tpWIN64 then + EmitOP_LOAD_PROC_64 + else + EmitOP_LOAD_PROC; + end; + end; + + K := 0; + b := false; + for I:= 1 to Code.Card do + begin + R := Code.Records[I]; + if R.Op = OP_BEGIN_INIT_CONST then + begin + b := true; + R.Op := OP_NOP; + Inc(K); + end + else if R.Op = OP_END_INIT_CONST then + begin + Dec(K); + if K = 0 then + b := false; + R.Op := OP_NOP; + end + else if b then + begin + Code.N := I; + Emit(I); + R.Op := OP_NOP; + end; + end; + + for I:= 1 to Code.Card do + begin + R := Code.Records[I]; + if R.Op = OP_ADD_MESSAGE then + begin + if TargetPlatform = tpWIN64 then + EmitOP_ADD_MESSAGE_64 + else + EmitOP_ADD_MESSAGE; + end; + end; + + Modules := TKernel(kernel).Modules; + Modules.Recalc; + + // emit initialization sections + + for J:=0 to Modules.LoadOrder.Count - 1 do + if Modules[J].PInitBegin > 0 then + for I:= Modules[J].PInitBegin + 1 to Modules[J].PInitEnd - 1 do + Emit(I); + + EmitOP_CHECK_INIT_ONLY; + for KK:=1 to MAGIC_INITIALIZATION_JMP_COUNT do + Prg.AsmJMP_Imm(0); + + case TargetPlatform of + tpOSX32, tpIOSSim: + begin + Prg.AsmPush_REG(_EBP); + Prg.AsmPush_REG(_EBX); + Prg.AsmPush_REG(_ESI); + Prg.AsmPush_REG(_EDI); + Prg.AsmMovREG_REG(_EBP, _ESP); + Prg.AsmSubREG_Imm(_ESP, $10); + + Prg.EmitGetCallerEIP; + end; + tpWIN64: + begin + Prg.AsmPush_REG(_EBP); + Prg.AsmSubReg_Imm(_ESP, $100); + Prg.AsmMovREG_REG(_EBP, _ESP); + end; + end; + + I := 1; + while I < Code.Card do + begin + R := Code.Records[I]; + Code.N := I; + if R.Op = OP_BEGIN_CRT_JS_FUNC_OBJECT then + begin + EmitOP_BEGIN_CRT_JS_FUNC_OBJECT; + R.Op := OP_NOP; + repeat + Inc(I); + R := Code.Records[I]; + Code.N := I; + Emit(I); + if R.Op = OP_END_CRT_JS_FUNC_OBJECT then + begin + R.Op := OP_NOP; + break; + end + else + R.Op := OP_NOP; + until false; + end; + + Inc(I); + end; + + I := 1; + while I <= Code.Card do + begin + R := Code.Records[I]; + Code.N := I; + + if R.Op = OP_SEPARATOR then + begin + EmitOP_SEPARATOR(I); + Inc(I); + continue; + end + else if R.Op = OP_EMIT_ON then + begin + EmitOP_EMIT_ON; + Inc(I); + continue; + end + else if R.Op = OP_EMIT_OFF then + begin + EmitOP_EMIT_OFF; + Inc(I); + continue; + end + else if R.Op = OP_END_INITIALIZATION then + begin + EmitOP_EMIT_ON; + Inc(I); + continue; + end + else if R.Op = OP_BEGIN_INITIALIZATION then + begin + EmitOP_EMIT_OFF; + Inc(I); + continue; + end + else if R.Op = OP_END_FINALIZATION then + begin + EmitOP_EMIT_ON; + Inc(I); + continue; + end + else if R.Op = OP_BEGIN_FINALIZATION then + begin + EmitOP_EMIT_OFF; + Inc(I); + continue; + end; + + if not EmitOff then + Emit(I); + + Inc(I); + end; + + Prg.Optimization; + + ShiftValue := 0; + for I:=1 to Prg.Card do + begin + Prg[I].ShiftValue := ShiftValue; + + J := Prg[I].LabelId; + if J > 0 then + SymbolTable[J].Value := ShiftValue; + + SZ := Prg[I].Size; + if SZ > 0 then + ShiftValue := ShiftValue + SZ; + end; + + for I:=0 to List1.Count - 1 do + begin + SymbolProgRec := TSymbolProgRec(List1[I]); // record of symbol code + ShiftValue := SymbolProgRec.ShiftValue; + SymbolRec := TSymbolRec(List3[I]); // label + if SymbolProgRec.Op = ASM_JMP then + begin + ShiftValue := SymbolRec.Value - ShiftValue - SymbolProgRec.Size; + Move(ShiftValue, SymbolProgRec.code[1], 4); + SymbolProgRec.Decompile; + end + else if SymbolProgRec.Op = ASM_PUSH then // pause + begin + ShiftValue := SymbolRec.Value; + Move(ShiftValue, SymbolProgRec.code[1], 4); + SymbolProgRec.Decompile; + end + else + RaiseError(errInternalError, []); + end; + + for I:=0 to List2.Count - 1 do + begin + SymbolProgRec := TSymbolProgRec(List2[I]); // record of symbol code + ShiftValue := SymbolTable[SymbolProgRec.SaveSubId].Value; + + // if ShiftValue < 0 then + // RaiseError(errInternalError, []); + + if TargetPlatform = tpWIN64 then + Move(ShiftValue, SymbolProgRec.code[3], 4) + else + begin + if SymbolProgRec.code[0] = $05 then // ADD EAX, Imm + Move(ShiftValue, SymbolProgRec.code[1], 4) + else + Move(ShiftValue, SymbolProgRec.code[2], 4); + end; + + SymbolProgRec.Decompile; + end; + finally + end; +end; + +procedure TEmitter.Emit(I: Integer); +var + Code: TCode; + J, KK, Op: Integer; + Modules: TModuleList; +begin + Code := TKernel(kernel).Code; + + R := Code.Records[I]; + Code.N := I; + Op := R.Op; + + if Op = OP_SEPARATOR then + begin + EmitOP_SEPARATOR(I); + end + else if Op = OP_SET_CODE_LINE then + begin + Prg.AsmComment('***** N ****** ' + IntToStr(Code.N)); + Prg.AsmMovREGPtr_Imm(_ESI, H_ByteCodePtr, I); + end + else if Op = OP_STMT then + begin + Prg.AsmMovREGPtr_Imm(_ESI, H_ByteCodePtr, I); + end + else if Op = OP_BEGIN_MODULE then + begin + Prg.AsmComment('Module ' + Code.GetModule(I).Name); + end + else if Op = OP_END_INTERFACE_SECTION then + begin + Prg.AsmComment('End of interface section of ' + Code.GetModule(I).Name); + end + else if Op = OP_END_MODULE then + begin + Prg.AsmComment('End of module ' + Code.GetModule(I).Name); + + case TargetPlatform of + tpOSX32, tpIOSSim: + begin + Prg.AsmAddReg_Imm(_ESP, $10); + Prg.AsmPop_REG(_EDI); + Prg.AsmPop_REG(_ESI); + Prg.AsmPop_REG(_EBX); + Prg.AsmPop_REG(_EBP); + end; + tpWIN64: + begin + Prg.AsmAddReg_Imm(_ESP, $100); + Prg.AsmPop_REG(_EBP); + end; + end; + + EmitOP_CHECK_BODY_ONLY; + + for KK:=1 to MAGIC_FINALIZATION_JMP_COUNT do + Prg.AsmJMP_Imm(0); + + case TargetPlatform of + tpOSX32, tpIOSSim: + begin + Prg.AsmPush_REG(_EBP); + Prg.AsmPush_REG(_EBX); + Prg.AsmPush_REG(_ESI); + Prg.AsmPush_REG(_EDI); + Prg.AsmMovREG_REG(_EBP, _ESP); + Prg.AsmSubReg_Imm(_ESP, $10); + + Prg.EmitGetCallerEIP; + end; + tpWIN64: + begin + Prg.AsmPush_REG(_EBP); + Prg.AsmSubReg_Imm(_ESP, $100); + Prg.AsmMovREG_REG(_EBP, _ESP); + end; + end; + + // emit finalization sections + Modules := TKernel(kernel).Modules; + + for J:=Modules.LoadOrder.Count - 1 downto 0 do + if Modules[J].PFinBegin > 0 then + for I:= Modules[J].PFinBegin + 1 to Modules[J].PFinEnd - 1 do + Emit(I); + + case TargetPlatform of + tpOSX32, tpIOSSim: + begin + Prg.AsmAddReg_Imm(_ESP, $10); + Prg.AsmPop_REG(_EDI); + Prg.AsmPop_REG(_ESI); + Prg.AsmPop_REG(_EBX); + Prg.AsmPop_REG(_EBP); + end; + tpWIN64: + begin + Prg.AsmAddReg_Imm(_ESP, $100); + Prg.AsmPop_REG(_EBP); + end; + end; + + Prg.AsmRet; + end + else if Op = OP_LABEL then + EmitLabel(R.Arg1, GetSymbolRec(R.Arg1).Name) + else + EmitList[-Op]; +end; + +procedure TEmitter.RaiseError(const Message: string; params: array of Const); +begin + TKernel(kernel).RaiseError(Message, params); +end; + +procedure TEmitter.CreateError(const Message: string; params: array of Const); +begin + TKernel(kernel).CreateError(Message, params); +end; + +function TEmitter.GetSymbolRec(Id: Integer): TSymbolRec; +begin + result := TKernel(kernel).SymbolTable[Id]; +end; + +function TEmitter.SymbolTable: TSymbolTable; +begin + result := TKernel(kernel).SymbolTable; +end; + +function TEmitter.ByteCode: TCode; +begin + result := TKernel(kernel).Code; +end; + +procedure TEmitter.EmitPCodeOperator; +var + S: String; + N: Integer; +begin + N := TKernel(kernel).Code.N; + if (R.Op = OP_CALL) or (R.Op = OP_LOAD_PROC) then + begin + if SymbolRec1.MethodIndex > 0 then + S := '(' + IntToStr(SymbolRec1.MethodIndex) + ')' + ' *** N *** ' + IntToStr(N) + else + S := ' *** N *** ' + IntToStr(N); + + Prg.AsmComment(' ' + OperName + ' ' + + GetSymbolRec(R.Arg1).FullName + '[' + IntToStr(R.Arg1) + ']' + S); + end + else + Prg.AsmComment(' ' + OperName + ' *** N *** ' + IntToStr(N)); +end; + +procedure TEmitter.EmitComment; +var + S: String; +begin + S := SymbolRec1.Value; + Prg.AsmComment(S); +end; + +procedure TEmitter.EmitStartSub(SubId: Integer); +var + R: TSymbolProgRec; +begin + R := Prg.AsmComment('START SUB [' + IntToStr(SubId) + ']; // ' + GetSymbolRec(SubId).FullName); + if not GetSymbolRec(SubId).IsNestedSub then + R.MapSub := - SubId; +end; + +procedure TEmitter.EmitFinSub(SubId: Integer); +var + R: TSymbolProgRec; +begin + R := Prg.AsmComment('FIN SUB [' + IntToStr(SubId) + ']; // ' + GetSymbolRec(SubId).FullName); + if not GetSymbolRec(SubId).IsNestedSub then + R.MapSub := SubId; +end; + +procedure TEmitter.EmitOP_SEPARATOR(I: Integer); +{$IFDEF TRIAL} +var SubId: Integer; +{$ENDIF} +begin +{$IFDEF DUMP} + Prg.AsmComment('------------------------------------------------------'); + Prg.AsmComment(TKernel(kernel).Code.GetSourceLine(I)); + Prg.AsmComment('------------------------------------------------------'); +{$ENDIF} + + {$IFDEF TRIAL} + Inc(_Counter); + if _Counter mod 101 = 0 then + begin + SubId := TKernel(kernel).SymbolTable.LookUp(strShowTrial, 0, false); + + EmitCallPro(SubId); + EmitStdCall(SubId); + end; + {$ENDIF} +end; + +procedure TEmitter.EmitOP_GO; +begin + EmitPCodeOperator; + + EmitJmp; +end; + +procedure TEmitter.EmitOP_PAUSE_64; +begin + RaiseError(errNotImplementedYet, []); +end; +procedure TEmitter.EmitOP_PAUSE; +var + Reg, SubId: Integer; +begin + EmitPCodeOperator; + + SubId := Id_Pause; + + EmitCallPro(SubId); + + Reg := GetReg; + + Prg.AsmMovREG_REG(Reg, _ESP); + Prg.AsmPush_REG(Reg); // push _ESP + + Prg.AsmMovREG_REG(Reg, _EBP); + Prg.AsmPush_REG(Reg); // push _EBP + + Prg.AsmPush_Imm(0); + + List3.Add(SymbolRec1); + List1.Add(Prg.Top); + + Prg.AsmMovREG_REG(Reg, _ESI); + Prg.AsmAddREG_Imm(Reg, H_SelfPtr); + Prg.AsmMovREG_REGPtr(Reg, Reg); // load TProgram.Self + Prg.AsmPush_REG(Reg); // push TProgram.Self + FreeReg(Reg); + + EmitStdCall(SubId); +end; + +procedure TEmitter.EmitOP_CHECK_PAUSE_64; +begin +// RaiseError(errNotImplementedYet, []); +end; +procedure TEmitter.EmitOP_CHECK_PAUSE; +begin + EmitPCodeOperator; + + Prg.AsmNOP; + Prg.AsmNOP; + Prg.AsmNOP; + Prg.AsmNOP; + Prg.AsmNOP; + + EmitCallPro(Id_CheckPause); + + GetReg(_EAX); + Prg.AsmMovREG_REG(_EAX, _ESI); + Prg.AsmAddREG_Imm(_EAX, H_SelfPtr); + Prg.AsmMovREG_REGPtr(_EAX, _EAX); // load TProgram.Self + FreeReg(_EAX); + + EmitStdCall(Id_CheckPause); + + Prg.AsmCmpReg32Ptr_Imm(_ESI, H_Flag, 1); + Prg.AsmJNZ_Imm(29); + + R.Op := OP_PAUSE; + EmitOP_PAUSE; + R.Op := OP_CHECK_PAUSE; +end; + +procedure TEmitter.EmitOP_CHECK_PAUSE_LIGHT_64; +begin + RaiseError(errNotImplementedYet, []); +end; +procedure TEmitter.EmitOP_CHECK_PAUSE_LIGHT; +begin + EmitPCodeOperator; + + Prg.AsmCmpReg32Ptr_Imm(_ESI, H_Flag, 1); + Prg.AsmJNZ_Imm(29); + + R.Op := OP_PAUSE; + EmitOP_PAUSE; + R.Op := OP_CHECK_PAUSE; +end; + +procedure TEmitter.EmitOP_HALT_64; +begin + RaiseError(errNotImplementedYet, []); +end; +procedure TEmitter.EmitOP_HALT; +var + Reg, SubId: Integer; +begin + EmitPCodeOperator; + + SubId := Id_Halt; + EmitCallPro(SubId); + + Reg := GetReg; + + Prg.AsmPush_Imm(SymbolRec1.Value); + + Prg.AsmMovREG_REG(Reg, _ESI); + Prg.AsmAddREG_Imm(Reg, H_SelfPtr); + Prg.AsmMovREG_REGPtr(Reg, Reg); // load TProgram.Self + Prg.AsmPush_REG(Reg); // push TProgram.Self + FreeReg(Reg); + + EmitStdCall(SubId); +end; + +procedure TEmitter.EmitOP_CHECK_INIT_ONLY; +begin + EmitPCodeOperator; + + case TargetPlatform of + tpOSX32, tpIOSSim: + begin + Prg.AsmCmpReg32Ptr_Imm(_ESI, H_InitOnly, 2); + Prg.AsmJNZ_Imm(11); + Prg.AsmAddReg_Imm(_ESP, $10); // 6 + Prg.AsmPop_REG(_EDI); // 1 + Prg.AsmPop_REG(_ESI); // 1 + Prg.AsmPop_REG(_EBX); // 1 + Prg.AsmPop_REG(_EBP); // 1 + Prg.AsmRet(); // 1 + end; + tpWIN64: + begin + Prg.AsmCmpReg32Ptr_Imm(_ESI, H_InitOnly, 2); + Prg.AsmJNZ_Imm(9); + Prg.AsmAddReg_Imm(_ESP, $100); // 7 + Prg.AsmPop_Reg(_EBP); // 1 + Prg.AsmRet(); // 1 + end; + else + begin + Prg.AsmCmpReg32Ptr_Imm(_ESI, H_InitOnly, 2); + Prg.AsmJNZ_Imm(1); + Prg.AsmRet(); + end; + end; +end; + +procedure TEmitter.EmitOP_CHECK_BODY_ONLY; +begin + EmitPCodeOperator; + + Prg.AsmCmpReg32Ptr_Imm(_ESI, H_BodyOnly, 3); + Prg.AsmJNZ_Imm(1); + Prg.AsmRet(); +end; + +procedure TEmitter.EmitOP_TRY_ON_64; +begin + EmitPCodeOperator; +{ + SubId := Id_TryOn; + + Reg := GetRegEx; + + Prg.AsmMovREG_REG(Reg, _ESI); + Prg.AsmAddREG_Imm(Reg, H_SelfPtr); + Prg.AsmMovREG_REGPtr(Reg, Reg); // load TProgram.Self + Prg.AsmMovREG_REG(_ECX, Reg); // push TProgram.Self + + Prg.AsmMovReg_Imm(Reg, R.Arg1); // block index + Prg.AsmMovREG_REG(_EDX, Reg); + + Prg.AsmMovREG_REG(_R8, _EBP); + Prg.AsmMovREG_REG(_R9, _ESP); + + EmitGet_REG(Reg, SymbolTable[SubId]); + Prg.AsmCall_REG(Reg); + + FreeReg(Reg); +} +end; +procedure TEmitter.EmitOP_TRY_ON; +var + Reg, SubId: Integer; +begin + EmitPCodeOperator; + + if TKernel(kernel).ModeSEH then + begin + Reg := _EAX; + + Prg.AsmPush_REG(_ESP); + + Prg.AsmPush_Imm(PAX_SEH); // magic + Prg.AsmPush_Imm(R.Arg1); // block index + + Prg.AsmMovREG_REG(Reg, _ESI); + Prg.AsmAddREG_Imm(Reg, H_SelfPtr); + Prg.AsmMovREG_REGPtr(Reg, Reg); // load TProgram.Self + Prg.AsmPush_REG(Reg); // push TProgram.Self + + Prg.AsmPush_Imm(0); // Self of method + + Prg.AsmPush_REG(_EBP); + + EmitGet_REG(Reg, SymbolTable[Id_PaxSEHHandler]); + Prg.AsmPush_REG(Reg); // push handler + + Prg.AsmXorREG_REG(_EAX, _EAX); + Prg.AsmPush_FS_REGPtr(_EAX); + Prg.AsmMovFS_REGPtr_REG32(_EAX, _ESP); + Exit; + end; + + SubId := Id_TryOn; + + EmitCallPro(SubId); + + if TargetPlatform = tpWIN64 then + begin + Reg := GetRegEx; + + Prg.AsmMovREG_REG(Reg, _ESI); + Prg.AsmAddREG_Imm(Reg, H_SelfPtr); + Prg.AsmMovREG_REGPtr(Reg, Reg); // load TProgram.Self + Prg.AsmMovREG_REG(_ECX, Reg); // push TProgram.Self + + Prg.AsmMovReg_Imm(Reg, R.Arg1); // block index + Prg.AsmMovREG_REG(_EDX, Reg); + + Prg.AsmMovREG_REG(_R8, _EBP); + Prg.AsmMovREG_REG(_R9, _ESP); + FreeReg(Reg); + + EmitStdCall(SubId); + end + else + begin + Prg.AsmPutREG_ESIPtr(_EDX, 0); + + Reg := GetReg; + + Prg.AsmMovREG_REG(Reg, _ESP); + Prg.AsmPush_REG(Reg); // push _ESP + + Prg.AsmMovREG_REG(Reg, _EBP); + Prg.AsmPush_REG(Reg); // push _EBP + + Prg.AsmPush_Imm(R.Arg1); // block index + + Prg.AsmMovREG_REG(Reg, _ESI); + Prg.AsmAddREG_Imm(Reg, H_SelfPtr); + Prg.AsmMovREG_REGPtr(Reg, Reg); // load TProgram.Self + Prg.AsmPush_REG(Reg); // push TProgram.Self + FreeReg(Reg); + + EmitStdCall(SubId); + + Prg.AsmGetREG_ESIPtr(_EDX, 0); + end; +end; + +procedure TEmitter.EmitOP_EXCEPT_SEH_64; +begin +end; +procedure TEmitter.EmitOP_EXCEPT_SEH; +begin + EmitPCodeOperator; + + if TKernel(kernel).ModeSEH then + begin + Prg.AsmXorREG_REG(_EAX, _EAX); + Prg.AsmPop_REG(_EDX); // 4 + Prg.AsmMovFS_REGPtr_REG32(_EAX, _EDX); + Prg.AsmAddREG_Imm(_ESP, SizeOf(TPaxExcFrame) - 4); + end; +end; + +procedure TEmitter.EmitOP_TRY_OFF_64; +var + Reg, SubId: Integer; +begin + EmitPCodeOperator; + + SubId := Id_TryOff; + EmitCallPro(SubId); + + Reg := GetRegEx; + + Prg.AsmMovREG_REG(Reg, _ESI); + Prg.AsmAddREG_Imm(Reg, H_SelfPtr); + Prg.AsmMovREG_REGPtr(Reg, Reg); // load TProgram.Self + Prg.AsmMovREG_REG(_ECX, Reg); // push TProgram.Self + + Prg.AsmMovReg_Imm(_EDX, R.Arg1); // block index + FreeReg(Reg); + + EmitStdCall(SubId); +end; + +procedure TEmitter.EmitOP_TRY_OFF; +var + Reg, SubId: Integer; +begin + EmitPCodeOperator; + + if TKernel(kernel).ModeSEH then + begin + exit; + end; + + SubId := Id_TryOff; + EmitCallPro(SubId); + + Reg := GetReg; + + Prg.AsmPush_Imm(R.Arg1); // block index + + Prg.AsmMovREG_REG(Reg, _ESI); + Prg.AsmAddREG_Imm(Reg, H_SelfPtr); + Prg.AsmMovREG_REGPtr(Reg, Reg); // load TProgram.Self + Prg.AsmPush_REG(Reg); // push TProgram.Self + FreeReg(Reg); + + EmitStdCall(SubId); +end; + +procedure TEmitter.EmitOP_FINALLY_64; +var + SubId, Reg: Integer; +begin + EmitPCodeOperator; + + SubId := Id_Finally; + EmitCallPro(SubId); + + Reg := _ECX; + Prg.AsmMovREG_REG(Reg, _ESI); + Prg.AsmAddREG_Imm(Reg, H_SelfPtr); + Prg.AsmMovREG_REGPtr(Reg, Reg); // load TProgram.Self + + EmitStdCall(SubId); +end; + +procedure TEmitter.EmitOP_FINALLY; +var + SubId, Reg: Integer; +begin + EmitPCodeOperator; + + SubId := Id_Finally; + EmitCallPro(SubId); + + Reg := GetReg; + + Prg.AsmMovREG_REG(Reg, _ESI); + Prg.AsmAddREG_Imm(Reg, H_SelfPtr); + Prg.AsmMovREG_REGPtr(Reg, Reg); // load TProgram.Self + Prg.AsmPush_REG(Reg); // push TProgram.Self + FreeReg(Reg); + + EmitStdCall(SubId); +end; + +procedure TEmitter.EmitOP_EXCEPT_64; +begin + EmitPCodeOperator; +end; +procedure TEmitter.EmitOP_EXCEPT; +begin + EmitPCodeOperator; +end; + +procedure TEmitter.EmitOP_EXCEPT_ON_64; +begin + EmitPCodeOperator; +end; +procedure TEmitter.EmitOP_EXCEPT_ON; +begin + EmitPCodeOperator; +end; + +procedure TEmitter.EmitOP_EXIT_64; +var + Reg, SubId: Integer; +begin + EmitPCodeOperator; + + SubId := Id_Exit; + EmitCallPro(SubId); + + Reg := GetRegEx; + + Prg.AsmMovREG_REG(Reg, _ESI); + Prg.AsmAddREG_Imm(Reg, H_SelfPtr); + Prg.AsmMovREG_REGPtr(Reg, Reg); // load TProgram.Self + Prg.AsmMovREG_REG(_ECX, Reg); // push TProgram.Self + + Prg.AsmMovREG_Imm(Reg, R.Res); // level + Prg.AsmMovREG_REG(_EDX, Reg); + + Prg.AsmMovREG_Imm(_R8, R.Arg2); // exit mode + FreeReg(Reg); + + EmitStdCall(SubId); +end; +procedure TEmitter.EmitOP_EXIT; +var + Reg, SubId: Integer; +begin + EmitPCodeOperator; + + SubId := Id_Exit; + EmitCallPro(SubId); + + Prg.AsmPush_Imm(R.Arg2); // exit mode + Prg.AsmPush_Imm(R.Res); // level + + Reg := GetReg; + + Prg.AsmMovREG_REG(Reg, _ESI); + Prg.AsmAddREG_Imm(Reg, H_SelfPtr); + Prg.AsmMovREG_REGPtr(Reg, Reg); // load TProgram.Self + Prg.AsmPush_REG(Reg); // push TProgram.Self + FreeReg(Reg); + + EmitStdCall(SubId); +end; + +procedure TEmitter.EmitOP_RAISE_64; +begin + RaiseError(errNotImplementedYet, []); +end; + +procedure TEmitter.EmitOP_RAISE; +var + Reg, SubId: Integer; +begin + EmitPCodeOperator; + + SubId := Id_Raise; + EmitCallPro(SubId); + + Prg.AsmPush_Reg(_ESP); + Prg.AsmPush_Imm(R.Arg2); // raise mode + + Reg := GetReg; + + if R.Arg1 = 0 then + Prg.AsmPush_Imm(R.Arg1) // block index + else + begin + EmitLoadIntVal(Reg, SymbolRec1); + Prg.AsmPush_REG(Reg); + end; + + Prg.AsmMovREG_REG(Reg, _ESI); + Prg.AsmAddREG_Imm(Reg, H_SelfPtr); + Prg.AsmMovREG_REGPtr(Reg, Reg); // load TProgram.Self + Prg.AsmPush_REG(Reg); // push TProgram.Self + FreeReg(Reg); + + EmitStdCall(SubId); +end; + +procedure TEmitter.EmitOP_OVERFLOW_CHECK_64; +begin + EmitPCodeOperator; + if R.Arg1 > 0 then + OverflowCheck := true + else + OverflowCheck := false; +end; +procedure TEmitter.EmitOP_OVERFLOW_CHECK; +begin + EmitPCodeOperator; + if R.Arg1 > 0 then + OverflowCheck := true + else + OverflowCheck := false; +end; + +procedure TEmitter.EmitOP_BEGIN_EXCEPT_BLOCK_64; +var + Reg, SubId: Integer; +begin + EmitPCodeOperator; + + SubId := Id_BeginExceptBlock; + EmitCallPro(SubId); + + Reg := GetRegEx; + + Prg.AsmMovREG_REG(Reg, _ESI); + Prg.AsmAddREG_Imm(Reg, H_SelfPtr); + Prg.AsmMovREG_REGPtr(Reg, Reg); // load TProgram.Self + Prg.AsmMovREG_REG(_ECX, Reg); // push TProgram.Self + FreeReg(Reg); + + EmitStdCall(SubId); +end; +procedure TEmitter.EmitOP_BEGIN_EXCEPT_BLOCK; +var + Reg, SubId: Integer; +begin + EmitPCodeOperator; + + SubId := Id_BeginExceptBlock; + EmitCallPro(SubId); + + Reg := GetReg; + + Prg.AsmMovREG_REG(Reg, _ESI); + Prg.AsmAddREG_Imm(Reg, H_SelfPtr); + Prg.AsmMovREG_REGPtr(Reg, Reg); // load TProgram.Self + Prg.AsmPush_REG(Reg); // push TProgram.Self + FreeReg(Reg); + + EmitStdCall(SubId); +end; + +procedure TEmitter.EmitOP_END_EXCEPT_BLOCK_64; +var + Reg, SubId: Integer; +begin + EmitPCodeOperator; + + SubId := Id_EndExceptBlock; + EmitCallPro(SubId); + + Reg := GetRegEx; + + Prg.AsmMovREG_REG(Reg, _ESI); + Prg.AsmAddREG_Imm(Reg, H_SelfPtr); + Prg.AsmMovREG_REGPtr(Reg, Reg); // load TProgram.Self + Prg.AsmMovREG_REG(_ECX, Reg); // push TProgram.Self + FreeReg(Reg); + + EmitStdCall(SubId); +end; +procedure TEmitter.EmitOP_END_EXCEPT_BLOCK; +var + Reg, SubId: Integer; +begin + EmitPCodeOperator; + + SubId := Id_EndExceptBlock; + EmitCallPro(SubId); + + Reg := GetReg; + + Prg.AsmMovREG_REG(Reg, _ESI); + Prg.AsmAddREG_Imm(Reg, H_SelfPtr); + Prg.AsmMovREG_REGPtr(Reg, Reg); // load TProgram.Self + Prg.AsmPush_REG(Reg); // push TProgram.Self + + FreeReg(Reg); + + EmitStdCall(SubId); +end; + +procedure TEmitter.EmitOP_COND_RAISE_64; +var + Reg, SubId, temp: Integer; +begin + EmitPCodeOperator; + + SubId := Id_CondRaise; + + EmitCallPro(SubId); + + Reg := GetRegEx; + + Prg.AsmMovREG_REG(Reg, _ESI); + Prg.AsmAddREG_Imm(Reg, H_SelfPtr); + Prg.AsmMovREG_REGPtr(Reg, Reg); // load TProgram.Self + Prg.AsmMovREG_REG(_ECX, Reg); // push TProgram.Self + + EmitLoadAddress(Reg, SymbolRecR); // IsExit + Prg.AsmMovREG_REG(_EDX, Reg); + + Prg.AsmMovREG_Imm(_R8, SymbolRecR.Level); // subid + + Prg.AsmMovREG_Imm(_R9, R.Arg2); // last cond raise + + Prg.AsmMovREG_Imm(Reg, _ESP); // subid + Prg.AsmMovRSPPtr_REG64(Reg, $20); + + FreeReg(Reg); + + EmitStdCall(SubId); + + if R.Arg1 > 0 then + begin + Reg := EmitGetAddressRegister(SymbolRecR); + Prg.AsmCmpREGPtr_Imm(Reg, SymbolRecR, 0); + Prg.AsmJZ_Imm(5); + EmitJmp; + FreeReg(Reg); + + if R.BreakLabel > 0 then + begin + Reg := EmitGetAddressRegister(SymbolRecR); + Prg.AsmCmpREGPtr_Imm(Reg, SymbolRecR, 0); + Prg.AsmJZ_Imm(5); + temp := R.Arg1; + R.Arg1 := R.BreakLabel; + EmitJmp; + R.Arg1 := temp; + FreeReg(Reg); + end; + end; +end; +procedure TEmitter.EmitOP_COND_RAISE; +var + Reg, SubId, temp: Integer; +begin + EmitPCodeOperator; + + SubId := Id_CondRaise; + EmitCallPro(SubId); + + Reg := GetReg; + + Prg.AsmPush_Reg(_ESP); + Prg.AsmPush_Imm(R.Arg2); // last cond raise + + Prg.AsmPush_Imm(SymbolRecR.Level); // subid + + EmitLoadAddress(Reg, SymbolRecR); // IsExit + Prg.AsmPush_REG(Reg); + + Prg.AsmMovREG_REG(Reg, _ESI); + Prg.AsmAddREG_Imm(Reg, H_SelfPtr); + Prg.AsmMovREG_REGPtr(Reg, Reg); // load TProgram.Self + Prg.AsmPush_REG(Reg); // push TProgram.Self + FreeReg(Reg); + + EmitStdCall(SubId); + + if R.Arg1 > 0 then + begin + Reg := EmitGetAddressRegister(SymbolRecR); + Prg.AsmCmpREGPtr_Imm(Reg, SymbolRecR, 1); + Prg.AsmJNZ_Imm(5); + EmitJmp; + FreeReg(Reg); + + if R.BreakLabel > 0 then + begin + Reg := EmitGetAddressRegister(SymbolRecR); + Prg.AsmCmpREGPtr_Imm(Reg, SymbolRecR, 2); + Prg.AsmJNZ_Imm(5); + temp := R.Arg1; + R.Arg1 := R.BreakLabel; + EmitJmp; + R.Arg1 := temp; + FreeReg(Reg); + end; + if R.ContinueLabel > 0 then + begin + Reg := EmitGetAddressRegister(SymbolRecR); + Prg.AsmCmpREGPtr_Imm(Reg, SymbolRecR, 3); + Prg.AsmJNZ_Imm(5); + temp := R.Arg1; + R.Arg1 := R.ContinueLabel; + EmitJmp; + R.Arg1 := temp; + FreeReg(Reg); + end; + end; +end; + +procedure TEmitter.EmitOP_GO_1; +var + Reg: Integer; +begin + EmitPCodeOperator; + + Reg := GetRegEx; + EmitLoadIntVal(Reg, SymbolRec2); + Prg.AsmCmpREG_Imm(Reg, 1); + + Prg.AsmJNZ_Imm(5); + EmitJmp; + FreeReg(Reg); +end; + +procedure TEmitter.EmitOP_GO_2; +var + Reg: Integer; +begin + EmitPCodeOperator; + + Reg := GetRegEx; + EmitLoadIntVal(Reg, SymbolRec2); + Prg.AsmCmpREG_Imm(Reg, 2); + + Prg.AsmJNZ_Imm(5); + EmitJmp; + FreeReg(Reg); +end; + +procedure TEmitter.EmitOP_GO_3; +var + Reg: Integer; +begin + EmitPCodeOperator; + + Reg := GetRegEx; + EmitLoadIntVal(Reg, SymbolRec2); + Prg.AsmCmpREG_Imm(Reg, 3); + + Prg.AsmJNZ_Imm(5); + EmitJmp; + FreeReg(Reg); +end; + +procedure TEmitter.EmitOP_GO_TRUE_64; +begin + EmitOP_GO_TRUE; +end; +procedure TEmitter.EmitOP_GO_TRUE; +var + Reg: Integer; +begin + EmitPCodeOperator; + + if SymbolRec2.Kind = kindCONST then + begin + if SymbolRec2.Value <> 0 then + EmitJmp; + Exit; + end; + +{ + Reg := GetReg; + EmitLoadAddress(Reg, SymbolRec2); + Prg.AsmCmpByteREGPtr_Imm(Reg, 0); +} + + Reg := EmitGetAddressRegister(SymbolRec2); + Prg.AsmCmpREGPtr_Imm(Reg, SymbolRec2, 0); + + Prg.AsmJZ_Imm(5); + EmitJmp; + FreeReg(Reg); +end; + +procedure TEmitter.EmitOP_GO_DL_64; +begin + EmitOP_GO_DL; +end; +procedure TEmitter.EmitOP_GO_DL; +begin + EmitPCodeOperator; + Prg.AsmTestREG8_REG8(_EDX, _EDX); + Prg.AsmJNZ_Imm(5); + EmitJmp; +end; + +procedure TEmitter.EmitSaveRBX; +var + Id, SubId, S: Integer; +begin + SubId := ByteCode.GetCurrSubId(ByteCode.N); + if SubId > 0 then + begin + Id := SymbolTable.GetRBX_Id(SubId); + S := GetOffset(SymbolTable[Id]); + end + else + S := -4; + + Prg.AsmPutREG32_EBPPtr(_EBX, S); +end; + +procedure TEmitter.EmitRestoreRBX; +var + Id, SubId, S: Integer; +begin + SubId := ByteCode.GetCurrSubId(ByteCode.N); + if SubId > 0 then + begin + Id := SymbolTable.GetRBX_Id(SubId); + S := GetOffset(SymbolTable[Id]); + end + else + S := -4; + + Prg.AsmGetREG32_EBPPtr(_EBX, S); +end; + +procedure TEmitter.EmitSaveRDI; +var + Id, SubId, S: Integer; +begin + SubId := ByteCode.GetCurrSubId(ByteCode.N); + if SubId > 0 then + begin + Id := SymbolTable.GetRDI_Id(SubId); + S := GetOffset(SymbolTable[Id]); + end + else + S := -8; + + Prg.AsmPutREG32_EBPPtr(_EDI, S); +end; + +procedure TEmitter.EmitRestoreRDI; +var + Id, SubId, S: Integer; +begin + SubId := ByteCode.GetCurrSubId(ByteCode.N); + if SubId > 0 then + begin + Id := SymbolTable.GetRDI_Id(SubId); + S := GetOffset(SymbolTable[Id]); + end + else + S := -8; + + Prg.AsmGetREG32_EBPPtr(_EDI, S); +end; + +procedure TEmitter.EmitOP_SAVE_EDX_64; +begin + EmitOP_SAVE_EDX; +end; + +procedure TEmitter.EmitOP_RESTORE_EDX_64; +begin + EmitOP_RESTORE_EDX; +end; + +procedure TEmitter.EmitOP_SAVE_EDX; +var + SubId, DL_id: Integer; +begin + EmitPCodeOperator; + + if TargetPlatform = tpWin32 then + Prg.AsmPush_REG(_EDX) + else + begin + SubId := ByteCode.GetCurrSubId(ByteCode.N); + Dl_Id := SymbolTable.GetDL_Id(SubId); + EmitSaveIntVal(_EDX, GetSymbolRec(DL_Id)); + end; +end; + +procedure TEmitter.EmitOP_RESTORE_EDX; +var + SubId, DL_id: Integer; +begin + EmitPCodeOperator; + + if TargetPlatform = tpWin32 then + Prg.AsmPop_REG(_EDX) + else + begin + SubId := ByteCode.GetCurrSubId(ByteCode.N); + Dl_Id := SymbolTable.GetDL_Id(SubId); + EmitLoadIntVal(_EDX, GetSymbolRec(DL_Id)); + end; +end; + +procedure TEmitter.EmitOP_GO_FALSE_64; +begin + EmitOP_GO_FALSE; +end; +procedure TEmitter.EmitOP_GO_FALSE; +var + Reg: Integer; +begin + EmitPCodeOperator; + + if SymbolRec2.Kind = kindCONST then + begin + if SymbolRec2.Value = 0 then + EmitJmp; + Exit; + end; + +{ + Reg := GetReg; + EmitLoadAddress(Reg, SymbolRec2); + Prg.AsmCmpByteREGPtr_Imm(Reg, 0); +} + + Reg := EmitGetAddressRegister(SymbolRec2); + Prg.AsmCmpREGPtr_Imm(Reg, SymbolRec2, 0); + + Prg.AsmJNZ_Imm(5); + EmitJmp; + FreeReg(Reg); +end; + +procedure TEmitter.EmitLabel(LabelId: Integer; const LabelName: String); +begin + Prg.AsmComment('LABEL: ' + LabelName); + Prg.Top.LabelId := LabelId; +end; + +procedure TEmitter.EmitOP_ASSIGN_INT_I_64; +begin + EmitOP_ASSIGN_INT_I; +end; +procedure TEmitter.EmitOP_ASSIGN_INT_I; +var + Reg: Integer; +begin + EmitPCodeOperator; + + Reg := EmitGetAddressRegister(SymbolRec1); + Prg.AsmMovREGPtr_Imm(Reg, SymbolRec1, ImmValue2); + FreeReg(Reg); +end; + +procedure TEmitter.EmitOP_ASSIGN_INT_M_64; +begin + EmitOP_ASSIGN_INT_M; +end; +procedure TEmitter.EmitOP_ASSIGN_INT_M; +var + Reg: Integer; +begin + EmitPCodeOperator; + + Reg := GetReg; + EmitLoadIntVal(Reg, SymbolRec2); + EmitSaveIntVal(Reg, SymbolRec1); + FreeReg(Reg); +end; + +procedure TEmitter.EmitOP_ASSIGN_PANSICHAR_64; +begin + EmitOP_ASSIGN_PANSICHAR; +end; +procedure TEmitter.EmitOP_ASSIGN_PANSICHAR; +var + Reg: Integer; +begin + EmitPCodeOperator; + + Reg := GetReg; + + EmitGet_REG(Reg, SymbolRec2); + if SymbolRec2.Host or SymbolRec2.ByRef or SymbolRec2.ByRefEx then + Prg.AsmMovREG_REGPtr(Reg, Reg); + + EmitSaveIntVal(Reg, SymbolRec1); + FreeReg(Reg); +end; + +procedure TEmitter.EmitOP_ASSIGN_PWIDECHAR_64; +begin + EmitOP_ASSIGN_PWIDECHAR; +end; +procedure TEmitter.EmitOP_ASSIGN_PWIDECHAR; +var + Reg: Integer; +begin + EmitPCodeOperator; + + Reg := GetReg; + + EmitGet_REG(Reg, SymbolRec2); + if SymbolRec2.Host or SymbolRec2.ByRef or SymbolRec2.ByRefEx then + Prg.AsmMovREG_REGPtr(Reg, Reg); + + EmitSaveIntVal(Reg, SymbolRec1); + FreeReg(Reg); +end; + +procedure TEmitter.EmitOP_ASSIGN_EVENT_64; +begin + EmitOP_ASSIGN_EVENT; +end; +procedure TEmitter.EmitOP_ASSIGN_EVENT; +var + Reg, Reg1, Reg2: Integer; +begin + EmitPCodeOperator; + + HandlesEvents := true; + + Reg := GetReg; + Reg1 := GetReg; + Reg2 := GetReg; + + EmitLoadAddress(Reg1, SymbolRec1); + EmitLoadAddress(Reg2, SymbolRec2); + + Prg.AsmMovREG_REGPtr(Reg, Reg2); + Prg.AsmMovREGPtr_REG(Reg1, Reg); + + Prg.AsmAddREG_Imm(Reg1, SizeOfPointer); + Prg.AsmAddREG_Imm(Reg2, SizeOfPointer); + + Prg.AsmMovREG_REGPtr(Reg, Reg2); + Prg.AsmMovREGPtr_REG(Reg1, Reg); + + FreeReg(Reg); + FreeReg(Reg1); + FreeReg(Reg2); +end; + +procedure TEmitter.EmitOP_CREATE_EVENT_64; +begin + EmitOP_CREATE_EVENT; +end; +procedure TEmitter.EmitOP_CREATE_EVENT; +var + Reg, Reg1, Reg2: Integer; + SymbolProgRec: TSymbolProgRec; +begin + EmitPCodeOperator; + + HandlesEvents := true; + + Reg := GetReg; + Reg1 := GetReg; + Reg2 := GetReg; + + EmitLoadIntVal(Reg1, SymbolRec1); // instance + + if SymbolRec2.IsVirtual then + begin + prg.AsmMovREG_REGPtr(Reg2, Reg1); + + if SymbolRec2.MethodIndex = 0 then + begin + SymbolProgRec := prg.AsmAddREG_Imm(Reg2, 0); + SymbolProgRec.MustBeFixed := true; + SymbolProgRec.OpOffset := 2; + SymbolProgRec.SubId := SymbolRec2.Id; + end + else + prg.AsmAddREG_Imm(Reg2, (SymbolRec2.MethodIndex - 1) * SizeOfPointer); + + prg.AsmMovREG_REGPtr(Reg2, Reg2); + end + else + begin + if Host2 then + EmitLoadAddress(Reg2, SymbolRec2) // address of method + else + begin + Prg.AsmMovREG_REG(Reg2, _EDI); + Prg.AsmAddREG_Imm(Reg2, 0); + Prg.Top.SaveSubId := R.Arg2; + List2.Add(Prg.Top); + end; + end; + + EmitLoadAddress(Reg, SymbolRecR); // address of event + + Prg.AsmMovREGPtr_REG(Reg, Reg2); // code + Prg.AsmAddREG_Imm(Reg, SizeOfPointer); + Prg.AsmMovREGPtr_REG(Reg, Reg1); // data + + FreeReg(Reg); + FreeReg(Reg1); + FreeReg(Reg2); +end; + +procedure TEmitter.EmitOP_ASSIGN_RECORD_64; +var + Reg, S, TypeId, SubId: Integer; + L: TIntegerList; +begin + TypeId := SymbolRec1.TerminalTypeId; + L := SymbolTable.GetShiftsOfDynamicFields(TypeId); + + try + if L.Count = 0 then + begin + EmitPCodeOperator; + + SubId := Id_RecordAssign; + EmitCallPro(SubId); + + Reg := GetRegEx; + + EmitLoadAddress(Reg, SymbolRecR); // dest + Prg.AsmMovREG_REG(_ECX, Reg); + + EmitLoadAddress(Reg, SymbolRec2); // source + Prg.AsmMovREG_REG(_EDX, Reg); + + S := SymbolRec1.PtrSize; + Prg.AsmMovREG_Imm(_R8, S); + FreeReg(Reg); + + EmitStdCall(SubId); + end + else + EmitOP_ASSIGN_RECORD_EX; + finally + FreeAndNil(L); + end; +end; +procedure TEmitter.EmitOP_ASSIGN_RECORD; +var + Reg, S, TypeId, SubId: Integer; + L: TIntegerList; +begin + TypeId := SymbolRec1.TerminalTypeId; + L := SymbolTable.GetShiftsOfDynamicFields(TypeId); + + try + if L.Count = 0 then + begin + EmitPCodeOperator; + + SubId := Id_RecordAssign; + EmitCallPro(SubId); + + Reg := GetRegEx; + + S := SymbolRec1.PtrSize; + Prg.AsmPush_Imm(S); + + EmitLoadAddress(Reg, SymbolRec2); // source + Prg.AsmPush_REG(Reg); + + EmitLoadAddress(Reg, SymbolRecR); // dest + Prg.AsmPush_REG(Reg); + FreeReg(Reg); + + EmitStdCall(SubId); + end + else + EmitOP_ASSIGN_RECORD_EX; + finally + FreeAndNil(L); + end; +end; + +procedure TEmitter.EmitOP_ASSIGN_RECORD_EX; + + var SymbolTable: TSymbolTable; + + procedure AssignArr(Reg1, Reg2, TypeId: Integer); forward; + + procedure AssignRec(Reg1, Reg2, TypeId: Integer); + var + I, FT, Reg, SubId, S, K: Integer; + RI: TSymbolRec; + ArrayTypeId, + ElTypeId, ElFinalTypeId, ElSize, + ElTypeId2, ElFinalTypeId2, ElSize2: Integer; + begin + K := 0; + SubId := 0; + for I := TypeId + 1 to SymbolTable.Card do + begin + RI := SymbolTable[I]; + if RI = SymbolTable.SR0 then + break; + if RI.Level <> TypeId then + continue; + if RI.Kind <> kindTYPE_FIELD then + continue; + FT := RI.FinalTypeId; + S := RI.PtrSize; + + Inc(K); + + Emit_PUSH_REGS; + + if K > 1 then + begin + Prg.AsmAddREG_Imm(Reg1, RI.Shift); + Prg.AsmAddREG_Imm(Reg2, RI.Shift); + end; + + case FT of + typeINTEGER, typeCARDINAL, typeLONGBOOL: + begin + Reg := GetReg; + Prg.AsmMovREG32_REGPtr(Reg, Reg2); + Prg.AsmMovREGPtr_REG32(Reg1, Reg); + FreeReg(Reg); + end; + typePOINTER, typePROC, + typeCLASS, typeCLASSREF: + begin + Reg := GetReg; + Prg.AsmMovREG_REGPtr(Reg, Reg2); + Prg.AsmMovREGPtr_REG(Reg1, Reg); + FreeReg(Reg); + end; + typeWORD, typeSMALLINT, typeWORDBOOL, typeWIDECHAR: + begin + Reg := GetReg; + Prg.AsmXorREG_REG(Reg, Reg); + Prg.AsmMovREG16_REGPtr(Reg, Reg2); + Prg.AsmMovREGPtr_REG16(Reg1, Reg); + FreeReg(Reg); + end; + typeBYTE, + typeBOOLEAN, + typeSHORTINT, +{$IFNDEF PAXARM} + typeANSICHAR, +{$ENDIF} + typeBYTEBOOL: + begin + Reg := GetReg; + Prg.AsmXorREG_REG(Reg, Reg); + Prg.AsmMovREG8_REGPtr(Reg, Reg2); + Prg.AsmMovREGPtr_REG8(Reg1, Reg); + FreeReg(Reg); + end; +{$IFNDEF PAXARM} + typeANSISTRING, + typeWIDESTRING, + typeSHORTSTRING, +{$ENDIF} + typeUNICSTRING, + typeVARIANT, + typeOLEVARIANT, + typeINTERFACE: + begin + case FT of +{$IFNDEF PAXARM} + typeANSISTRING: SubId := Id_AnsiStringAssign; + typeWIDESTRING: SubId := Id_WideStringAssign; + typeSHORTSTRING: SubId := Id_ShortStringAssign; +{$ENDIF} + typeUNICSTRING: SubId := Id_UnicStringAssign; + typeVARIANT, typeOLEVARIANT: SubId := Id_VariantAssign; + typeINTERFACE: SubId := Id_InterfaceAssign; + end; + + EmitCallPro(SubId); + + Reg := GetReg; + Prg.AsmPush_REG(Reg1); + Prg.AsmPush_REG(Reg2); + FreeReg(Reg); + + EmitStdCall(SubId); + end; + typeDYNARRAY: + begin + SubId := Id_DynarrayAssign; + EmitCallPro(SubId); + + Reg := GetReg; + ArrayTypeId := RI.TerminalTypeId; + ElTypeId := GetSymbolRec(ArrayTypeId).PatternId; + ElFinalTypeId := GetSymbolRec(ElTypeId).FinalTypeId; + ElSize := SymbolTable[ElTypeId].Size; + + ElTypeId2 := 0; + ElFinalTypeId2 := 0; + ElSize2 := 0; + if ElFinalTypeId = typeDYNARRAY then + begin + ElTypeId2 := GetSymbolRec(ElTypeId).TerminalTypeId; + ElTypeId2 := GetSymbolRec(ElTypeId2).PatternId; + ElFinalTypeId2 := GetSymbolRec(ElTypeId2).FinalTypeId; + ElSize2 := SymbolTable[ElTypeId2].Size; + end; + + Prg.AsmPush_Imm(ElSize2); + Prg.AsmPush_Imm(ElTypeId2); + Prg.AsmPush_Imm(ElFinalTypeId2); + + Prg.AsmPush_Imm(ElSize); + Prg.AsmPush_Imm(ElTypeId); + Prg.AsmPush_Imm(ElFinalTypeId); + + Prg.AsmPush_REG(Reg1); // dest + Prg.AsmPush_REG(Reg2); // source + FreeReg(Reg); + + EmitStdCall(SubId); + end; + typeRECORD: + AssignRec(Reg1, Reg2, RI.TerminalTypeId); + typeARRAY: + AssignArr(Reg1, Reg2, RI.TerminalTypeId); + else + begin + SubId := Id_RecordAssign; + + EmitCallPro(SubId); + + Prg.AsmPush_Imm(S); + Prg.AsmPush_REG(Reg2); + Prg.AsmPush_REG(Reg1); + + EmitStdCall(SubId); + end; + end; // case + Emit_POP_REGS; + end; + end; + + procedure AssignArr(Reg1, Reg2, TypeId: Integer); + var + RangeTypeId, ElemTypeId, H1, H2, FT, I, ElemSize, S, SubId, Reg: Integer; + begin + SymbolTable.GetArrayTypeInfo(TypeId, RangeTypeId, ElemTypeId); + H1 := SymbolTable.GetLowBoundRec(RangeTypeId).Value; + H2 := SymbolTable.GetHighBoundRec(RangeTypeId).Value; + + ElemSize := SymbolTable[ElemTypeId].Size; + + FT := SymbolTable[ElemTypeId].FinalTypeId; + + SubId := 0; + + case FT of +{$IFNDEF PAXARM} + typeANSISTRING, + typeWIDESTRING, +{$ENDIF} + typeUNICSTRING, + typeDYNARRAY, + typeVARIANT, + typeOLEVARIANT, + typeINTERFACE: + begin + case FT of +{$IFNDEF PAXARM} + typeANSISTRING: SubId := Id_AnsiStringAssign; + typeWIDESTRING: SubId := Id_WideStringAssign; + typeSHORTSTRING: SubId := Id_ShortStringAssign; +{$ENDIF} + typeUNICSTRING: SubId := Id_UnicStringAssign; + typeVARIANT, typeOLEVARIANT: SubId := Id_VariantAssign; + typeINTERFACE: SubId := Id_InterfaceAssign; + end; + for I:=0 to H2 - H1 do + begin + Emit_PUSH_REGS; + + EmitCallPro(SubId); + + Prg.AsmAddREG_Imm(Reg1, I * ElemSize); + Prg.AsmAddREG_Imm(Reg2, I * ElemSize); + Reg := GetReg; + Prg.AsmPush_REG(Reg1); + Prg.AsmPush_REG(Reg2); + + FreeReg(Reg); + + EmitStdCall(SubId); + + Emit_POP_REGS; + end; + end; + typeRECORD: + begin + TypeID := SymbolTable.TerminalTypeOf(ElemTypeId); + for I:=0 to H2 - H1 do + begin + Emit_PUSH_REGS; + Prg.AsmAddREG_Imm(Reg1, I * ElemSize); + Prg.AsmAddREG_Imm(Reg2, I * ElemSize); + AssignRec(Reg1, Reg2, TypeId); + Emit_POP_REGS; + end; + end; + typeARRAY: + begin + TypeID := SymbolTable.TerminalTypeOf(ElemTypeId); + for I:=0 to H2 - H1 do + begin + Emit_PUSH_REGS; + Prg.AsmAddREG_Imm(Reg1, I * ElemSize); + Prg.AsmAddREG_Imm(Reg2, I * ElemSize); + AssignArr(Reg1, Reg2, TypeId); + Emit_POP_REGS; + end; + end; + else + begin + SubId := Id_RecordAssign; + + EmitCallPro(SubId); + + S := SymbolTable[TypeId].PtrSize; + Prg.AsmPush_Imm(S); + Prg.AsmPush_REG(Reg2); + Prg.AsmPush_REG(Reg1); + + EmitStdCall(SubId); + end; + end; // case + end; + +var + Reg1, Reg2, S, FT: Integer; +begin + EmitPCodeOperator; + SymbolTable := TKernel(kernel).SymbolTable; + Reg1 := GetReg; + Reg2 := GetReg; + EmitLoadAddress(Reg1, SymbolRec1); // source + EmitLoadAddress(Reg2, SymbolRec2); // dest + FT := SymbolRec1.FinalTypeId; + case FT of + typeRECORD: + begin + AssignRec(Reg1, Reg2, SymbolRec1.TerminalTypeId); + end; + typeARRAY: + begin + AssignArr(Reg1, Reg2, SymbolRec1.TerminalTypeId); + end; + else + begin + EmitCallPro(Id_RecordAssign); + + S := SymbolRec1.PtrSize; + Prg.AsmPush_Imm(S); + Prg.AsmPush_REG(Reg2); + Prg.AsmPush_REG(Reg1); + + EmitStdCall(Id_RecordAssign); + end; + end; + FreeReg(Reg1); + FreeReg(Reg2); +end; + +procedure TEmitter.EmitOP_ASSIGN_DOUBLE_64; +begin + EmitOP_ASSIGN_DOUBLE; +end; +procedure TEmitter.EmitOP_ASSIGN_DOUBLE; +begin + EmitPCodeOperator; + + EmitFld(SymbolRec2); + EmitFstp(SymbolRec1); +end; + +procedure TEmitter.EmitOP_ASSIGN_CURRENCY_64; +var + Reg: Integer; +begin + EmitPCodeOperator; + + Reg := GetReg; + EmitLoadIntVal(Reg, SymbolRec2); + EmitSaveIntVal(Reg, SymbolRec1); + FreeReg(Reg); +end; +procedure TEmitter.EmitOP_ASSIGN_CURRENCY; +var + Reg, Reg1, Reg2: Integer; +begin + EmitPCodeOperator; + + Reg := GetReg; + Reg1 := GetReg; + Reg2 := GetReg; + + EmitLoadAddress(Reg1, SymbolRec1); + EmitLoadAddress(Reg2, SymbolRec2); + + Prg.AsmMovREG32_REGPtr(Reg, Reg2); + Prg.AsmMovREGPtr_REG32(Reg1, Reg); + + Prg.AsmAddREG_Imm(Reg1, 4); + Prg.AsmAddREG_Imm(Reg2, 4); + + Prg.AsmMovREG32_REGPtr(Reg, Reg2); + Prg.AsmMovREGPtr_REG32(Reg1, Reg); + + FreeReg(Reg); + FreeReg(Reg1); + FreeReg(Reg2); +end; + +procedure TEmitter.EmitOP_ASSIGN_SINGLE_64; +begin + EmitOP_ASSIGN_SINGLE; +end; +procedure TEmitter.EmitOP_ASSIGN_SINGLE; +begin + EmitPCodeOperator; + + EmitFld(SymbolRec2); + EmitFstp(SymbolRec1); +end; + +procedure TEmitter.EmitOP_ASSIGN_EXTENDED_64; +var + Reg: Integer; +begin + EmitPCodeOperator; + + Reg := GetReg; + EmitLoadIntVal(Reg, SymbolRec2); + EmitSaveIntVal(Reg, SymbolRec1); + FreeReg(Reg); +end; +procedure TEmitter.EmitOP_ASSIGN_EXTENDED; +begin + EmitPCodeOperator; + + EmitFld(SymbolRec2); + EmitFstp(SymbolRec1); +end; + +procedure TEmitter.EmitOP_ASSIGN_INT64_64; +begin + EmitOP_ASSIGN_INT64; +end; +procedure TEmitter.EmitOP_ASSIGN_INT64; +var + Reg, Reg1, Reg2: Integer; +begin + EmitPCodeOperator; + + Reg := GetReg; + Reg1 := GetReg; + Reg2 := GetReg; + + EmitLoadAddress(Reg1, SymbolRec1); + EmitLoadAddress(Reg2, SymbolRec2); + + Prg.AsmMovREG32_REGPtr(Reg, Reg2); + Prg.AsmMovREGPtr_REG32(Reg1, Reg); + + Prg.AsmAddREG_Imm(Reg1, 4); + Prg.AsmAddREG_Imm(Reg2, 4); + + Prg.AsmMovREG32_REGPtr(Reg, Reg2); + Prg.AsmMovREGPtr_REG32(Reg1, Reg); + + FreeReg(Reg); + FreeReg(Reg1); + FreeReg(Reg2); +end; + +procedure TEmitter.EmitFistp(S: TSymbolRec); +var + Reg: Integer; +begin + Reg := GetReg; + EmitLoadAddress(Reg, S); + Prg.AsmFistp_REG64Ptr(Reg); + FreeReg(Reg); + Prg.AsmWait; +end; + +procedure TEmitter.EmitOP_CURRENCY_FROM_INT_64; +begin + EmitPCodeOperator; + + EmitFild(SymbolRec2); + EmitFMul_10000; + EmitFistp(SymbolRecR); +end; +procedure TEmitter.EmitOP_CURRENCY_FROM_INT; +begin + EmitPCodeOperator; + + EmitFild(SymbolRec2); + EmitFMul_10000; + EmitFistp(SymbolRecR); +end; + +procedure TEmitter.EmitOP_CURRENCY_FROM_INT64_64; +begin + EmitPCodeOperator; + + EmitFild(SymbolRec2); + EmitFMul_10000; + EmitFistp(SymbolRecR); +end; +procedure TEmitter.EmitOP_CURRENCY_FROM_INT64; +begin + EmitPCodeOperator; + + EmitFild(SymbolRec2); + EmitFMul_10000; + EmitFistp(SymbolRecR); +end; + +procedure TEmitter.EmitOP_CURRENCY_FROM_REAL_64; +begin + EmitPCodeOperator; + + EmitFLD(SymbolRec2); + EmitFMul_10000; + EmitFistp(SymbolRecR); +end; +procedure TEmitter.EmitOP_CURRENCY_FROM_REAL; +begin + EmitPCodeOperator; + + EmitFLD(SymbolRec2); + EmitFMul_10000; + EmitFistp(SymbolRecR); +end; + +procedure TEmitter.EmitCheckOperResult(Reg: Integer); +var + SubId, T: Integer; +begin + if OverflowCheck = false then + Exit; + if TargetPlatform = tpWIN64 then + Exit; + if TargetPlatform in [tpOSX32, tpIOSSim] then + Exit; + + T := SymbolRecR.FinalTypeId; + + case T of + typeINTEGER: + begin + SubId := Id_IntOver; + + GetReg(_EBX); + if TargetPlatform = tpWIN64 then + begin + Prg.AsmJNO_Imm(9); + EmitGet_REG(_EBX, SymbolTable[SubId]); // 6 bytes + Prg.AsmCall_REG(_EBX); // 3 bytes + end + else + begin + Prg.AsmJNO_Imm(8); + EmitGet_REG(_EBX, SymbolTable[SubId]); // 6 bytes + Prg.AsmCall_REG(_EBX); // 2 bytes + end; + FreeReg(_EBX); + end; + typeCARDINAL: + begin + GetReg(_EBX); + SubId := Id_IntOver; + if TargetPlatform = tpWIN64 then + begin + Prg.AsmJNC_Imm(9); + EmitGet_REG(_EBX, SymbolTable[SubId]); // 6 bytes + Prg.AsmCall_REG(_EBX); // 3 bytes + end + else + begin + Prg.AsmJNC_Imm(8); + EmitGet_REG(_EBX, SymbolTable[SubId]); // 6 bytes + Prg.AsmCall_REG(_EBX); // 2 bytes + end; + FreeReg(_EBX); + end; + typeBYTE: + begin + GetReg(_EBX); + SubId := Id_BoundError; + Prg.AsmCmpReg_Imm(Reg, $ff); + if TargetPlatform = tpWIN64 then + begin + Prg.AsmJBE_Imm(9); + EmitGet_REG(_EBX, SymbolTable[SubId]); // 6 bytes + Prg.AsmCall_REG(_EBX); // 3 bytes + end + else + begin + Prg.AsmJBE_Imm(8); + EmitGet_REG(_EBX, SymbolTable[SubId]); // 6 bytes + Prg.AsmCall_REG(_EBX); // 2 bytes + end; + FreeReg(_EBX); + end; + typeWORD: + begin + GetReg(_EBX); + SubId := Id_BoundError; + Prg.AsmCmpReg_Imm(Reg, $ffff); + if TargetPlatform = tpWIN64 then + begin + Prg.AsmJBE_Imm(9); + EmitGet_REG(_EBX, SymbolTable[SubId]); // 6 bytes + Prg.AsmCall_REG(_EBX); // 3 bytes + end + else + begin + Prg.AsmJBE_Imm(8); + EmitGet_REG(_EBX, SymbolTable[SubId]); // 6 bytes + Prg.AsmCall_REG(_EBX); // 2 bytes + end; + FreeReg(_EBX); + end; + end; +end; + +procedure TEmitter.EmitOP_ADD_INT_MI_64; +begin + EmitOP_ADD_INT_MI; +end; +procedure TEmitter.EmitOP_ADD_INT_MI; +var + Reg: Integer; +begin + EmitPCodeOperator; + + if (SymbolRec1 = SymbolRecR) and (SymbolRecR.Size = 4) then + begin + Reg := EmitGetAddressRegister(SymbolRec1); + Prg.AsmAddREGPtr_Imm(Reg, SymbolRec1, ImmValue2); + EmitCheckOperResult(Reg); + FreeReg(Reg); + end + else + begin + Reg := GetReg; + EmitLoadIntVal(Reg, SymbolRec1); + Prg.AsmAddREG_Imm(Reg, ImmValue2); + EmitCheckOperResult(Reg); + EmitSaveIntVal(Reg, SymbolRecR); + FreeReg(Reg); + end; +end; + +procedure TEmitter.EmitOP_ADD_INT_MM_64; +begin + EmitOP_ADD_INT_MM; +end; +procedure TEmitter.EmitOP_ADD_INT_MM; +var + Reg1, Reg2: Integer; +begin + EmitPCodeOperator; + + Reg1 := GetReg; + Reg2 := GetReg; + + EmitLoadIntVal(Reg1, SymbolRec1); + EmitLoadIntVal(Reg2, SymbolRec2); + + Prg.AsmAddREG_REG(Reg1, Reg2); + EmitCheckOperResult(Reg1); + + FreeReg(Reg2); + EmitSaveIntVal(Reg1, SymbolRecR); + + FreeReg(Reg1); +end; + +procedure TEmitter.EmitOP_NEG_INT_64; +begin + EmitOP_NEG_INT; +end; +procedure TEmitter.EmitOP_NEG_INT; +var + Reg: Integer; +begin + EmitPCodeOperator; + + if (SymbolRec1 = SymbolRecR) and (SymbolRec1.PtrSize = SizeOfPointer) then + begin + Reg := EmitGetAddressRegister(SymbolRec1); + Prg.AsmNEG_REGPtr(Reg, SymbolRec1); + EmitCheckOperResult(Reg); + FreeReg(Reg); + end + else + begin + Reg := GetReg; + EmitLoadIntVal(Reg, SymbolRec1); + Prg.AsmNEGREG(Reg); + EmitCheckOperResult(Reg); + EmitSaveIntVal(Reg, SymbolRecR); + FreeReg(Reg); + end; +end; + +procedure TEmitter.EmitOP_NOT_64; +begin + EmitOP_NOT; +end; +procedure TEmitter.EmitOP_NOT; +var + Reg1, Reg2: Integer; +begin + EmitPCodeOperator; + + Reg1 := GetReg; + EmitLoadIntVal(Reg1, SymbolRec1); + + if SymbolRecR.FinalTypeId in BooleanTypes then + begin + Reg2 := GetReg; + Prg.AsmMovREG_Imm(Reg2, 1); + Prg.AsmXorREG_REG(Reg1, Reg2); + FreeReg(Reg2); + end + else + begin + Prg.AsmNotREG(Reg1); + end; + + EmitSaveIntVal(Reg1, SymbolRecR); + FreeReg(Reg1); +end; + +procedure TEmitter.EmitOP_NOT_BOOL; +var + Reg1, Reg2: Integer; +begin + EmitPCodeOperator; + + Reg1 := GetReg; + EmitLoadIntVal(Reg1, SymbolRec1); + + Reg2 := GetReg; + Prg.AsmMovREG_Imm(Reg2, 1); + Prg.AsmXorREG_REG(Reg1, Reg2); + FreeReg(Reg2); + + EmitSaveIntVal(Reg1, SymbolRecR); + FreeReg(Reg1); +end; + +procedure TEmitter.EmitOP_NOT_BOOL64; +begin + EmitOP_NOT_BOOL; +end; + +procedure TEmitter.EmitOP_NOT_BYTEBOOL; +var + Reg: Integer; +begin + EmitPCodeOperator; + Reg := GetReg; + + EmitLoadIntVal(Reg, SymbolRec1); + Prg.AsmCmpReg_Imm(Reg, 0); + Prg.AsmJZ_Imm(7); + Prg.AsmXorREG_REG(Reg, Reg); //2 + Prg.AsmJMP_Imm(5); //5 + Prg.AsmMovREG_Imm(Reg, $ff); //5 + EmitSaveIntVal(Reg, SymbolRecR); + FreeReg(Reg); +end; + +procedure TEmitter.EmitOP_NOT_BYTEBOOL64; +var + Reg: Integer; +begin + EmitPCodeOperator; + Reg := GetReg; + + EmitLoadIntVal(Reg, SymbolRec1); + Prg.AsmCmpReg_Imm(Reg, 0); + Prg.AsmJZ_Imm(8); + Prg.AsmXorREG_REG(Reg, Reg); //3 + Prg.AsmJMP_Imm(10); //5 + Prg.AsmMovREG_Imm(Reg, $ff); //10 + EmitSaveIntVal(Reg, SymbolRecR); + FreeReg(Reg); +end; + +procedure TEmitter.EmitOP_NOT_WORDBOOL; +var + Reg: Integer; +begin + EmitPCodeOperator; + Reg := GetReg; + + EmitLoadIntVal(Reg, SymbolRec1); + Prg.AsmCmpReg_Imm(Reg, 0); + Prg.AsmJZ_Imm(7); + Prg.AsmXorREG_REG(Reg, Reg); //2 + Prg.AsmJMP_Imm(5); //5 + Prg.AsmMovREG_Imm(Reg, $ffff); //5 + EmitSaveIntVal(Reg, SymbolRecR); + FreeReg(Reg); +end; + +procedure TEmitter.EmitOP_NOT_WORDBOOL64; +var + Reg: Integer; +begin + EmitPCodeOperator; + Reg := GetReg; + + EmitLoadIntVal(Reg, SymbolRec1); + Prg.AsmCmpReg_Imm(Reg, 0); + Prg.AsmJZ_Imm(8); + Prg.AsmXorREG_REG(Reg, Reg); //3 + Prg.AsmJMP_Imm(10); //5 + Prg.AsmMovREG_Imm(Reg, $ffff); //10 + EmitSaveIntVal(Reg, SymbolRecR); + FreeReg(Reg); +end; + +procedure TEmitter.EmitOP_NOT_LONGBOOL; +var + Reg: Integer; +begin + EmitPCodeOperator; + Reg := GetReg; + + EmitLoadIntVal(Reg, SymbolRec1); + Prg.AsmCmpReg_Imm(Reg, 0); + Prg.AsmJZ_Imm(7); + Prg.AsmXorREG_REG(Reg, Reg); //2 + Prg.AsmJMP_Imm(5); //5 + Prg.AsmMovREG_Imm(Reg, $ffffffff); //5 + EmitSaveIntVal(Reg, SymbolRecR); + FreeReg(Reg); +end; + +procedure TEmitter.EmitOP_NOT_LONGBOOL64; +var + Reg: Integer; +begin + EmitPCodeOperator; + Reg := GetReg; + + EmitLoadIntVal(Reg, SymbolRec1); + Prg.AsmCmpReg_Imm(Reg, 0); + Prg.AsmJZ_Imm(8); + Prg.AsmXorREG_REG(Reg, Reg); //3 + Prg.AsmJMP_Imm(10); //5 + Prg.AsmMovREG_Imm(Reg, $ffffffff); //10 + EmitSaveIntVal(Reg, SymbolRecR); + FreeReg(Reg); +end; + +procedure TEmitter.EmitOP_SUB_INT_MI_64; +begin + EmitOP_SUB_INT_MI; +end; +procedure TEmitter.EmitOP_SUB_INT_MI; +var + Reg: Integer; +begin + EmitPCodeOperator; + + Reg := GetReg; + EmitLoadIntVal(Reg, SymbolRec1); + Prg.AsmSubREG_Imm(Reg, ImmValue2); + EmitCheckOperResult(Reg); + EmitSaveIntVal(Reg, SymbolRecR); + FreeReg(Reg); +end; + +procedure TEmitter.EmitOP_SUB_INT_MM_64; +begin + EmitOP_SUB_INT_MM; +end; +procedure TEmitter.EmitOP_SUB_INT_MM; +var + Reg1, Reg2: Integer; +begin + EmitPCodeOperator; + + Reg1 := GetReg; + Reg2 := GetReg; + + EmitLoadIntVal(Reg1, SymbolRec1); + EmitLoadIntVal(Reg2, SymbolRec2); + + Prg.AsmSubREG_REG(Reg1, Reg2); + EmitCheckOperResult(Reg1); + + FreeReg(Reg2); + EmitSaveIntVal(Reg1, SymbolRecR); + + FreeReg(Reg1); +end; + +procedure TEmitter.EmitOP_IMUL_INT_MI_64; +begin + EmitOP_IMUL_INT_MI; +end; +procedure TEmitter.EmitOP_IMUL_INT_MI; +var + Reg2: Integer; +begin + EmitPCodeOperator; + + GetReg(_EAX); + Reg2 := GetReg; + + EmitLoadIntVal(_EAX, SymbolRec1); + Prg.AsmMovREG_Imm(Reg2, SymbolRec2.Value); + + Prg.AsmIMulREG(Reg2); + EmitCheckOperResult(_EAX); + + FreeReg(Reg2); + EmitSaveIntVal(_EAX, SymbolRecR); + + FreeReg(_EAX); +end; + +procedure TEmitter.EmitOP_IMUL_INT_MM_64; +begin + EmitOP_IMUL_INT_MM; +end; +procedure TEmitter.EmitOP_IMUL_INT_MM; +var + Reg2: Integer; +begin + EmitPCodeOperator; + + GetReg(_EAX); + Reg2 := GetReg; + + EmitLoadIntVal(_EAX, SymbolRec1); + EmitLoadIntVal(Reg2, SymbolRec2); + + Prg.AsmIMulREG(Reg2); + EmitCheckOperResult(_EAX); + + FreeReg(Reg2); + EmitSaveIntVal(_EAX, SymbolRecR); + + FreeReg(_EAX); +end; + +procedure TEmitter.EmitOP_IDIV_INT_MI_64; +begin + EmitOP_IDIV_INT_MI; +end; +procedure TEmitter.EmitOP_IDIV_INT_MI; +begin + EmitPCodeOperator; + + GetReg(_EAX); + GetReg(_ECX); + + EmitLoadIntVal(_EAX, SymbolRec1); + Prg.AsmMovREG_Imm(_ECX, SymbolRec2.Value); + + if SymbolRec1.FinalTypeId in UnsignedIntegerTypes then + begin + Prg.AsmXORReg_Reg(_EDX, _EDX); + Prg.AsmDivREG(_ECX); + end + else + begin + Prg.AsmCDQ; + Prg.AsmIDivREG(_ECX); + end; + + FreeReg(_ECX); + EmitSaveIntVal(_EAX, SymbolRecR); + FreeReg(_EAX); +end; + +procedure TEmitter.EmitOP_IDIV_INT_MM_64; +begin + EmitOP_IDIV_INT_MM; +end; +procedure TEmitter.EmitOP_IDIV_INT_MM; +begin + EmitPCodeOperator; + + GetReg(_EAX); + GetReg(_ECX); + + EmitLoadIntVal(_EAX, SymbolRec1); + EmitLoadIntVal(_ECX, SymbolRec2); + + if (SymbolRec1.FinalTypeId in UnsignedIntegerTypes) and + (SymbolRec2.FinalTypeId in UnsignedIntegerTypes) then + begin + Prg.AsmXORReg_Reg(_EDX, _EDX); + Prg.AsmDivREG(_ECX); + end + else + begin + Prg.AsmCDQ; + Prg.AsmIDivREG(_ECX); + end; + + FreeReg(_ECX); + EmitSaveIntVal(_EAX, SymbolRecR); + FreeReg(_EAX); +end; + +procedure TEmitter.EmitOP_IDIV_INT_IM_64; +begin + EmitOP_IDIV_INT_IM; +end; +procedure TEmitter.EmitOP_IDIV_INT_IM; +begin + EmitPCodeOperator; + + GetReg(_EAX); + GetReg(_ECX); + + Prg.AsmMovREG_Imm(_EAX, SymbolRec1.Value); + EmitLoadIntVal(_ECX, SymbolRec2); + + if SymbolRec2.FinalTypeId in UnsignedIntegerTypes then + begin + Prg.AsmXORReg_Reg(_EDX, _EDX); + Prg.AsmDivREG(_ECX); + end + else + begin + Prg.AsmCDQ; + Prg.AsmIDivREG(_ECX); + end; + + FreeReg(_ECX); + EmitSaveIntVal(_EAX, SymbolRecR); + FreeReg(_EAX); +end; + +procedure TEmitter.EmitOP_MOD_INT_MI_64; +begin + EmitOP_MOD_INT_MI; +end; +procedure TEmitter.EmitOP_MOD_INT_MI; +begin + EmitPCodeOperator; + + GetReg(_EAX); + GetReg(_EDX); + GetReg(_ECX); + + EmitLoadIntVal(_EAX, SymbolRec1); + Prg.AsmMovREG_Imm(_ECX, SymbolRec2.Value); + + if SymbolRec1.FinalTypeId in UnsignedIntegerTypes then + begin + Prg.AsmXORReg_Reg(_EDX, _EDX); + Prg.AsmDivREG(_ECX); + end + else + begin + Prg.AsmCDQ; + Prg.AsmIDivREG(_ECX); + end; + + FreeReg(_ECX); + FreeReg(_EAX); + EmitSaveIntVal(_EDX, SymbolRecR); + FreeReg(_EDX); +end; + +procedure TEmitter.EmitOP_MOD_INT_MM_64; +begin + EmitOP_MOD_INT_MM; +end; +procedure TEmitter.EmitOP_MOD_INT_MM; +begin + EmitPCodeOperator; + + GetReg(_EAX); + GetReg(_EDX); + GetReg(_ECX); + + EmitLoadIntVal(_EAX, SymbolRec1); + EmitLoadIntVal(_ECX, SymbolRec2); + + if (SymbolRec1.FinalTypeId in UnsignedIntegerTypes) and + (SymbolRec2.FinalTypeId in UnsignedIntegerTypes) then + begin + Prg.AsmXORReg_Reg(_EDX, _EDX); + Prg.AsmDivREG(_ECX); + end + else + begin + Prg.AsmCDQ; + Prg.AsmIDivREG(_ECX); + end; + + FreeReg(_ECX); + EmitSaveIntVal(_EDX, SymbolRecR); + FreeReg(_EDX); + FreeReg(_EAX); +end; + +procedure TEmitter.EmitOP_MOD_INT_IM_64; +begin + EmitOP_MOD_INT_IM; +end; +procedure TEmitter.EmitOP_MOD_INT_IM; +begin + EmitPCodeOperator; + + GetReg(_EAX); + GetReg(_EDX); + GetReg(_ECX); + + Prg.AsmMovREG_Imm(_EAX, SymbolRec1.Value); + EmitLoadIntVal(_ECX, SymbolRec2); + + if SymbolRec1.FinalTypeId in UnsignedIntegerTypes then + begin + Prg.AsmXORReg_Reg(_EDX, _EDX); + Prg.AsmDivREG(_ECX); + end + else + begin + Prg.AsmCDQ; + Prg.AsmIDivREG(_ECX); + end; + + FreeReg(_ECX); + EmitSaveIntVal(_EDX, SymbolRecR); + + FreeReg(_EDX); + FreeReg(_EAX); +end; + +procedure TEmitter.EmitOP_SHL_INT_MI_64; +begin + EmitOP_SHL_INT_MI; +end; +procedure TEmitter.EmitOP_SHL_INT_MI; +var + Reg: Integer; +begin + EmitPCodeOperator; + + GetReg(_ECX); + Reg := GetReg; + + Prg.AsmXorREG_REG(Reg, Reg); + EmitLoadIntVal(Reg, SymbolRec1); + Prg.AsmMovREG_Imm(_ECX, SymbolRec2.Value); + Prg.AsmShlREG(Reg); + EmitSaveIntVal(Reg, SymbolRecR); + + FreeReg(Reg); + FreeReg(_ECX); +end; + +procedure TEmitter.EmitOP_SHL_INT_MM_64; +begin + EmitOP_SHL_INT_MM; +end; +procedure TEmitter.EmitOP_SHL_INT_MM; +var + Reg: Integer; +begin + EmitPCodeOperator; + + GetReg(_ECX); + Reg := GetReg; + + Prg.AsmXorREG_REG(Reg, Reg); + EmitLoadIntVal(Reg, SymbolRec1); + EmitLoadIntVal(_ECX, SymbolRec2); + Prg.AsmShlREG(Reg); + EmitSaveIntVal(Reg, SymbolRecR); + + FreeReg(Reg); + FreeReg(_ECX); +end; + +procedure TEmitter.EmitOP_SHL_INT_IM_64; +begin + EmitOP_SHL_INT_IM; +end; +procedure TEmitter.EmitOP_SHL_INT_IM; +var + Reg: Integer; +begin + EmitPCodeOperator; + + GetReg(_ECX); + Reg := GetReg; + + Prg.AsmMovREG_Imm(Reg, SymbolRec1.Value); + EmitLoadIntVal(_ECX, SymbolRec2); + Prg.AsmShlREG(Reg); + EmitSaveIntVal(Reg, SymbolRecR); + + FreeReg(Reg); + FreeReg(_ECX); +end; + +procedure TEmitter.EmitOP_SHR_INT_MI_64; +begin + EmitOP_SHR_INT_MI; +end; +procedure TEmitter.EmitOP_SHR_INT_MI; +var + Reg: Integer; +begin + EmitPCodeOperator; + + GetReg(_ECX); + Reg := GetReg; + + Prg.AsmXorREG_REG(Reg, Reg); + EmitLoadIntVal(Reg, SymbolRec1); + Prg.AsmMovREG_Imm(_ECX, SymbolRec2.Value); + Prg.AsmShrREG(Reg); + EmitSaveIntVal(Reg, SymbolRecR); + + FreeReg(Reg); + FreeReg(_ECX); +end; + +procedure TEmitter.EmitOP_SHR_INT_MM_64; +begin + EmitOP_SHR_INT_MM; +end; +procedure TEmitter.EmitOP_SHR_INT_MM; +var + Reg: Integer; +begin + EmitPCodeOperator; + + GetReg(_ECX); + Reg := GetReg; + + Prg.AsmXorREG_REG(Reg, Reg); + EmitLoadIntVal(Reg, SymbolRec1); + EmitLoadIntVal(_ECX, SymbolRec2); + Prg.AsmShrREG(Reg); + EmitSaveIntVal(Reg, SymbolRecR); + + FreeReg(Reg); + FreeReg(_ECX); +end; + +procedure TEmitter.EmitOP_SHR_INT_IM_64; +begin + EmitOP_SHR_INT_IM; +end; +procedure TEmitter.EmitOP_SHR_INT_IM; +var + Reg: Integer; +begin + EmitPCodeOperator; + + GetReg(_ECX); + Reg := GetReg; + + Prg.AsmMovREG_Imm(Reg, SymbolRec1.Value); + EmitLoadIntVal(_ECX, SymbolRec2); + Prg.AsmShrREG(Reg); + EmitSaveIntVal(Reg, SymbolRecR); + + FreeReg(Reg); + FreeReg(_ECX); +end; + +procedure TEmitter.EmitOP_AND_INT_MI_64; +begin + EmitOP_AND_INT_MI; +end; +procedure TEmitter.EmitOP_AND_INT_MI; +var + Reg1, Reg2: Integer; +begin + EmitPCodeOperator; + + Reg1 := GetReg; + Reg2 := GetReg; + + EmitLoadIntVal(Reg1, SymbolRec1); + Prg.AsmMovREG_Imm(Reg2, SymbolRec2.Value); + Prg.AsmAndREG_REG(Reg1, Reg2); + EmitSaveIntVal(Reg1, SymbolRecR); + + FreeReg(Reg2); + FreeReg(Reg1); +end; + +procedure TEmitter.EmitOP_AND_INT_MM_64; +begin + EmitOP_AND_INT_MM; +end; +procedure TEmitter.EmitOP_AND_INT_MM; +var + Reg1, Reg2: Integer; +begin + EmitPCodeOperator; + + Reg1 := GetReg; + Reg2 := GetReg; + + EmitLoadIntVal(Reg1, SymbolRec1); + EmitLoadIntVal(Reg2, SymbolRec2); + Prg.AsmAndREG_REG(Reg1, Reg2); + EmitSaveIntVal(Reg1, SymbolRecR); + + FreeReg(Reg2); + FreeReg(Reg1); +end; + +procedure TEmitter.EmitOP_OR_INT_MI_64; +begin + EmitOP_OR_INT_MI; +end; +procedure TEmitter.EmitOP_OR_INT_MI; +var + Reg1, Reg2: Integer; +begin + EmitPCodeOperator; + + Reg1 := GetReg; + Reg2 := GetReg; + + EmitLoadIntVal(Reg1, SymbolRec1); + Prg.AsmMovREG_Imm(Reg2, SymbolRec2.Value); + Prg.AsmOrREG_REG(Reg1, Reg2); + EmitSaveIntVal(Reg1, SymbolRecR); + + FreeReg(Reg2); + FreeReg(Reg1); +end; + +procedure TEmitter.EmitOP_OR_INT_MM_64; +begin + EmitOP_OR_INT_MM; +end; +procedure TEmitter.EmitOP_OR_INT_MM; +var + Reg1, Reg2: Integer; +begin + EmitPCodeOperator; + + Reg1 := GetReg; + Reg2 := GetReg; + + EmitLoadIntVal(Reg1, SymbolRec1); + EmitLoadIntVal(Reg2, SymbolRec2); + Prg.AsmOrREG_REG(Reg1, Reg2); + EmitSaveIntVal(Reg1, SymbolRecR); + + FreeReg(Reg2); + FreeReg(Reg1); +end; + +procedure TEmitter.EmitOP_XOR_INT_MI_64; +begin + EmitOP_XOR_INT_MI; +end; +procedure TEmitter.EmitOP_XOR_INT_MI; +var + Reg1, Reg2: Integer; +begin + EmitPCodeOperator; + + Reg1 := GetReg; + Reg2 := GetReg; + + EmitLoadIntVal(Reg1, SymbolRec1); + Prg.AsmMovREG_Imm(Reg2, SymbolRec2.Value); + Prg.AsmXorREG_REG(Reg1, Reg2); + EmitSaveIntVal(Reg1, SymbolRecR); + + FreeReg(Reg2); + FreeReg(Reg1); +end; + +procedure TEmitter.EmitOP_XOR_INT_MM_64; +begin + EmitOP_XOR_INT_MM; +end; +procedure TEmitter.EmitOP_XOR_INT_MM; +var + Reg1, Reg2: Integer; +begin + EmitPCodeOperator; + + Reg1 := GetReg; + Reg2 := GetReg; + + EmitLoadIntVal(Reg1, SymbolRec1); + EmitLoadIntVal(Reg2, SymbolRec2); + Prg.AsmXorREG_REG(Reg1, Reg2); + EmitSaveIntVal(Reg1, SymbolRecR); + + FreeReg(Reg2); + FreeReg(Reg1); +end; + +procedure TEmitter.EmitOP_ADD_INT64_64; +begin + EmitOP_ADD_INT64; +end; +procedure TEmitter.EmitOP_ADD_INT64; +begin + EmitPCodeOperator; + + GetReg(_ECX); + GetReg(_EAX); + GetReg(_EDX); + + Prg.AsmClc; + +// EAX:EDX <-- [N1] + + EmitLoadAddress(_ECX, SymbolRec1); + Prg.AsmMovREG32_REGPtr(_EAX, _ECX); + Prg.AsmAddREG_Imm(_ECX, 4); + Prg.AsmMovREG32_REGPtr(_EDX, _ECX); + +// ADD EAX, [N2] + + EmitLoadAddress(_ECX, SymbolRec2); + Prg.AsmMovREG32_REGPtr(_ECX, _ECX); + Prg.AsmAddREG_REG(_EAX, _ECX); + + Prg.AsmPushfd; + +// ADC EDX, [N2 + 4] + + EmitLoadAddress(_ECX, SymbolRec2); + Prg.AsmAddREG_Imm(_ECX, 4); + Prg.AsmMovREG32_REGPtr(_ECX, _ECX); + Prg.AsmPopfd; + Prg.AsmAdcREG_REG(_EDX, _ECX); + +// EAX:EDX --> [N2] + + EmitLoadAddress(_ECX, SymbolRecR); + Prg.AsmMovREGPtr_REG32(_ECX, _EAX); + Prg.AsmAddREG_Imm(_ECX, 4); + Prg.AsmMovREGPtr_REG32(_ECX, _EDX); + + FreeReg(_EAX); + FreeReg(_EDX); + FreeReg(_ECX); +end; + +procedure TEmitter.EmitOP_ADD_UINT64_64; +begin + EmitOP_ADD_UINT64; +end; +procedure TEmitter.EmitOP_ADD_UINT64; +begin + EmitPCodeOperator; + + GetReg(_ECX); + GetReg(_EAX); + GetReg(_EDX); + + Prg.AsmClc; + +// EAX:EDX <-- [N1] + + EmitLoadAddress(_ECX, SymbolRec1); + Prg.AsmMovREG32_REGPtr(_EAX, _ECX); + Prg.AsmAddREG_Imm(_ECX, 4); + Prg.AsmMovREG32_REGPtr(_EDX, _ECX); + +// ADD EAX, [N2] + + EmitLoadAddress(_ECX, SymbolRec2); + Prg.AsmMovREG32_REGPtr(_ECX, _ECX); + Prg.AsmAddREG_REG(_EAX, _ECX); + + Prg.AsmPushfd; + +// ADC EDX, [N2 + 4] + + EmitLoadAddress(_ECX, SymbolRec2); + Prg.AsmAddREG_Imm(_ECX, 4); + Prg.AsmMovREG32_REGPtr(_ECX, _ECX); + Prg.AsmPopfd; + Prg.AsmAdcREG_REG(_EDX, _ECX); + +// EAX:EDX --> [N2] + + EmitLoadAddress(_ECX, SymbolRecR); + Prg.AsmMovREGPtr_REG32(_ECX, _EAX); + Prg.AsmAddREG_Imm(_ECX, 4); + Prg.AsmMovREGPtr_REG32(_ECX, _EDX); + + FreeReg(_EAX); + FreeReg(_EDX); + FreeReg(_ECX); +end; + +procedure TEmitter.EmitOP_NEG_INT64_64; +begin + EmitOP_NEG_INT64; +end; +procedure TEmitter.EmitOP_NEG_INT64; +begin + EmitPCodeOperator; + + GetReg(_EAX); + GetReg(_EDX); + GetReg(_ECX); + + Prg.AsmClc; + +// EAX:EDX <-- [N1] + + EmitLoadAddress(_ECX, SymbolRec1); + Prg.AsmMovREG32_REGPtr(_EAX, _ECX); + Prg.AsmAddREG_Imm(_ECX, 4); + Prg.AsmMovREG32_REGPtr(_EDX, _ECX); + + Prg.AsmXorREG_REG(_ECX, _ECX); + Prg.AsmNegREG(_EAX); + Prg.AsmXCHG(_EDX, _ECX); + Prg.AsmSbbREG_REG(_EDX, _ECX); + +// EAX:EDX --> [N2] + + EmitLoadAddress(_ECX, SymbolRecR); + Prg.AsmMovREGPtr_REG32(_ECX, _EAX); + Prg.AsmAddREG_Imm(_ECX, 4); + Prg.AsmMovREGPtr_REG32(_ECX, _EDX); + + FreeReg(_EAX); + FreeReg(_EDX); + FreeReg(_ECX); +end; + +procedure TEmitter.EmitOP_SUB_INT64_64; +begin + EmitOP_SUB_INT64; +end; +procedure TEmitter.EmitOP_SUB_INT64; +begin + EmitPCodeOperator; + + GetReg(_ECX); + GetReg(_EAX); + GetReg(_EDX); + +// EAX:EDX <-- [N1] + + EmitLoadAddress(_ECX, SymbolRec1); + Prg.AsmMovREG32_REGPtr(_EAX, _ECX); + Prg.AsmAddREG_Imm(_ECX, 4); + Prg.AsmMovREG32_REGPtr(_EDX, _ECX); + +// SUB EAX, [N2] + + EmitLoadAddress(_ECX, SymbolRec2); + Prg.AsmMovREG32_REGPtr(_ECX, _ECX); + Prg.AsmSubREG_REG(_EAX, _ECX); + + Prg.AsmPushfd; + +// SBB EDX, [N2 + 4] + + EmitLoadAddress(_ECX, SymbolRec2); + Prg.AsmAddREG_Imm(_ECX, 4); + Prg.AsmMovREG32_REGPtr(_ECX, _ECX); + Prg.AsmPopfd; + Prg.AsmSbbREG_REG(_EDX, _ECX); + +// EAX:EDX --> [N2] + + EmitLoadAddress(_ECX, SymbolRecR); + Prg.AsmMovREGPtr_REG32(_ECX, _EAX); + Prg.AsmAddREG_Imm(_ECX, 4); + Prg.AsmMovREGPtr_REG32(_ECX, _EDX); + + FreeReg(_EAX); + FreeReg(_EDX); + FreeReg(_ECX); +end; + +procedure TEmitter.EmitOP_SUB_UINT64_64; +begin + EmitOP_SUB_INT64; +end; +procedure TEmitter.EmitOP_SUB_UINT64; +begin + EmitPCodeOperator; + + GetReg(_ECX); + GetReg(_EAX); + GetReg(_EDX); + +// EAX:EDX <-- [N1] + + EmitLoadAddress(_ECX, SymbolRec1); + Prg.AsmMovREG32_REGPtr(_EAX, _ECX); + Prg.AsmAddREG_Imm(_ECX, 4); + Prg.AsmMovREG32_REGPtr(_EDX, _ECX); + +// SUB EAX, [N2] + + EmitLoadAddress(_ECX, SymbolRec2); + Prg.AsmMovREG32_REGPtr(_ECX, _ECX); + Prg.AsmSubREG_REG(_EAX, _ECX); + + Prg.AsmPushfd; + +// SBB EDX, [N2 + 4] + + EmitLoadAddress(_ECX, SymbolRec2); + Prg.AsmAddREG_Imm(_ECX, 4); + Prg.AsmMovREG32_REGPtr(_ECX, _ECX); + Prg.AsmPopfd; + Prg.AsmSbbREG_REG(_EDX, _ECX); + +// EAX:EDX --> [N2] + + EmitLoadAddress(_ECX, SymbolRecR); + Prg.AsmMovREGPtr_REG32(_ECX, _EAX); + Prg.AsmAddREG_Imm(_ECX, 4); + Prg.AsmMovREGPtr_REG32(_ECX, _EDX); + + FreeReg(_EAX); + FreeReg(_EDX); + FreeReg(_ECX); +end; + +procedure TEmitter.EmitOP_AND_INT64_64; +begin + EmitOP_AND_INT64; +end; +procedure TEmitter.EmitOP_AND_INT64; +begin + EmitPCodeOperator; + + GetReg(_ECX); + GetReg(_EAX); + GetReg(_EDX); + +// EAX:EDX <-- [N1] + + EmitLoadAddress(_ECX, SymbolRec1); + Prg.AsmMovREG32_REGPtr(_EAX, _ECX); + Prg.AsmAddREG_Imm(_ECX, 4); + Prg.AsmMovREG32_REGPtr(_EDX, _ECX); + +// AND EAX, [N2] + + EmitLoadAddress(_ECX, SymbolRec2); + Prg.AsmMovREG32_REGPtr(_ECX, _ECX); + Prg.AsmAndREG_REG(_EAX, _ECX); + +// AND EDX, [N2 + 4] + + EmitLoadAddress(_ECX, SymbolRec2); + Prg.AsmAddREG_Imm(_ECX, 4); + Prg.AsmMovREG32_REGPtr(_ECX, _ECX); + Prg.AsmAndREG_REG(_EDX, _ECX); + +// EAX:EDX --> [N2] + + EmitLoadAddress(_ECX, SymbolRecR); + Prg.AsmMovREGPtr_REG32(_ECX, _EAX); + Prg.AsmAddREG_Imm(_ECX, 4); + Prg.AsmMovREGPtr_REG32(_ECX, _EDX); + + FreeReg(_EAX); + FreeReg(_EDX); + FreeReg(_ECX); +end; + +procedure TEmitter.EmitOP_AND_UINT64_64; +begin + EmitOP_AND_INT64; +end; +procedure TEmitter.EmitOP_AND_UINT64; +begin + EmitPCodeOperator; + + GetReg(_ECX); + GetReg(_EAX); + GetReg(_EDX); + +// EAX:EDX <-- [N1] + + EmitLoadAddress(_ECX, SymbolRec1); + Prg.AsmMovREG32_REGPtr(_EAX, _ECX); + Prg.AsmAddREG_Imm(_ECX, 4); + Prg.AsmMovREG32_REGPtr(_EDX, _ECX); + +// AND EAX, [N2] + + EmitLoadAddress(_ECX, SymbolRec2); + Prg.AsmMovREG32_REGPtr(_ECX, _ECX); + Prg.AsmAndREG_REG(_EAX, _ECX); + +// AND EDX, [N2 + 4] + + EmitLoadAddress(_ECX, SymbolRec2); + Prg.AsmAddREG_Imm(_ECX, 4); + Prg.AsmMovREG32_REGPtr(_ECX, _ECX); + Prg.AsmAndREG_REG(_EDX, _ECX); + +// EAX:EDX --> [N2] + + EmitLoadAddress(_ECX, SymbolRecR); + Prg.AsmMovREGPtr_REG32(_ECX, _EAX); + Prg.AsmAddREG_Imm(_ECX, 4); + Prg.AsmMovREGPtr_REG32(_ECX, _EDX); + + FreeReg(_EAX); + FreeReg(_EDX); + FreeReg(_ECX); +end; + +procedure TEmitter.EmitOP_OR_INT64_64; +begin + EmitOP_OR_INT64; +end; +procedure TEmitter.EmitOP_OR_INT64; +begin + EmitPCodeOperator; + + GetReg(_ECX); + GetReg(_EAX); + GetReg(_EDX); + +// EAX:EDX <-- [N1] + + EmitLoadAddress(_ECX, SymbolRec1); + Prg.AsmMovREG32_REGPtr(_EAX, _ECX); + Prg.AsmAddREG_Imm(_ECX, 4); + Prg.AsmMovREG32_REGPtr(_EDX, _ECX); + +// OR EAX, [N2] + + EmitLoadAddress(_ECX, SymbolRec2); + Prg.AsmMovREG32_REGPtr(_ECX, _ECX); + Prg.AsmOrREG_REG(_EAX, _ECX); + +// OR EDX, [N2 + 4] + + EmitLoadAddress(_ECX, SymbolRec2); + Prg.AsmAddREG_Imm(_ECX, 4); + Prg.AsmMovREG32_REGPtr(_ECX, _ECX); + Prg.AsmOrREG_REG(_EDX, _ECX); + +// EAX:EDX --> [N2] + + EmitLoadAddress(_ECX, SymbolRecR); + Prg.AsmMovREGPtr_REG32(_ECX, _EAX); + Prg.AsmAddREG_Imm(_ECX, 4); + Prg.AsmMovREGPtr_REG32(_ECX, _EDX); + + FreeReg(_EAX); + FreeReg(_EDX); + FreeReg(_ECX); +end; + +procedure TEmitter.EmitOP_OR_UINT64_64; +begin + EmitOP_OR_UINT64; +end; +procedure TEmitter.EmitOP_OR_UINT64; +begin + EmitPCodeOperator; + + GetReg(_ECX); + GetReg(_EAX); + GetReg(_EDX); + +// EAX:EDX <-- [N1] + + EmitLoadAddress(_ECX, SymbolRec1); + Prg.AsmMovREG32_REGPtr(_EAX, _ECX); + Prg.AsmAddREG_Imm(_ECX, 4); + Prg.AsmMovREG32_REGPtr(_EDX, _ECX); + +// OR EAX, [N2] + + EmitLoadAddress(_ECX, SymbolRec2); + Prg.AsmMovREG32_REGPtr(_ECX, _ECX); + Prg.AsmOrREG_REG(_EAX, _ECX); + +// OR EDX, [N2 + 4] + + EmitLoadAddress(_ECX, SymbolRec2); + Prg.AsmAddREG_Imm(_ECX, 4); + Prg.AsmMovREG32_REGPtr(_ECX, _ECX); + Prg.AsmOrREG_REG(_EDX, _ECX); + +// EAX:EDX --> [N2] + + EmitLoadAddress(_ECX, SymbolRecR); + Prg.AsmMovREGPtr_REG32(_ECX, _EAX); + Prg.AsmAddREG_Imm(_ECX, 4); + Prg.AsmMovREGPtr_REG32(_ECX, _EDX); + + FreeReg(_EAX); + FreeReg(_EDX); + FreeReg(_ECX); +end; + +procedure TEmitter.EmitOP_XOR_INT64; +begin + EmitPCodeOperator; + + GetReg(_ECX); + GetReg(_EAX); + GetReg(_EDX); + +// EAX:EDX <-- [N1] + + EmitLoadAddress(_ECX, SymbolRec1); + Prg.AsmMovREG32_REGPtr(_EAX, _ECX); + Prg.AsmAddREG_Imm(_ECX, 4); + Prg.AsmMovREG32_REGPtr(_EDX, _ECX); + +// XOR EAX, [N2] + + EmitLoadAddress(_ECX, SymbolRec2); + Prg.AsmMovREG32_REGPtr(_ECX, _ECX); + Prg.AsmXorREG_REG(_EAX, _ECX); + +// XOR EDX, [N2 + 4] + + EmitLoadAddress(_ECX, SymbolRec2); + Prg.AsmAddREG_Imm(_ECX, 4); + Prg.AsmMovREG32_REGPtr(_ECX, _ECX); + Prg.AsmXorREG_REG(_EDX, _ECX); + +// EAX:EDX --> [N2] + + EmitLoadAddress(_ECX, SymbolRecR); + Prg.AsmMovREGPtr_REG32(_ECX, _EAX); + Prg.AsmAddREG_Imm(_ECX, 4); + Prg.AsmMovREGPtr_REG32(_ECX, _EDX); + + FreeReg(_EAX); + FreeReg(_EDX); + FreeReg(_ECX); +end; + +procedure TEmitter.EmitOP_XOR_UINT64; +begin + EmitPCodeOperator; + + GetReg(_ECX); + GetReg(_EAX); + GetReg(_EDX); + +// EAX:EDX <-- [N1] + + EmitLoadAddress(_ECX, SymbolRec1); + Prg.AsmMovREG32_REGPtr(_EAX, _ECX); + Prg.AsmAddREG_Imm(_ECX, 4); + Prg.AsmMovREG32_REGPtr(_EDX, _ECX); + +// XOR EAX, [N2] + + EmitLoadAddress(_ECX, SymbolRec2); + Prg.AsmMovREG32_REGPtr(_ECX, _ECX); + Prg.AsmXorREG_REG(_EAX, _ECX); + +// XOR EDX, [N2 + 4] + + EmitLoadAddress(_ECX, SymbolRec2); + Prg.AsmAddREG_Imm(_ECX, 4); + Prg.AsmMovREG32_REGPtr(_ECX, _ECX); + Prg.AsmXorREG_REG(_EDX, _ECX); + +// EAX:EDX --> [N2] + + EmitLoadAddress(_ECX, SymbolRecR); + Prg.AsmMovREGPtr_REG32(_ECX, _EAX); + Prg.AsmAddREG_Imm(_ECX, 4); + Prg.AsmMovREGPtr_REG32(_ECX, _EDX); + + FreeReg(_EAX); + FreeReg(_EDX); + FreeReg(_ECX); +end; + +procedure TEmitter.EmitStdCall_Adr1(SubId: Integer); +var + Reg: Integer; +begin + EmitPCodeOperator; + + EmitCallPro(SubId); + + if TargetPlatform = tpWIN64 then + begin + Reg := GetRegEx; + + EmitLoadAddress(Reg, SymbolRec1); // string source + Prg.AsmMovREG_REG(_ECX, Reg); + end + else + begin + Reg := GetReg; + + EmitLoadAddress(Reg, SymbolRec1); // string source + Prg.AsmPush_REG(Reg); + end; + FreeReg(Reg); + + EmitStdCall(SubId); +end; + +procedure TEmitter.EmitStdCall_Adr1_AdrR(SubId: Integer); +var + Reg: Integer; +begin + EmitPCodeOperator; + + EmitCallPro(SubId); + + if TargetPlatform = tpWIN64 then + begin + Reg := GetRegEx; + + EmitLoadAddress(Reg, SymbolRec1); // source + Prg.AsmMovREG_REG(_ECX, Reg); + + EmitLoadAddress(Reg, SymbolRecR); // dest + Prg.AsmMovREG_REG(_EDX, Reg); + + FreeReg(Reg); + + EmitStdCall(SubId); + + end + else + begin + Reg := GetReg; + + EmitLoadAddress(Reg, SymbolRecR); // dest + Prg.AsmPush_REG(Reg); + + EmitLoadAddress(Reg, SymbolRec1); // source + Prg.AsmPush_REG(Reg); + + FreeReg(Reg); + + EmitStdCall(SubId); + end; +end; + +procedure TEmitter.EmitStdCall_Adr1_from_Int2(SubId: Integer); +var + Reg: Integer; +begin + EmitPCodeOperator; + Emit_PUSH_REGS; + + EmitCallPro(SubId); + + if TargetPlatform = tpWIN64 then + begin + Reg := GetRegEx; + + EmitLoadIntVal(Reg, SymbolRec2); // source + Prg.AsmMovREG_REG(_ECX, Reg); + + EmitLoadAddress(Reg, SymbolRec1); // dest + Prg.AsmMovREG_REG(_EDX, Reg); + end + else + begin + Reg := GetRegEx; + + EmitLoadAddress(Reg, SymbolRec1); // dest + Prg.AsmPush_REG(Reg); + + EmitLoadIntVal(Reg, SymbolRec2); // source + Prg.AsmPush_REG(Reg); + end; + + FreeReg(Reg); + + EmitStdCall(SubId); + + Emit_POP_REGS; +end; + +procedure TEmitter.EmitStdCall_Adr1_from_Adr2(SubId: Integer); +var + Reg: Integer; +begin + EmitPCodeOperator; + Emit_PUSH_REGS; + + EmitCallPro(SubId); + + if TargetPlatform = tpWIN64 then + begin + Reg := GetRegEx; + + EmitLoadAddress(Reg, SymbolRec1); // dest + Prg.AsmMovREG_REG(_ECX, Reg); + + EmitLoadAddress(Reg, SymbolRec2); // source + Prg.AsmMovREG_REG(_EDX, Reg); + end + else + begin + Reg := GetRegEx; + + EmitLoadAddress(Reg, SymbolRec2); // source + Prg.AsmPush_REG(Reg); + + EmitLoadAddress(Reg, SymbolRec1); // dest + Prg.AsmPush_REG(Reg); + end; + FreeReg(Reg); + + EmitStdCall(SubId); + + Emit_POP_REGS; +end; + +procedure TEmitter.EmitStdCall_AdrR_from_Adr2(SubId: Integer); +var + Reg: Integer; +begin + EmitPCodeOperator; + Emit_PUSH_REGS; + + EmitCallPro(SubId); + + if TargetPlatform = tpWIN64 then + begin + Reg := GetRegEx; + + EmitLoadAddress(Reg, SymbolRecR); // dest + Prg.AsmMovREG_REG(_ECX, Reg); + + EmitLoadAddress(Reg, SymbolRec2); // source + Prg.AsmMovREG_REG(_EDX, Reg); + end + else + begin + Reg := GetRegEx; + + EmitLoadAddress(Reg, SymbolRec2); // source + Prg.AsmPush_REG(Reg); + + EmitLoadAddress(Reg, SymbolRecR); // dest + Prg.AsmPush_REG(Reg); + end; + FreeReg(Reg); + + EmitStdCall(SubId); + + Emit_POP_REGS; +end; + +procedure TEmitter.EmitStdCall_Adr1_Adr2_AdrR(SubId: Integer); +var + Reg: Integer; +begin + EmitPCodeOperator; + + EmitCallPro(SubId); + + if TargetPlatform = tpWIN64 then + begin + Reg := GetRegEx; + + EmitLoadAddress(Reg, SymbolRec1); // 1 - par + Prg.AsmMovREG_REG(_ECX, Reg); + + EmitLoadAddress(Reg, SymbolRec2); // 2 - par + Prg.AsmMovREG_REG(_EDX, Reg); + + EmitLoadAddress(Reg, SymbolRecR); // result + Prg.AsmMovREG_REG(_R8, Reg); + + FreeReg(Reg); + + EmitStdCall(SubId); + end + else + begin + Reg := GetReg; + + EmitLoadAddress(Reg, SymbolRecR); // result + Prg.AsmPush_REG(Reg); + + EmitLoadAddress(Reg, SymbolRec2); // 2 - par + Prg.AsmPush_REG(Reg); + + EmitLoadAddress(Reg, SymbolRec1); // 1 - par + Prg.AsmPush_REG(Reg); + + FreeReg(Reg); + + EmitStdCall(SubId); + end; +end; + +procedure TEmitter.EmitStdCall_Lang_Adr1_Adr2_AdrR(SubId: Integer); +var + Reg: Integer; +begin + EmitPCodeOperator; + + EmitCallPro(SubId); + + if TargetPlatform = tpWIN64 then + begin + Reg := GetRegEx; + + Prg.AsmMovREG_Imm(Reg, Language); // lang + Prg.AsmMovREG_REG(_ECX, Reg); + + EmitLoadAddress(Reg, SymbolRec1); // par 1 + Prg.AsmMovREG_REG(_EDX, Reg); + + EmitLoadAddress(Reg, SymbolRec2); // par 2 + Prg.AsmMovREG_REG(_R8, Reg); + + EmitLoadAddress(Reg, SymbolRecR); // result + Prg.AsmMovREG_REG(_R9, Reg); + + FreeReg(Reg); + + EmitStdCall(SubId); + end + else + begin + Reg := GetReg; + + EmitLoadAddress(Reg, SymbolRecR); // result + Prg.AsmPush_REG(Reg); + + EmitLoadAddress(Reg, SymbolRec2); // 2 - par + Prg.AsmPush_REG(Reg); + + EmitLoadAddress(Reg, SymbolRec1); // 1 - par + Prg.AsmPush_REG(Reg); + + Prg.AsmPush_Imm(Language); // lang + + FreeReg(Reg); + + EmitStdCall(SubId); + end; +end; + + +procedure TEmitter.EmitOP_GT_INT64_64; +begin + EmitOP_GT_INT64; +end; +procedure TEmitter.EmitOP_GT_INT64; +begin + EmitStdCall_Adr1_Adr2_AdrR(Id_Int64GreaterThan); +end; + +procedure TEmitter.EmitOP_GE_INT64_64; +begin + EmitOP_GE_INT64; +end; +procedure TEmitter.EmitOP_GE_INT64; +begin + EmitStdCall_Adr1_Adr2_AdrR(Id_Int64GreaterThanOrEqual); +end; + +procedure TEmitter.EmitOP_LT_INT64_64; +begin + EmitOP_LT_INT64; +end; +procedure TEmitter.EmitOP_LT_INT64; +begin + EmitStdCall_Adr1_Adr2_AdrR(Id_Int64LessThan); +end; + +procedure TEmitter.EmitOP_LE_INT64_64; +begin + EmitOP_LE_INT64; +end; +procedure TEmitter.EmitOP_LE_INT64; +begin + EmitStdCall_Adr1_Adr2_AdrR(Id_Int64LessThanOrEqual); +end; + +procedure TEmitter.EmitOP_EQ_INT64_64; +begin + EmitOP_EQ_INT64; +end; +procedure TEmitter.EmitOP_EQ_INT64; +begin + EmitStdCall_Adr1_Adr2_AdrR(Id_Int64Equality); +end; + +procedure TEmitter.EmitOP_NE_INT64_64; +begin + EmitOP_NE_INT64; +end; +procedure TEmitter.EmitOP_NE_INT64; +begin + EmitStdCall_Adr1_Adr2_AdrR(Id_Int64NotEquality); +end; + +procedure TEmitter.EmitOP_GT_UINT64_64; +begin + EmitOP_GT_UINT64; +end; +procedure TEmitter.EmitOP_GT_UINT64; +begin + EmitStdCall_Adr1_Adr2_AdrR(Id_UInt64GreaterThan); +end; + +procedure TEmitter.EmitOP_GE_UINT64_64; +begin + EmitOP_GE_UINT64; +end; +procedure TEmitter.EmitOP_GE_UINT64; +begin + EmitStdCall_Adr1_Adr2_AdrR(Id_UInt64GreaterThanOrEqual); +end; + +procedure TEmitter.EmitOP_LT_UINT64_64; +begin + EmitOP_LT_UINT64; +end; +procedure TEmitter.EmitOP_LT_UINT64; +begin + EmitStdCall_Adr1_Adr2_AdrR(Id_UInt64LessThan); +end; + +procedure TEmitter.EmitOP_LE_UINT64_64; +begin + EmitOP_LE_UINT64; +end; +procedure TEmitter.EmitOP_LE_UINT64; +begin + EmitStdCall_Adr1_Adr2_AdrR(Id_UInt64LessThanOrEqual); +end; + +procedure TEmitter.EmitOP_ADD_CURRENCY_64; +begin + EmitOP_ADD_CURRENCY; +end; +procedure TEmitter.EmitOP_ADD_CURRENCY; +begin + EmitPCodeOperator; + + if R.Arg1 <> 0 then + begin + if SymbolRec1.FinalTypeId <> typeCURRENCY then + begin + if SymbolRec1.FinalTypeId in IntegerTypes then + EmitFild(SymbolRec1) + else if SymbolRec1.FinalTypeId in RealTypes then + EmitFld(SymbolRec1) + else + RaiseError(errInternalError, []); + EmitFMul_10000; + end + else + EmitFild(SymbolRec1); + end; + + EmitFild(SymbolRec2); + + Prg.AsmFAdd; + + if R.Res <> 0 then + EmitFistp(SymbolRecR); +end; + +procedure TEmitter.EmitOP_SUB_CURRENCY_64; +begin + EmitOP_SUB_CURRENCY; +end; +procedure TEmitter.EmitOP_SUB_CURRENCY; +begin + EmitPCodeOperator; + + if R.Arg1 <> 0 then + begin + if SymbolRec1.FinalTypeId <> typeCURRENCY then + begin + if SymbolRec1.FinalTypeId in IntegerTypes then + EmitFild(SymbolRec1) + else if SymbolRec1.FinalTypeId in RealTypes then + EmitFld(SymbolRec1) + else + RaiseError(errInternalError, []); + + EmitFMul_10000; + + if TKernel(kernel).Code[TKernel(kernel).Code.N].SwappedArgs then + begin + Prg.AsmFChs; + EmitFild(SymbolRec2); + Prg.AsmFAdd; + EmitFistp(SymbolRecR); + Exit; + end; + end + else + EmitFild(SymbolRec1); + end; + + EmitFild(SymbolRec2); + + Prg.AsmFSub; + + if R.Res <> 0 then + EmitFistp(SymbolRecR); +end; + +procedure TEmitter.EmitOP_MUL_CURRENCY_64; +begin + EmitOP_MUL_CURRENCY; +end; +procedure TEmitter.EmitOP_MUL_CURRENCY; +begin + EmitPCodeOperator; + + if R.Arg1 <> 0 then + begin + if SymbolRec1.FinalTypeId <> typeCURRENCY then + begin + if SymbolRec1.FinalTypeId in IntegerTypes then + EmitFild(SymbolRec1) + else if SymbolRec1.FinalTypeId in RealTypes then + EmitFld(SymbolRec1) + else + RaiseError(errInternalError, []); + EmitFild(SymbolRec2); + Prg.AsmFMul; + EmitFistp(SymbolRecR); + Exit; + end + else + EmitFild(SymbolRec1); + end; + + EmitFild(SymbolRec2); + Prg.AsmFMul; + EmitFDiv_10000; + + if R.Res <> 0 then + EmitFistp(SymbolRecR); +end; + +procedure TEmitter.EmitOP_DIV_CURRENCY_64; +begin + EmitOP_DIV_CURRENCY; +end; +procedure TEmitter.EmitOP_DIV_CURRENCY; +begin + EmitPCodeOperator; + + if R.Arg1 <> 0 then + begin + if SymbolRec1.FinalTypeId <> typeCURRENCY then + begin + if SymbolRec1.FinalTypeId in IntegerTypes then + EmitFild(SymbolRec1) + else if SymbolRec1.FinalTypeId in RealTypes then + EmitFld(SymbolRec1) + else + RaiseError(errInternalError, []); + + EmitFild(SymbolRec2); + Prg.AsmFDiv; + + EmitFMul_10000; + EmitFMul_10000; + + EmitFistp(SymbolRecR); + + Exit; + end + else + begin + EmitFild(SymbolRec1); + + if SymbolRec2.FinalTypeId <> typeCURRENCY then + begin + if SymbolRec2.FinalTypeId in IntegerTypes then + EmitFild(SymbolRec2) + else if SymbolRec2.FinalTypeId in RealTypes then + EmitFld(SymbolRec2) + else + RaiseError(errInternalError, []); + + Prg.AsmFDiv; + EmitFistp(SymbolRecR); + + Exit; + end; + end; + end; + + // both operands are currency + + EmitFild(SymbolRec2); + + Prg.AsmFDiv; + + EmitFMul_10000; + + if R.Res <> 0 then + EmitFistp(SymbolRecR); +end; + +procedure TEmitter.EmitOP_ADD_DOUBLE_64; +begin + EmitStdCall_Lang_Adr1_Adr2_AdrR(Id_DoubleAddition); +end; +procedure TEmitter.EmitOP_ADD_DOUBLE; +begin + EmitPCodeOperator; + + EmitFld(SymbolRec1); + EmitFld(SymbolRec2); + Prg.AsmFAdd; + EmitFStp(SymbolRecR); +end; + +procedure TEmitter.EmitOP_ADD_SINGLE_64; +begin + EmitOP_ADD_SINGLE; +end; +procedure TEmitter.EmitOP_ADD_SINGLE; +begin + EmitPCodeOperator; + + EmitFld(SymbolRec1); + EmitFld(SymbolRec2); + Prg.AsmFAdd; + EmitFStp(SymbolRecR); +end; + +procedure TEmitter.EmitOP_ADD_EXTENDED_64; +begin + EmitOP_ADD_DOUBLE_64; +end; +procedure TEmitter.EmitOP_ADD_EXTENDED; +begin + EmitPCodeOperator; + + EmitFld(SymbolRec1); + EmitFld(SymbolRec2); + Prg.AsmFAdd; + EmitFStp(SymbolRecR); +end; + +procedure TEmitter.EmitOP_ABS_INT_64; +begin + EmitOP_ABS_INT; +end; +procedure TEmitter.EmitOP_ABS_INT; +begin + EmitPCodeOperator; + + GetReg(_EAX); + GetReg(_EDX); + + EmitLoadIntVal(_EAX, SymbolRec1); + Prg.AsmCDQ; + Prg.AsmXorREG_REG(_EAX, _EDX); + Prg.AsmSubREG_REG(_EAX, _EDX); + EmitSaveIntVal(_EAX, SymbolRecR); + + FreeReg(_EAX); + FreeReg(_EDX); +end; + +procedure TEmitter.EmitOP_ABS_DOUBLE_64; +begin + EmitOP_ABS_DOUBLE; +end; +procedure TEmitter.EmitOP_ABS_DOUBLE; +begin + EmitPCodeOperator; + + EmitFld(SymbolRec1); + Prg.AsmFAbs; + EmitFStp(SymbolRecR); +end; + +procedure TEmitter.EmitOP_ABS_SINGLE_64; +begin + EmitOP_ABS_SINGLE; +end; +procedure TEmitter.EmitOP_ABS_SINGLE; +begin + EmitPCodeOperator; + + EmitFld(SymbolRec1); + Prg.AsmFAbs; + EmitFStp(SymbolRecR); +end; + +procedure TEmitter.EmitOP_ABS_EXTENDED_64; +begin + EmitOP_ABS_EXTENDED; +end; +procedure TEmitter.EmitOP_ABS_EXTENDED; +begin + EmitPCodeOperator; + + EmitFld(SymbolRec1); + Prg.AsmFAbs; + EmitFStp(SymbolRecR); +end; + +procedure TEmitter.EmitOP_ABS_CURRENCY_64; +begin + EmitOP_ABS_CURRENCY; +end; +procedure TEmitter.EmitOP_ABS_CURRENCY; +begin + EmitPCodeOperator; + + EmitFild(SymbolRec1); + EmitFDiv_10000; + Prg.AsmFAbs; + EmitFMul_10000; + EmitFistp(SymbolRecR); +end; + +procedure TEmitter.EmitOP_NEG_DOUBLE_64; +var + SubId, Reg: Integer; +begin + EmitPCodeOperator; + + SubId := Id_DoubleNegation; + + EmitCallPro(SubId); + + Reg := GetRegEx; + + EmitLoadAddress(Reg, SymbolRec1); // source + Prg.AsmMovREG_REG(_ECX, Reg); + + EmitLoadAddress(Reg, SymbolRecR); // dest + Prg.AsmMovREG_REG(_EDX, Reg); + + FreeReg(Reg); + + EmitStdCall(SubId); +end; +procedure TEmitter.EmitOP_NEG_DOUBLE; +begin + EmitPCodeOperator; + + EmitFld(SymbolRec1); + Prg.AsmFChs; + EmitFStp(SymbolRecR); +end; + +procedure TEmitter.EmitOP_NEG_CURRENCY_64; +begin + EmitOP_NEG_CURRENCY; +end; +procedure TEmitter.EmitOP_NEG_CURRENCY; +var + Reg: Integer; +begin + EmitPCodeOperator; + + Reg := GetReg; + EmitLoadAddress(Reg, SymbolRec1); + Prg.AsmFild_REG64Ptr(Reg); + Prg.AsmFChs; + + FreeReg(Reg); + + EmitFistp(SymbolRecR); +end; + +procedure TEmitter.EmitOP_NEG_SINGLE_64; +begin + EmitOP_NEG_SINGLE; +end; +procedure TEmitter.EmitOP_NEG_SINGLE; +begin + EmitPCodeOperator; + + EmitFld(SymbolRec1); + Prg.AsmFChs; + EmitFStp(SymbolRecR); +end; + +procedure TEmitter.EmitOP_NEG_EXTENDED_64; +begin + EmitOP_NEG_DOUBLE_64; +end; +procedure TEmitter.EmitOP_NEG_EXTENDED; +begin + EmitPCodeOperator; + + EmitFld(SymbolRec1); + Prg.AsmFChs; + EmitFStp(SymbolRecR); +end; + +procedure TEmitter.EmitOP_SUB_DOUBLE_64; +begin + EmitStdCall_Lang_Adr1_Adr2_AdrR(Id_DoubleSubtraction); +end; +procedure TEmitter.EmitOP_SUB_DOUBLE; +begin + EmitPCodeOperator; + + EmitFld(SymbolRec1); + EmitFld(SymbolRec2); + Prg.AsmFSub; + EmitFStp(SymbolRecR); +end; + +procedure TEmitter.EmitOP_SUB_SINGLE_64; +begin + EmitOP_SUB_SINGLE; +end; +procedure TEmitter.EmitOP_SUB_SINGLE; +begin + EmitPCodeOperator; + + EmitFld(SymbolRec1); + EmitFld(SymbolRec2); + Prg.AsmFSub; + EmitFStp(SymbolRecR); +end; + +procedure TEmitter.EmitOP_SUB_EXTENDED_64; +begin + EmitOP_SUB_DOUBLE_64; +end; +procedure TEmitter.EmitOP_SUB_EXTENDED; +begin + EmitPCodeOperator; + + EmitFld(SymbolRec1); + EmitFld(SymbolRec2); + Prg.AsmFSub; + EmitFStp(SymbolRecR); +end; + +procedure TEmitter.EmitOP_MUL_DOUBLE_64; +begin + EmitStdCall_Lang_Adr1_Adr2_AdrR(Id_DoubleMultiplication); +end; +procedure TEmitter.EmitOP_MUL_DOUBLE; +begin + EmitPCodeOperator; + + EmitFld(SymbolRec1); + EmitFld(SymbolRec2); + Prg.AsmFMul; + EmitFStp(SymbolRecR); +end; + +procedure TEmitter.EmitOP_MUL_SINGLE_64; +begin + EmitOP_MUL_SINGLE; +end; +procedure TEmitter.EmitOP_MUL_SINGLE; +begin + EmitPCodeOperator; + + EmitFld(SymbolRec1); + EmitFld(SymbolRec2); + Prg.AsmFMul; + EmitFStp(SymbolRecR); +end; + +procedure TEmitter.EmitOP_MUL_EXTENDED_64; +begin + EmitOP_MUL_DOUBLE_64; +end; +procedure TEmitter.EmitOP_MUL_EXTENDED; +begin + EmitPCodeOperator; + + EmitFld(SymbolRec1); + EmitFld(SymbolRec2); + Prg.AsmFMul; + EmitFStp(SymbolRecR); +end; + +procedure TEmitter.EmitOP_DIV_DOUBLE_64; +begin + EmitStdCall_Lang_Adr1_Adr2_AdrR(Id_DoubleMultiplication); +end; +procedure TEmitter.EmitOP_DIV_DOUBLE; +begin + EmitPCodeOperator; + + EmitFld(SymbolRec1); + EmitFld(SymbolRec2); + Prg.AsmFDiv; + EmitFStp(SymbolRecR); +end; + +procedure TEmitter.EmitOP_DIV_SINGLE_64; +begin + EmitOP_DIV_SINGLE; +end; +procedure TEmitter.EmitOP_DIV_SINGLE; +begin + EmitPCodeOperator; + + EmitFld(SymbolRec1); + EmitFld(SymbolRec2); + Prg.AsmFDiv; + EmitFStp(SymbolRecR); +end; + +procedure TEmitter.EmitOP_DIV_EXTENDED_64; +begin + EmitOP_DIV_DOUBLE_64; +end; +procedure TEmitter.EmitOP_DIV_EXTENDED; +begin + EmitPCodeOperator; + + EmitFld(SymbolRec1); + EmitFld(SymbolRec2); + Prg.AsmFDiv; + EmitFStp(SymbolRecR); +end; + +procedure TEmitter.EmitOP_LT_INT_MI_64; +begin + EmitOP_LT_INT_MI; +end; +procedure TEmitter.EmitOP_LT_INT_MI; +var + Reg, RegR: Integer; +begin + EmitPCodeOperator; + + if HasTheSameAddressRegister(SymbolRec1, SymbolRecR) then + begin + Reg := EmitGetAddressRegister(SymbolRec1); + Prg.AsmCmpREGPtr_Imm(Reg, SymbolRec1, ImmValue2); + if SymbolRec1.FinalTypeId in UnsignedIntegerTypes then + Prg.AsmSet_REGPtr(ASM_SETB, Reg, SymbolRecR) + else + Prg.AsmSet_REGPtr(ASM_SETL, Reg, SymbolRecR); + FreeReg(Reg); + end + else + begin + RegR := GetReg; + EmitLoadAddress(RegR, SymbolRecR); + Reg := EmitGetAddressRegister(SymbolRec1); + Prg.AsmCmpREGPtr_Imm(Reg, SymbolRec1, ImmValue2); + if SymbolRec1.FinalTypeId in UnsignedIntegerTypes then + Prg.AsmSetB_REGPtr(RegR) + else + Prg.AsmSetL_REGPtr(RegR); + FreeReg(Reg); + FreeReg(RegR); + end; +end; + +procedure TEmitter.EmitOP_LT_INT_MM_64; +begin + EmitOP_LT_INT_MM; +end; +procedure TEmitter.EmitOP_LT_INT_MM; +var + Reg1, Reg2, RegR: Integer; +begin + EmitPCodeOperator; + + Reg1 := GetReg; + Reg2 := GetReg; + RegR := GetReg; + EmitLoadAddress(RegR, SymbolRecR); + EmitLoadIntVal(Reg1, SymbolRec1); + EmitLoadIntVal(Reg2, SymbolRec2); + Prg.AsmCmpREG_REG(Reg1, Reg2); + if (SymbolRec1.FinalTypeId in UnsignedIntegerTypes) and + (SymbolRec2.FinalTypeId in UnsignedIntegerTypes) then + Prg.AsmSetB_REGPtr(RegR) + else + Prg.AsmSetL_REGPtr(RegR); + FreeReg(RegR); + FreeReg(Reg2); + FreeReg(Reg1); +end; + +procedure TEmitter.EmitOP_LE_INT_MI_64; +begin + EmitOP_LE_INT_MI; +end; +procedure TEmitter.EmitOP_LE_INT_MI; +var + Reg, RegR: Integer; +begin + EmitPCodeOperator; + + if HasTheSameAddressRegister(SymbolRec1, SymbolRecR) then + begin + Reg := EmitGetAddressRegister(SymbolRec1); + Prg.AsmCmpREGPtr_Imm(Reg, SymbolRec1, ImmValue2); + if SymbolRec1.FinalTypeId in UnsignedIntegerTypes then + Prg.AsmSet_REGPtr(ASM_SETBE, Reg, SymbolRecR) + else + Prg.AsmSet_REGPtr(ASM_SETLE, Reg, SymbolRecR); + FreeReg(Reg); + end + else + begin + RegR := GetReg; + EmitLoadAddress(RegR, SymbolRecR); + Reg := EmitGetAddressRegister(SymbolRec1); + Prg.AsmCmpREGPtr_Imm(Reg, SymbolRec1, ImmValue2); + if SymbolRec1.FinalTypeId in UnsignedIntegerTypes then + Prg.AsmSetBE_REGPtr(RegR) + else + Prg.AsmSetLE_REGPtr(RegR); + FreeReg(Reg); + FreeReg(RegR); + end; +end; + +procedure TEmitter.EmitOP_LE_INT_MM_64; +begin + EmitOP_LE_INT_MM; +end; +procedure TEmitter.EmitOP_LE_INT_MM; +var + Reg1, Reg2, RegR: Integer; +begin + EmitPCodeOperator; + + Reg1 := GetReg; + Reg2 := GetReg; + RegR := GetReg; + EmitLoadAddress(RegR, SymbolRecR); + EmitLoadIntVal(Reg1, SymbolRec1); + EmitLoadIntVal(Reg2, SymbolRec2); + Prg.AsmCmpREG_REG(Reg1, Reg2); + if (SymbolRec1.FinalTypeId in UnsignedIntegerTypes) and + (SymbolRec2.FinalTypeId in UnsignedIntegerTypes) then + Prg.AsmSetBE_REGPtr(RegR) + else + Prg.AsmSetLE_REGPtr(RegR); + FreeReg(RegR); + FreeReg(Reg2); + FreeReg(Reg1); +end; + +procedure TEmitter.EmitOP_GT_INT_MI_64; +begin + EmitOP_GT_INT_MI; +end; +procedure TEmitter.EmitOP_GT_INT_MI; +var + Reg, RegR: Integer; +begin + EmitPCodeOperator; + + if HasTheSameAddressRegister(SymbolRec1, SymbolRecR) then + begin + Reg := EmitGetAddressRegister(SymbolRec1); + Prg.AsmCmpREGPtr_Imm(Reg, SymbolRec1, ImmValue2); + if SymbolRec1.FinalTypeId in UnsignedIntegerTypes then + Prg.AsmSet_REGPtr(ASM_SETNBE, Reg, SymbolRecR) + else + Prg.AsmSet_REGPtr(ASM_SETNLE, Reg, SymbolRecR); + FreeReg(Reg); + end + else + begin + RegR := GetReg; + EmitLoadAddress(RegR, SymbolRecR); + Reg := EmitGetAddressRegister(SymbolRec1); + Prg.AsmCmpREGPtr_Imm(Reg, SymbolRec1, ImmValue2); + if SymbolRec1.FinalTypeId in UnsignedIntegerTypes then + Prg.AsmSetNBE_REGPtr(RegR) + else + Prg.AsmSetNLE_REGPtr(RegR); + FreeReg(Reg); + FreeReg(RegR); + end; +end; + +procedure TEmitter.EmitOP_GT_INT_MM_64; +begin + EmitOP_GT_INT_MM; +end; +procedure TEmitter.EmitOP_GT_INT_MM; +var + Reg1, Reg2, RegR: Integer; +begin + EmitPCodeOperator; + + Reg1 := GetReg; + Reg2 := GetReg; + RegR := GetReg; + EmitLoadAddress(RegR, SymbolRecR); + EmitLoadIntVal(Reg1, SymbolRec1); + EmitLoadIntVal(Reg2, SymbolRec2); + Prg.AsmCmpREG_REG(Reg1, Reg2); + if (SymbolRec1.FinalTypeId in UnsignedIntegerTypes) and + (SymbolRec2.FinalTypeId in UnsignedIntegerTypes) then + Prg.AsmSetNBE_REGPtr(RegR) + else + Prg.AsmSetNLE_REGPtr(RegR); + FreeReg(RegR); + FreeReg(Reg2); + FreeReg(Reg1); +end; + +procedure TEmitter.EmitOP_GE_INT_MI_64; +begin + EmitOP_GE_INT_MI; +end; +procedure TEmitter.EmitOP_GE_INT_MI; +var + Reg, RegR: Integer; +begin + EmitPCodeOperator; + + if HasTheSameAddressRegister(SymbolRec1, SymbolRecR) then + begin + Reg := EmitGetAddressRegister(SymbolRec1); + Prg.AsmCmpREGPtr_Imm(Reg, SymbolRec1, ImmValue2); + if SymbolRec1.FinalTypeId in UnsignedIntegerTypes then + Prg.AsmSet_REGPtr(ASM_SETNB, Reg, SymbolRecR) + else + Prg.AsmSet_REGPtr(ASM_SETNL, Reg, SymbolRecR); + FreeReg(Reg); + end + else + begin + RegR := GetReg; + EmitLoadAddress(RegR, SymbolRecR); + Reg := EmitGetAddressRegister(SymbolRec1); + Prg.AsmCmpREGPtr_Imm(Reg, SymbolRec1, ImmValue2); + if SymbolRec1.FinalTypeId in UnsignedIntegerTypes then + Prg.AsmSetNB_REGPtr(RegR) + else + Prg.AsmSetNL_REGPtr(RegR); + FreeReg(Reg); + FreeReg(RegR); + end; +end; + +procedure TEmitter.EmitOP_GE_INT_MM_64; +begin + EmitOP_GE_INT_MM; +end; +procedure TEmitter.EmitOP_GE_INT_MM; +var + Reg1, Reg2, RegR: Integer; +begin + EmitPCodeOperator; + + Reg1 := GetReg; + Reg2 := GetReg; + RegR := GetReg; + + EmitLoadAddress(RegR, SymbolRecR); + EmitLoadIntVal(Reg1, SymbolRec1); + EmitLoadIntVal(Reg2, SymbolRec2); + Prg.AsmCmpREG_REG(Reg1, Reg2); + if (SymbolRec1.FinalTypeId in UnsignedIntegerTypes) and + (SymbolRec2.FinalTypeId in UnsignedIntegerTypes) then + Prg.AsmSetNB_REGPtr(RegR) + else + Prg.AsmSetNL_REGPtr(RegR); + + FreeReg(RegR); + FreeReg(Reg2); + FreeReg(Reg1); +end; + +procedure TEmitter.EmitOP_EQ_INT_MI_64; +begin + EmitOP_EQ_INT_MI; +end; +procedure TEmitter.EmitOP_EQ_INT_MI; +var + Reg, RegR: Integer; +begin + EmitPCodeOperator; + + if HasTheSameAddressRegister(SymbolRec1, SymbolRecR) then + begin + Reg := EmitGetAddressRegister(SymbolRec1); + Prg.AsmCmpREGPtr_Imm(Reg, SymbolRec1, ImmValue2); + Prg.AsmSet_REGPtr(ASM_SETZ, Reg, SymbolRecR); + FreeReg(Reg); + end + else + begin + RegR := GetReg; + EmitLoadAddress(RegR, SymbolRecR); + Reg := EmitGetAddressRegister(SymbolRec1); + Prg.AsmCmpREGPtr_Imm(Reg, SymbolRec1, ImmValue2); + Prg.AsmSetZ_REGPtr(RegR); + FreeReg(Reg); + FreeReg(RegR); + end; +end; + +procedure TEmitter.EmitOP_EQ_INT_MM_64; +begin + EmitOP_EQ_INT_MM; +end; +procedure TEmitter.EmitOP_EQ_INT_MM; +var + Reg1, Reg2, RegR: Integer; +begin + EmitPCodeOperator; + + Reg1 := GetReg; + Reg2 := GetReg; + RegR := GetReg; + EmitLoadAddress(RegR, SymbolRecR); + EmitLoadIntVal(Reg1, SymbolRec1); + EmitLoadIntVal(Reg2, SymbolRec2); + Prg.AsmCmpREG_REG(Reg1, Reg2); + Prg.AsmSetZ_REGPtr(RegR); + FreeReg(RegR); + FreeReg(Reg2); + FreeReg(Reg1); +end; + +procedure TEmitter.EmitOP_NE_INT_MI_64; +begin + EmitOP_NE_INT_MI; +end; +procedure TEmitter.EmitOP_NE_INT_MI; +var + Reg, RegR: Integer; +begin + EmitPCodeOperator; + + if HasTheSameAddressRegister(SymbolRec1, SymbolRecR) then + begin + Reg := EmitGetAddressRegister(SymbolRec1); + Prg.AsmCmpREGPtr_Imm(Reg, SymbolRec1, ImmValue2); + Prg.AsmSet_REGPtr(ASM_SETNZ, Reg, SymbolRecR); + FreeReg(Reg); + end + else + begin + RegR := GetReg; + EmitLoadAddress(RegR, SymbolRecR); + Reg := EmitGetAddressRegister(SymbolRec1); + Prg.AsmCmpREGPtr_Imm(Reg, SymbolRec1, ImmValue2); + Prg.AsmSetNZ_REGPtr(RegR); + FreeReg(Reg); + FreeReg(RegR); + end; +end; + +procedure TEmitter.EmitOP_NE_INT_MM_64; +begin + EmitOP_NE_INT_MM; +end; +procedure TEmitter.EmitOP_NE_INT_MM; +var + Reg1, Reg2, RegR: Integer; +begin + EmitPCodeOperator; + + Reg1 := GetReg; + Reg2 := GetReg; + RegR := GetReg; + EmitLoadAddress(RegR, SymbolRecR); + EmitLoadIntVal(Reg1, SymbolRec1); + EmitLoadIntVal(Reg2, SymbolRec2); + Prg.AsmCmpREG_REG(Reg1, Reg2); + Prg.AsmSetNZ_REGPtr(RegR); + FreeReg(RegR); + FreeReg(Reg2); + FreeReg(Reg1); +end; + +procedure TEmitter.EmitOP_LT_CURRENCY_64; +begin + EmitOP_LT_CURRENCY; +end; +procedure TEmitter.EmitOP_LT_CURRENCY; +var + Reg: Integer; + S: TSymbolRec; +begin + EmitPCodeOperator; + + S := SymbolRec2; + if S.FinalTypeId <> typeCURRENCY then + begin + if S.FinalTypeId in IntegerTypes then + EmitFild(S) + else if S.FinalTypeId in RealTypes then + EmitFld(S) + else + RaiseError(errInternalError, []); + EmitFMul_10000; + end + else + EmitFild(S); + + S := SymbolRec1; + if S.FinalTypeId <> typeCURRENCY then + begin + if S.FinalTypeId in IntegerTypes then + EmitFild(S) + else if S.FinalTypeId in RealTypes then + EmitFld(S) + else + RaiseError(errInternalError, []); + EmitFMul_10000; + end + else + EmitFild(S); + + GetReg(_EAX); + Reg := GetReg; + EmitLoadAddress(Reg, SymbolRecR); + Prg.AsmFCompP; + Prg.AsmFstsw_AX; + Prg.AsmSahv; + Prg.AsmSetB_REGPtr(Reg); + FreeReg(Reg); + FreeReg(_EAX); +end; + +procedure TEmitter.EmitOP_LE_CURRENCY_64; +begin + EmitOP_LE_CURRENCY; +end; +procedure TEmitter.EmitOP_LE_CURRENCY; +var + Reg: Integer; + S: TSymbolRec; +begin + EmitPCodeOperator; + + S := SymbolRec2; + if S.FinalTypeId <> typeCURRENCY then + begin + if S.FinalTypeId in IntegerTypes then + EmitFild(S) + else if S.FinalTypeId in RealTypes then + EmitFld(S) + else + RaiseError(errInternalError, []); + EmitFMul_10000; + end + else + EmitFild(S); + + S := SymbolRec1; + if S.FinalTypeId <> typeCURRENCY then + begin + if S.FinalTypeId in IntegerTypes then + EmitFild(S) + else if S.FinalTypeId in RealTypes then + EmitFld(S) + else + RaiseError(errInternalError, []); + EmitFMul_10000; + end + else + EmitFild(S); + + GetReg(_EAX); + Reg := GetReg; + EmitLoadAddress(Reg, SymbolRecR); + Prg.AsmFCompP; + Prg.AsmFstsw_AX; + Prg.AsmSahv; + Prg.AsmSetBE_REGPtr(Reg); + FreeReg(Reg); + FreeReg(_EAX); +end; + +procedure TEmitter.EmitOP_GT_CURRENCY_64; +begin + EmitOP_GT_CURRENCY; +end; +procedure TEmitter.EmitOP_GT_CURRENCY; +var + Reg: Integer; + S: TSymbolRec; +begin + EmitPCodeOperator; + + S := SymbolRec2; + if S.FinalTypeId <> typeCURRENCY then + begin + if S.FinalTypeId in IntegerTypes then + EmitFild(S) + else if S.FinalTypeId in RealTypes then + EmitFld(S) + else + RaiseError(errInternalError, []); + EmitFMul_10000; + end + else + EmitFild(S); + + S := SymbolRec1; + if S.FinalTypeId <> typeCURRENCY then + begin + if S.FinalTypeId in IntegerTypes then + EmitFild(S) + else if S.FinalTypeId in RealTypes then + EmitFld(S) + else + RaiseError(errInternalError, []); + EmitFMul_10000; + end + else + EmitFild(S); + + GetReg(_EAX); + Reg := GetReg; + EmitLoadAddress(Reg, SymbolRecR); + Prg.AsmFCompP; + Prg.AsmFstsw_AX; + Prg.AsmSahv; + Prg.AsmSetNBE_REGPtr(Reg); + FreeReg(Reg); + FreeReg(_EAX); +end; + +procedure TEmitter.EmitOP_GE_CURRENCY_64; +begin + EmitOP_GE_CURRENCY; +end; +procedure TEmitter.EmitOP_GE_CURRENCY; +var + Reg: Integer; + S: TSymbolRec; +begin + EmitPCodeOperator; + + S := SymbolRec2; + if S.FinalTypeId <> typeCURRENCY then + begin + if S.FinalTypeId in IntegerTypes then + EmitFild(S) + else if S.FinalTypeId in RealTypes then + EmitFld(S) + else + RaiseError(errInternalError, []); + EmitFMul_10000; + end + else + EmitFild(S); + + S := SymbolRec1; + if S.FinalTypeId <> typeCURRENCY then + begin + if S.FinalTypeId in IntegerTypes then + EmitFild(S) + else if S.FinalTypeId in RealTypes then + EmitFld(S) + else + RaiseError(errInternalError, []); + EmitFMul_10000; + end + else + EmitFild(S); + + GetReg(_EAX); + Reg := GetReg; + EmitLoadAddress(Reg, SymbolRecR); + Prg.AsmFCompP; + Prg.AsmFstsw_AX; + Prg.AsmSahv; + Prg.AsmSetNB_REGPtr(Reg); + FreeReg(Reg); + FreeReg(_EAX); +end; + +procedure TEmitter.EmitOP_EQ_CURRENCY_64; +begin + EmitOP_EQ_CURRENCY; +end; +procedure TEmitter.EmitOP_EQ_CURRENCY; +var + Reg: Integer; + S: TSymbolRec; +begin + EmitPCodeOperator; + + S := SymbolRec2; + if S.FinalTypeId <> typeCURRENCY then + begin + if S.FinalTypeId in IntegerTypes then + EmitFild(S) + else if S.FinalTypeId in RealTypes then + EmitFld(S) + else + RaiseError(errInternalError, []); + EmitFMul_10000; + end + else + EmitFild(S); + + S := SymbolRec1; + if S.FinalTypeId <> typeCURRENCY then + begin + if S.FinalTypeId in IntegerTypes then + EmitFild(S) + else if S.FinalTypeId in RealTypes then + EmitFld(S) + else + RaiseError(errInternalError, []); + EmitFMul_10000; + end + else + EmitFild(S); + + GetReg(_EAX); + Reg := GetReg; + EmitLoadAddress(Reg, SymbolRecR); + Prg.AsmFCompP; + Prg.AsmFstsw_AX; + Prg.AsmSahv; + Prg.AsmSetZ_REGPtr(Reg); + FreeReg(Reg); + FreeReg(_EAX); +end; + +procedure TEmitter.EmitOP_NE_CURRENCY_64; +begin + EmitOP_NE_CURRENCY; +end; +procedure TEmitter.EmitOP_NE_CURRENCY; +var + Reg: Integer; + S: TSymbolRec; +begin + EmitPCodeOperator; + + S := SymbolRec2; + if S.FinalTypeId <> typeCURRENCY then + begin + if S.FinalTypeId in IntegerTypes then + EmitFild(S) + else if S.FinalTypeId in RealTypes then + EmitFld(S) + else + RaiseError(errInternalError, []); + EmitFMul_10000; + end + else + EmitFild(S); + + S := SymbolRec1; + if S.FinalTypeId <> typeCURRENCY then + begin + if S.FinalTypeId in IntegerTypes then + EmitFild(S) + else if S.FinalTypeId in RealTypes then + EmitFld(S) + else + RaiseError(errInternalError, []); + EmitFMul_10000; + end + else + EmitFild(S); + + GetReg(_EAX); + Reg := GetReg; + EmitLoadAddress(Reg, SymbolRecR); + Prg.AsmFCompP; + Prg.AsmFstsw_AX; + Prg.AsmSahv; + Prg.AsmSetNZ_REGPtr(Reg); + FreeReg(Reg); + FreeReg(_EAX); +end; + +procedure TEmitter.EmitOP_LT_DOUBLE_64; +begin + EmitOP_LT_DOUBLE; +end; +procedure TEmitter.EmitOP_LT_DOUBLE; +var + Reg: Integer; +begin + EmitPCodeOperator; + + EmitFld(SymbolRec2); + EmitFld(SymbolRec1); + + GetReg(_EAX); + Reg := GetReg; + + EmitLoadAddress(Reg, SymbolRecR); + Prg.AsmFCompP; + Prg.AsmFstsw_AX; + Prg.AsmSahv; + Prg.AsmSetB_REGPtr(Reg); + + FreeReg(Reg); + FreeReg(_EAX); +end; + +procedure TEmitter.EmitOP_LT_SINGLE_64; +begin + EmitOP_LT_SINGLE; +end; +procedure TEmitter.EmitOP_LT_SINGLE; +var + Reg: Integer; +begin + EmitPCodeOperator; + + EmitFld(SymbolRec2); + EmitFld(SymbolRec1); + + GetReg(_EAX); + Reg := GetReg; + + EmitLoadAddress(Reg, SymbolRecR); + Prg.AsmFCompP; + Prg.AsmFstsw_AX; + Prg.AsmSahv; + Prg.AsmSetB_REGPtr(Reg); + + FreeReg(Reg); + FreeReg(_EAX); +end; + +procedure TEmitter.EmitOP_LT_EXTENDED_64; +begin + EmitOP_LT_EXTENDED; +end; +procedure TEmitter.EmitOP_LT_EXTENDED; +var + Reg: Integer; +begin + EmitPCodeOperator; + + EmitFld(SymbolRec2); + EmitFld(SymbolRec1); + + GetReg(_EAX); + Reg := GetReg; + + EmitLoadAddress(Reg, SymbolRecR); + Prg.AsmFCompP; + Prg.AsmFstsw_AX; + Prg.AsmSahv; + Prg.AsmSetB_REGPtr(Reg); + + FreeReg(Reg); + FreeReg(_EAX); +end; + +procedure TEmitter.EmitOP_LE_DOUBLE_64; +begin + EmitOP_LE_DOUBLE; +end; +procedure TEmitter.EmitOP_LE_DOUBLE; +var + Reg: Integer; +begin + EmitPCodeOperator; + + EmitFld(SymbolRec2); + EmitFld(SymbolRec1); + + GetReg(_EAX); + Reg := GetReg; + + EmitLoadAddress(Reg, SymbolRecR); + Prg.AsmFCompP; + Prg.AsmFstsw_AX; + Prg.AsmSahv; + Prg.AsmSetBE_REGPtr(Reg); + + FreeReg(Reg); + FreeReg(_EAX); +end; + +procedure TEmitter.EmitOP_LE_SINGLE_64; +begin + EmitOP_LE_SINGLE; +end; +procedure TEmitter.EmitOP_LE_SINGLE; +var + Reg: Integer; +begin + EmitPCodeOperator; + + EmitFld(SymbolRec2); + EmitFld(SymbolRec1); + + GetReg(_EAX); + Reg := GetReg; + + EmitLoadAddress(Reg, SymbolRecR); + Prg.AsmFCompP; + Prg.AsmFstsw_AX; + Prg.AsmSahv; + Prg.AsmSetBE_REGPtr(Reg); + + FreeReg(Reg); + FreeReg(_EAX); +end; + +procedure TEmitter.EmitOP_LE_EXTENDED_64; +begin + EmitOP_LE_EXTENDED; +end; +procedure TEmitter.EmitOP_LE_EXTENDED; +var + Reg: Integer; +begin + EmitPCodeOperator; + + EmitFld(SymbolRec2); + EmitFld(SymbolRec1); + + GetReg(_EAX); + Reg := GetReg; + + EmitLoadAddress(Reg, SymbolRecR); + Prg.AsmFCompP; + Prg.AsmFstsw_AX; + Prg.AsmSahv; + Prg.AsmSetBE_REGPtr(Reg); + + FreeReg(Reg); + FreeReg(_EAX); +end; + +procedure TEmitter.EmitOP_GT_DOUBLE_64; +begin + EmitOP_GT_DOUBLE; +end; +procedure TEmitter.EmitOP_GT_DOUBLE; +var + Reg: Integer; +begin + EmitPCodeOperator; + + EmitFld(SymbolRec2); + EmitFld(SymbolRec1); + + GetReg(_EAX); + Reg := GetReg; + + EmitLoadAddress(Reg, SymbolRecR); + Prg.AsmFCompP; + Prg.AsmFstsw_AX; + Prg.AsmSahv; + Prg.AsmSetNBE_REGPtr(Reg); + + FreeReg(Reg); + FreeReg(_EAX); +end; + +procedure TEmitter.EmitOP_GT_SINGLE_64; +begin + EmitOP_GT_SINGLE; +end; +procedure TEmitter.EmitOP_GT_SINGLE; +var + Reg: Integer; +begin + EmitPCodeOperator; + + EmitFld(SymbolRec2); + EmitFld(SymbolRec1); + + GetReg(_EAX); + Reg := GetReg; + + EmitLoadAddress(Reg, SymbolRecR); + Prg.AsmFCompP; + Prg.AsmFstsw_AX; + Prg.AsmSahv; + Prg.AsmSetNBE_REGPtr(Reg); + + FreeReg(Reg); + FreeReg(_EAX); +end; + +procedure TEmitter.EmitOP_GT_EXTENDED_64; +begin + EmitOP_GT_EXTENDED; +end; +procedure TEmitter.EmitOP_GT_EXTENDED; +var + Reg: Integer; +begin + EmitPCodeOperator; + + EmitFld(SymbolRec2); + EmitFld(SymbolRec1); + + GetReg(_EAX); + Reg := GetReg; + + EmitLoadAddress(Reg, SymbolRecR); + Prg.AsmFCompP; + Prg.AsmFstsw_AX; + Prg.AsmSahv; + Prg.AsmSetNBE_REGPtr(Reg); + + FreeReg(Reg); + FreeReg(_EAX); +end; + +procedure TEmitter.EmitOP_GE_DOUBLE_64; +begin + EmitOP_GE_DOUBLE; +end; +procedure TEmitter.EmitOP_GE_DOUBLE; +var + Reg: Integer; +begin + EmitPCodeOperator; + + EmitFld(SymbolRec2); + EmitFld(SymbolRec1); + + GetReg(_EAX); + Reg := GetReg; + + EmitLoadAddress(Reg, SymbolRecR); + Prg.AsmFCompP; + Prg.AsmFstsw_AX; + Prg.AsmSahv; + Prg.AsmSetNB_REGPtr(Reg); + + FreeReg(Reg); + FreeReg(_EAX); +end; + +procedure TEmitter.EmitOP_GE_SINGLE_64; +begin + EmitOP_GE_SINGLE; +end; +procedure TEmitter.EmitOP_GE_SINGLE; +var + Reg: Integer; +begin + EmitPCodeOperator; + + EmitFld(SymbolRec2); + EmitFld(SymbolRec1); + + GetReg(_EAX); + Reg := GetReg; + + EmitLoadAddress(Reg, SymbolRecR); + Prg.AsmFCompP; + Prg.AsmFstsw_AX; + Prg.AsmSahv; + Prg.AsmSetNB_REGPtr(Reg); + + FreeReg(Reg); + FreeReg(_EAX); +end; + +procedure TEmitter.EmitOP_GE_EXTENDED_64; +begin + EmitOP_GE_EXTENDED; +end; +procedure TEmitter.EmitOP_GE_EXTENDED; +var + Reg: Integer; +begin + EmitPCodeOperator; + + EmitFld(SymbolRec2); + EmitFld(SymbolRec1); + + GetReg(_EAX); + Reg := GetReg; + + EmitLoadAddress(Reg, SymbolRecR); + Prg.AsmFCompP; + Prg.AsmFstsw_AX; + Prg.AsmSahv; + Prg.AsmSetNB_REGPtr(Reg); + + FreeReg(Reg); + FreeReg(_EAX); +end; + +procedure TEmitter.EmitOP_EQ_DOUBLE_64; +begin + EmitOP_EQ_DOUBLE; +end; +procedure TEmitter.EmitOP_EQ_DOUBLE; +var + Reg: Integer; +begin + EmitPCodeOperator; + + EmitFld(SymbolRec2); + EmitFld(SymbolRec1); + + GetReg(_EAX); + Reg := GetReg; + + EmitLoadAddress(Reg, SymbolRecR); + Prg.AsmFCompP; + Prg.AsmFstsw_AX; + Prg.AsmSahv; + Prg.AsmSetZ_REGPtr(Reg); + + FreeReg(Reg); + FreeReg(_EAX); +end; + +procedure TEmitter.EmitOP_EQ_SINGLE_64; +begin + EmitOP_EQ_SINGLE; +end; +procedure TEmitter.EmitOP_EQ_SINGLE; +var + Reg: Integer; +begin + EmitPCodeOperator; + + EmitFld(SymbolRec2); + EmitFld(SymbolRec1); + + GetReg(_EAX); + Reg := GetReg; + + EmitLoadAddress(Reg, SymbolRecR); + Prg.AsmFCompP; + Prg.AsmFstsw_AX; + Prg.AsmSahv; + Prg.AsmSetZ_REGPtr(Reg); + + FreeReg(Reg); + FreeReg(_EAX); +end; + +procedure TEmitter.EmitOP_EQ_EXTENDED_64; +begin + EmitOP_EQ_EXTENDED; +end; +procedure TEmitter.EmitOP_EQ_EXTENDED; +var + Reg: Integer; +begin + EmitPCodeOperator; + + EmitFld(SymbolRec2); + EmitFld(SymbolRec1); + + GetReg(_EAX); + Reg := GetReg; + + EmitLoadAddress(Reg, SymbolRecR); + Prg.AsmFCompP; + Prg.AsmFstsw_AX; + Prg.AsmSahv; + Prg.AsmSetZ_REGPtr(Reg); + + FreeReg(Reg); + FreeReg(_EAX); +end; + +procedure TEmitter.EmitOP_NE_DOUBLE_64; +begin + EmitOP_NE_DOUBLE; +end; +procedure TEmitter.EmitOP_NE_DOUBLE; +var + Reg: Integer; +begin + EmitPCodeOperator; + + EmitFld(SymbolRec2); + EmitFld(SymbolRec1); + + GetReg(_EAX); + Reg := GetReg; + + EmitLoadAddress(Reg, SymbolRecR); + Prg.AsmFCompP; + Prg.AsmFstsw_AX; + Prg.AsmSahv; + Prg.AsmSetNZ_REGPtr(Reg); + + FreeReg(Reg); + FreeReg(_EAX); +end; + +procedure TEmitter.EmitOP_NE_SINGLE_64; +begin + EmitOP_NE_SINGLE; +end; +procedure TEmitter.EmitOP_NE_SINGLE; +var + Reg: Integer; +begin + EmitPCodeOperator; + + EmitFld(SymbolRec2); + EmitFld(SymbolRec1); + + GetReg(_EAX); + Reg := GetReg; + + EmitLoadAddress(Reg, SymbolRecR); + Prg.AsmFCompP; + Prg.AsmFstsw_AX; + Prg.AsmSahv; + Prg.AsmSetNZ_REGPtr(Reg); + + FreeReg(Reg); + FreeReg(_EAX); +end; + +procedure TEmitter.EmitOP_NE_EXTENDED_64; +begin + EmitOP_NE_EXTENDED; +end; +procedure TEmitter.EmitOP_NE_EXTENDED; +var + Reg: Integer; +begin + EmitPCodeOperator; + + EmitFld(SymbolRec2); + EmitFld(SymbolRec1); + + GetReg(_EAX); + Reg := GetReg; + + EmitLoadAddress(Reg, SymbolRecR); + Prg.AsmFCompP; + Prg.AsmFstsw_AX; + Prg.AsmSahv; + Prg.AsmSetNZ_REGPtr(Reg); + + FreeReg(Reg); + FreeReg(_EAX); +end; + +procedure TEmitter.EmitOP_PUSH_STRUCTURE_64; +var + Reg, RegTemp: Integer; + SubId, ParamId, ParamNumber, SZ: Integer; + ByRefer: Boolean; + S: TSymbolRec; +begin + EmitPCodeOperator; + + SubId := R.Res; + ParamNumber := R.Arg2; + ParamId := SymbolTable.GetParamId(SubId, ParamNumber); + + S := GetSymbolRec(ParamId); + SZ := S.Size; + + if SZ > 8 then + ByRefer := true + else + ByRefer := S.ByRef or (S.IsConst and (SZ > 8)); + + if (not ByRefer) and (SZ > 8) then + begin + while SZ mod 8 <> 0 do + Inc(SZ); + + Reg := GetReg; + EmitLoadAddress(Reg, SymbolRec1); + + Dec(SZ, 8); + if SZ > 0 then + Prg.AsmAddREG_Imm(Reg, SZ); + + RegTemp := GetReg; + + repeat + if SZ = 0 then + Prg.AsmXorREG_REG(RegTemp, RegTemp); + + Prg.AsmMovREG_REGPtr(RegTemp, Reg); + EmitPushParam(RegTemp); + + Dec(SZ, 8); + if SZ < 0 then + break; + + Prg.AsmSubREG_Imm(Reg, 8); + until false; + + FreeReg(RegTemp); + FreeReg(Reg); + + Exit; + end; + + // push address or 4-byte value + + Reg := GetSymbolRec(ParamId).Register; + + if Reg > 0 then + begin + GetReg(Reg); + EmitLoadAddress(Reg, SymbolRec1); + + if not ByRefer then + Prg.AsmMovREG_REGPtr(Reg, Reg); + + FreeReg(Reg); + Exit; + end; + + Reg := GetRegEx; + EmitLoadAddress(Reg, SymbolRec1); + + if not ByRefer then + Prg.AsmMovREG_REGPtr(Reg, Reg); + + EmitPushParam(Reg); + FreeReg(Reg); +end; +procedure TEmitter.EmitOP_PUSH_STRUCTURE; +var + Reg, RegTemp: Integer; + SubId, ParamId, ParamNumber, SZ: Integer; + ByRefer: Boolean; + S: TSymbolRec; +begin + EmitPCodeOperator; + + SubId := R.Res; + ParamNumber := R.Arg2; + ParamId := SymbolTable.GetParamId(SubId, ParamNumber); + + S := GetSymbolRec(ParamId); + SZ := S.Size; + + if (GetSymbolRec(SubId).CallConv = ccREGISTER) and (SZ > 4) then + ByRefer := true + else + ByRefer := S.ByRef or (S.IsConst and (SZ > 4)); + + if (not ByRefer) and (SZ > 4) then + begin + while SZ mod 4 <> 0 do + Inc(SZ); + + Reg := GetReg; + EmitLoadAddress(Reg, SymbolRec1); + + Dec(SZ, 4); + if SZ > 0 then + Prg.AsmAddREG_Imm(Reg, SZ); + + RegTemp := GetReg; + + repeat + if SZ = 0 then + Prg.AsmXorREG_REG(RegTemp, RegTemp); + + Prg.AsmMovREG_REGPtr(RegTemp, Reg); + Prg.AsmPush_REG(RegTemp); + + Dec(SZ, 4); + if SZ < 0 then + break; + + Prg.AsmSubREG_Imm(Reg, 4); + until false; + + FreeReg(RegTemp); + FreeReg(Reg); + + Exit; + end; + + // push address or 4-byte value + + if GetSymbolRec(SubId).CallConv in [ccREGISTER, ccMSFASTCALL] then + begin + Reg := GetSymbolRec(ParamId).Register; + + if Reg > 0 then + begin + GetReg(Reg); + EmitLoadAddress(Reg, SymbolRec1); + + if not ByRefer then + Prg.AsmMovREG_REGPtr(Reg, Reg); + + FreeReg(Reg); + Exit; + end; + end; + + Reg := GetReg; + EmitLoadAddress(Reg, SymbolRec1); + + if not ByRefer then + Prg.AsmMovREG_REGPtr(Reg, Reg); + + Prg.AsmPush_REG(Reg); + FreeReg(Reg); +end; + +procedure TEmitter.EmitOP_EXPORTS_64; +begin + EmitPCodeOperator; +end; +procedure TEmitter.EmitOP_EXPORTS; +begin + EmitPCodeOperator; +end; + +procedure TEmitter.EmitOP_PUSH_ADDRESS_64; +begin + EmitOP_PUSH_ADDRESS; +end; +procedure TEmitter.EmitOP_PUSH_ADDRESS; +var + Reg: Integer; + SubId, ParamId, ParamNumber: Integer; +begin + EmitPCodeOperator; + + SubId := R.Res; + ParamNumber := R.Arg2; + + if GetSymbolRec(SubId).CallConv in [ccREGISTER, ccMSFASTCALL, cc64] then + begin + if GetSymbolRec(SubId).CallConv = cc64 then + if SubId = JS_FunctionCallId then + begin + Reg := GetRegEx; + EmitLoadAddress(Reg, SymbolRec1); + if ParamNumber = 1 then + Prg.AsmMovREG_REG(_R9, Reg) + else if ParamNumber > 1 then + Prg.AsmMovRSPPtr_REG64(Reg, $20 + (ParamNumber - 2)*8) + else + RaiseError(errInternalError, []); + FreeReg(Reg); + Exit; + end; + + ParamId := SymbolTable.GetParamId(SubId, ParamNumber); + Reg := GetSymbolRec(ParamId).Register; + + if Reg > 0 then + begin + GetReg(Reg); + + if SymbolRec1.Kind = KindSUB then + begin + if Host1 then + EmitGet_REG(Reg, SymbolRec1) + else + begin + Prg.AsmMovREG_REG(Reg, _EDI); + Prg.AsmAddREG_Imm(Reg, 0); + Prg.Top.SaveSubId := R.Arg1; + List2.Add(Prg.Top); + end; + end + else + EmitLoadAddress(Reg, SymbolRec1); + + if SymbolRec1.FinalTypeId = typeRECORD then + if SymbolRec1.PtrSize <= 4 then + begin + Prg.AsmMovREG32_REGPtr(Reg, Reg); + end; + + FreeReg(Reg); + Exit; + end; + end; + + Reg := GetReg; + + if SymbolRec1.Kind = KindSUB then + begin + if Host1 then + EmitGet_REG(Reg, SymbolRec1) + else + begin + Prg.AsmMovREG_REG(Reg, _EDI); + Prg.AsmAddREG_Imm(Reg, 0); + Prg.Top.SaveSubId := R.Arg1; + List2.Add(Prg.Top); + end; + end + else + EmitLoadAddress(Reg, SymbolRec1); + + EmitPushParam(Reg); + FreeReg(Reg); +end; + +procedure TEmitter.EmitOP_PUSH_INT_IMM_64; +begin + EmitOP_PUSH_INT_IMM; +end; +procedure TEmitter.EmitOP_PUSH_INT_IMM; +var + Reg: Integer; + SubId, ParamId, ParamNumber: Integer; +begin + EmitPCodeOperator; + + if R.Res = 0 then + begin + Prg.AsmPush_IMM(ImmValue1); + Exit; + end; + + SubId := R.Res; + ParamNumber := R.Arg2; + + if GetSymbolRec(SubId).CallConv in [ccREGISTER, ccMSFASTCALL] then + begin + ParamId := SymbolTable.GetParamId(SubId, ParamNumber); + + Reg := GetSymbolRec(ParamId).Register; + + if Reg > 0 then + begin + GetReg(Reg); + Prg.AsmMovREG_IMM(Reg, ImmValue1); + FreeReg(Reg); + Exit; + end; + end + else if GetSymbolRec(SubId).CallConv = cc64 then + begin + if SubId = JS_FunctionCallId then + begin + Prg.AsmMovREG_IMM(_R8, ImmValue1); + Exit; + end; + + ParamId := SymbolTable.GetParamId(SubId, ParamNumber); + + Reg := GetSymbolRec(ParamId).Register; + + if Reg > 0 then + begin + GetReg(Reg); + Prg.AsmMovREG_IMM(Reg, ImmValue1); + FreeReg(Reg); + Exit; + end; + + Reg := GetRegEx; + Prg.AsmMovREG_Imm(Reg, ImmValue1); + EmitPushParam(Reg); + FreeReg(Reg); + Exit; + end; + + Prg.AsmPush_IMM(ImmValue1); +end; + +procedure TEmitter.EmitOP_PUSH_DATA_64; +begin + RaiseNotImpl; +end; +procedure TEmitter.EmitOP_PUSH_DATA; +var + Reg: Integer; +begin + EmitPCodeOperator; + + Reg := GetRegEx; + + Emit_PUSH_REGS; + EmitLoadAddress(Reg, SymbolRec1); + Prg.AsmAddREG_Imm(Reg, SizeOfPointer); + Prg.AsmMovREG_REGPtr(Reg, Reg); + Emit_POP_REGS; + + if SymbolRecR.CallConv in [ccREGISTER, ccMSFASTCALL] then + Prg.AsmMovREG_REG(_EAX, Reg) + else + Prg.AsmPush_REG(Reg); + + FreeReg(Reg); +end; + +procedure TEmitter.EmitOP_PUSH_INT_64; +begin + EmitOP_PUSH_INT; +end; +procedure TEmitter.EmitOP_PUSH_INT; +var + Reg: Integer; + SubId, ParamId, ParamNumber: Integer; +begin + EmitPCodeOperator; + + if R.Res = 0 then + begin + Reg := GetReg; + EmitLoadIntVal(Reg, SymbolRec1); + Prg.AsmPush_REG(Reg); + FreeReg(Reg); + Exit; + end; + + SubId := R.Res; + ParamNumber := R.Arg2; + ParamId := SymbolTable.GetParamId(SubId, ParamNumber); + + Reg := GetSymbolRec(ParamId).Register; + + if Reg > 0 then + begin + GetReg(Reg); + EmitLoadIntVal(Reg, SymbolRec1); + FreeReg(Reg); + Exit; + end; + + Reg := GetReg; + EmitLoadIntVal(Reg, SymbolRec1); + EmitPushParam(Reg); + FreeReg(Reg); +end; + +procedure TEmitter.EmitOP_PUSH_SET_64; +begin + EmitOP_PUSH_SET; +end; +procedure TEmitter.EmitOP_PUSH_SET; +var + Reg: Integer; + SubId, ParamId, ParamNumber, K: Integer; +begin + EmitPCodeOperator; + + K := SymbolRec1.Kind; + try + SymbolRec1.Kind := KindVAR; + + if R.Res = 0 then + begin + Reg := GetReg; + EmitLoadIntVal(Reg, SymbolRec1); + Prg.AsmPush_REG(Reg); + FreeReg(Reg); + Exit; + end; + + SubId := R.Res; + ParamNumber := R.Arg2; + ParamId := SymbolTable.GetParamId(SubId, ParamNumber); + + Reg := GetSymbolRec(ParamId).Register; + + if Reg > 0 then + begin + GetReg(Reg); + EmitLoadIntVal(Reg, SymbolRec1); + FreeReg(Reg); + Exit; + end; + + Reg := GetReg; + EmitLoadIntVal(Reg, SymbolRec1); + EmitPushParam(Reg); + FreeReg(Reg); + + finally + SymbolRec1.Kind := K; + end; +end; + +procedure TEmitter.EmitOP_PUSH_DYNARRAY_64; +var + Reg, RegEx: Integer; + SubId, ParamId, ParamNumber, K, Z: Integer; + S: String; +begin + EmitPCodeOperator; + + if R.Res = 0 then + begin + Reg := GetReg; + EmitLoadIntVal(Reg, SymbolRec1); + Prg.AsmPush_REG(Reg); + FreeReg(Reg); + Exit; + end; + + SubId := R.Res; + ParamNumber := R.Arg2; + ParamId := SymbolTable.GetParamId(SubId, ParamNumber); + + S := SymbolTable[SubId].Name; + + Reg := GetSymbolRec(ParamId).Register; + + k := SymbolRec1.Count; + + Z := GetSymbolRec(ParamId).RSPOffset; + + if Reg > 0 then + begin + GetReg(Reg); + EmitLoadIntVal(Reg, SymbolRec1); + FreeReg(Reg); + + if SymbolTable[ParamId].IsOpenArray then + begin + if Reg = _ECX then + RegEx := _EDX + else if Reg = _EDX then + RegEx := _R8 + else if Reg = _R8 then + RegEx := _R9 + else + RegEx := _EBX; + + if (RegEx = _EBX) and (Reg <> _R9) then + begin + Prg.AsmMovRSPPtr_REG64(Reg, Z); + Inc(Z, 8); + end; + + GetReg(RegEx); + + // load high(A) into RegEx + Prg.AsmMovREG_Imm(RegEx, k - 1); + + if RegEx = _EBX then + Prg.AsmMovRSPPtr_REG64(RegEx, Z); + + FreeReg(RegEx); + end; + + Exit; + end; + + Reg := GetReg(_EBX); + + EmitLoadIntVal(Reg, SymbolRec1); + Prg.AsmMovRSPPtr_REG64(Reg, Z); + Inc(Z, 8); + + if SymbolTable[ParamId].IsOpenArray then + begin + // load high(A) into RegEx + Prg.AsmMovREG_Imm(Reg, k - 1); + Prg.AsmMovRSPPtr_REG64(Reg, Z); + end; + + FreeReg(Reg); +end; +procedure TEmitter.EmitOP_PUSH_DYNARRAY; +var + Reg, RegEx: Integer; + SubId, ParamId, ParamNumber: Integer; + S: String; +begin + EmitPCodeOperator; + + if R.Res = 0 then + begin + Reg := GetReg; + EmitLoadIntVal(Reg, SymbolRec1); + Prg.AsmPush_REG(Reg); + FreeReg(Reg); + Exit; + end; + + SubId := R.Res; + ParamNumber := R.Arg2; + ParamId := SymbolTable.GetParamId(SubId, ParamNumber); + + S := SymbolTable[SubId].Name; + + Reg := GetSymbolRec(ParamId).Register; + + if Reg > 0 then + begin + GetReg(Reg); + EmitLoadIntVal(Reg, SymbolRec1); + FreeReg(Reg); + + if SymbolTable[ParamId].IsOpenArray then + begin + if Reg = _EAX then + RegEx := _EDX + else if Reg = _EDX then + RegEx := _ECX + else + RegEx := _EBX; + + if (RegEx = _EBX) and (Reg <> _ECX) then + Prg.AsmPush_REG(Reg); + + GetReg(RegEx); + + if SymbolRec1.FinalTypeId = typeDYNARRAY then + begin + // load high(A) into RegEx + + Prg.AsmMovREG_REG(RegEx, Reg); + + Prg.AsmCmpREG_Imm(RegEx, 0); + Prg.AsmJZ_Imm(5 + 2); + + Prg.AsmAddREG_Imm(RegEx, -4); // 5 + Prg.AsmMovREG32_REGPtr(RegEx, RegEx); // 2 + Prg.AsmAddREG_Imm(RegEx, -1); + end + else + begin + Prg.AsmMovREG_Imm(RegEx, 0); + end; + + if RegEx = _EBX then + Prg.AsmPush_REG(RegEx); + + FreeReg(RegEx); + end; + + Exit; + end; + + if GetSymbolRec(SubId).CallConv in [ccREGISTER, ccMSFASTCALL] then + begin + Reg := GetReg; + + EmitLoadIntVal(Reg, SymbolRec1); + Prg.AsmPush_REG(Reg); + + if SymbolTable[ParamId].IsOpenArray then + begin + if SymbolRec1.FinalTypeId = typeDYNARRAY then + begin + // load high(A) into RegEx + EmitLoadIntVal(Reg, SymbolRec1); + + Prg.AsmCmpREG_Imm(Reg, 0); + Prg.AsmJZ_Imm(5 + 2); + + Prg.AsmAddREG_Imm(Reg, -4); //5 + Prg.AsmMovREG32_REGPtr(Reg, Reg); //2 + Prg.AsmAddREG_Imm(Reg, -1); + Prg.AsmPush_REG(Reg); + end + else + Prg.AsmPush_Imm(0); + end; + +// EmitLoadIntVal(Reg, SymbolRec1); +// Prg.AsmPush_REG(Reg); + + FreeReg(Reg); + Exit; + end; + + Reg := GetReg; + if SymbolTable[ParamId].IsOpenArray then + begin + if SymbolRec1.FinalTypeId = typeDYNARRAY then + begin + // load high(A) into RegEx + + EmitLoadIntVal(Reg, SymbolRec1); + + Prg.AsmCmpREG_Imm(Reg, 0); + Prg.AsmJZ_Imm(5 + 2); + + Prg.AsmAddREG_Imm(Reg, -4); // 5 + Prg.AsmMovREG32_REGPtr(Reg, Reg); // 2 + Prg.AsmAddREG_Imm(Reg, -1); + Prg.AsmPush_REG(Reg); + end + else + Prg.AsmPush_Imm(0); + end; + + EmitLoadIntVal(Reg, SymbolRec1); + Prg.AsmPush_REG(Reg); + FreeReg(Reg); +end; + +procedure TEmitter.EmitOP_PUSH_OPENARRAY_64; +begin + RaiseNotImpl; +end; +procedure TEmitter.EmitOP_PUSH_OPENARRAY; +var + Reg, RegEx: Integer; + SubId, ParamId, HighParamId, ParamNumber: Integer; + ArrayTypeId, RangeTypeId, ElemTypeId, B1, B2: Integer; +begin + EmitPCodeOperator; + + if R.Res = 0 then + begin + RaiseError(errInternalError, []); + end; + + SubId := R.Res; + ParamNumber := R.Arg2; + ParamId := SymbolTable.GetParamId(SubId, ParamNumber); + + Reg := GetSymbolRec(ParamId).Register; + + if Reg > 0 then + begin + if SymbolRec1.IsOpenArray then + begin + + GetReg(Reg); + EmitLoadIntVal(Reg, SymbolRec1); + FreeReg(Reg); + + if Reg = _EAX then + RegEx := _EDX + else if Reg = _EDX then + RegEx := _ECX + else + RegEx := _EBX; + + if (RegEx = _EBX) and (Reg <> _ECX) then + Prg.AsmPush_REG(Reg); + + GetReg(RegEx); + + // load high(A) into RegEx + HighParamId := SymbolTable.GetOpenArrayHighId(R.Arg1); + EmitLoadIntVal(RegEx, GetSymbolRec(HighParamId)); + + if RegEx = _EBX then + Prg.AsmPush_REG(RegEx); + + FreeReg(RegEx); + end + else if SymbolRec1.FinalTypeId = typeARRAY then + begin + GetReg(Reg); + EmitLoadAddress(Reg, SymbolRec1); + FreeReg(Reg); + + if Reg = _EAX then + RegEx := _EDX + else if Reg = _EDX then + RegEx := _ECX + else + RegEx := _EBX; + + if (RegEx = _EBX) and (Reg <> _ECX) then + Prg.AsmPush_REG(Reg); + + GetReg(RegEx); + + // load high(A) into RegEx + ArrayTypeId := SymbolRec1.TerminalTypeId; + TKernel(kernel).SymbolTable.GetArrayTypeInfo(ArrayTypeId, RangeTypeId, ElemTypeId); + B1 := TKernel(kernel).SymbolTable.GetLowBoundRec(RangeTypeId).Value; + B2 := TKernel(kernel).SymbolTable.GetHighBoundRec(RangeTypeId).Value; + Prg.AsmMovREG_Imm(RegEx, B2 - B1); + + if RegEx = _EBX then + Prg.AsmPush_REG(RegEx); + + FreeReg(RegEx); + end + else if SymbolRec1.IsFWArrayVar then + begin + + GetReg(Reg); + EmitLoadIntVal(Reg, SymbolRec1); + Prg.AsmAddReg_Imm(Reg, FWArrayOffset); + Prg.AsmMovREG32_REGPtr(Reg, Reg); + FreeReg(Reg); + + if Reg = _EAX then + RegEx := _EDX + else if Reg = _EDX then + RegEx := _ECX + else + RegEx := _EBX; + + if (RegEx = _EBX) and (Reg <> _ECX) then + Prg.AsmPush_REG(Reg); + + Prg.AsmMovREG_REG(RegEx, Reg); + + Prg.AsmCmpREG_Imm(RegEx, 0); + Prg.AsmJZ_Imm(5 + 2); + + Prg.AsmAddREG_Imm(RegEx, -4); // 5 + Prg.AsmMovREG32_REGPtr(RegEx, RegEx); // 2 + Prg.AsmAddREG_Imm(RegEx, -1); + + if RegEx = _EBX then + Prg.AsmPush_REG(RegEx); + end; + + + Exit; + end; + + if GetSymbolRec(SubId).CallConv in [ccREGISTER, ccMSFASTCALL] then + begin + Reg := GetReg; + EmitLoadIntVal(Reg, SymbolRec1); + Prg.AsmPush_REG(Reg); + if SymbolRec1.IsOpenArray then + begin + // load high(A) into RegEx + HighParamId := SymbolTable.GetOpenArrayHighId(R.Arg1); + EmitLoadIntVal(Reg, GetSymbolRec(HighParamId)); + Prg.AsmPush_REG(Reg); + end + else if SymbolRec1.FinalTypeId = typeARRAY then + begin + // load high(A) into RegEx + ArrayTypeId := SymbolRec1.TerminalTypeId; + TKernel(kernel).SymbolTable.GetArrayTypeInfo(ArrayTypeId, RangeTypeId, ElemTypeId); + B1 := TKernel(kernel).SymbolTable.GetLowBoundRec(RangeTypeId).Value; + B2 := TKernel(kernel).SymbolTable.GetHighBoundRec(RangeTypeId).Value; + Prg.AsmMovREG_Imm(Reg, B2 - B1); + Prg.AsmPush_REG(Reg); + end; + FreeReg(Reg); + Exit; + end; + + if SymbolRec1.IsFWArrayVar then + begin + Reg := GetReg; + // load high(A) into RegEx + + EmitLoadIntVal(Reg, SymbolRec1); + Prg.AsmAddReg_Imm(Reg, FWArrayOffset); + Prg.AsmMovREG32_REGPtr(Reg, Reg); + + Prg.AsmCmpREG_Imm(Reg, 0); + Prg.AsmJZ_Imm(5 + 2); + + Prg.AsmAddREG_Imm(Reg, -4); //5 + Prg.AsmMovREG32_REGPtr(Reg, Reg); //2 + Prg.AsmAddREG_Imm(Reg, -1); + Prg.AsmPush_REG(Reg); + + EmitLoadIntVal(Reg, SymbolRec1); + Prg.AsmAddReg_Imm(Reg, FWArrayOffset); + Prg.AsmMovREG32_REGPtr(Reg, Reg); + Prg.AsmPush_REG(Reg); + FreeReg(Reg); + Exit; + end; + + Reg := GetReg; + if SymbolRec1.IsOpenArray then + begin + // load high(A) into Reg + HighParamId := SymbolTable.GetOpenArrayHighId(R.Arg1); + EmitLoadIntVal(Reg, GetSymbolRec(HighParamId)); + Prg.AsmPush_REG(Reg); + end + else if SymbolRec1.FinalTypeId = typeARRAY then + begin + // load high(A) into RegEx + ArrayTypeId := SymbolRec1.TerminalTypeId; + TKernel(kernel).SymbolTable.GetArrayTypeInfo(ArrayTypeId, RangeTypeId, ElemTypeId); + B1 := TKernel(kernel).SymbolTable.GetLowBoundRec(RangeTypeId).Value; + B2 := TKernel(kernel).SymbolTable.GetHighBoundRec(RangeTypeId).Value; + Prg.AsmMovREG_Imm(Reg, B2 - B1); + Prg.AsmPush_REG(Reg); + end; + EmitLoadIntVal(Reg, SymbolRec1); + Prg.AsmPush_REG(Reg); + FreeReg(Reg); +end; + +procedure TEmitter.EmitOP_CLEAR_EDX_64; +begin + EmitOP_CLEAR_EDX; +end; +procedure TEmitter.EmitOP_CLEAR_EDX; +begin + EmitPCodeOperator; + Prg.AsmMovREG_Imm(_EDX, 0); +end; + +procedure TEmitter.EmitOP_UPDATE_INSTANCE_64; +var + Reg: Integer; + SubId: Integer; +begin + EmitPCodeOperator; + + SubId := Id_UpdateInstance; + EmitCallPro(SubId); + + Reg := GetRegEx; + + Emit_PUSH_REGS; + + Prg.AsmMovREG_REG(Reg, _ESI); + Prg.AsmAddREG_Imm(Reg, H_SelfPtr); + Prg.AsmMovREG_REGPtr(Reg, Reg); // load TProgram.Self + Prg.AsmMovREG_REG(_ECX, Reg); + + EmitLoadIntVal(Reg, SymbolRec1); // instance + Prg.AsmMovREG_REG(_EDX, Reg); + FreeReg(Reg); + + EmitStdCall(SubId); + + Emit_POP_REGS; +end; +procedure TEmitter.EmitOP_UPDATE_INSTANCE; +var + Reg: Integer; + SubId: Integer; +begin + EmitPCodeOperator; + + SubId := Id_UpdateInstance; + EmitCallPro(SubId); + + Reg := GetRegEx; + + Emit_PUSH_REGS; + + EmitLoadIntVal(Reg, SymbolRec1); // instance + Prg.AsmPush_REG(Reg); + + Prg.AsmMovREG_REG(Reg, _ESI); + Prg.AsmAddREG_Imm(Reg, H_SelfPtr); + Prg.AsmMovREG_REGPtr(Reg, Reg); // load TProgram.Self + Prg.AsmPush_REG(Reg); + + FreeReg(Reg); + + EmitStdCall(SubId); + + Emit_POP_REGS; +end; + +procedure TEmitter.EmitOP_PUSH_INST_64; +var + Reg: Integer; + SubId: Integer; + L, K: Integer; + SR: TSymbolRec; +begin + EmitPCodeOperator; + + L := GetSymbolRec(R.Res).Level; + if GetSymbolRec(L).FinalTypeId = typeHELPER then + L := GetSymbolRec(L).PatternId; + + K := SymbolTable[R.Res].Kind; + if (K = kindCONSTRUCTOR) and + (SymbolTable[SymbolTable[R.Res].Level].FinalTypeId <> typeRECORD) and + SymbolTable[R.Res].Host and + (not SymbolTable[R.Res].IsExternal) then + begin + SubId := Id_ToParentClass; + EmitCallPro(SubId); + + Reg := GetRegEx; + + Emit_PUSH_REGS; + + Prg.AsmMovREG_REG(Reg, _ESI); + Prg.AsmAddREG_Imm(Reg, H_SelfPtr); + Prg.AsmMovREG_REGPtr(Reg, Reg); // load TProgram.Self + Prg.AsmMovREG_REG(_ECX, Reg); + + EmitLoadIntVal(Reg, SymbolRec1); // instance + Prg.AsmMovREG_REG(_EDX, Reg); + FreeReg(Reg); + + EmitStdCall(SubId); + + Emit_POP_REGS; + end; + + GetReg(_ECX); + + if GetSymbolRec(L).FinalTypeId in [typeCLASS, typeINTERFACE] then + EmitLoadIntVal(_ECX, SymbolRec1) + else + EmitLoadAddress(_ECX, SymbolRec1); + + if SymbolRecR.IsSharedMethod then + if not StrEql(SymbolRecR.Name, 'ClassType') then + Prg.AsmMovREG_REGPtr(_ECX, _ECX); + + FreeReg(_ECX); + + SR := SymbolTable[R.Res]; + + if SR.Kind in [kindCONSTRUCTOR, kindDESTRUCTOR] then + begin + Prg.AsmMovREG_Imm(_EDX, 0); + end + else if SR.IsFakeMethod then + if SR.ExtraParamNeeded then + begin + Prg.AsmMovREG_REG(_EDX, _ECX); + end; +end; +procedure TEmitter.EmitOP_PUSH_INST; +var + Reg: Integer; + SubId: Integer; + L, K: Integer; +begin + EmitPCodeOperator; + + L := GetSymbolRec(R.Res).Level; + if GetSymbolRec(L).FinalTypeId = typeHELPER then + L := GetSymbolRec(L).PatternId; + + if SymbolTable[R.Res].CallConv in [ccREGISTER, ccMSFASTCALL] then + begin + K := SymbolTable[R.Res].Kind; + if (K = kindCONSTRUCTOR) and + (SymbolTable[SymbolTable[R.Res].Level].FinalTypeId <> typeRECORD) and + SymbolTable[R.Res].Host and + (not SymbolTable[R.Res].IsExternal) then + begin + SubId := Id_ToParentClass; + EmitCallPro(SubId); + + Reg := GetRegEx; + + Emit_PUSH_REGS; + + EmitLoadIntVal(Reg, SymbolRec1); // instance + Prg.AsmPush_REG(Reg); + + Prg.AsmMovREG_REG(Reg, _ESI); + Prg.AsmAddREG_Imm(Reg, H_SelfPtr); + Prg.AsmMovREG_REGPtr(Reg, Reg); // load TProgram.Self + Prg.AsmPush_REG(Reg); + + FreeReg(Reg); + + EmitStdCall(SubId); + + Emit_POP_REGS; + end; + + GetReg(_EAX); + + if GetSymbolRec(L).FinalTypeId in [typeCLASS, typeINTERFACE] then + EmitLoadIntVal(_EAX, SymbolRec1) + else + EmitLoadAddress(_EAX, SymbolRec1); + + if SymbolRecR.IsSharedMethod then + if not StrEql(SymbolRecR.Name, 'ClassType') then + Prg.AsmMovREG_REGPtr(_EAX, _EAX); + + FreeReg(_EAX); + + if SymbolTable[R.Res].Kind in [kindCONSTRUCTOR, kindDESTRUCTOR] then + begin + Prg.AsmMovREG_Imm(_EDX, 0); + end; + end + else + begin + + if (SymbolTable[R.Res].Kind = kindCONSTRUCTOR) and + SymbolTable[R.Res].Host and + (not SymbolTable[R.Res].IsExternal) then + begin + SubId := Id_ToParentClass; + EmitCallPro(SubId); + + Reg := GetRegEx; + + Emit_PUSH_REGS; + + EmitLoadIntVal(Reg, SymbolRec1); // instance + Prg.AsmPush_REG(Reg); + + Prg.AsmMovREG_REG(Reg, _ESI); + Prg.AsmAddREG_Imm(Reg, H_SelfPtr); + Prg.AsmMovREG_REGPtr(Reg, Reg); // load TProgram.Self + Prg.AsmPush_REG(Reg); + + FreeReg(Reg); + + EmitStdCall(SubId); + + Emit_POP_REGS; + end; + + GetReg(_EAX); + Reg := _EAX; + + if GetSymbolRec(L).FinalTypeId in [typeCLASS, typeINTERFACE] then + EmitLoadIntVal(Reg, SymbolRec1) + else + EmitLoadAddress(Reg, SymbolRec1); + + if SymbolRecR.IsSharedMethod then + if not StrEql(SymbolRecR.Name, 'ClassType') then + Prg.AsmMovREG_REGPtr(_EAX, _EAX); + + Prg.AsmPush_REG(Reg); + FreeReg(Reg); + end; +end; + +procedure TEmitter.EmitOP_PUSH_CLSREF_64; +begin + EmitPCodeOperator; + + if SymbolRecR.Kind = kindCONSTRUCTOR then + begin + GetReg(_ECX); + GetReg(_EDX); + +{$IFDEF FPC} + if SymbolRecR.Host then + begin + EmitLoadIntVal(_EDX, SymbolRec1); + Prg.AsmMovREG_Imm(_ECX, 0); + end + else + begin + EmitLoadIntVal(_ECX, SymbolRec1); + Prg.AsmMovREG_Imm(_EDX, 1); + end; +{$ELSE} + EmitLoadIntVal(_ECX, SymbolRec1); + Prg.AsmMovREG_Imm(_EDX, 1); +{$ENDIF} + + FreeReg(_EDX); + FreeReg(_ECX); + + if SymbolRecR.IsExternal then + begin + Emit_PUSH_REGS; + + Prg.AsmPush_REG(_EAX); + + Prg.AsmMovREG_REG(_EBX, _ESI); + Prg.AsmAddREG_Imm(_EBX, H_SelfPtr); + Prg.AsmMovREG_REGPtr(_EBX, _EBX); // load TProgram.Self + Prg.AsmPush_REG(_EBX); + + Prg.AsmGetREG_ESIPtr(_EBX, GetOffset(SymbolTable[Id_LoadClassRef])); + Prg.AsmCall_REG(_EBX); + + Emit_POP_REGS; + end; + end + else + begin + GetReg(_EAX); + EmitLoadIntVal(_EAX, SymbolRec1); + if SymbolTable[R.Res].CallConv <> ccREGISTER then + Prg.AsmPush_REG(_EAX); + FreeReg(_EAX); + end; +end; + +procedure TEmitter.EmitOP_PUSH_CLSREF; +var + Reg, SubId: Integer; +begin + EmitPCodeOperator; + + if SymbolRecR.Kind = kindCONSTRUCTOR then + begin + GetReg(_EAX); + GetReg(_EDX); + +{$IFDEF FPC} + if SymbolRecR.Host then + begin + EmitLoadIntVal(_EDX, SymbolRec1); + Prg.AsmMovREG_Imm(_EAX, 0); + end + else + begin + EmitLoadIntVal(_EAX, SymbolRec1); + Prg.AsmMovREG_Imm(_EDX, 1); + end; +{$ELSE} + EmitLoadIntVal(_EAX, SymbolRec1); + Prg.AsmMovREG_Imm(_EDX, 1); +{$ENDIF} + + FreeReg(_EDX); + FreeReg(_EAX); + + if SymbolRecR.IsExternal then + begin + Emit_PUSH_REGS; + + SubId := Id_LoadClassRef; + + EmitCallPro(SubId); + + Reg := GetRegEx; + + Prg.AsmPush_REG(_EAX); + + Prg.AsmMovREG_REG(Reg, _ESI); + Prg.AsmAddREG_Imm(Reg, H_SelfPtr); + Prg.AsmMovREG_REGPtr(Reg, Reg); // load TProgram.Self + Prg.AsmPush_REG(Reg); + + FreeReg(Reg); + + EmitStdCall(SubId); + + Emit_POP_REGS; + end; + end + else + begin + GetReg(_EAX); + EmitLoadIntVal(_EAX, SymbolRec1); + if SymbolTable[R.Res].CallConv <> ccREGISTER then + Prg.AsmPush_REG(_EAX); + FreeReg(_EAX); + end; +end; + +procedure TEmitter.EmitOP_PUSH_INT64; +var + Reg: Integer; +begin + EmitPCodeOperator; + + Reg := GetReg; + if Host1 or ByRef1 then + begin + EmitLoadAddress(Reg, SymbolRec1); + + Prg.AsmAddREG_Imm(Reg, 4); + Prg.AsmPush_REGPtr(Reg); + Prg.AsmAddREG_Imm(Reg, -4); + Prg.AsmPush_REGPtr(Reg); + end + else + begin + EmitGet_REG(Reg, SymbolRec1, + 4); + Prg.AsmPush_REG(Reg); + EmitGet_REG(Reg, SymbolRec1); + Prg.AsmPush_REG(Reg); + end; + FreeReg(Reg); +end; + +procedure TEmitter.EmitOP_PUSH_EVENT_64; +begin + RaiseNotImpl; +end; +procedure TEmitter.EmitOP_PUSH_EVENT; +var + Reg: Integer; +begin + EmitPCodeOperator; + + HandlesEvents := true; + + Reg := GetReg; + if Host1 or ByRef1 then + begin + EmitLoadAddress(Reg, SymbolRec1); + + Prg.AsmAddREG_Imm(Reg, 4); + Prg.AsmPush_REGPtr(Reg); + Prg.AsmAddREG_Imm(Reg, -4); + Prg.AsmPush_REGPtr(Reg); + end + else + begin + EmitGet_REG(Reg, SymbolRec1, + 4); + Prg.AsmPush_REG(Reg); + EmitGet_REG(Reg, SymbolRec1); + Prg.AsmPush_REG(Reg); + end; + FreeReg(Reg); +end; + +procedure TEmitter.EmitOP_PUSH_DOUBLE_64; +var + Reg, SubId, ParamNumber, ParamId: Integer; + S: TSymbolRec; +begin + EmitPCodeOperator; + + SubId := R.Res; + ParamNumber := R.Arg2; + ParamId := SymbolTable.GetParamId(SubId, ParamNumber); + S := GetSymbolRec(ParamId); + + Reg := GetReg; + EmitLoadAddress(Reg, SymbolRec1); + if S.XMMReg > 0 then + begin + Prg.AsmMovsdXMM_RegPtr(S.XMMReg, Reg); + end + else + begin + Prg.AsmMovsdXMM_RegPtr(_XMM4, Reg); + Prg.AsmMovREG_REG(Reg, _ESP); + Prg.AsmAddREG_Imm(Reg, S.RSPOffset); + Prg.AsmMovsdRegPtr_XMM(_XMM4, Reg); + end; + FreeReg(Reg); +end; +procedure TEmitter.EmitOP_PUSH_DOUBLE; +var + Reg: Integer; +begin + EmitPCodeOperator; + + Reg := GetReg; + if Host1 or ByRef1 then + begin + EmitLoadAddress(Reg, SymbolRec1); + + Prg.AsmAddREG_Imm(Reg, 4); + Prg.AsmPush_REGPtr(Reg); + Prg.AsmAddREG_Imm(Reg, -4); + Prg.AsmPush_REGPtr(Reg); + end + else + begin + EmitGet_REG(Reg, SymbolRec1, + 4); + Prg.AsmPush_REG(Reg); + EmitGet_REG(Reg, SymbolRec1); + Prg.AsmPush_REG(Reg); + end; + FreeReg(Reg); +end; + +procedure TEmitter.EmitOP_PUSH_CURRENCY; +var + Reg: Integer; +begin + EmitPCodeOperator; + + Reg := GetReg; + if Host1 or ByRef1 then + begin + EmitLoadAddress(Reg, SymbolRec1); + + Prg.AsmAddREG_Imm(Reg, 4); + Prg.AsmPush_REGPtr(Reg); + Prg.AsmAddREG_Imm(Reg, -4); + Prg.AsmPush_REGPtr(Reg); + end + else + begin + EmitGet_REG(Reg, SymbolRec1, + 4); + Prg.AsmPush_REG(Reg); + EmitGet_REG(Reg, SymbolRec1); + Prg.AsmPush_REG(Reg); + end; + FreeReg(Reg); +end; + +procedure TEmitter.EmitOP_PUSH_EXTENDED; +var + RegAddr, RegE: Integer; +begin + EmitPCodeOperator; + + RegAddr := GetReg; + + EmitLoadAddress(RegAddr, SymbolRec1); + + if TargetPlatform in [tpOSX32, tpIOSSim] then + begin + Prg.AsmAddREG_Imm(RegAddr, 12); + + Prg.AsmPush_REGPtr(RegAddr); + + Prg.AsmAddREG_Imm(RegAddr, -4); + Prg.AsmPush_REGPtr(RegAddr); + + Prg.AsmAddREG_Imm(RegAddr, -4); + Prg.AsmPush_REGPtr(RegAddr); + + Prg.AsmAddREG_Imm(RegAddr, -4); + Prg.AsmPush_REGPtr(RegAddr); + end + else + begin + RegE := GetReg; + Prg.AsmAddREG_Imm(RegAddr, 8); + Prg.AsmMovREG16_REGPtr(RegE, RegAddr); + Prg.AsmPush_REG(RegE); + + Prg.AsmAddREG_Imm(RegAddr, -4); + Prg.AsmPush_REGPtr(RegAddr); + Prg.AsmAddREG_Imm(RegAddr, -4); + Prg.AsmPush_REGPtr(RegAddr); + FreeReg(RegE); + end; + + FreeReg(RegAddr); +end; + +procedure TEmitter.EmitOP_PUSH_SINGLE_64; +var + Reg, SubId, ParamNumber, ParamId: Integer; + S: TSymbolRec; +begin + EmitPCodeOperator; + + SubId := R.Res; + ParamNumber := R.Arg2; + ParamId := SymbolTable.GetParamId(SubId, ParamNumber); + S := GetSymbolRec(ParamId); + + Reg := GetReg; + EmitLoadAddress(Reg, SymbolRec1); + if S.XMMReg > 0 then + begin + Prg.AsmMovssXMM_RegPtr(S.XMMReg, Reg); + end + else + begin + Prg.AsmMovssXMM_RegPtr(_XMM4, Reg); + Prg.AsmMovREG_REG(Reg, _ESP); + Prg.AsmAddREG_Imm(Reg, S.RSPOffset); + Prg.AsmMovssRegPtr_XMM(_XMM4, Reg); + end; + FreeReg(Reg); +end; +procedure TEmitter.EmitOP_PUSH_SINGLE; +var + Reg: Integer; + I: Integer; + S: Single; +begin + EmitPCodeOperator; + + if SymbolRec1.Kind = KindCONST then + begin + S := SymbolRec1.Value; + Move(S, I, SizeOf(Single)); + Prg.AsmPush_IMM(I); + end + else + begin + Reg := GetReg; + EmitLoadIntVal(Reg, SymbolRec1); + Prg.AsmPush_REG(Reg); + FreeReg(Reg); + end; +end; + +procedure TEmitter.EmitOP_PUSH_ANSISTRING_64; +begin + EmitOP_PUSH_ANSISTRING; +end; +procedure TEmitter.EmitOP_PUSH_ANSISTRING; +var + Reg: Integer; + SubId, ParamId, ParamNumber: Integer; +begin + EmitPCodeOperator; + + SubId := R.Res; + ParamNumber := R.Arg2; + ParamId := SymbolTable.GetParamId(SubId, ParamNumber); + + Reg := GetSymbolRec(ParamId).Register; + + if Reg > 0 then + begin + GetReg(Reg); + EmitLoadIntVal(Reg, SymbolRec1); + FreeReg(Reg); + Exit; + end; + + Reg := GetReg; + EmitLoadIntVal(Reg, SymbolRec1); + EmitPushParam(Reg); + FreeReg(Reg); +end; + +procedure TEmitter.EmitOP_PUSH_WIDESTRING_64; +begin + EmitOP_PUSH_WIDESTRING; +end; +procedure TEmitter.EmitOP_PUSH_WIDESTRING; +var + Reg: Integer; + SubId, ParamId, ParamNumber: Integer; +begin + EmitPCodeOperator; + + SubId := R.Res; + ParamNumber := R.Arg2; + ParamId := SymbolTable.GetParamId(SubId, ParamNumber); + + Reg := GetSymbolRec(ParamId).Register; + + if Reg > 0 then + begin + GetReg(Reg); + EmitLoadIntVal(Reg, SymbolRec1); + FreeReg(Reg); + Exit; + end; + + Reg := GetReg; + EmitLoadIntVal(Reg, SymbolRec1); + EmitPushParam(Reg); + FreeReg(Reg); +end; + +procedure TEmitter.EmitOP_PUSH_UNICSTRING_64; +begin + EmitOP_PUSH_UNICSTRING; +end; +procedure TEmitter.EmitOP_PUSH_UNICSTRING; +var + Reg: Integer; + SubId, ParamId, ParamNumber: Integer; +begin + EmitPCodeOperator; + + SubId := R.Res; + ParamNumber := R.Arg2; + ParamId := SymbolTable.GetParamId(SubId, ParamNumber); + + Reg := GetSymbolRec(ParamId).Register; + + if Reg > 0 then + begin + GetReg(Reg); + EmitLoadIntVal(Reg, SymbolRec1); + FreeReg(Reg); + Exit; + end; + + Reg := GetReg; + EmitLoadIntVal(Reg, SymbolRec1); + EmitPushParam(Reg); + FreeReg(Reg); +end; + +procedure TEmitter.EmitOP_PUSH_SHORTSTRING_64; +begin + EmitOP_PUSH_SHORTSTRING; +end; +procedure TEmitter.EmitOP_PUSH_SHORTSTRING; +var + Reg: Integer; + SubId, ParamId, ParamNumber: Integer; +begin + EmitPCodeOperator; + + // push address + + SubId := R.Res; + ParamNumber := R.Arg2; + ParamId := SymbolTable.GetParamId(SubId, ParamNumber); + Reg := GetSymbolRec(ParamId).Register; + + if Reg > 0 then + begin + GetReg(Reg); + EmitLoadAddress(Reg, SymbolRec1); + FreeReg(Reg); + Exit; + end; + + Reg := GetReg; + EmitLoadAddress(Reg, SymbolRec1); + EmitPushParam(Reg); + FreeReg(Reg); +end; + +{$IFNDEF PAXARM} +procedure TEmitter.EmitOP_PUSH_PANSICHAR_IMM_64; +begin + EmitOP_PUSH_PANSICHAR_IMM; +end; +procedure TEmitter.EmitOP_PUSH_PANSICHAR_IMM; +var + Reg: Integer; + SubId, ParamId, ParamNumber, Id: Integer; +begin + EmitPCodeOperator; + + // to provide unique constant address + Id := SymbolTable.FindPAnsiCharConst(SymbolRec1.Value, R.Arg1 - 1); + if Id > 0 then + if SymbolTable.InCode[Id] then + R.Arg1 := Id; + + SubId := R.Res; + ParamNumber := R.Arg2; + ParamId := SymbolTable.GetParamId(SubId, ParamNumber); + + Reg := GetSymbolRec(ParamId).Register; + + if Reg > 0 then + begin + GetReg(Reg); + EmitGet_REG(Reg, SymbolRec1); // pchar source + FreeReg(Reg); + Exit; + end; + + Reg := GetReg; + EmitGet_REG(Reg, SymbolRec1); // pchar source + EmitPushParam(Reg); + FreeReg(Reg); +end; +{$ENDIF} + +procedure TEmitter.EmitOP_PUSH_PWIDECHAR_IMM_64; +begin + EmitOP_PUSH_PWIDECHAR_IMM; +end; +procedure TEmitter.EmitOP_PUSH_PWIDECHAR_IMM; +var + Reg: Integer; + SubId, ParamId, ParamNumber, Id: Integer; +begin + EmitPCodeOperator; + + // to provide unique constant address + Id := SymbolTable.FindPWideCharConst(SymbolRec1.Value, R.Arg1 - 1); + if Id > 0 then + if SymbolTable.InCode[Id] then + R.Arg1 := Id; + + SubId := R.Res; + ParamNumber := R.Arg2; + ParamId := SymbolTable.GetParamId(SubId, ParamNumber); + + Reg := GetSymbolRec(ParamId).Register; + + if Reg > 0 then + begin + GetReg(Reg); + EmitGet_REG(Reg, SymbolRec1); // pchar source + FreeReg(Reg); + Exit; + end; + + Reg := GetReg; + EmitGet_REG(Reg, SymbolRec1); // pchar source + EmitPushParam(Reg); + FreeReg(Reg); +end; + +procedure TEmitter.EmitOP_ADDREF_64; +begin + EmitOP_ADDREF; +end; + +procedure TEmitter.EmitOP_ADDREF; +var + Reg, SubId: Integer; +begin + EmitPCodeOperator; + + SubId := 0; + + case SymbolRec1.FinalTypeId of +{$IFNDEF PAXARM} + typeANSISTRING: SubId := Id_StringAddRef; + typeWIDESTRING: SubId := Id_WideStringAddRef; +{$ENDIF} + typeUNICSTRING: SubId := Id_UnicStringAddRef; + typeVARIANT, typeOLEVARIANT: SubId := Id_VariantAddRef; + typeDYNARRAY: SubId := Id_DynarrayAddRef; + typeINTERFACE: SubId := Id_InterfaceAddRef; + else + RaiseError(errInternalError, []); + end; + + EmitCallPro(SubId); + + Reg := GetReg; + EmitLoadAddress(Reg, SymbolRec1); + Prg.AsmPush_REG(Reg); + FreeReg(Reg); + + EmitStdCall(SubId); +end; + +procedure TEmitter.EmitOP_BEGIN_CALL_64; +begin + EmitOP_BEGIN_CALL; +end; +procedure TEmitter.EmitOP_BEGIN_CALL; +var + Reg, I, SubId: Integer; + Code: TCode; +begin + EmitPCodeOperator; + + SubId := SymbolRec1.Id; + + if not SymbolRec1.IsNestedSub then + SaveRegisters([_ESI, _EDI], 4 * SizeOfPointer); + + EmitCallPro(SubId); + + if SymbolRec1.CallConv = ccSAFECALL then + begin + Code := TKernel(kernel).Code; + I := Code.N; + while I < Code.Card do + begin + Inc(I); + if Code[I].Op = OP_CALL then + if Code[I].Arg1 = SubId then + begin + if Code[I].Res > 0 then + begin + Reg := GetReg; + EmitLoadAddress(Reg, GetSymbolRec(Code[I].Res)); + Prg.AsmPush_REG(Reg); + FreeReg(Reg); + + Exit; + end; + break; + end; + end; + if Code[I].Res > 0 then + RaiseError(errInternalError, []); + end; +end; + +procedure TEmitter.EmitOP_CALL_64; +begin + EmitOP_CALL; +end; +procedure TEmitter.EmitOP_CALL; + +function DiscardVirtualCall: Boolean; +var + Code: TCode; + I: Integer; +begin + Code := TKernel(kernel).Code; + I := Code.N - 1; + while Code[I].Op <> OP_PUSH_INST do + Dec(I); + result := Code[I].CodeRecTag = TAG_DISCARD_VIRTUAL_CALL; +end; + +procedure EmitInterfaceAddress(MethodIndex: Integer); +var + Code: TCode; + I, RegInstance: Integer; +{$IFDEF FPC} + b: Boolean; +{$ENDIF} +begin +{$IFDEF FPC} + b := GetSymbolRec(SymbolRec1.Level).FinalTypeId = typeINTERFACE; +{$ENDIF} + + if TargetPlatform = tpWIN64 then + RegInstance := _ECX + else + RegInstance := _EAX; + Code := TKernel(kernel).Code; + I := Code.N - 1; + while Code[I].Op <> OP_PUSH_INST do + Dec(I); + + if I = Code.N - 1 then + begin + prg.AsmMovREG_REGPtr(_EBX, RegInstance); + prg.AsmAddREG_Imm(_EBX, (MethodIndex - 1) * SizeOfPointer); + +{$IFDEF FPC} + if not b then + prg.AsmAddREG_Imm(_EBX, FPC_VIRTUAL_OFFSET); +{$ENDIF} + prg.AsmMovREG_REGPtr(_EBX, _EBX); + end + else + begin + Emit_PUSH_REGS; + EmitLoadIntVal(_EAX, GetSymbolRec(Code[I].Arg1)); + prg.AsmMovREG_REGPtr(_EBX, RegInstance); + prg.AsmAddREG_Imm(_EBX, (MethodIndex - 1) * SizeOfPointer); +{$IFDEF FPC} + if not b then + prg.AsmAddREG_Imm(_EBX, FPC_VIRTUAL_OFFSET); +{$ENDIF} + prg.AsmMovREG_REGPtr(_EBX, _EBX); + Emit_POP_REGS; + end; +end; + +function FindBeginCall: TCodeRec; +var + RR: TCodeRec; + I, K, SubId: Integer; + Code: TCode; +begin + result := nil; + Code := TKernel(kernel).Code; + I := Code.N - 1; + RR := Code[Code.N]; + SubId := RR.Arg1; + K := 0; + repeat + if (Code[I].Op = OP_CALL) and (Code[I].Arg1 = SubId) then + Dec(K) + else if (Code[I].Op = OP_BEGIN_CALL) and (Code[I].Arg1 = SubId) then + begin + if K = 0 then + begin + result := Code[I]; + Exit; + end; + + Inc(K); + end; + + Dec(I); + until I = 0; +end; + +var + Reg, ParamId, I, K, T: Integer; + + {$IFDEF FPC} + SubId: Integer; + {$ENDIF} + + Code: TCode; + TrueSubId, cc: Integer; + + RR: TCodeRec; +begin + EmitPCodeOperator; + Code := TKernel(kernel).Code; + + if SymbolRec1.Kind = KindVAR then + begin + T := SymbolRec1.TerminalTypeId; + TrueSubId := GetSymbolRec(T).PatternId; + + if not (GetSymbolRec(TrueSubId).Kind in kindSUBS) then + begin + K := Code.N - 1; + repeat + if Code[K] .Op = OP_GET_VMT_ADDRESS then + if Code[K] .Res = SymbolRec1.Id then + begin + TrueSubId := Code[K] .Arg2; + break; + end; + + if Code[K] .Op = OP_SEPARATOR then + break; + + Dec(K); + until false; + end + else + begin + // ok + end; + + end + else + TrueSubId := SymbolRec1.Id; + + cc := GetSymbolRec(TrueSubId).CallConv; + + if (GetSymbolRec(TrueSubId).Level = H_TObject) then + if (GetSymbolRec(TrueSubId).Name = 'ClassName') then + begin + if Code[Code.N - 1].Op = OP_PUSH_CLSREF then + begin + if TargetPlatform = tpWIN64 then + begin + Prg.AsmMovREG_REG(_EDX, _ECX); + Prg.AsmMovREG_Imm(_ECX, 1); + end + else + Prg.AsmPush_Imm(1); + end + else if Code[Code.N - 1].Op = OP_PUSH_INST then + begin + I := Code.GetCurrSelfId(Code.N); + if I = Code[Code.N - 1].Arg1 then + begin + I := Code.GetCurrSubId(Code.N); + if GetSymbolRec(I).IsStatic then + begin + if TargetPlatform = tpWIN64 then + begin + Prg.AsmMovREG_REG(_R8, _ECX); + Prg.AsmMovREG_Imm(_EDX, 1); + end + else + Prg.AsmPush_Imm(1); + end + else + begin + if TargetPlatform = tpWIN64 then + begin + Prg.AsmMovREG_REG(_R8, _ECX); + Prg.AsmMovREG_Imm(_EDX, 0); + end + else + Prg.AsmPush_Imm(0); + end; + end + else + begin + if TargetPlatform = tpWIN64 then + begin + Prg.AsmMovREG_REG(_R8, _ECX); + Prg.AsmMovREG_Imm(_EDX, 0); + end + else + Prg.AsmPush_Imm(0); + end; + end + else + begin + if TargetPlatform = tpWIN64 then + begin + Prg.AsmMovREG_REG(_R8, _ECX); + Prg.AsmMovREG_Imm(_EDX, 0); + end + else + Prg.AsmPush_Imm(0); + end; + end; + + {$IFDEF TRIAL} + Inc(_Counter); + {$ENDIF} + + Reg := GetReg(_EBX); + + if SymbolRec1.RunnerParameter then + begin + Prg.AsmMovREG_REG(Reg, _ESI); + Prg.AsmAddREG_Imm(Reg, H_SelfPtr); + Prg.AsmMovREG_REGPtr(Reg, Reg); // load TProgram.Self + Prg.AsmAddREG_Imm(Reg, RUNNER_OWNER_OFFSET); + Prg.AsmMovREG_REGPtr(_EDI, Reg); + end; + + if Host1 and (SymbolRec1.PushProgRequired) then + begin + Prg.AsmMovREG_REG(Reg, _ESI); + Prg.AsmAddREG_Imm(Reg, H_SelfPtr); + Prg.AsmMovREG_REGPtr(Reg, Reg); // load TProgram.Self + if TargetPlatform = tpWIN64 then + Prg.AsmMovREG_REG(_ECX, Reg) // push TProgram.Self + else + Prg.AsmPush_REG(Reg); // push TProgram.Self + end; + + if GetSymbolRec(TrueSubId).ExtraParamNeeded and (cc <> ccSAFECALL) then + begin + if GetSymbolRec(TrueSubId).CallConv = ccREGISTER then + begin + K := 0; + if (GetSymbolRec(TrueSubId).IsMethod or + (GetSymbolRec(TrueSubId-1).FinalTypeId = typeEVENT) and (GetSymbolRec(TrueSubId-1).PatternId = TrueSubId)) and + (GetSymbolRec(TrueSubId).CallMode <> cmSTATIC) then + Inc(K); + + for I:= 0 to R.Arg2 - 1 do + begin + ParamId := SymbolTable.GetParamId(TrueSubId, I); + if GetSymbolRec(ParamId).Register > 0 then + begin + Inc(K); + if GetSymbolRec(ParamId).FinalTypeId in [typeDYNARRAY, typeOPENARRAY] then + if GetSymbolRec(ParamId).IsOpenArray then + Inc(K); + end; + end; + + case K of + 0: + begin + GetReg(_EAX); + EmitLoadAddress(_EAX, SymbolRecR); + FreeReg(_EAX); + end; + 1: + begin + GetReg(_EDX); + EmitLoadAddress(_EDX, SymbolRecR); + FreeReg(_EDX); + end; + 2: + begin + GetReg(_ECX); + EmitLoadAddress(_ECX, SymbolRecR); + FreeReg(_ECX); + end; + else + begin + EmitLoadAddress(Reg, SymbolRecR); + Prg.AsmPush_REG(Reg); + end; + end; + end //ccREGISTER + else if GetSymbolRec(TrueSubId).CallConv = cc64 then + begin + K := 0; + if (GetSymbolRec(TrueSubId).IsMethod or + (GetSymbolRec(TrueSubId-1).FinalTypeId = typeEVENT) and (GetSymbolRec(TrueSubId-1).PatternId = TrueSubId)) and + (GetSymbolRec(TrueSubId).CallMode <> cmSTATIC) then + Inc(K); + + if GetSymbolRec(TrueSubId).IsNestedSub then + K := 1; + + if (GetSymbolRec(TrueSubId).Level = H_TObject) then + if (GetSymbolRec(TrueSubId).Name = 'ClassName') then + K := 0; + + if GetSymbolRec(TrueSubId).IsFakeMethod then + K := 0; + + case K of + 0: + begin + GetReg(_ECX); + EmitLoadAddress(_ECX, SymbolRecR); + FreeReg(_ECX); + end; + 1: + begin + GetReg(_EDX); + EmitLoadAddress(_EDX, SymbolRecR); + FreeReg(_EDX); + end; + else + begin + RaiseError(errInternalError, []); + end; + end; + end //cc64 + else + begin + + if (GetSymbolRec(TrueSubId).CallConv = ccPASCAL) and + (GetSymbolRec(TrueSubId).IsMethod) then + begin + GetReg(_EDX); + Prg.AsmPop_REG(_EDX); + FreeReg(_EDX); + end; + + EmitLoadAddress(Reg, SymbolRecR); + Prg.AsmPush_REG(Reg); + + if (GetSymbolRec(TrueSubId).CallConv = ccPASCAL) and + (GetSymbolRec(TrueSubId).IsMethod) then + begin + GetReg(_EDX); + Prg.AsmPush_REG(_EDX); + FreeReg(_EDX); + end; + + end; + end; // extra param needed + + if Host1 then + begin + if (SymbolRec1.MethodIndex > 0) and (GetSymbolRec(SymbolRec1.Level).FinalTypeId = typeINTERFACE) then + EmitInterfaceAddress(SymbolRec1.MethodIndex) + else + EmitGet_REG(Reg, SymbolRec1); + end + else + begin + if (SymbolRec1.MethodIndex > 0) and (not DiscardVirtualCall) then + EmitInterfaceAddress(SymbolRec1.MethodIndex) + else if SymbolRec1.Kind = kindVAR then + EmitLoadIntVal(Reg, SymbolRec1) + else + begin + Prg.AsmMovREG_REG(Reg, _EDI); + Prg.AsmAddREG_Imm(Reg, 0); + Prg.Top.SaveSubId := R.Arg1; + List2.Add(Prg.Top); + end; + end; + + if SymbolRec1.Kind = KindVAR then + if SymbolRec1.Host then + if SymbolRec1.FinalTypeId = typeEVENT then + begin + Prg.AsmMovREG_REGPtr(Reg, Reg); + end; + + if GetSymbolRec(TrueSubId).IsNestedSub then + begin + if ContextStack.Count >= 2 then + begin + if TargetPlatform = tpWin64 then + EmitRestoreEBP(_ECX, GetSymbolRec(TrueSubId)) + else + EmitRestoreEBP(_EAX, GetSymbolRec(TrueSubId)); + end + else + begin + if TargetPlatform = tpWin64 then + Prg.AsmMovREG_REG(_ECX, _EBP) + else + Prg.AsmMovREG_REG(_EAX, _EBP); + end; + end; + + if TargetPlatform in [tpOSX32, tpIOSSim] then + begin + EmitSaveRDI; + Prg.AsmMovREG_REG(_EDI, Reg); + EmitRestoreRBX; + Prg.AsmCall_REG(_EDI); + EmitRestoreRDI; + end + else + Prg.AsmCall_REG(Reg); + + EmitCallEpi(TrueSubId); + + if not (TargetPlatform in [tpOSX32, tpIOSSim]) then + begin + if SymbolRec1.Kind = KindVAR then + begin + T := SymbolRec1.TerminalTypeId; + K := GetSymbolRec(T).PatternId; + if GetSymbolRec(K).CallConv = ccCDECL then + Prg.AsmAddREG_Imm(_ESP, SymbolTable.GetSizeOfParams(K)); + end + else + begin + if SymbolRec1.CallConv = ccCDECL then + Prg.AsmAddREG_Imm(_ESP, SymbolTable.GetSizeOfParams(R.Arg1)); + end; + end; + + if not SymbolRec1.IsNestedSub then + begin + RestoreRegisters([_ESI, _EDI], 4 * SizeOfPointer); + end; + + if R.Res <> 0 then if cc <> ccSAFECALL then + begin + case GetSymbolRec(TrueSubId).FinalTypeId of + typeVOID: + begin + // ok + end; + typeBOOLEAN, typeBYTEBOOL, typeWORDBOOL, typeLONGBOOL, +{$IFNDEF PAXARM} + typeANSICHAR, +{$ENDIF} + typeWIDECHAR, typeENUM, typePOINTER, + typeINTEGER, typeBYTE, typeWORD, typeSMALLINT, typeSHORTINT, + typeCARDINAL, typeCLASS, typeCLASSREF: + begin + if SymbolRec1.CallConv = ccSAFECALL then + begin + RR := FindBeginCall; + if RR = nil then + RaiseError(errInternalError, []); + EmitLoadIntVal(_EAX, GetSymbolRec(RR.Res)); + end; + + EmitPut_REG(_EAX, SymbolRecR); + end; + typeINT64, typeUINT64: + begin + GetReg(_ECX); + GetReg(_EDX); + EmitLoadAddress(_ECX, SymbolRecR); + Prg.AsmMovREGPtr_REG32(_ECX, _EAX); + Prg.AsmAddREG_Imm(_ECX, 4); + Prg.AsmMovREGPtr_REG32(_ECX, _EDX); + FreeReg(_ECX); + FreeReg(_EDX); + end; +{$IFNDEF PAXARM} + typeANSISTRING: + begin + {$IFDEF FPC} +{ + GetReg(_EAX); + + Prg.AsmPush_REG(_EAX); // save result of function + + EmitLoadAddress(_EAX, SymbolRecR); // load address into EAX + SubId := Id_DecStringCounter; +// SubId := Id_IncStringCounter; + EmitGet_REG(_EBX, TKernel(kernel).SymbolTable[SubId]); + Prg.AsmCall_REG(_EBX); + + EmitLoadAddress(_EAX, SymbolRecR); // load address into EAX + + Prg.AsmPop_REG(_EBX); + Prg.AsmMovREGPtr_REG(_EAX, _EBX); + + FreeReg(_EAX); +} + {$ELSE} + // ok + {$ENDIF} + end; + typeSHORTSTRING: + begin + // ok + end; + typeWIDESTRING: + begin + // ok + end; +{$ENDIF} + typeUNICSTRING: + begin + // ok + end; + typeINTERFACE: + begin + // ok + end; + typeVARIANT, typeOLEVARIANT: + begin + // ok + end; + typeRECORD: + begin + if GetSymbolRec(TrueSubId).CallConv = ccMSFASTCALL then + begin + T := GetSymbolRec(TrueSubId).TerminalTypeId; + if GetSymbolRec(T).Size <= 4 then + begin + EmitPut_REG(_EAX, SymbolRecR); + end + else if GetSymbolRec(T).Size <= 8 then + begin + GetReg(_ECX); + GetReg(_EDX); + EmitLoadAddress(_ECX, SymbolRecR); + Prg.AsmMovREGPtr_REG32(_ECX, _EAX); + Prg.AsmAddREG_Imm(_ECX, 4); + Prg.AsmMovREGPtr_REG32(_ECX, _EDX); + FreeReg(_ECX); + FreeReg(_EDX); + end; + end + else + begin + T := GetSymbolRec(TrueSubId).TerminalTypeId; + if GetSymbolRec(T).Size <= SizeOf(Pointer) then + begin + EmitPut_REG(_EAX, SymbolRecR); + end + end; + end; + typeARRAY: + begin + T := GetSymbolRec(TrueSubId).TerminalTypeId; + if GetSymbolRec(T).Size <= SizeOf(Pointer) then + begin + EmitPut_REG(_EAX, SymbolRecR); + end + end; + typeDYNARRAY: + begin + // ok + end; + typeSET: + begin + if not GetSymbolRec(TrueSubId).ExtraParamNeeded then + EmitPut_REG(_EAX, SymbolRecR); + + // else - ok + end; + typeDOUBLE: + begin + EmitLoadAddress(Reg, SymbolRecR); + if TargetPlatform = tpWIN64 then + Prg.AsmMovsdRegPtr_XMM(_XMM0, Reg) + else + Prg.AsmFStpDouble_REGPtr(Reg); + end; + typeSINGLE: + begin + EmitLoadAddress(Reg, SymbolRecR); + if TargetPlatform = tpWIN64 then + Prg.AsmMovsdRegPtr_XMM(_XMM0, Reg) + else + Prg.AsmFStpSingle_REGPtr(Reg); + end; + typeEXTENDED: + begin + EmitLoadAddress(Reg, SymbolRecR); + if TargetPlatform = tpWIN64 then + Prg.AsmMovsdRegPtr_XMM(_XMM0, Reg) + else + Prg.AsmFStpExtended_REGPtr(Reg); + end; + typeCURRENCY: + begin + EmitLoadAddress(Reg, SymbolRecR); + EmitFistp(SymbolRecR); + end; + typeEVENT: + begin + // ok + end; + else + RaiseError(errInternalError, []); + end; + end; + + FreeReg(Reg); + + if TrueSubId = Id_TObject_Free then + begin + I := Code[Code.N - 1].Arg1; + Reg := EmitGetAddressRegister(SymbolTable[I]); + Prg.AsmMovREGPtr_Imm(Reg, SymbolTable[I], 0); + FreeReg(Reg); + end; + + if HandlesEvents then + begin + Reg := GetRegEx; + + Prg.AsmMovREG_REG(Reg, _ESI); + Prg.AsmAddREG_Imm(Reg, H_SelfPtr); + Prg.AsmMovREG_REGPtr(Reg, Reg); // load TProgram.Self + if TargetPlatform = tpWIN64 then + Prg.AsmMovREG_REG(_ECX, Reg) + else + Prg.AsmPush_REG(Reg); // push TProgram.Self + + EmitGet_REG(Reg, SymbolTable[Id_CondHalt]); + Prg.AsmCall_REG(Reg); + + FreeReg(Reg); + end; +end; + +procedure TEmitter.EmitOP_INIT_SUB_64; +begin + EmitOP_INIT_SUB; +end; +procedure TEmitter.EmitOP_INIT_SUB; +var + SubId, I, J, T, TypeID, Reg, RegEx, S, ParamId, ParamCount, SZ, FT, SubId2: Integer; + L, TypeList, ProtectedShits: TIntegerList; + HighParamId: Integer; +begin + EmitPCodeOperator; + + ProtectedShits := TIntegerList.Create; + + try + + SubId := R.Arg1; + ParamCount := GetSymbolRec(SubId).Count; + + EmitStartSub(SubId); + + for I:=0 to ParamCount - 1 do + begin + ParamId := SymbolTable.GetParamId(SubId, I); + if GetSymbolRec(ParamId).Register > 0 then + ProtectedShits.Add(GetSymbolRec(ParamId).Shift); + if GetSymbolRec(ParamId).IsOpenArray then + begin + ParamId := SymbolTable.GetOpenArrayHighId(ParamId); + ProtectedShits.Add(GetSymbolRec(ParamId).Shift); + end; + end; + + case TargetPlatform of + tpOSX32, tpIOSSim: + begin + Prg.AsmPush_REG(_EBP); + Prg.AsmPush_REG(_ESI); + Prg.AsmPush_REG(_EDI); + Prg.AsmPush_REG(_EBX); + Prg.AsmMovREG_REG(_EBP, _ESP); + Prg.AsmAddREG_Imm(_ESP, - SymbolTable.GetSizeOfLocalsEx(SubId)); + end; + tpWIN64: + begin + Prg.AsmPush_REG(_EBP); + Prg.AsmPush_REG(_ESI); + Prg.AsmPush_REG(_EDI); + Prg.AsmPush_REG(_EBX); + + Prg.AsmSubREG_Imm(_ESP, SymbolTable.GetSubRSPSize(SubId)); + Prg.AsmMovREG_REG(_EBP, _ESP); + end; + else + begin + Prg.AsmPush_REG(_EBP); + Prg.AsmPush_REG(_ESI); + Prg.AsmPush_REG(_EDI); + Prg.AsmPush_REG(_EBX); + Prg.AsmMovREG_REG(_EBP, _ESP); + Prg.AsmAddREG_Imm(_ESP, - SymbolTable.GetSizeOfLocalsEx(SubId)); + end; + end; + + Prg.EmitZ; + + ContextStack.Push(SubId); + + if GetSymbolRec(SubId).CallConv = cc64 then + begin + if SymbolRec1.IsNestedSub then + begin + ParamId := SymbolTable.GetRBP_Id(SubId); + Prg.AsmPutREG_EBPPtr(_ECX, GetOffset(GetSymbolRec(ParamId))); + end; + + ParamId := SymbolTable.GetSelfId(SubId); + if GetSymbolRec(ParamId).Register > 0 then + Prg.AsmPutREG_EBPPtr(GetSymbolRec(ParamId).Register, GetOffset(GetSymbolRec(ParamId))); + + for I:=0 to GetSymbolRec(SubId).Count - 1 do + begin + ParamId := SymbolTable.GetParamId(SubId, I); + + if GetSymbolRec(ParamId).XMMReg > 0 then + begin + Prg.AsmMovREG_REG(_EBX, _EBP); + Prg.AsmAddREG_Imm(_EBX, GetOffset(GetSymbolRec(ParamId))); + if GetSymbolRec(ParamId).FinalTypeId = typeSINGLE then + Prg.AsmMovssRegPtr_XMM(GetSymbolRec(ParamId).XMMReg, _EBX) + else + Prg.AsmMovsdRegPtr_XMM(GetSymbolRec(ParamId).XMMReg, _EBX); + end + else if GetSymbolRec(ParamId).Register > 0 then + begin + Prg.AsmPutREG_EBPPtr(GetSymbolRec(ParamId).Register, GetOffset(GetSymbolRec(ParamId))); + if GetSymbolRec(ParamId).FinalTypeId = typeOPENARRAY then + begin + Reg := GetSymbolRec(ParamId).Register; + HighParamId := SymbolTable.GetOpenArrayHighId(ParamId); + if Reg > 0 then + begin + if Reg <> _R9 then + begin + if Reg = _ECX then + Reg := _EDX + else if Reg = _EDX then + Reg := _R8 + else if Reg = _R8 then + Reg := _R9; + Prg.AsmPutREG32_EBPPtr(Reg, GetOffset(GetSymbolRec(HighParamId))); + end + else + begin + Prg.AsmGetREG32_EBPPtr(_EBX, 8); + Prg.AsmPutREG32_EBPPtr(_EBX, GetOffset(GetSymbolRec(HighParamId))); + end; + end; + end; + end + else + if GetSymbolRec(ParamId).FinalTypeId = typeOPENARRAY then + begin + HighParamId := SymbolTable.GetOpenArrayHighId(ParamId); + Prg.AsmGetREG32_EBPPtr(_EBX, GetOffset(GetSymbolRec(ParamId)) - 4); + Prg.AsmPutREG32_EBPPtr(_EBX, GetOffset(GetSymbolRec(HighParamId))); + end; + end; + + if GetSymbolRec(SubId).ExtraParamNeeded then + begin + ParamId := SymbolTable.GetResultId(SubId); + RegEx := GetSymbolRec(ParamId).Register; + if RegEx > 0 then + begin + Prg.AsmPutREG_EBPPtr(RegEx, GetOffset(GetSymbolRec(ParamId))); + end + else + begin + RaiseError(errInternalError, []); + end; + end; + end //cc64 + else if GetSymbolRec(SubId).CallConv in [ccREGISTER, ccMSFASTCALL] then + begin + ParamId := SymbolTable.GetSelfId(SubId); + if GetSymbolRec(ParamId).Register > 0 then + Prg.AsmPutREG32_EBPPtr(GetSymbolRec(ParamId).Register, GetOffset(GetSymbolRec(ParamId))); + + for I:=0 to GetSymbolRec(SubId).Count - 1 do + begin + ParamId := SymbolTable.GetParamId(SubId, I); + if GetSymbolRec(ParamId).Register > 0 then + begin + Prg.AsmPutREG32_EBPPtr(GetSymbolRec(ParamId).Register, GetOffset(GetSymbolRec(ParamId))); + if GetSymbolRec(ParamId).FinalTypeId = typeOPENARRAY then + begin + Reg := GetSymbolRec(ParamId).Register; + HighParamId := SymbolTable.GetOpenArrayHighId(ParamId); + if Reg > 0 then + begin + if Reg <> _ECX then + begin + if Reg = _EAX then + Reg := _EDX + else if Reg = _EDX then + Reg := _ECX; + Prg.AsmPutREG32_EBPPtr(Reg, GetOffset(GetSymbolRec(HighParamId))); + end + else + begin + Prg.AsmGetREG32_EBPPtr(_EBX, 8); + Prg.AsmPutREG32_EBPPtr(_EBX, GetOffset(GetSymbolRec(HighParamId))); + end; + end; + end; + end + else + if GetSymbolRec(ParamId).FinalTypeId = typeOPENARRAY then + begin + HighParamId := SymbolTable.GetOpenArrayHighId(ParamId); + Prg.AsmGetREG32_EBPPtr(_EBX, GetOffset(GetSymbolRec(ParamId)) - 4); + Prg.AsmPutREG32_EBPPtr(_EBX, GetOffset(GetSymbolRec(HighParamId))); + end; + end; + + if GetSymbolRec(SubId).ExtraParamNeeded then + begin + ParamId := SymbolTable.GetResultId(SubId); + if GetSymbolRec(ParamId).Register > 0 then + Prg.AsmPutREG32_EBPPtr(GetSymbolRec(ParamId).Register, GetOffset(GetSymbolRec(ParamId))); + end; + end + else if GetSymbolRec(SubId).CallConv in [ccSTDCALL, ccCDECL, ccSAFECALL] then + begin + if SymbolRec1.IsNestedSub then + begin + ParamId := SymbolTable.GetRBP_Id(SubId); + Prg.AsmPutREG_EBPPtr(_EAX, GetSymbolRec(ParamId).Shift); + ProtectedShits.Add(GetSymbolRec(ParamId).Shift); + end; + + for I:=0 to GetSymbolRec(SubId).Count - 1 do + begin + ParamId := SymbolTable.GetParamId(SubId, I); + if GetSymbolRec(ParamId).FinalTypeId = typeOPENARRAY then + begin + HighParamId := SymbolTable.GetOpenArrayHighId(ParamId); + Prg.AsmGetREG32_EBPPtr(_EBX, GetOffset(GetSymbolRec(ParamId)) + 4); + Prg.AsmPutREG32_EBPPtr(_EBX, GetOffset(GetSymbolRec(HighParamId))); + end; + end; + end; + + // init dynamic vars + + for I:=0 to ParamCount - 1 do + begin + ParamId := SymbolTable.GetParamId(SubId, I); + FT := SymbolTable[ParamId].FinalTypeId; + if FT in [typeRECORD, typeARRAY] then + if SymbolTable[I].UnionId = 0 then + if not (SymbolTable[ParamId].ByRef or SymbolTable[ParamId].ByRefEx) then + begin + TypeId := SymbolTable[ParamId].TerminalTypeId; + L := SymbolTable.GetShiftsOfDynamicFields(TypeId); + TypeList := SymbolTable.GetTypesOfDynamicFields(TypeId); + + if TypeList.Count <> L.Count then + RaiseError(errInternalError, []); + + try + + Reg := GetReg; + + for J:=0 to L.Count - 1 do + begin + S := L[J]; + + SubId2 := 0; + case GetSymbolRec(TypeList[J]).FinalTypeId of +{$IFNDEF PAXARM} + typeANSISTRING: SubId2 := Id_StringAddRef; + typeWIDESTRING: SubId2 := Id_WideStringAddRef; +{$ENDIF} + typeUNICSTRING: SubId2 := Id_UnicStringAddRef; + typeVARIANT, typeOLEVARIANT: SubId2 := Id_VariantAddRef; + typeDYNARRAY: SubId2 := Id_DynarrayAddRef; + typeINTERFACE: SubId2 := Id_InterfaceAddRef; + else + RaiseError(errInternalError, []); + end; + + EmitCallPro(SubId2); + + EmitLoadAddress(Reg, SymbolTable[ParamId]); + Prg.AsmAddREG_Imm(Reg, S); + Prg.AsmPush_REG(Reg); + + EmitStdCall(SubId2); + end; + + FreeReg(Reg); + + finally + + FreeAndNil(L); + FreeAndNil(TypeList); + + end; + end; + end; + + for I:=SubId + 1 to SymbolTable.Card do + begin + if SymbolTable[I].Level = SubId then + if SymbolTable[I].Kind = KindVAR then + begin + if SymbolTable[I].UnionId = 0 then + if (not (SymbolTable[I].ByRef or SymbolTable[I].ByRefEx)) then + begin + if SymbolTable[I].Local and (not SymbolTable[I].Param) then + if ProtectedShits.IndexOf(SymbolTable[I].Shift) = -1 then + begin + T := SymbolTable[I].FinalTypeId; + case T of +{$IFNDEF PAXARM} + typeANSISTRING, + typeWIDESTRING, +{$ENDIF} + typeUNICSTRING, + typeDYNARRAY, + typeINTERFACE, + typeCLASS, + typeCLASSREF: + begin + Reg := EmitGetAddressRegister(SymbolTable[I]); + Prg.AsmMovREGPtr_Imm(Reg, SymbolTable[I], 0); + FreeReg(Reg); + end; + typeSET: + begin + T := SymbolTable[I].TerminalTypeId; + Reg := GetReg; + + case SymbolTable.GetSizeOfSetType(T) of + 1, 2, 4: + begin + Prg.AsmMovREG_Imm(Reg, 0); + EmitSaveIntVal(Reg, SymbolTable[I]); + end; + else + begin + SZ := SymbolTable.GetSizeOfSetType(T) div 4; + if SZ = 0 then + SZ := 1; + EmitLoadAddress(Reg, SymbolTable[I]); + for J := 1 to SZ do + begin + Prg.AsmMovREGPtr_Imm(Reg, 0); + if J < SZ then + Prg.AsmAddREG_Imm(Reg, 4); + end; + end; + end; // case + FreeReg(Reg); + end; + typeVARIANT, typeOLEVARIANT: + begin + Reg := GetReg; + EmitLoadAddress(Reg, SymbolTable[I]); + Prg.AsmMovREGPtr_Imm(Reg, 0); + Prg.AsmAddREG_Imm(Reg, 4); + Prg.AsmMovREGPtr_Imm(Reg, 0); + Prg.AsmAddREG_Imm(Reg, 4); + Prg.AsmMovREGPtr_Imm(Reg, 0); + Prg.AsmAddREG_Imm(Reg, 4); + Prg.AsmMovREGPtr_Imm(Reg, 0); + FreeReg(Reg); + end; + typeINTEGER, + typeBYTE, + typeSMALLINT, + typeWORD, + typeSHORTINT, + typeCARDINAL, + typePOINTER: + if TKernel(Kernel).DEBUG_MODE then + begin + Reg := EmitGetAddressRegister(SymbolTable[I]); + Prg.AsmMovREGPtr_Imm(Reg, SymbolTable[I], 0); + FreeReg(Reg); + end; + typeSINGLE: + if TKernel(Kernel).DEBUG_MODE then + begin + Reg := GetReg; + EmitLoadAddress(Reg, SymbolTable[I]); + Prg.AsmMovREGPtr_Imm(Reg, 0); + FreeReg(Reg); + end; + typeDOUBLE, typeCURRENCY, typeINT64, typeUINT64: + if TKernel(Kernel).DEBUG_MODE then + begin + Reg := GetReg; + EmitLoadAddress(Reg, SymbolTable[I]); + Prg.AsmMovREGPtr_Imm(Reg, 0); + Prg.AsmAddREG_Imm(Reg, 4); + Prg.AsmMovREGPtr_Imm(Reg, 0); + FreeReg(Reg); + end; + typeEXTENDED: + if TKernel(Kernel).DEBUG_MODE then + begin + Reg := GetReg; + EmitLoadAddress(Reg, SymbolTable[I]); + Prg.AsmMovREGPtr_Imm(Reg, 0); + Prg.AsmAddREG_Imm(Reg, 4); + Prg.AsmMovREGPtr_Imm(Reg, 0); + Prg.AsmAddREG_Imm(Reg, 4); + Prg.AsmMovREGPtr_Imm(Reg, 0); + FreeReg(Reg); + end; + typeRECORD, typeARRAY: + begin + TypeId := SymbolTable[I].TerminalTypeId; + L := SymbolTable.GetShiftsOfDynamicFields(TypeId); + + Reg := GetReg; + + for J:=0 to L.Count - 1 do + begin + S := L[J]; + EmitLoadAddress(Reg, SymbolTable[I]); + Prg.AsmAddREG_Imm(Reg, S); + Prg.AsmMovREGPtr_Imm(Reg, 0); + end; + + if TypeId = H_TValue then + begin + EmitLoadAddress(Reg, SymbolTable[I]); + Prg.AsmMovREGPtr_Imm(Reg, 0); + Prg.AsmAddREG_Imm(Reg, 4); + Prg.AsmMovREGPtr_Imm(Reg, 0); + Prg.AsmAddREG_Imm(Reg, 4); + Prg.AsmMovREGPtr_Imm(Reg, 0); + Prg.AsmAddREG_Imm(Reg, 4); + Prg.AsmMovREGPtr_Imm(Reg, 0); //16 + + Prg.AsmAddREG_Imm(Reg, 4); + Prg.AsmMovREGPtr_Imm(Reg, 0); + Prg.AsmAddREG_Imm(Reg, 4); + Prg.AsmMovREGPtr_Imm(Reg, 0); // 24 + end; + + FreeReg(Reg); + + FreeAndNil(L); + end; + end; + end; // local + end; + end; + end; + + if TargetPlatform in [tpOSX32, tpIOSSim] then + begin + Prg.EmitGetCallerEIP; + EmitSaveRBX; + end; + + if TKernel(Kernel).DEBUG_MODE then + begin + Prg.AsmComment('***** N ****** ' + IntToStr(TKernel(kernel).Code.N)); +// Prg.AsmMovREGPtr32_Imm(_ESI, H_ByteCodePtr, TKernel(kernel).Code.N); + + Emit_PUSH_REGS_EX; + + EmitCallPro(Id_InitSub); + + if TargetPlatform = tpWin64 then + begin + Prg.AsmMovREG_REG(_ECX, _ESI); + Prg.AsmAddREG_Imm(_ECX, H_SelfPtr); + Prg.AsmMovREG_REGPtr(_ECX, _ECX); // load TProgram.Self + + Prg.AsmMovREG_Imm(_EDX, SubId); + + Prg.AsmMovREG_REG(_R8, _EBP); + end + else + begin + Prg.AsmMovREG_REG(_EAX, _ESI); + Prg.AsmAddREG_Imm(_EAX, H_SelfPtr); + Prg.AsmMovREG_REGPtr(_EAX, _EAX); // load TProgram.Self + + Prg.AsmMovREG_Imm(_EDX, SubId); + Prg.AsmMovREG_REG(_ECX, _EBP); + end; + + EmitStdCall(Id_InitSub); + Emit_POP_REGS_EX; + end; + + finally + FreeAndNil(ProtectedShits); + end; +end; + +procedure TEmitter.EmitOP_END_SUB_64; +begin + EmitPCodeOperator; +end; +procedure TEmitter.EmitOP_END_SUB; +begin + EmitPCodeOperator; +end; + +procedure TEmitter.EmitOP_FIN_SUB_64; +begin + EmitOP_FIN_SUB; +end; +procedure TEmitter.EmitOP_FIN_SUB; +var + TypeID, ResultId, SubId, Reg, + T, I, J, ParamId, ParamCount, FT, SubId2, S, + ArrayTypeId, + ElTypeId, ElFinalTypeId, ElSize: Integer; + ElTypeId2, ElFinalTypeId2, ElSize2: Integer; + + L, TypeList: TIntegerList; +begin + EmitPCodeOperator; + + SubId := R.Arg1; + + I := SymbolTable[SubId].Level; + if I > 0 then + if SymbolTable[I].FinalTypeId = typeINTERFACE then + Exit; + + ParamCount := GetSymbolRec(SubId).Count; + + // clear dynamic fields in parameters + + for I:=0 to ParamCount - 1 do + begin + ParamId := SymbolTable.GetParamId(SubId, I); + FT := SymbolTable[ParamId].FinalTypeId; + if FT in [typeRECORD, typeARRAY] then + if not (SymbolTable[ParamId].ByRef or SymbolTable[ParamId].ByRefEx) then + begin + TypeId := SymbolTable[ParamId].TerminalTypeId; + L := SymbolTable.GetShiftsOfDynamicFields(TypeId); + TypeList := SymbolTable.GetTypesOfDynamicFields(TypeId); + + if TypeList.Count <> L.Count then + RaiseError(errInternalError, []); + + try + + Reg := GetReg; + + for J:=0 to L.Count - 1 do + begin + S := L[J]; + + SubId2 := 0; + case GetSymbolRec(TypeList[J]).FinalTypeId of +{$IFNDEF PAXARM} + typeANSISTRING: SubId2 := Id_AnsiStringClr; + typeWIDESTRING: SubId2 := Id_WideStringClr; +{$ENDIF} + typeUNICSTRING: SubId2 := Id_UnicStringClr; + typeVARIANT, typeOLEVARIANT: SubId2 := Id_VariantClr; + typeDYNARRAY: + begin + SubId2 := Id_DynarrayClr; + + ArrayTypeId := TypeList[J]; + ElTypeId := GetSymbolRec(ArrayTypeId).PatternId; + ElFinalTypeId := GetSymbolRec(ElTypeId).FinalTypeId; + ElSize := SymbolTable[ElTypeId].Size; + + ElTypeId2 := 0; + ElFinalTypeId2 := 0; + ElSize2 := 0; + if ElFinalTypeId = typeDYNARRAY then + begin + ElTypeId2 := GetSymbolRec(ElTypeId).TerminalTypeId; + ElTypeId2 := GetSymbolRec(ElTypeId2).PatternId; + ElFinalTypeId2 := GetSymbolRec(ElTypeId2).FinalTypeId; + ElSize2 := SymbolTable[ElTypeId2].Size; + end; + + Prg.AsmPush_Imm(ElSize2); + Prg.AsmPush_Imm(ElTypeId2); + Prg.AsmPush_Imm(ElFinalTypeId2); + + Prg.AsmPush_Imm(ElSize); + Prg.AsmPush_Imm(ElTypeId); + Prg.AsmPush_Imm(ElFinalTypeId); + + end; + typeINTERFACE: SubId2 := Id_InterfaceClr; + else + RaiseError(errInternalError, []); + end; + + EmitCallPro(SubId2); + + EmitLoadAddress(Reg, SymbolTable[ParamId]); + Prg.AsmAddREG_Imm(Reg, S); + Prg.AsmPush_REG(Reg); + + EmitStdCall(SubId2); + end; + + FreeReg(Reg); + + finally + + FreeAndNil(L); + FreeAndNil(TypeList); + + end; + end; + end; + + + if TKernel(Kernel).DEBUG_MODE then + begin + EmitCallPro(Id_EndSub); + + if TargetPlatform = tpWIN64 then + begin + Prg.AsmMovREG_REG(_ECX, _ESI); + Prg.AsmAddREG_Imm(_ECX, H_SelfPtr); + Prg.AsmMovREG_REGPtr(_ECX, _ECX); // load TProgram.Self + end + else + begin + Prg.AsmMovREG_REG(_EAX, _ESI); + Prg.AsmAddREG_Imm(_EAX, H_SelfPtr); + Prg.AsmMovREG_REGPtr(_EAX, _EAX); // load TProgram.Self + end; + + EmitStdCall(Id_EndSub); + end; + + TypeID := SymbolRec1.FinalTypeID; + ResultId := SymbolTable.GetResultId(SubId); + + if SymbolRec1.Kind = KindCONSTRUCTOR then + begin + ResultId := SymbolTable.GetSelfId(SubId); + EmitGet_REG(_EAX, SymbolTable[ResultId]); + end + else if SymbolRec1.Kind = KindDESTRUCTOR then + begin + // ok + end + else if TypeID in INT64Types then + begin + GetReg(_EAX); + GetReg(_EDX); + GetReg(_ECX); + + EmitLoadAddress(_ECX, SymbolTable[ResultId]); + Prg.AsmMovREG32_REGPtr(_EAX, _ECX); + Prg.AsmAddREG_Imm(_ECX, 4); + Prg.AsmMovREG32_REGPtr(_EDX, _ECX); + + FreeReg(_EAX); + FreeReg(_EDX); + FreeReg(_ECX); + end + else if (TypeID = typeRECORD) and + (SymbolRec1.CallConv = ccMSFASTCALL) then + begin + T := SymbolRec1.TerminalTypeId; + if GetSymbolRec(T).Size <= SizeOf(Pointer) then + begin + EmitGet_REG(_EAX, SymbolTable[ResultId]); + end + else if GetSymbolRec(T).Size <= 8 then + begin + GetReg(_EAX); + GetReg(_EDX); + GetReg(_ECX); + + EmitLoadAddress(_ECX, SymbolTable[ResultId]); + Prg.AsmMovREG32_REGPtr(_EAX, _ECX); + Prg.AsmAddREG_Imm(_ECX, 4); + Prg.AsmMovREG32_REGPtr(_EDX, _ECX); + + FreeReg(_EAX); + FreeReg(_EDX); + FreeReg(_ECX); + end; + end + else if TypeID in (OrdinalTypes + + [ +{$IFNDEF PAXARM} + typeANSISTRING, typeWIDESTRING, +{$ENDIF} + typeUNICSTRING, typeVARIANT, + typeOLEVARIANT, + typePOINTER, typeCLASS, typeCLASSREF, typeDYNARRAY, + typeINTERFACE]) then + begin + EmitGet_REG(_EAX, SymbolTable[ResultId]); + end + else if TypeID = typeSET then + begin + if not SymbolTable[SubId].ExtraParamNeeded then + EmitGet_REG(_EAX, SymbolTable[ResultId]); + end + else if TypeID = typeDOUBLE then + begin + Reg := GetReg; + Prg.AsmMovREG_REG(Reg, _EBP); + Prg.AsmAddREG_Imm(Reg, GetOffset(SymbolTable[ResultId])); + Prg.AsmFldDouble_REGPtr(Reg); + FreeReg(Reg); + end + else if TypeID = typeSINGLE then + begin + Reg := GetReg; + Prg.AsmMovREG_REG(Reg, _EBP); + Prg.AsmAddREG_Imm(Reg, GetOffset(SymbolTable[ResultId])); + Prg.AsmFldSingle_REGPtr(Reg); + FreeReg(Reg); + end + else if TypeID = typeEXTENDED then + begin + Reg := GetReg; + Prg.AsmMovREG_REG(Reg, _EBP); + Prg.AsmAddREG_Imm(Reg, GetOffset(SymbolTable[ResultId])); + Prg.AsmFldExtended_REGPtr(Reg); + FreeReg(Reg); + end + else if TypeID = typeCURRENCY then + begin + Reg := GetReg; + Prg.AsmMovREG_REG(Reg, _EBP); + Prg.AsmAddREG_Imm(Reg, GetOffset(SymbolTable[ResultId])); + Prg.AsmFild_REG64Ptr(Reg); + FreeReg(Reg); + end; + + case TargetPlatform of + tpOSX32, tpIOSSim: + begin + Prg.AsmMovREG_REG(_ESP, _EBP); + Prg.AsmPop_REG(_EBX); + Prg.AsmPop_REG(_EDI); + Prg.AsmPop_REG(_ESI); + Prg.AsmPop_REG(_EBP); + end; + tpWIN64: + begin + // Prg.AsmLeaRSP_RBPPtr(TKernel(kernel).GetSubRSPSize(SubId)); + Prg.AsmAddREG_Imm(_ESP, SymbolTable.GetSubRSPSize(SubId)); + + Prg.AsmPop_REG(_EBX); + Prg.AsmPop_REG(_EDI); + Prg.AsmPop_REG(_ESI); + Prg.AsmPop_REG(_EBP); + end; + else + begin + Prg.AsmMovREG_REG(_ESP, _EBP); + Prg.AsmPop_REG(_EBX); + Prg.AsmPop_REG(_EDI); + Prg.AsmPop_REG(_ESI); + Prg.AsmPop_REG(_EBP); + end; + end; + + if SymbolTable[SubId].CallConv = ccCDECL then + Prg.AsmRet(0) + else + begin + if TargetPlatform = tpWIN64 then + Prg.AsmRet(0) + else + Prg.AsmRet(SymbolTable.GetSizeOfParams(R.Arg1)); + end; + + ContextStack.Pop; + + EmitFinSub(SubId); +end; + +procedure TEmitter.EmitOP_PUSH_EBP_64; +begin + EmitPCodeOperator; + Prg.AsmMovREG_REG(_ECX, _EBP); +end; + +procedure TEmitter.EmitOP_PUSH_EBP; +var + SubId, CurrSubId, Height, CurrHeight, Reg, I, D: Integer; +begin + EmitPCodeOperator; + + if ContextStack.Count >= 2 then + begin + SubId := SymbolRecR.Id; + EmitRestoreEBP(_EAX, GetSymbolRec(SubId)); + end + else + Prg.AsmMovREG_REG(_EAX, _EBP); +end; + +procedure TEmitter.EmitOP_POP_64; +begin + EmitPCodeOperator; +end; +procedure TEmitter.EmitOP_POP; +begin + EmitPCodeOperator; +end; + +procedure TEmitter.EmitOP_SAVE_REGS_64; +begin + EmitPCodeOperator; + Emit_PUSH_REGS; +end; +procedure TEmitter.EmitOP_SAVE_REGS; +begin + EmitPCodeOperator; + Emit_PUSH_REGS; +end; + +procedure TEmitter.EmitOP_RESTORE_REGS_64; +begin + EmitPCodeOperator; + Emit_POP_REGS; +end; +procedure TEmitter.EmitOP_RESTORE_REGS; +begin + EmitPCodeOperator; + Emit_POP_REGS; +end; + +procedure TEmitter.EmitOP_RET_64; +begin + EmitPCodeOperator; + + Prg.AsmRet; +end; +procedure TEmitter.EmitOP_RET; +begin + EmitPCodeOperator; + + Prg.AsmRet; +end; + +procedure TEmitter.EmitOP_FIELD_64; +var + Reg: Integer; + PatternId: Integer; +begin + EmitPCodeOperator; + Reg := GetReg; + EmitLoadAddress(Reg, SymbolRec1); // load address of record + + PatternId := SymbolRec2.PatternId; // find id of pattern field + + if SymbolRec1.FinalTypeId = typeCLASS then + Prg.AsmMovREG_REGPtr(Reg, Reg); + + Prg.AsmAddREG_Imm(Reg, GetOffset(SymbolTable[PatternId])); + + EmitPut_REG(Reg, SymbolRec2); + FreeReg(Reg); +end; +procedure TEmitter.EmitOP_FIELD; +var + Reg: Integer; + PatternId: Integer; +begin + EmitPCodeOperator; + Reg := GetReg; + EmitLoadAddress(Reg, SymbolRec1); // load address of record + + PatternId := SymbolRec2.PatternId; // find id of pattern field + + if SymbolRec1.FinalTypeId = typeCLASS then + Prg.AsmMovREG_REGPtr(Reg, Reg); + + Prg.AsmAddREG_Imm(Reg, GetOffset(SymbolTable[PatternId])); + + EmitPut_REG(Reg, SymbolRec2); + FreeReg(Reg); +end; + +procedure TEmitter.EmitOP_GET_COMPONENT_64; +var + Reg: Integer; + SubId: Integer; +begin + EmitPCodeOperator; + + SubId := Id_GetComponent; + EmitCallPro(SubId); + + Reg := GetRegEx; + + EmitLoadIntVal(Reg, SymbolRec1); // the first parameter + Prg.AsmMovREG_REG(_ECX, Reg); + + Prg.AsmMovREG_Imm(_EDX, R.Arg2); // the second parameter + + EmitLoadAddress(Reg, SymbolRecR); // the third parameter + Prg.AsmMovREG_REG(_R8, Reg); + + FreeReg(Reg); + + EmitStdCall(SubId); +end; + +procedure TEmitter.EmitOP_GET_COMPONENT; +var + Reg: Integer; + SubId: Integer; +begin + EmitPCodeOperator; + + SubId := Id_GetComponent; + EmitCallPro(SubId); + + Reg := GetReg; + + EmitLoadAddress(Reg, SymbolRecR); // the third parameter + Prg.AsmPush_REG(Reg); + + Prg.AsmPush_Imm(R.Arg2); // the second parameter + + EmitLoadIntVal(Reg, SymbolRec1); // the first parameter + Prg.AsmPush_REG(Reg); + + FreeReg(Reg); + + EmitStdCall(SubId); +end; + +procedure TEmitter.EmitOP_ELEM_64; +begin + EmitOP_ELEM; +end; +procedure TEmitter.EmitOP_ELEM; + + function LeftPartOfAssignment: Boolean; + var + I, N, Res, Op: Integer; + Code: TCode; + begin + result := false; + Code := TKernel(kernel).Code; + N := Code.N; + Res := Code[N].Res; + I := N; + repeat + Inc(I); + if I > Code.Card then + Exit; + Op := Code[I].GenOp; + if Op = OP_STMT then + Exit; + if Op = OP_ASSIGN then + if Code[I].Arg1 = Res then + begin + result := true; + Exit; + end; + until false; + end; + +var + Reg, RegIndex: Integer; + ArrayTypeId, RangeTypeId, ElemTypeId, H1, ElSize: Integer; + IsFWArray: Boolean; +begin + EmitPCodeOperator; + + ElemTypeId := SymbolRec2.FinalTypeId; + if not (ElemTypeId in OrdinalTypes + INT64Types) then + TKernel(kernel).CreateError(errIncompatibleTypesNoArgs, []); +{$IFNDEF PAXARM} + if SymbolRec1.HasPAnsiCharType then // pchar + begin + RegIndex := GetReg; + Reg := GetReg; + + if SymbolRec2.Kind = KindCONST then + Prg.AsmMovReg_Imm(RegIndex, SymbolRec2.Value) + else + EmitLoadIntVal(RegIndex, SymbolRec2); // RegIndex := + + EmitLoadAddress(Reg, SymbolRec1); // Reg :=
+ Prg.AsmMovREG_REGPtr(Reg, Reg); + Prg.AsmAddREG_REG(Reg, RegIndex); // Reg := Reg + RegIndex + EmitPut_REG(Reg, SymbolTable[R.Res]); // save address + + FreeReg(Reg); + FreeReg(RegIndex); + end + else +{$ENDIF} + if SymbolRec1.HasPWideCharType then // pchar + begin + RegIndex := GetReg; + Reg := GetReg; + + if SymbolRec2.Kind = KindCONST then + Prg.AsmMovReg_Imm(RegIndex, SymbolRec2.Value) + else + EmitLoadIntVal(RegIndex, SymbolRec2); // RegIndex := + + EmitLoadAddress(Reg, SymbolRec1); // Reg :=
+ Prg.AsmMovREG_REGPtr(Reg, Reg); + Prg.AsmAddREG_REG(Reg, RegIndex); // Reg := Reg + RegIndex + Prg.AsmAddREG_REG(Reg, RegIndex); // Reg := Reg + RegIndex + EmitPut_REG(Reg, SymbolTable[R.Res]); // save address + + FreeReg(Reg); + FreeReg(RegIndex); + end +{$IFNDEF PAXARM} + else if SymbolRec1.FinalTypeId = typeANSISTRING then + begin + if LeftPartOfAssignment then + begin + + SaveRegisters([_ESI, _EDI]); + + EmitCallPro(Id_UniqueAnsiString); + + Reg := GetReg; + EmitLoadAddress(Reg, SymbolRec1); // Reg :=
+ Prg.AsmPush_REG(Reg); + + FreeReg(Reg); + + EmitStdCall(Id_UniqueAnsiString); + + RestoreRegisters([_ESI, _EDI]); + end; + + RegIndex := GetReg; + Reg := GetReg; + + if SymbolRec2.Kind = KindCONST then + begin + Prg.AsmMovReg_Imm(RegIndex, SymbolRec2.Value - 1); + end + else + begin + EmitLoadIntVal(RegIndex, SymbolRec2); // RegIndex := + Prg.AsmAddReg_Imm(RegIndex, -1); + end; + + EmitLoadAddress(Reg, SymbolRec1); // Reg :=
+ Prg.AsmMovREG_REGPtr(Reg, Reg); + Prg.AsmAddREG_REG(Reg, RegIndex); // Reg := Reg + RegIndex + EmitPut_REG(Reg, SymbolTable[R.Res]); // save address + + FreeReg(Reg); + FreeReg(RegIndex); + end +{$ENDIF} + else if SymbolRec1.FinalTypeId in [{$IFNDEF PAXARM}typeWIDESTRING,{$ENDIF} typeUNICSTRING] then + begin + if SymbolRec1.FinalTypeId = typeUNICSTRING then + if LeftPartOfAssignment then + begin + SaveRegisters([_ESI, _EDI]); + + Reg := GetReg; + + EmitCallPro(Id_UniqueUnicString); + + EmitLoadAddress(Reg, SymbolRec1); // Reg :=
+ Prg.AsmPush_REG(Reg); + + FreeReg(Reg); + + EmitStdCall(Id_UniqueUnicString); + + RestoreRegisters([_ESI, _EDI]); + end; + + RegIndex := GetReg; + Reg := GetReg; + + if SymbolRec2.Kind = KindCONST then + begin + Prg.AsmMovReg_Imm(RegIndex, (SymbolRec2.Value - 1) * SizeOf(WideChar)); + end + else + begin + EmitLoadIntVal(RegIndex, SymbolRec2); // RegIndex := + Prg.AsmAddReg_Imm(RegIndex, -1); + Prg.AsmAddREG_REG(RegIndex, RegIndex); + end; + + EmitLoadAddress(Reg, SymbolRec1); // Reg :=
+ Prg.AsmMovREG_REGPtr(Reg, Reg); + Prg.AsmAddREG_REG(Reg, RegIndex); // Reg := Reg + RegIndex + EmitPut_REG(Reg, SymbolTable[R.Res]); // save address + + FreeReg(Reg); + FreeReg(RegIndex); + end +{$IFNDEF PAXARM} + else if SymbolRec1.FinalTypeId = typeSHORTSTRING then + begin + RegIndex := GetReg; + Reg := GetReg; + + EmitLoadIntVal(RegIndex, SymbolRec2); // RegIndex := + EmitLoadAddress(Reg, SymbolRec1); // Reg :=
+ Prg.AsmAddREG_REG(Reg, RegIndex); // Reg := Reg + RegIndex + EmitPut_REG(Reg, SymbolTable[R.Res]); // save address + + FreeReg(Reg); + FreeReg(RegIndex); + end +{$ENDIF} + else if (SymbolRec1.FinalTypeId = typeDYNARRAY) or // dynamic array + (SymbolRec1.FinalTypeId = typeOPENARRAY) or + (SymbolRec1.IsFWArrayVar) then + begin + IsFWArray := SymbolRec1.IsFWArrayVar; + + ArrayTypeId := SymbolRec1.TerminalTypeId; + ElemTypeId := GetSymbolRec(ArrayTypeId).PatternId; + + if IsFWArray then + ElemTypeId := GetSymbolRec(ElemTypeId).PatternId; + + ElSize := SymbolTable[ElemTypeId].Size; + + // emit + + RegIndex := _EAX; + GetReg(RegIndex); + Reg := GetReg; + + EmitLoadIntVal(RegIndex, SymbolRec2); // RegIndex := + Prg.AsmMovREG_Imm(Reg, ElSize); // Reg := + Prg.AsmMulREG(Reg); // RegIndex := RegIndex * Reg + + EmitLoadAddress(Reg, SymbolRec1); // Reg :=
+ + if IsFWArray then + begin + Prg.AsmMovREG_REGPtr(Reg, Reg); + Prg.AsmAddReg_Imm(Reg, FWArrayOffset); + end; + + Prg.AsmMovREG_REGPtr(Reg, Reg); + Prg.AsmAddREG_REG(Reg, RegIndex); // Reg := Reg + RegIndex + EmitPut_REG(Reg, SymbolTable[R.Res]); // save address + + FreeReg(Reg); + FreeReg(RegIndex); + end + else // static array + begin + ArrayTypeId := SymbolRec1.TerminalTypeId; + SymbolTable.GetArrayTypeInfo(ArrayTypeId, RangeTypeId, ElemTypeId); + H1 := SymbolTable.GetLowBoundRec(RangeTypeId).Value; + ElSize := SymbolTable[ElemTypeId].Size; + + // emit + + RegIndex := _EAX; + GetReg(RegIndex); + Reg := GetReg; + + EmitLoadIntVal(RegIndex, SymbolRec2); // RegIndex := + Prg.AsmAddREG_Imm(RegIndex, - H1); // RegIndex := RegIndex - H1 + Prg.AsmMovREG_Imm(Reg, ElSize); // Reg := + Prg.AsmMulREG(Reg); // RegIndex := RegIndex * Reg + + EmitLoadAddress(Reg, SymbolRec1); // Reg :=
+ Prg.AsmAddREG_REG(Reg, RegIndex); // Reg := Reg + RegIndex + EmitPut_REG(Reg, SymbolTable[R.Res]); // save address + + FreeReg(Reg); + FreeReg(RegIndex); + end; +end; + +procedure TEmitter.EmitOP_INT_TO_INT64_64; +begin + EmitPCodeOperator; + + GetReg(_ECX); + EmitLoadAddress(_ECX, SymbolRecR); + + GetReg(_EAX); + GetReg(_EDX); + + EmitLoadIntVal(_EAX, SymbolRec1); + Prg.AsmCDQ; + Prg.AsmMovREGPtr_REG32(_ECX, _EAX); + Prg.AsmAddREG_Imm(_ECX, 4); + Prg.AsmMovREGPtr_REG32(_ECX, _EDX); + + FreeReg(_EAX); + FreeReg(_EDX); + FreeReg(_ECX); +end; +procedure TEmitter.EmitOP_INT_TO_INT64; +begin + EmitPCodeOperator; + + GetReg(_ECX); + EmitLoadAddress(_ECX, SymbolRecR); + + GetReg(_EAX); + GetReg(_EDX); + + EmitLoadIntVal(_EAX, SymbolRec1); + Prg.AsmCDQ; + Prg.AsmMovREGPtr_REG32(_ECX, _EAX); + Prg.AsmAddREG_Imm(_ECX, 4); + Prg.AsmMovREGPtr_REG32(_ECX, _EDX); + + FreeReg(_EAX); + FreeReg(_EDX); + FreeReg(_ECX); +end; + +procedure TEmitter.EmitOP_BYTE_TO_INT64_64; +begin + EmitPCodeOperator; + + GetReg(_ECX); + EmitLoadAddress(_ECX, SymbolRecR); + + GetReg(_EAX); + GetReg(_EDX); + + EmitLoadIntVal(_EAX, SymbolRec1); + Prg.AsmXorREG_REG(_EDX, _EDX); + Prg.AsmMovREGPtr_REG32(_ECX, _EAX); + Prg.AsmAddREG_Imm(_ECX, 4); + Prg.AsmMovREGPtr_REG32(_ECX, _EDX); + + FreeReg(_EAX); + FreeReg(_EDX); + FreeReg(_ECX); +end; +procedure TEmitter.EmitOP_BYTE_TO_INT64; +begin + EmitPCodeOperator; + + GetReg(_ECX); + EmitLoadAddress(_ECX, SymbolRecR); + + GetReg(_EAX); + GetReg(_EDX); + + EmitLoadIntVal(_EAX, SymbolRec1); + Prg.AsmXorREG_REG(_EDX, _EDX); + Prg.AsmMovREGPtr_REG32(_ECX, _EAX); + Prg.AsmAddREG_Imm(_ECX, 4); + Prg.AsmMovREGPtr_REG32(_ECX, _EDX); + + FreeReg(_EAX); + FreeReg(_EDX); + FreeReg(_ECX); +end; + +procedure TEmitter.EmitOP_WORD_TO_INT64_64; +begin + EmitPCodeOperator; + + GetReg(_ECX); + EmitLoadAddress(_ECX, SymbolRecR); + + GetReg(_EAX); + GetReg(_EDX); + + EmitLoadIntVal(_EAX, SymbolRec1); + Prg.AsmXorREG_REG(_EDX, _EDX); + Prg.AsmMovREGPtr_REG32(_ECX, _EAX); + Prg.AsmAddREG_Imm(_ECX, 4); + Prg.AsmMovREGPtr_REG32(_ECX, _EDX); + + FreeReg(_EAX); + FreeReg(_EDX); + FreeReg(_ECX); +end; +procedure TEmitter.EmitOP_WORD_TO_INT64; +begin + EmitPCodeOperator; + + GetReg(_ECX); + EmitLoadAddress(_ECX, SymbolRecR); + + GetReg(_EAX); + GetReg(_EDX); + + EmitLoadIntVal(_EAX, SymbolRec1); + Prg.AsmXorREG_REG(_EDX, _EDX); + Prg.AsmMovREGPtr_REG32(_ECX, _EAX); + Prg.AsmAddREG_Imm(_ECX, 4); + Prg.AsmMovREGPtr_REG32(_ECX, _EDX); + + FreeReg(_EAX); + FreeReg(_EDX); + FreeReg(_ECX); +end; + +procedure TEmitter.EmitOP_CARDINAL_TO_INT64_64; +begin + EmitPCodeOperator; + + GetReg(_ECX); + EmitLoadAddress(_ECX, SymbolRecR); + + GetReg(_EAX); + GetReg(_EDX); + + EmitLoadIntVal(_EAX, SymbolRec1); + Prg.AsmXorREG_REG(_EDX, _EDX); + Prg.AsmMovREGPtr_REG32(_ECX, _EAX); + Prg.AsmAddREG_Imm(_ECX, 4); + Prg.AsmMovREGPtr_REG32(_ECX, _EDX); + + FreeReg(_EAX); + FreeReg(_EDX); + FreeReg(_ECX); +end; +procedure TEmitter.EmitOP_CARDINAL_TO_INT64; +begin + EmitPCodeOperator; + + GetReg(_ECX); + EmitLoadAddress(_ECX, SymbolRecR); + + GetReg(_EAX); + GetReg(_EDX); + + EmitLoadIntVal(_EAX, SymbolRec1); + Prg.AsmXorREG_REG(_EDX, _EDX); + Prg.AsmMovREGPtr_REG32(_ECX, _EAX); + Prg.AsmAddREG_Imm(_ECX, 4); + Prg.AsmMovREGPtr_REG32(_ECX, _EDX); + + FreeReg(_EAX); + FreeReg(_EDX); + FreeReg(_ECX); +end; + +procedure TEmitter.EmitOP_SMALLINT_TO_INT64_64; +begin + EmitPCodeOperator; + + GetReg(_ECX); + EmitLoadAddress(_ECX, SymbolRecR); + + GetReg(_EAX); + GetReg(_EDX); + + EmitLoadIntVal(_EAX, SymbolRec1); + Prg.AsmXorREG_REG(_EDX, _EDX); + Prg.AsmMovREGPtr_REG32(_ECX, _EAX); + Prg.AsmAddREG_Imm(_ECX, 4); + Prg.AsmMovREGPtr_REG32(_ECX, _EDX); + + FreeReg(_EAX); + FreeReg(_EDX); + FreeReg(_ECX); +end; +procedure TEmitter.EmitOP_SMALLINT_TO_INT64; +begin + EmitPCodeOperator; + + GetReg(_ECX); + EmitLoadAddress(_ECX, SymbolRecR); + + GetReg(_EAX); + GetReg(_EDX); + + EmitLoadIntVal(_EAX, SymbolRec1); + Prg.AsmXorREG_REG(_EDX, _EDX); + Prg.AsmMovREGPtr_REG32(_ECX, _EAX); + Prg.AsmAddREG_Imm(_ECX, 4); + Prg.AsmMovREGPtr_REG32(_ECX, _EDX); + + FreeReg(_EAX); + FreeReg(_EDX); + FreeReg(_ECX); +end; + +procedure TEmitter.EmitOP_SHORTINT_TO_INT64_64; +begin + EmitPCodeOperator; + + GetReg(_ECX); + EmitLoadAddress(_ECX, SymbolRecR); + + GetReg(_EAX); + GetReg(_EDX); + + EmitLoadIntVal(_EAX, SymbolRec1); + Prg.AsmXorREG_REG(_EDX, _EDX); + Prg.AsmMovREGPtr_REG32(_ECX, _EAX); + Prg.AsmAddREG_Imm(_ECX, 4); + Prg.AsmMovREGPtr_REG32(_ECX, _EDX); + + FreeReg(_EAX); + FreeReg(_EDX); + FreeReg(_ECX); +end; +procedure TEmitter.EmitOP_SHORTINT_TO_INT64; +begin + EmitPCodeOperator; + + GetReg(_ECX); + EmitLoadAddress(_ECX, SymbolRecR); + + GetReg(_EAX); + GetReg(_EDX); + + EmitLoadIntVal(_EAX, SymbolRec1); + Prg.AsmXorREG_REG(_EDX, _EDX); + Prg.AsmMovREGPtr_REG32(_ECX, _EAX); + Prg.AsmAddREG_Imm(_ECX, 4); + Prg.AsmMovREGPtr_REG32(_ECX, _EDX); + + FreeReg(_EAX); + FreeReg(_EDX); + FreeReg(_ECX); +end; + +procedure TEmitter.EmitOP_INT_TO_DOUBLE_64; +var + Reg: Integer; +begin + EmitPCodeOperator; + + EmitFild(SymbolRec1); + + Reg := GetReg; + EmitLoadAddress(Reg, SymbolRecR); + Prg.AsmFstpDouble_REGPtr(Reg); + FreeReg(Reg); +end; +procedure TEmitter.EmitOP_INT_TO_DOUBLE; +var + Reg: Integer; +begin + EmitPCodeOperator; + + EmitFild(SymbolRec1); + + Reg := GetReg; + EmitLoadAddress(Reg, SymbolRecR); + Prg.AsmFstpDouble_REGPtr(Reg); + FreeReg(Reg); +end; + +procedure TEmitter.EmitOP_INT64_TO_DOUBLE_64; +var + Reg: Integer; +begin + EmitPCodeOperator; + + Reg := GetReg; + + EmitLoadAddress(Reg, SymbolRec1); + Prg.AsmFild_REG64Ptr(Reg); + + EmitLoadAddress(Reg, SymbolRecR); + Prg.AsmFstpDouble_REGPtr(Reg); + + FreeReg(Reg); +end; +procedure TEmitter.EmitOP_INT64_TO_DOUBLE; +var + Reg: Integer; +begin + EmitPCodeOperator; + + Reg := GetReg; + + EmitLoadAddress(Reg, SymbolRec1); + Prg.AsmFild_REG64Ptr(Reg); + + EmitLoadAddress(Reg, SymbolRecR); + Prg.AsmFstpDouble_REGPtr(Reg); + + FreeReg(Reg); +end; + +procedure TEmitter.EmitOP_INT_TO_SINGLE_64; +var + Reg: Integer; +begin + EmitPCodeOperator; + + EmitFild(SymbolRec1); + + Reg := GetReg; + EmitLoadAddress(Reg, SymbolRecR); + Prg.AsmFstpSingle_REGPtr(Reg); + FreeReg(Reg); +end; +procedure TEmitter.EmitOP_INT_TO_SINGLE; +var + Reg: Integer; +begin + EmitPCodeOperator; + + EmitFild(SymbolRec1); + + Reg := GetReg; + EmitLoadAddress(Reg, SymbolRecR); + Prg.AsmFstpSingle_REGPtr(Reg); + FreeReg(Reg); +end; + +procedure TEmitter.EmitOP_INT64_TO_SINGLE_64; +var + Reg: Integer; +begin + EmitPCodeOperator; + Reg := GetReg; + EmitLoadAddress(Reg, SymbolRec1); + Prg.AsmFild_REG64Ptr(Reg); + EmitLoadAddress(Reg, SymbolRecR); + Prg.AsmFstpSingle_REGPtr(Reg); + FreeReg(Reg); +end; +procedure TEmitter.EmitOP_INT64_TO_SINGLE; +var + Reg: Integer; +begin + EmitPCodeOperator; + Reg := GetReg; + EmitLoadAddress(Reg, SymbolRec1); + Prg.AsmFild_REG64Ptr(Reg); + EmitLoadAddress(Reg, SymbolRecR); + Prg.AsmFstpSingle_REGPtr(Reg); + FreeReg(Reg); +end; + +procedure TEmitter.EmitOP_INT_TO_EXTENDED_64; +var + Reg: Integer; +begin + EmitPCodeOperator; + + EmitFild(SymbolRec1); + + Reg := GetReg; + EmitLoadAddress(Reg, SymbolRecR); + Prg.AsmFstpExtended_REGPtr(Reg); + FreeReg(Reg); +end; +procedure TEmitter.EmitOP_INT_TO_EXTENDED; +var + Reg: Integer; +begin + EmitPCodeOperator; + + EmitFild(SymbolRec1); + + Reg := GetReg; + EmitLoadAddress(Reg, SymbolRecR); + Prg.AsmFstpExtended_REGPtr(Reg); + FreeReg(Reg); +end; + +procedure TEmitter.EmitOP_INT64_TO_EXTENDED_64; +var + Reg: Integer; +begin + EmitPCodeOperator; + Reg := GetReg; + EmitLoadAddress(Reg, SymbolRec1); + Prg.AsmFild_REG64Ptr(Reg); + EmitLoadAddress(Reg, SymbolRecR); + Prg.AsmFstpExtended_REGPtr(Reg); + FreeReg(Reg); +end; +procedure TEmitter.EmitOP_INT64_TO_EXTENDED; +var + Reg: Integer; +begin + EmitPCodeOperator; + Reg := GetReg; + EmitLoadAddress(Reg, SymbolRec1); + Prg.AsmFild_REG64Ptr(Reg); + EmitLoadAddress(Reg, SymbolRecR); + Prg.AsmFstpExtended_REGPtr(Reg); + FreeReg(Reg); +end; + +procedure TEmitter.EmitOP_DOUBLE_TO_SINGLE_64; +var + Reg: Integer; +begin + EmitPCodeOperator; + Reg := GetReg; + EmitLoadAddress(Reg, SymbolRec1); + Prg.AsmCvtsd2ssXMM_RegPtr(_XMM4, Reg); + EmitLoadAddress(Reg, SymbolRecR); + Prg.AsmMovsdRegPtr_XMM(_XMM4, Reg); + FreeReg(Reg); +end; +procedure TEmitter.EmitOP_DOUBLE_TO_SINGLE; +var + Reg: Integer; +begin + EmitPCodeOperator; + Reg := GetReg; + EmitLoadAddress(Reg, SymbolRec1); + Prg.AsmFldDouble_REGPtr(Reg); + EmitLoadAddress(Reg, SymbolRecR); + Prg.AsmFstpSingle_REGPtr(Reg); + FreeReg(Reg); +end; + +procedure TEmitter.EmitOP_DOUBLE_TO_EXTENDED_64; +var + Reg: Integer; +begin + EmitPCodeOperator; + Reg := GetReg; + EmitLoadAddress(Reg, SymbolRec1); + Prg.AsmMovsdXMM_RegPtr(_XMM4, Reg); + EmitLoadAddress(Reg, SymbolRecR); + Prg.AsmMovsdRegPtr_XMM(_XMM4, Reg); + FreeReg(Reg); +end; +procedure TEmitter.EmitOP_DOUBLE_TO_EXTENDED; +var + Reg: Integer; +begin + EmitPCodeOperator; + Reg := GetReg; + EmitLoadAddress(Reg, SymbolRec1); + Prg.AsmFldDouble_REGPtr(Reg); + EmitLoadAddress(Reg, SymbolRecR); + Prg.AsmFstpExtended_REGPtr(Reg); + FreeReg(Reg); +end; + +procedure TEmitter.EmitOP_EXTENDED_TO_DOUBLE_64; +var + Reg: Integer; +begin + EmitPCodeOperator; + Reg := GetReg; + EmitLoadAddress(Reg, SymbolRec1); + Prg.AsmMovsdXMM_RegPtr(_XMM4, Reg); + EmitLoadAddress(Reg, SymbolRecR); + Prg.AsmMovsdRegPtr_XMM(_XMM4, Reg); + FreeReg(Reg); +end; +procedure TEmitter.EmitOP_EXTENDED_TO_DOUBLE; +var + Reg: Integer; +begin + EmitPCodeOperator; + Reg := GetReg; + EmitLoadAddress(Reg, SymbolRec1); + Prg.AsmFldExtended_REGPtr(Reg); + EmitLoadAddress(Reg, SymbolRecR); + Prg.AsmFstpDouble_REGPtr(Reg); + FreeReg(Reg); +end; + +procedure TEmitter.EmitOP_EXTENDED_TO_SINGLE_64; +var + Reg: Integer; +begin + EmitPCodeOperator; + Reg := GetReg; + EmitLoadAddress(Reg, SymbolRec1); + Prg.AsmCvtsd2ssXMM_RegPtr(_XMM4, Reg); + EmitLoadAddress(Reg, SymbolRecR); + Prg.AsmMovsdRegPtr_XMM(_XMM4, Reg); + FreeReg(Reg); +end; +procedure TEmitter.EmitOP_EXTENDED_TO_SINGLE; +var + Reg: Integer; +begin + EmitPCodeOperator; + Reg := GetReg; + EmitLoadAddress(Reg, SymbolRec1); + Prg.AsmFldExtended_REGPtr(Reg); + EmitLoadAddress(Reg, SymbolRecR); + Prg.AsmFstpSingle_REGPtr(Reg); + FreeReg(Reg); +end; + +procedure TEmitter.EmitOP_SINGLE_TO_DOUBLE_64; +var + Reg: Integer; +begin + EmitPCodeOperator; + Reg := GetReg; + EmitLoadAddress(Reg, SymbolRec1); + Prg.AsmCvtss2sdXMM_RegPtr(_XMM4, Reg); + EmitLoadAddress(Reg, SymbolRecR); + Prg.AsmMovsdRegPtr_XMM(_XMM4, Reg); + FreeReg(Reg); +end; +procedure TEmitter.EmitOP_SINGLE_TO_DOUBLE; +var + Reg: Integer; +begin + EmitPCodeOperator; + Reg := GetReg; + EmitLoadAddress(Reg, SymbolRec1); + Prg.AsmFldSingle_REGPtr(Reg); + EmitLoadAddress(Reg, SymbolRecR); + Prg.AsmFstpDouble_REGPtr(Reg); + FreeReg(Reg); +end; + +procedure TEmitter.EmitFDiv_10000; +begin + Prg.AsmFDiv_ESIPtr32(GetOffset(GetSymbolRec(CURR_FMUL_Id))); +end; + +procedure TEmitter.EmitFMul_10000; +begin + Prg.AsmFMul_ESIPtr32(GetOffset(GetSymbolRec(CURR_FMUL_Id))); +end; + +procedure TEmitter.EmitOP_CURRENCY_TO_DOUBLE_64; +begin + EmitPCodeOperator; + + EmitFild(SymbolRec1); + EmitFDiv_10000; + EmitFstp(SymbolRecR); +end; +procedure TEmitter.EmitOP_CURRENCY_TO_DOUBLE; +begin + EmitPCodeOperator; + + EmitFild(SymbolRec1); + EmitFDiv_10000; + EmitFstp(SymbolRecR); +end; + +procedure TEmitter.EmitOP_CURRENCY_TO_SINGLE_64; +begin + EmitPCodeOperator; + + EmitFild(SymbolRec1); + EmitFDiv_10000; + EmitFstp(SymbolRecR); +end; +procedure TEmitter.EmitOP_CURRENCY_TO_SINGLE; +begin + EmitPCodeOperator; + + EmitFild(SymbolRec1); + EmitFDiv_10000; + EmitFstp(SymbolRecR); +end; + +procedure TEmitter.EmitOP_CURRENCY_TO_EXTENDED_64; +begin + EmitPCodeOperator; + + EmitFild(SymbolRec1); + EmitFDiv_10000; + EmitFstp(SymbolRecR); +end; +procedure TEmitter.EmitOP_CURRENCY_TO_EXTENDED; +begin + EmitPCodeOperator; + + EmitFild(SymbolRec1); + EmitFDiv_10000; + EmitFstp(SymbolRecR); +end; + +procedure TEmitter.EmitOP_SINGLE_TO_EXTENDED_64; +var + Reg: Integer; +begin + EmitPCodeOperator; + Reg := GetReg; + EmitLoadAddress(Reg, SymbolRec1); + Prg.AsmCvtss2sdXMM_RegPtr(_XMM4, Reg); + EmitLoadAddress(Reg, SymbolRecR); + Prg.AsmMovsdRegPtr_XMM(_XMM4, Reg); + FreeReg(Reg); +end; +procedure TEmitter.EmitOP_SINGLE_TO_EXTENDED; +var + Reg: Integer; +begin + EmitPCodeOperator; + Reg := GetReg; + EmitLoadAddress(Reg, SymbolRec1); + Prg.AsmFldSingle_REGPtr(Reg); + EmitLoadAddress(Reg, SymbolRecR); + Prg.AsmFstpExtended_REGPtr(Reg); + FreeReg(Reg); +end; + +procedure TEmitter.EmitOP_ADDRESS_PROG_64; +var + Reg: Integer; +begin + EmitPCodeOperator; + Reg := GetReg; + Prg.AsmMovREG_REG(Reg, _ESI); + Prg.AsmAddREG_Imm(Reg, H_SelfPtr); + EmitSaveIntVal(Reg, SymbolRecR); + FreeReg(Reg); +end; +procedure TEmitter.EmitOP_ADDRESS_PROG; +var + Reg: Integer; +begin + EmitPCodeOperator; + Reg := GetReg; + Prg.AsmMovREG_REG(Reg, _ESI); + Prg.AsmAddREG_Imm(Reg, H_SelfPtr); + EmitSaveIntVal(Reg, SymbolRecR); + FreeReg(Reg); +end; + +procedure TEmitter.EmitOP_ASSIGN_PROG_64; +var + Reg, SubId: Integer; +begin + EmitPCodeOperator; + Reg := GetRegEx; + + SubId := JS_AssignProgId; + EmitCallPro(SubId); + + EmitLoadIntVal(Reg, SymbolRecR); + Prg.AsmMovREG_REG(_ECX, Reg); + + Prg.AsmMovREG_REG(Reg, _ESI); + Prg.AsmAddREG_Imm(Reg, H_SelfPtr); + Prg.AsmMovREG_REGPtr(Reg, Reg); + Prg.AsmMovREG_REG(_EDX, Reg); + + FreeReg(Reg); + + EmitStdCall(SubId); +end; +procedure TEmitter.EmitOP_ASSIGN_PROG; +var + Reg, SubId: Integer; +begin + EmitPCodeOperator; + Reg := GetReg; + + SubId := JS_AssignProgId; + EmitCallPro(SubId); + + Prg.AsmMovREG_REG(Reg, _ESI); + Prg.AsmAddREG_Imm(Reg, H_SelfPtr); + Prg.AsmMovREG_REGPtr(Reg, Reg); + Prg.AsmPush_REG(Reg); + + EmitLoadIntVal(Reg, SymbolRecR); + Prg.AsmPush_REG(Reg); + + FreeReg(Reg); + + EmitStdCall(SubId); +end; + +procedure TEmitter.EmitOP_ADDRESS_64; +var + Reg: Integer; +begin + EmitPCodeOperator; + + Reg := GetReg; + + if SymbolRec1.Kind in KindSUBS then + begin + + if Host1 then + EmitGet_REG(Reg, SymbolRec1) + else + begin + Prg.AsmMovREG_REG(Reg, _EDI); + Prg.AsmAddREG_Imm(Reg, 0); + Prg.Top.SaveSubId := R.Arg1; + List2.Add(Prg.Top); + end; + EmitSaveIntVal(Reg, SymbolRecR); + + end + else + begin + EmitLoadAddress(Reg, SymbolRec1); + EmitSaveIntVal(Reg, SymbolRecR); + end; + + FreeReg(Reg); +end; +procedure TEmitter.EmitOP_ADDRESS; +var + Reg: Integer; +begin + EmitPCodeOperator; + + Reg := GetReg; + + if SymbolRec1.Kind in KindSUBS then + begin + + if Host1 then + EmitGet_REG(Reg, SymbolRec1) + else + begin + Prg.AsmMovREG_REG(Reg, _EDI); + Prg.AsmAddREG_Imm(Reg, 0); + Prg.Top.SaveSubId := R.Arg1; + List2.Add(Prg.Top); + end; + EmitSaveIntVal(Reg, SymbolRecR); + + end + else + begin + EmitLoadAddress(Reg, SymbolRec1); + EmitSaveIntVal(Reg, SymbolRecR); + end; + + FreeReg(Reg); +end; + +procedure TEmitter.EmitOP_INIT_PCHAR_LITERAL; +var + Reg: Integer; +begin + EmitPCodeOperator; + + Reg := GetReg; + + EmitLoadAddress(Reg, SymbolRec1); + Prg.AsmAddREG_Imm(Reg, 12); + EmitSaveIntVal(Reg, SymbolRec1); + + FreeReg(Reg); +end; + +procedure TEmitter.EmitOP_INIT_PWIDECHAR_LITERAL; +var + Reg: Integer; +begin + EmitPCodeOperator; + + Reg := GetReg; + + EmitLoadAddress(Reg, SymbolRec1); + Prg.AsmAddREG_Imm(Reg, 8); + EmitSaveIntVal(Reg, SymbolRec1); + + FreeReg(Reg); +end; + +procedure TEmitter.EmitOP_TERMINAL_64; +var + Reg, temp: Integer; +begin + EmitPCodeOperator; + + Reg := GetReg; + + EmitLoadIntVal(Reg, SymbolRec1); + SymbolRecR.ByRef := false; + temp := SymbolRecR.TypeID; + SymbolRecR.TypeID := TypePOINTER; + EmitSaveIntVal(Reg, SymbolRecR); + SymbolRecR.ByRef := true; + SymbolRecR.TypeID := temp; + + FreeReg(Reg); +end; +procedure TEmitter.EmitOP_TERMINAL; +var + Reg, temp: Integer; +begin + EmitPCodeOperator; + + Reg := GetReg; + + EmitLoadIntVal(Reg, SymbolRec1); + SymbolRecR.ByRef := false; + temp := SymbolRecR.TypeID; + SymbolRecR.TypeID := TypePOINTER; + EmitSaveIntVal(Reg, SymbolRecR); + SymbolRecR.ByRef := true; + SymbolRecR.TypeID := temp; + + FreeReg(Reg); +end; + +procedure TEmitter.CheckSetElement(S: TSymbolRec); +var + I: Integer; +begin + if S.Kind = KindCONST then + if not IsVarObject(S.Value) then + begin + I := S.Value; + if (I < 0) or (I > 255) then + CreateError(errInvalidSet, []); + end; +end; + +procedure TEmitter.EmitOP_SET_INCLUDE_64; +var + SubId, Reg: Integer; +begin + EmitPCodeOperator; + + CheckSetElement(SymbolRec1); + + SubId := Id_SetInclude; + EmitCallPro(SubId); + + Reg := GetRegEx; + + EmitLoadAddress(Reg, SymbolRec1); // 1 - par + Prg.AsmMovREG_REG(_ECX, Reg); + + EmitLoadIntVal(Reg, SymbolRec2); // 2 - par + Prg.AsmMovREG_REG(_EDX, Reg); + + FreeReg(Reg); + + EmitStdCall(SubId); +end; +procedure TEmitter.EmitOP_SET_INCLUDE; +var + SubId, Reg: Integer; +begin + EmitPCodeOperator; + + CheckSetElement(SymbolRec2); + + SubId := Id_SetInclude; + EmitCallPro(SubId); + + Reg := GetReg; + + EmitLoadIntVal(Reg, SymbolRec2); // the second parameter + Prg.AsmPush_REG(Reg); + + EmitLoadAddress(Reg, SymbolRec1); // the first parameter + Prg.AsmPush_REG(Reg); + + FreeReg(Reg); + + EmitStdCall(SubId); +end; + +procedure TEmitter.EmitOP_SET_INCLUDE_INTERVAL_64; +var + SubId, Reg: Integer; +begin + EmitPCodeOperator; + CheckSetElement(SymbolRec1); + CheckSetElement(SymbolRec2); + + SubId := Id_SetIncludeInterval; + EmitCallPro(SubId); + + Reg := GetRegEx; + + EmitLoadAddress(Reg, SymbolRec1); // the first parameter + Prg.AsmMovREG_REG(_ECX, Reg); + + EmitLoadIntVal(Reg, SymbolRec2); // the second parameter + Prg.AsmMovREG_REG(_EDX, Reg); + + EmitLoadIntVal(Reg, SymbolRecR); // the third parameter + Prg.AsmMovREG_REG(_R8, Reg); + + FreeReg(Reg); + + EmitStdCall(SubId); +end; +procedure TEmitter.EmitOP_SET_INCLUDE_INTERVAL; +var + SubId, Reg: Integer; +begin + EmitPCodeOperator; + CheckSetElement(SymbolRec1); + CheckSetElement(SymbolRec2); + + SubId := Id_SetIncludeInterval; + EmitCallPro(SubId); + + Reg := GetReg; + + EmitLoadIntVal(Reg, SymbolRecR); // the third parameter + Prg.AsmPush_REG(Reg); + + EmitLoadIntVal(Reg, SymbolRec2); // the second parameter + Prg.AsmPush_REG(Reg); + + EmitLoadAddress(Reg, SymbolRec1); // the first parameter + Prg.AsmPush_REG(Reg); + + FreeReg(Reg); + + EmitStdCall(SubId); +end; + +procedure TEmitter.EmitOP_SET_EXCLUDE_64; +var + SubId, Reg: Integer; +begin + EmitPCodeOperator; + + CheckSetElement(SymbolRec1); + + SubId := Id_SetExclude; + EmitCallPro(SubId); + + Reg := GetRegEx; + + EmitLoadAddress(Reg, SymbolRec1); // 1 - par + Prg.AsmMovREG_REG(_ECX, Reg); + + EmitLoadIntVal(Reg, SymbolRec2); // 2 - par + Prg.AsmMovREG_REG(_EDX, Reg); + + FreeReg(Reg); + + EmitStdCall(SubId); +end; +procedure TEmitter.EmitOP_SET_EXCLUDE; +var + SubId, Reg: Integer; +begin + EmitPCodeOperator; + + CheckSetElement(SymbolRec2); + + SubId := Id_SetExclude; + EmitCallPro(SubId); + + Reg := GetReg; + + EmitLoadIntVal(Reg, SymbolRec2); // the second parameter + Prg.AsmPush_REG(Reg); + + EmitLoadAddress(Reg, SymbolRec1); // the first parameter + Prg.AsmPush_REG(Reg); + + FreeReg(Reg); + + EmitStdCall(SubId); +end; + +procedure TEmitter.EmitOP_SET_UNION_64; +var + SubId, Reg, T, SZ: Integer; +begin + EmitPCodeOperator; + + SubId := Id_SetUnion; + EmitCallPro(SubId); + + Reg := GetRegEx; + + EmitLoadAddress(Reg, SymbolRec1); // 1 - par + Prg.AsmMovREG_REG(_ECX, Reg); + + EmitLoadAddress(Reg, SymbolRec2); // 2 - par + Prg.AsmMovREG_REG(_EDX, Reg); + + EmitLoadAddress(Reg, SymbolRecR); // 3 - par + Prg.AsmMovREG_REG(_R8, Reg); + + T := SymbolRec1.TerminalTypeId; + SZ := SymbolTable.GetSizeOfSetType(T); + Prg.AsmMovREG_Imm(Reg, SZ); + Prg.AsmMovREG_REG(_R9, Reg); + + T := SymbolRec2.TerminalTypeId; + SZ := SymbolTable.GetSizeOfSetType(T); + Prg.AsmMovREG_Imm(Reg, SZ); + Prg.AsmMovRSPPtr_REG64(Reg, $20); + + FreeReg(Reg); + + EmitStdCall(SubId); +end; +procedure TEmitter.EmitOP_SET_UNION; +var + SubId, Reg, T, SZ: Integer; +begin + EmitPCodeOperator; + + SubId := Id_SetUnion; + EmitCallPro(SubId); + + Reg := GetReg; + + T := SymbolRec2.TerminalTypeId; + SZ := SymbolTable.GetSizeOfSetType(T); + Prg.AsmPush_Imm(SZ); + + T := SymbolRec1.TerminalTypeId; + SZ := SymbolTable.GetSizeOfSetType(T); + Prg.AsmPush_Imm(SZ); + + EmitLoadAddress(Reg, SymbolRecR); // the third parameter + Prg.AsmPush_REG(Reg); + + EmitLoadAddress(Reg, SymbolRec2); // the second parameter + Prg.AsmPush_REG(Reg); + + EmitLoadAddress(Reg, SymbolRec1); // the first parameter + Prg.AsmPush_REG(Reg); + + FreeReg(Reg); + + EmitStdCall(SubId); +end; + +procedure TEmitter.EmitOP_SET_DIFFERENCE_64; +var + SubId, Reg, T, SZ: Integer; +begin + EmitPCodeOperator; + + SubId := Id_SetDifference; + EmitCallPro(SubId); + + Reg := GetRegEx; + + EmitLoadAddress(Reg, SymbolRec1); // 1 - par + Prg.AsmMovREG_REG(_ECX, Reg); + + EmitLoadAddress(Reg, SymbolRec2); // 2 - par + Prg.AsmMovREG_REG(_EDX, Reg); + + EmitLoadAddress(Reg, SymbolRecR); // 3 - par + Prg.AsmMovREG_REG(_R8, Reg); + + T := SymbolRec1.TerminalTypeId; + SZ := SymbolTable.GetSizeOfSetType(T); + Prg.AsmMovREG_Imm(Reg, SZ); + Prg.AsmMovREG_REG(_R9, Reg); + + T := SymbolRec2.TerminalTypeId; + SZ := SymbolTable.GetSizeOfSetType(T); + Prg.AsmMovREG_Imm(Reg, SZ); + Prg.AsmMovRSPPtr_REG64(Reg, $20); + + FreeReg(Reg); + + EmitStdCall(SubId); +end; +procedure TEmitter.EmitOP_SET_DIFFERENCE; +var + SubId, Reg, T, SZ: Integer; +begin + EmitPCodeOperator; + + SubId := Id_SetDifference; + EmitCallPro(SubId); + + Reg := GetReg; + + T := SymbolRec2.TerminalTypeId; + SZ := SymbolTable.GetSizeOfSetType(T); + Prg.AsmPush_Imm(SZ); + + T := SymbolRec1.TerminalTypeId; + SZ := SymbolTable.GetSizeOfSetType(T); + Prg.AsmPush_Imm(SZ); + + EmitLoadAddress(Reg, SymbolRecR); // the third parameter + Prg.AsmPush_REG(Reg); + + EmitLoadAddress(Reg, SymbolRec2); // the second parameter + Prg.AsmPush_REG(Reg); + + EmitLoadAddress(Reg, SymbolRec1); // the first parameter + Prg.AsmPush_REG(Reg); + + FreeReg(Reg); + + EmitStdCall(SubId); +end; + +procedure TEmitter.EmitOP_SET_INTERSECTION_64; +var + SubId, Reg, T, SZ: Integer; +begin + EmitPCodeOperator; + + SubId := Id_SetIntersection; + EmitCallPro(SubId); + + Reg := GetRegEx; + + EmitLoadAddress(Reg, SymbolRec1); // 1 - par + Prg.AsmMovREG_REG(_ECX, Reg); + + EmitLoadAddress(Reg, SymbolRec2); // 2 - par + Prg.AsmMovREG_REG(_EDX, Reg); + + EmitLoadAddress(Reg, SymbolRecR); // 3 - par + Prg.AsmMovREG_REG(_R8, Reg); + + T := SymbolRec1.TerminalTypeId; + SZ := SymbolTable.GetSizeOfSetType(T); + Prg.AsmMovREG_Imm(Reg, SZ); + Prg.AsmMovREG_REG(_R9, Reg); + + T := SymbolRec2.TerminalTypeId; + SZ := SymbolTable.GetSizeOfSetType(T); + Prg.AsmMovREG_Imm(Reg, SZ); + Prg.AsmMovRSPPtr_REG64(Reg, $20); + + FreeReg(Reg); + + EmitStdCall(SubId); +end; +procedure TEmitter.EmitOP_SET_INTERSECTION; +var + SubId, Reg, T, SZ: Integer; +begin + EmitPCodeOperator; + + SubId := Id_SetIntersection; + EmitCallPro(SubId); + + Reg := GetReg; + + T := SymbolRec2.TerminalTypeId; + SZ := SymbolTable.GetSizeOfSetType(T); + Prg.AsmPush_Imm(SZ); + + T := SymbolRec1.TerminalTypeId; + SZ := SymbolTable.GetSizeOfSetType(T); + Prg.AsmPush_Imm(SZ); + + EmitLoadAddress(Reg, SymbolRecR); // the third parameter + Prg.AsmPush_REG(Reg); + + EmitLoadAddress(Reg, SymbolRec2); // the second parameter + Prg.AsmPush_REG(Reg); + + EmitLoadAddress(Reg, SymbolRec1); // the first parameter + Prg.AsmPush_REG(Reg); + + FreeReg(Reg); + + EmitStdCall(SubId); +end; + +procedure TEmitter.EmitOP_SET_SUBSET_64; +var + SubId, Reg, T, SZ: Integer; +begin + EmitPCodeOperator; + + SubId := Id_SetSubset; + EmitCallPro(SubId); + + GetReg(_EAX); + Reg := _EAX; + + EmitLoadAddress(Reg, SymbolRec1); // 1 - par + Prg.AsmMovREG_REG(_ECX, Reg); + + EmitLoadAddress(Reg, SymbolRec2); // 2 - par + Prg.AsmMovREG_REG(_EDX, Reg); + + T := SymbolRec1.TerminalTypeId; + SZ := SymbolTable.GetSizeOfSetType(T); + Prg.AsmMovREG_Imm(Reg, SZ); + Prg.AsmMovREG_REG(_R8, Reg); + + T := SymbolRec2.TerminalTypeId; + SZ := SymbolTable.GetSizeOfSetType(T); + Prg.AsmMovREG_Imm(Reg, SZ); + Prg.AsmMovREG_REG(_R9, Reg); + + FreeReg(Reg); + + EmitStdCall(SubId); + + EmitPut_REG(_EAX, SymbolRecR); +end; +procedure TEmitter.EmitOP_SET_SUBSET; +var + SubId, Reg, T, SZ: Integer; +begin + EmitPCodeOperator; + + SubId := Id_SetSubset; + EmitCallPro(SubId); + + GetReg(_EAX); + Reg := _EAX; + + T := SymbolRec2.TerminalTypeId; + SZ := SymbolTable.GetSizeOfSetType(T); + Prg.AsmPush_Imm(SZ); + + T := SymbolRec1.TerminalTypeId; + SZ := SymbolTable.GetSizeOfSetType(T); + Prg.AsmPush_Imm(SZ); + + EmitLoadAddress(Reg, SymbolRec2); // the second parameter + Prg.AsmPush_REG(Reg); + + EmitLoadAddress(Reg, SymbolRec1); // the first parameter + Prg.AsmPush_REG(Reg); + + FreeReg(Reg); + + EmitStdCall(SubId); + + EmitPut_REG(_EAX, SymbolRecR); +end; + +procedure TEmitter.EmitOP_SET_SUPERSET_64; +var + SubId, Reg, T, SZ: Integer; +begin + EmitPCodeOperator; + + SubId := Id_SetSuperset; + EmitCallPro(SubId); + + GetReg(_EAX); + Reg := _EAX; + + EmitLoadAddress(Reg, SymbolRec1); // 1 - par + Prg.AsmMovREG_REG(_ECX, Reg); + + EmitLoadAddress(Reg, SymbolRec2); // 2 - par + Prg.AsmMovREG_REG(_EDX, Reg); + + T := SymbolRec1.TerminalTypeId; + SZ := SymbolTable.GetSizeOfSetType(T); + Prg.AsmMovREG_Imm(Reg, SZ); + Prg.AsmMovREG_REG(_R8, Reg); + + T := SymbolRec2.TerminalTypeId; + SZ := SymbolTable.GetSizeOfSetType(T); + Prg.AsmMovREG_Imm(Reg, SZ); + Prg.AsmMovREG_REG(_R9, Reg); + + FreeReg(Reg); + + EmitStdCall(SubId); + EmitPut_REG(_EAX, SymbolRecR); +end; +procedure TEmitter.EmitOP_SET_SUPERSET; +var + SubId, Reg, T, SZ: Integer; +begin + EmitPCodeOperator; + + SubId := Id_SetSuperset; + EmitCallPro(SubId); + + GetReg(_EAX); + Reg := _EAX; + + T := SymbolRec2.TerminalTypeId; + SZ := SymbolTable.GetSizeOfSetType(T); + Prg.AsmPush_Imm(SZ); + + T := SymbolRec1.TerminalTypeId; + SZ := SymbolTable.GetSizeOfSetType(T); + Prg.AsmPush_Imm(SZ); + + EmitLoadAddress(Reg, SymbolRec2); // the second parameter + Prg.AsmPush_REG(Reg); + + EmitLoadAddress(Reg, SymbolRec1); // the first parameter + Prg.AsmPush_REG(Reg); + + FreeReg(Reg); + + EmitStdCall(SubId); + EmitPut_REG(_EAX, SymbolRecR); +end; + +procedure TEmitter.EmitOP_SET_EQUALITY_64; +var + SubId, Reg, T, SZ: Integer; +begin + EmitPCodeOperator; + + SubId := Id_SetEquality; + EmitCallPro(SubId); + + GetReg(_EAX); + Reg := _EAX; + + EmitLoadAddress(Reg, SymbolRec1); // 1 - par + Prg.AsmMovREG_REG(_ECX, Reg); + + EmitLoadAddress(Reg, SymbolRec2); // 2 - par + Prg.AsmMovREG_REG(_EDX, Reg); + + T := SymbolRec1.TerminalTypeId; + SZ := SymbolTable.GetSizeOfSetType(T); + Prg.AsmMovREG_Imm(Reg, SZ); + Prg.AsmMovREG_REG(_R8, Reg); + + T := SymbolRec2.TerminalTypeId; + SZ := SymbolTable.GetSizeOfSetType(T); + Prg.AsmMovREG_Imm(Reg, SZ); + Prg.AsmMovREG_REG(_R9, Reg); + + FreeReg(Reg); + + EmitStdCall(SubId); + + EmitPut_REG(_EAX, SymbolRecR); +end; +procedure TEmitter.EmitOP_SET_EQUALITY; +var + SubId, Reg, T, SZ: Integer; +begin + EmitPCodeOperator; + + SubId := Id_SetEquality; + EmitCallPro(SubId); + + GetReg(_EAX); + Reg := _EAX; + + T := SymbolRec2.TerminalTypeId; + SZ := SymbolTable.GetSizeOfSetType(T); + Prg.AsmPush_Imm(SZ); + + T := SymbolRec1.TerminalTypeId; + SZ := SymbolTable.GetSizeOfSetType(T); + Prg.AsmPush_Imm(SZ); + + EmitLoadAddress(Reg, SymbolRec2); // the second parameter + Prg.AsmPush_REG(Reg); + + EmitLoadAddress(Reg, SymbolRec1); // the first parameter + Prg.AsmPush_REG(Reg); + + FreeReg(Reg); + + EmitStdCall(SubId); + + EmitPut_REG(_EAX, SymbolRecR); +end; + +procedure TEmitter.EmitOP_SET_INEQUALITY_64; +var + SubId, Reg, T, SZ: Integer; +begin + EmitPCodeOperator; + + SubId := Id_SetInequality; + EmitCallPro(SubId); + + GetReg(_EAX); + Reg := _EAX; + + EmitLoadAddress(Reg, SymbolRec1); // 1 - par + Prg.AsmMovREG_REG(_ECX, Reg); + + EmitLoadAddress(Reg, SymbolRec2); // 2 - par + Prg.AsmMovREG_REG(_EDX, Reg); + + T := SymbolRec1.TerminalTypeId; + SZ := SymbolTable.GetSizeOfSetType(T); + Prg.AsmMovREG_Imm(Reg, SZ); + Prg.AsmMovREG_REG(_R8, Reg); + + T := SymbolRec2.TerminalTypeId; + SZ := SymbolTable.GetSizeOfSetType(T); + Prg.AsmMovREG_Imm(Reg, SZ); + Prg.AsmMovREG_REG(_R9, Reg); + + FreeReg(Reg); + + EmitStdCall(SubId); + + EmitPut_REG(_EAX, SymbolRecR); +end; +procedure TEmitter.EmitOP_SET_INEQUALITY; +var + SubId, Reg, T, SZ: Integer; +begin + EmitPCodeOperator; + + SubId := Id_SetInequality; + EmitCallPro(SubId); + + GetReg(_EAX); + Reg := _EAX; + + T := SymbolRec2.TerminalTypeId; + SZ := SymbolTable.GetSizeOfSetType(T); + Prg.AsmPush_Imm(SZ); + + T := SymbolRec1.TerminalTypeId; + SZ := SymbolTable.GetSizeOfSetType(T); + Prg.AsmPush_Imm(SZ); + + EmitLoadAddress(Reg, SymbolRec2); // the second parameter + Prg.AsmPush_REG(Reg); + + EmitLoadAddress(Reg, SymbolRec1); // the first parameter + Prg.AsmPush_REG(Reg); + + FreeReg(Reg); + + EmitStdCall(SubId); + + EmitPut_REG(_EAX, SymbolRecR); +end; + +procedure TEmitter.EmitOP_SET_MEMBERSHIP_64; +var + SubId, Reg: Integer; +begin + EmitPCodeOperator; + + SubId := Id_SetMembership; + EmitCallPro(SubId); + + GetReg(_EAX); + Reg := _EAX; + + EmitLoadIntVal(Reg, SymbolRec1); // 1 - par + Prg.AsmMovREG_REG(_ECX, Reg); + + EmitLoadAddress(Reg, SymbolRec2); // 2 - par + Prg.AsmMovREG_REG(_EDX, Reg); + + FreeReg(Reg); + + EmitStdCall(SubId); + + EmitPut_REG(_EAX, SymbolRecR); +end; +procedure TEmitter.EmitOP_SET_MEMBERSHIP; +var + SubId, Reg: Integer; +begin + EmitPCodeOperator; + + SubId := Id_SetMembership; + EmitCallPro(SubId); + + GetReg(_EAX); + Reg := _EAX; + + EmitLoadAddress(Reg, SymbolRec2); // the second parameter + Prg.AsmPush_REG(Reg); + + EmitLoadIntVal(Reg, SymbolRec1); // the first parameter + Prg.AsmPush_REG(Reg); + + FreeReg(Reg); + + EmitStdCall(SubId); + + EmitPut_REG(_EAX, SymbolRecR); +end; + +procedure TEmitter.EmitOP_SET_ASSIGN_64; +var + Reg1, Reg2, TypeId, SetSize: Integer; +begin + EmitPCodeOperator; + + GetReg(_ECX); + Reg1 := GetReg; + Reg2 := GetReg; + + TypeId := SymbolRec1.TerminalTypeId; + SetSize := TKernel(kernel).SymbolTable.GetSizeOfSetType(TypeId); + + EmitLoadAddress(Reg1, SymbolRec1); + EmitLoadAddress(Reg2, SymbolRec2); + + Prg.AsmPush_Reg(_ESI); + Prg.AsmPush_Reg(_EDI); + + Prg.AsmMovREG_REG(_ESI, Reg2); + Prg.AsmMovREG_REG(_EDI, Reg1); + + Prg.AsmMovREG_Imm(_ECX, SetSize); + Prg.AsmRep_MOVSB; + + Prg.AsmPop_Reg(_EDI); + Prg.AsmPop_Reg(_ESI); + + FreeReg(Reg2); + FreeReg(Reg1); + FreeReg(_ECX); +end; +procedure TEmitter.EmitOP_SET_ASSIGN; +var + Reg1, Reg2, TypeId, SetSize: Integer; +begin + EmitPCodeOperator; + + GetReg(_ECX); + Reg1 := GetReg; + Reg2 := GetReg; + + TypeId := SymbolRec1.TerminalTypeId; + SetSize := TKernel(kernel).SymbolTable.GetSizeOfSetType(TypeId); + + EmitLoadAddress(Reg1, SymbolRec1); + EmitLoadAddress(Reg2, SymbolRec2); + + SaveRegisters([_ESI, _EDI]); + + Prg.AsmMovREG_REG(_ESI, Reg2); + Prg.AsmMovREG_REG(_EDI, Reg1); + + Prg.AsmMovREG_Imm(_ECX, SetSize); + Prg.AsmRep_MOVSB; + + RestoreRegisters([_ESI, _EDI]); + + FreeReg(Reg2); + FreeReg(Reg1); + FreeReg(_ECX); +end; + +procedure TEmitter.EmitOP_SET_COUNTER_ASSIGN_64; +var + Reg, TypeId, SetSize: Integer; +begin + EmitPCodeOperator; + + Reg := GetReg; + + TypeId := SymbolRec2.TerminalTypeId; + SetSize := TKernel(kernel).SymbolTable.GetSizeOfSetType(TypeId); + + Prg.AsmMovREG_Imm(Reg, SetSize * 8); + EmitSaveIntVal(Reg, SymbolRec1); + + FreeReg(Reg); +end; +procedure TEmitter.EmitOP_SET_COUNTER_ASSIGN; +var + Reg, TypeId, SetSize: Integer; +begin + EmitPCodeOperator; + + Reg := GetReg; + + TypeId := SymbolRec2.TerminalTypeId; + SetSize := TKernel(kernel).SymbolTable.GetSizeOfSetType(TypeId); + + Prg.AsmMovREG_Imm(Reg, SetSize * 8); + EmitSaveIntVal(Reg, SymbolRec1); + + FreeReg(Reg); +end; + +procedure TEmitter.EmitOP_CREATE_METHOD_64; +var + SubId, Reg: Integer; +begin + EmitPCodeOperator; + + SubId := Id_CreateMethod; + EmitCallPro(SubId); + + Reg := GetRegEx; + + EmitLoadIntVal(Reg, SymbolRec1); // 1 - par - data + Prg.AsmMovREG_REG(_ECX, Reg); + + EmitLoadIntVal(Reg, SymbolRec2); // 2 - par - code + Prg.AsmMovREG_REG(_EDX, Reg); + + EmitLoadAddress(Reg, SymbolRecR); // result + Prg.AsmMovREG_REG(_R8, Reg); + + FreeReg(Reg); + + EmitStdCall(SubId); +end; +procedure TEmitter.EmitOP_CREATE_METHOD; +var + SubId, Reg: Integer; +begin + EmitPCodeOperator; + + SubId := Id_CreateMethod; + EmitCallPro(SubId); + + Reg := GetReg; + + EmitLoadAddress(Reg, SymbolRecR); // result + Prg.AsmPush_REG(Reg); + + EmitLoadIntVal(Reg, SymbolRec2); // code + Prg.AsmPush_REG(Reg); + + EmitLoadIntVal(Reg, SymbolRec1); // data + Prg.AsmPush_REG(Reg); + + FreeReg(Reg); + + EmitStdCall(SubId); +end; + +procedure TEmitter.EmitOP_TO_JS_OBJECT_64; +var + SubId, Reg, FinTypeId: Integer; +begin + EmitPCodeOperator; + Emit_PUSH_REGS; + + SubId := JS_ToObjectId; + EmitCallPro(SubId); + + Reg := GetRegEx; + + Prg.AsmMovREG_REG(Reg, _ESI); + Prg.AsmAddREG_Imm(Reg, H_SelfPtr); + Prg.AsmMovREG_REGPtr(Reg, Reg); // load TProgram.Self + Prg.AsmMovREG_REG(_ECX, Reg); + + EmitLoadAddress(Reg, SymbolRec1); // source + Prg.AsmMovREG_REG(_EDX, Reg); + + if (SymbolRec1.Kind = kindCONST) and + (SymbolRec1.FinalTypeId in IntegerTypes) then + begin +{ + Id := SymbolRec1.Value; + Id := TKernel(kernel).SymbolTable.AddInt64Const(Id).Id; + + Prg.AsmPush_Imm(typeINT64); + EmitLoadAddress(Reg, GetSymbolRec(Id)); // source +} + RaiseError(errInternalError, []); + end + else + begin + FinTypeId := GetSymbolRec(R.Arg1).FinalTypeId; + Prg.AsmMovREG_Imm(Reg, FinTypeId); + Prg.AsmMovREG_REG(_R8, Reg); + end; + + EmitLoadAddress(Reg, SymbolRecR); // result + Prg.AsmMovREG_REG(_R9, Reg); + + FreeReg(Reg); + EmitStdCall(SubId); + + Emit_POP_REGS; +end; +procedure TEmitter.EmitOP_TO_JS_OBJECT; +var + SubId, Reg, FinTypeId: Integer; +begin + EmitPCodeOperator; + Emit_PUSH_REGS; + + SubId := JS_ToObjectId; + EmitCallPro(SubId); + + Reg := GetRegEx; + + EmitLoadAddress(Reg, SymbolRecR); // result + Prg.AsmPush_REG(Reg); + + if (SymbolRec1.Kind = kindCONST) and + (SymbolRec1.FinalTypeId in IntegerTypes) then + begin +{ + Id := SymbolRec1.Value; + Id := TKernel(kernel).SymbolTable.AddInt64Const(Id).Id; + + Prg.AsmPush_Imm(typeINT64); + EmitLoadAddress(Reg, GetSymbolRec(Id)); // source +} + RaiseError(errInternalError, []); + end + else + begin + FinTypeId := GetSymbolRec(R.Arg1).FinalTypeId; + Prg.AsmPush_Imm(FinTypeId); + + EmitLoadAddress(Reg, SymbolRec1); // source + end; + + Prg.AsmPush_REG(Reg); + + Prg.AsmMovREG_REG(Reg, _ESI); + Prg.AsmAddREG_Imm(Reg, H_SelfPtr); + Prg.AsmMovREG_REGPtr(Reg, Reg); // load TProgram.Self + Prg.AsmPush_REG(Reg); + + FreeReg(Reg); + EmitStdCall(SubId); + + Emit_POP_REGS; +end; + +procedure TEmitter.EmitOP_GET_NEXTJSPROP_64; +begin + EmitStdCall_Adr1_Adr2_AdrR(JS_GetNextPropId); +end; +procedure TEmitter.EmitOP_GET_NEXTJSPROP; +begin + EmitStdCall_Adr1_Adr2_AdrR(JS_GetNextPropId); +end; + +procedure TEmitter.EmitOP_CLEAR_REFERENCES_64; +var + SubId, Reg: Integer; +begin + EmitPCodeOperator; + + SubId := JS_ClearReferencesId; + EmitCallPro(SubId); + + Reg := GetRegEx; + + Prg.AsmMovREG_REG(Reg, _ESI); + Prg.AsmAddREG_Imm(Reg, H_SelfPtr); + Prg.AsmMovREG_REGPtr(Reg, Reg); // load TProgram.Self + Prg.AsmMovREG_REG(_ECX, Reg); // push TProgram.Self + + FreeReg(Reg); + EmitStdCall(SubId); +end; +procedure TEmitter.EmitOP_CLEAR_REFERENCES; +var + SubId, Reg: Integer; +begin + EmitPCodeOperator; + + SubId := JS_ClearReferencesId; + EmitCallPro(SubId); + + Reg := GetReg; + + Prg.AsmMovREG_REG(Reg, _ESI); + Prg.AsmAddREG_Imm(Reg, H_SelfPtr); + Prg.AsmMovREG_REGPtr(Reg, Reg); // load TProgram.Self + Prg.AsmPush_REG(Reg); // push TProgram.Self + + FreeReg(Reg); + EmitStdCall(SubId); +end; + +procedure TEmitter.EmitOP_JS_TYPEOF_64; +var + SubId, Reg: Integer; +begin + EmitPCodeOperator; + + SubId := JS_TypeOfId; + EmitCallPro(SubId); + + Reg := GetRegEx; + + EmitLoadAddress(Reg, SymbolRec1); // 1 - par + Prg.AsmMovREG_REG(_ECX, Reg); + + EmitLoadAddress(Reg, SymbolRecR); // 2 - result + Prg.AsmMovREG_REG(_EDX, Reg); + + FreeReg(Reg); + EmitStdCall(SubId); +end; +procedure TEmitter.EmitOP_JS_TYPEOF; +var + SubId, Reg: Integer; +begin + EmitPCodeOperator; + + SubId := JS_TypeOfId; + EmitCallPro(SubId); + + Reg := GetReg; + + EmitLoadAddress(Reg, SymbolRecR); // result + Prg.AsmPush_REG(Reg); + + EmitLoadAddress(Reg, SymbolRec1); // 1st arg - object + Prg.AsmPush_REG(Reg); + + FreeReg(Reg); + EmitStdCall(SubId); +end; + +procedure TEmitter.EmitOP_JS_VOID_64; +var + SubId, Reg: Integer; +begin + EmitPCodeOperator; + + SubId := JS_VoidId; + EmitCallPro(SubId); + + Reg := GetReg; + + EmitLoadAddress(Reg, SymbolRecR); // result + Prg.AsmMovREG_REG(_ECX, Reg); + + EmitLoadAddress(Reg, SymbolRec1); // 1st arg - object + Prg.AsmMovREG_REG(_EDX, Reg); + + FreeReg(Reg); + EmitStdCall(SubId); +end; +procedure TEmitter.EmitOP_JS_VOID; +var + SubId, Reg: Integer; +begin + EmitPCodeOperator; + + SubId := JS_VoidId; + EmitCallPro(SubId); + + Reg := GetReg; + + EmitLoadAddress(Reg, SymbolRecR); // result + Prg.AsmPush_REG(Reg); + + EmitLoadAddress(Reg, SymbolRec1); // 1st arg - object + Prg.AsmPush_REG(Reg); + + FreeReg(Reg); + EmitStdCall(SubId); +end; + +{$IFNDEF PAXARM} +procedure TEmitter.EmitOP_SHORTSTRING_FROM_PANSICHAR_LITERAL_64; +var + T1, L, L1, L2: Integer; +begin + EmitPCodeOperator; + Emit_PUSH_REGS; + + T1 := SymbolRec1.TerminalTypeID; + L1 := GetSymbolRec(T1).Count; + if T1 = typeSHORTSTRING then + L1 := 255; + L2 := Length(SymbolRec2.Value); + + if L2 < L1 then + L := L2 + else + L := L1; + + GetReg(_EAX); + GetReg(_EDX); + GetReg(_ECX); + + Prg.AsmMovREG_Imm(_ECX, L); + EmitLoadAddress(_EAX, SymbolRec1); // string dest + Prg.AsmMovREGPtr_REG8(_EAX, _ECX); // s[0] := length + EmitGet_REG(_EDX, SymbolRec2); // pchar source + + Prg.AsmPush_REG(_ESI); + Prg.AsmPush_REG(_EDI); + + Prg.AsmMovREG_REG(_ESI, _EDX); + Prg.AsmAddREG_Imm(_EAX, 1); + Prg.AsmMovREG_REG(_EDI, _EAX); + Prg.AsmRep_MOVSB; + + Prg.AsmPop_REG(_EDI); + Prg.AsmPop_REG(_ESI); + + FreeReg(_EAX); + FreeReg(_EDX); + FreeReg(_ECX); + + Emit_POP_REGS; +end; +procedure TEmitter.EmitOP_SHORTSTRING_FROM_PANSICHAR_LITERAL; +var + T1, L, L1, L2: Integer; +begin + EmitPCodeOperator; + Emit_PUSH_REGS; + + T1 := SymbolRec1.TerminalTypeID; + L1 := GetSymbolRec(T1).Count; + if T1 = typeSHORTSTRING then + L1 := 255; + L2 := Length(SymbolRec2.Value); + + if L2 < L1 then + L := L2 + else + L := L1; + + GetReg(_EAX); + GetReg(_EDX); + GetReg(_ECX); + + Prg.AsmMovREG_Imm(_ECX, L); + EmitLoadAddress(_EAX, SymbolRec1); // string dest + Prg.AsmMovREGPtr_REG8(_EAX, _ECX); // s[0] := length + EmitGet_REG(_EDX, SymbolRec2); // pchar source + + SaveRegisters([_ESI, _EDI]); + + Prg.AsmMovREG_REG(_ESI, _EDX); + Prg.AsmAddREG_Imm(_EAX, 1); + Prg.AsmMovREG_REG(_EDI, _EAX); + Prg.AsmRep_MOVSB; + + RestoreRegisters([_ESI, _EDI]); + + FreeReg(_EAX); + FreeReg(_EDX); + FreeReg(_ECX); + + Emit_POP_REGS; +end; + +procedure TEmitter.EmitOP_SHORTSTRING_FROM_PWIDECHAR_LITERAL_64; +var + T1, L1, SubId, Reg: Integer; +begin + SubId := Id_ShortStringFromPWideChar; + + EmitPCodeOperator; + Emit_PUSH_REGS; + + EmitCallPro(SubId); + + Reg := GetRegEx; + + EmitLoadAddress(Reg, SymbolRec1); // string dest + Prg.AsmMovREG_REG(_ECX, Reg); + +// + + T1 := SymbolRec1.TerminalTypeID; + L1 := GetSymbolRec(T1).Count; + if T1 = typeSHORTSTRING then + L1 := 255; + + Prg.AsmMovREG_Imm(Reg, L1); + Prg.AsmMovREG_REG(_EDX, Reg); + Prg.AsmMovREG_REG(_R8, Reg); + + EmitGet_REG(Reg, SymbolRec2); // pwidechar source + Prg.AsmMovREG_REG(_R9, Reg); + + FreeReg(Reg); + EmitStdCall(SubId); + + Emit_POP_REGS; +end; +procedure TEmitter.EmitOP_SHORTSTRING_FROM_PWIDECHAR_LITERAL; +var + T1, L1, SubId, Reg: Integer; +begin + SubId := Id_ShortStringFromPWideChar; + + EmitPCodeOperator; + Emit_PUSH_REGS; + + EmitCallPro(SubId); + + T1 := SymbolRec1.TerminalTypeID; + L1 := GetSymbolRec(T1).Count; + if T1 = typeSHORTSTRING then + L1 := 255; + + Reg := GetReg; + EmitGet_REG(Reg, SymbolRec2); // pwidechar source + Prg.AsmPush_REG(Reg); + Prg.AsmPush_Imm(L1); + Prg.AsmPush_Imm(L1); + EmitLoadAddress(Reg, SymbolRec1); // string dest + Prg.AsmPush_REG(Reg); + + FreeReg(Reg); + EmitStdCall(SubId); + + Emit_POP_REGS; +end; +{$ENDIF} + +procedure TEmitter.EmitOP_WIDESTRING_FROM_PANSICHAR_LITERAL_64; +var + SubId, Reg: Integer; +begin + EmitPCodeOperator; + Emit_PUSH_REGS; + + SubId := Id_WideStringFromPAnsiChar; + EmitCallPro(SubId); + + Reg := GetRegEx; + + EmitGet_REG(Reg, SymbolRec2); // pchar source + Prg.AsmMovREG_REG(_ECX, Reg); + + EmitLoadAddress(Reg, SymbolRec1); // string dest + Prg.AsmMovREG_REG(_EDX, Reg); + + FreeReg(Reg); + EmitStdCall(SubId); + + Emit_POP_REGS; +end; +procedure TEmitter.EmitOP_WIDESTRING_FROM_PANSICHAR_LITERAL; +var + SubId, Reg: Integer; +begin + EmitPCodeOperator; + Emit_PUSH_REGS; + + SubId := Id_WideStringFromPAnsiChar; + EmitCallPro(SubId); + + Reg := GetRegEx; + + EmitLoadAddress(Reg, SymbolRec1); // string dest + Prg.AsmPush_REG(Reg); + + EmitGet_REG(Reg, SymbolRec2); // pchar source + Prg.AsmPush_REG(Reg); + + FreeReg(Reg); + EmitStdCall(SubId); + + Emit_POP_REGS; +end; + +procedure TEmitter.EmitOP_UNICSTRING_FROM_PANSICHAR_LITERAL_64; +var + SubId, Reg: Integer; +begin + EmitPCodeOperator; + Emit_PUSH_REGS; + + SubId := Id_UnicStringFromPAnsiChar; + EmitCallPro(SubId); + + Reg := GetRegEx; + + EmitGet_REG(Reg, SymbolRec2); // pchar source + Prg.AsmMovREG_REG(_EDX, Reg); + + EmitLoadAddress(Reg, SymbolRec1); // string dest + Prg.AsmMovREG_REG(_ECX, Reg); + + FreeReg(Reg); + EmitStdCall(SubId); + + Emit_POP_REGS; +end; +procedure TEmitter.EmitOP_UNICSTRING_FROM_PANSICHAR_LITERAL; +var + SubId, Reg: Integer; +begin + EmitPCodeOperator; + Emit_PUSH_REGS; + + SubId := Id_UnicStringFromPAnsiChar; + EmitCallPro(SubId); + + Reg := GetRegEx; + + EmitLoadAddress(Reg, SymbolRec1); // string dest + Prg.AsmPush_REG(Reg); + + EmitGet_REG(Reg, SymbolRec2); // pchar source + Prg.AsmPush_REG(Reg); + + FreeReg(Reg); + EmitStdCall(SubId); + + Emit_POP_REGS; +end; + +procedure TEmitter.EmitOP_WIDESTRING_FROM_PWIDECHAR_LITERAL_64; +var + SubId, Reg: Integer; +begin + EmitPCodeOperator; + Emit_PUSH_REGS; + + SubId := Id_WideStringFromPWideChar; + EmitCallPro(SubId); + + Reg := GetRegEx; + + EmitGet_REG(Reg, SymbolRec2); // pchar source + Prg.AsmMovREG_REG(_ECX, Reg); + + EmitLoadAddress(Reg, SymbolRec1); // string dest + Prg.AsmMovREG_REG(_EDX, Reg); + + FreeReg(Reg); + EmitStdCall(SubId); + + Emit_POP_REGS; +end; +procedure TEmitter.EmitOP_WIDESTRING_FROM_PWIDECHAR_LITERAL; +var + SubId, Reg: Integer; +begin + EmitPCodeOperator; + Emit_PUSH_REGS; + + SubId := Id_WideStringFromPWideChar; + EmitCallPro(SubId); + + Reg := GetRegEx; + + EmitLoadAddress(Reg, SymbolRec1); // string dest + Prg.AsmPush_REG(Reg); + + EmitGet_REG(Reg, SymbolRec2); // pchar source + Prg.AsmPush_REG(Reg); + + FreeReg(Reg); + EmitStdCall(SubId); + + Emit_POP_REGS; +end; + +procedure TEmitter.EmitOP_UNICSTRING_FROM_PWIDECHAR_LITERAL_64; +var + SubId, Reg: Integer; +begin + EmitPCodeOperator; + Emit_PUSH_REGS; + + SubId := Id_UnicStringFromPWideChar; + EmitCallPro(SubId); + + Reg := GetRegEx; + + EmitGet_REG(Reg, SymbolRec2); // pchar source + Prg.AsmMovREG_REG(_ECX, Reg); + + EmitLoadAddress(Reg, SymbolRec1); // string dest + Prg.AsmMovREG_REG(_EDX, Reg); + + FreeReg(Reg); + EmitStdCall(SubId); + + Emit_POP_REGS; +end; +procedure TEmitter.EmitOP_UNICSTRING_FROM_PWIDECHAR_LITERAL; +var + SubId, Reg: Integer; +begin + EmitPCodeOperator; + Emit_PUSH_REGS; + + SubId := Id_UnicStringFromPWideChar; + EmitCallPro(SubId); + + Reg := GetRegEx; + + EmitLoadAddress(Reg, SymbolRec1); // string dest + Prg.AsmPush_REG(Reg); + + EmitGet_REG(Reg, SymbolRec2); // pchar source + Prg.AsmPush_REG(Reg); + + FreeReg(Reg); + EmitStdCall(SubId); + + Emit_POP_REGS; +end; + +procedure TEmitter.EmitOP_VARIANT_FROM_PANSICHAR_LITERAL_64; +var + SubId, Reg: Integer; +begin + EmitPCodeOperator; + Emit_PUSH_REGS; + + SubId := Id_VariantFromPAnsiChar; + EmitCallPro(SubId); + + Reg := GetRegEx; + + EmitGet_REG(Reg, SymbolRec2); // pchar source + Prg.AsmMovREG_REG(_ECX, Reg); + + EmitLoadAddress(Reg, SymbolRec1); // variant dest + Prg.AsmMovREG_REG(_EDX, Reg); + + FreeReg(Reg); + EmitStdCall(SubId); + + Emit_POP_REGS; +end; +procedure TEmitter.EmitOP_VARIANT_FROM_PANSICHAR_LITERAL; +var + SubId, Reg: Integer; +begin + EmitPCodeOperator; + Emit_PUSH_REGS; + + SubId := Id_VariantFromPAnsiChar; + EmitCallPro(SubId); + + Reg := GetRegEx; + + EmitLoadAddress(Reg, SymbolRec1); // variant dest + Prg.AsmPush_REG(Reg); + + EmitGet_REG(Reg, SymbolRec2); // pchar source + Prg.AsmPush_REG(Reg); + + FreeReg(Reg); + EmitStdCall(SubId); + + Emit_POP_REGS; +end; + +procedure TEmitter.EmitOP_VARIANT_FROM_PWIDECHAR_LITERAL_64; +var + SubId, Reg: Integer; +begin + EmitPCodeOperator; + Emit_PUSH_REGS; + + SubId := Id_VariantFromPWideChar; + EmitCallPro(SubId); + + Reg := GetRegEx; + + EmitGet_REG(Reg, SymbolRec2); // pchar source + Prg.AsmMovREG_REG(_ECX, Reg); + + EmitLoadAddress(Reg, SymbolRec1); // variant dest + Prg.AsmMovREG_REG(_EDX, Reg); + + FreeReg(Reg); + EmitStdCall(SubId); + + Emit_POP_REGS; +end; +procedure TEmitter.EmitOP_VARIANT_FROM_PWIDECHAR_LITERAL; +var + SubId, Reg: Integer; +begin + EmitPCodeOperator; + Emit_PUSH_REGS; + + SubId := Id_VariantFromPWideChar; + EmitCallPro(SubId); + + Reg := GetRegEx; + + EmitLoadAddress(Reg, SymbolRec1); // variant dest + Prg.AsmPush_REG(Reg); + + EmitGet_REG(Reg, SymbolRec2); // pchar source + Prg.AsmPush_REG(Reg); + + FreeReg(Reg); + EmitStdCall(SubId); + + Emit_POP_REGS; +end; + +procedure TEmitter.EmitOP_OLEVARIANT_FROM_PANSICHAR_LITERAL_64; +var + SubId, Reg: Integer; +begin + EmitPCodeOperator; + Emit_PUSH_REGS; + + SubId := Id_OleVariantFromPAnsiChar; + EmitCallPro(SubId); + + Reg := GetRegEx; + + EmitGet_REG(Reg, SymbolRec2); // pchar source + Prg.AsmMovREG_REG(_ECX, Reg); + + EmitLoadAddress(Reg, SymbolRec1); // variant dest + Prg.AsmMovREG_REG(_EDX, Reg); + + FreeReg(Reg); + EmitStdCall(SubId); + + Emit_POP_REGS; +end; +procedure TEmitter.EmitOP_OLEVARIANT_FROM_PANSICHAR_LITERAL; +var + SubId, Reg: Integer; +begin + EmitPCodeOperator; + Emit_PUSH_REGS; + + SubId := Id_OleVariantFromPAnsiChar; + EmitCallPro(SubId); + + Reg := GetRegEx; + + EmitLoadAddress(Reg, SymbolRec1); // variant dest + Prg.AsmPush_REG(Reg); + + EmitGet_REG(Reg, SymbolRec2); // pchar source + Prg.AsmPush_REG(Reg); + + FreeReg(Reg); + EmitStdCall(SubId); + + Emit_POP_REGS; +end; + +procedure TEmitter.EmitOP_OLEVARIANT_FROM_PWIDECHAR_LITERAL_64; +var + SubId, Reg: Integer; +begin + EmitPCodeOperator; + Emit_PUSH_REGS; + + SubId := Id_OleVariantFromPWideChar; + EmitCallPro(SubId); + + Reg := GetRegEx; + + EmitGet_REG(Reg, SymbolRec2); // pchar source + Prg.AsmMovREG_REG(_ECX, Reg); + + EmitLoadAddress(Reg, SymbolRec1); // variant dest + Prg.AsmMovREG_REG(_EDX, Reg); + + FreeReg(Reg); + EmitStdCall(SubId); + + Emit_POP_REGS; +end; +procedure TEmitter.EmitOP_OLEVARIANT_FROM_PWIDECHAR_LITERAL; +var + SubId, Reg: Integer; +begin + EmitPCodeOperator; + Emit_PUSH_REGS; + + SubId := Id_OleVariantFromPWideChar; + EmitCallPro(SubId); + + Reg := GetRegEx; + + EmitLoadAddress(Reg, SymbolRec1); // variant dest + Prg.AsmPush_REG(Reg); + + EmitGet_REG(Reg, SymbolRec2); // pchar source + Prg.AsmPush_REG(Reg); + + FreeReg(Reg); + EmitStdCall(SubId); + + Emit_POP_REGS; +end; + +{$IFNDEF PAXARM} +procedure TEmitter.EmitOP_SHORTSTRING_FROM_ANSISTRING_64; +var + T1, L1, SubId, Reg: Integer; +begin + SubId := Id_ShortStringFromAnsiString; + + EmitPCodeOperator; + Emit_PUSH_REGS; + + EmitCallPro(SubId); + + Reg := GetRegEx; + + T1 := SymbolRec1.TerminalTypeID; + L1 := GetSymbolRec(T1).Count; + if T1 = typeSHORTSTRING then + L1 := 255; + + EmitLoadAddress(Reg, SymbolRec1); // string dest + Prg.AsmMovREG_REG(_ECX, Reg); + + Prg.AsmMovREG_Imm(Reg, L1); + Prg.AsmMovREG_REG(_EDX, Reg); + Prg.AsmMovREG_REG(_R8, Reg); + + EmitLoadAddress(Reg, SymbolRec2); // string source + Prg.AsmMovREG_REG(_R9, Reg); + + FreeReg(Reg); + EmitStdCall(SubId); + + Emit_POP_REGS; +end; +procedure TEmitter.EmitOP_SHORTSTRING_FROM_ANSISTRING; +var + T1, L1, SubId, Reg: Integer; +begin + SubId := Id_ShortStringFromAnsiString; + + EmitPCodeOperator; + Emit_PUSH_REGS; + + EmitCallPro(SubId); + + T1 := SymbolRec1.TerminalTypeID; + L1 := GetSymbolRec(T1).Count; + if T1 = typeSHORTSTRING then + L1 := 255; + + Reg := GetReg; + EmitLoadAddress(Reg, SymbolRec2); // string source + Prg.AsmPush_REG(Reg); + Prg.AsmPush_Imm(L1); + Prg.AsmPush_Imm(L1); + EmitLoadAddress(Reg, SymbolRec1); // string dest + Prg.AsmPush_REG(Reg); + + FreeReg(Reg); + EmitStdCall(SubId); + + Emit_POP_REGS; +end; + +procedure TEmitter.EmitOP_SHORTSTRING_FROM_WIDESTRING_64; +var + T1, L1, SubId, Reg: Integer; +begin + SubId := Id_ShortStringFromWideString; + + EmitPCodeOperator; + Emit_PUSH_REGS; + + EmitCallPro(SubId); + + Reg := GetRegEx; + + T1 := SymbolRec1.TerminalTypeID; + L1 := GetSymbolRec(T1).Count; + if T1 = typeSHORTSTRING then + L1 := 255; + + EmitLoadAddress(Reg, SymbolRec1); // string dest + Prg.AsmMovREG_REG(_ECX, Reg); + + Prg.AsmMovREG_Imm(Reg, L1); + Prg.AsmMovREG_REG(_EDX, Reg); + Prg.AsmMovREG_REG(_R8, Reg); + + EmitLoadAddress(Reg, SymbolRec2); // string source + Prg.AsmMovREG_REG(_R9, Reg); + + FreeReg(Reg); + EmitStdCall(SubId); + + Emit_POP_REGS; +end; +procedure TEmitter.EmitOP_SHORTSTRING_FROM_WIDESTRING; +var + T1, L1, SubId, Reg: Integer; +begin + SubId := Id_ShortStringFromWideString; + + EmitPCodeOperator; + Emit_PUSH_REGS; + + EmitCallPro(SubId); + + T1 := SymbolRec1.TerminalTypeID; + L1 := GetSymbolRec(T1).Count; + if T1 = typeSHORTSTRING then + L1 := 255; + + Reg := GetReg; + EmitLoadAddress(Reg, SymbolRec2); // string source + Prg.AsmPush_REG(Reg); + Prg.AsmPush_Imm(L1); + Prg.AsmPush_Imm(L1); + EmitLoadAddress(Reg, SymbolRec1); // string dest + Prg.AsmPush_REG(Reg); + + FreeReg(Reg); + EmitStdCall(SubId); + + Emit_POP_REGS; +end; + +procedure TEmitter.EmitOP_SHORTSTRING_FROM_UNICSTRING_64; +var + T1, L1, SubId, Reg: Integer; +begin + SubId := Id_ShortStringFromUnicString; + + EmitPCodeOperator; + Emit_PUSH_REGS; + + EmitCallPro(SubId); + + Reg := GetRegEx; + + T1 := SymbolRec1.TerminalTypeID; + L1 := GetSymbolRec(T1).Count; + if T1 = typeSHORTSTRING then + L1 := 255; + + EmitLoadAddress(Reg, SymbolRec1); // string dest + Prg.AsmMovREG_REG(_ECX, Reg); + + Prg.AsmMovREG_Imm(Reg, L1); + Prg.AsmMovREG_REG(_EDX, Reg); + Prg.AsmMovREG_REG(_R8, Reg); + + EmitLoadAddress(Reg, SymbolRec2); // string source + Prg.AsmMovREG_REG(_R9, Reg); + + FreeReg(Reg); + EmitStdCall(SubId); + + Emit_POP_REGS; +end; +procedure TEmitter.EmitOP_SHORTSTRING_FROM_UNICSTRING; +var + T1, L1, SubId, Reg: Integer; +begin + SubId := Id_ShortStringFromUnicString; + + EmitPCodeOperator; + Emit_PUSH_REGS; + + EmitCallPro(SubId); + + T1 := SymbolRec1.TerminalTypeID; + L1 := GetSymbolRec(T1).Count; + if T1 = typeSHORTSTRING then + L1 := 255; + + Reg := GetReg; + EmitLoadAddress(Reg, SymbolRec2); // string source + Prg.AsmPush_REG(Reg); + Prg.AsmPush_Imm(L1); + Prg.AsmPush_Imm(L1); + EmitLoadAddress(Reg, SymbolRec1); // string dest + Prg.AsmPush_REG(Reg); + + FreeReg(Reg); + EmitStdCall(SubId); + + Emit_POP_REGS; +end; +{$ENDIF} +procedure TEmitter.EmitOP_ANSISTRING_FROM_SHORTSTRING_64; +begin + EmitStdCall_Adr1_from_Adr2(Id_AnsiStringFromShortString); +end; +procedure TEmitter.EmitOP_ANSISTRING_FROM_SHORTSTRING; +begin + EmitStdCall_Adr1_from_Adr2(Id_AnsiStringFromShortString); +end; + +procedure TEmitter.EmitOP_UNICSTRING_FROM_WIDESTRING_64; +begin + EmitStdCall_Adr1_from_Adr2(Id_UnicStringFromWideString); +end; +procedure TEmitter.EmitOP_UNICSTRING_FROM_WIDESTRING; +begin + EmitStdCall_Adr1_from_Adr2(Id_UnicStringFromWideString); +end; + +procedure TEmitter.EmitOP_WIDESTRING_FROM_SHORTSTRING_64; +begin + EmitStdCall_Adr1_from_Adr2(Id_WideStringFromShortString); +end; +procedure TEmitter.EmitOP_WIDESTRING_FROM_SHORTSTRING; +begin + EmitStdCall_Adr1_from_Adr2(Id_WideStringFromShortString); +end; + +procedure TEmitter.EmitOP_WIDESTRING_FROM_UNICSTRING_64; +begin + EmitStdCall_Adr1_from_Adr2(Id_WideStringFromUnicString); +end; +procedure TEmitter.EmitOP_WIDESTRING_FROM_UNICSTRING; +begin + EmitStdCall_Adr1_from_Adr2(Id_WideStringFromUnicString); +end; + +procedure TEmitter.EmitOP_UNICSTRING_FROM_SHORTSTRING_64; +begin + EmitStdCall_Adr1_from_Adr2(Id_UnicStringFromShortString); +end; +procedure TEmitter.EmitOP_UNICSTRING_FROM_SHORTSTRING; +begin + EmitStdCall_Adr1_from_Adr2(Id_UnicStringFromShortString); +end; + +procedure TEmitter.EmitOP_ANSISTRING_FROM_WIDESTRING_64; +begin + EmitStdCall_Adr1_from_Adr2(Id_AnsiStringFromWideString); +end; +procedure TEmitter.EmitOP_ANSISTRING_FROM_WIDESTRING; +begin + EmitStdCall_Adr1_from_Adr2(Id_AnsiStringFromWideString); +end; + +procedure TEmitter.EmitOP_ANSISTRING_FROM_UNICSTRING_64; +begin + EmitStdCall_Adr1_from_Adr2(Id_AnsiStringFromUnicString); +end; +procedure TEmitter.EmitOP_ANSISTRING_FROM_UNICSTRING; +begin + EmitStdCall_Adr1_from_Adr2(Id_AnsiStringFromUnicString); +end; + +procedure TEmitter.EmitOP_WIDESTRING_FROM_ANSISTRING_64; +begin + EmitStdCall_Adr1_from_Adr2(Id_WideStringFromAnsiString); +end; +procedure TEmitter.EmitOP_WIDESTRING_FROM_ANSISTRING; +begin + EmitStdCall_Adr1_from_Adr2(Id_WideStringFromAnsiString); +end; + +procedure TEmitter.EmitOP_UNICSTRING_FROM_ANSISTRING_64; +begin + EmitStdCall_Adr1_from_Adr2(Id_UnicStringFromAnsiString); +end; +procedure TEmitter.EmitOP_UNICSTRING_FROM_ANSISTRING; +begin + EmitStdCall_Adr1_from_Adr2(Id_UnicStringFromAnsiString); +end; + +procedure TEmitter.EmitOP_INTERFACE_CAST_64; +var + SubId, Reg: Integer; + GuidId: Integer; +begin + EmitPCodeOperator; + + SubId := Id_InterfaceCast; + EmitCallPro(SubId); + + GuidId := SymbolRec2.TerminalTypeId + 1; + + EmitPCodeOperator; + + Reg := GetRegEx; + + EmitLoadAddress(Reg, SymbolRecR); // interface dest + Prg.AsmMovREG_REG(_ECX, Reg); + + EmitLoadAddress(Reg, GetSymbolRec(GuidId)); + Prg.AsmMovREG_REG(_EDX, Reg); + + EmitLoadAddress(Reg, SymbolRec1); // interface source + Prg.AsmMovREG_REG(_R8, Reg); + + FreeReg(Reg); + EmitStdCall(SubId); +end; +procedure TEmitter.EmitOP_INTERFACE_CAST; +var + SubId, Reg: Integer; + GuidId: Integer; +begin + EmitPCodeOperator; + + SubId := Id_InterfaceCast; + + GuidId := SymbolRec2.TerminalTypeId + 1; + + EmitCallPro(SubId); + + Reg := GetReg; + + EmitLoadAddress(Reg, SymbolRec1); // interface source + Prg.AsmPush_REG(Reg); + + EmitLoadAddress(Reg, GetSymbolRec(GuidId)); + Prg.AsmPush_REG(Reg); + + EmitLoadAddress(Reg, SymbolRecR); // interface dest + Prg.AsmPush_REG(Reg); + + FreeReg(Reg); + EmitStdCall(SubId); +end; + +procedure TEmitter.EmitOP_INTERFACE_FROM_CLASS_64; +var + SubId, Reg: Integer; + GuidId: Integer; +begin + SubId := Id_InterfaceFromClass; + + GuidId := SymbolRec1.TerminalTypeId + 1; + + EmitPCodeOperator; + + Emit_PUSH_REGS; + + EmitCallPro(SubId); + + Reg := GetRegEx; + + EmitLoadAddress(Reg, SymbolRec1); // interface dest + Prg.AsmMovREG_REG(_ECX, Reg); + + EmitLoadAddress(Reg, GetSymbolRec(GuidId)); + Prg.AsmMovREG_REG(_EDX, Reg); + + EmitLoadAddress(Reg, SymbolRec2); // object + Prg.AsmMovREG_REG(_R8, Reg); + + FreeReg(Reg); + EmitStdCall(SubId); + + Emit_POP_REGS; +end; +procedure TEmitter.EmitOP_INTERFACE_FROM_CLASS; +var + SubId, Reg: Integer; + GuidId: Integer; +begin + SubId := Id_InterfaceFromClass; + + GuidId := SymbolRec1.TerminalTypeId + 1; + + EmitPCodeOperator; + Emit_PUSH_REGS; + + EmitCallPro(SubId); + + Reg := GetReg; + + EmitLoadAddress(Reg, SymbolRec2); // object + Prg.AsmPush_REG(Reg); + + EmitLoadAddress(Reg, GetSymbolRec(GuidId)); + Prg.AsmPush_REG(Reg); + + EmitLoadAddress(Reg, SymbolRec1); // interface dest + Prg.AsmPush_REG(Reg); + + FreeReg(Reg); + EmitStdCall(SubId); + + Emit_POP_REGS; +end; + +procedure TEmitter.EmitOP_ASSIGN_INTERFACE_64; +begin + EmitStdCall_Adr1_from_Adr2(Id_InterfaceAssign); +end; +procedure TEmitter.EmitOP_ASSIGN_INTERFACE; +begin + EmitStdCall_Adr1_from_Adr2(Id_InterfaceAssign); +end; + +procedure TEmitter.EmitOP_VARIANT_FROM_CLASS_64; +begin + EmitStdCall_Adr1_from_Adr2(Id_VariantFromClass); +end; +procedure TEmitter.EmitOP_VARIANT_FROM_CLASS; +begin + EmitStdCall_Adr1_from_Adr2(Id_VariantFromClass); +end; + +procedure TEmitter.EmitOP_CLASS_FROM_VARIANT_64; +begin + EmitStdCall_AdrR_from_Adr2(Id_ClassFromVariant); +end; +procedure TEmitter.EmitOP_CLASS_FROM_VARIANT; +begin + EmitStdCall_AdrR_from_Adr2(Id_ClassFromVariant); +end; + +procedure TEmitter.EmitOP_VARIANT_FROM_POINTER_64; +begin + EmitStdCall_Adr1_from_Adr2(Id_VariantFromPointer); +end; +procedure TEmitter.EmitOP_VARIANT_FROM_POINTER; +begin + EmitStdCall_Adr1_from_Adr2(Id_VariantFromPointer); +end; + +procedure TEmitter.EmitOP_VARIANT_FROM_ANSISTRING_64; +begin + EmitStdCall_Adr1_from_Adr2(Id_VariantFromAnsiString); +end; +procedure TEmitter.EmitOP_VARIANT_FROM_ANSISTRING; +begin + EmitStdCall_Adr1_from_Adr2(Id_VariantFromAnsiString); +end; + +procedure TEmitter.EmitOP_OLEVARIANT_FROM_ANSISTRING_64; +begin + EmitStdCall_Adr1_from_Adr2(Id_OleVariantFromAnsiString); +end; +procedure TEmitter.EmitOP_OLEVARIANT_FROM_ANSISTRING; +begin + EmitStdCall_Adr1_from_Adr2(Id_OleVariantFromAnsiString); +end; + +procedure TEmitter.EmitOP_OLEVARIANT_FROM_VARIANT_64; +begin + EmitStdCall_Adr1_from_Adr2(Id_OleVariantFromVariant); +end; +procedure TEmitter.EmitOP_OLEVARIANT_FROM_VARIANT; +begin + EmitStdCall_Adr1_from_Adr2(Id_OleVariantFromVariant); +end; + +procedure TEmitter.EmitOP_VARIANT_FROM_WIDESTRING_64; +begin + EmitStdCall_Adr1_from_Adr2(Id_VariantFromWideString); +end; +procedure TEmitter.EmitOP_VARIANT_FROM_WIDESTRING; +begin + EmitStdCall_Adr1_from_Adr2(Id_VariantFromWideString); +end; + +procedure TEmitter.EmitOP_VARIANT_FROM_UNICSTRING_64; +begin + EmitStdCall_Adr1_from_Adr2(Id_VariantFromUnicString); +end; +procedure TEmitter.EmitOP_VARIANT_FROM_UNICSTRING; +begin + EmitStdCall_Adr1_from_Adr2(Id_VariantFromUnicString); +end; + +procedure TEmitter.EmitOP_OLEVARIANT_FROM_WIDESTRING_64; +begin + EmitStdCall_Adr1_from_Adr2(Id_OleVariantFromWideString); +end; +procedure TEmitter.EmitOP_OLEVARIANT_FROM_WIDESTRING; +begin + EmitStdCall_Adr1_from_Adr2(Id_OleVariantFromWideString); +end; + +procedure TEmitter.EmitOP_OLEVARIANT_FROM_UNICSTRING_64; +begin + EmitStdCall_Adr1_from_Adr2(Id_OleVariantFromUnicString); +end; +procedure TEmitter.EmitOP_OLEVARIANT_FROM_UNICSTRING; +begin + EmitStdCall_Adr1_from_Adr2(Id_OleVariantFromUnicString); +end; + +procedure TEmitter.EmitOP_VARIANT_FROM_SHORTSTRING_64; +begin + EmitStdCall_Adr1_from_Adr2(Id_VariantFromShortString); +end; +procedure TEmitter.EmitOP_VARIANT_FROM_SHORTSTRING; +begin + EmitStdCall_Adr1_from_Adr2(Id_VariantFromShortString); +end; + +procedure TEmitter.EmitOP_OLEVARIANT_FROM_SHORTSTRING_64; +begin + EmitStdCall_Adr1_from_Adr2(Id_OleVariantFromShortString); +end; +procedure TEmitter.EmitOP_OLEVARIANT_FROM_SHORTSTRING; +begin + EmitStdCall_Adr1_from_Adr2(Id_OleVariantFromShortString); +end; + +procedure TEmitter.EmitOP_SHORTSTRING_FROM_ANSICHAR_64; +var + Reg1, Reg2: Integer; +begin + EmitPCodeOperator; + + Reg1 := GetReg; + Reg2 := GetReg; + + Prg.AsmMovREG_Imm(Reg2, 1); + EmitLoadAddress(Reg1, SymbolRec1); // string dest + Prg.AsmMovREGPtr_REG8(Reg1, Reg2); // s[0] := length + EmitGet_REG(Reg2, SymbolRec2); // char + + Prg.AsmAddREG_Imm(Reg1, 1); + Prg.AsmMovREGPtr_REG8(Reg1, Reg2); + + FreeReg(Reg1); + FreeReg(Reg2); +end; +procedure TEmitter.EmitOP_SHORTSTRING_FROM_ANSICHAR; +var + Reg1, Reg2: Integer; +begin + EmitPCodeOperator; + + Reg1 := GetReg; + Reg2 := GetReg; + + Prg.AsmMovREG_Imm(Reg2, 1); + EmitLoadAddress(Reg1, SymbolRec1); // string dest + Prg.AsmMovREGPtr_REG8(Reg1, Reg2); // s[0] := length + EmitGet_REG(Reg2, SymbolRec2); // char + + Prg.AsmAddREG_Imm(Reg1, 1); + Prg.AsmMovREGPtr_REG8(Reg1, Reg2); + + FreeReg(Reg1); + FreeReg(Reg2); +end; + +procedure TEmitter.EmitOP_SHORTSTRING_FROM_WIDECHAR_64; +var + Reg1, Reg2: Integer; +begin + EmitPCodeOperator; + + Reg1 := GetReg; + Reg2 := GetReg; + + Prg.AsmMovREG_Imm(Reg2, 1); + EmitLoadAddress(Reg1, SymbolRec1); // string dest + Prg.AsmMovREGPtr_REG8(Reg1, Reg2); // s[0] := length + EmitGet_REG(Reg2, SymbolRec2); // char + + Prg.AsmAddREG_Imm(Reg1, 1); + Prg.AsmMovREGPtr_REG8(Reg1, Reg2); + + FreeReg(Reg1); + FreeReg(Reg2); +end; +procedure TEmitter.EmitOP_SHORTSTRING_FROM_WIDECHAR; +var + Reg1, Reg2: Integer; +begin + EmitPCodeOperator; + + Reg1 := GetReg; + Reg2 := GetReg; + + Prg.AsmMovREG_Imm(Reg2, 1); + EmitLoadAddress(Reg1, SymbolRec1); // string dest + Prg.AsmMovREGPtr_REG8(Reg1, Reg2); // s[0] := length + EmitGet_REG(Reg2, SymbolRec2); // char + + Prg.AsmAddREG_Imm(Reg1, 1); + Prg.AsmMovREGPtr_REG8(Reg1, Reg2); + + FreeReg(Reg1); + FreeReg(Reg2); +end; + +procedure TEmitter.EmitOP_BEGIN_CRT_JS_FUNC_OBJECT_64; +begin + EmitPCodeOperator; +end; +procedure TEmitter.EmitOP_BEGIN_CRT_JS_FUNC_OBJECT; +begin + EmitPCodeOperator; +end; + +procedure TEmitter.EmitOP_END_CRT_JS_FUNC_OBJECT_64; +begin + EmitPCodeOperator; +end; +procedure TEmitter.EmitOP_END_CRT_JS_FUNC_OBJECT; +begin + EmitPCodeOperator; +end; + +procedure TEmitter.EmitOP_LOAD_PROC_64; +var + SubId, Reg, SubShift, OverCount: Integer; +begin + EmitPCodeOperator; + + Prg.AsmSubReg_Imm(_ESP, $100); + + Emit_PUSH_REGS; + + SubId := Id_LoadProc; + EmitCallPro(SubId); + + SymbolRec1.Host := true; + + SubShift := GetOffset(SymbolRec1); + OverCount := SymbolRec1.OverCount; + + Reg := GetRegEx; + + Prg.AsmMovREG_REG(Reg, _ESI); + Prg.AsmAddREG_Imm(Reg, H_SelfPtr); + Prg.AsmMovREG_REGPtr(Reg, Reg); // load TProgram.Self + Prg.AsmMovREG_REG(_ECX, Reg); + + Prg.AsmMovREG_Imm(Reg, SubShift); + Prg.AsmMovREG_REG(_EDX, Reg); + + EmitGet_REG(Reg, SymbolRec2); // proc name (pchar const) + Prg.AsmMovREG_REG(_R8, Reg); + + EmitGet_REG(Reg, SymbolRecR); // dll name (pchar const) + Prg.AsmMovREG_REG(_R9, Reg); + + Prg.AsmMovREG_Imm(Reg, OverCount); + Prg.AsmMovRSPPtr_REG64(Reg, $20); + + FreeReg(Reg); + EmitStdCall(SubId); + + Emit_POP_REGS; + + Prg.AsmAddReg_Imm(_ESP, $100); + +end; +procedure TEmitter.EmitOP_LOAD_PROC; +var + SubId, Reg, SubShift, OverCount: Integer; +begin + EmitPCodeOperator; + + Emit_PUSH_REGS; + + SubId := Id_LoadProc; + EmitCallPro(SubId); + + SymbolRec1.Host := true; + + SubShift := GetOffset(SymbolRec1); + OverCount := SymbolRec1.OverCount; + + Reg := GetRegEx; + + Prg.AsmPush_Imm(OverCount); + + EmitGet_REG(Reg, SymbolRecR); // dll name (pchar const) + Prg.AsmPush_REG(Reg); + + EmitGet_REG(Reg, SymbolRec2); // proc name (pchar const) + Prg.AsmPush_REG(Reg); + + Prg.AsmPush_Imm(SubShift); + + Prg.AsmMovREG_REG(Reg, _ESI); + Prg.AsmAddREG_Imm(Reg, H_SelfPtr); + Prg.AsmMovREG_REGPtr(Reg, Reg); // load TProgram.Self + Prg.AsmPush_REG(Reg); + + FreeReg(Reg); + EmitStdCall(SubId); + + Emit_POP_REGS; +end; + +procedure TEmitter.EmitOP_ADD_MESSAGE_64; +var + SubId, Reg: Integer; +begin + EmitPCodeOperator; + + SubId := Id_AddMessage; + EmitCallPro(SubId); + + Reg := GetRegEx; + + Prg.AsmMovREG_REG(Reg, _ESI); + Prg.AsmAddREG_Imm(Reg, H_SelfPtr); + Prg.AsmMovREG_REGPtr(Reg, Reg); // load TProgram.Self + Prg.AsmMovREG_REG(_ECX, Reg); + + EmitLoadIntVal(Reg, SymbolRec2); // message id + Prg.AsmMovREG_REG(_EDX, Reg); + + EmitGet_REG(Reg, SymbolRecR); // FullName (pchar const) + Prg.AsmMovREG_REG(_R8, Reg); + + FreeReg(Reg); + EmitStdCall(SubId); +end; +procedure TEmitter.EmitOP_ADD_MESSAGE; +var + SubId, Reg: Integer; +begin + EmitPCodeOperator; + + SubId := Id_AddMessage; + EmitCallPro(SubId); + + Reg := GetReg; + + EmitGet_REG(Reg, SymbolRecR); // FullName (pchar const) + Prg.AsmPush_REG(Reg); + + EmitLoadIntVal(Reg, SymbolRec2); // message id + Prg.AsmPush_REG(Reg); + + Prg.AsmMovREG_REG(Reg, _ESI); + Prg.AsmAddREG_Imm(Reg, H_SelfPtr); + Prg.AsmMovREG_REGPtr(Reg, Reg); // load TProgram.Self + Prg.AsmPush_REG(Reg); + + FreeReg(Reg); + EmitStdCall(SubId); +end; + +procedure TEmitter.EmitOP_VAR_FROM_TVALUE_64; +var + SubId, Reg, T: Integer; +begin + EmitPCodeOperator; + Emit_PUSH_REGS; + + SubId := Id_VarFromTValue; + EmitCallPro(SubId); + + if SubId <= 0 then + RaiseError(errInternalError, []); + + Reg := GetRegEx; + + EmitLoadAddress(Reg, SymbolRec2); // source + Prg.AsmMovREG_REG(_ECX, Reg); + + T := SymbolRec1.FinalTypeId; + Prg.AsmMovREG_Imm(Reg, T); + Prg.AsmMovREG_REG(_EDX, Reg); + + EmitLoadAddress(Reg, SymbolRec1); // dest + Prg.AsmMovREG_REG(_R8, Reg); + + FreeReg(Reg); + EmitStdCall(SubId); + + Emit_POP_REGS; +end; +procedure TEmitter.EmitOP_VAR_FROM_TVALUE; +var + SubId, Reg, T: Integer; +begin + EmitPCodeOperator; + Emit_PUSH_REGS; + + SubId := Id_VarFromTValue; + EmitCallPro(SubId); + + if SubId <= 0 then + RaiseError(errInternalError, []); + + Reg := GetRegEx; + + EmitLoadAddress(Reg, SymbolRec1); // dest + Prg.AsmPush_REG(Reg); + + T := SymbolRec1.FinalTypeId; + Prg.AsmPush_Imm(T); + + EmitLoadAddress(Reg, SymbolRec2); // source + Prg.AsmPush_REG(Reg); + + FreeReg(Reg); + EmitStdCall(SubId); + + Emit_POP_REGS; +end; + +procedure TEmitter.EmitOP_ANSISTRING_FROM_PANSICHAR_64; +var + SubId, Reg: Integer; +begin + EmitPCodeOperator; + Emit_PUSH_REGS; + + SubId := Id_AnsiStringFromPAnsiChar; + EmitCallPro(SubId); + + Reg := GetRegEx; + + EmitGet_REG(Reg, SymbolRec2); // pchar source + Prg.AsmMovREG_REG(_ECX, Reg); + + EmitLoadAddress(Reg, SymbolRec1); // string dest + Prg.AsmMovREG_REG(_EDX, Reg); + + FreeReg(Reg); + EmitStdCall(SubId); + + Emit_POP_REGS; +end; +procedure TEmitter.EmitOP_ANSISTRING_FROM_PANSICHAR; +var + SubId, Reg: Integer; +begin + EmitPCodeOperator; + Emit_PUSH_REGS; + + SubId := Id_AnsiStringFromPAnsiChar; + EmitCallPro(SubId); + + Reg := GetRegEx; + + EmitLoadAddress(Reg, SymbolRec1); // string dest + Prg.AsmPush_REG(Reg); + + EmitGet_REG(Reg, SymbolRec2); // pchar source + Prg.AsmPush_REG(Reg); + + FreeReg(Reg); + EmitStdCall(SubId); + + Emit_POP_REGS; +end; + +procedure TEmitter.EmitOP_ANSISTRING_FROM_PWIDECHAR_64; +var + SubId, Reg: Integer; +begin + EmitPCodeOperator; + Emit_PUSH_REGS; + + SubId := Id_AnsiStringFromPWideChar; + EmitCallPro(SubId); + + Reg := GetRegEx; + + EmitGet_REG(Reg, SymbolRec2); // pchar source + Prg.AsmMovREG_REG(_ECX, Reg); + + EmitLoadAddress(Reg, SymbolRec1); // string dest + Prg.AsmMovREG_REG(_EDX, Reg); + + FreeReg(Reg); + EmitStdCall(SubId); + + Emit_POP_REGS; +end; +procedure TEmitter.EmitOP_ANSISTRING_FROM_PWIDECHAR; +var + SubId, Reg: Integer; +begin + EmitPCodeOperator; + Emit_PUSH_REGS; + + SubId := Id_AnsiStringFromPWideChar; + EmitCallPro(SubId); + + Reg := GetRegEx; + + EmitLoadAddress(Reg, SymbolRec1); // string dest + Prg.AsmPush_REG(Reg); + + EmitGet_REG(Reg, SymbolRec2); // pchar source + Prg.AsmPush_REG(Reg); + + FreeReg(Reg); + EmitStdCall(SubId); + + Emit_POP_REGS; +end; + +procedure TEmitter.EmitOP_ERR_ABSTRACT_64; +var + SubId, Reg: Integer; +begin + EmitPCodeOperator; + + SubId := Id_ErrAbstract; + EmitCallPro(SubId); + + Reg := GetRegEx; + + EmitGet_REG(Reg, SymbolRec1); // pchar source + Prg.AsmMovREG_REG(_ECX, Reg); + + FreeReg(Reg); + EmitStdCall(SubId); +end; +procedure TEmitter.EmitOP_ERR_ABSTRACT; +var + SubId, Reg: Integer; +begin + EmitPCodeOperator; + + SubId := Id_ErrAbstract; + EmitCallPro(SubId); + + Reg := GetRegEx; + + EmitGet_REG(Reg, SymbolRec1); // pchar source + Prg.AsmPush_REG(Reg); + + FreeReg(Reg); + EmitStdCall(SubId); +end; + +procedure TEmitter.EmitOP_ANSISTRING_FROM_ANSICHAR_64; +begin + EmitStdCall_Adr1_from_Int2(Id_AnsiStringFromAnsiChar); +end; +procedure TEmitter.EmitOP_ANSISTRING_FROM_ANSICHAR; +begin + EmitStdCall_Adr1_from_Int2(Id_AnsiStringFromAnsiChar); +end; + +procedure TEmitter.EmitOP_WIDESTRING_FROM_ANSICHAR_64; +begin + EmitStdCall_Adr1_from_Int2(Id_WideStringFromAnsiChar); +end; +procedure TEmitter.EmitOP_WIDESTRING_FROM_ANSICHAR; +begin + EmitStdCall_Adr1_from_Int2(Id_WideStringFromAnsiChar); +end; + +procedure TEmitter.EmitOP_UNICSTRING_FROM_ANSICHAR_64; +begin + EmitStdCall_Adr1_from_Int2(Id_UnicStringFromAnsiChar); +end; +procedure TEmitter.EmitOP_UNICSTRING_FROM_ANSICHAR; +begin + EmitStdCall_Adr1_from_Int2(Id_UnicStringFromAnsiChar); +end; + +procedure TEmitter.EmitOP_VARIANT_FROM_ANSICHAR_64; +begin + EmitStdCall_Adr1_from_Int2(Id_VariantFromAnsiChar); +end; +procedure TEmitter.EmitOP_VARIANT_FROM_ANSICHAR; +begin + EmitStdCall_Adr1_from_Int2(Id_VariantFromAnsiChar); +end; + +procedure TEmitter.EmitOP_OLEVARIANT_FROM_ANSICHAR_64; +begin + EmitStdCall_Adr1_from_Int2(Id_OleVariantFromAnsiChar); +end; +procedure TEmitter.EmitOP_OLEVARIANT_FROM_ANSICHAR; +begin + EmitStdCall_Adr1_from_Int2(Id_OleVariantFromAnsiChar); +end; + +procedure TEmitter.EmitOP_VARIANT_FROM_INT_64; +begin + EmitStdCall_Adr1_from_Int2(Id_VariantFromInt); +end; +procedure TEmitter.EmitOP_VARIANT_FROM_INT; +begin + EmitStdCall_Adr1_from_Int2(Id_VariantFromInt); +end; + +procedure TEmitter.EmitOP_OLEVARIANT_FROM_INT_64; +begin + EmitStdCall_Adr1_from_Int2(Id_OleVariantFromInt); +end; +procedure TEmitter.EmitOP_OLEVARIANT_FROM_INT; +begin + EmitStdCall_Adr1_from_Int2(Id_OleVariantFromInt); +end; + +procedure TEmitter.EmitOP_VARIANT_FROM_INTERFACE_64; +begin + EmitStdCall_Adr1_from_Int2(Id_VariantFromInterface); +end; +procedure TEmitter.EmitOP_VARIANT_FROM_INTERFACE; +begin + EmitStdCall_Adr1_from_Int2(Id_VariantFromInterface); +end; + +procedure TEmitter.EmitOP_OLEVARIANT_FROM_INTERFACE_64; +begin + EmitStdCall_Adr1_from_Int2(Id_OleVariantFromInterface); +end; +procedure TEmitter.EmitOP_OLEVARIANT_FROM_INTERFACE; +begin + EmitStdCall_Adr1_from_Int2(Id_OleVariantFromInterface); +end; + +procedure TEmitter.EmitOP_VARIANT_FROM_INT64_64; +begin + EmitStdCall_Adr1_from_Adr2(Id_VariantFromInt64); +end; +procedure TEmitter.EmitOP_VARIANT_FROM_INT64; +begin + EmitStdCall_Adr1_from_Adr2(Id_VariantFromInt64); +end; + +procedure TEmitter.EmitOP_OLEVARIANT_FROM_INT64_64; +begin + EmitStdCall_Adr1_from_Adr2(Id_OleVariantFromInt64); +end; +procedure TEmitter.EmitOP_OLEVARIANT_FROM_INT64; +begin + EmitStdCall_Adr1_from_Adr2(Id_OleVariantFromInt64); +end; + +procedure TEmitter.EmitOP_VARIANT_FROM_BYTE_64; +begin + EmitStdCall_Adr1_from_Int2(Id_VariantFromByte); +end; +procedure TEmitter.EmitOP_VARIANT_FROM_BYTE; +begin + EmitStdCall_Adr1_from_Int2(Id_VariantFromByte); +end; + +procedure TEmitter.EmitOP_OLEVARIANT_FROM_BYTE_64; +begin + EmitStdCall_Adr1_from_Int2(Id_OleVariantFromByte); +end; +procedure TEmitter.EmitOP_OLEVARIANT_FROM_BYTE; +begin + EmitStdCall_Adr1_from_Int2(Id_OleVariantFromByte); +end; + +procedure TEmitter.EmitOP_VARIANT_FROM_BOOL_64; +begin + EmitStdCall_Adr1_from_Int2(Id_VariantFromBool); +end; +procedure TEmitter.EmitOP_VARIANT_FROM_BOOL; +begin + EmitStdCall_Adr1_from_Int2(Id_VariantFromBool); +end; + +procedure TEmitter.EmitOP_OLEVARIANT_FROM_BOOL_64; +begin + EmitStdCall_Adr1_from_Int2(Id_OleVariantFromBool); +end; +procedure TEmitter.EmitOP_OLEVARIANT_FROM_BOOL; +begin + EmitStdCall_Adr1_from_Int2(Id_OleVariantFromBool); +end; + +procedure TEmitter.EmitOP_VARIANT_FROM_WORD_64; +begin + EmitStdCall_Adr1_from_Int2(Id_VariantFromWord); +end; +procedure TEmitter.EmitOP_VARIANT_FROM_WORD; +begin + EmitStdCall_Adr1_from_Int2(Id_VariantFromWord); +end; + +procedure TEmitter.EmitOP_OLEVARIANT_FROM_WORD_64; +begin + EmitStdCall_Adr1_from_Int2(Id_OleVariantFromWord); +end; +procedure TEmitter.EmitOP_OLEVARIANT_FROM_WORD; +begin + EmitStdCall_Adr1_from_Int2(Id_OleVariantFromWord); +end; + +procedure TEmitter.EmitOP_VARIANT_FROM_CARDINAL_64; +begin + EmitStdCall_Adr1_from_Int2(Id_VariantFromCardinal); +end; +procedure TEmitter.EmitOP_VARIANT_FROM_CARDINAL; +begin + EmitStdCall_Adr1_from_Int2(Id_VariantFromCardinal); +end; + +procedure TEmitter.EmitOP_OLEVARIANT_FROM_CARDINAL_64; +begin + EmitStdCall_Adr1_from_Int2(Id_OleVariantFromCardinal); +end; +procedure TEmitter.EmitOP_OLEVARIANT_FROM_CARDINAL; +begin + EmitStdCall_Adr1_from_Int2(Id_OleVariantFromCardinal); +end; + +procedure TEmitter.EmitOP_VARIANT_FROM_SMALLINT_64; +begin + EmitStdCall_Adr1_from_Int2(Id_VariantFromSmallInt); +end; +procedure TEmitter.EmitOP_VARIANT_FROM_SMALLINT; +begin + EmitStdCall_Adr1_from_Int2(Id_VariantFromSmallInt); +end; + +procedure TEmitter.EmitOP_OLEVARIANT_FROM_SMALLINT_64; +begin + EmitStdCall_Adr1_from_Int2(Id_OleVariantFromSmallInt); +end; +procedure TEmitter.EmitOP_OLEVARIANT_FROM_SMALLINT; +begin + EmitStdCall_Adr1_from_Int2(Id_OleVariantFromSmallInt); +end; + +procedure TEmitter.EmitOP_VARIANT_FROM_SHORTINT_64; +begin + EmitStdCall_Adr1_from_Int2(Id_VariantFromShortInt); +end; +procedure TEmitter.EmitOP_VARIANT_FROM_SHORTINT; +begin + EmitStdCall_Adr1_from_Int2(Id_VariantFromShortInt); +end; + +procedure TEmitter.EmitOP_OLEVARIANT_FROM_SHORTINT_64; +begin + EmitStdCall_Adr1_from_Int2(Id_OleVariantFromShortInt); +end; +procedure TEmitter.EmitOP_OLEVARIANT_FROM_SHORTINT; +begin + EmitStdCall_Adr1_from_Int2(Id_OleVariantFromShortInt); +end; + +procedure TEmitter.EmitOP_VARIANT_FROM_DOUBLE_64; +begin + EmitStdCall_Adr1_from_Adr2(Id_VariantFromDouble); +end; +procedure TEmitter.EmitOP_VARIANT_FROM_DOUBLE; +begin + EmitStdCall_Adr1_from_Adr2(Id_VariantFromDouble); +end; + +procedure TEmitter.EmitOP_OLEVARIANT_FROM_DOUBLE_64; +begin + EmitStdCall_Adr1_from_Adr2(Id_OleVariantFromDouble); +end; +procedure TEmitter.EmitOP_OLEVARIANT_FROM_DOUBLE; +begin + EmitStdCall_Adr1_from_Adr2(Id_OleVariantFromDouble); +end; + +procedure TEmitter.EmitOP_VARIANT_FROM_CURRENCY_64; +begin + EmitStdCall_Adr1_from_Adr2(Id_VariantFromCurrency); +end; +procedure TEmitter.EmitOP_VARIANT_FROM_CURRENCY; +begin + EmitStdCall_Adr1_from_Adr2(Id_VariantFromCurrency); +end; + +procedure TEmitter.EmitOP_OLEVARIANT_FROM_CURRENCY_64; +begin + EmitStdCall_Adr1_from_Adr2(Id_OleVariantFromCurrency); +end; +procedure TEmitter.EmitOP_OLEVARIANT_FROM_CURRENCY; +begin + EmitStdCall_Adr1_from_Adr2(Id_OleVariantFromCurrency); +end; + +procedure TEmitter.EmitOP_VARIANT_FROM_SINGLE_64; +begin + EmitStdCall_Adr1_from_Adr2(Id_VariantFromSingle); +end; +procedure TEmitter.EmitOP_VARIANT_FROM_SINGLE; +begin + EmitStdCall_Adr1_from_Adr2(Id_VariantFromSingle); +end; + +procedure TEmitter.EmitOP_OLEVARIANT_FROM_SINGLE_64; +begin + EmitStdCall_Adr1_from_Adr2(Id_OleVariantFromSingle); +end; +procedure TEmitter.EmitOP_OLEVARIANT_FROM_SINGLE; +begin + EmitStdCall_Adr1_from_Adr2(Id_OleVariantFromSingle); +end; + +procedure TEmitter.EmitOP_VARIANT_FROM_EXTENDED_64; +begin + EmitStdCall_Adr1_from_Adr2(Id_VariantFromExtended); +end; +procedure TEmitter.EmitOP_VARIANT_FROM_EXTENDED; +begin + EmitStdCall_Adr1_from_Adr2(Id_VariantFromExtended); +end; + +procedure TEmitter.EmitOP_OLEVARIANT_FROM_EXTENDED_64; +begin + EmitStdCall_Adr1_from_Adr2(Id_OleVariantFromExtended); +end; +procedure TEmitter.EmitOP_OLEVARIANT_FROM_EXTENDED; +begin + EmitStdCall_Adr1_from_Adr2(Id_OleVariantFromExtended); +end; + +procedure TEmitter.EmitOP_ANSISTRING_FROM_INT_64; // JS only +begin + EmitStdCall_AdrR_from_Adr2(Id_AnsiStringFromInt); +end; +procedure TEmitter.EmitOP_ANSISTRING_FROM_INT; // JS only +begin + EmitStdCall_AdrR_from_Adr2(Id_AnsiStringFromInt); +end; + +procedure TEmitter.EmitOP_ANSISTRING_FROM_DOUBLE_64; // JS only +begin + EmitStdCall_AdrR_from_Adr2(Id_AnsiStringFromDouble); +end; +procedure TEmitter.EmitOP_ANSISTRING_FROM_DOUBLE; // JS only +begin + EmitStdCall_AdrR_from_Adr2(Id_AnsiStringFromDouble); +end; + +procedure TEmitter.EmitOP_ANSISTRING_FROM_SINGLE_64; // JS only +begin + EmitStdCall_AdrR_from_Adr2(Id_AnsiStringFromSingle); +end; +procedure TEmitter.EmitOP_ANSISTRING_FROM_SINGLE; // JS only +begin + EmitStdCall_AdrR_from_Adr2(Id_AnsiStringFromSingle); +end; + +procedure TEmitter.EmitOP_ANSISTRING_FROM_EXTENDED_64; // JS only +begin + EmitStdCall_AdrR_from_Adr2(Id_AnsiStringFromExtended); +end; +procedure TEmitter.EmitOP_ANSISTRING_FROM_EXTENDED; // JS only +begin + EmitStdCall_AdrR_from_Adr2(Id_AnsiStringFromExtended); +end; + +procedure TEmitter.EmitOP_ANSISTRING_FROM_BOOLEAN_64; // JS only +begin + EmitStdCall_AdrR_from_Adr2(Id_AnsiStringFromBoolean); +end; +procedure TEmitter.EmitOP_ANSISTRING_FROM_BOOLEAN; // JS only +begin + EmitStdCall_AdrR_from_Adr2(Id_AnsiStringFromBoolean); +end; + +procedure TEmitter.EmitOP_UNICSTRING_FROM_INT_64; // JS only +begin + EmitStdCall_AdrR_from_Adr2(Id_UnicStringFromInt); +end; +procedure TEmitter.EmitOP_UNICSTRING_FROM_INT; // JS only +begin + EmitStdCall_AdrR_from_Adr2(Id_UnicStringFromInt); +end; + +procedure TEmitter.EmitOP_UNICSTRING_FROM_DOUBLE_64; // JS only +begin + EmitStdCall_AdrR_from_Adr2(Id_UnicStringFromDouble); +end; +procedure TEmitter.EmitOP_UNICSTRING_FROM_DOUBLE; // JS only +begin + EmitStdCall_AdrR_from_Adr2(Id_UnicStringFromDouble); +end; + +procedure TEmitter.EmitOP_UNICSTRING_FROM_SINGLE_64; // JS only +begin + EmitStdCall_AdrR_from_Adr2(Id_UnicStringFromSingle); +end; +procedure TEmitter.EmitOP_UNICSTRING_FROM_SINGLE; // JS only +begin + EmitStdCall_AdrR_from_Adr2(Id_UnicStringFromSingle); +end; + +procedure TEmitter.EmitOP_UNICSTRING_FROM_EXTENDED_64; // JS only +begin + EmitStdCall_AdrR_from_Adr2(Id_UnicStringFromExtended); +end; +procedure TEmitter.EmitOP_UNICSTRING_FROM_EXTENDED; // JS only +begin + EmitStdCall_AdrR_from_Adr2(Id_UnicStringFromExtended); +end; + +procedure TEmitter.EmitOP_UNICSTRING_FROM_BOOLEAN_64; // JS only +begin + EmitStdCall_AdrR_from_Adr2(Id_UnicStringFromBoolean); +end; +procedure TEmitter.EmitOP_UNICSTRING_FROM_BOOLEAN; // JS only +begin + EmitStdCall_AdrR_from_Adr2(Id_UnicStringFromBoolean); +end; + +procedure TEmitter.EmitOP_JS_FUNC_OBJ_FROM_VARIANT_64; // JS only +begin + EmitStdCall_Adr1_AdrR(Id_FuncObjFromVariant); +end; +procedure TEmitter.EmitOP_JS_FUNC_OBJ_FROM_VARIANT; // JS only +begin + EmitStdCall_Adr1_AdrR(Id_FuncObjFromVariant); +end; + +procedure TEmitter.EmitOP_ANSICHAR_FROM_VARIANT_64; +begin + EmitStdCall_AdrR_from_Adr2(Id_AnsiCharFromVariant); +end; +procedure TEmitter.EmitOP_ANSICHAR_FROM_VARIANT; +begin + EmitStdCall_AdrR_from_Adr2(Id_AnsiCharFromVariant); +end; + +procedure TEmitter.EmitOP_WIDECHAR_FROM_VARIANT_64; +begin + EmitStdCall_AdrR_from_Adr2(Id_WideCharFromVariant); +end; +procedure TEmitter.EmitOP_WIDECHAR_FROM_VARIANT; +begin + EmitStdCall_AdrR_from_Adr2(Id_WideCharFromVariant); +end; + +procedure TEmitter.EmitOP_ANSISTRING_FROM_VARIANT_64; +begin + EmitStdCall_AdrR_from_Adr2(Id_AnsiStringFromVariant); +end; +procedure TEmitter.EmitOP_ANSISTRING_FROM_VARIANT; +begin + EmitStdCall_AdrR_from_Adr2(Id_AnsiStringFromVariant); +end; + +procedure TEmitter.EmitOP_WIDESTRING_FROM_VARIANT_64; +begin + EmitStdCall_AdrR_from_Adr2(Id_WideStringFromVariant); +end; +procedure TEmitter.EmitOP_WIDESTRING_FROM_VARIANT; +begin + EmitStdCall_AdrR_from_Adr2(Id_WideStringFromVariant); +end; + +procedure TEmitter.EmitOP_UNICSTRING_FROM_VARIANT_64; +begin + EmitStdCall_AdrR_from_Adr2(Id_UnicStringFromVariant); +end; +procedure TEmitter.EmitOP_UNICSTRING_FROM_VARIANT; +begin + EmitStdCall_AdrR_from_Adr2(Id_UnicStringFromVariant); +end; + +{$IFNDEF PAXARM} +procedure TEmitter.EmitOP_SHORTSTRING_FROM_VARIANT_64; +var + T1, L1, SubId, Reg: Integer; +begin + SubId := Id_ShortStringFromVariant; + + EmitPCodeOperator; + Emit_PUSH_REGS; + + EmitCallPro(SubId); + + Reg := GetRegEx; + + T1 := SymbolRec1.TerminalTypeID; + L1 := GetSymbolRec(T1).Count; + if T1 = typeSHORTSTRING then + L1 := 255; + + EmitLoadAddress(Reg, SymbolRec1); // string dest + Prg.AsmMovREG_REG(_ECX, Reg); + + Prg.AsmMovREG_Imm(Reg, L1); + Prg.AsmMovREG_REG(_EDX, Reg); + Prg.AsmMovREG_REG(_R8, Reg); + + EmitLoadAddress(Reg, SymbolRec2); // string source + Prg.AsmMovREG_REG(_R9, Reg); + + FreeReg(Reg); + EmitStdCall(SubId); + + Emit_POP_REGS; +end; +procedure TEmitter.EmitOP_SHORTSTRING_FROM_VARIANT; +var + T1, L1, SubId, Reg: Integer; +begin + SubId := Id_ShortStringFromVariant; + + EmitPCodeOperator; + Emit_PUSH_REGS; + + EmitCallPro(SubId); + + T1 := SymbolRec1.TerminalTypeID; + L1 := GetSymbolRec(T1).Count; + if T1 = typeSHORTSTRING then + L1 := 255; + + Reg := GetReg; + EmitLoadAddress(Reg, SymbolRec2); // string source + Prg.AsmPush_REG(Reg); + Prg.AsmPush_Imm(L1); + Prg.AsmPush_Imm(L1); + EmitLoadAddress(Reg, SymbolRec1); // string dest + Prg.AsmPush_REG(Reg); + + FreeReg(Reg); + EmitStdCall(SubId); + + Emit_POP_REGS; +end; +{$ENDIF} + +procedure TEmitter.EmitOP_DOUBLE_FROM_VARIANT_64; +begin + EmitStdCall_AdrR_from_Adr2(Id_DoubleFromVariant); +end; +procedure TEmitter.EmitOP_DOUBLE_FROM_VARIANT; +begin + EmitStdCall_AdrR_from_Adr2(Id_DoubleFromVariant); +end; + +procedure TEmitter.EmitOP_CURRENCY_FROM_VARIANT_64; +begin + EmitStdCall_AdrR_from_Adr2(Id_CurrencyFromVariant); +end; +procedure TEmitter.EmitOP_CURRENCY_FROM_VARIANT; +begin + EmitStdCall_AdrR_from_Adr2(Id_CurrencyFromVariant); +end; + +procedure TEmitter.EmitOP_SINGLE_FROM_VARIANT_64; +begin + EmitStdCall_AdrR_from_Adr2(Id_SingleFromVariant); +end; +procedure TEmitter.EmitOP_SINGLE_FROM_VARIANT; +begin + EmitStdCall_AdrR_from_Adr2(Id_SingleFromVariant); +end; + +procedure TEmitter.EmitOP_EXTENDED_FROM_VARIANT_64; +begin + EmitStdCall_AdrR_from_Adr2(Id_ExtendedFromVariant); +end; +procedure TEmitter.EmitOP_EXTENDED_FROM_VARIANT; +begin + EmitStdCall_AdrR_from_Adr2(Id_ExtendedFromVariant); +end; + +procedure TEmitter.EmitOP_INT_FROM_VARIANT_64; +begin + EmitStdCall_AdrR_from_Adr2(Id_IntFromVariant); +end; +procedure TEmitter.EmitOP_INT_FROM_VARIANT; +begin + EmitStdCall_AdrR_from_Adr2(Id_IntFromVariant); +end; + +procedure TEmitter.EmitOP_INT64_FROM_VARIANT_64; +begin + EmitStdCall_AdrR_from_Adr2(Id_Int64FromVariant); +end; +procedure TEmitter.EmitOP_INT64_FROM_VARIANT; +begin + EmitStdCall_AdrR_from_Adr2(Id_Int64FromVariant); +end; + +procedure TEmitter.EmitOP_INT_FROM_INT64_64; +var + Reg: Integer; +begin + EmitPCodeOperator; + + Reg := GetReg; + EmitLoadIntVal(Reg, SymbolRec2); + EmitSaveIntVal(Reg, SymbolRecR); + FreeReg(Reg); +end; +procedure TEmitter.EmitOP_INT_FROM_INT64; +var + Reg: Integer; +begin + EmitPCodeOperator; + + Reg := GetReg; + EmitLoadIntVal(Reg, SymbolRec2); + EmitSaveIntVal(Reg, SymbolRecR); + FreeReg(Reg); +end; + +procedure TEmitter.EmitOP_BYTE_FROM_INT64_64; +var + Reg: Integer; +begin + EmitPCodeOperator; + + Reg := GetReg; + EmitLoadIntVal(Reg, SymbolRec2); + EmitSaveIntVal(Reg, SymbolRecR); + FreeReg(Reg); +end; +procedure TEmitter.EmitOP_BYTE_FROM_INT64; +var + Reg: Integer; +begin + EmitPCodeOperator; + + Reg := GetReg; + EmitLoadIntVal(Reg, SymbolRec2); + EmitSaveIntVal(Reg, SymbolRecR); + FreeReg(Reg); +end; + +procedure TEmitter.EmitOP_WORD_FROM_INT64_64; +var + Reg: Integer; +begin + EmitPCodeOperator; + + Reg := GetReg; + EmitLoadIntVal(Reg, SymbolRec2); + EmitSaveIntVal(Reg, SymbolRecR); + FreeReg(Reg); +end; +procedure TEmitter.EmitOP_WORD_FROM_INT64; +var + Reg: Integer; +begin + EmitPCodeOperator; + + Reg := GetReg; + EmitLoadIntVal(Reg, SymbolRec2); + EmitSaveIntVal(Reg, SymbolRecR); + FreeReg(Reg); +end; + +procedure TEmitter.EmitOP_CARDINAL_FROM_INT64_64; +var + Reg: Integer; +begin + EmitPCodeOperator; + + Reg := GetReg; + EmitLoadIntVal(Reg, SymbolRec2); + EmitSaveIntVal(Reg, SymbolRecR); + FreeReg(Reg); +end; +procedure TEmitter.EmitOP_CARDINAL_FROM_INT64; +var + Reg: Integer; +begin + EmitPCodeOperator; + + Reg := GetReg; + EmitLoadIntVal(Reg, SymbolRec2); + EmitSaveIntVal(Reg, SymbolRecR); + FreeReg(Reg); +end; + +procedure TEmitter.EmitOP_SMALLINT_FROM_INT64_64; +var + Reg: Integer; +begin + EmitPCodeOperator; + + Reg := GetReg; + EmitLoadIntVal(Reg, SymbolRec2); + EmitSaveIntVal(Reg, SymbolRecR); + FreeReg(Reg); +end; +procedure TEmitter.EmitOP_SMALLINT_FROM_INT64; +var + Reg: Integer; +begin + EmitPCodeOperator; + + Reg := GetReg; + EmitLoadIntVal(Reg, SymbolRec2); + EmitSaveIntVal(Reg, SymbolRecR); + FreeReg(Reg); +end; + +procedure TEmitter.EmitOP_SHORTINT_FROM_INT64_64; +var + Reg: Integer; +begin + EmitPCodeOperator; + + Reg := GetReg; + EmitLoadIntVal(Reg, SymbolRec2); + EmitSaveIntVal(Reg, SymbolRecR); + FreeReg(Reg); +end; +procedure TEmitter.EmitOP_SHORTINT_FROM_INT64; +var + Reg: Integer; +begin + EmitPCodeOperator; + + Reg := GetReg; + EmitLoadIntVal(Reg, SymbolRec2); + EmitSaveIntVal(Reg, SymbolRecR); + FreeReg(Reg); +end; + +procedure TEmitter.EmitOP_BYTE_FROM_VARIANT_64; +begin + EmitStdCall_AdrR_from_Adr2(Id_ByteFromVariant); +end; +procedure TEmitter.EmitOP_BYTE_FROM_VARIANT; +begin + EmitStdCall_AdrR_from_Adr2(Id_ByteFromVariant); +end; + +procedure TEmitter.EmitOP_WORD_FROM_VARIANT_64; +begin + EmitStdCall_AdrR_from_Adr2(Id_WordFromVariant); +end; +procedure TEmitter.EmitOP_WORD_FROM_VARIANT; +begin + EmitStdCall_AdrR_from_Adr2(Id_WordFromVariant); +end; + +procedure TEmitter.EmitOP_CARDINAL_FROM_VARIANT_64; +begin + EmitStdCall_AdrR_from_Adr2(Id_CardinalFromVariant); +end; +procedure TEmitter.EmitOP_CARDINAL_FROM_VARIANT; +begin + EmitStdCall_AdrR_from_Adr2(Id_CardinalFromVariant); +end; + +procedure TEmitter.EmitOP_SMALLINT_FROM_VARIANT_64; +begin + EmitStdCall_AdrR_from_Adr2(Id_SmallIntFromVariant); +end; +procedure TEmitter.EmitOP_SMALLINT_FROM_VARIANT; +begin + EmitStdCall_AdrR_from_Adr2(Id_SmallIntFromVariant); +end; + +procedure TEmitter.EmitOP_SHORTINT_FROM_VARIANT_64; +begin + EmitStdCall_AdrR_from_Adr2(Id_ShortIntFromVariant); +end; +procedure TEmitter.EmitOP_SHORTINT_FROM_VARIANT; +begin + EmitStdCall_AdrR_from_Adr2(Id_ShortIntFromVariant); +end; + +procedure TEmitter.EmitOP_BOOL_FROM_VARIANT_64; +begin + EmitStdCall_AdrR_from_Adr2(Id_BoolFromVariant); +end; +procedure TEmitter.EmitOP_BOOL_FROM_VARIANT; +begin + EmitStdCall_AdrR_from_Adr2(Id_BoolFromVariant); +end; + +procedure TEmitter.EmitOP_BOOL_FROM_BYTEBOOL; +var + Reg: Integer; +begin + EmitPCodeOperator; + + Reg := GetReg; + EmitLoadIntVal(Reg, SymbolRec2); + Prg.AsmCmpREG_Imm(Reg, 0); + Prg.AsmJZ_Imm(5); + Prg.AsmMovREG_Imm(Reg, 1); + EmitSaveIntVal(Reg, SymbolRecR); + FreeReg(Reg); +end; + +procedure TEmitter.EmitOP_BOOL_FROM_BYTEBOOL_64; +var + Reg: Integer; +begin + EmitPCodeOperator; + + Reg := GetRegEx; + EmitLoadIntVal(Reg, SymbolRec2); + Prg.AsmCmpREG_Imm(Reg, 0); + Prg.AsmJZ_Imm(10); + Prg.AsmMovREG_Imm(Reg, 1); + EmitSaveIntVal(Reg, SymbolRecR); + FreeReg(Reg); +end; + +procedure TEmitter.EmitOP_BOOL_FROM_WORDBOOL; +var + Reg: Integer; +begin + EmitPCodeOperator; + + Reg := GetReg; + EmitLoadIntVal(Reg, SymbolRec2); + Prg.AsmCmpREG_Imm(Reg, 0); + Prg.AsmJZ_Imm(5); + Prg.AsmMovREG_Imm(Reg, 1); + EmitSaveIntVal(Reg, SymbolRecR); + FreeReg(Reg); +end; + +procedure TEmitter.EmitOP_BOOL_FROM_WORDBOOL_64; +var + Reg: Integer; +begin + EmitPCodeOperator; + + Reg := GetRegEx; + EmitLoadIntVal(Reg, SymbolRec2); + Prg.AsmCmpREG_Imm(Reg, 0); + Prg.AsmJZ_Imm(10); + Prg.AsmMovREG_Imm(Reg, 1); + EmitSaveIntVal(Reg, SymbolRecR); + FreeReg(Reg); +end; + +procedure TEmitter.EmitOP_BOOL_FROM_LONGBOOL; +var + Reg: Integer; +begin + EmitPCodeOperator; + + Reg := GetReg; + EmitLoadIntVal(Reg, SymbolRec2); + Prg.AsmCmpREG_Imm(Reg, 0); + Prg.AsmJZ_Imm(5); + Prg.AsmMovREG_Imm(Reg, 1); + EmitSaveIntVal(Reg, SymbolRecR); + FreeReg(Reg); +end; + +procedure TEmitter.EmitOP_BOOL_FROM_LONGBOOL_64; +var + Reg: Integer; +begin + EmitPCodeOperator; + + Reg := GetRegEx; + EmitLoadIntVal(Reg, SymbolRec2); + Prg.AsmCmpREG_Imm(Reg, 0); + Prg.AsmJZ_Imm(10); + Prg.AsmMovREG_Imm(Reg, 1); + EmitSaveIntVal(Reg, SymbolRecR); + FreeReg(Reg); +end; + +procedure TEmitter.EmitOP_BYTEBOOL_FROM_VARIANT_64; +begin + EmitStdCall_AdrR_from_Adr2(Id_ByteBoolFromVariant); +end; +procedure TEmitter.EmitOP_BYTEBOOL_FROM_VARIANT; +begin + EmitStdCall_AdrR_from_Adr2(Id_ByteBoolFromVariant); +end; + +procedure TEmitter.EmitOP_WORDBOOL_FROM_VARIANT_64; +begin + EmitStdCall_AdrR_from_Adr2(Id_WordBoolFromVariant); +end; +procedure TEmitter.EmitOP_WORDBOOL_FROM_VARIANT; +begin + EmitStdCall_AdrR_from_Adr2(Id_WordBoolFromVariant); +end; + +procedure TEmitter.EmitOP_LONGBOOL_FROM_VARIANT_64; +begin + EmitStdCall_AdrR_from_Adr2(Id_LongBoolFromVariant); +end; +procedure TEmitter.EmitOP_LONGBOOL_FROM_VARIANT; +begin + EmitStdCall_AdrR_from_Adr2(Id_LongBoolFromVariant); +end; + +procedure TEmitter.EmitOP_WIDESTRING_FROM_WIDECHAR_64; +begin + EmitStdCall_Adr1_from_Int2(Id_WideStringFromWideChar); +end; +procedure TEmitter.EmitOP_WIDESTRING_FROM_WIDECHAR; +begin + EmitStdCall_Adr1_from_Int2(Id_WideStringFromWideChar); +end; + +procedure TEmitter.EmitOP_UNICSTRING_FROM_WIDECHAR_64; +begin + EmitStdCall_Adr1_from_Int2(Id_UnicStringFromWideChar); +end; +procedure TEmitter.EmitOP_UNICSTRING_FROM_WIDECHAR; +begin + EmitStdCall_Adr1_from_Int2(Id_UnicStringFromWideChar); +end; + +procedure TEmitter.EmitOP_ANSISTRING_FROM_WIDECHAR_64; +begin + EmitStdCall_Adr1_from_Int2(Id_AnsiStringFromWideChar); +end; + +procedure TEmitter.EmitOP_ANSISTRING_FROM_WIDECHAR; +begin + EmitStdCall_Adr1_from_Int2(Id_AnsiStringFromWideChar); +end; + +procedure TEmitter.EmitOP_VARIANT_FROM_WIDECHAR_64; +begin + EmitStdCall_Adr1_from_Int2(Id_VariantFromWideChar); +end; +procedure TEmitter.EmitOP_VARIANT_FROM_WIDECHAR; +begin + EmitStdCall_Adr1_from_Int2(Id_VariantFromWideChar); +end; + +procedure TEmitter.EmitOP_OLEVARIANT_FROM_WIDECHAR_64; +begin + EmitStdCall_Adr1_from_Int2(Id_OleVariantFromWideChar); +end; +procedure TEmitter.EmitOP_OLEVARIANT_FROM_WIDECHAR; +begin + EmitStdCall_Adr1_from_Int2(Id_OleVariantFromWideChar); +end; + +procedure TEmitter.EmitOP_WIDESTRING_FROM_WIDECHAR_LITERAL_64; +var + SubId, Reg: Integer; +begin + EmitPCodeOperator; + Emit_PUSH_REGS; + + SubId := Id_WideStringFromWideChar; + EmitCallPro(SubId); + + Reg := GetRegEx; + + Prg.AsmMovReg_Imm(Reg, SymbolRec2.Value); // widechar walue + Prg.AsmMovREG_REG(_ECX, Reg); + + EmitLoadAddress(Reg, SymbolRec1); // string dest + Prg.AsmMovREG_REG(_EDX, Reg); + + FreeReg(Reg); + EmitStdCall(SubId); + + Emit_POP_REGS; +end; +procedure TEmitter.EmitOP_WIDESTRING_FROM_WIDECHAR_LITERAL; +var + SubId, Reg: Integer; +begin + EmitPCodeOperator; + Emit_PUSH_REGS; + + SubId := Id_WideStringFromWideChar; + EmitCallPro(SubId); + + Reg := GetRegEx; + + EmitLoadAddress(Reg, SymbolRec1); // string dest + Prg.AsmPush_REG(Reg); + + Prg.AsmPush_Imm(SymbolRec2.Value); // widechar walue + + FreeReg(Reg); + EmitStdCall(SubId); + + Emit_POP_REGS; +end; + +procedure TEmitter.EmitOP_UNICSTRING_FROM_WIDECHAR_LITERAL_64; +var + SubId, Reg: Integer; +begin + EmitPCodeOperator; + Emit_PUSH_REGS; + + SubId := Id_UnicStringFromWideChar; + EmitCallPro(SubId); + + Reg := GetRegEx; + + Prg.AsmMovREG_Imm(Reg, SymbolRec2.Value); // widechar walue + Prg.AsmMovREG_REG(_ECX, Reg); + + EmitLoadAddress(Reg, SymbolRec1); // string dest + Prg.AsmMovREG_REG(_EDX, Reg); + + FreeReg(Reg); + EmitStdCall(SubId); + + Emit_POP_REGS; +end; +procedure TEmitter.EmitOP_UNICSTRING_FROM_WIDECHAR_LITERAL; +var + SubId, Reg: Integer; +begin + EmitPCodeOperator; + Emit_PUSH_REGS; + + SubId := Id_UnicStringFromWideChar; + EmitCallPro(SubId); + + Reg := GetRegEx; + + EmitLoadAddress(Reg, SymbolRec1); // string dest + Prg.AsmPush_REG(Reg); + + Prg.AsmPush_Imm(SymbolRec2.Value); // widechar walue + + FreeReg(Reg); + EmitStdCall(SubId); + + Emit_POP_REGS; +end; + +procedure TEmitter.EmitOP_VARIANT_FROM_WIDECHAR_LITERAL_64; +var + SubId, Reg: Integer; +begin + EmitPCodeOperator; + Emit_PUSH_REGS; + + SubId := Id_VariantFromWideChar; + EmitCallPro(SubId); + + Reg := GetRegEx; + + Prg.AsmPush_Imm(SymbolRec2.Value); // widechar walue + Prg.AsmMovREG_REG(_ECX, Reg); + + EmitLoadAddress(Reg, SymbolRec1); // string dest + Prg.AsmMovREG_REG(_EDX, Reg); + + FreeReg(Reg); + EmitStdCall(SubId); + + Emit_POP_REGS; +end; +procedure TEmitter.EmitOP_VARIANT_FROM_WIDECHAR_LITERAL; +var + SubId, Reg: Integer; +begin + EmitPCodeOperator; + Emit_PUSH_REGS; + + SubId := Id_VariantFromWideChar; + EmitCallPro(SubId); + + Reg := GetRegEx; + + EmitLoadAddress(Reg, SymbolRec1); // string dest + Prg.AsmPush_REG(Reg); + + Prg.AsmPush_Imm(SymbolRec2.Value); // widechar walue + + FreeReg(Reg); + EmitStdCall(SubId); + + Emit_POP_REGS; +end; + +procedure TEmitter.EmitOP_OLEVARIANT_FROM_WIDECHAR_LITERAL_64; +var + SubId, Reg: Integer; +begin + EmitPCodeOperator; + Emit_PUSH_REGS; + + SubId := Id_OleVariantFromWideChar; + EmitCallPro(SubId); + + Reg := GetRegEx; + + Prg.AsmPush_Imm(SymbolRec2.Value); // widechar walue + Prg.AsmMovREG_REG(_ECX, Reg); + + EmitLoadAddress(Reg, SymbolRec1); // string dest + Prg.AsmMovREG_REG(_EDX, Reg); + + FreeReg(Reg); + EmitStdCall(SubId); + + Emit_POP_REGS; +end; +procedure TEmitter.EmitOP_OLEVARIANT_FROM_WIDECHAR_LITERAL; +var + SubId, Reg: Integer; +begin + EmitPCodeOperator; + Emit_PUSH_REGS; + + SubId := Id_OleVariantFromWideChar; + EmitCallPro(SubId); + + Reg := GetRegEx; + + EmitLoadAddress(Reg, SymbolRec1); // string dest + Prg.AsmPush_REG(Reg); + + Prg.AsmPush_Imm(SymbolRec2.Value); // widechar walue + + FreeReg(Reg); + EmitStdCall(SubId); + + Emit_POP_REGS; +end; + +procedure TEmitter.EmitOP_ASSIGN_VARIANT_64; +begin + EmitStdCall_AdrR_from_Adr2(Id_VariantAssign); +end; +procedure TEmitter.EmitOP_ASSIGN_VARIANT; +begin + EmitStdCall_AdrR_from_Adr2(Id_VariantAssign); +end; + +procedure TEmitter.EmitOP_ASSIGN_OLEVARIANT_64; +begin + EmitStdCall_AdrR_from_Adr2(Id_OleVariantAssign); +end; +procedure TEmitter.EmitOP_ASSIGN_OLEVARIANT; +begin + EmitStdCall_AdrR_from_Adr2(Id_OleVariantAssign); +end; + +procedure TEmitter.EmitOP_ASSIGN_CLASS_64; +begin + EmitStdCall_AdrR_from_Adr2(Id_ClassAssign); +end; +procedure TEmitter.EmitOP_ASSIGN_CLASS; +begin + EmitStdCall_AdrR_from_Adr2(Id_ClassAssign); +end; + +procedure TEmitter.EmitOP_ASSIGN_ANSISTRING_64; +begin + EmitStdCall_AdrR_from_Adr2(Id_AnsiStringAssign); +end; +procedure TEmitter.EmitOP_ASSIGN_ANSISTRING; +begin + EmitStdCall_AdrR_from_Adr2(Id_AnsiStringAssign); +end; + +procedure TEmitter.EmitOP_ASSIGN_WIDESTRING_64; +begin + EmitStdCall_AdrR_from_Adr2(Id_WideStringAssign); +end; +procedure TEmitter.EmitOP_ASSIGN_WIDESTRING; +begin + EmitStdCall_AdrR_from_Adr2(Id_WideStringAssign); +end; + +procedure TEmitter.EmitOP_ASSIGN_UNICSTRING_64; +begin + EmitStdCall_AdrR_from_Adr2(Id_UnicStringAssign); +end; +procedure TEmitter.EmitOP_ASSIGN_UNICSTRING; +begin + EmitStdCall_AdrR_from_Adr2(Id_UnicStringAssign); +end; + +{$IFNDEF PAXARM} +procedure TEmitter.EmitOP_ASSIGN_SHORTSTRING_64; +var + L, T, SubId, Reg: Integer; +begin + EmitPCodeOperator; + + SubId := Id_ShortStringAssign; + EmitCallPro(SubId); + + Reg := GetRegEx; + + EmitLoadAddress(Reg, SymbolRec2); // string source + Prg.AsmMovREG_REG(_ECX, Reg); + + T := SymbolRecR.TerminalTypeID; + if T = typeSHORTSTRING then + L := 255 + else + L := GetSymbolRec(T).Count; + + Prg.AsmMovREG_Imm(Reg, L); + Prg.AsmMovREG_REG(_EDX, Reg); + + EmitLoadAddress(Reg, SymbolRecR); // string dest + Prg.AsmMovREG_REG(_R8, Reg); + + FreeReg(Reg); + EmitStdCall(SubId); +end; +procedure TEmitter.EmitOP_ASSIGN_SHORTSTRING; +var + L, T, SubId, Reg: Integer; +begin + EmitPCodeOperator; + + SubId := Id_ShortStringAssign; + EmitCallPro(SubId); + + T := SymbolRecR.TerminalTypeID; + if T = typeSHORTSTRING then + L := 255 + else + L := GetSymbolRec(T).Count; + + Reg := GetReg; + + EmitLoadAddress(Reg, SymbolRecR); // string dest + Prg.AsmPush_REG(Reg); + + Prg.AsmPush_Imm(L); + + EmitLoadAddress(Reg, SymbolRec2); // string source + Prg.AsmPush_REG(Reg); + + FreeReg(Reg); + EmitStdCall(SubId); +end; +{$ENDIF} + +procedure TEmitter.EmitOP_ADD_ANSISTRING_64; +begin + EmitStdCall_Adr1_Adr2_AdrR(Id_AnsiStringAddition); +end; +procedure TEmitter.EmitOP_ADD_ANSISTRING; +begin + EmitStdCall_Adr1_Adr2_AdrR(Id_AnsiStringAddition); +end; + +procedure TEmitter.EmitOP_ADD_WIDESTRING_64; +begin + EmitStdCall_Adr1_Adr2_AdrR(Id_WideStringAddition); +end; +procedure TEmitter.EmitOP_ADD_WIDESTRING; +begin + EmitStdCall_Adr1_Adr2_AdrR(Id_WideStringAddition); +end; + +procedure TEmitter.EmitOP_ADD_UNICSTRING_64; +begin + EmitStdCall_Adr1_Adr2_AdrR(Id_UnicStringAddition); +end; +procedure TEmitter.EmitOP_ADD_UNICSTRING; +begin + EmitStdCall_Adr1_Adr2_AdrR(Id_UnicStringAddition); +end; + +procedure TEmitter.EmitOP_ADD_SHORTSTRING_64; +begin + EmitStdCall_Adr1_Adr2_AdrR(Id_ShortStringAddition); +end; +procedure TEmitter.EmitOP_ADD_SHORTSTRING; +begin + EmitStdCall_Adr1_Adr2_AdrR(Id_ShortStringAddition); +end; + +procedure TEmitter.EmitOP_MULT_INT64_64; +begin + EmitStdCall_Adr1_Adr2_AdrR(Id_Int64Multiplication); +end; +procedure TEmitter.EmitOP_MULT_INT64; +begin + EmitStdCall_Adr1_Adr2_AdrR(Id_Int64Multiplication); +end; + +procedure TEmitter.EmitOP_IDIV_INT64_64; +begin + EmitStdCall_Adr1_Adr2_AdrR(Id_Int64Division); +end; +procedure TEmitter.EmitOP_IDIV_INT64; +begin + EmitStdCall_Adr1_Adr2_AdrR(Id_Int64Division); +end; + +procedure TEmitter.EmitOP_MOD_INT64_64; +begin + EmitStdCall_Adr1_Adr2_AdrR(Id_Int64Modulo); +end; +procedure TEmitter.EmitOP_MOD_INT64; +begin + EmitStdCall_Adr1_Adr2_AdrR(Id_Int64Modulo); +end; + +procedure TEmitter.EmitOP_SHL_INT64_64; +begin + EmitStdCall_Adr1_Adr2_AdrR(Id_Int64LeftShift); +end; +procedure TEmitter.EmitOP_SHL_INT64; +begin + EmitStdCall_Adr1_Adr2_AdrR(Id_Int64LeftShift); +end; + +procedure TEmitter.EmitOP_SHR_INT64_64; +begin + EmitStdCall_Adr1_Adr2_AdrR(Id_Int64RightShift); +end; +procedure TEmitter.EmitOP_SHR_INT64; +begin + EmitStdCall_Adr1_Adr2_AdrR(Id_Int64RightShift); +end; + +procedure TEmitter.EmitOP_NEG_VARIANT_64; +begin + EmitStdCall_Adr1_AdrR(Id_VariantNegation); +end; +procedure TEmitter.EmitOP_NEG_VARIANT; +begin + EmitStdCall_Adr1_AdrR(Id_VariantNegation); +end; + +procedure TEmitter.EmitOP_ABS_VARIANT_64; +begin + EmitStdCall_Adr1_AdrR(Id_VariantAbs); +end; +procedure TEmitter.EmitOP_ABS_VARIANT; +begin + EmitStdCall_Adr1_AdrR(Id_VariantAbs); +end; + +procedure TEmitter.EmitOP_ABS_INT64_64; +begin + EmitStdCall_Adr1_AdrR(Id_Int64Abs); +end; +procedure TEmitter.EmitOP_ABS_INT64; +begin + EmitStdCall_Adr1_AdrR(Id_Int64Abs); +end; + +procedure TEmitter.EmitOP_NOT_VARIANT_64; +begin + EmitStdCall_Adr1_AdrR(Id_VariantNot); +end; +procedure TEmitter.EmitOP_NOT_VARIANT; +begin + EmitStdCall_Adr1_AdrR(Id_VariantNot); +end; + +procedure TEmitter.EmitOP_ADD_VARIANT_64; +begin + EmitStdCall_Lang_Adr1_Adr2_AdrR(Id_VariantAddition); +end; +procedure TEmitter.EmitOP_ADD_VARIANT; +begin + EmitStdCall_Lang_Adr1_Adr2_AdrR(Id_VariantAddition); +end; + +procedure TEmitter.EmitOP_SUB_VARIANT_64; +begin + EmitStdCall_Lang_Adr1_Adr2_AdrR(Id_VariantSubtraction); +end; +procedure TEmitter.EmitOP_SUB_VARIANT; +begin + EmitStdCall_Lang_Adr1_Adr2_AdrR(Id_VariantSubtraction); +end; + +procedure TEmitter.EmitOP_MULT_VARIANT_64; +begin + EmitStdCall_Lang_Adr1_Adr2_AdrR(Id_VariantMultiplication); +end; +procedure TEmitter.EmitOP_MULT_VARIANT; +begin + EmitStdCall_Lang_Adr1_Adr2_AdrR(Id_VariantMultiplication); +end; + +procedure TEmitter.EmitOP_DIV_VARIANT_64; +begin + EmitStdCall_Lang_Adr1_Adr2_AdrR(Id_VariantDivision); +end; +procedure TEmitter.EmitOP_DIV_VARIANT; +begin + EmitStdCall_Lang_Adr1_Adr2_AdrR(Id_VariantDivision); +end; + +procedure TEmitter.EmitOP_IDIV_VARIANT_64; +begin + EmitStdCall_Lang_Adr1_Adr2_AdrR(Id_VariantIDivision); +end; +procedure TEmitter.EmitOP_IDIV_VARIANT; +begin + EmitStdCall_Lang_Adr1_Adr2_AdrR(Id_VariantIDivision); +end; + +procedure TEmitter.EmitOP_MOD_VARIANT_64; +begin + EmitStdCall_Lang_Adr1_Adr2_AdrR(Id_VariantModulo); +end; +procedure TEmitter.EmitOP_MOD_VARIANT; +begin + EmitStdCall_Lang_Adr1_Adr2_AdrR(Id_VariantModulo); +end; + +procedure TEmitter.EmitOP_SHL_VARIANT_64; +begin + EmitStdCall_Lang_Adr1_Adr2_AdrR(Id_VariantLeftShift); +end; +procedure TEmitter.EmitOP_SHL_VARIANT; +begin + EmitStdCall_Lang_Adr1_Adr2_AdrR(Id_VariantLeftShift); +end; + +procedure TEmitter.EmitOP_SHR_VARIANT_64; +begin + EmitStdCall_Lang_Adr1_Adr2_AdrR(Id_VariantRightShift); +end; +procedure TEmitter.EmitOP_SHR_VARIANT; +begin + EmitStdCall_Lang_Adr1_Adr2_AdrR(Id_VariantRightShift); +end; + +procedure TEmitter.EmitOP_AND_VARIANT_64; +begin + EmitStdCall_Lang_Adr1_Adr2_AdrR(Id_VariantAnd); +end; +procedure TEmitter.EmitOP_AND_VARIANT; +begin + EmitStdCall_Lang_Adr1_Adr2_AdrR(Id_VariantAnd); +end; + +procedure TEmitter.EmitOP_OR_VARIANT_64; +begin + EmitStdCall_Lang_Adr1_Adr2_AdrR(Id_VariantOr); +end; +procedure TEmitter.EmitOP_OR_VARIANT; +begin + EmitStdCall_Lang_Adr1_Adr2_AdrR(Id_VariantOr); +end; + +procedure TEmitter.EmitOP_XOR_VARIANT_64; +begin + EmitStdCall_Lang_Adr1_Adr2_AdrR(Id_VariantXor); +end; +procedure TEmitter.EmitOP_XOR_VARIANT; +begin + EmitStdCall_Lang_Adr1_Adr2_AdrR(Id_VariantXor); +end; + +procedure TEmitter.EmitOP_LT_VARIANT_64; +begin + EmitStdCall_Lang_Adr1_Adr2_AdrR(Id_VariantLessThan); +end; +procedure TEmitter.EmitOP_LT_VARIANT; +begin + EmitStdCall_Lang_Adr1_Adr2_AdrR(Id_VariantLessThan); +end; + +procedure TEmitter.EmitOP_LE_VARIANT_64; +begin + EmitStdCall_Lang_Adr1_Adr2_AdrR(Id_VariantLessThanOrEqual); +end; +procedure TEmitter.EmitOP_LE_VARIANT; +begin + EmitStdCall_Lang_Adr1_Adr2_AdrR(Id_VariantLessThanOrEqual); +end; + +procedure TEmitter.EmitOP_GT_VARIANT_64; +begin + EmitStdCall_Lang_Adr1_Adr2_AdrR(Id_VariantGreaterThan); +end; +procedure TEmitter.EmitOP_GT_VARIANT; +begin + EmitStdCall_Lang_Adr1_Adr2_AdrR(Id_VariantGreaterThan); +end; + +procedure TEmitter.EmitOP_GE_VARIANT_64; +begin + EmitStdCall_Lang_Adr1_Adr2_AdrR(Id_VariantGreaterThanOrEqual); +end; +procedure TEmitter.EmitOP_GE_VARIANT; +begin + EmitStdCall_Lang_Adr1_Adr2_AdrR(Id_VariantGreaterThanOrEqual); +end; + +procedure TEmitter.EmitOP_EQ_VARIANT_64; +begin + EmitStdCall_Lang_Adr1_Adr2_AdrR(Id_VariantEquality); +end; +procedure TEmitter.EmitOP_EQ_VARIANT; +begin + EmitStdCall_Lang_Adr1_Adr2_AdrR(Id_VariantEquality); +end; + +procedure TEmitter.EmitOP_NE_VARIANT_64; +begin + EmitStdCall_Lang_Adr1_Adr2_AdrR(Id_VariantNotEquality); +end; +procedure TEmitter.EmitOP_NE_VARIANT; +begin + EmitStdCall_Lang_Adr1_Adr2_AdrR(Id_VariantNotEquality); +end; + +procedure TEmitter.EmitOP_EQ_STRUCT_64; +var + SubId, Reg, SZ: Integer; +begin + EmitPCodeOperator; + + SubId := Id_StructEquality; + EmitCallPro(SubId); + + Reg := GetRegEx; + + EmitLoadAddress(Reg, SymbolRec1); // s1 + Prg.AsmMovREG_REG(_ECX, Reg); + + EmitLoadAddress(Reg, SymbolRec2); // s2 + Prg.AsmMovREG_REG(_EDX, Reg); + + sz := SymbolRec1.PtrSize; + Prg.AsmMovREG_Imm(Reg, sz); + Prg.AsmMovREG_REG(_R8, Reg); + + EmitLoadAddress(Reg, SymbolRecR); // result + Prg.AsmMovREG_REG(_R9, Reg); + + FreeReg(Reg); + EmitStdCall(SubId); +end; +procedure TEmitter.EmitOP_EQ_STRUCT; +var + SubId, Reg, SZ: Integer; +begin + EmitPCodeOperator; + + SubId := Id_StructEquality; + EmitCallPro(SubId); + + Reg := GetReg; + + EmitLoadAddress(Reg, SymbolRecR); // result + Prg.AsmPush_REG(Reg); + + sz := SymbolRec1.PtrSize; + Prg.AsmPush_Imm(sz); + + EmitLoadAddress(Reg, SymbolRec2); // s2 + Prg.AsmPush_REG(Reg); + + EmitLoadAddress(Reg, SymbolRec1); // s1 + Prg.AsmPush_REG(Reg); + + FreeReg(Reg); + EmitStdCall(SubId); +end; + +procedure TEmitter.EmitOP_NE_STRUCT_64; +var + SubId, Reg, SZ: Integer; +begin + EmitPCodeOperator; + + SubId := Id_StructNotEquality; + EmitCallPro(SubId); + + Reg := GetRegEx; + + EmitLoadAddress(Reg, SymbolRec1); // s1 + Prg.AsmMovREG_REG(_ECX, Reg); + + EmitLoadAddress(Reg, SymbolRec2); // s2 + Prg.AsmMovREG_REG(_EDX, Reg); + + sz := SymbolRec1.PtrSize; + Prg.AsmMovREG_Imm(Reg, sz); + Prg.AsmMovREG_REG(_R8, Reg); + + EmitLoadAddress(Reg, SymbolRecR); // result + Prg.AsmMovREG_REG(_R9, Reg); + + FreeReg(Reg); + EmitStdCall(SubId); +end; +procedure TEmitter.EmitOP_NE_STRUCT; +var + SubId, Reg, SZ: Integer; +begin + EmitPCodeOperator; + + SubId := Id_StructNotEquality; + EmitCallPro(SubId); + + Reg := GetReg; + + EmitLoadAddress(Reg, SymbolRecR); // result + Prg.AsmPush_REG(Reg); + + sz := SymbolRec1.PtrSize; + Prg.AsmPush_Imm(sz); + + EmitLoadAddress(Reg, SymbolRec2); // s2 + Prg.AsmPush_REG(Reg); + + EmitLoadAddress(Reg, SymbolRec1); // s1 + Prg.AsmPush_REG(Reg); + + FreeReg(Reg); + EmitStdCall(SubId); +end; + +procedure TEmitter.EmitOP_EQ_ANSISTRING_64; +begin + EmitStdCall_Adr1_Adr2_AdrR(Id_AnsiStringEquality); +end; +procedure TEmitter.EmitOP_EQ_ANSISTRING; +begin + EmitStdCall_Adr1_Adr2_AdrR(Id_AnsiStringEquality); +end; + +procedure TEmitter.EmitOP_GT_ANSISTRING_64; +begin + EmitStdCall_Adr1_Adr2_AdrR(Id_AnsiStringGreaterThan); +end; +procedure TEmitter.EmitOP_GT_ANSISTRING; +begin + EmitStdCall_Adr1_Adr2_AdrR(Id_AnsiStringGreaterThan); +end; + +procedure TEmitter.EmitOP_GE_ANSISTRING_64; +begin + EmitStdCall_Adr1_Adr2_AdrR(Id_AnsiStringGreaterThanOrEqual); +end; +procedure TEmitter.EmitOP_GE_ANSISTRING; +begin + EmitStdCall_Adr1_Adr2_AdrR(Id_AnsiStringGreaterThanOrEqual); +end; + +procedure TEmitter.EmitOP_LT_ANSISTRING_64; +begin + EmitStdCall_Adr1_Adr2_AdrR(Id_AnsiStringLessThan); +end; +procedure TEmitter.EmitOP_LT_ANSISTRING; +begin + EmitStdCall_Adr1_Adr2_AdrR(Id_AnsiStringLessThan); +end; + +procedure TEmitter.EmitOP_LE_ANSISTRING_64; +begin + EmitStdCall_Adr1_Adr2_AdrR(Id_AnsiStringLessThanOrEqual); +end; +procedure TEmitter.EmitOP_LE_ANSISTRING; +begin + EmitStdCall_Adr1_Adr2_AdrR(Id_AnsiStringLessThanOrEqual); +end; + +procedure TEmitter.EmitOP_GT_SHORTSTRING_64; +begin + EmitStdCall_Adr1_Adr2_AdrR(Id_ShortStringGreaterThan); +end; +procedure TEmitter.EmitOP_GT_SHORTSTRING; +begin + EmitStdCall_Adr1_Adr2_AdrR(Id_ShortStringGreaterThan); +end; + +procedure TEmitter.EmitOP_GE_SHORTSTRING_64; +begin + EmitStdCall_Adr1_Adr2_AdrR(Id_ShortStringGreaterThanOrEqual); +end; +procedure TEmitter.EmitOP_GE_SHORTSTRING; +begin + EmitStdCall_Adr1_Adr2_AdrR(Id_ShortStringGreaterThanOrEqual); +end; + +procedure TEmitter.EmitOP_LT_SHORTSTRING_64; +begin + EmitStdCall_Adr1_Adr2_AdrR(Id_ShortStringLessThan); +end; +procedure TEmitter.EmitOP_LT_SHORTSTRING; +begin + EmitStdCall_Adr1_Adr2_AdrR(Id_ShortStringLessThan); +end; + +procedure TEmitter.EmitOP_LE_SHORTSTRING_64; +begin + EmitStdCall_Adr1_Adr2_AdrR(Id_ShortStringLessThanOrEqual); +end; +procedure TEmitter.EmitOP_LE_SHORTSTRING; +begin + EmitStdCall_Adr1_Adr2_AdrR(Id_ShortStringLessThanOrEqual); +end; + +procedure TEmitter.EmitOP_GT_WIDESTRING_64; +begin + EmitStdCall_Adr1_Adr2_AdrR(Id_WideStringGreaterThan); +end; +procedure TEmitter.EmitOP_GT_WIDESTRING; +begin + EmitStdCall_Adr1_Adr2_AdrR(Id_WideStringGreaterThan); +end; + +procedure TEmitter.EmitOP_GT_UNICSTRING_64; +begin + EmitStdCall_Adr1_Adr2_AdrR(Id_UnicStringGreaterThan); +end; +procedure TEmitter.EmitOP_GT_UNICSTRING; +begin + EmitStdCall_Adr1_Adr2_AdrR(Id_UnicStringGreaterThan); +end; + +procedure TEmitter.EmitOP_GE_WIDESTRING_64; +begin + EmitStdCall_Adr1_Adr2_AdrR(Id_WideStringGreaterThanOrEqual); +end; +procedure TEmitter.EmitOP_GE_WIDESTRING; +begin + EmitStdCall_Adr1_Adr2_AdrR(Id_WideStringGreaterThanOrEqual); +end; + +procedure TEmitter.EmitOP_GE_UNICSTRING_64; +begin + EmitStdCall_Adr1_Adr2_AdrR(Id_UnicStringGreaterThanOrEqual); +end; +procedure TEmitter.EmitOP_GE_UNICSTRING; +begin + EmitStdCall_Adr1_Adr2_AdrR(Id_UnicStringGreaterThanOrEqual); +end; + +procedure TEmitter.EmitOP_LT_WIDESTRING_64; +begin + EmitStdCall_Adr1_Adr2_AdrR(Id_WideStringLessThan); +end; +procedure TEmitter.EmitOP_LT_WIDESTRING; +begin + EmitStdCall_Adr1_Adr2_AdrR(Id_WideStringLessThan); +end; + +procedure TEmitter.EmitOP_LT_UNICSTRING_64; +begin + EmitStdCall_Adr1_Adr2_AdrR(Id_UnicStringLessThan); +end; +procedure TEmitter.EmitOP_LT_UNICSTRING; +begin + EmitStdCall_Adr1_Adr2_AdrR(Id_UnicStringLessThan); +end; + +procedure TEmitter.EmitOP_LE_WIDESTRING_64; +begin + EmitStdCall_Adr1_Adr2_AdrR(Id_WideStringLessThanOrEqual); +end; +procedure TEmitter.EmitOP_LE_WIDESTRING; +begin + EmitStdCall_Adr1_Adr2_AdrR(Id_WideStringLessThanOrEqual); +end; + +procedure TEmitter.EmitOP_LE_UNICSTRING_64; +begin + EmitStdCall_Adr1_Adr2_AdrR(Id_UnicStringLessThanOrEqual); +end; +procedure TEmitter.EmitOP_LE_UNICSTRING; +begin + EmitStdCall_Adr1_Adr2_AdrR(Id_UnicStringLessThanOrEqual); +end; + +procedure TEmitter.EmitOP_NE_ANSISTRING_64; +begin + EmitStdCall_Adr1_Adr2_AdrR(Id_AnsiStringNotEquality); +end; +procedure TEmitter.EmitOP_NE_ANSISTRING; +begin + EmitStdCall_Adr1_Adr2_AdrR(Id_AnsiStringNotEquality); +end; + +procedure TEmitter.EmitOP_EQ_SHORTSTRING_64; +begin + EmitStdCall_Adr1_Adr2_AdrR(Id_ShortStringEquality); +end; +procedure TEmitter.EmitOP_EQ_SHORTSTRING; +begin + EmitStdCall_Adr1_Adr2_AdrR(Id_ShortStringEquality); +end; + +procedure TEmitter.EmitOP_NE_SHORTSTRING_64; +begin + EmitStdCall_Adr1_Adr2_AdrR(Id_ShortStringNotEquality); +end; +procedure TEmitter.EmitOP_NE_SHORTSTRING; +begin + EmitStdCall_Adr1_Adr2_AdrR(Id_ShortStringNotEquality); +end; + +procedure TEmitter.EmitOP_EQ_WIDESTRING_64; +begin + EmitStdCall_Adr1_Adr2_AdrR(Id_WideStringEquality); +end; +procedure TEmitter.EmitOP_EQ_WIDESTRING; +begin + EmitStdCall_Adr1_Adr2_AdrR(Id_WideStringEquality); +end; + +procedure TEmitter.EmitOP_EQ_UNICSTRING_64; +begin + EmitStdCall_Adr1_Adr2_AdrR(Id_UnicStringEquality); +end; +procedure TEmitter.EmitOP_EQ_UNICSTRING; +begin + EmitStdCall_Adr1_Adr2_AdrR(Id_UnicStringEquality); +end; + +procedure TEmitter.EmitOP_NE_WIDESTRING_64; +begin + EmitStdCall_Adr1_Adr2_AdrR(Id_WideStringNotEquality); +end; +procedure TEmitter.EmitOP_NE_WIDESTRING; +begin + EmitStdCall_Adr1_Adr2_AdrR(Id_WideStringNotEquality); +end; + +procedure TEmitter.EmitOP_NE_UNICSTRING_64; +begin + EmitStdCall_Adr1_Adr2_AdrR(Id_UnicStringNotEquality); +end; +procedure TEmitter.EmitOP_NE_UNICSTRING; +begin + EmitStdCall_Adr1_Adr2_AdrR(Id_UnicStringNotEquality); +end; + +procedure TEmitter.EmitOP_VARARRAY_GET_64; +var + SubId: Integer; +begin + SubId := 0; + case R.Arg2 of + 1: SubId := Id_VarArrayGet1; + 2: SubId := Id_VarArrayGet2; + 3: SubId := Id_VarArrayGet3; + else + RaiseError(errInternalError, []); + end; + EmitStdCall_Adr1_AdrR(SubId); +end; +procedure TEmitter.EmitOP_VARARRAY_GET; +var + SubId: Integer; +begin + SubId := 0; + case R.Arg2 of + 1: SubId := Id_VarArrayGet1; + 2: SubId := Id_VarArrayGet2; + 3: SubId := Id_VarArrayGet3; + else + RaiseError(errInternalError, []); + end; + EmitStdCall_Adr1_AdrR(SubId); +end; + +procedure TEmitter.EmitOP_VARARRAY_PUT_64; +var + SubId: Integer; +begin + SubId := 0; + case R.Arg2 of + 1: SubId := Id_VarArrayPut1; + 2: SubId := Id_VarArrayPut2; + 3: SubId := Id_VarArrayPut3; + else + RaiseError(errInternalError, []); + end; + EmitStdCall_Adr1_AdrR(SubId); +end; +procedure TEmitter.EmitOP_VARARRAY_PUT; +var + SubId: Integer; +begin + SubId := 0; + case R.Arg2 of + 1: SubId := Id_VarArrayPut1; + 2: SubId := Id_VarArrayPut2; + 3: SubId := Id_VarArrayPut3; + else + RaiseError(errInternalError, []); + end; + EmitStdCall_Adr1_AdrR(SubId); +end; + +procedure TEmitter.EmitOP_GENERAL_GET_64; +var + Reg, SubId, PropNameId: Integer; + Code: TCode; + I, NP: Integer; + L: TIntegerList; +begin + EmitPCodeOperator; + + SubId := JS_GetGenericPropertyId; + + PropNameId := SymbolRec2.Id; + Code := TKernel(kernel).Code; + L := TIntegerList.Create; + for I:=Code.N downto 1 do + if Code.Records[I].Op = OP_OLE_PARAM then + if Code.Records[I].Res = PropNameId then + L.Insert(0, Code.Records[I].Arg1); + + Reg := GetRegEx; + + NP := L.Count; + + EmitCallPro(SubId, (NP + 5) * SizeOf(Pointer)); + + if NP > 0 then + for I:=0 to NP - 1 do + begin + EmitLoadAddress(Reg, GetSymbolRec(L[I])); + Prg.AsmMovRSPPtr_REG64(Reg, $20 + I * 8); + end; + + Prg.AsmMovREG_REG(Reg, _ESI); + Prg.AsmAddREG_Imm(Reg, H_SelfPtr); + Prg.AsmMovREG_REGPtr(Reg, Reg); // load TProgram.Self + Prg.AsmMovREG_REG(_ECX, Reg); + + EmitLoadAddress(Reg, SymbolRec1); // object + Prg.AsmMovREG_REG(_EDX, Reg); + + EmitGet_REG(Reg, SymbolRec2); // prop name - pchar + Prg.AsmMovREG_REG(_R8, Reg); + + Prg.AsmMovREG_Imm(_R9, NP); + + EmitLoadAddress(Reg, SymbolRecR); // result + Prg.AsmMovREG_REG(_R10, Reg); + + Prg.AsmMovREG_REG(_EAX, _ESP); + Prg.AsmAddREG_Imm(_EAX, $20); + + FreeReg(Reg); + EmitStdCall(SubId, (NP + 5) * SizeOf(Pointer)); +end; +procedure TEmitter.EmitOP_GENERAL_GET; +var + Reg, SubId, PropNameId: Integer; + Code: TCode; + I, NP: Integer; + L: TIntegerList; +begin + EmitPCodeOperator; + + SubId := JS_GetGenericPropertyId; + + PropNameId := SymbolRec2.Id; + Code := TKernel(kernel).Code; + L := TIntegerList.Create; + for I:=Code.N downto 1 do + if Code.Records[I].Op = OP_OLE_PARAM then + if Code.Records[I].Res = PropNameId then + L.Insert(0, Code.Records[I].Arg1); + + Reg := GetReg; + + NP := L.Count; + + EmitCallPro(SubId, (NP + 5) * SizeOf(Pointer)); + + if NP > 0 then + for I:=NP - 1 downto 0 do + begin + EmitLoadAddress(Reg, GetSymbolRec(L[I])); + Prg.AsmPush_REG(Reg); + end; + + EmitLoadAddress(Reg, SymbolRecR); // result + Prg.AsmPush_REG(Reg); + + Prg.AsmPush_Imm(NP); + + EmitGet_REG(Reg, SymbolRec2); // prop name - pchar + Prg.AsmPush_REG(Reg); + + EmitLoadAddress(Reg, SymbolRec1); // object + Prg.AsmPush_REG(Reg); + + Prg.AsmMovREG_REG(Reg, _ESI); + Prg.AsmAddREG_Imm(Reg, H_SelfPtr); + Prg.AsmMovREG_REGPtr(Reg, Reg); // load TProgram.Self + Prg.AsmPush_REG(Reg); + + FreeReg(Reg); + EmitStdCall(SubId, (NP + 5) * SizeOf(Pointer)); +end; + +procedure TEmitter.EmitOP_GENERAL_PUT_64; +var + Reg, SubId, PropNameId: Integer; + Code: TCode; + I, NP: Integer; + L: TIntegerList; +begin + EmitPCodeOperator; + + SubId := JS_PutGenericPropertyId; + + PropNameId := SymbolRec2.Id; + Code := TKernel(kernel).Code; + L := TIntegerList.Create; + for I:=Code.N downto 1 do + if Code.Records[I].Op = OP_OLE_PARAM then + if Code.Records[I].Res = PropNameId then + L.Insert(0, Code.Records[I].Arg1); + + Reg := GetRegEx; + + NP := L.Count; + EmitCallPro(SubId, (NP + 5) * SizeOf(Pointer)); + + if NP > 0 then + for I:=0 to NP - 1 do + begin + EmitLoadAddress(Reg, GetSymbolRec(L[I])); + Prg.AsmMovRSPPtr_REG64(Reg, $20 + I * 8); + end; + + EmitLoadAddress(Reg, SymbolRec1); // object + Prg.AsmMovREG_REG(_ECX, Reg); + + EmitGet_REG(Reg, SymbolRec2); // prop name - pchar + Prg.AsmMovREG_REG(_EDX, Reg); + + Prg.AsmMovREG_Imm(Reg, NP); + Prg.AsmMovREG_REG(_R8, Reg); + + EmitLoadAddress(Reg, SymbolRecR); // value + Prg.AsmMovREG_REG(_R9, Reg); + + Prg.AsmMovREG_REG(_EAX, _ESP); + Prg.AsmAddREG_Imm(_EAX, $20); + + FreeReg(Reg); + EmitStdCall(SubId, (NP + 5) * SizeOf(Pointer)); +end; +procedure TEmitter.EmitOP_GENERAL_PUT; +var + Reg, SubId, PropNameId: Integer; + Code: TCode; + I, NP: Integer; + L: TIntegerList; +begin + EmitPCodeOperator; + + SubId := JS_PutGenericPropertyId; + + PropNameId := SymbolRec2.Id; + Code := TKernel(kernel).Code; + L := TIntegerList.Create; + for I:=Code.N downto 1 do + if Code.Records[I].Op = OP_OLE_PARAM then + if Code.Records[I].Res = PropNameId then + L.Insert(0, Code.Records[I].Arg1); + + Reg := GetReg; + + NP := L.Count; + EmitCallPro(SubId, (NP + 4) * SizeOf(Pointer)); + + if NP > 0 then + for I:=NP - 1 downto 0 do + begin + EmitLoadAddress(Reg, GetSymbolRec(L[I])); + Prg.AsmPush_REG(Reg); + end; + + EmitLoadAddress(Reg, SymbolRecR); // value + Prg.AsmPush_REG(Reg); + + Prg.AsmPush_Imm(NP); + + EmitGet_REG(Reg, SymbolRec2); // prop name - pchar + Prg.AsmPush_REG(Reg); + + EmitLoadAddress(Reg, SymbolRec1); // object + Prg.AsmPush_REG(Reg); + + FreeReg(Reg); + EmitStdCall(SubId, (NP + 4) * SizeOf(Pointer)); +end; + +procedure TEmitter.EmitOP_OLE_GET_64; +begin + RaiseError(errNotImplementedYet, []); +end; +procedure TEmitter.EmitOP_OLE_GET; +var + Reg, SubId, PropNameId: Integer; + Code: TCode; + I: Integer; + L: TIntegerList; +begin + if R.Language = JS_LANGUAGE then + begin + if TargetPlatform = tpWIN64 then + EmitOP_GENERAL_GET_64 + else + EmitOP_GENERAL_GET; + Exit; + end; + + EmitPCodeOperator; + + SubId := LookUp(_strGetOLEProperty); + if SubId = 0 then + RaiseError(errIMPORT_ActiveX, []); + + PropNameId := SymbolRec2.Id; + Code := TKernel(kernel).Code; + L := TIntegerList.Create; + + try + for I:=Code.N downto 1 do + if Code.Records[I].Op = OP_OLE_PARAM then + if Code.Records[I].Res = PropNameId then + L.Insert(0, Code.Records[I].Arg1); + + Reg := GetReg; + + for I:=L.Count - 1 downto 0 do + begin + EmitLoadAddress(Reg, GetSymbolRec(L[I])); + Prg.AsmPush_REG(Reg); + end; + + Prg.AsmPush_Imm(L.Count); + + EmitLoadAddress(Reg, SymbolRecR); // result + Prg.AsmPush_REG(Reg); + + EmitGet_REG(Reg, SymbolRec2); // prop name - pchar + Prg.AsmPush_REG(Reg); + + EmitLoadAddress(Reg, SymbolRec1); // object + Prg.AsmPush_REG(Reg); + + EmitGet_REG(Reg, SymbolTable[SubId]); + Prg.AsmCall_REG(Reg); + FreeReg(Reg); + finally + FreeAndNil(L); + end; +end; + +procedure TEmitter.EmitOP_OLE_SET_64; +begin + RaiseError(errNotImplementedYet, []); +end; +procedure TEmitter.EmitOP_OLE_SET; +var + Reg, SubId, PropNameId: Integer; + Code: TCode; + I: Integer; + L: TIntegerList; +begin + if R.Language = JS_LANGUAGE then + begin + if TargetPlatform = tpWIN64 then + EmitOP_GENERAL_PUT_64 + else + EmitOP_GENERAL_PUT; + Exit; + end; + + EmitPCodeOperator; + + SubId := LookUp(_strSetOLEProperty); + if SubId = 0 then + RaiseError(errIMPORT_ActiveX, []); + + PropNameId := SymbolRec2.Id; + Code := TKernel(kernel).Code; + L := TIntegerList.Create; + + try + for I:=Code.N downto 1 do + if Code.Records[I].Op = OP_OLE_PARAM then + if Code.Records[I].Res = PropNameId then + L.Insert(0, Code.Records[I].Arg1); + + Reg := GetReg; + + for I:=L.Count - 1 downto 0 do + begin + EmitLoadAddress(Reg, GetSymbolRec(L[I])); + Prg.AsmPush_REG(Reg); + end; + + Prg.AsmPush_Imm(L.Count); + + EmitLoadAddress(Reg, SymbolRecR); // value + Prg.AsmPush_REG(Reg); + + EmitGet_REG(Reg, SymbolRec2); // prop name - pchar + Prg.AsmPush_REG(Reg); + + EmitLoadAddress(Reg, SymbolRec1); // object + Prg.AsmPush_REG(Reg); + + EmitGet_REG(Reg, SymbolTable[SubId]); + Prg.AsmCall_REG(Reg); + FreeReg(Reg); + finally + FreeAndNil(L); + end; +end; + +procedure TEmitter.EmitOP_OLE_PARAM_64; +begin + EmitPCodeOperator; +end; +procedure TEmitter.EmitOP_OLE_PARAM; +begin + EmitPCodeOperator; +end; + +procedure TEmitter.EmitOP_ANSISTRING_CLR; +begin + EmitStdCall_Adr1(Id_AnsiStringClr); +end; +procedure TEmitter.EmitOP_ANSISTRING_CLR_64; +begin + EmitStdCall_Adr1(Id_AnsiStringClr); +end; + +procedure TEmitter.EmitOP_SET_LENGTH_64; +var + SubId, Reg, FinTypeId, T1, L1: Integer; +begin + EmitPCodeOperator; + Emit_PUSH_REGS; + + L1 := 0; + FinTypeId := SymbolRec1.FinalTypeId; + case FinTypeId of + typeVARIANT: SubId := Id_SetVariantLength; + typeUNICSTRING: SubId := Id_SetUnicStringLength; +{$IFNDEF PAXARM} + typeANSISTRING: SubId := Id_SetStringLength; + typeWIDESTRING: SubId := Id_SetWideStringLength; + typeSHORTSTRING: + begin + SubId := Id_SetShortStringLength; + T1 := SymbolRec1.TerminalTypeID; + L1 := GetSymbolRec(T1).Count; + if T1 = typeSHORTSTRING then + L1 := 255; + end; +{$ENDIF} + else + begin + SubId := 0; + RaiseError(errInternalError, []); + end; + end; + + EmitCallPro(SubId); + + Reg := GetRegEx; + + EmitLoadAddress(Reg, SymbolRec1); // source + Prg.AsmMovREG_REG(_ECX, Reg); + +{$IFNDEF PAXARM} + if FinTypeId = typeSHORTSTRING then + Prg.AsmMovREG_Imm(Reg, L1) + else +{$ENDIF} + if FinTypeId = typeVARIANT then + Prg.AsmMovREG_Imm(Reg, varVariant); + Prg.AsmMovREG_REG(_EDX, Reg); + + EmitLoadIntVal(Reg, SymbolRec2); // L + Prg.AsmMovREG_REG(_R8, Reg); + + FreeReg(Reg); + EmitStdCall(SubId); + + Emit_POP_REGS; +end; +procedure TEmitter.EmitOP_SET_LENGTH; +var + SubId, Reg, FinTypeId, T1, L1: Integer; +begin + EmitPCodeOperator; + Emit_PUSH_REGS; + + L1 := 0; + FinTypeId := SymbolRec1.FinalTypeId; + case FinTypeId of + typeVARIANT: SubId := Id_SetVariantLength; + typeUNICSTRING: SubId := Id_SetUnicStringLength; +{$IFNDEF PAXARM} + typeANSISTRING: SubId := Id_SetStringLength; + typeWIDESTRING: SubId := Id_SetWideStringLength; + typeSHORTSTRING: + begin + SubId := Id_SetShortStringLength; + T1 := SymbolRec1.TerminalTypeID; + L1 := GetSymbolRec(T1).Count; + if T1 = typeSHORTSTRING then + L1 := 255; + end; +{$ENDIF} + else + begin + SubId := 0; + RaiseError(errInternalError, []); + end; + end; + + EmitCallPro(SubId); + + Reg := GetReg; + + EmitLoadIntVal(Reg, SymbolRec2); // L + Prg.AsmPush_REG(Reg); + +{$IFNDEF PAXARM} + if FinTypeId = typeSHORTSTRING then + Prg.AsmPush_Imm(L1) + else +{$ENDIF} + if FinTypeId = typeVARIANT then + Prg.AsmPush_Imm(varVariant); + + EmitLoadAddress(Reg, SymbolRec1); // source + Prg.AsmPush_REG(Reg); + + FreeReg(Reg); + EmitStdCall(SubId); + + Emit_POP_REGS; +end; + +procedure TEmitter.EmitOP_SET_LENGTH_EX_64; +begin + RaiseError(errNotImplementedYet, []); +end; +procedure TEmitter.EmitOP_SET_LENGTH_EX; +var + I, K, SubId, Reg, FinTypeId,Id: Integer; + Lst: TIntegerList; + Code: TCode; + ElFinalTypeID, ElTypeID, ElSize: Integer; + IsFWArray: Boolean; +begin + Lst := TIntegerList.Create; + SubId := 0; + EmitPCodeOperator; + Emit_PUSH_REGS; + + Reg := GetReg; + + try + K := SymbolRec2.Id; + Code := TKernel(kernel).Code; + for I := Code.N downto 1 do + if Code[I].GenOp = OP_PUSH_LENGTH then + begin + Lst.Add(Code[I].Arg1); + if Lst.Count = K then + break; + end; + + FinTypeId := SymbolRec1.FinalTypeId; + + if FinTypeId = typeCLASS then + begin + FinTypeId := typeDYNARRAY; + IsFWArray := true; + end + else + IsFWArray := false; + + case FinTypeId of + typeVARIANT: + case K of + 1: SubId := Id_SetVariantLength; + 2: SubId := Id_SetVariantLength2; + 3: SubId := Id_SetVariantLength3; + else + RaiseError(errInternalError, []); + end; + typeDYNARRAY: + case K of + 1: SubId := Id_DynarraySetLength; + 2: SubId := Id_DynarraySetLength2; + 3: SubId := Id_DynarraySetLength3; + else + RaiseError(errInternalError, []); + end; + else + RaiseError(errInternalError, []); + end; + + EmitCallPro(SubId); + + if FinTypeId = typeDYNARRAY then + begin + ElTypeID := SymbolRec1.TerminalTypeId; + + if IsFWArray then + ElTypeID := GetSymbolRec(ElTypeId).PatternId; + + ElTypeID := GetSymbolRec(ElTypeId).PatternId; + + while GetSymbolRec(ElTypeId).FinalTypeId = typeDYNARRAY do + begin + ElTypeID := GetSymbolRec(ElTypeId).TerminalTypeId; + ElTypeID := GetSymbolRec(ElTypeId).PatternId; + end; + + ElFinalTypeID := GetSymbolRec(ElTypeId).FinalTypeId; + ElSize := GetSymbolRec(ElTypeId).Size; + + Prg.AsmPush_Imm(ElSize); + Prg.AsmPush_Imm(ElTypeID); + Prg.AsmPush_Imm(ElFinalTypeID); + + for I := 0 to Lst.Count - 1 do + begin + Id := Lst[I]; + EmitLoadIntVal(Reg, GetSymbolRec(Id)); + Prg.AsmPush_REG(Reg); + end; + + EmitLoadAddress(Reg, SymbolRec1); // address of array + + if IsFWArray then + begin + Prg.AsmMovREG_REGPtr(Reg, Reg); + Prg.AsmAddReg_Imm(Reg, FWArrayOffset); + end; + + Prg.AsmPush_REG(Reg); + + FreeReg(Reg); + + EmitStdCall(SubId); + + Exit; + end; + + for I := 0 to Lst.Count - 1 do + begin + Id := Lst[I]; + EmitLoadIntVal(Reg, GetSymbolRec(Id)); + Prg.AsmPush_REG(Reg); + end; + + Prg.AsmPush_Imm(varVariant); + + EmitLoadAddress(Reg, SymbolRec1); // source + Prg.AsmPush_REG(Reg); + + FreeReg(Reg); + EmitStdCall(SubId); + + finally + Emit_POP_REGS; + FreeAndNil(Lst); + end; +end; + +procedure TEmitter.EmitOP_WIDESTRING_CLR_64; +begin + EmitStdCall_Adr1(Id_WideStringClr); +end; +procedure TEmitter.EmitOP_WIDESTRING_CLR; +begin + EmitStdCall_Adr1(Id_WideStringClr); +end; + +procedure TEmitter.EmitOP_UNICSTRING_CLR_64; +begin + EmitStdCall_Adr1(Id_UnicStringClr); +end; +procedure TEmitter.EmitOP_UNICSTRING_CLR; +begin + EmitStdCall_Adr1(Id_UnicStringClr); +end; + +procedure TEmitter.EmitOP_INTERFACE_CLR_64; +begin + EmitStdCall_Adr1(Id_InterfaceClr); +end; +procedure TEmitter.EmitOP_INTERFACE_CLR; +begin + EmitStdCall_Adr1(Id_InterfaceClr); +end; + +procedure TEmitter.EmitOP_CLASS_CLR_64; +begin + EmitStdCall_Adr1(Id_ClassClr); +end; +procedure TEmitter.EmitOP_CLASS_CLR; +begin + EmitStdCall_Adr1(Id_ClassClr); +end; + +procedure TEmitter.EmitOP_SHORTSTRING_HIGH_64; +begin + EmitStdCall_Adr1_AdrR(Id_ShortstringHigh); +end; +procedure TEmitter.EmitOP_SHORTSTRING_HIGH; +begin + EmitStdCall_Adr1_AdrR(Id_ShortstringHigh); +end; + +procedure TEmitter.EmitOP_LOCK_VARRAY_64; +begin + EmitStdCall_Adr1_AdrR(Id_LockVArray); +end; +procedure TEmitter.EmitOP_LOCK_VARRAY; +begin + EmitStdCall_Adr1_AdrR(Id_LockVArray); +end; + +procedure TEmitter.EmitOP_UNLOCK_VARRAY_64; +begin + EmitStdCall_Adr1(Id_UnLockVArray); +end; +procedure TEmitter.EmitOP_UNLOCK_VARRAY; +begin + EmitStdCall_Adr1(Id_UnLockVArray); +end; + +procedure TEmitter.EmitOP_VARIANT_CLR_64; +begin + EmitStdCall_Adr1(Id_VariantClr); +end; +procedure TEmitter.EmitOP_VARIANT_CLR; +begin + EmitStdCall_Adr1(Id_VariantClr); +end; + +procedure TEmitter.EmitOP_DYNARRAY_CLR_64; +var + SubId, Reg, + ArrayTypeId, + ElSize, ElTypeId, ElFinalTypeId: Integer; + ElSize2, ElTypeId2, ElFinalTypeId2: Integer; +begin + EmitPCodeOperator; + + SubId := Id_DynarrayClr; + EmitCallPro(SubId); + + Reg := GetRegEx; + + ArrayTypeId := SymbolRec1.TerminalTypeId; + ElTypeId := GetSymbolRec(ArrayTypeId).PatternId; + ElFinalTypeId := GetSymbolRec(ElTypeId).FinalTypeId; + ElSize := SymbolTable[ElTypeId].Size; + + ElTypeId2 := 0; + ElFinalTypeId2 := 0; + ElSize2 := 0; + if ElFinalTypeId = typeDYNARRAY then + begin + ElTypeId2 := GetSymbolRec(ElTypeId).TerminalTypeId; + ElTypeId2 := GetSymbolRec(ElTypeId2).PatternId; + ElFinalTypeId2 := GetSymbolRec(ElTypeId2).FinalTypeId; + ElSize2 := SymbolTable[ElTypeId2].Size; + end; + + EmitLoadAddress(Reg, SymbolRec1); // source + Prg.AsmMovREG_REG(_ECX, Reg); + + Prg.AsmMovREG_Imm(Reg, ElFinalTypeId); + Prg.AsmMovREG_REG(_EDX, Reg); + + Prg.AsmMovREG_Imm(Reg, ElTypeId); + Prg.AsmMovREG_REG(_R8, Reg); + + Prg.AsmMovREG_Imm(Reg, ElSize); + Prg.AsmMovREG_REG(_R9, Reg); + + Prg.AsmMovREG_Imm(Reg, ElFinalTypeId2); + Prg.AsmMovRSPPtr_REG64(Reg, $20); + + Prg.AsmMovREG_Imm(Reg, ElTypeId2); + Prg.AsmMovRSPPtr_REG64(Reg, $28); + + Prg.AsmMovREG_Imm(Reg, ElSize2); + Prg.AsmMovRSPPtr_REG64(Reg, $30); + + FreeReg(Reg); + EmitStdCall(SubId); +end; +procedure TEmitter.EmitOP_DYNARRAY_CLR; +var + SubId, Reg, + ArrayTypeId, + ElSize, ElTypeId, ElFinalTypeId: Integer; + ElSize2, ElTypeId2, ElFinalTypeId2: Integer; +begin + EmitPCodeOperator; + + SubId := Id_DynarrayClr; + EmitCallPro(SubId); + + Reg := GetReg; + + ArrayTypeId := SymbolRec1.TerminalTypeId; + ElTypeId := GetSymbolRec(ArrayTypeId).PatternId; + ElFinalTypeId := GetSymbolRec(ElTypeId).FinalTypeId; + ElSize := SymbolTable[ElTypeId].Size; + + ElTypeId2 := 0; + ElFinalTypeId2 := 0; + ElSize2 := 0; + if ElFinalTypeId = typeDYNARRAY then + begin + ElTypeId2 := GetSymbolRec(ElTypeId).TerminalTypeId; + ElTypeId2 := GetSymbolRec(ElTypeId2).PatternId; + ElFinalTypeId2 := GetSymbolRec(ElTypeId2).FinalTypeId; + ElSize2 := SymbolTable[ElTypeId2].Size; + end; + + Prg.AsmPush_Imm(ElSize2); + Prg.AsmPush_Imm(ElTypeId2); + Prg.AsmPush_Imm(ElFinalTypeId2); + + Prg.AsmPush_Imm(ElSize); + Prg.AsmPush_Imm(ElTypeId); + Prg.AsmPush_Imm(ElFinalTypeId); + + EmitLoadAddress(Reg, SymbolRec1); // source + Prg.AsmPush_REG(Reg); + + FreeReg(Reg); + EmitStdCall(SubId); +end; + +procedure TEmitter.EmitOP_CREATE_EMPTY_DYNARRAY_64; +begin + Emit_PUSH_REGS; + EmitStdCall_Adr1(Id_CreateEmptyDynarray); + Emit_POP_REGS; +end; +procedure TEmitter.EmitOP_CREATE_EMPTY_DYNARRAY; +begin + Emit_PUSH_REGS; + EmitStdCall_Adr1(Id_CreateEmptyDynarray); + Emit_POP_REGS; +end; + +procedure TEmitter.EmitOP_DYNARRAY_HIGH_64; +begin + EmitStdCall_Adr1_AdrR(Id_DynarrayHigh); +end; +procedure TEmitter.EmitOP_DYNARRAY_HIGH; +begin + EmitStdCall_Adr1_AdrR(Id_DynarrayHigh); +end; + +procedure TEmitter.EmitOP_DYNARRAY_ASSIGN_64; +var + SubId, Reg, + ArrayTypeId, + ElSize, ElTypeId, ElFinalTypeId, + ElSize2, ElTypeId2, ElFinalTypeId2: Integer; +begin + EmitPCodeOperator; + + SubId := Id_DynarrayAssign; + EmitCallPro(SubId); + + Reg := GetRegEx; + + ArrayTypeId := SymbolRec1.TerminalTypeId; + ElTypeId := GetSymbolRec(ArrayTypeId).PatternId; + ElFinalTypeId := GetSymbolRec(ElTypeId).FinalTypeId; + ElSize := SymbolTable[ElTypeId].Size; + + ElTypeId2 := 0; + ElFinalTypeId2 := 0; + ElSize2 := 0; + if ElFinalTypeId = typeDYNARRAY then + begin + ElTypeId2 := GetSymbolRec(ElTypeId).TerminalTypeId; + ElTypeId2 := GetSymbolRec(ElTypeId2).PatternId; + ElFinalTypeId2 := GetSymbolRec(ElTypeId2).FinalTypeId; + ElSize2 := SymbolTable[ElTypeId2].Size; + end; + + EmitLoadAddress(Reg, SymbolRec2); // source + Prg.AsmMovREG_REG(_ECX, Reg); + + EmitLoadAddress(Reg, SymbolRec1); // dest + Prg.AsmMovREG_REG(_EDX, Reg); + + Prg.AsmMovREG_Imm(Reg, ElFinalTypeId); + Prg.AsmMovREG_REG(_R8, Reg); + + Prg.AsmMovREG_Imm(Reg, ElTypeId); + Prg.AsmMovREG_REG(_R9, Reg); + + Prg.AsmMovREG_Imm(Reg, ElSize); + Prg.AsmMovRSPPtr_REG64(Reg, $20); + + Prg.AsmMovREG_Imm(Reg, ElFinalTypeId2); + Prg.AsmMovRSPPtr_REG64(Reg, $28); + + Prg.AsmMovREG_Imm(Reg, ElTypeId2); + Prg.AsmMovRSPPtr_REG64(Reg, $30); + + Prg.AsmMovREG_Imm(Reg, ElSize2); + Prg.AsmMovRSPPtr_REG64(Reg, $38); + + FreeReg(Reg); + EmitStdCall(SubId); +end; +procedure TEmitter.EmitOP_DYNARRAY_ASSIGN; +var + SubId, Reg, + ArrayTypeId, + ElSize, ElTypeId, ElFinalTypeId, + ElSize2, ElTypeId2, ElFinalTypeId2: Integer; +begin + EmitPCodeOperator; + + SubId := Id_DynarrayAssign; + EmitCallPro(SubId); + + Reg := GetReg; + + ArrayTypeId := SymbolRec1.TerminalTypeId; + ElTypeId := GetSymbolRec(ArrayTypeId).PatternId; + ElFinalTypeId := GetSymbolRec(ElTypeId).FinalTypeId; + ElSize := SymbolTable[ElTypeId].Size; + + ElTypeId2 := 0; + ElFinalTypeId2 := 0; + ElSize2 := 0; + if ElFinalTypeId = typeDYNARRAY then + begin + ElTypeId2 := GetSymbolRec(ElTypeId).TerminalTypeId; + ElTypeId2 := GetSymbolRec(ElTypeId2).PatternId; + ElFinalTypeId2 := GetSymbolRec(ElTypeId2).FinalTypeId; + ElSize2 := SymbolTable[ElTypeId2].Size; + end; + + Prg.AsmPush_Imm(ElSize2); + Prg.AsmPush_Imm(ElTypeId2); + Prg.AsmPush_Imm(ElFinalTypeId2); + + Prg.AsmPush_Imm(ElSize); + Prg.AsmPush_Imm(ElTypeId); + Prg.AsmPush_Imm(ElFinalTypeId); + + EmitLoadAddress(Reg, SymbolRec1); // dest + Prg.AsmPush_REG(Reg); + + EmitLoadAddress(Reg, SymbolRec2); // source + Prg.AsmPush_REG(Reg); + + FreeReg(Reg); + EmitStdCall(SubId); +end; + +procedure TEmitter.EmitOP_ASSIGN_TVarRec_64; +var + SubId, Reg, + FinalTypeId: Integer; +begin + EmitPCodeOperator; + + SubId := Id_AssignTVarRec; + + EmitCallPro(SubId); + + Reg := GetRegEx; + + FinalTypeId := SymbolRec2.FinalTypeId; +{$IFNDEF PAXARM} + if SymbolRec2.HasPAnsiCharType then + begin + if SymbolRec2.Kind <> KindCONST then + FinalTypeId := typeANSISTRING + else + FinalTypeId := typePANSICHAR; + end + else +{$ENDIF} + if SymbolRec2.HasPWideCharType then + begin + if SymbolRec2.Kind <> KindCONST then + FinalTypeId := typeUNICSTRING + else + FinalTypeId := typePWIDECHAR; + end; + + Prg.AsmMovREG_REG(Reg, _ESI); + Prg.AsmAddREG_Imm(Reg, H_SelfPtr); + Prg.AsmMovREG_REGPtr(Reg, Reg); // load TProgram.Self + Prg.AsmMovREG_REG(_ECX, Reg); // push TProgram.Self + + EmitLoadAddress(Reg, SymbolRec2); // source + Prg.AsmMovREG_REG(_EDX, Reg); + + EmitLoadAddress(Reg, SymbolRec1); // dest + Prg.AsmMovREG_REG(_R8, Reg); + + Prg.AsmMovREG_Imm(Reg, FinalTypeId); + Prg.AsmMovREG_REG(_R9, Reg); + + FreeReg(Reg); + EmitStdCall(SubId); +end; +procedure TEmitter.EmitOP_ASSIGN_TVarRec; +var + SubId, Reg, + FinalTypeId: Integer; +begin + EmitPCodeOperator; + + SubId := Id_AssignTVarRec; + EmitCallPro(SubId); + + Reg := GetReg; + + FinalTypeId := SymbolRec2.FinalTypeId; +{$IFNDEF PAXARM} + if SymbolRec2.HasPAnsiCharType then + begin + if SymbolRec2.Kind <> KindCONST then + FinalTypeId := typeANSISTRING + else + FinalTypeId := typePANSICHAR; + end + else +{$ENDIF} + if SymbolRec2.HasPWideCharType then + begin + if SymbolRec2.Kind <> KindCONST then + FinalTypeId := typeUNICSTRING + else + FinalTypeId := typePWIDECHAR; + end; + + Prg.AsmPush_Imm(FinalTypeId); + + EmitLoadAddress(Reg, SymbolRec1); // dest + Prg.AsmPush_REG(Reg); + + EmitLoadAddress(Reg, SymbolRec2); // source + Prg.AsmPush_REG(Reg); + + Prg.AsmMovREG_REG(Reg, _ESI); + Prg.AsmAddREG_Imm(Reg, H_SelfPtr); + Prg.AsmMovREG_REGPtr(Reg, Reg); // load TProgram.Self + Prg.AsmPush_REG(Reg); // push TProgram.Self + + FreeReg(Reg); + EmitStdCall(SubId); +end; + +procedure TEmitter.EmitOP_STRUCTURE_CLR_64; +var + SubId, Reg, TypeId, I, S, FT, + ArrayTypeId, DestructorId, + ElTypeId, ElFinalTypeId, ElSize: Integer; + ElTypeId2, ElFinalTypeId2, ElSize2: Integer; + L, T: TIntegerList; +begin + EmitPCodeOperator; + + TypeId := SymbolRec1.TerminalTypeId; + + if TKernel(kernel).SymbolTable[TypeId].FinalTypeId = typeRECORD then + begin + DestructorId := TKernel(kernel).SymbolTable.FindDestructorId(TypeId); + if DestructorId <> 0 then + begin + EmitCallPro(DestructorId, 0); + if GetSymbolRec(DestructorId).Host then + begin + Reg := _EBX; + EmitGet_REG(Reg, GetSymbolRec(DestructorId)); + Prg.AsmCall_REG(Reg); + end + else + begin + EmitLoadAddress(_EAX, SymbolRec1); + + Reg := _EBX; + Prg.AsmMovREG_REG(Reg, _EDI); + Prg.AsmAddREG_Imm(Reg, 0); + Prg.Top.SaveSubId := DestructorId; + List2.Add(Prg.Top); + Prg.AsmCall_REG(Reg); + end; + EmitCallEpi(DestructorId, 0); + end; + end; + + L := TKernel(kernel).SymbolTable.GetShiftsOfDynamicFields(TypeId); + T := TKernel(kernel).SymbolTable.GetTypesOfDynamicFields(TypeId); + + if T.Count <> L.Count then + RaiseError(errInternalError, []); + + try + for I:=0 to L.Count - 1 do + begin + Reg := GetRegEx; + + S := L[I]; + + FT := GetSymbolRec(T[I]).FinalTypeId; + + SubId := 0; + case FT of +{$IFNDEF PAXARM} + typeANSISTRING: SubId := Id_AnsiStringClr; + typeWIDESTRING: SubId := Id_WideStringClr; +{$ENDIF} + typeUNICSTRING: SubId := Id_UnicStringClr; + typeVARIANT, typeOLEVARIANT: SubId := Id_VariantClr; + typeDYNARRAY: SubId := Id_DynarrayClr; + typeINTERFACE: SubId := Id_InterfaceClr; + typeCLASS: SubId := Id_ClassClr; + else + RaiseError(errInternalError, []); + end; + + EmitCallPro(SubId); + + if FT = typeDYNARRAY then + begin + ArrayTypeId := T[I]; + ElTypeId := GetSymbolRec(ArrayTypeId).PatternId; + ElFinalTypeId := GetSymbolRec(ElTypeId).FinalTypeId; + ElSize := SymbolTable[ElTypeId].Size; + + ElTypeId2 := 0; + ElFinalTypeId2 := 0; + ElSize2 := 0; + if ElFinalTypeId = typeDYNARRAY then + begin + ElTypeId2 := GetSymbolRec(ElTypeId).TerminalTypeId; + ElTypeId2 := GetSymbolRec(ElTypeId2).PatternId; + ElFinalTypeId2 := GetSymbolRec(ElTypeId2).FinalTypeId; + ElSize2 := SymbolTable[ElTypeId2].Size; + end; + + EmitLoadAddress(Reg, SymbolRec1); + Prg.AsmAddREG_Imm(Reg, S); + Prg.AsmMovREG_REG(_ECX, Reg); + + Prg.AsmMovREG_Imm(Reg, ElFinalTypeId); + Prg.AsmMovREG_REG(_EDX, Reg); + + Prg.AsmMovREG_Imm(Reg, ElTypeId); + Prg.AsmMovREG_REG(_R8, Reg); + + Prg.AsmMovREG_Imm(Reg, ElSize); + Prg.AsmMovREG_REG(_R9, Reg); + + Prg.AsmMovREG_Imm(Reg, ElFinalTypeId2); + Prg.AsmMovRSPPtr_REG64(Reg, $20); + + Prg.AsmMovREG_Imm(Reg, ElTypeId2); + Prg.AsmMovRSPPtr_REG64(Reg, $28); + + Prg.AsmMovREG_Imm(Reg, ElSize2); + Prg.AsmMovRSPPtr_REG64(Reg, $30); + end + else + begin + EmitLoadAddress(Reg, SymbolRec1); + Prg.AsmAddREG_Imm(Reg, S); + Prg.AsmMovREG_REG(_ECX, Reg); + end; + + FreeReg(Reg); + EmitStdCall(SubId); + end; // for-loop + finally + FreeAndNil(L); + FreeAndNil(T); + end; +end; +procedure TEmitter.EmitOP_STRUCTURE_CLR; +var + SubId, Reg, TypeId, I, S, FT, + ArrayTypeId, DestructorId, + ElTypeId, ElFinalTypeId, ElSize: Integer; + ElTypeId2, ElFinalTypeId2, ElSize2: Integer; + L, T: TIntegerList; +begin + EmitPCodeOperator; + + TypeId := SymbolRec1.TerminalTypeId; + + if TKernel(kernel).SymbolTable[TypeId].FinalTypeId = typeRECORD then + begin + DestructorId := TKernel(kernel).SymbolTable.FindDestructorId(TypeId); + if DestructorId <> 0 then + begin + SubId := DestructorId; + EmitCallPro(SubId); + if GetSymbolRec(DestructorId).Host then + begin + EmitStdCall(SubId); + end + else + begin + EmitLoadAddress(_EAX, SymbolRec1); + + Reg := _EDX; + Prg.AsmMovREG_REG(Reg, _EDI); + Prg.AsmAddREG_Imm(Reg, 0); + Prg.Top.SaveSubId := DestructorId; + List2.Add(Prg.Top); + Prg.AsmCall_REG(Reg); + + EmitCallEpi(SubId); + end; + end; + end; + + L := TKernel(kernel).SymbolTable.GetShiftsOfDynamicFields(TypeId); + T := TKernel(kernel).SymbolTable.GetTypesOfDynamicFields(TypeId); + + if T.Count <> L.Count then + RaiseError(errInternalError, []); + + try + for I:=0 to L.Count - 1 do + begin + Reg := GetReg; + S := L[I]; + + FT := GetSymbolRec(T[I]).FinalTypeId; + + SubId := 0; + case FT of +{$IFNDEF PAXARM} + typeANSISTRING: SubId := Id_AnsiStringClr; + typeWIDESTRING: SubId := Id_WideStringClr; +{$ENDIF} + typeUNICSTRING: SubId := Id_UnicStringClr; + typeVARIANT, typeOLEVARIANT: SubId := Id_VariantClr; + typeDYNARRAY: SubId := Id_DynarrayClr; + typeINTERFACE: SubId := Id_InterfaceClr; + typeCLASS: SubId := Id_ClassClr; + else + RaiseError(errInternalError, []); + end; + + EmitCallPro(SubId); + + if FT = typeDYNARRAY then + begin + ArrayTypeId := T[I]; + ElTypeId := GetSymbolRec(ArrayTypeId).PatternId; + ElFinalTypeId := GetSymbolRec(ElTypeId).FinalTypeId; + ElSize := SymbolTable[ElTypeId].Size; + + ElTypeId2 := 0; + ElFinalTypeId2 := 0; + ElSize2 := 0; + if ElFinalTypeId = typeDYNARRAY then + begin + ElTypeId2 := GetSymbolRec(ElTypeId).TerminalTypeId; + ElTypeId2 := GetSymbolRec(ElTypeId2).PatternId; + ElFinalTypeId2 := GetSymbolRec(ElTypeId2).FinalTypeId; + ElSize2 := SymbolTable[ElTypeId2].Size; + end; + + Prg.AsmPush_Imm(ElSize2); + Prg.AsmPush_Imm(ElTypeId2); + Prg.AsmPush_Imm(ElFinalTypeId2); + + Prg.AsmPush_Imm(ElSize); + Prg.AsmPush_Imm(ElTypeId); + Prg.AsmPush_Imm(ElFinalTypeId); + end; + + EmitLoadAddress(Reg, SymbolRec1); + Prg.AsmAddREG_Imm(Reg, S); + Prg.AsmPush_REG(Reg); + + FreeReg(Reg); + + EmitStdCall(SubId); + end; // for-loop + + finally + FreeAndNil(L); + FreeAndNil(T); + end; +end; + +procedure TEmitter.EmitOP_STRUCTURE_ADDREF_64; +var + SubId, Reg, TypeId, I, S, FT: Integer; + L, T: TIntegerList; +begin + EmitPCodeOperator; + + TypeId := SymbolRec1.TerminalTypeId; + L := TKernel(kernel).SymbolTable.GetShiftsOfDynamicFields(TypeId); + T := TKernel(kernel).SymbolTable.GetTypesOfDynamicFields(TypeId); + + if T.Count <> L.Count then + RaiseError(errInternalError, []); + + try + for I:=0 to L.Count - 1 do + begin + Reg := GetRegEx; + + S := L[I]; + + FT := GetSymbolRec(T[I]).FinalTypeId; + + SubId := 0; + case FT of +{$IFNDEF PAXARM} + typeANSISTRING: SubId := Id_StringAddRef; +{$ENDIF} + typeUNICSTRING: SubId := Id_UnicStringAddRef; + typeVARIANT, typeOLEVARIANT: SubId := Id_VariantAddRef; + typeDYNARRAY: SubId := Id_DynarrayAddRef; + typeINTERFACE: SubId := Id_InterfaceAddRef; + else + RaiseError(errInternalError, []); + end; + + EmitCallPro(SubId); + + EmitLoadAddress(Reg, SymbolRec1); + Prg.AsmAddREG_Imm(Reg, S); + Prg.AsmMovREG_REG(_ECX, Reg); + + FreeReg(Reg); + + EmitStdCall(SubId); + end; // for-loop + + finally + FreeAndNil(L); + FreeAndNil(T); + end; +end; +procedure TEmitter.EmitOP_STRUCTURE_ADDREF; +var + SubId, Reg, TypeId, I, S, FT: Integer; + L, T: TIntegerList; +begin + EmitPCodeOperator; + + TypeId := SymbolRec1.TerminalTypeId; + L := TKernel(kernel).SymbolTable.GetShiftsOfDynamicFields(TypeId); + T := TKernel(kernel).SymbolTable.GetTypesOfDynamicFields(TypeId); + + if T.Count <> L.Count then + RaiseError(errInternalError, []); + + try + for I:=0 to L.Count - 1 do + begin + Reg := GetReg; + + S := L[I]; + + FT := GetSymbolRec(T[I]).FinalTypeId; + + SubId := 0; + case FT of +{$IFNDEF PAXARM} + typeANSISTRING: SubId := Id_StringAddRef; +{$ENDIF} + typeVARIANT, typeOLEVARIANT: SubId := Id_VariantAddRef; + typeDYNARRAY: SubId := Id_DynarrayAddRef; + typeINTERFACE: SubId := Id_InterfaceAddRef; + else + RaiseError(errInternalError, []); + end; + + EmitCallPro(SubId); + + EmitLoadAddress(Reg, SymbolRec1); + Prg.AsmAddREG_Imm(Reg, S); + Prg.AsmPush_REG(Reg); + + FreeReg(Reg); + + EmitStdCall(SubId); + end; // for-loop + finally + FreeAndNil(L); + FreeAndNil(T); + end; +end; + +procedure TEmitter.EmitOP_PRINT_EX_64; +var + Reg, SubId, L, FT, K: Integer; +begin + EmitPCodeOperator; + + SubId := Id_PrintEx; + EmitCallPro(SubId); + + K := SymbolRec1.Kind; +{$IFNDEF PAXARM} + if SymbolRec1.HasPAnsiCharType then + FT := typePANSICHAR + else +{$ENDIF} + if SymbolRec1.HasPWideCharType then + FT := typePWIDECHAR + else + FT := SymbolRec1.FinalTypeId; + + Reg := GetRegEx; + + Prg.AsmMovREG_REG(Reg, _ESI); + Prg.AsmAddREG_Imm(Reg, H_SelfPtr); + Prg.AsmMovREG_REGPtr(Reg, Reg); // load TProgram.Self + Prg.AsmMovREG_REG(_ECX, Reg); + + if K = KindCONST then + begin + if FT in INT64Types then + begin + Prg.AsmMovREG_Imm(_EDX, ImmValue1); + end + else if FT in OrdinalTypes then + Prg.AsmMovREG_Imm(_EDX, ImmValue1) +{$IFNDEF PAXARM} + else if FT = typePANSICHAR then + begin + EmitGet_REG(Reg, SymbolRec1); // pchar source + Prg.AsmMovREG_REG(_EDX, Reg); + end +{$ENDIF} + else if FT = typePWIDECHAR then + begin + EmitGet_REG(Reg, SymbolRec1); // pchar source + Prg.AsmMovREG_REG(_EDX, Reg); + end + else + begin + EmitLoadAddress(Reg, SymbolRec1); // value + Prg.AsmMovREG_REG(_EDX, Reg); + end; + end + else + begin + EmitLoadAddress(Reg, SymbolRec1); // value + Prg.AsmMovREG_REG(_EDX, Reg); + end; + + Prg.AsmMovREG_Imm(_R8, K); + Prg.AsmMovREG_Imm(_R9, FT); + +/////////////////////////////////////////////////////////////////// + + L := R.Arg2; + if L > 0 then + begin + if GetSymbolRec(L).Kind = KindCONST then + begin + Prg.AsmMovREG_Imm(Reg, Cardinal(GetSymbolRec(L).Value)); + Prg.AsmMovRSPPtr_REG64(Reg, $20); + end + else + begin + EmitLoadIntVal(Reg, GetSymbolRec(L)); + Prg.AsmMovRSPPtr_REG64(Reg, $20); + end; + end + else + begin + Prg.AsmMovREG_Imm(Reg, 0); + Prg.AsmMovRSPPtr_REG64(Reg, $20); + end; + + L := R.Res; + if L > 0 then + begin + if GetSymbolRec(L).Kind = KindCONST then + begin + Prg.AsmMovREG_Imm(Reg, Cardinal(GetSymbolRec(L).Value)); + Prg.AsmMovRSPPtr_REG64(Reg, $28); + end + else + begin + EmitLoadIntVal(Reg, GetSymbolRec(L)); + Prg.AsmMovRSPPtr_REG64(Reg, $28); + end; + end + else + begin + Prg.AsmMovREG_Imm(Reg, 0); + Prg.AsmMovRSPPtr_REG64(Reg, $28); + end; + + FreeReg(Reg); + EmitStdCall(SubId); +end; +procedure TEmitter.EmitOP_PRINT_EX; +var + Reg, SubId, L, FT, K: Integer; +begin + EmitPCodeOperator; + + SubId := Id_PrintEx; + + EmitCallPro(SubId); + + Reg := GetReg; + + L := R.Res; + if L > 0 then + begin + if GetSymbolRec(L).Kind = KindCONST then + Prg.AsmPush_Imm(Cardinal(GetSymbolRec(L).Value)) + else + begin + EmitLoadIntVal(Reg, GetSymbolRec(L)); + Prg.AsmPush_REG(Reg); + end; + end + else + Prg.AsmPush_Imm(0); + + L := R.Arg2; + if L > 0 then + begin + if GetSymbolRec(L).Kind = KindCONST then + Prg.AsmPush_Imm(Cardinal(GetSymbolRec(L).Value)) + else + begin + EmitLoadIntVal(Reg, GetSymbolRec(L)); + Prg.AsmPush_REG(Reg); + end; + end + else + Prg.AsmPush_Imm(0); + +{$IFNDEF PAXARM} + if SymbolRec1.HasPAnsiCharType then + FT := typePANSICHAR + else +{$ENDIF} + if SymbolRec1.HasPWideCharType then + FT := typePWIDECHAR + else + FT := SymbolRec1.FinalTypeId; + + K := SymbolRec1.Kind; + + Prg.AsmPush_Imm(FT); + Prg.AsmPush_Imm(K); + + if K = KindCONST then + begin + if FT in INT64Types then + begin + Prg.AsmPush_Imm(ImmValue1); + end + else if FT in OrdinalTypes then + Prg.AsmPush_Imm(ImmValue1) +{$IFNDEF PAXARM} + else if FT = typePANSICHAR then + begin + EmitGet_REG(Reg, SymbolRec1); // pchar source + Prg.AsmPush_REG(Reg); + end +{$ENDIF} + else if FT = typePWIDECHAR then + begin + EmitGet_REG(Reg, SymbolRec1); // pchar source + Prg.AsmPush_REG(Reg); + end + else + begin + EmitLoadAddress(Reg, SymbolRec1); // value + Prg.AsmPush_REG(Reg); + end; + end + else + begin + EmitLoadAddress(Reg, SymbolRec1); // value + Prg.AsmPush_REG(Reg); + end; + + Prg.AsmMovREG_REG(Reg, _ESI); + Prg.AsmAddREG_Imm(Reg, H_SelfPtr); + Prg.AsmMovREG_REGPtr(Reg, Reg); // load TProgram.Self + Prg.AsmPush_REG(Reg); + + FreeReg(Reg); + EmitStdCall(SubId); +end; + +procedure TEmitter.EmitOP_TO_FW_OBJECT_64; +var + Reg, SubId, FT, K: Integer; +begin + EmitPCodeOperator; + + SubId := Id_ToFWObject; + EmitCallPro(SubId); + + Reg := GetRegEx; + + K := SymbolRec1.Kind; +{$IFNDEF PAXARM} + if SymbolRec1.HasPAnsiCharType then + FT := typePANSICHAR + else +{$ENDIF} + if SymbolRec1.HasPWideCharType then + FT := typePWIDECHAR + else + FT := SymbolRec1.FinalTypeId; + + Prg.AsmMovREG_REG(Reg, _ESI); + Prg.AsmAddREG_Imm(Reg, H_SelfPtr); + Prg.AsmMovREG_REGPtr(Reg, Reg); // load TProgram.Self + Prg.AsmMovREG_REG(_ECX, Reg); + + if K = KindCONST then + begin + if FT in INT64Types then + begin + Prg.AsmMovREG_Imm(Reg, ImmValue1); + Prg.AsmMovREG_REG(_EDX, Reg); + end + else if FT in OrdinalTypes then + begin + Prg.AsmMovREG_Imm(Reg, ImmValue1); + Prg.AsmMovREG_REG(_EDX, Reg); + end +{$IFNDEF PAXARM} + else if FT = typePANSICHAR then + begin + EmitGet_REG(Reg, SymbolRec1); // pchar source + Prg.AsmMovREG_REG(_EDX, Reg); + end +{$ENDIF} + else if FT = typePWIDECHAR then + begin + EmitGet_REG(Reg, SymbolRec1); // pchar source + Prg.AsmMovREG_REG(_EDX, Reg); + end + else + begin + EmitLoadAddress(Reg, SymbolRec1); // value + Prg.AsmMovREG_REG(_EDX, Reg); + end; + end + else + begin + EmitLoadAddress(Reg, SymbolRec1); // value + Prg.AsmMovREG_REG(_EDX, Reg); + end; + + Prg.AsmMovREG_Imm(Reg, K); + Prg.AsmMovREG_REG(_R8, Reg); + + Prg.AsmMovREG_Imm(Reg, FT); + Prg.AsmMovREG_REG(_R9, Reg); + + Prg.AsmMovREG_Imm(Reg, SymbolRec1.TypeId); + Prg.AsmMovRSPPtr_REG64(Reg, $20); + + EmitLoadAddress(Reg, SymbolRecR); // result + Prg.AsmMovRSPPtr_REG64(Reg, $28); + + FreeReg(Reg); + EmitStdCall(SubId); +end; +procedure TEmitter.EmitOP_TO_FW_OBJECT; +var + Reg, SubId, FT, K: Integer; +begin + EmitPCodeOperator; + + SubId := Id_ToFWObject; + EmitCallPro(SubId); + + Reg := GetReg; + + EmitLoadAddress(Reg, SymbolRecR); // result + Prg.AsmPush_REG(Reg); + +{$IFNDEF PAXARM} + if SymbolRec1.HasPAnsiCharType then + FT := typePANSICHAR + else +{$ENDIF} + if SymbolRec1.HasPWideCharType then + FT := typePWIDECHAR + else + FT := SymbolRec1.FinalTypeId; + + K := SymbolRec1.Kind; + + Prg.AsmPush_Imm(SymbolRec1.TypeId); + Prg.AsmPush_Imm(FT); + Prg.AsmPush_Imm(K); + + if K = KindCONST then + begin + if FT in INT64Types then + begin + Prg.AsmPush_Imm(ImmValue1); + end + else if FT in OrdinalTypes then + Prg.AsmPush_Imm(ImmValue1) +{$IFNDEF PAXARM} + else if FT = typePANSICHAR then + begin + EmitGet_REG(Reg, SymbolRec1); // pchar source + Prg.AsmPush_REG(Reg); + end +{$ENDIF} + else if FT = typePWIDECHAR then + begin + EmitGet_REG(Reg, SymbolRec1); // pchar source + Prg.AsmPush_REG(Reg); + end + else + begin + EmitLoadAddress(Reg, SymbolRec1); // value + Prg.AsmPush_REG(Reg); + end; + end + else + begin + EmitLoadAddress(Reg, SymbolRec1); // value + Prg.AsmPush_REG(Reg); + end; + + Prg.AsmMovREG_REG(Reg, _ESI); + Prg.AsmAddREG_Imm(Reg, H_SelfPtr); + Prg.AsmMovREG_REGPtr(Reg, Reg); // load TProgram.Self + Prg.AsmPush_REG(Reg); + + FreeReg(Reg); + EmitStdCall(SubId); +end; + +procedure TEmitter.EmitOP_PUSH_CONTEXT_64; +var + SubId, Reg: Integer; +begin + EmitPCodeOperator; + + SubId := Id_PushContext; + EmitCallPro(SubId); + + Reg := GetRegEx; + + Prg.AsmMovREG_REG(Reg, _ESI); + Prg.AsmAddREG_Imm(Reg, H_SelfPtr); + Prg.AsmMovREG_REGPtr(Reg, Reg); // load TProgram.Self + Prg.AsmMovREG_REG(_ECX, Reg); + + EmitLoadAddress(Reg, SymbolRec1); // instance + Prg.AsmMovREG_REG(_EDX, Reg); + + FreeReg(Reg); + EmitStdCall(SubId); +end; +procedure TEmitter.EmitOP_PUSH_CONTEXT; +var + SubId, Reg: Integer; +begin + EmitPCodeOperator; + + SubId := Id_PushContext; + EmitCallPro(SubId); + + Reg := GetReg; + + EmitLoadAddress(Reg, SymbolRec1); // instance + Prg.AsmPush_REG(Reg); + + Prg.AsmMovREG_REG(Reg, _ESI); + Prg.AsmAddREG_Imm(Reg, H_SelfPtr); + Prg.AsmMovREG_REGPtr(Reg, Reg); // load TProgram.Self + Prg.AsmPush_REG(Reg); + + FreeReg(Reg); + EmitStdCall(SubId); +end; + +procedure TEmitter.EmitOP_FIND_CONTEXT_64; +var + SubId, Reg: Integer; +begin + EmitPCodeOperator; + + SubId := Id_FindContext; + EmitCallPro(SubId); + + Reg := GetRegEx; + + Prg.AsmMovREG_REG(Reg, _ESI); + Prg.AsmAddREG_Imm(Reg, H_SelfPtr); + Prg.AsmMovREG_REGPtr(Reg, Reg); // load TProgram.Self + Prg.AsmMovREG_REG(_ECX, Reg); + + EmitGet_REG(Reg, SymbolRec1); // prop name - pchar + Prg.AsmMovREG_REG(_EDX, Reg); + + EmitLoadAddress(Reg, SymbolRec2); // alt + Prg.AsmMovREG_REG(_R8, Reg); + + Prg.AsmMovREG_Imm(Reg, SymbolRec2.FinalTypeId); + Prg.AsmMovREG_REG(_R9, Reg); + + EmitLoadAddress(Reg, SymbolRecR); // (var) result + Prg.AsmMovRSPPtr_REG64(Reg, $20); + + FreeReg(Reg); + EmitStdCall(SubId); +end; +procedure TEmitter.EmitOP_FIND_CONTEXT; +var + SubId, Reg: Integer; +begin + + EmitPCodeOperator; + + SubId := Id_FindContext; + EmitCallPro(SubId); + + Reg := GetReg; + + EmitLoadAddress(Reg, SymbolRecR); // (var) result + Prg.AsmPush_REG(Reg); + + Prg.AsmPush_Imm(SymbolRec2.FinalTypeId); + + EmitLoadAddress(Reg, SymbolRec2); // alt + Prg.AsmPush_REG(Reg); + + EmitGet_REG(Reg, SymbolRec1); // prop name - pchar + Prg.AsmPush_REG(Reg); + + Prg.AsmMovREG_REG(Reg, _ESI); + Prg.AsmAddREG_Imm(Reg, H_SelfPtr); + Prg.AsmMovREG_REGPtr(Reg, Reg); // load TProgram.Self + Prg.AsmPush_REG(Reg); + + FreeReg(Reg); + EmitStdCall(SubId); +end; + +procedure TEmitter.EmitOP_FIND_JS_FUNC_64; +var + SubId, Reg: Integer; +begin + EmitPCodeOperator; + + SubId := JS_FindFuncId; + EmitCallPro(SubId); + + + Reg := GetRegEx; + + Prg.AsmMovREG_REG(Reg, _ESI); + Prg.AsmAddREG_Imm(Reg, H_SelfPtr); + Prg.AsmMovREG_REGPtr(Reg, Reg); // load TProgram.Self + Prg.AsmMovREG_REG(_ECX, Reg); + + EmitGet_REG(Reg, SymbolRec1); // prop name - pchar + Prg.AsmMovREG_REG(_EDX, Reg); + + EmitLoadAddress(Reg, SymbolRec2); // alt + Prg.AsmMovREG_REG(_R8, Reg); + + EmitLoadAddress(Reg, SymbolRecR); // (var) result + Prg.AsmMovREG_REG(_R9, Reg); + + FreeReg(Reg); + EmitStdCall(SubId); +end; +procedure TEmitter.EmitOP_FIND_JS_FUNC; +var + SubId, Reg: Integer; +begin + EmitPCodeOperator; + + SubId := JS_FindFuncId; + EmitCallPro(SubId); + + Reg := GetReg; + + EmitLoadAddress(Reg, SymbolRecR); // (var) result + Prg.AsmPush_REG(Reg); + + EmitLoadAddress(Reg, SymbolRec2); // alt + Prg.AsmPush_REG(Reg); + + EmitGet_REG(Reg, SymbolRec1); // prop name - pchar + Prg.AsmPush_REG(Reg); + + Prg.AsmMovREG_REG(Reg, _ESI); + Prg.AsmAddREG_Imm(Reg, H_SelfPtr); + Prg.AsmMovREG_REGPtr(Reg, Reg); // load TProgram.Self + Prg.AsmPush_REG(Reg); + + FreeReg(Reg); + EmitStdCall(SubId); +end; + +procedure TEmitter.EmitOP_POP_CONTEXT_64; +var + SubId, Reg: Integer; +begin + EmitPCodeOperator; + + SubId := Id_PopContext; + EmitCallPro(SubId); + + Reg := GetRegEx; + + Prg.AsmMovREG_REG(Reg, _ESI); + Prg.AsmAddREG_Imm(Reg, H_SelfPtr); + Prg.AsmMovREG_REGPtr(Reg, Reg); // load TProgram.Self + Prg.AsmMovREG_REG(_ECX, Reg); + + FreeReg(Reg); + EmitStdCall(SubId); +end; +procedure TEmitter.EmitOP_POP_CONTEXT; +var + SubId, Reg: Integer; +begin + EmitPCodeOperator; + + SubId := Id_PopContext; + EmitCallPro(SubId); + + Reg := GetReg; + + Prg.AsmMovREG_REG(Reg, _ESI); + Prg.AsmAddREG_Imm(Reg, H_SelfPtr); + Prg.AsmMovREG_REGPtr(Reg, Reg); // load TProgram.Self + Prg.AsmPush_REG(Reg); + + FreeReg(Reg); + EmitStdCall(SubId); +end; + +procedure TEmitter.EmitOP_IS_64; +var + SubId, Reg, TypeId: Integer; +begin + EmitPCodeOperator; + + SubId := Id_Is; + EmitCallPro(SubId); + + Reg := GetRegEx; + + TypeId := SymbolRec2.TerminalTypeId; + EmitLoadIntVal(Reg, GetSymbolRec(TypeId + 1)); // instance + Prg.AsmMovREG_REG(_ECX, Reg); + + EmitLoadIntVal(Reg, SymbolRec1); // instance + Prg.AsmMovREG_REG(_EDX, Reg); + + EmitLoadAddress(Reg, SymbolRecR); // result + Prg.AsmMovREG_REG(_R8, Reg); + + FreeReg(Reg); + EmitStdCall(SubId); +end; +procedure TEmitter.EmitOP_IS; +var + SubId, Reg, TypeId: Integer; +begin + EmitPCodeOperator; + + SubId := Id_Is; + EmitCallPro(SubId); + + Reg := GetReg; + + EmitLoadAddress(Reg, SymbolRecR); // result + Prg.AsmPush_REG(Reg); + + EmitLoadIntVal(Reg, SymbolRec1); // instance + Prg.AsmPush_REG(Reg); + + TypeId := SymbolRec2.TerminalTypeId; + EmitLoadIntVal(Reg, GetSymbolRec(TypeId + 1)); // instance + Prg.AsmPush_REG(Reg); + + FreeReg(Reg); + EmitStdCall(SubId); +end; + +procedure TEmitter.EmitOP_GET_PROG_64; +var + Reg: Integer; +begin + EmitPCodeOperator; + + Reg := GetRegEx; + + Prg.AsmMovREG_REG(Reg, _ESI); + Prg.AsmAddREG_Imm(Reg, H_SelfPtr); + Prg.AsmMovREG_REGPtr(Reg, Reg); // load TProgram.Self + + EmitSaveIntVal(Reg, SymbolRecR); + + FreeReg(Reg); +end; +procedure TEmitter.EmitOP_GET_PROG; +var + Reg: Integer; +begin + EmitPCodeOperator; + + Reg := GetRegEx; + + Prg.AsmMovREG_REG(Reg, _ESI); + Prg.AsmAddREG_Imm(Reg, H_SelfPtr); + Prg.AsmMovREG_REGPtr(Reg, Reg); // load TProgram.Self + + EmitSaveIntVal(Reg, SymbolRecR); + + FreeReg(Reg); +end; + +procedure TEmitter.EmitOP_TYPEINFO_64; +var + SubId, Reg: Integer; +begin + EmitPCodeOperator; + + SubId := Id_TypeInfo; + EmitCallPro(SubId); + + Reg := GetRegEx; + + Prg.AsmMovREG_REG(Reg, _ESI); + Prg.AsmAddREG_Imm(Reg, H_SelfPtr); + Prg.AsmMovREG_REGPtr(Reg, Reg); // load TProgram.Self + Prg.AsmMovREG_REG(_ECX, Reg); + + EmitGet_REG(Reg, SymbolRec2); // prop name - pchar + Prg.AsmMovREG_REG(_EDX, Reg); + + EmitLoadAddress(Reg, SymbolRecR); // result + Prg.AsmMovREG_REG(_R8, Reg); + + FreeReg(Reg); + EmitStdCall(SubId); +end; +procedure TEmitter.EmitOP_TYPEINFO; +var + SubId, Reg: Integer; +begin + EmitPCodeOperator; + + SubId := Id_TypeInfo; + EmitCallPro(SubId); + + Reg := GetReg; + + EmitLoadAddress(Reg, SymbolRecR); // result + Prg.AsmPush_REG(Reg); + + EmitGet_REG(Reg, SymbolRec2); // prop name - pchar + Prg.AsmPush_REG(Reg); + + Prg.AsmMovREG_REG(Reg, _ESI); + Prg.AsmAddREG_Imm(Reg, H_SelfPtr); + Prg.AsmMovREG_REGPtr(Reg, Reg); // load TProgram.Self + Prg.AsmPush_REG(Reg); + + FreeReg(Reg); + EmitStdCall(SubId); +end; + +procedure TEmitter.EmitOP_INIT_FWARRAY_64; +var + SubId, Reg, T: Integer; +begin + EmitPCodeOperator; + + SubId := Id_InitFWArray; + EmitCallPro(SubId); + + T := SymbolRec1.TerminalTypeId; + T := TKernel(kernel).SymbolTable[T].PatternId; //ArrayTypeId + T := TKernel(kernel).SymbolTable[T].PatternId; //ElemTypeId + + Reg := GetRegEx; + + Prg.AsmMovREG_REG(Reg, _ESI); + Prg.AsmAddREG_Imm(Reg, H_SelfPtr); + Prg.AsmMovREG_REGPtr(Reg, Reg); // load TProgram.Self + Prg.AsmMovREG_REG(_ECX, Reg); // push TProgram.Self + + EmitLoadIntVal(Reg, SymbolRec1); // instance + Prg.AsmMovREG_REG(_EDX, Reg); + + Prg.AsmMovREG_Imm(Reg, R.Arg2); // NBounds + Prg.AsmMovREG_REG(_R8, Reg); + + Prg.AsmMovREG_Imm(Reg, TKernel(kernel).SymbolTable[T].FinalTypeId); + Prg.AsmMovREG_REG(_R9, Reg); + + Prg.AsmMovREG_Imm(Reg, T); // ElemTypeId + Prg.AsmMovRSPPtr_REG64(Reg, $20); + + Prg.AsmMovREG_Imm(Reg, TKernel(kernel).SymbolTable[T].FinSize); + Prg.AsmMovRSPPtr_REG64(Reg, $28); + + Prg.AsmMovREG_Imm(Reg, R.Res); + Prg.AsmMovRSPPtr_REG64(Reg, $30); + + FreeReg(Reg); + EmitStdCall(SubId); +end; +procedure TEmitter.EmitOP_INIT_FWARRAY; +var + SubId, Reg, T: Integer; +begin + EmitPCodeOperator; + + SubId := Id_InitFWArray; + EmitCallPro(SubId); + + Reg := GetReg; + + Prg.AsmMovREG_REG(Reg, _ESI); + Prg.AsmAddREG_Imm(Reg, H_SelfPtr); + Prg.AsmMovREG_REGPtr(Reg, Reg); // load TProgram.Self + Prg.AsmPush_REG(Reg); // push TProgram.Self + + EmitLoadIntVal(Reg, SymbolRec1); // instance + Prg.AsmPush_REG(Reg); + + Prg.AsmPush_Imm(R.Arg2); // NBounds + + T := SymbolRec1.TerminalTypeId; + T := TKernel(kernel).SymbolTable[T].PatternId; //ArrayTypeId + T := TKernel(kernel).SymbolTable[T].PatternId; //ElemTypeId + + Prg.AsmPush_Imm(TKernel(kernel).SymbolTable[T].FinalTypeId); + Prg.AsmPush_Imm(T); // ElemTypeId + Prg.AsmPush_Imm(TKernel(kernel).SymbolTable[T].FinSize); + Prg.AsmPush_Imm(R.Res); // ElemTypeId + + FreeReg(Reg); + EmitStdCall(SubId); +end; + +procedure TEmitter.EmitOP_BEFORE_CALL_HOST; +var + SubId, Reg: Integer; +begin + EmitPCodeOperator; + + SubId := Id_BeforeCallHost; + EmitCallPro(SubId); + + Reg := GetReg; + + Prg.AsmPush_Imm(SymbolRec1.Id); + + Prg.AsmMovREG_REG(Reg, _ESI); + Prg.AsmAddREG_Imm(Reg, H_SelfPtr); + Prg.AsmMovREG_REGPtr(Reg, Reg); // load TProgram.Self + Prg.AsmPush_REG(Reg); + + FreeReg(Reg); + EmitStdCall(SubId); +end; + +procedure TEmitter.EmitOP_AFTER_CALL_HOST; +var + SubId, Reg: Integer; +begin + EmitPCodeOperator; + + SubId := Id_AfterCallHost; + EmitCallPro(SubId); + + Reg := GetReg; + + Prg.AsmPush_Imm(SymbolRec1.Id); + + Prg.AsmMovREG_REG(Reg, _ESI); + Prg.AsmAddREG_Imm(Reg, H_SelfPtr); + Prg.AsmMovREG_REGPtr(Reg, Reg); // load TProgram.Self + Prg.AsmPush_REG(Reg); + + FreeReg(Reg); + EmitStdCall(SubId); +end; + +procedure TEmitter.EmitOP_BEFORE_CALL_HOST_64; +var + SubId, Reg: Integer; +begin + EmitPCodeOperator; + + SubId := Id_BeforeCallHost; + EmitCallPro(SubId); + + Reg := GetRegEx; + + Prg.AsmMovREG_REG(Reg, _ESI); + Prg.AsmAddREG_Imm(Reg, H_SelfPtr); + Prg.AsmMovREG_REGPtr(Reg, Reg); // load TProgram.Self + Prg.AsmMovREG_REG(_ECX, Reg); + + Prg.AsmMovREG_Imm(_EDX, SymbolRec1.Id); + + FreeReg(Reg); + EmitStdCall(SubId); +end; + +procedure TEmitter.EmitOP_AFTER_CALL_HOST_64; +var + SubId, Reg: Integer; +begin + EmitPCodeOperator; + + SubId := Id_AfterCallHost; + EmitCallPro(SubId); + + Reg := GetRegEx; + + Prg.AsmMovREG_REG(Reg, _ESI); + Prg.AsmAddREG_Imm(Reg, H_SelfPtr); + Prg.AsmMovREG_REGPtr(Reg, Reg); // load TProgram.Self + Prg.AsmMovREG_REG(_ECX, Reg); + + Prg.AsmMovREG_Imm(_EDX, SymbolRec1.Id); + + FreeReg(Reg); + EmitStdCall(SubId); +end; + +procedure TEmitter.EmitOP_ONCREATE_HOST_OBJECT_64; +var + SubId, Reg: Integer; +begin + SubId := Id_OnCreateHostObject; + + EmitPCodeOperator; + + EmitCallPro(SubId); + + Reg := GetRegEx; + + Prg.AsmMovREG_REG(Reg, _ESI); + Prg.AsmAddREG_Imm(Reg, H_SelfPtr); + Prg.AsmMovREG_REGPtr(Reg, Reg); // load TProgram.Self + Prg.AsmMovREG_REG(_ECX, Reg); + + EmitLoadIntVal(Reg, SymbolRec1); // instance + Prg.AsmMovREG_REG(_EDX, Reg); + + FreeReg(Reg); + EmitStdCall(SubId); +end; +procedure TEmitter.EmitOP_ONCREATE_HOST_OBJECT; +var + SubId, Reg: Integer; +begin + SubId := Id_OnCreateHostObject; + + EmitPCodeOperator; + + EmitCallPro(SubId); + + Reg := GetReg; + + EmitLoadIntVal(Reg, SymbolRec1); // instance + Prg.AsmPush_REG(Reg); + + Prg.AsmMovREG_REG(Reg, _ESI); + Prg.AsmAddREG_Imm(Reg, H_SelfPtr); + Prg.AsmMovREG_REGPtr(Reg, Reg); // load TProgram.Self + Prg.AsmPush_REG(Reg); + + FreeReg(Reg); + EmitStdCall(SubId); +end; + +procedure TEmitter.EmitOP_ONDESTROY_HOST_OBJECT_64; +var + SubId, Reg: Integer; +begin + SubId := Id_OnDestroyHostObject; + + EmitPCodeOperator; + + EmitCallPro(SubId); + + Reg := GetRegEx; + + Prg.AsmMovREG_REG(Reg, _ESI); + Prg.AsmAddREG_Imm(Reg, H_SelfPtr); + Prg.AsmMovREG_REGPtr(Reg, Reg); // load TProgram.Self + Prg.AsmMovREG_REG(_ECX, Reg); + + EmitLoadIntVal(Reg, SymbolRec1); // instance + Prg.AsmMovREG_REG(_EDX, Reg); + + FreeReg(Reg); + EmitStdCall(SubId); +end; +procedure TEmitter.EmitOP_ONDESTROY_HOST_OBJECT; +var + SubId, Reg: Integer; +begin + SubId := Id_OnDestroyHostObject; + + EmitPCodeOperator; + + EmitCallPro(SubId); + + Reg := GetReg; + + EmitLoadIntVal(Reg, SymbolRec1); // instance + Prg.AsmPush_REG(Reg); + + Prg.AsmMovREG_REG(Reg, _ESI); + Prg.AsmAddREG_Imm(Reg, H_SelfPtr); + Prg.AsmMovREG_REGPtr(Reg, Reg); // load TProgram.Self + Prg.AsmPush_REG(Reg); + + FreeReg(Reg); + EmitStdCall(SubId); +end; + +procedure TEmitter.EmitOP_ONCREATE_OBJECT_64; +var + SubId, Reg: Integer; +begin + SubId := Id_OnCreateObject; + + EmitPCodeOperator; + + EmitCallPro(SubId); + + Reg := GetRegEx; + + Prg.AsmMovREG_REG(Reg, _ESI); + Prg.AsmAddREG_Imm(Reg, H_SelfPtr); + Prg.AsmMovREG_REGPtr(Reg, Reg); // load TProgram.Self + Prg.AsmMovREG_REG(_ECX, Reg); + + EmitLoadIntVal(Reg, SymbolRec1); // instance + Prg.AsmMovREG_REG(_EDX, Reg); + + FreeReg(Reg); + EmitStdCall(SubId); +end; +procedure TEmitter.EmitOP_ONCREATE_OBJECT; +var + SubId, Reg: Integer; +begin + SubId := Id_OnCreateObject; + + EmitPCodeOperator; + + EmitCallPro(SubId); + + Reg := GetReg; + + EmitLoadIntVal(Reg, SymbolRec1); // instance + Prg.AsmPush_REG(Reg); + + Prg.AsmMovREG_REG(Reg, _ESI); + Prg.AsmAddREG_Imm(Reg, H_SelfPtr); + Prg.AsmMovREG_REGPtr(Reg, Reg); // load TProgram.Self + Prg.AsmPush_REG(Reg); + + FreeReg(Reg); + EmitStdCall(SubId); +end; + +procedure TEmitter.EmitOP_ON_AFTER_OBJECT_CREATION_64; +var + SubId, Reg: Integer; +begin + SubId := Id_OnAfterObjectCreation; + + EmitPCodeOperator; + + EmitCallPro(SubId); + + Reg := GetRegEx; + + Prg.AsmMovREG_REG(Reg, _ESI); + Prg.AsmAddREG_Imm(Reg, H_SelfPtr); + Prg.AsmMovREG_REGPtr(Reg, Reg); // load TProgram.Self + Prg.AsmMovREG_REG(_ECX, Reg); + + EmitLoadAddress(Reg, SymbolRec1); // instance + Prg.AsmMovREG_REG(_EDX, Reg); + + FreeReg(Reg); + EmitStdCall(SubId); +end; +procedure TEmitter.EmitOP_ON_AFTER_OBJECT_CREATION; +var + SubId, Reg: Integer; +begin + SubId := Id_OnAfterObjectCreation; + + EmitPCodeOperator; + + EmitCallPro(SubId); + + Reg := GetReg; + + EmitLoadAddress(Reg, SymbolRec1); // instance + Prg.AsmPush_REG(Reg); + + Prg.AsmMovREG_REG(Reg, _ESI); + Prg.AsmAddREG_Imm(Reg, H_SelfPtr); + Prg.AsmMovREG_REGPtr(Reg, Reg); // load TProgram.Self + Prg.AsmPush_REG(Reg); + + FreeReg(Reg); + EmitStdCall(SubId); +end; + +procedure TEmitter.EmitOP_CLASSNAME_64; +begin + EmitStdCall_Adr1_AdrR(Id_ClassName); +end; +procedure TEmitter.EmitOP_CLASSNAME; +begin + EmitStdCall_Adr1_AdrR(Id_ClassName); +end; + +procedure TEmitter.EmitOP_GET_DRTTI_PROP_64; +var + SubId, Reg, ClassId, PropIndex, Shift, FT: Integer; +begin + FT := SymbolRecR.FinalTypeId; + if FT in INT64Types then + SubId := Id_GetDRTTIInt64Property + else if FT in IntegerTypes then + SubId := Id_GetDRTTIIntegerProperty + else if FT in StringTypes then + SubId := Id_GetDRTTIStringProperty + else if FT in RealTypes then + SubId := Id_GetDRTTIExtendedProperty + else if FT in VariantTypes then + SubId := Id_GetDRTTIVariantProperty + else + SubId := Id_GetDRTTIProperty; + + EmitPCodeOperator; + + EmitCallPro(SubId); + + Reg := GetRegEx; + + // push ppi + PropIndex := SymbolRec2.PropIndex; + ClassId := GetSymbolRec(SymbolRec1.TerminalHostClassId).Id; + Shift := GetOffset(GetSymbolRec(ClassId + 1)); + Inc(Shift, (PropIndex + 1) * SizeOfPointer); + Prg.AsmGetREG_ESIPtr(Reg, Shift); + Prg.AsmMovREG_REG(_ECX, Reg); + + EmitLoadIntVal(Reg, SymbolRec1); // instance + Prg.AsmMovREG_REG(_EDX, Reg); + + EmitLoadAddress(Reg, SymbolRecR); // result + Prg.AsmMovREG_REG(_R8, Reg); + + FreeReg(Reg); + EmitStdCall(SubId); +end; +procedure TEmitter.EmitOP_GET_DRTTI_PROP; +var + SubId, Reg, ClassId, PropIndex, Shift, FT: Integer; +begin + FT := SymbolRecR.FinalTypeId; + if FT in INT64Types then + SubId := Id_GetDRTTIInt64Property + else if FT in IntegerTypes then + SubId := Id_GetDRTTIIntegerProperty + else if FT in StringTypes then + SubId := Id_GetDRTTIStringProperty + else if FT in RealTypes then + SubId := Id_GetDRTTIExtendedProperty + else if FT in VariantTypes then + SubId := Id_GetDRTTIVariantProperty + else + SubId := Id_GetDRTTIProperty; + + EmitPCodeOperator; + + EmitCallPro(SubId); + + Reg := GetReg; + + EmitLoadAddress(Reg, SymbolRecR); // result + Prg.AsmPush_REG(Reg); + + EmitLoadIntVal(Reg, SymbolRec1); // instance + Prg.AsmPush_REG(Reg); + + // push ppi + PropIndex := SymbolRec2.PropIndex; + ClassId := GetSymbolRec(SymbolRec1.TerminalHostClassId).Id; + Shift := GetOffset(GetSymbolRec(ClassId + 1)); + Inc(Shift, (PropIndex + 1) * SizeOfPointer); + Prg.AsmGetREG_ESIPtr(Reg, Shift); + Prg.AsmPush_REG(Reg); + + FreeReg(Reg); + EmitStdCall(SubId); +end; + +procedure TEmitter.EmitOP_SET_DRTTI_PROP_64; +var + SubId, Reg, PropIndex, ClassId, Shift: Integer; +begin + SubId := Id_SetDRTTIProperty; + + EmitPCodeOperator; + + EmitCallPro(SubId); + + Reg := GetRegEx; + + // push ppi + PropIndex := SymbolRec2.PropIndex; + ClassId := GetSymbolRec(SymbolRec1.TerminalHostClassId).Id; + Shift := GetOffset(GetSymbolRec(ClassId + 1)); + Inc(Shift, (PropIndex + 1) * SizeOfPointer); + Prg.AsmGetREG_ESIPtr(Reg, Shift); + Prg.AsmMovREG_REG(_ECX, Reg); + + EmitLoadIntVal(Reg, SymbolRec1); // instance + Prg.AsmMovREG_REG(_EDX, Reg); + + EmitLoadAddress(Reg, SymbolRecR); // value + Prg.AsmMovREG_REG(_R8, Reg); + + FreeReg(Reg); + EmitStdCall(SubId); +end; +procedure TEmitter.EmitOP_SET_DRTTI_PROP; +var + SubId, Reg, PropIndex, ClassId, Shift: Integer; +begin + SubId := Id_SetDRTTIProperty; + + EmitPCodeOperator; + + EmitCallPro(SubId); + + Reg := GetReg; + + EmitLoadAddress(Reg, SymbolRecR); // value + Prg.AsmPush_REG(Reg); + + EmitLoadIntVal(Reg, SymbolRec1); // instance + Prg.AsmPush_REG(Reg); + + // push ppi + PropIndex := SymbolRec2.PropIndex; + ClassId := GetSymbolRec(SymbolRec1.TerminalHostClassId).Id; + Shift := GetOffset(GetSymbolRec(ClassId + 1)); + Inc(Shift, (PropIndex + 1) * SizeOfPointer); + Prg.AsmGetREG_ESIPtr(Reg, Shift); + Prg.AsmPush_REG(Reg); + + FreeReg(Reg); + EmitStdCall(SubId); +end; + +procedure TEmitter.EmitOP_GET_ANSISTR_PROP_64; +var + SubId, Reg, ClassId, PropIndex, Shift: Integer; +begin + SubId := Id_GetAnsiStrProp; + + EmitPCodeOperator; + + EmitCallPro(SubId); + + Reg := GetRegEx; + + // push ppi + PropIndex := SymbolRec2.PropIndex; + ClassId := GetSymbolRec(SymbolRec1.TerminalHostClassId).Id; + Shift := GetOffset(GetSymbolRec(ClassId + 1)); + Inc(Shift, (PropIndex + 1) * SizeOfPointer); + Prg.AsmGetREG_ESIPtr(Reg, Shift); + Prg.AsmMovREG_REG(_ECX, Reg); + + EmitLoadIntVal(Reg, SymbolRec1); // instance + Prg.AsmMovREG_REG(_EDX, Reg); + + EmitLoadAddress(Reg, SymbolRecR); // result + Prg.AsmMovREG_REG(_R8, Reg); + + FreeReg(Reg); + EmitStdCall(SubId); +end; +procedure TEmitter.EmitOP_GET_ANSISTR_PROP; +var + SubId, Reg, ClassId, PropIndex, Shift: Integer; +begin + SubId := Id_GetAnsiStrProp; + + EmitPCodeOperator; + + EmitCallPro(SubId); + + Reg := GetReg; + + EmitLoadAddress(Reg, SymbolRecR); // result + Prg.AsmPush_REG(Reg); + + EmitLoadIntVal(Reg, SymbolRec1); // instance + Prg.AsmPush_REG(Reg); + + // push ppi + PropIndex := SymbolRec2.PropIndex; + ClassId := GetSymbolRec(SymbolRec1.TerminalHostClassId).Id; + Shift := GetOffset(GetSymbolRec(ClassId + 1)); + Inc(Shift, (PropIndex + 1) * SizeOfPointer); + Prg.AsmGetREG_ESIPtr(Reg, Shift); + Prg.AsmPush_REG(Reg); + + FreeReg(Reg); + EmitStdCall(SubId); +end; + +procedure TEmitter.EmitOP_SET_ANSISTR_PROP_64; +var + SubId, Reg, PropIndex, ClassId, Shift: Integer; +begin + SubId := Id_SetAnsiStrProp; + + EmitPCodeOperator; + + EmitCallPro(SubId); + + Reg := GetRegEx; + + // push ppi + PropIndex := SymbolRec2.PropIndex; + ClassId := GetSymbolRec(SymbolRec1.TerminalHostClassId).Id; + Shift := GetOffset(GetSymbolRec(ClassId + 1)); + Inc(Shift, (PropIndex + 1) * SizeOfPointer); + Prg.AsmGetREG_ESIPtr(Reg, Shift); + Prg.AsmMovREG_REG(_ECX, Reg); + + EmitLoadIntVal(Reg, SymbolRec1); // instance + Prg.AsmMovREG_REG(_EDX, Reg); + +{$IFNDEF PAXARM} + if SymbolRecR.HasPAnsiCharType then + EmitGet_REG(Reg, SymbolRecR) + else +{$ENDIF} + EmitLoadIntVal(Reg, SymbolRecR); // value + Prg.AsmMovREG_REG(_R8, Reg); + + FreeReg(Reg); + EmitStdCall(SubId); +end; +procedure TEmitter.EmitOP_SET_ANSISTR_PROP; +var + SubId, Reg, PropIndex, ClassId, Shift: Integer; +begin + SubId := Id_SetAnsiStrProp; + + EmitPCodeOperator; + + EmitCallPro(SubId); + + Reg := GetReg; + +{$IFNDEF PAXARM} + if SymbolRecR.HasPAnsiCharType then + EmitGet_REG(Reg, SymbolRecR) + else +{$ENDIF} + EmitLoadIntVal(Reg, SymbolRecR); // value + Prg.AsmPush_REG(Reg); + + EmitLoadIntVal(Reg, SymbolRec1); // instance + Prg.AsmPush_REG(Reg); + + // push ppi + PropIndex := SymbolRec2.PropIndex; + ClassId := GetSymbolRec(SymbolRec1.TerminalHostClassId).Id; + Shift := GetOffset(GetSymbolRec(ClassId + 1)); + Inc(Shift, (PropIndex + 1) * SizeOfPointer); + Prg.AsmGetREG_ESIPtr(Reg, Shift); + Prg.AsmPush_REG(Reg); + + FreeReg(Reg); + EmitStdCall(SubId); +end; + +procedure TEmitter.EmitOP_GET_WIDESTR_PROP_64; +var + SubId, Reg, ClassId, PropIndex, Shift: Integer; +begin + SubId := Id_GetWideStrProp; + + EmitPCodeOperator; + + EmitCallPro(SubId); + + Reg := GetRegEx; + + // push ppi + PropIndex := SymbolRec2.PropIndex; + ClassId := GetSymbolRec(SymbolRec1.TerminalHostClassId).Id; + Shift := GetOffset(GetSymbolRec(ClassId + 1)); + Inc(Shift, (PropIndex + 1) * SizeOfPointer); + Prg.AsmGetREG_ESIPtr(Reg, Shift); + Prg.AsmMovREG_REG(_ECX, Reg); + + EmitLoadIntVal(Reg, SymbolRec1); // instance + Prg.AsmMovREG_REG(_EDX, Reg); + + EmitLoadAddress(Reg, SymbolRecR); // result + Prg.AsmMovREG_REG(_R8, Reg); + + FreeReg(Reg); + EmitStdCall(SubId); +end; +procedure TEmitter.EmitOP_GET_WIDESTR_PROP; +var + SubId, Reg, ClassId, PropIndex, Shift: Integer; +begin + SubId := Id_GetWideStrProp; + + EmitPCodeOperator; + + EmitCallPro(SubId); + + Reg := GetReg; + + EmitLoadAddress(Reg, SymbolRecR); // result + Prg.AsmPush_REG(Reg); + + EmitLoadIntVal(Reg, SymbolRec1); // instance + Prg.AsmPush_REG(Reg); + + // push ppi + PropIndex := SymbolRec2.PropIndex; + ClassId := GetSymbolRec(SymbolRec1.TerminalHostClassId).Id; + Shift := GetOffset(GetSymbolRec(ClassId + 1)); + Inc(Shift, (PropIndex + 1) * SizeOfPointer); + Prg.AsmGetREG_ESIPtr(Reg, Shift); + Prg.AsmPush_REG(Reg); + + FreeReg(Reg); + EmitStdCall(SubId); +end; + +procedure TEmitter.EmitOP_SET_WIDESTR_PROP_64; +var + SubId, Reg, PropIndex, ClassId, Shift: Integer; +begin + SubId := Id_SetWideStrProp; + + EmitPCodeOperator; + + EmitCallPro(SubId); + + Reg := GetRegEx; + + // push ppi + PropIndex := SymbolRec2.PropIndex; + ClassId := GetSymbolRec(SymbolRec1.TerminalHostClassId).Id; + Shift := GetOffset(GetSymbolRec(ClassId + 1)); + Inc(Shift, (PropIndex + 1) * SizeOfPointer); + Prg.AsmGetREG_ESIPtr(Reg, Shift); + Prg.AsmMovREG_REG(_ECX, Reg); + + EmitLoadIntVal(Reg, SymbolRec1); // instance + Prg.AsmMovREG_REG(_EDX, Reg); + +{$IFNDEF PAXARM} + if SymbolRecR.HasPAnsiCharType then + EmitGet_REG(Reg, SymbolRecR) + else +{$ENDIF} + EmitLoadIntVal(Reg, SymbolRecR); // value + Prg.AsmMovREG_REG(_R8, Reg); + + FreeReg(Reg); + EmitStdCall(SubId); +end; +procedure TEmitter.EmitOP_SET_WIDESTR_PROP; +var + SubId, Reg, PropIndex, ClassId, Shift: Integer; +begin + SubId := Id_SetWideStrProp; + + EmitPCodeOperator; + + EmitCallPro(SubId); + + Reg := GetReg; + +{$IFNDEF PAXARM} + if SymbolRecR.HasPAnsiCharType then + EmitGet_REG(Reg, SymbolRecR) + else +{$ENDIF} + EmitLoadIntVal(Reg, SymbolRecR); // value + Prg.AsmPush_REG(Reg); + + EmitLoadIntVal(Reg, SymbolRec1); // instance + Prg.AsmPush_REG(Reg); + + // push ppi + PropIndex := SymbolRec2.PropIndex; + ClassId := GetSymbolRec(SymbolRec1.TerminalHostClassId).Id; + Shift := GetOffset(GetSymbolRec(ClassId + 1)); + Inc(Shift, (PropIndex + 1) * SizeOfPointer); + Prg.AsmGetREG_ESIPtr(Reg, Shift); + Prg.AsmPush_REG(Reg); + + FreeReg(Reg); + EmitStdCall(SubId); +end; + +procedure TEmitter.EmitOP_GET_UNICSTR_PROP_64; +var + SubId, Reg, ClassId, PropIndex, Shift: Integer; +begin + SubId := Id_GetUnicStrProp; + + EmitPCodeOperator; + + EmitCallPro(SubId); + + Reg := GetRegEx; + + // push ppi + PropIndex := SymbolRec2.PropIndex; + ClassId := GetSymbolRec(SymbolRec1.TerminalHostClassId).Id; + Shift := GetOffset(GetSymbolRec(ClassId + 1)); + Inc(Shift, (PropIndex + 1) * SizeOfPointer); + Prg.AsmGetREG_ESIPtr(Reg, Shift); + Prg.AsmMovREG_REG(_ECX, Reg); + + EmitLoadIntVal(Reg, SymbolRec1); // instance + Prg.AsmMovREG_REG(_EDX, Reg); + + EmitLoadAddress(Reg, SymbolRecR); // result + Prg.AsmMovREG_REG(_R8, Reg); + + FreeReg(Reg); + EmitStdCall(SubId); +end; +procedure TEmitter.EmitOP_GET_UNICSTR_PROP; +var + SubId, Reg, ClassId, PropIndex, Shift: Integer; +begin + SubId := Id_GetUnicStrProp; + + EmitPCodeOperator; + + EmitCallPro(SubId); + + Reg := GetReg; + + EmitLoadAddress(Reg, SymbolRecR); // result + Prg.AsmPush_REG(Reg); + + EmitLoadIntVal(Reg, SymbolRec1); // instance + Prg.AsmPush_REG(Reg); + + // push ppi + PropIndex := SymbolRec2.PropIndex; + ClassId := GetSymbolRec(SymbolRec1.TerminalHostClassId).Id; + Shift := GetOffset(GetSymbolRec(ClassId + 1)); + Inc(Shift, (PropIndex + 1) * SizeOfPointer); + Prg.AsmGetREG_ESIPtr(Reg, Shift); + Prg.AsmPush_REG(Reg); + + FreeReg(Reg); + EmitStdCall(SubId); +end; + +procedure TEmitter.EmitOP_SET_UNICSTR_PROP_64; +var + SubId, Reg, PropIndex, ClassId, Shift: Integer; +begin + SubId := Id_SetUnicStrProp; + + EmitPCodeOperator; + + EmitCallPro(SubId); + + Reg := GetRegEx; + + // push ppi + PropIndex := SymbolRec2.PropIndex; + ClassId := GetSymbolRec(SymbolRec1.TerminalHostClassId).Id; + Shift := GetOffset(GetSymbolRec(ClassId + 1)); + Inc(Shift, (PropIndex + 1) * SizeOfPointer); + Prg.AsmGetREG_ESIPtr(Reg, Shift); + Prg.AsmMovREG_REG(_ECX, Reg); + + EmitLoadIntVal(Reg, SymbolRec1); // instance + Prg.AsmMovREG_REG(_EDX, Reg); + + if SymbolRecR.HasPWideCharType then + EmitGet_REG(Reg, SymbolRecR) + else + EmitLoadIntVal(Reg, SymbolRecR); // value + Prg.AsmMovREG_REG(_R8, Reg); + + FreeReg(Reg); + EmitStdCall(SubId); +end; +procedure TEmitter.EmitOP_SET_UNICSTR_PROP; +var + SubId, Reg, PropIndex, ClassId, Shift: Integer; +begin + SubId := Id_SetUnicStrProp; + + EmitPCodeOperator; + + EmitCallPro(SubId); + + Reg := GetReg; + + if SymbolRecR.HasPWideCharType then + EmitGet_REG(Reg, SymbolRecR) + else + EmitLoadIntVal(Reg, SymbolRecR); // value + Prg.AsmPush_REG(Reg); + + EmitLoadIntVal(Reg, SymbolRec1); // instance + Prg.AsmPush_REG(Reg); + + // push ppi + PropIndex := SymbolRec2.PropIndex; + ClassId := GetSymbolRec(SymbolRec1.TerminalHostClassId).Id; + Shift := GetOffset(GetSymbolRec(ClassId + 1)); + Inc(Shift, (PropIndex + 1) * SizeOfPointer); + Prg.AsmGetREG_ESIPtr(Reg, Shift); + Prg.AsmPush_REG(Reg); + + FreeReg(Reg); + EmitStdCall(SubId); +end; + +procedure TEmitter.EmitOP_GET_ORD_PROP_64; +var + SubId, Reg, ClassId, PropIndex, Shift: Integer; +begin + SubId := Id_GetOrdProp; + + EmitPCodeOperator; + + EmitCallPro(SubId); + + Reg := GetRegEx; + + // push ppi + PropIndex := SymbolRec2.PropIndex; + ClassId := GetSymbolRec(SymbolRec1.TerminalHostClassId).Id; + Shift := GetOffset(GetSymbolRec(ClassId + 1)); + Inc(Shift, (PropIndex + 1) * SizeOfPointer); + Prg.AsmGetREG_ESIPtr(Reg, Shift); + Prg.AsmMovREG_REG(_ECX, Reg); + + EmitLoadIntVal(Reg, SymbolRec1); // instance + Prg.AsmMovREG_REG(_EDX, Reg); + + EmitLoadAddress(Reg, SymbolRecR); // result + Prg.AsmMovREG_REG(_R8, Reg); + + FreeReg(Reg); + EmitStdCall(SubId); +end; +procedure TEmitter.EmitOP_GET_ORD_PROP; +var + SubId, Reg, ClassId, PropIndex, Shift: Integer; +begin + SubId := Id_GetOrdProp; + + EmitPCodeOperator; + + Emit_PUSH_REGS; + + EmitCallPro(SubId); + + Reg := GetReg; + + EmitLoadAddress(Reg, SymbolRecR); // result + Prg.AsmPush_REG(Reg); + + EmitLoadIntVal(Reg, SymbolRec1); // instance + Prg.AsmPush_REG(Reg); + + // push ppi + PropIndex := SymbolRec2.PropIndex; + ClassId := GetSymbolRec(SymbolRec1.TerminalHostClassId).Id; + Shift := GetOffset(GetSymbolRec(ClassId + 1)); + Inc(Shift, (PropIndex + 1) * SizeOfPointer); + Prg.AsmGetREG_ESIPtr(Reg, Shift); + Prg.AsmPush_REG(Reg); + + FreeReg(Reg); + EmitStdCall(SubId); + + Emit_POP_REGS; +end; + +procedure TEmitter.EmitOP_SET_ORD_PROP_64; +var + SubId, Reg, PropIndex, ClassId, Shift: Integer; +begin + SubId := Id_SetOrdProp; + + EmitPCodeOperator; + + EmitCallPro(SubId); + + Reg := GetRegEx; + + // push ppi + PropIndex := SymbolRec2.PropIndex; + ClassId := GetSymbolRec(SymbolRec1.TerminalHostClassId).Id; + Shift := GetOffset(GetSymbolRec(ClassId + 1)); + Inc(Shift, (PropIndex + 1) * SizeOfPointer); + Prg.AsmGetREG_ESIPtr(Reg, Shift); + Prg.AsmMovREG_REG(_ECX, Reg); + + EmitLoadIntVal(Reg, SymbolRec1); // instance + Prg.AsmMovREG_REG(_EDX, Reg); + + EmitLoadIntVal(Reg, SymbolRecR); // value + Prg.AsmMovREG_REG(_R8, Reg); + + FreeReg(Reg); + EmitStdCall(SubId); +end; +procedure TEmitter.EmitOP_SET_ORD_PROP; +var + SubId, Reg, PropIndex, ClassId, Shift: Integer; +begin + SubId := Id_SetOrdProp; + + EmitPCodeOperator; + + EmitCallPro(SubId); + + Reg := GetReg; + + EmitLoadIntVal(Reg, SymbolRecR); // value + Prg.AsmPush_REG(Reg); + + EmitLoadIntVal(Reg, SymbolRec1); // instance + Prg.AsmPush_REG(Reg); + + // push ppi + PropIndex := SymbolRec2.PropIndex; + ClassId := GetSymbolRec(SymbolRec1.TerminalHostClassId).Id; + Shift := GetOffset(GetSymbolRec(ClassId + 1)); + Inc(Shift, (PropIndex + 1) * SizeOfPointer); + Prg.AsmGetREG_ESIPtr(Reg, Shift); + Prg.AsmPush_REG(Reg); + + FreeReg(Reg); + EmitStdCall(SubId); +end; + +procedure TEmitter.EmitOP_GET_INTERFACE_PROP_64; +var + SubId, Reg, ClassId, PropIndex, Shift: Integer; +begin + SubId := Id_GetInterfaceProp; + + EmitPCodeOperator; + + EmitCallPro(SubId); + + Reg := GetRegEx; + + // push ppi + PropIndex := SymbolRec2.PropIndex; + ClassId := GetSymbolRec(SymbolRec1.TerminalHostClassId).Id; + Shift := GetOffset(GetSymbolRec(ClassId + 1)); + Inc(Shift, (PropIndex + 1) * SizeOfPointer); + Prg.AsmGetREG_ESIPtr(Reg, Shift); + Prg.AsmMovREG_REG(_ECX, Reg); + + EmitLoadIntVal(Reg, SymbolRec1); // instance + Prg.AsmMovREG_REG(_EDX, Reg); + + EmitLoadAddress(Reg, SymbolRecR); // result + Prg.AsmMovREG_REG(_R8, Reg); + + FreeReg(Reg); + EmitStdCall(SubId); +end; +procedure TEmitter.EmitOP_GET_INTERFACE_PROP; +var + SubId, Reg, ClassId, PropIndex, Shift: Integer; +begin + SubId := Id_GetInterfaceProp; + + EmitPCodeOperator; + + EmitCallPro(SubId); + + Reg := GetReg; + + EmitLoadAddress(Reg, SymbolRecR); // result + Prg.AsmPush_REG(Reg); + + EmitLoadIntVal(Reg, SymbolRec1); // instance + Prg.AsmPush_REG(Reg); + + // push ppi + PropIndex := SymbolRec2.PropIndex; + ClassId := GetSymbolRec(SymbolRec1.TerminalHostClassId).Id; + Shift := GetOffset(GetSymbolRec(ClassId + 1)); + Inc(Shift, (PropIndex + 1) * SizeOfPointer); + Prg.AsmGetREG_ESIPtr(Reg, Shift); + Prg.AsmPush_REG(Reg); + + FreeReg(Reg); + EmitStdCall(SubId); +end; + +procedure TEmitter.EmitOP_SET_INTERFACE_PROP_64; +var + SubId, Reg, PropIndex, ClassId, Shift: Integer; +begin + SubId := Id_SetOrdProp; + + EmitPCodeOperator; + + EmitCallPro(SubId); + + Reg := GetRegEx; + + // push ppi + PropIndex := SymbolRec2.PropIndex; + ClassId := GetSymbolRec(SymbolRec1.TerminalHostClassId).Id; + Shift := GetOffset(GetSymbolRec(ClassId + 1)); + Inc(Shift, (PropIndex + 1) * SizeOfPointer); + Prg.AsmGetREG_ESIPtr(Reg, Shift); + Prg.AsmMovREG_REG(_ECX, Reg); + + EmitLoadIntVal(Reg, SymbolRec1); // instance + Prg.AsmMovREG_REG(_EDX, Reg); + + EmitLoadIntVal(Reg, SymbolRecR); // value + Prg.AsmMovREG_REG(_R8, Reg); + + FreeReg(Reg); + EmitStdCall(SubId); +end; +procedure TEmitter.EmitOP_SET_INTERFACE_PROP; +var + SubId, Reg, PropIndex, ClassId, Shift: Integer; +begin + SubId := Id_SetOrdProp; + + EmitPCodeOperator; + + EmitCallPro(SubId); + + Reg := GetReg; + + EmitLoadIntVal(Reg, SymbolRecR); // value + Prg.AsmPush_REG(Reg); + + EmitLoadIntVal(Reg, SymbolRec1); // instance + Prg.AsmPush_REG(Reg); + + // push ppi + PropIndex := SymbolRec2.PropIndex; + ClassId := GetSymbolRec(SymbolRec1.TerminalHostClassId).Id; + Shift := GetOffset(GetSymbolRec(ClassId + 1)); + Inc(Shift, (PropIndex + 1) * SizeOfPointer); + Prg.AsmGetREG_ESIPtr(Reg, Shift); + Prg.AsmPush_REG(Reg); + + FreeReg(Reg); + EmitStdCall(SubId); +end; + +procedure TEmitter.EmitOP_GET_SET_PROP_64; +var + SubId, Reg, ClassId, PropIndex, Shift: Integer; +begin + SubId := Id_GetSetProp; + + EmitPCodeOperator; + + EmitCallPro(SubId); + + Reg := GetRegEx; + + // push ppi + PropIndex := SymbolRec2.PropIndex; + ClassId := GetSymbolRec(SymbolRec1.TerminalHostClassId).Id; + Shift := GetOffset(GetSymbolRec(ClassId + 1)); + Inc(Shift, (PropIndex + 1) * SizeOfPointer); + Prg.AsmGetREG_ESIPtr(Reg, Shift); + Prg.AsmMovREG_REG(_ECX, Reg); + + EmitLoadAddress(Reg, SymbolRecR); // result + Prg.AsmMovREG_REG(_EDX, Reg); + + EmitLoadIntVal(Reg, SymbolRec1); // instance + Prg.AsmMovREG_REG(_R8, Reg); + + FreeReg(Reg); + EmitStdCall(SubId); +end; +procedure TEmitter.EmitOP_GET_SET_PROP; +var + SubId, Reg, ClassId, PropIndex, Shift: Integer; +begin + SubId := Id_GetSetProp; + + EmitPCodeOperator; + + EmitCallPro(SubId); + + Reg := GetReg; + + EmitLoadAddress(Reg, SymbolRecR); // result + Prg.AsmPush_REG(Reg); + + EmitLoadIntVal(Reg, SymbolRec1); // instance + Prg.AsmPush_REG(Reg); + + // push ppi + PropIndex := SymbolRec2.PropIndex; + ClassId := GetSymbolRec(SymbolRec1.TerminalHostClassId).Id; + Shift := GetOffset(GetSymbolRec(ClassId + 1)); + Inc(Shift, (PropIndex + 1) * SizeOfPointer); + Prg.AsmGetREG_ESIPtr(Reg, Shift); + Prg.AsmPush_REG(Reg); + + FreeReg(Reg); + EmitStdCall(SubId); +end; + +procedure TEmitter.EmitOP_SET_SET_PROP_64; +var + SubId, Reg, ClassId, PropIndex, Shift: Integer; +begin + SubId := Id_SetSetProp; + + EmitPCodeOperator; + + EmitCallPro(SubId); + + Reg := GetRegEx; + + // push ppi + PropIndex := SymbolRec2.PropIndex; + ClassId := GetSymbolRec(SymbolRec1.TerminalHostClassId).Id; + Shift := GetOffset(GetSymbolRec(ClassId + 1)); + Inc(Shift, (PropIndex + 1) * SizeOfPointer); + Prg.AsmGetREG_ESIPtr(Reg, Shift); + Prg.AsmMovREG_REG(_ECX, Reg); + + EmitLoadAddress(Reg, SymbolRecR); // value + Prg.AsmMovREG_REG(_EDX, Reg); + + EmitLoadIntVal(Reg, SymbolRec1); // instance + Prg.AsmMovREG_REG(_R8, Reg); + + FreeReg(Reg); + EmitStdCall(SubId); +end; +procedure TEmitter.EmitOP_SET_SET_PROP; +var + SubId, Reg, ClassId, PropIndex, Shift: Integer; +begin + SubId := Id_SetSetProp; + + EmitPCodeOperator; + + EmitCallPro(SubId); + + Reg := GetReg; + + EmitLoadAddress(Reg, SymbolRecR); // value + Prg.AsmPush_REG(Reg); + + EmitLoadIntVal(Reg, SymbolRec1); // instance + Prg.AsmPush_REG(Reg); + + // push ppi + PropIndex := SymbolRec2.PropIndex; + ClassId := GetSymbolRec(SymbolRec1.TerminalHostClassId).Id; + Shift := GetOffset(GetSymbolRec(ClassId + 1)); + Inc(Shift, (PropIndex + 1) * SizeOfPointer); + Prg.AsmGetREG_ESIPtr(Reg, Shift); + Prg.AsmPush_REG(Reg); + + FreeReg(Reg); + EmitStdCall(SubId); +end; + +procedure TEmitter.EmitOP_GET_FLOAT_PROP_64; +var + SubId, Reg, ClassId, PropIndex, Shift: Integer; +begin + SubId := Id_GetFloatProp; + + EmitPCodeOperator; + + EmitCallPro(SubId); + + Reg := GetRegEx; + + // push ppi + PropIndex := SymbolRec2.PropIndex; + ClassId := GetSymbolRec(SymbolRec1.TerminalHostClassId).Id; + Shift := GetOffset(GetSymbolRec(ClassId + 1)); + Inc(Shift, (PropIndex + 1) * SizeOfPointer); + Prg.AsmGetREG_ESIPtr(Reg, Shift); + Prg.AsmMovREG_REG(_ECX, Reg); + + EmitLoadIntVal(Reg, SymbolRec1); // instance + Prg.AsmMovREG_REG(_EDX, Reg); + + EmitLoadAddress(Reg, SymbolRecR); // result + Prg.AsmMovREG_REG(_R8, Reg); + + FreeReg(Reg); + EmitStdCall(SubId); +end; +procedure TEmitter.EmitOP_GET_FLOAT_PROP; +var + SubId, Reg, ClassId, PropIndex, Shift: Integer; +begin + SubId := Id_GetFloatProp; + + EmitPCodeOperator; + + EmitCallPro(SubId); + + Reg := GetReg; + + EmitLoadAddress(Reg, SymbolRecR); // result + Prg.AsmPush_REG(Reg); + + EmitLoadIntVal(Reg, SymbolRec1); // instance + Prg.AsmPush_REG(Reg); + + // push ppi + PropIndex := SymbolRec2.PropIndex; + ClassId := GetSymbolRec(SymbolRec1.TerminalHostClassId).Id; + Shift := GetOffset(GetSymbolRec(ClassId + 1)); + Inc(Shift, (PropIndex + 1) * SizeOfPointer); + Prg.AsmGetREG_ESIPtr(Reg, Shift); + Prg.AsmPush_REG(Reg); + + FreeReg(Reg); + EmitStdCall(SubId); +end; + +procedure TEmitter.EmitOP_SET_FLOAT_PROP_64; +var + SubId, Reg, ClassId, PropIndex, Shift: Integer; +begin + SubId := Id_SetFloatProp; + + EmitPCodeOperator; + + EmitCallPro(SubId); + + Reg := GetRegEx; + + // push ppi + PropIndex := SymbolRec2.PropIndex; + ClassId := GetSymbolRec(SymbolRec1.TerminalHostClassId).Id; + Shift := GetOffset(GetSymbolRec(ClassId + 1)); + Inc(Shift, (PropIndex + 1) * SizeOfPointer); + Prg.AsmGetREG_ESIPtr(Reg, Shift); + Prg.AsmMovREG_REG(_ECX, Reg); + + EmitLoadIntVal(Reg, SymbolRec1); // instance + Prg.AsmMovREG_REG(_EDX, Reg); + + EmitLoadAddress(Reg, SymbolRecR); // value + Prg.AsmMovREG_REG(_R8, Reg); + + FreeReg(Reg); + EmitStdCall(SubId); +end; +procedure TEmitter.EmitOP_SET_FLOAT_PROP; +var + SubId, Reg, ClassId, PropIndex, Shift: Integer; +begin + SubId := Id_SetFloatProp; + + EmitPCodeOperator; + + EmitCallPro(SubId); + + Reg := GetReg; + + EmitLoadAddress(Reg, SymbolRecR); // value + Prg.AsmPush_REG(Reg); + + EmitLoadIntVal(Reg, SymbolRec1); // instance + Prg.AsmPush_REG(Reg); + + // push ppi + PropIndex := SymbolRec2.PropIndex; + ClassId := GetSymbolRec(SymbolRec1.TerminalHostClassId).Id; + Shift := GetOffset(GetSymbolRec(ClassId + 1)); + Inc(Shift, (PropIndex + 1) * SizeOfPointer); + Prg.AsmGetREG_ESIPtr(Reg, Shift); + Prg.AsmPush_REG(Reg); + + FreeReg(Reg); + EmitStdCall(SubId); +end; + +procedure TEmitter.EmitOP_GET_VARIANT_PROP_64; +var + SubId, Reg, ClassId, PropIndex, Shift: Integer; +begin + SubId := Id_GetVariantProp; + + EmitPCodeOperator; + + EmitCallPro(SubId); + + Reg := GetRegEx; + + // push ppi + PropIndex := SymbolRec2.PropIndex; + ClassId := GetSymbolRec(SymbolRec1.TerminalHostClassId).Id; + Shift := GetOffset(GetSymbolRec(ClassId + 1)); + Inc(Shift, (PropIndex + 1) * SizeOfPointer); + Prg.AsmGetREG_ESIPtr(Reg, Shift); + Prg.AsmMovREG_REG(_ECX, Reg); + + EmitLoadIntVal(Reg, SymbolRec1); // instance + Prg.AsmMovREG_REG(_EDX, Reg); + + EmitLoadAddress(Reg, SymbolRecR); // result + Prg.AsmMovREG_REG(_R8, Reg); + + FreeReg(Reg); + EmitStdCall(SubId); +end; +procedure TEmitter.EmitOP_GET_VARIANT_PROP; +var + SubId, Reg, ClassId, PropIndex, Shift: Integer; +begin + SubId := Id_GetVariantProp; + + EmitPCodeOperator; + + EmitCallPro(SubId); + + Reg := GetReg; + + EmitLoadAddress(Reg, SymbolRecR); // result + Prg.AsmPush_REG(Reg); + + EmitLoadIntVal(Reg, SymbolRec1); // instance + Prg.AsmPush_REG(Reg); + + // push ppi + PropIndex := SymbolRec2.PropIndex; + ClassId := GetSymbolRec(SymbolRec1.TerminalHostClassId).Id; + Shift := GetOffset(GetSymbolRec(ClassId + 1)); + Inc(Shift, (PropIndex + 1) * SizeOfPointer); + Prg.AsmGetREG_ESIPtr(Reg, Shift); + Prg.AsmPush_REG(Reg); + + FreeReg(Reg); + EmitStdCall(SubId); +end; + +procedure TEmitter.EmitOP_SET_VARIANT_PROP_64; +var + SubId, Reg, ClassId, PropIndex, Shift: Integer; +begin + SubId := Id_SetVariantProp; + + EmitPCodeOperator; + + EmitCallPro(SubId); + + Reg := GetRegEx; + + // push ppi + PropIndex := SymbolRec2.PropIndex; + ClassId := GetSymbolRec(SymbolRec1.TerminalHostClassId).Id; + Shift := GetOffset(GetSymbolRec(ClassId + 1)); + Inc(Shift, (PropIndex + 1) * SizeOfPointer); + Prg.AsmGetREG_ESIPtr(Reg, Shift); + Prg.AsmMovREG_REG(_ECX, Reg); + + EmitLoadIntVal(Reg, SymbolRec1); // instance + Prg.AsmMovREG_REG(_EDX, Reg); + + EmitLoadAddress(Reg, SymbolRecR); // value + Prg.AsmMovREG_REG(_R8, Reg); + + FreeReg(Reg); + EmitStdCall(SubId); +end; +procedure TEmitter.EmitOP_SET_VARIANT_PROP; +var + SubId, Reg, ClassId, PropIndex, Shift: Integer; +begin + SubId := Id_SetVariantProp; + + EmitPCodeOperator; + + EmitCallPro(SubId); + + Reg := GetReg; + + EmitLoadAddress(Reg, SymbolRecR); // value + Prg.AsmPush_REG(Reg); + + EmitLoadIntVal(Reg, SymbolRec1); // instance + Prg.AsmPush_REG(Reg); + + // push ppi + PropIndex := SymbolRec2.PropIndex; + ClassId := GetSymbolRec(SymbolRec1.TerminalHostClassId).Id; + Shift := GetOffset(GetSymbolRec(ClassId + 1)); + Inc(Shift, (PropIndex + 1) * SizeOfPointer); + Prg.AsmGetREG_ESIPtr(Reg, Shift); + Prg.AsmPush_REG(Reg); + + FreeReg(Reg); + EmitStdCall(SubId); +end; + +procedure TEmitter.EmitOP_GET_INT64_PROP_64; +var + SubId, Reg, ClassId, PropIndex, Shift: Integer; +begin + SubId := Id_GetInt64Prop; + + EmitPCodeOperator; + + EmitCallPro(SubId); + + Reg := GetRegEx; + + // push ppi + PropIndex := SymbolRec2.PropIndex; + ClassId := GetSymbolRec(SymbolRec1.TerminalHostClassId).Id; + Shift := GetOffset(GetSymbolRec(ClassId + 1)); + Inc(Shift, (PropIndex + 1) * SizeOfPointer); + Prg.AsmGetREG_ESIPtr(Reg, Shift); + Prg.AsmMovREG_REG(_ECX, Reg); + + EmitLoadIntVal(Reg, SymbolRec1); // instance + Prg.AsmMovREG_REG(_EDX, Reg); + + EmitLoadAddress(Reg, SymbolRecR); // result + Prg.AsmMovREG_REG(_R8, Reg); + + FreeReg(Reg); + EmitStdCall(SubId); +end; +procedure TEmitter.EmitOP_GET_INT64_PROP; +var + SubId, Reg, ClassId, PropIndex, Shift: Integer; +begin + SubId := Id_GetInt64Prop; + + EmitPCodeOperator; + + EmitCallPro(SubId); + + Reg := GetReg; + + EmitLoadAddress(Reg, SymbolRecR); // result + Prg.AsmPush_REG(Reg); + + EmitLoadIntVal(Reg, SymbolRec1); // instance + Prg.AsmPush_REG(Reg); + + // push ppi + PropIndex := SymbolRec2.PropIndex; + ClassId := GetSymbolRec(SymbolRec1.TerminalHostClassId).Id; + Shift := GetOffset(GetSymbolRec(ClassId + 1)); + Inc(Shift, (PropIndex + 1) * SizeOfPointer); + Prg.AsmGetREG_ESIPtr(Reg, Shift); + Prg.AsmPush_REG(Reg); + + FreeReg(Reg); + EmitStdCall(SubId); +end; + +procedure TEmitter.EmitOP_SET_INT64_PROP_64; +var + SubId, Reg, ClassId, PropIndex, Shift: Integer; +begin + SubId := Id_SetInt64Prop; + + EmitPCodeOperator; + + EmitCallPro(SubId); + + Reg := GetRegEx; + + // push ppi + PropIndex := SymbolRec2.PropIndex; + ClassId := GetSymbolRec(SymbolRec1.TerminalHostClassId).Id; + Shift := GetOffset(GetSymbolRec(ClassId + 1)); + Inc(Shift, (PropIndex + 1) * SizeOfPointer); + Prg.AsmGetREG_ESIPtr(Reg, Shift); + Prg.AsmMovREG_REG(_ECX, Reg); + + EmitLoadIntVal(Reg, SymbolRec1); // instance + Prg.AsmMovREG_REG(_EDX, Reg); + + EmitLoadAddress(Reg, SymbolRecR); // value + Prg.AsmMovREG_REG(_R8, Reg); + + FreeReg(Reg); + EmitStdCall(SubId); +end; +procedure TEmitter.EmitOP_SET_INT64_PROP; +var + SubId, Reg, ClassId, PropIndex, Shift: Integer; +begin + SubId := Id_SetInt64Prop; + + EmitPCodeOperator; + + EmitCallPro(SubId); + + Reg := GetReg; + + EmitLoadAddress(Reg, SymbolRecR); // value + Prg.AsmPush_REG(Reg); + + EmitLoadIntVal(Reg, SymbolRec1); // instance + Prg.AsmPush_REG(Reg); + + // push ppi + PropIndex := SymbolRec2.PropIndex; + ClassId := GetSymbolRec(SymbolRec1.TerminalHostClassId).Id; + Shift := GetOffset(GetSymbolRec(ClassId + 1)); + Inc(Shift, (PropIndex + 1) * SizeOfPointer); + Prg.AsmGetREG_ESIPtr(Reg, Shift); + Prg.AsmPush_REG(Reg); + + FreeReg(Reg); + EmitStdCall(SubId); +end; + +procedure TEmitter.EmitOP_GET_EVENT_PROP_64; +var + SubId, Reg, ClassId, PropIndex, Shift: Integer; +begin + SubId := Id_GetEventProp; + + EmitPCodeOperator; + + EmitCallPro(SubId); + + HandlesEvents := true; + + Reg := GetRegEx; + + // push ppi + PropIndex := SymbolRec2.PropIndex; + ClassId := GetSymbolRec(SymbolRec1.TerminalHostClassId).Id; + Shift := GetOffset(GetSymbolRec(ClassId + 1)); + Inc(Shift, (PropIndex + 1) * SizeOfPointer); + Prg.AsmGetREG_ESIPtr(Reg, Shift); + Prg.AsmMovREG_REG(_ECX, Reg); + + EmitLoadIntVal(Reg, SymbolRec1); // instance + Prg.AsmMovREG_REG(_EDX, Reg); + + EmitLoadAddress(Reg, SymbolRecR); // result + Prg.AsmMovREG_REG(_R8, Reg); + + FreeReg(Reg); + EmitStdCall(SubId); +end; +procedure TEmitter.EmitOP_GET_EVENT_PROP; +var + SubId, Reg, ClassId, PropIndex, Shift: Integer; +begin + SubId := Id_GetEventProp; + + EmitPCodeOperator; + + EmitCallPro(SubId); + + HandlesEvents := true; + + Reg := GetReg; + + EmitLoadAddress(Reg, SymbolRecR); // result + Prg.AsmPush_REG(Reg); + + EmitLoadIntVal(Reg, SymbolRec1); // instance + Prg.AsmPush_REG(Reg); + + // push ppi + PropIndex := SymbolRec2.PropIndex; + ClassId := GetSymbolRec(SymbolRec1.TerminalHostClassId).Id; + Shift := GetOffset(GetSymbolRec(ClassId + 1)); + Inc(Shift, (PropIndex + 1) * SizeOfPointer); + Prg.AsmGetREG_ESIPtr(Reg, Shift); + Prg.AsmPush_REG(Reg); + + FreeReg(Reg); + EmitStdCall(SubId); +end; + +procedure TEmitter.EmitOP_SET_EVENT_PROP2_64; +var + SubId, Reg, ClassId, PropIndex, Shift: Integer; +begin + SubId := Id_SetEventProp2; + + EmitPCodeOperator; + + EmitCallPro(SubId); + + HandlesEvents := true; + + Reg := GetRegEx; + + Prg.AsmMovREG_REG(Reg, _ESI); + Prg.AsmAddREG_Imm(Reg, H_SelfPtr); + Prg.AsmMovREG_REGPtr(Reg, Reg); // load TProgram.Self + Prg.AsmMovREG_REG(_ECX, Reg); // push TProgram.Self + + // push ppi + PropIndex := SymbolRec2.PropIndex; + ClassId := GetSymbolRec(SymbolRec1.TerminalHostClassId).Id; + Shift := GetOffset(GetSymbolRec(ClassId + 1)); + Inc(Shift, (PropIndex + 1) * SizeOfPointer); + Prg.AsmGetREG_ESIPtr(Reg, Shift); + Prg.AsmMovREG_REG(_EDX, Reg); + + EmitLoadIntVal(Reg, SymbolRec1); // instance + Prg.AsmMovREG_REG(_R8, Reg); + + EmitLoadAddress(Reg, SymbolRecR); // result + Prg.AsmMovREG_REG(_R9, Reg); + + FreeReg(Reg); + EmitStdCall(SubId); +end; +procedure TEmitter.EmitOP_SET_EVENT_PROP2; +var + SubId, Reg, ClassId, PropIndex, Shift: Integer; +begin + SubId := Id_SetEventProp2; + + EmitPCodeOperator; + + EmitCallPro(SubId); + + HandlesEvents := true; + + Reg := GetReg; + + EmitLoadAddress(Reg, SymbolRecR); // result + Prg.AsmPush_REG(Reg); + + EmitLoadIntVal(Reg, SymbolRec1); // instance + Prg.AsmPush_REG(Reg); + + // push ppi + PropIndex := SymbolRec2.PropIndex; + ClassId := GetSymbolRec(SymbolRec1.TerminalHostClassId).Id; + Shift := GetOffset(GetSymbolRec(ClassId + 1)); + Inc(Shift, (PropIndex + 1) * SizeOfPointer); + Prg.AsmGetREG_ESIPtr(Reg, Shift); + Prg.AsmPush_REG(Reg); + + Prg.AsmMovREG_REG(Reg, _ESI); + Prg.AsmAddREG_Imm(Reg, H_SelfPtr); + Prg.AsmMovREG_REGPtr(Reg, Reg); // load TProgram.Self + Prg.AsmPush_REG(Reg); // push TProgram.Self + + FreeReg(Reg); + EmitStdCall(SubId); +end; + +procedure TEmitter.EmitOP_SET_EVENT_PROP_64; +var + SubId, Reg, ClassId, + PropIndex, Shift, CodeId, DataId, CallConv, RetSize: Integer; + R: TSymbolRec; +begin + SubId := Id_SetEventProp; + + EmitPCodeOperator; + + EmitCallPro(SubId); + + Reg := GetRegEx; + + HandlesEvents := true; + + if SymbolRecR.Id = TKernel(kernel).SymbolTable.NilId then + begin + R := TKernel(kernel).SymbolTable.AddIntegerConst(0); + R.MustBeAllocated := true; + DataId := R.Id; + R := TKernel(kernel).SymbolTable.AddIntegerConst(0); + R.MustBeAllocated := true; + CodeId := R.Id; + + CallConv := ccREGISTER; + RetSize := 0; + end + else + begin + DataId := SymbolRecR.OwnerId; + CodeId := SymbolRecR.PatternId; + + if GetSymbolRec(DataId).Kind = KindTYPE then + Inc(DataId); + + CallConv := GetSymbolRec(CodeId).CallConv; + RetSize := SymbolTable.GetSizeOfParams(CodeId); + end; + + Prg.AsmMovREG_REG(Reg, _ESI); + Prg.AsmAddREG_Imm(Reg, H_SelfPtr); + Prg.AsmMovREG_REGPtr(Reg, Reg); // load TProgram.Self + Prg.AsmMovREG_REG(_ECX, Reg); // push TProgram.Self + + // push ppi + PropIndex := SymbolRec2.PropIndex; + ClassId := GetSymbolRec(SymbolRec1.TerminalHostClassId).Id; + Shift := GetOffset(GetSymbolRec(ClassId + 1)); + Inc(Shift, (PropIndex + 1) * SizeOfPointer); + Prg.AsmGetREG_ESIPtr(Reg, Shift); + Prg.AsmMovREG_REG(_EDX, Reg); + + EmitLoadIntVal(Reg, SymbolRec1); // instance + Prg.AsmMovREG_REG(_R8, Reg); + + if GetSymbolRec(CodeId).Host then + begin + EmitGet_REG(Reg, GetSymbolRec(CodeId)); + end + else + begin + Prg.AsmMovREG_REG(Reg, _EDI); + Prg.AsmAddREG_Imm(Reg, 0); + Prg.Top.SaveSubId := CodeId; + List2.Add(Prg.Top); + end; + Prg.AsmMovREG_REG(_R9, Reg); + + EmitLoadIntVal(Reg, GetSymbolRec(DataId)); // data + Prg.AsmMovRSPPtr_REG64(Reg, $20); + + Prg.AsmMovREG_Imm(Reg, CallConv); + Prg.AsmMovRSPPtr_REG64(Reg, $28); + + Prg.AsmMovREG_Imm(Reg, RetSize); + Prg.AsmMovRSPPtr_REG64(Reg, $30); + + FreeReg(Reg); + EmitStdCall(SubId); +end; +procedure TEmitter.EmitOP_SET_EVENT_PROP; +var + SubId, Reg, ClassId, + PropIndex, Shift, CodeId, DataId, CallConv, RetSize: Integer; + R: TSymbolRec; +begin + SubId := Id_SetEventProp; + + EmitPCodeOperator; + + EmitCallPro(SubId); + + Reg := GetReg; + + HandlesEvents := true; + + if SymbolRecR.Id = TKernel(kernel).SymbolTable.NilId then + begin + R := TKernel(kernel).SymbolTable.AddIntegerConst(0); + R.MustBeAllocated := true; + DataId := R.Id; + R := TKernel(kernel).SymbolTable.AddIntegerConst(0); + R.MustBeAllocated := true; + CodeId := R.Id; + + CallConv := ccREGISTER; + RetSize := 0; + end + else + begin + DataId := SymbolRecR.OwnerId; + CodeId := SymbolRecR.PatternId; + + if GetSymbolRec(DataId).Kind = KindTYPE then + Inc(DataId); + + CallConv := GetSymbolRec(CodeId).CallConv; + RetSize := SymbolTable.GetSizeOfParams(CodeId); + end; + + Prg.AsmPush_Imm(RetSize); + Prg.AsmPush_Imm(CallConv); + + EmitLoadIntVal(Reg, GetSymbolRec(DataId)); // data + Prg.AsmPush_REG(Reg); + + if GetSymbolRec(CodeId).Host then + begin + EmitGet_REG(Reg, GetSymbolRec(CodeId)); + Prg.AsmPush_REG(Reg); + end + else + begin + Prg.AsmMovREG_REG(Reg, _EDI); + Prg.AsmAddREG_Imm(Reg, 0); + Prg.Top.SaveSubId := CodeId; + List2.Add(Prg.Top); + Prg.AsmPush_REG(Reg); + end; + + EmitLoadIntVal(Reg, SymbolRec1); // instance + Prg.AsmPush_REG(Reg); + + // push ppi + PropIndex := SymbolRec2.PropIndex; + ClassId := GetSymbolRec(SymbolRec1.TerminalHostClassId).Id; + Shift := GetOffset(GetSymbolRec(ClassId + 1)); + Inc(Shift, (PropIndex + 1) * SizeOfPointer); + Prg.AsmGetREG_ESIPtr(Reg, Shift); + Prg.AsmPush_REG(Reg); + + Prg.AsmMovREG_REG(Reg, _ESI); + Prg.AsmAddREG_Imm(Reg, H_SelfPtr); + Prg.AsmMovREG_REGPtr(Reg, Reg); // load TProgram.Self + Prg.AsmPush_REG(Reg); // push TProgram.Self + + FreeReg(Reg); + EmitStdCall(SubId); +end; + +procedure TEmitter.EmitOP_EMIT_ON; +begin + EmitPCodeOperator; + EmitOff := false; +end; + +procedure TEmitter.EmitOP_EMIT_OFF; +begin + EmitPCodeOperator; + EmitOff := true; +end; + +procedure TEmitter.EmitOP_CREATE_OBJECT_64; +var + Reg, SubId, Id: Integer; +begin + EmitPCodeOperator; + + SubId := Id_CreateObject; + EmitCallPro(SubId); + + Reg := GetRegEx; + + Id := TKernel(kernel).Code.GetCurrSelfId(TKernel(kernel).Code.N); + EmitLoadIntVal(Reg, GetSymbolRec(Id)); + Prg.AsmMovREG_REG(_ECX, Reg); + + EmitLoadAddress(Reg, SymbolRecR); + Prg.AsmMovREG_REG(_EDX, Reg); + + FreeReg(Reg); + EmitStdCall(SubId); +end; +procedure TEmitter.EmitOP_CREATE_OBJECT; +var + Reg, SubId, Id: Integer; +begin + EmitPCodeOperator; + + SubId := Id_CreateObject; + EmitCallPro(SubId); + + Reg := GetReg; + + EmitLoadAddress(Reg, SymbolRecR); + Prg.AsmPush_REG(Reg); + +// TypeId := SymbolRec1.TerminalTypeId; +// EmitLoadIntVal(Reg, GetSymbolRec(TypeId + 1)); + Id := TKernel(kernel).Code.GetCurrSelfId(TKernel(kernel).Code.N); + EmitLoadIntVal(Reg, GetSymbolRec(Id)); + Prg.AsmPush_REG(Reg); + + FreeReg(Reg); + EmitStdCall(SubId); +end; + +procedure TEmitter.EmitOP_DESTROY_OBJECT_64; +begin +end; +procedure TEmitter.EmitOP_DESTROY_OBJECT; +begin +end; + +procedure TEmitter.EmitOP_PUSH_PROG; // stdcall expected on win32 +var + Reg: Integer; +begin + EmitPCodeOperator; + + Reg := GetRegEx; + + Prg.AsmMovREG_REG(Reg, _ESI); + Prg.AsmAddREG_Imm(Reg, H_SelfPtr); + Prg.AsmMovREG_REGPtr(Reg, Reg); // load TProgram.Self + if TargetPlatform = tpWIN64 then + Prg.AsmMovREG_REG(_ECX, Reg) // push TProgram.Self + else + Prg.AsmPush_REG(Reg); // push TProgram.Self + + FreeReg(Reg); +end; + +procedure TEmitter.EmitOP_GET_VMT_ADDRESS_64; +var + Reg, MethodIndex, I, msg_id: Integer; + SymbolProgRec: TSymbolProgRec; +begin + EmitPCodeOperator; + + msg_id := SymbolRec2.DynamicMethodIndex; + if msg_id = 0 then + begin + I := TKernel(kernel).MessageList.IndexOf(SymbolRec2.FullName); + if I >= 0 then + msg_id := TKernel(kernel).MessageList[I].msg_id; + end; + + if msg_id <> 0 then + begin + Emit_PUSH_REGS; + + Reg := GetRegEx; + + EmitLoadIntVal(Reg, SymbolRec1); // instance + if SymbolRec1.FinalTypeId <> typeCLASSREF then + prg.AsmMovREG_REGPtr(Reg, Reg); + Prg.AsmMovREG_REG(_ECX, Reg); + + Prg.AsmMovREG_Imm(Reg, msg_id); + Prg.AsmMovREG_REG(_EDX, Reg); + + EmitLoadAddress(Reg, SymbolRecR); + Prg.AsmMovREG_REG(_R8, Reg); + + EmitGet_REG(Reg, SymbolTable[Id_GetDynamicMethodAddress]); + Prg.AsmCall_REG(Reg); + + FreeReg(Reg); + Emit_POP_REGS; + + Exit; + end; + + if IsLocalPos then + Emit_PUSH_REGS; + + Reg := GetRegEx; + + MethodIndex := SymbolRec2.MethodIndex; + + EmitLoadIntVal(Reg, SymbolRec1); // instance + if SymbolRec1.FinalTypeId <> typeCLASSREF then + prg.AsmMovREG_REGPtr(Reg, Reg); + + if MethodIndex = 0 then + begin + SymbolProgRec := prg.AsmAddREG_Imm(Reg, 0); + SymbolProgRec.MustBeFixed := true; + SymbolProgRec.OpOffset := 2; + SymbolProgRec.SubId := SymbolRec2.Id; + end + else + begin + prg.AsmAddREG_Imm(Reg, (MethodIndex - 1) * SizeOfPointer); +{$IFDEF FPC} + prg.AsmAddREG_Imm(Reg, FPC_VIRTUAL_OFFSET); +{$ENDIF} + end; + prg.AsmMovREG_REGPtr(Reg, Reg); + + EmitSaveIntVal(Reg, SymbolRecR); // result + + FreeReg(Reg); + + if IsLocalPos then + Emit_POP_REGS; +end; +procedure TEmitter.EmitOP_GET_VMT_ADDRESS; +var + Reg, MethodIndex, I, msg_id: Integer; + SymbolProgRec: TSymbolProgRec; +begin + EmitPCodeOperator; + + msg_id := SymbolRec2.DynamicMethodIndex; + if msg_id = 0 then + begin + I := TKernel(kernel).MessageList.IndexOf(SymbolRec2.FullName); + if I >= 0 then + msg_id := TKernel(kernel).MessageList[I].msg_id; + end; + + if msg_id <> 0 then + begin + Emit_PUSH_REGS; + + Reg := GetRegEx; + + EmitLoadAddress(Reg, SymbolRecR); + Prg.AsmPush_REG(Reg); + + Prg.AsmPush_Imm(msg_id); + + EmitLoadIntVal(Reg, SymbolRec1); // instance + if SymbolRec1.FinalTypeId <> typeCLASSREF then + prg.AsmMovREG_REGPtr(Reg, Reg); + Prg.AsmPush_REG(Reg); + + EmitGet_REG(Reg, SymbolTable[Id_GetDynamicMethodAddress]); + Prg.AsmCall_REG(Reg); + + FreeReg(Reg); + Emit_POP_REGS; + + Exit; + end; + + if IsLocalPos then + Emit_PUSH_REGS; + + Reg := GetRegEx; + + MethodIndex := SymbolRec2.MethodIndex; + + EmitLoadIntVal(Reg, SymbolRec1); // instance + + if SymbolRec1.FinalTypeId <> typeCLASSREF then + prg.AsmMovREG_REGPtr(Reg, Reg); + + if MethodIndex = 0 then + begin + SymbolProgRec := prg.AsmAddREG_Imm(Reg, 0); + SymbolProgRec.MustBeFixed := true; + SymbolProgRec.OpOffset := 2; + SymbolProgRec.SubId := SymbolRec2.Id; + end + else + begin + prg.AsmAddREG_Imm(Reg, (MethodIndex - 1) * SizeOfPointer); +{$IFDEF FPC} + prg.AsmAddREG_Imm(Reg, FPC_VIRTUAL_OFFSET); +{$ENDIF} + end; + prg.AsmMovREG_REGPtr(Reg, Reg); + + EmitSaveIntVal(Reg, SymbolRecR); // result + + FreeReg(Reg); + + if IsLocalPos then + Emit_POP_REGS; +end; + +function TEmitter.HasTheSameAddressRegister(S1, S2: TSymbolRec): Boolean; + +var + t: Integer; + +function RR(S: TSymbolRec): Integer; +begin + Inc(t); + + if (S.Local or S.Param) and (not S.OverScript) then // local + begin + if S.ByRef or S.ByRefEx then + result := t + else + begin + if S.Level = ContextStack.Top then + result := _EBP + else + result := t; + end; + end + else // global + begin + if S.Host or S.ByRef or S.ByRefEx then + result := t + else + result := _ESI; + end; +end; + +begin + t := 100; + result := RR(S1) = RR(S2); +end; + +function TEmitter.EmitGetAddressRegister(S: TSymbolRec): Integer; + // returns a register. + // If it returns ESI or EBP, address = result + S.Shift !! + // otherwise, address = result + // Caller must free the register !! +var + temp: Integer; +begin + if (S.Local or S.LocalInternalField or S.Param) and (not S.OverScript) then + begin + if S.ByRef or S.ByRefEx then + begin + result := GetReg; + EmitGet_REG(result, S); + end + else + begin + if S.Level = ContextStack.Top then + result := _EBP + else + begin + result := GetReg; + EmitRestoreEBP(result, S); + Prg.AsmAddREG_Imm(result, GetOffset(S)); + end; + end; + end + else // global + begin + if S.Host or S.ByRef or S.ByRefEx then + begin + result := GetReg; + + temp := S.FinSize; + S.FinSize := SizeOf(IntPax); + EmitGet_REG(result, S); + S.FinSize := temp; + end + else + result := _ESI; + end; +end; + +procedure TEmitter.EmitFLD(S: TSymbolRec); +var + Reg: Integer; +begin + Reg := EmitGetAddressRegister(S); + case S.FinalTypeId of + typeDOUBLE: Prg.AsmFldDouble_REGPtr(Reg, S); + typeSINGLE: Prg.AsmFldSingle_REGPtr(Reg, S); + typeEXTENDED: Prg.AsmFldExtended_REGPtr(Reg, S); + else + RaiseError(errInternalError, []); + end; + FreeReg(Reg); +end; + +procedure TEmitter.EmitFild(S: TSymbolRec); +var + Reg, TempReg: Integer; +begin + Reg := GetReg; + EmitLoadAddress(Reg, S); + if S.PtrSize = 8 then + Prg.AsmFild_REG64Ptr(Reg) + else if S.FinalTypeId in IntegerTypes then + begin + EmitLoadAddress(Reg, S); + case S.PtrSize of + 1: + begin + TempReg := GetReg; + Prg.AsmXorREG_REG(TempReg, TempReg); + Prg.AsmMovREG8_REGPtr(TempReg, Reg); + Prg.AsmPush_REG(TempReg); + Prg.AsmMovREG_REG(TempReg, _ESP); + Prg.AsmFild_REG32Ptr(TempReg); + Prg.AsmPop_REG(TempReg); + FreeReg(TempReg); + end; + 2: Prg.AsmFild_REG16Ptr(Reg); + 4: Prg.AsmFild_REG32Ptr(Reg); + end; + end + else + RaiseError(errInternalError, []); + FreeReg(Reg); +end; + +procedure TEmitter.EmitFSTP(S: TSymbolRec); +var + Reg: Integer; +begin + Reg := EmitGetAddressRegister(S); + case S.FinalTypeId of + typeDOUBLE: Prg.AsmFStpDouble_REGPtr(Reg, S); + typeSINGLE: Prg.AsmFStpSingle_REGPtr(Reg, S); + typeEXTENDED: Prg.AsmFStpExtended_REGPtr(Reg, S); + else + RaiseError(errInternalError, []); + end; + FreeReg(Reg); +end; + +procedure TEmitter.EmitJmp; +begin + List3.Add(SymbolRec1); + Prg.AsmJMP_Imm(0); + List1.Add(Prg.Top); +end; + +procedure TEmitter.EmitOP_EQ_EVENT_64; +begin + RaiseNotImpl; +end; + +procedure TEmitter.EmitOP_NE_EVENT_64; +begin + RaiseNotImpl; +end; + +procedure TEmitter.EmitLoadAddress(Reg: Integer; S: TSymbolRec); +var + temp: Integer; +begin + if (S.Local or S.LocalInternalField or S.Param) and (not S.OverScript) then + begin + if S.ByRef or S.ByRefEx then + begin + EmitGet_REG(Reg, S); + end + else + begin + if S.Level = ContextStack.Top then + begin + Prg.AsmMovREG_REG(Reg, _EBP); + Prg.AsmAddREG_Imm(Reg, GetOffset(S)); + end + else + begin + EmitRestoreEBP(Reg, S); + Prg.AsmAddREG_Imm(Reg, GetOffset(S)); + end; + end; + end + else // global + begin + if S.Host or S.ByRef or S.ByRefEx then + begin + temp := S.FinSize; + S.FinSize := SizeOf(IntPax); + EmitGet_REG(Reg, S); + S.FinSize := temp; + end + else + begin + Prg.AsmMovREG_REG(Reg, _ESI); + Prg.AsmAddREG_Imm(Reg, GetOffset(S)); + end; + end; +end; + +procedure TEmitter.EmitLoadIntVal(Reg: Integer; S: TSymbolRec); +var + TempReg, Temp: Integer; + C: Cardinal; +begin + if (S.Kind = KindCONST) and (not (S.FinalTypeId in RealTypes + [typeCURRENCY])) then + begin + C := S.Value; + Prg.AsmMovREG_Imm(Reg, C); + end + else + begin + if S.Host or S.ByRef or S.ByRefEx then + begin + temp := S.FinSize; + S.FinSize := SizeOf(IntPax); + EmitGet_REG(Reg, S); + S.FinSize := temp; + case S.PtrSize of + 1: + begin + if TargetPlatform = tpWIN64 then + TempReg := GetReg64 + else + TempReg := GetReg; + Prg.AsmPush_REG(TempReg); + Prg.AsmMovREG_Imm(TempReg, 0); + Prg.AsmMovREG8_REGPtr(TempReg, Reg); + Prg.AsmMovREG_REG(Reg, TempReg); + Prg.AsmPop_REG(TempReg); + FreeReg(TempReg); + end; + 2: + begin + if TargetPlatform = tpWIN64 then + TempReg := GetReg64 + else + TempReg := GetReg; + Prg.AsmPush_REG(TempReg); + Prg.AsmMovREG_Imm(TempReg, 0); + Prg.AsmMovREG16_REGPtr(TempReg, Reg); + Prg.AsmMovREG_REG(Reg, TempReg); + Prg.AsmPop_REG(TempReg); + FreeReg(TempReg); + end; + else + begin + if TargetPlatform = tpWIN64 then + begin + case S.PtrSize of + 4: Prg.AsmMovREG32_REGPtr(Reg, Reg); + 8: Prg.AsmMovREG64_REGPtr(Reg, Reg); + else + RaiseError(errInternalError, []); + end; + end + else + Prg.AsmMovREG32_REGPtr(Reg, Reg); + end; + end; //case + end + else + begin + if S.PtrSize < SizeOfPointer then + Prg.AsmMovREG_Imm(Reg, 0); + EmitGet_REG(Reg, S); + end; + end; +end; + +procedure TEmitter.EmitSaveIntVal(Reg: Integer; S: TSymbolRec); +var + RegR: Integer; +begin + if S.Host or S.ByRef or S.ByRefEx then + begin + RegR := GetReg; + EmitLoadAddress(RegR, S); + case S.PtrSize of + 1: Prg.AsmMovREGPtr_REG8(RegR, Reg); + 2: Prg.AsmMovREGPtr_REG16(RegR, Reg); + else + begin + if TargetPlatform = tpWIN64 then + begin + case S.PtrSize of + 4: Prg.AsmMovREGPtr_REG32(RegR, Reg); + 8: Prg.AsmMovREGPtr_REG64(RegR, Reg); + else + RaiseError(errInternalError, []); + end; + end + else + Prg.AsmMovREGPtr_REG32(RegR, Reg); + end; + end; + FreeReg(RegR); + end + else + EmitPut_REG(Reg, S); +end; + +procedure TEmitter.EmitPut_REG_64(Reg: Integer; S: TSymbolRec; ExtraShift: Integer = 0); + // Reg contains a 32-bit value + // S - destination +var + SZ, TempReg: Integer; +begin + SZ := S.Size; + + case SZ of + 1: + begin + if (S.Param or S.Local or S.LocalInternalField) and (not S.OverScript) then // local + begin + if S.Level = ContextStack.Top then + Prg.AsmPutREG8_EBPPtr(Reg, GetOffset(S) + ExtraShift) + else + begin + TempReg := GetReg64; + Prg.AsmPush_REG(TempReg); + EmitRestoreEBP(TempReg, S); + Prg.AsmAddREG_Imm(TempReg, GetOffset(S) + ExtraShift); + Prg.AsmMovREGPtr_REG8(TempReg, Reg); + Prg.AsmPop_REG(TempReg); + FreeReg(TempReg); + end; + end + else // global + Prg.AsmPutREG8_ESIPtr(Reg, GetOffset(S) + ExtraShift); + end; + 2: + begin + if (S.Param or S.Local or S.LocalInternalField) and (not S.OverScript) then // local + begin + if S.Level = ContextStack.Top then + Prg.AsmPutREG16_EBPPtr(Reg, GetOffset(S) + ExtraShift) + else + begin + TempReg := GetReg64; + Prg.AsmPush_REG(TempReg); + EmitRestoreEBP(TempReg, S); + Prg.AsmAddREG_Imm(TempReg, GetOffset(S) + ExtraShift); + Prg.AsmMovREGPtr_REG16(TempReg, Reg); + Prg.AsmPop_REG(TempReg); + FreeReg(TempReg); + end; + end + else // global + Prg.AsmPutREG16_ESIPtr(Reg, GetOffset(S) + ExtraShift); + end; + 4: + begin + if (S.Param or S.Local or S.LocalInternalField) and (not S.OverScript) then // local + begin + if S.Level = ContextStack.Top then + Prg.AsmPutREG32_EBPPtr(Reg, GetOffset(S) + ExtraShift) + else + begin + TempReg := GetReg64; + Prg.AsmPush_REG(TempReg); + EmitRestoreEBP(TempReg, S); + Prg.AsmAddREG_Imm(TempReg, GetOffset(S) + ExtraShift); + Prg.AsmMovREGPtr_REG32(TempReg, Reg); + Prg.AsmPop_REG(TempReg); + FreeReg(TempReg); + end; + end + else // global + Prg.AsmPutREG32_ESIPtr(Reg, GetOffset(S) + ExtraShift); + end; + 8: + begin + if (S.Param or S.Local or S.LocalInternalField) and (not S.OverScript) then // local + begin + if S.Level = ContextStack.Top then + Prg.AsmPutREG64_RBPPtr(Reg, GetOffset(S) + ExtraShift) + else + begin + TempReg := GetReg64; + Prg.AsmPush_REG(TempReg); + EmitRestoreEBP(TempReg, S); + Prg.AsmAddREG_Imm(TempReg, GetOffset(S) + ExtraShift); + Prg.AsmMovREGPtr_REG64(TempReg, Reg); + Prg.AsmPop_REG(TempReg); + FreeReg(TempReg); + end; + end + else // global + Prg.AsmPutREG64_RSIPtr(Reg, GetOffset(S) + ExtraShift); + end; + else + RaiseError(errInternalError, []); + end; +end; +procedure TEmitter.EmitPut_REG(Reg: Integer; S: TSymbolRec; ExtraShift: Integer = 0); + // Reg contains a 32-bit value + // S - destination +var + SZ, TempReg: Integer; +begin + if TargetPlatform = tpWIN64 then + begin + EmitPut_REG_64(Reg, S, ExtraShift); + Exit; + end; + + SZ := S.Size; + + case SZ of + 1: + begin + if (S.Param or S.Local or S.LocalInternalField) and (not S.OverScript) then // local + begin + if S.Level = ContextStack.Top then + Prg.AsmPutREG8_EBPPtr(Reg, GetOffset(S) + ExtraShift) + else + begin + TempReg := GetReg; + Prg.AsmPush_REG(TempReg); + EmitRestoreEBP(TempReg, S); + Prg.AsmAddREG_Imm(TempReg, GetOffset(S) + ExtraShift); + Prg.AsmMovREGPtr_REG8(TempReg, Reg); + Prg.AsmPop_REG(TempReg); + FreeReg(TempReg); + end; + end + else // global + Prg.AsmPutREG8_ESIPtr(Reg, GetOffset(S) + ExtraShift); + end; + 2: + begin + if (S.Param or S.Local or S.LocalInternalField) and (not S.OverScript) then // local + begin + if S.Level = ContextStack.Top then + Prg.AsmPutREG16_EBPPtr(Reg, GetOffset(S) + ExtraShift) + else + begin + TempReg := GetReg; + Prg.AsmPush_REG(TempReg); + EmitRestoreEBP(TempReg, S); + Prg.AsmAddREG_Imm(TempReg, GetOffset(S) + ExtraShift); + Prg.AsmMovREGPtr_REG16(TempReg, Reg); + Prg.AsmPop_REG(TempReg); + FreeReg(TempReg); + end; + end + else // global + Prg.AsmPutREG16_ESIPtr(Reg, GetOffset(S) + ExtraShift); + end; + else + begin + if (S.Param or S.Local or S.LocalInternalField) and (not S.OverScript) then // local + begin + if S.Level = ContextStack.Top then + Prg.AsmPutREG32_EBPPtr(Reg, GetOffset(S) + ExtraShift) + else + begin + TempReg := GetReg; + Prg.AsmPush_REG(TempReg); + EmitRestoreEBP(TempReg, S); + Prg.AsmAddREG_Imm(TempReg, GetOffset(S) + ExtraShift); + Prg.AsmMovREGPtr_REG32(TempReg, Reg); + Prg.AsmPop_REG(TempReg); + FreeReg(TempReg); + end; + end + else // global + Prg.AsmPutREG32_ESIPtr(Reg, GetOffset(S) + ExtraShift); + end; + end; +end; + +procedure TEmitter.EmitGet_REG_64(Reg: Integer; S: TSymbolRec; ExtraShift: Integer = 0); + // S - source + // Reg - destination +var + SZ, TempReg: Integer; +begin + SZ := S.Size; + + case SZ of + 1: + begin + if (S.Param or S.Local or S.LocalInternalField) and (not S.OverScript) then // local + begin + if S.Level = ContextStack.Top then + Prg.AsmGetREG8_EBPPtr(Reg, GetOffset(S) + ExtraShift) + else + begin + TempReg := GetReg64; + Prg.AsmPush_REG(TempReg); + EmitRestoreEBP(TempReg, S); + Prg.AsmAddREG_Imm(TempReg, GetOffset(S) + ExtraShift); + Prg.AsmMovREG_Imm(Reg, 0); + Prg.AsmMovREG8_REGPtr(Reg, TempReg); + Prg.AsmPop_REG(TempReg); + FreeReg(TempReg); + end; + end + else // global + begin + Prg.AsmMovREG_Imm(Reg, 0); + Prg.AsmGetREG8_ESIPtr(Reg, GetOffset(S) + ExtraShift); + end; + end; + 2: + begin + if (S.Param or S.Local or S.LocalInternalField) and (not S.OverScript) then // local + begin + if S.Level = ContextStack.Top then + Prg.AsmGetREG16_EBPPtr(Reg, GetOffset(S) + ExtraShift) + else + begin + TempReg := GetReg64; + Prg.AsmPush_REG(TempReg); + EmitRestoreEBP(TempReg, S); + Prg.AsmAddREG_Imm(TempReg, GetOffset(S) + ExtraShift); + Prg.AsmMovREG_Imm(Reg, 0); + Prg.AsmMovREG16_REGPtr(Reg, TempReg); + Prg.AsmPop_REG(TempReg); + FreeReg(TempReg); + end; + end + else // global + begin + Prg.AsmMovREG_Imm(Reg, 0); + Prg.AsmGetREG16_ESIPtr(Reg, GetOffset(S) + ExtraShift); + end; + end; + 4: + begin + if (S.Param or S.Local or S.LocalInternalField) and (not S.OverScript) then // local + begin + if S.Level = ContextStack.Top then + Prg.AsmGetREG32_EBPPtr(Reg, GetOffset(S) + ExtraShift) + else + begin + TempReg := GetReg64; + Prg.AsmPush_REG(TempReg); + EmitRestoreEBP(TempReg, S); + Prg.AsmAddREG_Imm(TempReg, GetOffset(S) + ExtraShift); + Prg.AsmMovREG32_REGPtr(Reg, TempReg); + Prg.AsmPop_REG(TempReg); + FreeReg(TempReg); + end; + end + else // global + Prg.AsmGetREG32_ESIPtr(Reg, GetOffset(S) + ExtraShift); + end; + else + begin + if (S.Param or S.Local or S.LocalInternalField) and (not S.OverScript) then // local + begin + if S.Level = ContextStack.Top then + Prg.AsmGetREG64_RBPPtr(Reg, GetOffset(S) + ExtraShift) + else + begin + TempReg := GetReg64; + Prg.AsmPush_REG(TempReg); + EmitRestoreEBP(TempReg, S); + Prg.AsmAddREG_Imm(TempReg, GetOffset(S) + ExtraShift); + Prg.AsmMovREG64_REGPtr(Reg, TempReg); + Prg.AsmPop_REG(TempReg); + FreeReg(TempReg); + end; + end + else // global + Prg.AsmGetREG64_RSIPtr(Reg, GetOffset(S) + ExtraShift); + end; + end; +end; +procedure TEmitter.EmitGet_REG(Reg: Integer; S: TSymbolRec; ExtraShift: Integer = 0); + // S - source + // Reg - destination +var + SZ, TempReg: Integer; +begin + if TargetPlatform = tpWIN64 then + begin + EmitGet_REG_64(Reg, S, ExtraShift); + Exit; + end; + + SZ := S.Size; + + case SZ of + 1: + begin + if (S.Param or S.Local or S.LocalInternalField) and (not S.OverScript) then // local + begin + if S.Level = ContextStack.Top then + Prg.AsmGetREG8_EBPPtr(Reg, GetOffset(S) + ExtraShift) + else + begin + TempReg := GetReg; + Prg.AsmPush_REG(TempReg); + EmitRestoreEBP(TempReg, S); + Prg.AsmAddREG_Imm(TempReg, GetOffset(S) + ExtraShift); + Prg.AsmXorREG_REG(Reg, Reg); + Prg.AsmMovREG8_REGPtr(Reg, TempReg); + Prg.AsmPop_REG(TempReg); + FreeReg(TempReg); + end; + end + else // global + begin + Prg.AsmXorREG_REG(Reg, Reg); + Prg.AsmGetREG8_ESIPtr(Reg, GetOffset(S) + ExtraShift); + end; + end; + 2: + begin + if (S.Param or S.Local or S.LocalInternalField) and (not S.OverScript) then // local + begin + if S.Level = ContextStack.Top then + Prg.AsmGetREG16_EBPPtr(Reg, GetOffset(S) + ExtraShift) + else + begin + TempReg := GetReg; + Prg.AsmPush_REG(TempReg); + EmitRestoreEBP(TempReg, S); + Prg.AsmAddREG_Imm(TempReg, GetOffset(S) + ExtraShift); + Prg.AsmXorREG_REG(Reg, Reg); + Prg.AsmMovREG16_REGPtr(Reg, TempReg); + Prg.AsmPop_REG(TempReg); + FreeReg(TempReg); + end; + end + else // global + begin + Prg.AsmXorREG_REG(Reg, Reg); + Prg.AsmGetREG16_ESIPtr(Reg, GetOffset(S) + ExtraShift); + end; + end; + else + begin + if (S.Param or S.Local or S.LocalInternalField) and (not S.OverScript) then // local + begin + if S.Level = ContextStack.Top then + Prg.AsmGetREG32_EBPPtr(Reg, GetOffset(S) + ExtraShift) + else + begin + TempReg := GetReg; + Prg.AsmPush_REG(TempReg); + EmitRestoreEBP(TempReg, S); + Prg.AsmAddREG_Imm(TempReg, GetOffset(S) + ExtraShift); + Prg.AsmMovREG32_REGPtr(Reg, TempReg); + Prg.AsmPop_REG(TempReg); + FreeReg(TempReg); + end; + end + else // global + Prg.AsmGetREG32_ESIPtr(Reg, GetOffset(S) + ExtraShift); + end; + end; +end; + +procedure TEmitter.EmitRestoreEBP_64(Reg: Integer; S: TSymbolRec); +var + I, Index, SubId, RBP_Id: Integer; +begin + SubId := S.Level; + Index := ContextStack.IndexOf(SubId); + + if ContextStack.Count > 2 then + Prg.AsmPush_REG(_EBP); + + for I:=ContextStack.Count - 1 downto Index + 1 do + begin + SubId := ContextStack[I]; + RBP_Id := SymbolTable.GetRBP_Id(SubId); + Prg.AsmGetREG64_RBPPtr(Reg, GetOffset(GetSymbolRec(RBP_Id))); + + if ContextStack.Count > 2 then + if I <> Index + 1 then + Prg.AsmMovREG_REG(_EBP, Reg); + end; + + if ContextStack.Count > 2 then + Prg.AsmPop_REG(_EBP); +end; + +procedure TEmitter.EmitRestoreEBP(Reg: Integer; S: TSymbolRec); +var + I, Index, SubId, EBP_Id: Integer; +begin + if TargetPlatform = tpWIN64 then + begin + EmitRestoreEBP_64(Reg, S); + Exit; + end; + + SubId := S.Level; + Index := ContextStack.IndexOf(SubId); + + if ContextStack.Count > 2 then + Prg.AsmPush_REG(_EBP); + + for I:=ContextStack.Count - 1 downto Index + 1 do + begin + SubId := ContextStack[I]; + EBP_Id := SymbolTable.GetRBP_Id(SubId); + Prg.AsmGetREG_EBPPtr(Reg, GetOffset(GetSymbolRec(EBP_Id))); + + if ContextStack.Count > 2 then + if I <> Index + 1 then + Prg.AsmMovREG_REG(_EBP, Reg); + end; + + if ContextStack.Count > 2 then + Prg.AsmPop_REG(_EBP); +end; + +procedure TEmitter.Emit_PUSH_REGS(SubId: Integer = 0); +begin + if SubId > 0 then + if not (GetSymbolRec(SubId).CallConv in [ccREGISTER, cc64, ccMSFASTCALL]) then + Exit; + + case TargetPlatform of + tpOSX32, tpIOSSim: SaveRegisters([_EAX, _ECX, _EDX, _EBX]); + tpWIN64: SaveRegisters([_ECX, _EDX, _R8, _R9]); + else + SaveRegisters([_EAX, _ECX, _EDX]); + end; +end; + +procedure TEmitter.Emit_POP_REGS(SubId: Integer = 0); +begin + if SubId > 0 then + if not (GetSymbolRec(SubId).CallConv in [ccREGISTER, cc64, ccMSFASTCALL]) then + Exit; + + case TargetPlatform of + tpOSX32, tpIOSSim: RestoreRegisters([_EAX, _ECX, _EDX, _EBX]); + tpWIN64: RestoreRegisters([_ECX, _EDX, _R8, _R9]); + else + RestoreRegisters([_EAX, _ECX, _EDX]); + end; +end; + +procedure TEmitter.Emit_PUSH_REGS_EX; +begin + case TargetPlatform of + tpOSX32, tpIOSSim: SaveRegisters([_EAX, _ECX, _EDX, _EBX, _ESI, _EDI]); + tpWIN64: SaveRegisters([_EAX, _ECX, _EDX, _ESI, _EDI]); + else + SaveRegisters([_EAX, _ECX, _EDX, _ESI, _EDI]); + end; +end; + +procedure TEmitter.Emit_POP_REGS_EX; +begin + case TargetPlatform of + tpOSX32, tpIOSSim: RestoreRegisters([_EAX, _ECX, _EDX, _EBX, _ESI, _EDI]); + tpWIN64: RestoreRegisters([_EAX, _ECX, _EDX, _ESI, _EDI]); + else + RestoreRegisters([_EAX, _ECX, _EDX, _ESI, _EDI]); + end; +end; + +procedure TEmitter.CopyContextStack(AStack: TIntegerStack); +var + I: Integer; +begin + for I := 0 to AStack.Count - 1 do + ContextStack.Push(AStack[I]); +end; + +function TEmitter.GetSaveRegAreaOffset: Integer; +begin + result := $60; +end; + +procedure TEmitter.SaveRegisters(const A: array of Integer; + ExtraOffset: Integer = 0); +var + I, S, Reg: Integer; +begin + case TargetPlatform of + tpOSX32, tpIOSSim: + begin + for I := 0 to System.Length(A) - 1 do + Prg.AsmPush_REG(A[I]); + S := System.Length(A) mod 4; + if S <> 0 then + Prg.AsmSubREG_Imm(_ESP, 16 - S * 4); + end; + tpWIN64: + begin + S := GetSaveRegAreaOffset + ExtraOffset; + for I := 0 to System.Length(A) - 1 do + begin + Reg := A[I]; + Prg.AsmMovRSPPtr_REG64(Reg, S); + Inc(S, 8); + end; + end; + else + for I := 0 to System.Length(A) - 1 do + Prg.AsmPush_REG(A[I]); + end; +end; + +procedure TEmitter.RestoreRegisters(const A: array of Integer; + ExtraOffset: Integer = 0); +var + I, S, Reg: Integer; +begin + case TargetPlatform of + tpOSX32, tpIOSSim: + begin + S := System.Length(A) mod 4; + if S <> 0 then + Prg.AsmAddREG_Imm(_ESP, 16 - S * 4); + for I := System.Length(A) - 1 downto 0 do + Prg.AsmPop_REG(A[I]); + end; + tpWIN64: + begin + S := GetSaveRegAreaOffset + ExtraOffset; + for I := 0 to System.Length(A) - 1 do + begin + Reg := A[I]; + Prg.AsmMovREG64_RSPPtr(Reg, S); + Inc(S, 8); + end; + end; + else + for I := System.Length(A) - 1 downto 0 do + Prg.AsmPop_REG(A[I]); + end; +end; + +procedure TEmitter.EmitPushParam_64(Reg: Integer); +var + SubId, ParamNumber, ParamId: Integer; +begin + SubId := R.Res; + if GetSymbolRec(SubId).CallConv <> cc64 then + begin + Prg.AsmPush_REG(Reg); + Exit; + end; + ParamNumber := R.Arg2; + ParamId := SymbolTable.GetParamId(SubId, ParamNumber); + Prg.AsmMovRSPPtr_REG64(Reg, GetSymbolRec(ParamId).RSPOffset); +end; + +procedure TEmitter.EmitPushParam(Reg: Integer); +begin + if TargetPlatform = tpWIN64 then + EmitPushParam_64(Reg) + else + Prg.AsmPush_REG(Reg); +end; + +procedure TEmitter.EmitCallPro(SubId: Integer; InitSize: Integer = - 1); +var + K, cc, sz, S: Integer; +begin + if not (TargetPlatform in [tpOSX32, tpIOSSim]) then + Exit; + K := GetSymbolRec(SubId).Kind; + if not (K in KindSUBS) then + Exit; + +// Prg.EmitGetCallerEIP; +// EmitSaveRBX; + + cc := GetSymbolRec(SubId).CallConv; + if InitSize = - 1 then + sz := TKernel(kernel).SymbolTable.GetSizeOfParams(SubId) + else + sz := InitSize; + case cc of + ccREGISTER: + begin + S := 12 - (sz mod 16); + prg.AsmSubREG_Imm(_ESP, S); + end; + ccSTDCALL: + begin + prg.AsmPush_Imm($80000000 + R1(sz)); + prg.AsmPush_Reg(_EBP); + prg.AsmPush_Imm($beeffeed); + prg.AsmSubREG_Imm(_ESP, R2(sz)); + end; + ccCDECL: + begin + prg.AsmPush_Imm(R1(sz)); + prg.AsmPush_Reg(_EBP); + prg.AsmPush_Imm($beeffeed); + prg.AsmSubREG_Imm(_ESP, R2(sz)); + end; + ccPASCAL: + begin + S := 12 - (sz mod 16); + prg.AsmSubREG_Imm(_ESP, S); + end; + else + RIE; + end; +end; + +procedure TEmitter.EmitStdCall(SubId: Integer; InitSize: Integer = - 1); +begin + if TargetPlatform in [tpOSX32, tpIOSSim] then + begin + EmitSaveRDI; + EmitRestoreRBX; + EmitGet_REG(_EDI, SymbolTable[SubId]); + Prg.AsmCall_REG(_EDI); + EmitCallEpi(SubId, InitSize); + EmitRestoreRDI; + end + else + begin + EmitGet_REG(_EBX, SymbolTable[SubId]); + Prg.AsmCall_REG(_EBX); + EmitCallEpi(SubId, InitSize); + end; +end; + +procedure TEmitter.EmitCallEpi(SubId: Integer; InitSize: Integer = -1); +var + K, cc, sz, S: Integer; +begin + if not (TargetPlatform in [tpOSX32, tpIOSSim]) then + Exit; + K := GetSymbolRec(SubId).Kind; + if not (K in KindSUBS) then + Exit; + cc := GetSymbolRec(SubId).CallConv; + if InitSize = - 1 then + sz := TKernel(kernel).SymbolTable.GetSizeOfParams(SubId) + else + sz := InitSize; + case cc of + ccREGISTER: + begin + S := 12 - (sz mod 16); + prg.AsmAddREG_Imm(_ESP, S); + end; + ccSTDCALL: + begin + prg.AsmAddREG_Imm(_ESP, R2(sz)); + prg.AsmAddREG_Imm(_ESP, $0c); + Prg.AsmIncBytePtr(_ESP, - $0c); + end; + ccCDECL: + begin + prg.AsmAddREG_Imm(_ESP, R3(sz)); + Prg.AsmIncBytePtr(_ESP, - $0c); + end; + ccPASCAL: + begin + S := 12 - (sz mod 16); + prg.AsmAddREG_Imm(_ESP, S); + end + else + RIE; + end; +end; + +function TEmitter.GetSizeOfPointer: Integer; +begin + if TargetPlatform = tpWIN64 then + result := 8 + else + result := 4; +end; + +function TEmitter.GetTargetPlatform: TTargetPlatform; +begin + result := TKernel(kernel).TargetPlatform; +end; + +procedure EmitProgProc(akernel, aprog: Pointer; context: Pointer = nil); +var + kernel: TKernel; + prog: TProgram; + Emitter: TEmitter; + SymbolProgram: TSymbolProg; + IsEval: Boolean; +begin + kernel := TKernel(akernel); + prog := TProgram(aprog); + + IsEval := context <> nil; + + Emitter := TEmitter.Create(kernel); + if IsEval then + Emitter.CopyContextStack(TIntegerStack(context)); + SymbolProgram := Emitter.CreateSymbolProgram(kernel); + try + if not IsEval then + begin + kernel.Code.CreateMapping(prog.ScriptMapTable, false, + prog.HostMapTable, prog.ScriptMapTable); + prog.CreateMapOffsets; + kernel.Code.CreateExportList(prog.ScriptMapTable); + end; + + SymbolProgram.CreateProgram(prog, IsEval); + Dump_All(DUMP_PATH, kernel, prog, SymbolProgram); + + finally + FreeAndNil(Emitter); + FreeAndNil(SymbolProgram); + end; +end; + +end. diff --git a/Sources/PAXCOMP_ERROR.pas b/Sources/PAXCOMP_ERROR.pas new file mode 100644 index 0000000..cbeaa97 --- /dev/null +++ b/Sources/PAXCOMP_ERROR.pas @@ -0,0 +1,149 @@ +//////////////////////////////////////////////////////////////////////////// +// PaxCompiler +// Site: http://www.paxcompiler.com +// Author: Alexander Baranovsky (paxscript@gmail.com) +// ======================================================================== +// Copyright (c) Alexander Baranovsky, 2006-2014. All rights reserved. +// Code Version: 4.2 +// ======================================================================== +// Unit: PAXCOMP_ERROR.pas +// ======================================================================== +//////////////////////////////////////////////////////////////////////////// + +{$I PaxCompiler.def} +{$O-} +unit PAXCOMP_ERROR; +interface +uses {$I uses.def} + PAXCOMP_TYPES, + SysUtils, + Classes; + +type + TError = class + private + kernel: Pointer; + fMessage: String; + fPCodeLineNumber: Integer; + fModuleName: String; + fSourceLineNumber: Integer; + fSourceLine: String; + fLinePos: Integer; + fSourceFileName: String; + public + constructor Create(i_kernel: Pointer; const i_Message: String); overload; + constructor Create(i_kernel: Pointer); overload; + function Clone(i_kernel: Pointer): TError; + property Message: String read fMessage; + property PCodeLineNumber: Integer read fPCodeLineNumber; + property ModuleName: String read fModuleName; + property SourceLine: String read fSourceLine; + property SourceLineNumber: Integer read fSourceLineNumber; + property LinePos: Integer read fLinePos; + property SourceFileName: String read fSourceFileName; + end; + + TErrorList = class(TTypedList) + private + kernel: Pointer; + function GetRecord(I: Integer): TError; + public + constructor Create(i_kernel: Pointer); + procedure Reset; + procedure Add(E: TError); + function IndexOf(E: TError): Integer; + property Records[I: Integer]: TError read GetRecord; default; + end; + +implementation + +uses + PAXCOMP_KERNEL, PAXCOMP_PARSER, PAXCOMP_MODULE; + +constructor TError.Create(i_kernel: Pointer); +begin + inherited Create; + kernel := i_kernel; +end; + +constructor TError.Create(i_kernel: Pointer; const i_Message: String); +var + M: TModule; +begin + inherited Create; + fMessage := i_Message; + kernel := i_kernel; + fPCodeLineNumber := TKernel(kernel).Code.N; + if (fPCodeLineNumber < 1) or (fPCodeLineNumber > TKernel(kernel).Code.Card) then + fPCodeLineNumber := TKernel(kernel).Code.Card; + M := TKernel(kernel).Code.GetModule(fPCodeLineNumber); + if M <> nil then + begin + fModuleName := M.Name; + fSourceLine := TKernel(kernel).Code.GetSourceLine(fPCodeLineNumber); + fSourceLineNumber := TKernel(kernel).Code.GetSourceLineNumber(fPCodeLineNumber); + fLinePos := TKernel(kernel).Code.GetLinePos(fPCodeLineNumber); + fSourceFileName := TKernel(kernel).Code.GetIncludedFileName(fPCodeLineNumber); + if fSourceFileName = '' then + fSourceFileName := M.FileName; + end + else + begin + fModuleName := ''; + fSourceLine := ''; + fSourceLineNumber := 0; + fLinePos := 0; + end; +end; + +function TError.Clone(i_kernel: Pointer): TError; +begin + result := TError.Create(i_Kernel); + result.fMessage := fMessage; + result.fPCodeLineNumber := fPCodeLineNumber; + result.fModuleName := fModuleName; + result.fSourceLineNumber := fSourceLineNumber; + result.fSourceLine := fSourceLine; + result.fLinePos := fLinePos; + result.fSourceFileName := fSourceFileName; +end; + +constructor TErrorList.Create(i_kernel: Pointer); +begin + inherited Create; + Self.kernel := i_kernel; +end; + +procedure TErrorList.Reset; +begin + Clear; +end; + +function TErrorList.GetRecord(I: Integer): TError; +begin + result := TError(L[I]); +end; + +function TErrorList.IndexOf(E: TError): Integer; +var + I: Integer; +begin + result := -1; + for I := 0 to Count - 1 do + if Records[I].fSourceLineNumber = E.fSourceLineNumber then + if Records[I].fMessage = E.fMessage then + begin + result := I; + Exit; + end; +end; + +procedure TErrorList.Add(E: TError); +begin + if IndexOf(E) = -1 then + L.Add(E) + else + FreeAndNil(E); +end; + +end. diff --git a/Sources/PAXCOMP_EVAL.pas b/Sources/PAXCOMP_EVAL.pas new file mode 100644 index 0000000..230aacc --- /dev/null +++ b/Sources/PAXCOMP_EVAL.pas @@ -0,0 +1,870 @@ +//////////////////////////////////////////////////////////////////////////// +// PaxCompiler +// Site: http://www.paxcompiler.com +// Author: Alexander Baranovsky (paxscript@gmail.com) +// ======================================================================== +// Copyright (c) Alexander Baranovsky, 2006-2014. All rights reserved. +// Code Version: 4.2 +// ======================================================================== +// Unit: PAXCOMP_EVAL.pas +// ======================================================================== +//////////////////////////////////////////////////////////////////////////// + +{$I PaxCompiler.def} +{$R-} +{$O-} +unit PAXCOMP_EVAL; +interface +uses {$I uses.def} + SysUtils, + Classes, + PAXCOMP_CONSTANTS, + PAXCOMP_TYPES, + PAXCOMP_SYS, + PAXCOMP_BYTECODE, + PAXCOMP_SYMBOL_REC, + PAXCOMP_BASESYMBOL_TABLE, + PAXCOMP_SYMBOL_TABLE, + PAXCOMP_EXTRASYMBOL_TABLE, + PAXCOMP_KERNEL, + PAXCOMP_MODULE, + PAXCOMP_CLASSFACT, + PAXCOMP_BASERUNNER; + +type + TSaveRec = class + public + Id: Integer; + Shift: Integer; + Host: Boolean; + Address: Pointer; + OverScript: Boolean; + ClassIndex: Integer; + end; + + TSaveList = class(TTypedList) + private + symbol_table: TSymbolTable; + function GetRecord(I: Integer): TSaveRec; + public + function AddRec(id: Integer): TSaveRec; + procedure Save; + procedure Restore; + constructor Create(st: TSymbolTable); + property Records[I: Integer]: TSaveRec read GetRecord; default; + end; + + TEval = class + private + SN: Integer; + PascalParser: Pointer; + CurrSubId: Integer; + ECode_InitCard: Integer; + HostState: TMemoryStream; + SaveList: TSaveList; + ContextStack: TIntegerStack; + HostState_Position: Integer; + IsPaused: Boolean; + function GetPAX64: Boolean; + procedure RemoveSubs; + procedure CreateECode; + procedure CreateESymbolTable; + procedure SaveHostState; + procedure RestoreHostState; + procedure ClearResult; + public + ResultId: Integer; + NamespaceList: TStringList; + SKernel, EKernel: TKernel; + SProg, EProg: TBaseRunner; + RunnerClass: TBaseRunnerClass; + constructor Create; + destructor Destroy; override; + procedure Reset; + procedure Init(kernel: TKernel; prog: TBaseRunner; N: Integer); + procedure CompileExpression(const Source: String); + procedure CompileProgram(const Source: String); + procedure Run; + function Valid: Boolean; + function GetResultAsVariant: Variant; + function GetResultAsString: String; + function GetResultAddress: Pointer; + function GetResultTypeName: String; + function GetResultTypeId: Integer; + function HasErrors: Boolean; + function GetErrorCount: Integer; + function GetErrorMessage(I: Integer): String; + procedure MapAddresses; + property PAX64: Boolean read GetPAX64; + end; + +implementation + +uses + PaxRunner, + PAXCOMP_STDLIB, + PAXCOMP_PASCAL_PARSER; + +constructor TSaveList.Create(st: TSymbolTable); +begin + inherited Create; + symbol_table := st; +end; + +function TSaveList.AddRec(id: Integer): TSaveRec; +var + R: TSymbolRec; +begin + R := symbol_table[id]; + result := TSaveRec.Create; + result.Id := R.id; + result.Shift := R.Shift; + result.Host := R.Host; + result.Address := R.Address; + result.OverScript := R.OverScript; + result.ClassIndex := R.ClassIndex; + L.Add(result); +end; + +procedure TSaveList.Save; +var + I: Integer; +begin + for I := symbol_table.CompileCard + 1 to symbol_table.Card do + AddRec(I); +end; + +procedure TSaveList.Restore; +var + I: Integer; + R: TSymbolRec; +begin + for I := 0 to Count - 1 do + begin + R := symbol_table[Records[I].Id]; + with Records[I] do + begin + R.Shift := Shift; + R.Host := Host; + R.OverScript := OverScript; + R.ClassIndex := ClassIndex; + end; + end; +end; + +function TSaveList.GetRecord(I: Integer): TSaveRec; +begin + result := TSaveRec(L[I]); +end; + +constructor TEval.Create; +begin + inherited; + + SKernel := nil; + SProg := nil; + EKernel := nil; + EProg := nil; + + PascalParser := TPascalParser.Create; + HostState := TMemoryStream.Create; + NamespaceList := TStringList.Create; + + SaveList := nil; + + ContextStack := TIntegerStack.Create; +end; + +destructor TEval.Destroy; +begin + ClearResult; + + NamespaceList.Free; + + if ekernel <> nil then + EKernel.MessageList := nil; + + if eprog <> nil then + EProg.ProgClassFactory := nil; + + if ekernel <> nil then + EKernel.Free; + + if eprog <> nil then + EProg.Free; + TPascalParser(PascalParser).Free; + HostState.Free; + + ContextStack.Free; + + if SaveList <> nil then + begin + SaveList.Restore; + SaveList.Free; + SaveList := nil; + end; + + inherited; +end; + +procedure TEval.Reset; +begin + ClearResult; + + NamespaceList.Clear; + + ContextStack.Clear; + + if SaveList <> nil then + begin + SaveList.Restore; + SaveList.Free; + SaveList := nil; + end; + + SKernel := nil; + SProg := nil; + EKernel.Reset; +end; + +procedure TEval.Init(kernel: TKernel; prog: TBaseRunner; N: Integer); +begin + RunnerClass := TBaseRunnerClass(TObject(prog).ClassType); + + IsPaused := prog.IsPaused; + + skernel := kernel; + sprog := prog; + EKernel := TKernel.Create(nil); + EKernel.SignCompression := false; + EKernel.PAX64 := skernel.PAX64; + + EKernel.MessageList := SProg.MessageList; + + EProg := RunnerClass.Create; + EProg.PAX64 := skernel.PAX64; + + EProg.ProgClassFactory.Free; + EProg.ProgClassFactory := SProg.ProgClassFactory; + + SN := N; + if SN <= 0 then + SN := skernel.Code.Card; + + CurrSubId := skernel.Code.GetCurrSubId(SN); + + CreateECode; + CreateESymbolTable; + TKernel(ekernel).RegisterParser(PascalParser); + + ResultId := ekernel.SymbolTable.Card + 3; +end; + +function TEval.GetResultAddress: Pointer; +var + StackFrameNumber: Integer; +begin + StackFrameNumber := 0; + if sprog.GetCallStackCount > 0 then + StackFrameNumber := sprog.GetCallStackCount - 1; + result := EKernel.SymbolTable.GetFinalAddress(EProg, StackFrameNumber, ResultId); +end; + +function TEval.GetResultTypeId: Integer; +begin + result := EKernel.SymbolTable[ResultId].TypeId; +end; + +function TEval.GetResultTypeName: String; +var + TypeId: Integer; +begin + TypeId := EKernel.SymbolTable[ResultId].TypeId; + result := EKernel.SymbolTable[TypeId].Name; +end; + +function TEval.GetResultAsString: String; +var + Address: Pointer; + TypeId: Integer; + StackFrameNumber: Integer; +begin + StackFrameNumber := 0; + if sprog.GetCallStackCount > 0 then + StackFrameNumber := sprog.GetCallStackCount - 1; + Address := EKernel.SymbolTable.GetFinalAddress(EProg, + StackFrameNumber, ResultId); + TypeId := EKernel.SymbolTable[ResultId].TypeId; + result := EKernel.SymbolTable.GetStrVal(Address, TypeId); +end; + +function TEval.GetResultAsVariant: Variant; +var + Address: Pointer; + TypeId: Integer; + StackFrameNumber: Integer; +begin + StackFrameNumber := 0; + if sprog.GetCallStackCount > 0 then + StackFrameNumber := sprog.GetCallStackCount - 1; + Address := EKernel.SymbolTable.GetFinalAddress(EProg, StackFrameNumber, ResultId); + TypeId := EKernel.SymbolTable[ResultId].TypeId; + result := EKernel.SymbolTable.GetVariantVal(Address, TypeId); +end; + +function TEval.Valid: Boolean; +begin + result := (SKernel <> nil) and (SProg <> nil); +end; + +procedure TEval.CompileExpression(const Source: String); +var + M: TModule; + temp_kernel, temp_runner: Pointer; +begin + with ekernel do + begin + ClassFactory := SProg.ProgClassFactory; + + M := AddModule('$', 'Pascal'); + AddCode('$', Source); + ParseModule(M, 0, wpEvalExpression, Self); + + if HasError then Exit; + code.RemoveEvalOp; + + if HasError then Exit; + modules.CreateLoadOrder; + if HasError then Exit; + + code.CheckTypes; + if HasError then Exit; + + SymbolTable.LinkCard := SymbolTable.CompileCard; + + SymbolTable.SetShifts(nil); + + if HasError then Exit; + code.ProcessSizeOf; + if HasError then Exit; + code.ChangeOrderOfActualParams; + + if HasError then Exit; + code.DestroyExpressionTempVars(ResultId); + + if HasError then Exit; + code.AssignShifts; + + RemoveSubs; + + if HasError then Exit; + code.Optimization; + + end; + + MapAddresses; + + temp_kernel := CurrKernel; + temp_runner := CurrProg; + CurrKernel := ekernel; + CurrProg := nil; + +// Dump_all('', ekernel, nil, nil); + + try + TPaxRunner(sprog.Owner).EmitProc(ekernel, eprog, ContextStack); + finally + CurrKernel := temp_kernel; + CurrProg := temp_runner; + end; +end; + +procedure TEval.CompileProgram(const Source: String); +var + M: TModule; +begin + with ekernel do + begin + ClassFactory := SProg.ProgClassFactory; + + M := AddModule('$', 'Pascal'); + AddCode('$', Source); + ParseModule(M, 0, wpProgram, Self); + + if HasError then Exit; + code.RemoveEvalOp; + + if HasError then Exit; + modules.CreateLoadOrder; + if HasError then Exit; + + code.CheckTypes; + if HasError then Exit; + + SymbolTable.SetShifts(nil); + + if HasError then Exit; + code.ProcessSizeOf; + if HasError then Exit; + code.ChangeOrderOfActualParams; + + if HasError then Exit; + code.InsertDynamicTypeDestructors; + + if HasError then Exit; + code.AssignShifts; + + RemoveSubs; + + if HasError then Exit; + code.Optimization; + end; + MapAddresses; + + TPaxRunner(sprog.Owner).EmitProc(ekernel, eprog, ContextStack); +end; + +procedure TEval.SaveHostState; +begin + HostState_Position := HostState.Position; + SProg.SaveState(HostState); +end; + +procedure TEval.RestoreHostState; +begin + HostState.Position := HostState_Position; + SProg.LoadState(HostState); +end; + +procedure TEval.Run; +begin + SaveHostState; + try + SProg.RemovePause; + EProg.Run; + if IsPaused then + SProg.Pause; + finally + RestoreHostState; + end; +end; + +procedure TEval.CreateESymbolTable; + +var + SSymbolTable: TSymbolTable; + SCode: TCode; + + L1, L2: TIntegerList; + +procedure SearchSubstitute(ParamId: Integer); +var + R: TSymbolRec; + I: Integer; + CR: TCodeRec; +begin + R := SSymbolTable[ParamId]; + if R.ByRef then + Exit; + if R.IsConst then + Exit; + if not (R.FinalTypeId in StringTypes) then + Exit; + for I := 1 to SCode.Card do + begin + CR := SCode[I]; + if CR.Op = OP_DECLARE_TEMP_VAR then + if CR.Res = ParamId then + begin + L1.Add(ParamId); + L2.Add(CR.Arg2); + end; + end; +end; + +function InSkope(R: TSymbolRec; SubId: Integer): Boolean; +begin + result := false; + + if SubId = 0 then + Exit; + + if R.Level = 0 then + Exit; + + repeat + + result := R.Level = SubId; + if result then + Exit; + + SubId := SSymbolTable[SubId].Level; + + if not (SSymbolTable[SubId].Kind in KindSUBS) then + Exit; + + until false; + +end; + +var + I, J, StackFrameNumber: Integer; + R: TSymbolRec; + S: Integer; +begin + ekernel.SymbolTable.Free; + ekernel.SymbolTable := TExtraSymbolTable.Create(ekernel, + skernel.SymbolTable); + ekernel.SymbolTable.Reset; + + StackFrameNumber := 0; + if sprog.GetCallStackCount > 0 then + StackFrameNumber := sprog.GetCallStackCount - 1; + + SSymbolTable := skernel.SymbolTable; + SCode := skernel.Code; + + S := SSymbolTable.GetDataSize(SSymbolTable.CompileCard); + + if SaveList = nil then + begin + SaveList := TSaveList.Create(SSymbolTable); + SaveList.Save; + end; + + L1 := TIntegerList.Create; + L2 := TIntegerList.Create; + + try + + for I := SSymbolTable.CompileCard + 1 to SSymbolTable.Card do + begin + R := SSymbolTable[I]; + + if R.Kind in kindSUBs then + begin + if R.Host then + continue; + + J := R.Value; + R.Host := true; + R.OverScript := true; + R.Address := ShiftPointer(TBaseRunner(sprog).CodePtr, J); + R.Shift := S; + Inc(S, 4); + + continue; + end; + + if R.IsGlobalVarEx then + begin + if R.Host then + continue; + + R.Address := SSymbolTable.GetFinalAddress(SProg, StackFrameNumber, I); + R.Host := true; + R.OverScript := true; + R.Shift := S; + Inc(S, 4); + + continue; + end; + + if R.OverScript then + begin + R.OverScript := false; + R.Host := false; + R.Shift := R.SavedShift; + end + else + begin + R.SavedShift := R.Shift; + end; + + if R.Param then + begin + if not InSkope(R, CurrSubId) then + continue; + + R.Address := SSymbolTable.GetFinalAddress(SProg, StackFrameNumber, I); + R.Host := true; + R.OverScript := true; + R.Shift := S; + Inc(S, 4); + + SearchSubstitute(I); + + continue; + end; + + if R.IsLocalVarEx or (R.Name = '@') then + begin + if R.Level <> CurrSubId then + continue; + + R.Address := SSymbolTable.GetFinalAddress(SProg, StackFrameNumber, I); + R.Host := true; + R.OverScript := true; + R.Shift := S; + Inc(S, 4); + + continue; + end; + + if R.Kind = kindVAR then + begin + R.Kind := kindNONE; + R.Shift := 0; + end + else if R.Kind = kindCONST then if R.OwnerId = 0 then + begin + R.Kind := kindNONE; + R.Shift := 0; + end; + end; + + finally + + for I := 0 to L1.Count - 1 do + begin + SSymbolTable[L1[I]].Address := SSymbolTable[L2[I]].Address; + end; + + L1.Free; + L2.Free; + end; +end; + +procedure TEval.CreateECode; +var + I, Op, Id, L: Integer; + R: TCodeRec; + SCode, ECode: TCode; + SR: TSymbolRec; + SSymbolTable: TSymbolTable; +begin + SCode := skernel.Code; + ECode := ekernel.Code; + SSymbolTable := skernel.SymbolTable; + + ECode.Reset; + for I := 1 to SN do + begin + R := SCode.Records[I]; + Op := R.Op; + if (Op = OP_BEGIN_MODULE) or (Op = OP_END_MODULE) or + (Op = OP_BEGIN_USING) or (Op = OP_END_USING) then + begin + ECode.Add(Op, R.Arg1, R.Arg2, R.Res, 0, + R.Upcase, R.Language, 0, + R.LinePos); + end + else if (Op = OP_BEGIN_WITH) or (Op = OP_END_WITH) then + begin + Id := R.Arg1; + SR := SCode.GetSymbolRec(Id); + L := SR.Level; + if SSymbolTable[L].Kind in kindSUBS then + if SSymbolTable.GetSelfId(L) = Id then + ECode.Add(Op, R.Arg1, R.Arg2, R.Res, 0, + R.Upcase, R.Language, 0, + R.LinePos); + end + else if Op = OP_BEGIN_SUB then + begin + ECode.Add(Op, R.Arg1, R.Arg2, R.Res, 0, + R.Upcase, R.Language, 0, + R.LinePos); + ContextStack.Push(R.Arg1); + end + else if Op = OP_END_SUB then + begin + ContextStack.Pop; + ECode.Add(Op, R.Arg1, R.Arg2, R.Res, 0, + R.Upcase, R.Language, 0, + R.LinePos); + end; + end; + + ECode_InitCard := ECode.Card; +end; + +procedure TEval.RemoveSubs; +var + I: Integer; + R: TCodeRec; +begin + for I := 1 to ECode_InitCard do + begin + R := ekernel.Code[I]; + if R.Op = OP_BEGIN_SUB then + R.Op := OP_NOP + else if R.Op = OP_END_SUB then + R.Op := OP_NOP + else if R.Op = OP_BEGIN_MODULE then + R.Op := OP_NOP + else if R.Op = OP_END_MODULE then + R.Op := OP_NOP + else if R.Op = OP_BEGIN_USING then + R.Op := OP_NOP + else if R.Op = OP_END_USING then + R.Op := OP_NOP + else if R.Op = OP_BEGIN_WITH then + R.Op := OP_NOP + else if R.Op = OP_END_WITH then + R.Op := OP_NOP; + end; +end; + +function TEval.HasErrors: Boolean; +begin + result := ekernel.Errors.Count > 0; +end; + +function TEval.GetErrorCount: Integer; +begin + result := ekernel.Errors.Count; +end; + +function TEval.GetErrorMessage(I: Integer): String; +begin + if (I >= 0) and (I < GetErrorCount) then + result := ekernel.Errors[I].Message + else + result := ''; +end; + +procedure TEval.ClearResult; +var + T, S: Integer; + Address: Pointer; + ArrayTypeId, ElTypeId, ElSize: Integer; +begin + if ekernel = nil then + Exit; + if HasErrors then + Exit; + + if not ((ResultId > 0) and (ResultId <= ekernel.SymbolTable.Card)) then + Exit; + + if ekernel.SymbolTable[ResultId].TypeId = 0 then + Exit; + + T := ekernel.SymbolTable[ResultId].FinalTypeId; + S := ekernel.SymbolTable[ResultId].Shift; + Address := eprog.GetAddress(S); + case T of +{$IFNDEF PAXARM} + typeANSISTRING: AnsiString(Address^) := ''; + typeWIDESTRING: WideString(Address^) := ''; +{$ENDIF} + typeUNICSTRING: UnicString(Address^) := ''; + typeVARIANT, typeOLEVARIANT: VarClear(Variant(Address^)); + typeINTERFACE: IUnknown(Address^) := nil; + typeDYNARRAY: + begin + ArrayTypeId := ekernel.SymbolTable[ResultId].TerminalTypeId; + ElTypeId := ekernel.SymbolTable[ArrayTypeId].PatternId; + ElSize := ekernel.SymbolTable[ElTypeId].Size; + _DynarrayClr(Address, T, ArrayTypeId, ElSize, 0, 0, 0); + end; + end; +end; + +procedure TEval.MapAddresses; +var + SymbolTable: TSymbolTable; + Code: TCode; + I, J, Level, K1, K2, Id: Integer; + R: TSymbolRec; + S: String; + b1, b2: Boolean; + L: TIntegerList; + CodeRec: TCodeRec; +begin + b1 := Assigned(SProg.OnMapTableVarAddress); + b2 := Assigned(SProg.OnMapTableProcAddress); + + if (not b1) and (not b2) then + Exit; + + SymbolTable := ekernel.SymbolTable; + Code := ekernel.Code; + K1 := StdCard + 1; + K2 := SymbolTable.GlobalST.Card; + + L := TIntegerList.Create; + try + for I := 1 to Code.Card do + begin + CodeRec := Code[I]; + if CodeRec.OP = OP_SET_CODE_LINE then + continue; + if CodeRec.OP = OP_SEPARATOR then + continue; + + Id := CodeRec.Arg1; + if (Id >= K1) and (Id <= K2) then + if L.IndexOf(Id) = -1 then + L.Add(Id); + Id := CodeRec.Arg2; + if (Id >= K1) and (Id <= K2) then + if L.IndexOf(Id) = -1 then + L.Add(Id); + Id := CodeRec.Res; + if (Id >= K1) and (Id <= K2) then + if L.IndexOf(Id) = -1 then + L.Add(Id); + end; + + for J := 0 to L.Count - 1 do + begin + I := L[J]; + + R := SymbolTable[I]; + if R.Address = nil then + if R.PatternId = 0 then + if R.OwnerId = 0 then + if (not R.Param) then + case R.Kind of + KindVAR: + begin + if not b1 then + continue; + + S := R.Name; + if S <> '' then + if S <> '@' then + SProg.OnMapTableVarAddress(SProg.Owner, + R.FullName, true, R.Address); + end; + KindSUB: + begin + if not b2 then + continue; + + Level := R.Level; + if Level > 0 then + if SymbolTable[Level].Kind = KindTYPE then + if SymbolTable[Level].FinalTypeId = typeINTERFACE then + continue; + + S := R.Name; + if S <> '' then + SProg.OnMapTableProcAddress(SProg.Owner, + R.FullName, R.OverCount, true, R.Address); + end; + end; + end; + finally + L.Free; + end; +end; + +function TEval.GetPAX64: Boolean; +begin + result := ekernel.PAX64; +end; + +end. diff --git a/Sources/PAXCOMP_EVENT.pas b/Sources/PAXCOMP_EVENT.pas new file mode 100644 index 0000000..ccbb34d --- /dev/null +++ b/Sources/PAXCOMP_EVENT.pas @@ -0,0 +1,280 @@ +//////////////////////////////////////////////////////////////////////////// +// PaxCompiler +// Site: http://www.paxcompiler.com +// Author: Alexander Baranovsky (paxscript@gmail.com) +// ======================================================================== +// Copyright (c) Alexander Baranovsky, 2006-2014. All rights reserved. +// Code Version: 4.2 +// ======================================================================== +// Unit: PAXCOMP_EVENT.pas +// ======================================================================== +//////////////////////////////////////////////////////////////////////////// + +{$I PaxCompiler.def} +{$O-} +unit PAXCOMP_EVENT; +interface +uses {$I uses.def} + SysUtils, + Classes, + PAXCOMP_TYPES, + PAXCOMP_SYS; + +type + TEventHandlerRec = class + public + _ESI: Integer; // 4 + _EDI: Integer; // 8 + Code: Pointer; // 12 + Data: TObject; // 16 + Prog: Pointer; // 20 + CallConv: Integer; // 24 + RetSize: Integer; // 28 + procedure Invoke; + procedure InvokeDirect; + end; + + TEventHandlerList = class(TTypedList) + private + function GetRecord(I: Integer): TEventHandlerRec; + public + function Lookup(Code: Pointer; Data: TObject): TEventHandlerRec; + function Add(Prog, Code, Data: Pointer; CallConv, RetSize: Integer): TEventHandlerRec; + property Records[I: Integer]: TEventHandlerRec read GetRecord; default; + end; + +implementation + +uses + PAXCOMP_CONSTANTS, + PAXCOMP_PROG, + PAXCOMP_STDLIB, + PAXCOMP_PAUSE, + PAXCOMP_INVOKE; + +// -- TEventHandlerRec --------------------------------------------------------- + +{$IFDEF PAX64} +procedure TEventHandlerRec.InvokeDirect; +begin + RaiseNotImpl; +end; +{$ELSE} +procedure TEventHandlerRec.InvokeDirect; assembler; +asm + sub esp, 4 // reserve place for Code + + push ecx + mov ecx, [eax + 12] +// add ecx, 14 + mov [esp + 4], ecx // Code + pop ecx + + mov esi, [eax + 4] // esi + mov edi, [eax + 8] // edi + + mov eax, [eax + 16] // Data + + add esp, 4 + mov ebx, [esp - 4] + jmp ebx +end; +{$ENDIF} + +{$IFDEF PAX64} +procedure SaveRegisters(var _RAX, _RCX, _RDX, _R8, _R9: IntPax); assembler; +asm + mov _RAX, rax + mov _RCX, rcx + mov _RDX, rdx + mov _R8, r8 + mov _R9, r9 +end; +{$ENDIF} + +procedure TEventHandlerRec.Invoke; +var + P: TProgram; + EPoint, OldEPoint: TInvoke; +{$IFDEF PAX64} + _RAX, _RCX, _RDX, _R8, _R9: IntPax; +{$ELSE} + _EAX, _ECX, _EDX, _EBP: Integer; +{$ENDIF} + OldESP0: Integer; + OldIsEvent: Boolean; + S: TMemoryStream; +begin +{$IFDEF PAX64} + SaveRegisters(_RAX, _RCX, _RDX, _R8, _R9); +{$ELSE} + asm + mov _EBP, ebp + mov _EAX, eax + mov _ECX, ecx + mov _EDX, edx + end; +{$ENDIF} + + P := Prog; + P := P.RootProg; + + if not P.IsPauseUpdated then + begin + EPoint := TInvoke.CreateInternal; +{$IFDEF PAX64} + EPoint._EAX := _RAX; + EPoint._ECX := _RCX; + EPoint._EDX := _RDX; + EPoint._R8 := _R8; + EPoint._R9 := _R9; +{$ELSE} + EPoint._EAX := _EAX; + EPoint._ECX := _ECX; + EPoint._EDX := _EDX; +{$ENDIF} + EPoint.CallConv := CallConv; + EPoint.StackSize := RetSize; + EPoint.StackFrame := Pointer(_EBP + 4 + RetSize); + + OldEPoint := P.EPoint; + OldESP0 := P.RootESP0; + OldIsEvent := P.RootIsEvent; + + S := TMemoryStream.Create; + try + P.RootTryStack.SaveToStream(S); + P.RootTryStack.Clear; + + P.RootIsEvent := true; + + EPoint.Address := Code; + EPoint.SetThis(Data); + + if CallConv = ccREGISTER then + EPoint._EAX := Integer(Data); + + P.EPoint := EPoint; + P.RunEx; + + finally + S.Position := 0; + P.RootTryStack.LoadFromStream(S); + + P.RootESP0 := OldESP0; + P.RootIsEvent := OldIsEvent; + + P.EPoint := OldEPoint; + FreeAndNil(EPoint); + FreeAndNil(S); + end; + + // emulate ret RetSize + + if P.IsHalted then + raise THaltException.Create(P.ExitCode); + + if P.HasError then + if P.fCurrException <> nil then + begin + if P.PauseRec <> nil then + begin + P.PauseRec.Clear; + end; + raise P.fCurrException; + end; + + + end; + +{$IFDEF PAX64} + Exit; +{$ELSE} + if RetSize = 0 then + Exit; + + _ecx := RetSize; +{$ENDIF} +{ + asm + mov ecx, _ecx + + mov esp, ebp + pop ebp + mov ebx, [esp] + + @@loop: + pop edx + sub ecx, 4 + jnz @@loop + pop edx + jmp ebx + end; +} +{$IFDEF PAX64} + Exit; +{$ELSE} + + asm + mov ecx, _ecx + + mov esp, ebp + pop ebp + + fild dword ptr [esp] + + @@loop: + pop edx + sub ecx, 4 + jnz @@loop + + fistp dword ptr [esp] + + pop edx + jmp edx + end; +{$ENDIF} +end; + +// -- TEventHandlerList -------------------------------------------------------- + +function TEventHandlerList.GetRecord(I: Integer): TEventHandlerRec; +begin + result := TEventHandlerRec(L[I]); +end; + +function TEventHandlerList.Add(Prog, Code, Data: Pointer; CallConv, RetSize: Integer): TEventHandlerRec; +begin + result := Lookup(Code, Data); + if result = nil then + begin + result := TEventHandlerRec.Create; + result.Code := Code; + result.Data := Data; + result._ESI := Integer(TProgram(Prog).DataPtr); + result._EDI := Integer(TProgram(Prog).CodePtr); + result.Prog := Prog; + result.CallConv := CallConv; + result.RetSize := RetSize; + L.Add(result); + end; +end; + +function TEventHandlerList.Lookup(Code: Pointer; Data: TObject): TEventHandlerRec; +var + R: TEventHandlerRec; + I: Integer; +begin + for I:=0 to Count - 1 do + begin + R := Records[I]; + if (R.Code = Code) and (R.Data = Data) then + begin + result := R; + Exit; + end; + end; + result := nil; +end; + +end. diff --git a/Sources/PAXCOMP_EXTRASYMBOL_TABLE.pas b/Sources/PAXCOMP_EXTRASYMBOL_TABLE.pas new file mode 100644 index 0000000..1e8c402 --- /dev/null +++ b/Sources/PAXCOMP_EXTRASYMBOL_TABLE.pas @@ -0,0 +1,101 @@ +//////////////////////////////////////////////////////////////////////////// +// PaxCompiler +// Site: http://www.paxcompiler.com +// Author: Alexander Baranovsky (paxscript@gmail.com) +// ======================================================================== +// Copyright (c) Alexander Baranovsky, 2006-2014. All rights reserved. +// Code Version: 4.2 +// ======================================================================== +// Unit: PAXCOMP_EXTRASYMBOL_TABLE.pas +// ======================================================================== +//////////////////////////////////////////////////////////////////////////// + +{$I PaxCompiler.def} +{$O-} +unit PAXCOMP_EXTRASYMBOL_TABLE; +interface +uses {$I uses.def} + TypInfo, + SysUtils, + Classes, + PAXCOMP_CONSTANTS, + PAXCOMP_SYS, + PAXCOMP_BASESYMBOL_TABLE, + PAXCOMP_SYMBOL_TABLE, + PAXCOMP_SYMBOL_REC, + PAXCOMP_MAP, + PAXCOMP_STDLIB; +type + TExtraSymbolTable = class(TSymbolTable) + private + LocalSymbolTable: TSymbolTable; + protected + function GetRecord(I: Integer): TSymbolRec; override; + public + constructor Create(kernel: Pointer; ALocalSymbolTable: TSymbolTable); + procedure Reset; override; + property Records[I: Integer]: TSymbolRec read GetRecord; default; + end; + +implementation + +constructor TExtraSymbolTable.Create(kernel: Pointer; ALocalSymbolTable: TSymbolTable); +begin + inherited Create(kernel); + LocalSymbolTable := ALocalSymbolTable; + IsExtraTable := true; +end; + +procedure TExtraSymbolTable.Reset; +var + I: Integer; +begin + for I:=A.Count - 1 downto 0 do +{$IFDEF ARC} + A[I] := nil; +{$ELSE} + TSymbolRec(A[I]).Free; +{$ENDIF} + + A.Clear; + + Card := LocalSymbolTable.Card; + + ResultId := LocalSymbolTable.ResultId; + + TrueId := LocalSymbolTable.TrueId; + FalseId := LocalSymbolTable.FalseId; + NilId := LocalSymbolTable.NilId; + EventNilId := LocalSymbolTable.EventNilId; + CurrExceptionObjectId := LocalSymbolTable.CurrExceptionObjectId; + EmptySetId := LocalSymbolTable.EmptySetId; + EmptyStringId := LocalSymbolTable.EmptyStringId; + LastShiftValue := LocalSymbolTable.LastShiftValue; + LastClassIndex := LocalSymbolTable.LastClassIndex; + +// GlobalST_LastShiftValue := GlobalST.LastShiftValue; + + FreeAndNil(HashArray); + HashArray := LocalSymbolTable.HashArray.Clone; + + FreeAndNil(GuidList); + GuidList := LocalSymbolTable.GuidList.Clone; + + FreeAndNil(SomeTypeList); + SomeTypeList := LocalSymbolTable.SomeTypeList.Clone; + +// ExternList.Free; +// ExternList := GlobalST.ExternList.Clone; + + // CompileCard := Card; +end; + +function TExtraSymbolTable.GetRecord(I: Integer): TSymbolRec; +begin + if I <= LocalSymbolTable.Card then + result := LocalSymbolTable[I] + else + result := TSymbolRec(A[I - LocalSymbolTable.Card - 1]); +end; + +end. diff --git a/Sources/PAXCOMP_FORBID.pas b/Sources/PAXCOMP_FORBID.pas new file mode 100644 index 0000000..10b7c46 --- /dev/null +++ b/Sources/PAXCOMP_FORBID.pas @@ -0,0 +1,186 @@ +//////////////////////////////////////////////////////////////////////////// +// PaxCompiler +// Site: http://www.paxcompiler.com +// Author: Alexander Baranovsky (paxscript@gmail.com) +// ======================================================================== +// Copyright (c) Alexander Baranovsky, 2006-2014. All rights reserved. +// Code Version: 4.2 +// ======================================================================== +// Unit: PAXCOMP_FORBID.pas +// ======================================================================== +//////////////////////////////////////////////////////////////////////////// +{$I PaxCompiler.def} +unit PAXCOMP_FORBID; +interface +uses {$I uses.def} + PAXCOMP_SYS, + PAXCOMP_TYPES, + SysUtils, + Classes; + +type + TForbiddenPropRec = class + private + C: TClass; + L: TStringList; + All: Boolean; + public + constructor Create; + destructor Destroy; override; + function IndexOf(const PropName: String): Integer; + end; + + TForbiddenPropList = class(TTypedList) + private + function GetRecord(I: Integer): TForbiddenPropRec; + public + function FindRecord(C: TClass): TForbiddenPropRec; + procedure Add(C: TClass; const PropName: String); + procedure AddAll(C: TClass); + procedure Delete(C: TClass; const PropName: String); + procedure DeleteAll(C: TClass); + function IsForbidden(C: TClass; const PropName: String): Boolean; + function IsForbiddenAll(C: TClass): Boolean; + property Records[I: Integer]: TForbiddenPropRec read GetRecord; default; + end; + +var + ForbiddenPropList: TForbiddenPropList = nil; + +implementation + +constructor TForbiddenPropRec.Create; +begin + inherited; + L := TStringList.Create; + All := false; +end; + +destructor TForbiddenPropRec.Destroy; +begin + FreeAndNil(L); + inherited; +end; + +function TForbiddenPropRec.IndexOf(const PropName: String): Integer; +var + I: Integer; +begin + result := -1; + for I := 0 to L.Count - 1 do + if StrEql(L[I], PropName) then + begin + result := I; + Exit; + end; +end; + +function TForbiddenPropList.GetRecord(I: Integer): TForbiddenPropRec; +begin + result := TForbiddenPropRec(L[I]); +end; + +function TForbiddenPropList.FindRecord(C: TClass): TForbiddenPropRec; +var + I: Integer; +begin + result := nil; + for I := 0 to L.Count - 1 do + if Records[I].C = C then + begin + result := Records[I]; + Exit; + end; +end; + +procedure TForbiddenPropList.Add(C: TClass; const PropName: String); +var + R: TForbiddenPropRec; +begin + R := FindRecord(C); + if R = nil then + begin + R := TForbiddenPropRec.Create; + R.C := C; + L.Add(R); + end; + R.L.Add(PropName); +end; + +procedure TForbiddenPropList.AddAll(C: TClass); +var + R: TForbiddenPropRec; +begin + R := FindRecord(C); + if R = nil then + begin + R := TForbiddenPropRec.Create; + R.C := C; + L.Add(R); + end; + R.All := true; +end; + +procedure TForbiddenPropList.Delete(C: TClass; const PropName: String); +var + R: TForbiddenPropRec; + I: Integer; +begin + R := FindRecord(C); + if R = nil then + Exit; + I := R.IndexOf(PropName); + if I >= 0 then + R.L.Delete(I); +end; + +procedure TForbiddenPropList.DeleteAll(C: TClass); +var + R: TForbiddenPropRec; +begin + R := FindRecord(C); + if R = nil then + Exit; + R.L.Clear; +end; + +function TForbiddenPropList.IsForbidden(C: TClass; const PropName: String): Boolean; +var + R: TForbiddenPropRec; +begin + R := FindRecord(C); + if R = nil then + begin + result := false; + Exit; + end; + + if R.All then + begin + result := true; + Exit; + end; + + result := R.IndexOf(PropName) >= 0; +end; + +function TForbiddenPropList.IsForbiddenAll(C: TClass): Boolean; +var + R: TForbiddenPropRec; +begin + R := FindRecord(C); + if R = nil then + begin + result := false; + Exit; + end; + result := R.All; +end; + +initialization +finalization + + if Assigned(ForbiddenPropList) then + ForbiddenPropList.Free; +end. + diff --git a/Sources/PAXCOMP_FRAMEWORK.pas b/Sources/PAXCOMP_FRAMEWORK.pas new file mode 100644 index 0000000..cf9108d --- /dev/null +++ b/Sources/PAXCOMP_FRAMEWORK.pas @@ -0,0 +1,4215 @@ +//////////////////////////////////////////////////////////////////////////// +// PaxCompiler +// Site: http://www.paxcompiler.com +// Author: Alexander Baranovsky (paxscript@gmail.com) +// ======================================================================== +// Copyright (c) Alexander Baranovsky, 2006-2014. All rights reserved. +// Code Version: 4.2 +// ======================================================================== +// Unit: PAXCOMP_FRAMEWORK.pas +// ======================================================================== +//////////////////////////////////////////////////////////////////////////// + +{$I PaxCompiler.def} +{$O-} + +unit PAXCOMP_FRAMEWORK; +interface +uses {$I uses.def} + SysUtils, + Classes, + Math, +{$IFNDEF FPC} + Masks, +{$ENDIF} +{$IFNDEF PAXARM} + PAXCOMP_MASKS, // (cross compiler/platform!) +{$ENDIF} +{$IFDEF UNIC} + DateUtils, + StrUtils, +{$IFNDEF PAXARM} + AnsiStrings, +{$ENDIF} + EncdDecd, +{$ENDIF} + PAXCOMP_SYS, + PAXCOMP_CONSTANTS, + PAXCOMP_BASESYMBOL_TABLE, + PAXCOMP_GC; + +type +{$IFNDEF PAXARM} + TAnsiStringDynArray = array of AnsiString; +{$ENDIF} + TStringDynArray = array of UnicString; + TVarType = Word; + + TFW_Object = class(TGC_Object) + private + procedure AddToGC; + public + prog: Pointer; + function GetGC: TGC; override; + function _ToString: String; virtual; abstract; + end; + + TFW_Boolean = class(TFW_Object) + private + val: Boolean; + public + function _ToString: String; override; + function _ToInt32: integer; + function _ToISOString: String; +{$IFNDEF PAXARM} + function _ToISOAnsiString: AnsiString; + function _FromISOAnsiString(const Value: AnsiString): Boolean; +{$ENDIF} + function _FromISOString(const Value: String): Boolean; + function _Equals(const Value: Boolean): boolean; + end; + + TFW_ByteBool = class(TFW_Object) + private + val: ByteBool; + public + function _ToString: String; override; + function _ToInt32: integer; + function _Equals(const Value: ByteBool): boolean; + end; + + TFW_WordBool = class(TFW_Object) + private + val: WordBool; + public + function _ToString: String; override; + function _ToInt32: integer; + function _Equals(const Value: WordBool): boolean; + end; + + TFW_LongBool = class(TFW_Object) + private + val: LongBool; + public + function _ToString: String; override; + function _ToInt32: integer; + function _Equals(const Value: LongBool): boolean; + end; + + TFW_Byte = class(TFW_Object) + private + val: Byte; + public + function _ToString: String; override; + function _Equals(const Value: Byte): boolean; + end; + + TFW_SmallInt = class(TFW_Object) + private + val: SmallInt; + public + function _ToString: String; override; + function _Equals(const Value: SmallInt): boolean; + function _MinValue: SmallInt; + function _MaxValue: SmallInt; + end; + + TFW_ShortInt = class(TFW_Object) + private + val: ShortInt; + public + function _ToString: String; override; + function _Equals(const Value: ShortInt): boolean; + function _MinValue: ShortInt; + function _MaxValue: ShortInt; + end; + + TFW_Word = class(TFW_Object) + private + val: Word; + public + function _ToString: String; override; + function _Equals(const Value: Word): boolean; + function _MinValue: Word; + function _MaxValue: Word; + end; + + TFW_Cardinal = class(TFW_Object) + private + val: Cardinal; + public + function _ToString: String; override; + function _Equals(const Value: Cardinal): boolean; + function _MinValue: Cardinal; + function _MaxValue: Cardinal; + end; + + TFW_Double = class(TFW_Object) + private + val: Double; + public + function _ToString: String; override; + function _ToStringFormat(const Format: String): String; +{$IFDEF UNIC} + function _ToISOString: String; +{$IFNDEF PAXARM} + function _ToISOAnsiString: AnsiString; + function _FromISOAnsiString(const Value: AnsiString): double; +{$ENDIF} + function _FromISOString(const Value: String): double; + function _RoundTo(const Digit: integer): double; +{$ENDIF} + function _Equals(const Value: Double): boolean; + function _Round: Int64; + function _Power(const Exponent: Extended): double; + function _Trunc: Int64; + function _Floor: Integer; + function _Ceil: Integer; + function _Min(const Value: Double): Double; + function _Max(const Value: Double): Double; + end; + + TFW_DateTime = class(TFW_Object) + private + val: TDateTime; + public + function _ToString: String; override; + function _ToStringFormat(const Format: String): String; + function _ToStringISO: String; +{$IFNDEF PAXARM} + function _FromISOAnsiString(const Value: AnsiString): TDateTime; +{$IFDEF UNIC} + function _ToAnsiStringISO: AnsiString; +{$ENDIF} +{$ENDIF} + function _FromISOString(const Value: String): TDateTime; + function _Equals(const Value: TDateTime): boolean; + function _ToInt32: Integer; + + function _IsDate: boolean; + function _IsDateTime: boolean; + function _IsTime: boolean; + + function _Date: TDateTime; + function _Time: TDateTime; + function _Now: TDateTime; + + function _IsInLeapYear: boolean; + function _DateOf: TDateTime; + function _TimeOf: TDateTime; + function _YearOf: Word; + function _MonthOf: Word; + function _DayOf: Word; + function _HourOf: Word; + function _MinuteOf: Word; + function _SecondOf: Word; + function _MilliSecondOf: Word; + function _WeeksInYear: Word; + function _DaysInYear: Word; + function _Today: TDateTime; + function _Yesterday: TDateTime; + function _Tomorrow: TDateTime; + function _YearSpan(const Value: TDateTime): Double; + function _MonthSpan(const Value: TDateTime): Double; + function _WeekSpan(const Value: TDateTime): Double; + function _DaySpan(const Value: TDateTime): Double; + function _HourSpan(const Value: TDateTime): Double; + function _MinuteSpan(const Value: TDateTime): Double; + function _SecondSpan(const Value: TDateTime): Double; + function _MilliSecondSpan(const Value: TDateTime): Double; + function _AddYears(const ANumberOfYears: Integer = 1): TDateTime; + function _AddWeeks(const ANumberOfWeeks: Integer = 1): TDateTime; + function _AddDays(const ANumberOfDays: Integer = 1): TDateTime; + function _AddHours(const ANumberOfHours: Int64 = 1): TDateTime; + function _AddMinutes(const ANumberOfMinutes: Int64 = 1): TDateTime; + function _AddSeconds(const ANumberOfSeconds: Int64 = 1): TDateTime; + function _AddMilliSeconds(const ANumberOfMilliSeconds: Int64 = 1): TDateTime; +{$IFDEF UNIC} + function _EncodeDateTime(const AYear, AMonth, ADay, AHour, AMinute, ASecond, AMilliSecond: Word): TDateTime; +{$ENDIF} + function _EncodeDate(const AYear, AMonth, ADay: Word): TDateTime; + function _EncodeTime(const AHour, AMinute, ASecond, AMilliSecond: Word): TDateTime; + function _Min(const Value: TDateTime): TDateTime; + function _Max(const Value: TDateTime): TDateTime; + function _MinValue: TDateTime; + function _MaxValue: TDateTime; + end; + + TFW_Single = class(TFW_Object) + private + val: Single; + public + function _ToString: String; override; + function _Equals(const Value: Single): boolean; + function _Min(const Value: Single): Single; + function _Max(const Value: Single): Single; + end; + + TFW_Extended = class(TFW_Object) + private + val: Extended; + public + function _ToString: String; override; + function _ToStringFormat(const Format: String): String; +{$IFDEF UNIC} + function _ToISOString: String; +{$IFNDEF PAXARM} + function _ToISOAnsiString: AnsiString; + function _FromISOAnsiString(const Value: AnsiString): Extended; +{$ENDIF} + function _RoundTo(const Digit: integer): Extended; + function _FromISOString(const Value: String): Extended; +{$ENDIF} + function _Equals(const Value: Extended): boolean; + function _Round: Int64; + function _Power(const Exponent: Extended): Extended; + function _Trunc: Int64; + function _Floor: Integer; + function _Ceil: Integer; + function _Min(const Value: Extended): Extended; + function _Max(const Value: Extended): Extended; + end; + + TFW_Currency = class(TFW_Object) + private + val: Currency; + public + function _ToString: String; override; + function _ToStringFormat(const Format: String): String; +{$IFDEF UNIC} + function _ToISOString: String; + function _FromISOString(const Value: String): Currency; +{$IFNDEF PAXARM} + function _ToISOAnsiString: AnsiString; + function _FromISOAnsiString(const Value: AnsiString): Currency; +{$ENDIF} + function _RoundTo(const Digit: integer): Currency; +{$ENDIF} + function _Equals(const Value: Currency): boolean; + function _Round: Int64; + function _Power(const Exponent: Extended): Currency; + function _Trunc: Int64; + function _Floor: Integer; + function _Ceil: Integer; + function _Min(const Value: Currency): Currency; + function _Max(const Value: Currency): Currency; + end; + +{$IFNDEF PAXARM} + TFW_AnsiChar = class(TFW_Object) + private + val: AnsiChar; + public + function _ToString: String; override; + function _Equals(const Value: AnsiChar): boolean; + end; +{$ENDIF} + + TFW_WideChar = class(TFW_Object) + private + val: WideChar; + public + function _ToString: String; override; + function _Equals(const Value: WideChar): boolean; + end; + + TFW_Integer = class(TFW_Object) + private + val: Integer; + public + function _ToString: String; override; + function _ToDate: TDateTime; + function _ToHex(Digits: Integer = 8): String; + function _FromHex(const Value: String): Integer; +{$IFNDEF PAXARM} + function _FromHexAnsi(const Value: AnsiString): Integer; +{$ENDIF} + function _Equals(const Value: Integer): boolean; + function _Min(const Value: Integer): Integer; + function _Max(const Value: Integer): Integer; + function _MinValue: Integer; + function _MaxValue: Integer; + end; + + TFW_Int64 = class(TFW_Object) //-- NOT WORKING + private + val: Int64; + public + function _ToString: String; override; + function _ToDate: TDateTime; + function _ToHex(Digits: Integer = 8): String; + function _FromHex(const Value: String): Int64; +{$IFNDEF PAXARM} + function _FromHexAnsi(const Value: AnsiString): Int64; +{$ENDIF} + function _Equals(const Value: Int64): boolean; + function _Min(const Value: Int64): Int64; + function _Max(const Value: Int64): Int64; + function _MinValue: Int64; + function _MaxValue: Int64; + end; + + TFW_Variant = class(TFW_Object) //-- NOT WORKING + private + val: Variant; + public + function _ToString: String; override; + function _ToDate: TDateTime; + function _ToDateTime: TDateTime; + function _ToTime: TDateTime; + function _Equals(const Value: Variant): boolean; + function _IsType: TVarType; + function _IsNull: boolean; + function _IsEmpty: boolean; +{$IFDEF VARIANTS} + function _IsEmptyParam: boolean; + function _IsError: boolean; + function _IsArray: boolean; + function _IsFilled: boolean; +{$ENDIF} + function _Null: Variant; + function _Unassigned: Variant; + function _Clear: Variant; + function _DimCount: Integer; + function _LowBound(const Dim: integer): integer; + function _HighBound(const Dim: integer): integer; + end; +{$IFNDEF PAXARM} + TFW_AnsiString = class(TFW_Object) + private + val: AnsiString; + public + function _ToString: String; override; + function _Replace(const OldPattern: AnsiString; const NewPattern: AnsiString): AnsiString; + function _Equals(const Value: AnsiString): boolean; + function _Length: integer; +{$IFDEF UNIC} + function _ToDate: TDateTime; + function _ToTime: TDateTime; + function _ToDateTime: TDateTime; + function _ToCurrency: Currency; + function _ToExtended: Extended; + function _ToDouble: Double; + function _ToCardinal: Cardinal; + function _ToShortInt: ShortInt; + function _ToSmallInt: SmallInt; + function _ToSingle: Single; + function _ToWord: Word; + function _ToInt32: Integer; + function _ToInt64: Int64; + function _ToBoolean: Boolean; + function _ToByteBool: ByteBool; + function _ToLongBool: LongBool; + function _ToWordBool: WordBool; + function _ToUTF8: UTF8String; + function _FromUTF8(const Value: UTF8String): AnsiString; + function _ToUnicode: UnicodeString; + function _FromUnicode(const Value: UnicodeString): AnsiString; + + function _ToBase64: AnsiString; + function _FromBase64(const Value: AnsiString): AnsiString; + + function _ISOToBoolean: Boolean; + function _ISOToDate: TDateTime; + function _ISOToTime: TDateTime; + function _ISOToDateTime: TDateTime; + function _ISOToCurrency: Currency; + function _ISOToExtended: Extended; + function _ISOToDouble: Double; + + function _Copy(Index: integer; Count: integer): AnsiString; + function _Delete(Index: integer; Count: integer): AnsiString; + function _Trim: AnsiString; + function _TrimLeft: AnsiString; + function _TrimRight: AnsiString; + function _Contains(const Value: AnsiString): boolean; + function _Pos(const Value: AnsiString): integer; + function _IndexOf(const Value: AnsiString; const StartIndex: integer = 1): integer; + function _Quoted(const Quote: AnsiChar = '"'): AnsiString; + function _Dequoted(const Quote: AnsiChar = '"'): AnsiString; + function _SplitEx(const Seperator: AnsiChar; const Quotes: Boolean; const Quote: AnsiChar = '"'; const TrimText: Boolean = false): TAnsiStringDynArray; + function _ToUpper: AnsiString; + function _ToLower: AnsiString; + function _Split(const Seperator: AnsiString): TAnsiStringDynArray; + function _Join(const Value: TAnsiStringDynArray; const Seperator: AnsiString): AnsiString; + function _Insert(const Value: AnsiString; Index: integer): AnsiString; + function _IsNumeric: boolean; + function _IsAlpha: boolean; + function _IsAlphaNumeric: boolean; + function _Match(const Mask: String): boolean; + function _EndsWith(const Value: AnsiString): boolean; + function _StartsWith(const Value: AnsiString): boolean; + function _Reverse: AnsiString; + function _Left(const Length: Integer): AnsiString; + function _Right(const Length: Integer): AnsiString; + function _AppendA(const Value: AnsiString): AnsiString; + function _AppendW(const Value: String): AnsiString; + function _AppendLineA(const Value: AnsiString): AnsiString; + function _AppendLineW(const Value: String): AnsiString; + function _Lastchar: AnsiChar; + function _LastDelimiter(const Delimiters: AnsiString = ';'): Integer; + function _FindDelimiter(const Delimiters: AnsiString = ';'; const StartIdx: integer = 1): Integer; + function _StringOfChar(const Ch: AnsiChar; const Count: integer): AnsiString; +{$ENDIF} + end; +{$ENDIF} // PAXARM + + TFW_UnicString = class(TFW_Object) + private + val: UnicString; + public + constructor Create; + function _ToString: String; override; + function _Replace(const OldPattern: String; const NewPattern: String): String; + function _Equals(const Value: String): boolean; + function _Length: integer; +{$IFDEF UNIC} + function _ToDate: TDateTime; + function _ToTime: TDateTime; + function _ToDateTime: TDateTime; + function _ToCurrency: Currency; + function _ToExtended: Extended; + function _ToDouble: Double; + function _ToCardinal: Cardinal; + function _ToShortInt: ShortInt; + function _ToSmallInt: SmallInt; + function _ToSingle: Single; + function _ToWord: Word; + function _ToInt32: Integer; + function _ToInt64: Int64; + function _ToBoolean: Boolean; + function _ToByteBool: ByteBool; + function _ToLongBool: LongBool; + function _ToWordBool: WordBool; +{$IFNDEF PAXARM} + function _ToUTF8: UTF8String; + function _FromUTF8(const Value: UTF8String): String; + function _ToAnsi: AnsiString; + function _FromAnsi(const Value: AnsiString): String; +{$ENDIF} + function _ToBase64: String; + function _FromBase64(const Value: String): String; + + function _ISOToBoolean: Boolean; + function _ISOToDate: TDateTime; + function _ISOToTime: TDateTime; + function _ISOToDateTime: TDateTime; + function _ISOToCurrency: Currency; + function _ISOToExtended: Extended; + function _ISOToDouble: Double; + + function _Copy(Index: integer; Count: integer): String; + function _Delete(Index: integer; Count: integer): String; + function _Trim: String; + function _TrimLeft: String; + function _TrimRight: String; + function _Contains(const Value: String): boolean; + function _Pos(const Value: String): integer; + function _IndexOf(const Value: String; const StartIndex: integer = 1): integer; + function _Quoted(const Quote: WideChar = '"'): String; + function _Dequoted(const Quote: WideChar = '"'): String; + function _ToUpper: String; + function _ToLower: String; + function _Split(const Seperator: String): TStringDynArray; + function _SplitEx(const Seperator: WideChar; const Quotes: Boolean; const Quote: WideChar = '"'; const TrimText: Boolean = false): TStringDynArray; + function _Join(const Value: TStringDynArray; const Seperator: String): String; + function _Insert(const Value: String; Index: integer): String; + function _IsNumeric: boolean; + function _IsAlpha: boolean; + function _IsAlphaNumeric: boolean; + function _Match(const Mask: String): boolean; + function _EndsWith(const Value: String): boolean; + function _StartsWith(const Value: String): boolean; + function _Reverse: String; + function _Left(const Length: Integer): String; + function _Right(const Length: Integer): String; +{$IFNDEF PAXARM} + function _AppendLineA(const Value: AnsiString): String; + function _AppendA(const Value: AnsiString): String; +{$ENDIF} + function _AppendW(const Value: String): String; + function _AppendLineW(const Value: String): String; + function _Lastchar: WideChar; + function _LastDelimiter(const Delimiters: String = ';'): Integer; + function _FindDelimiter(const Delimiters: String = ';'; const StartIdx: integer = 1): Integer; + function _StringOfChar(const Ch: WideChar; const Count: integer): String; +{$ENDIF} + end; + + TFW_Array = class(TFW_Object) + private + NBounds: Integer; + ElTypeId: Integer; + ElFinalTypeID: Integer; + ElSize: Integer; + function GetBound(I: Integer): Integer; + function GetLength: Integer; + public + P: Pointer; + constructor Create; + destructor Destroy; override; + procedure Clear; + procedure SetLength(const Bounds: array of Integer); + function AddressOfElement(const Indexes: array of Integer): Pointer; + function Get(const Indexes: array of Integer): Variant; + procedure Put(const Indexes: array of Integer; const Value: Variant); + property Length: Integer read GetLength; + property Bound[I: Integer]: Integer read GetBound; + end; + +procedure _InitFWArray(P: Pointer; + A: TFW_Array; + NBounds: Integer; + ElFinalTypeId: Integer; + ElTypeId: Integer; + ElSize: Integer; + DecRefCount: Integer); pascal; + +procedure Register_Framework(st: TBaseSymbolTable); + +implementation + +uses + PAXCOMP_BASERUNNER, + PAXCOMP_STDLIB, + PAXCOMP_JavaScript; + +procedure _ToFWObject(Prog: TBaseRunner; + Address: Pointer; + Kind: Integer; + FinTypeId: Integer; + TypeId: Integer; + var result: TFW_Object); stdcall; forward; + +procedure _Boxing(Prog: TBaseRunner; + Address: Pointer; // value + Kind: Integer; // kind + FinTypeId: Integer; // of value + TypeId: Integer; // of value + var result: TFW_Object); stdcall; +var + r: TFW_Object; + p: PGC_Object; +begin + p := @result; + r := nil; + _ToFWObject(Prog, Address, Kind, FinTypeId, TypeId, r); + GC_Assign(p, r); +end; + +procedure _ToFWObject(Prog: TBaseRunner; + Address: Pointer; + Kind: Integer; + FinTypeId: Integer; + TypeId: Integer; + var result: TFW_Object); stdcall; +begin + case Kind of + KindCONST: + case FinTypeId of + typeBOOLEAN: + begin + result := TFW_Boolean.Create; + result.prog := Prog; + result.AddToGC; + TFW_Boolean(result).val := Boolean(Address); + end; + typeBYTEBOOL: + begin + result := TFW_ByteBool.Create; + result.prog := Prog; + result.AddToGC; + TFW_ByteBool(result).val := ByteBool(Address); + end; + typeWORDBOOL: + begin + result := TFW_WordBool.Create; + result.prog := Prog; + result.AddToGC; + TFW_WordBool(result).val := WordBool(Address); + end; + typeLONGBOOL: + begin + result := TFW_LongBool.Create; + result.prog := Prog; + result.AddToGC; + TFW_LongBool(result).val := LongBool(Address); + end; + typeBYTE: + begin + result := TFW_Byte.Create; + result.prog := Prog; + result.AddToGC; + TFW_Byte(result).val := Byte(Address); + end; + typeSMALLINT: + begin + result := TFW_SmallInt.Create; + result.prog := Prog; + result.AddToGC; + TFW_SmallInt(result).val := SmallInt(Address); + end; + typeSHORTINT: + begin + result := TFW_ShortInt.Create; + result.prog := Prog; + result.AddToGC; + TFW_ShortInt(result).val := ShortInt(Address); + end; + typeWORD: + begin + result := TFW_Word.Create; + result.prog := Prog; + result.AddToGC; + TFW_Word(result).val := Word(Address); + end; + typeCARDINAL: + begin + result := TFW_Cardinal.Create; + result.prog := Prog; + result.AddToGC; + TFW_Cardinal(result).val := Cardinal(Address); + end; + typeDOUBLE: + begin + if TypeId = Id_TDateTime then + begin + result := TFW_DateTime.Create; + result.prog := Prog; + result.AddToGC; + TFW_DateTime(result).val := Double(Address^); + end + else + begin + result := TFW_Double.Create; + result.prog := Prog; + result.AddToGC; + TFW_Double(result).val := Double(Address^); + end; + end; + typeSINGLE: + begin + result := TFW_Single.Create; + result.prog := Prog; + result.AddToGC; + TFW_Single(result).val := Single(Address^); + end; + typeEXTENDED: + begin + result := TFW_Extended.Create; + result.prog := Prog; + result.AddToGC; + TFW_Extended(result).val := Extended(Address^); + end; + typeCURRENCY: + begin + result := TFW_Currency.Create; + result.prog := Prog; + result.AddToGC; + TFW_Currency(result).val := Currency(Address^); + end; +{$IFNDEF PAXARM} + typeANSICHAR: + begin + result := TFW_AnsiChar.Create; + result.prog := Prog; + result.AddToGC; + TFW_AnsiChar(result).val := AnsiChar(Address); + end; +{$ENDIF} + typeWIDECHAR: + begin + result := TFW_WideChar.Create; + result.prog := Prog; + result.AddToGC; + TFW_WideChar(result).val := WideChar(Address); + end; + typeINT64: + begin + result := TFW_Int64.Create; + result.prog := Prog; + result.AddToGC; + TFW_Int64(result).val := Integer(Address); + end; + typeINTEGER: + begin + result := TFW_Integer.Create; + result.prog := Prog; + result.AddToGC; + TFW_Integer(result).val := Integer(Address); + end; +{$IFNDEF PAXARM} + typePANSICHAR: + begin + result := TFW_AnsiString.Create; + result.prog := Prog; + result.AddToGC; + TFW_AnsiString(result).val := AnsiString(PAnsiChar(Address)); + end; +{$ENDIF} + typePWIDECHAR: + begin + result := TFW_UnicString.Create; + result.prog := Prog; + result.AddToGC; + TFW_UnicString(result).val := UnicString(PWideChar(Address)); + end; + typeVARIANT: + begin + result := TFW_Variant.Create; + result.prog := Prog; + result.AddToGC; + TFW_Variant(result).val := Variant(PVariant(Address)^); + end; + else + Prog.RaiseError(errInternalError, []); + end; // KindCONST + KindVAR: + case FinTypeId of + typeBOOLEAN: + begin + result := TFW_Boolean.Create; + result.prog := Prog; + result.AddToGC; + TFW_Boolean(result).val := Boolean(Address^); + end; + typeBYTEBOOL: + begin + result := TFW_ByteBool.Create; + result.prog := Prog; + result.AddToGC; + TFW_ByteBool(result).val := ByteBool(Address^); + end; + typeWORDBOOL: + begin + result := TFW_WordBool.Create; + result.prog := Prog; + result.AddToGC; + TFW_WordBool(result).val := WordBool(Address^); + end; + typeLONGBOOL: + begin + result := TFW_LongBool.Create; + result.prog := Prog; + result.AddToGC; + TFW_LongBool(result).val := LongBool(Address^); + end; + typeBYTE: + begin + result := TFW_Byte.Create; + result.prog := Prog; + result.AddToGC; + TFW_Byte(result).val := Byte(Address^); + end; + typeSMALLINT: + begin + result := TFW_SmallInt.Create; + result.prog := Prog; + result.AddToGC; + TFW_SmallInt(result).val := SmallInt(Address^); + end; + typeSHORTINT: + begin + result := TFW_ShortInt.Create; + result.prog := Prog; + result.AddToGC; + TFW_ShortInt(result).val := ShortInt(Address^); + end; + typeWORD: + begin + result := TFW_Word.Create; + result.prog := Prog; + result.AddToGC; + TFW_Word(result).val := Word(Address^); + end; + typeCARDINAL: + begin + result := TFW_Cardinal.Create; + result.prog := Prog; + result.AddToGC; + TFW_Cardinal(result).val := Cardinal(Address^); + end; + typeDOUBLE: + begin + if TypeId = Id_TDateTime then + begin + result := TFW_DateTime.Create; + result.prog := Prog; + result.AddToGC; + TFW_DateTime(result).val := Double(Address^); + end + else + begin + result := TFW_Double.Create; + result.prog := Prog; + result.AddToGC; + TFW_Double(result).val := Double(Address^); + end; + end; + typeSINGLE: + begin + result := TFW_Single.Create; + result.prog := Prog; + result.AddToGC; + TFW_Single(result).val := Single(Address^); + end; + typeEXTENDED: + begin + result := TFW_Extended.Create; + result.prog := Prog; + result.AddToGC; + TFW_Extended(result).val := Extended(Address^); + end; + typeCURRENCY: + begin + result := TFW_Currency.Create; + result.prog := Prog; + result.AddToGC; + TFW_Currency(result).val := Currency(Address^); + end; +{$IFNDEF PAXARM} + typeANSICHAR: + begin + result := TFW_AnsiChar.Create; + result.prog := Prog; + result.AddToGC; + TFW_AnsiChar(result).val := AnsiChar(Address^); + end; +{$ENDIF} + typeWIDECHAR: + begin + result := TFW_WideChar.Create; + result.prog := Prog; + result.AddToGC; + TFW_WideChar(result).val := WideChar(Address^); + end; + typeINTEGER: + begin + result := TFW_Integer.Create; + result.prog := Prog; + result.AddToGC; + TFW_Integer(result).val := Integer(Address^); + end; + typeINT64: + begin + result := TFW_Int64.Create; + result.prog := Prog; + result.AddToGC; + TFW_Int64(result).val := Int64(Address^); + end; +{$IFNDEF PAXARM} + typeANSISTRING: + begin + result := TFW_AnsiString.Create; + result.prog := Prog; + result.AddToGC; + TFW_AnsiString(result).val := AnsiString(Address^); + end; +{$ENDIF} + typeUNICSTRING: + begin + result := TFW_UnicString.Create; + result.prog := Prog; + result.AddToGC; + TFW_UnicString(result).val := UnicString(Address^); + end; + typeVariant: + begin + result := TFW_Variant.Create; + result.prog := Prog; + result.AddToGC; + TFW_Variant(result).val := Variant(Address^); + end; + else + Prog.RaiseError(errInternalError, []); + end; + else + Prog.RaiseError(errInternalError, []); + end; +end; + +// TFW_Object ------------------------------------------------------------------ + +procedure TFW_Object.AddToGC; +begin + if prog = nil then + raise Exception.Create(errInternalError); + TBaseRunner(prog).RootGC.AddObject(Self); +end; + +function TFW_Object.GetGC: TGC; +begin + if prog = nil then + raise Exception.Create(errInternalError); + result := TBaseRunner(prog).RootGC; +end; + +// TFW_Boolean ----------------------------------------------------------------- + +function TFW_Boolean._ToString: String; +begin + if val then + result := 'true' + else + result := 'false'; +end; + +function TFW_Boolean._toInt32: integer; +begin + if val then + result := 1 + else + result := 0; +end; + +function TFW_Boolean._ToISOString: String; +begin + if val then + result := '1' + else + result := '0'; +end; + +{$IFNDEF PAXARM} +function TFW_Boolean._ToISOAnsiString: AnsiString; +begin + if val then + result := '1' + else + result := '0'; +end; + +function TFW_Boolean._FromISOAnsiString(const Value: AnsiString): Boolean; +begin + result := false; + if Value = '1' then + result := true; +end; + +{$ENDIF} + +function TFW_Boolean._FromISOString(const Value: String): Boolean; +begin + result := false; + if Value = '1' then + result := true; +end; + +function TFW_Boolean._Equals(const Value: Boolean): boolean; +begin + result := val = Value; +end; + +// TFW_ByteBool ---------------------------------------------------------------- + +function TFW_ByteBool._ToString: String; +begin + if val then + result := 'true' + else + result := 'false'; +end; + +function TFW_ByteBool._toInt32: integer; +begin + if val then + result := 1 + else + result := 0; +end; + +function TFW_ByteBool._Equals(const Value: ByteBool): boolean; +begin + result := val = Value; +end; + +// TFW_WordBool ---------------------------------------------------------------- + +function TFW_WordBool._ToString: String; +begin + if val then + result := 'true' + else + result := 'false'; +end; + +function TFW_WordBool._toInt32: integer; +begin + if val then + result := 1 + else + result := 0; +end; + +function TFW_WordBool._Equals(const Value: WordBool): boolean; +begin + result := val = Value; +end; + +// TFW_LongBool ---------------------------------------------------------------- + +function TFW_LongBool._ToString: String; +begin + if val then + result := 'true' + else + result := 'false'; +end; + +function TFW_LongBool._toInt32: integer; +begin + if val then + result := 1 + else + result := 0; +end; + +function TFW_LongBool._Equals(const Value: LongBool): boolean; +begin + result := val = Value; +end; + +// TFW_Byte -------------------------------------------------------------------- + +function TFW_Byte._ToString: String; +begin + result := IntToStr(val); +end; + +function TFW_Byte._Equals(const Value: Byte): boolean; +begin + result := val = Value; +end; + +// TFW_SmallInt ---------------------------------------------------------------- + +function TFW_SmallInt._ToString: String; +begin + result := IntToStr(val); +end; + +function TFW_SmallInt._Equals(const Value: SmallInt): boolean; +begin + result := val = Value; +end; + +function TFW_SmallInt._MinValue: SmallInt; +begin + result := -32768; +end; + +function TFW_SmallInt._MaxValue: SmallInt; +begin + result := 32767; +end; + +// TFW_ShortInt ---------------------------------------------------------------- + +function TFW_ShortInt._ToString: String; +begin + result := IntToStr(val); +end; + +function TFW_ShortInt._Equals(const Value: ShortInt): boolean; +begin + result := val = Value; +end; + +function TFW_ShortInt._MinValue: ShortInt; +begin + result := -127; +end; + +function TFW_ShortInt._MaxValue: ShortInt; +begin + result := 127; +end; + +// TFW_Word -------------------------------------------------------------------- + +function TFW_Word._ToString: String; +begin + result := IntToStr(val); +end; + +function TFW_Word._Equals(const Value: Word): boolean; +begin + result := val = Value; +end; + +function TFW_Word._MinValue: Word; +begin + result := 0; +end; + +function TFW_Word._MaxValue: Word; +begin + result := 65535; +end; + +// TFW_Cardinal ---------------------------------------------------------------- + +function TFW_Cardinal._ToString: String; +begin + result := IntToStr(val); +end; + +function TFW_Cardinal._Equals(const Value: Cardinal): boolean; +begin + result := val = Value; +end; + +function TFW_Cardinal._MinValue: Cardinal; +begin + result := 0; +end; + +function TFW_Cardinal._MaxValue: Cardinal; +begin + result := 4294967295; +end; + +// TFW_DateTime ------------------------------------------------------------------ + +function TFW_DateTime._ToString: String; +begin + result := DateTimeToStr(val); +end; + +function TFW_DateTime._ToStringFormat(const Format: String): String; +begin + result := FormatDateTime(Format, val); +end; + +function TFW_DateTime._ToStringISO: String; +begin + if _IsDateTime then + begin + result := FormatDateTime('yyyymmddhhnnsszzz', val); + end else + if _IsDate then + begin + result := FormatDateTime('yyyymmdd', val); + end else + if _IsTime then + begin + result := FormatDateTime('hhnnsszzz', val); + end; +end; + +{$IFDEF UNIC} + +{$IFNDEF PAXARM} +function TFW_DateTime._ToAnsiStringISO: AnsiString; +begin + if _IsDateTime then + begin + result := AnsiString(UTF8ToAnsi(UTF8Encode(FormatDateTime('yyyymmddhhnnsszzz', val)))); + end else + if _IsDate then + begin + result := AnsiString(UTF8ToAnsi(UTF8Encode(FormatDateTime('yyyymmdd', val)))); + end else + if _IsTime then + begin + result := AnsiString(UTF8ToAnsi(UTF8Encode(FormatDateTime('hhnnsszzz', val)))); + end; +end; +{$ENDIF} +{$ENDIF} + +function TFW_DateTime._ToInt32: Integer; +var + AYear : Word; + AMonth : Word; + aDay : Word; +begin + DecodeDate(val, AYear, AMonth, aDay); + result := AYear * 10000 + AMonth * 100 + aDay; +end; + +function TFW_DateTime._FromISOString(const Value: String): TDateTime; +var + aYear : Word; + aMonth : Word; + aDay : Word; + aHour : Word; + aMin : Word; + aSec : Word; + aMSec : Word; + aLen : Integer; +begin + result := 0; + aLen := Length(Value); + if aLen >= 8 then + begin + aYear := strtoint(copy(Value, 1, 4)); + aMonth := strtoint(copy(Value, 5, 2)); + aDay := strtoint(copy(Value, 7, 2)); + aHour := 0; + aMin := 0; + aSec := 0; + aMSec := 0; + if aLen > 9 then + begin + try + aHour := strtoint(copy(Value, 9, 2)); + aMin := strtoint(copy(Value, 11, 2)); + aSec := strtoint(copy(Value, 13, 2)); + aMSec := strtoint(copy(Value, 15, 2)); + except + end; + end; + + result := EncodeDate(aYear, aMonth, aDay) + + EncodeTime(aHour, aMin, aSec, aMSec); + end; +end; + +{$IFNDEF PAXARM} +function TFW_DateTime._FromISOAnsiString(const Value: AnsiString): TDateTime; +var + aYear : Word; + aMonth : Word; + aDay : Word; + aHour : Word; + aMin : Word; + aSec : Word; + aMSec : Word; + aLen : Integer; +begin + result := 0; + aLen := Length(Value); + if aLen >= 8 then + begin + aYear := strtoint(copy(String(Value), 1, 4)); + aMonth := strtoint(copy(String(Value), 5, 2)); + aDay := strtoint(copy(String(Value), 7, 2)); + aHour := 0; + aMin := 0; + aSec := 0; + aMSec := 0; + if aLen > 9 then + begin + try + aHour := strtoint(copy(String(Value), 9, 2)); + aMin := strtoint(copy(String(Value), 11, 2)); + aSec := strtoint(copy(String(Value), 13, 2)); + aMSec := strtoint(copy(String(Value), 15, 2)); + except + end; + end; + + result := EncodeDate(aYear, aMonth, aDay) + + EncodeTime(aHour, aMin, aSec, aMSec); + end; +end; +{$ENDIF} + +function TFW_DateTime._IsDate: boolean; +var + aYear : Word; + aMonth : Word; + aDay : Word; + aHour : Word; + aMinute : Word; + aSecond : Word; + aMilliSecond : Word; +begin + DecodeDate(val, aYear, aMonth, aDay); + DecodeTime(val, aHour, aMinute, aSecond, aMilliSecond); + result := ( + (aHour = 0) and + (aMinute = 0) and + (aSecond = 0) and + (aMilliSecond = 0) + ) and + ( + (aYear <> 0) or + (aMonth <> 0) or + (aDay <> 0) + ); +end; + +function TFW_DateTime._IsDateTime: boolean; +var + aYear : Word; + aMonth : Word; + aDay : Word; + aHour : Word; + aMinute : Word; + aSecond : Word; + aMilliSecond : Word; +begin + DecodeDate(val, aYear, aMonth, aDay); + DecodeTime(val, aHour, aMinute, aSecond, aMilliSecond); + result := ( + (aHour <> 0) or + (aMinute <> 0) or + (aSecond <> 0) or + (aMilliSecond <> 0) + ) and + ( + (aYear <> 0) or + (aMonth <> 0) or + (aDay <> 0) + ); +end; + +function TFW_DateTime._IsTime: boolean; +var + aYear : Word; + aMonth : Word; + aDay : Word; + aHour : Word; + aMinute : Word; + aSecond : Word; + aMilliSecond : Word; +begin + DecodeDate(val, aYear, aMonth, aDay); + DecodeTime(val, aHour, aMinute, aSecond, aMilliSecond); + result := ( + (aHour <> 0) or + (aMinute <> 0) or + (aSecond <> 0) or + (aMilliSecond <> 0) + ) and + ( + (aYear = 0) and + (aMonth = 0) and + (aDay = 0) + ); +end; + +function TFW_DateTime._Date: TDateTime; +begin + result := Date; +end; + +function TFW_DateTime._Time: TDateTime; +begin + result := Time; +end; + +function TFW_DateTime._Now: TDateTime; +begin + result := Now; +end; + +function TFW_DateTime._IsInLeapYear: boolean; +var + aYear, aMonth, aDay: Word; +begin + DecodeDate(val, aYear, aMonth, aDay); + Result := IsLeapYear(aYear); +end; + +function TFW_DateTime._DateOf: TDateTime; +begin + Result := Trunc(val); +end; + +function TFW_DateTime._TimeOf: TDateTime; +begin + Result := Frac(val); +end; + +function TFW_DateTime._YearOf: Word; +var + aMonth, aDay: Word; +begin + DecodeDate(val, Result, aMonth, aDay); +end; + +function TFW_DateTime._MonthOf: Word; +var + aYear, aDay: Word; +begin + DecodeDate(val, aYear, result, aDay); +end; + +function TFW_DateTime._DayOf: Word; +var + aYear, aMonth: Word; +begin + DecodeDate(val, aYear, aMonth, result); +end; + +function TFW_DateTime._HourOf: Word; +var + aMinute : Word; + aSecond : Word; + aMilliSecond : Word; +begin + DecodeTime(val, result, aMinute, aSecond, aMilliSecond); +end; + +function TFW_DateTime._MinuteOf: Word; +var + aHour : Word; + aSecond : Word; + aMilliSecond : Word; +begin + DecodeTime(val, aHour, result, aSecond, aMilliSecond); +end; + +function TFW_DateTime._SecondOf: Word; +var + aHour : Word; + aMinute : Word; + aMilliSecond : Word; +begin + DecodeTime(val, aHour, aMinute, result, aMilliSecond); +end; + +function TFW_DateTime._MilliSecondOf: Word; +var + aHour : Word; + aMinute : Word; + aSecond : Word; +begin + DecodeTime(val, aHour, aMinute, aSecond, result); +end; + +const + DayMonday = 1; + DayTuesday = 2; + DayWednesday = 3; + DayThursday = 4; + DayFriday = 5; + DaySaturday = 6; + DaySunday = 7; + ApproxDaysPerMonth: Double = 30.4375; + ApproxDaysPerYear: Double = 365.25; + DaysPerWeek = 7; + WeeksPerFortnight = 2; + MonthsPerYear = 12; + YearsPerDecade = 10; + YearsPerCentury = 100; + YearsPerMillennium = 1000; + HoursPerDay = 24; + MinsPerHour = 60; + MinsPerDay = 24 * 60; + MSecsPerSec = 1000; + +function DayOfTheWeek(const AValue: TDateTime): Word; +begin + Result := (DateTimeToTimeStamp(AValue).Date - 1) mod 7 + 1; +end; + +function WeeksInAYear(const AYear: Word): Word; +var + LDayOfWeek: Word; +begin + Result := 52; + LDayOfWeek := DayOfTheWeek(EncodeDate(AYear, 1, 1)); + if (LDayOfWeek = DayThursday) or + ((LDayOfWeek = DayWednesday) and IsLeapYear(AYear)) then + Inc(Result); +end; + +function TFW_DateTime._WeeksInYear: Word; +var + aYear, aMonth, aDay: Word; +begin + DecodeDate(val, aYear, aMonth, aDay); + Result := WeeksInAYear(aYear); +end; + +function TFW_DateTime._DaysInYear: Word; +var + aYear, aMonth, aDay: Word; +begin + DecodeDate(val, aYear, aMonth, aDay); + if IsLeapYear(AYear) then + result := 366 + else + result := 365; +end; + +function TFW_DateTime._Today: TDateTime; +begin + Result := Date; +end; + +function TFW_DateTime._Yesterday: TDateTime; +begin + Result := Date - 1; +end; + +function TFW_DateTime._Tomorrow: TDateTime; +begin + Result := Date + 1; +end; + +function DaySpan(const ANow, AThen: TDateTime): Double; forward; +function IncDay(const AValue: TDateTime; + const ANumberOfDays: Integer = 1): TDateTime; forward; +function IncHour(const AValue: TDateTime; const ANumberOfHours: Int64 = 1): TDateTime; forward; +function IncMinute(const AValue: TDateTime; + const ANumberOfMinutes: Int64 = 1): TDateTime; forward; +function IncSecond(const AValue: TDateTime; + const ANumberOfSeconds: Int64 = 1): TDateTime; forward; +function IncMilliSecond(const AValue: TDateTime; + const ANumberOfMilliSeconds: Int64 = 1): TDateTime; forward; + +function SpanOfNowAndThen(const ANow, AThen: TDateTime): TDateTime; +begin + if ANow < AThen then + Result := AThen - ANow + else + Result := ANow - AThen; +end; + +function YearSpan(const ANow, AThen: TDateTime): Double; +begin + Result := DaySpan(ANow, AThen) / ApproxDaysPerYear; +end; + +function MonthSpan(const ANow, AThen: TDateTime): Double; +begin + Result := DaySpan(ANow, AThen) / ApproxDaysPerMonth; +end; + +function WeekSpan(const ANow, AThen: TDateTime): Double; +begin + Result := DaySpan(ANow, AThen) / DaysPerWeek; +end; + +function DaySpan(const ANow, AThen: TDateTime): Double; +begin + Result := SpanOfNowAndThen(ANow, AThen); +end; + +function HourSpan(const ANow, AThen: TDateTime): Double; +begin + Result := HoursPerDay * SpanOfNowAndThen(ANow, AThen); +end; + +function MinuteSpan(const ANow, AThen: TDateTime): Double; +begin + Result := MinsPerDay * SpanOfNowAndThen(ANow, AThen); +end; + +function SecondSpan(const ANow, AThen: TDateTime): Double; +begin + Result := SecsPerDay * SpanOfNowAndThen(ANow, AThen); +end; + +function MilliSecondSpan(const ANow, AThen: TDateTime): Double; +begin + Result := MSecsPerDay * SpanOfNowAndThen(ANow, AThen); +end; + +function IncYear(const AValue: TDateTime; + const ANumberOfYears: Integer): TDateTime; +begin + Result := IncMonth(AValue, ANumberOfYears * MonthsPerYear); +end; + +function IncWeek(const AValue: TDateTime; + const ANumberOfWeeks: Integer): TDateTime; +begin + Result := IncDay(AValue, ANumberOfWeeks * DaysPerWeek); +end; + +function IncDay(const AValue: TDateTime; + const ANumberOfDays: Integer = 1): TDateTime; +begin + Result := IncHour(AValue, ANumberOfDays * HoursPerDay); +end; + +function IncHour(const AValue: TDateTime; const ANumberOfHours: Int64 = 1): TDateTime; +begin + Result := IncMinute(AValue, ANumberOfHours * MinsPerHour); +end; + +function IncMinute(const AValue: TDateTime; + const ANumberOfMinutes: Int64 = 1): TDateTime; +begin + Result := IncSecond(AValue, ANumberOfMinutes * MinsPerHour); +end; + +function IncSecond(const AValue: TDateTime; + const ANumberOfSeconds: Int64 = 1): TDateTime; +begin + Result := IncMilliSecond(Avalue, ANumberOfSeconds * MSecsPerSec); +end; + +function IncMilliSecond(const AValue: TDateTime; + const ANumberOfMilliSeconds: Int64 = 1): TDateTime; +var + TS: TTimeStamp; + TempTime: Comp; +begin + TS := DateTimeToTimeStamp(AValue); + TempTime := TimeStampToMSecs(TS); + TempTime := TempTime + ANumberOfMilliSeconds; + TS := MSecsToTimeStamp(TempTime); + Result := TimeStampToDateTime(TS); +end; + + +function TFW_DateTime._YearSpan(const Value: TDateTime): Double; +begin + result := YearSpan(val, Value); +end; + +function TFW_DateTime._MonthSpan(const Value: TDateTime): Double; +begin + result := MonthSpan(val, Value); +end; + +function TFW_DateTime._WeekSpan(const Value: TDateTime): Double; +begin + result := WeekSpan(val, Value); +end; + +function TFW_DateTime._DaySpan(const Value: TDateTime): Double; +begin + result := DaySpan(val, Value); +end; + +function TFW_DateTime._HourSpan(const Value: TDateTime): Double; +begin + result := HourSpan(val, Value); +end; + +function TFW_DateTime._MinuteSpan(const Value: TDateTime): Double; +begin + result := MinuteSpan(val, Value); +end; + +function TFW_DateTime._SecondSpan(const Value: TDateTime): Double; +begin + result := SecondSpan(val, Value); +end; + +function TFW_DateTime._MilliSecondSpan(const Value: TDateTime): Double; +begin + result := MinuteSpan(val, Value); +end; + +function TFW_DateTime._AddYears(const ANumberOfYears: Integer = 1): TDateTime; +begin + result := IncYear(val, ANumberOfYears); +end; + +function TFW_DateTime._AddWeeks(const ANumberOfWeeks: Integer = 1): TDateTime; +begin + result := IncWeek(val, ANumberOfWeeks); +end; + +function TFW_DateTime._AddDays(const ANumberOfDays: Integer = 1): TDateTime; +begin + result := IncDay(val, ANumberOfDays); +end; + +function TFW_DateTime._AddHours(const ANumberOfHours: Int64 = 1): TDateTime; +begin + result := IncHour(val, ANumberOfHours); +end; + +function TFW_DateTime._AddMinutes(const ANumberOfMinutes: Int64 = 1): TDateTime; +begin + result := IncMinute(val, ANumberOfMinutes); +end; + +function TFW_DateTime._AddSeconds(const ANumberOfSeconds: Int64 = 1): TDateTime; +begin + result := IncSecond(val, ANumberOfSeconds); +end; + +function TFW_DateTime._AddMilliSeconds(const ANumberOfMilliSeconds: Int64 = 1): TDateTime; +begin + result := IncMilliSecond(val, ANumberOfMilliSeconds); +end; + +{$IFDEF UNIC} +function TFW_DateTime._EncodeDateTime(const AYear, AMonth, ADay, AHour, AMinute, ASecond, AMilliSecond: Word): TDateTime; +begin + result := DateUtils.EncodeDateTime(AYear, AMonth, ADay, AHour, AMinute, ASecond, AMilliSecond); +end; +{$ENDIF} + +function TFW_DateTime._EncodeDate(const AYear, AMonth, ADay: Word): TDateTime; +begin + result := EncodeDate(AYear, AMonth, ADay); +end; + +function TFW_DateTime._EncodeTime(const AHour, AMinute, ASecond, AMilliSecond: Word): TDateTime; +begin + result := EncodeTime(AHour, AMinute, ASecond, AMilliSecond); +end; + +function TFW_DateTime._Min(const Value: TDateTime): TDateTime; +begin + if val < Value then + result := val + else + result := Value; +end; + +function TFW_DateTime._Max(const Value: TDateTime): TDateTime; +begin + if val > Value then + result := val + else + result := Value; +end; + +function TFW_DateTime._Equals(const Value: TDateTime): boolean; +begin + result := val = Value; +end; + +function TFW_DateTime._MinValue: TDateTime; +begin + result := 0; +end; + +function TFW_DateTime._MaxValue: TDateTime; +begin + result := 2958465.99998843; //31.12.9999 23:59:59:999; +end; + +// TFW_Double ------------------------------------------------------------------ + +function TFW_Double._ToString: String; +begin + result := FloatToStr(val); +end; + +function TFW_Double._ToStringFormat(const Format: String): String; +begin + result := FormatFloat(Format, val); +end; + +{$IFDEF UNIC} +function TFW_Double._ToISOString: String; +var + aFormat: TFormatSettings; +begin + aFormat.DecimalSeparator := '.'; + result := FloatToStrF(val, ffFixed, 18, 6, aFormat); +end; + +{$IFNDEF PAXARM} +function TFW_Double._ToISOAnsiString: AnsiString; +begin + result := UTF8Encode(_ToISOString); +end; + +function TFW_Double._FromISOAnsiString(const Value: AnsiString): double; +var + aFormat: TFormatSettings; +begin + aFormat.DecimalSeparator := '.'; + if not TryStrToFloat(String(Value), result, aFormat) then + result := 0; +end; +{$ENDIF} + +function TFW_Double._FromISOString(const Value: String): double; +var + aFormat: TFormatSettings; +begin + aFormat.DecimalSeparator := '.'; + if not TryStrToFloat(Value, result, aFormat) then + result := 0; +end; +{$ENDIF} + +function TFW_Double._Round: Int64; +begin + result := Round(val); +end; + +{$IFDEF UNIC} +function TFW_Double._RoundTo(const Digit: integer): double; +begin + result := Math.RoundTo(val, Digit); +end; +{$ENDIF} + +function TFW_Double._Power(const Exponent: Extended): double; +begin + result := Math.Power(val, Exponent); +end; + +function TFW_Double._Trunc: Int64; +begin + result := System.Trunc(val); +end; + +function TFW_Double._Floor: Integer; +begin + result := Math.Floor(val); +end; + +function TFW_Double._Ceil: Integer; +begin + result := Math.Ceil(val); +end; + +function TFW_Double._Min(const Value: Double): Double; +begin + if val < Value then + result := val + else + result := Value; +end; + +function TFW_Double._Max(const Value: Double): Double; +begin + if val > Value then + result := val + else + result := Value; +end; + +function TFW_Double._Equals(const Value: Double): boolean; +begin + result := val = Value; +end; + + +// TFW_Single ------------------------------------------------------------------ + +function TFW_Single._ToString: String; +begin + result := FloatToStr(val); +end; + +function TFW_Single._Min(const Value: Single): Single; +begin + if val < Value then + result := val + else + result := Value; +end; + +function TFW_Single._Max(const Value: Single): Single; +begin + if val > Value then + result := val + else + result := Value; +end; + +function TFW_Single._Equals(const Value: Single): boolean; +begin + result := val = Value; +end; + +// TFW_Extended ---------------------------------------------------------------- + +function TFW_Extended._ToString: String; +begin + result := FloatToStr(val); +end; + +function TFW_Extended._ToStringFormat(const Format: String): String; +begin + result := FormatFloat(Format, val); +end; + +{$IFDEF UNIC} +function TFW_Extended._ToISOString: String; +var + aFormat: TFormatSettings; +begin + aFormat.DecimalSeparator := '.'; + result := FloatToStrF(val, ffFixed, 18, 6, aFormat); +end; + +{$IFNDEF PAXARM} +function TFW_Extended._ToISOAnsiString: AnsiString; +begin + result := UTF8Encode(_ToISOString); +end; + +function TFW_Extended._FromISOAnsiString(const Value: AnsiString): Extended; +var + aFormat: TFormatSettings; +begin + aFormat.DecimalSeparator := '.'; + if not TryStrToFloat(String(Value), result, aFormat) then + result := 0; +end; +{$ENDIF} + +function TFW_Extended._FromISOString(const Value: String): Extended; +var + aFormat: TFormatSettings; +begin + aFormat.DecimalSeparator := '.'; + if not TryStrToFloat(Value, result, aFormat) then + result := 0; +end; + +function TFW_Extended._RoundTo(const Digit: integer): Extended; +begin + result := Math.RoundTo(val, Digit); +end; +{$ENDIF} + +function TFW_Extended._Round: Int64; +begin + result := Round(val); +end; + +function TFW_Extended._Power(const Exponent: Extended): Extended; +begin + result := Math.Power(val, Exponent); +end; + +function TFW_Extended._Trunc: Int64; +begin + result := System.Trunc(val); +end; + +function TFW_Extended._Floor: Integer; +begin + result := Math.Floor(val); +end; + +function TFW_Extended._Ceil: Integer; +begin + result := Math.Ceil(val); +end; + +function TFW_Extended._Min(const Value: Extended): Extended; +begin + if val < Value then + result := val + else + result := Value; +end; + +function TFW_Extended._Max(const Value: Extended): Extended; +begin + if val > Value then + result := val + else + result := Value; +end; + +function TFW_Extended._Equals(const Value: Extended): boolean; +begin + result := val = Value; +end; + +// TFW_Currency ---------------------------------------------------------------- + +function TFW_Currency._ToString: String; +begin + result := CurrToStr(val); +end; + +function TFW_Currency._ToStringFormat(const Format: String): String; +begin + result := FormatFloat(Format, val); +end; + +{$IFDEF UNIC} +function TFW_Currency._ToISOString: String; +var + aFormat: TFormatSettings; +begin + aFormat.DecimalSeparator := '.'; + result := FloatToStrF(val, ffFixed, 18, 6, aFormat); +end; + +{$IFNDEF PAXARM} +function TFW_Currency._ToISOAnsiString: AnsiString; +begin + result := UTF8Encode(_ToISOString); +end; + +function TFW_Currency._FromISOAnsiString(const Value: AnsiString): Currency; +var + aFormat: TFormatSettings; +begin + aFormat.DecimalSeparator := '.'; + if not TryStrToCurr(String(Value), result, aFormat) then + result := 0; +end; +{$ENDIF} + +function TFW_Currency._FromISOString(const Value: String): Currency; +var + aFormat: TFormatSettings; +begin + aFormat.DecimalSeparator := '.'; + if not TryStrToCurr(Value, result, aFormat) then + result := 0; +end; + +function TFW_Currency._RoundTo(const Digit: integer): Currency; +begin + result := Math.RoundTo(val, Digit); +end; +{$ENDIF} + +function TFW_Currency._Round: Int64; +begin + result := Round(val); +end; + +function TFW_Currency._Power(const Exponent: Extended): Currency; +begin + result := Math.Power(val, Exponent); +end; + +function TFW_Currency._Trunc: Int64; +begin + result := Trunc(val); +end; + +function TFW_Currency._Floor: Integer; +begin + result := Math.Floor(val); +end; + +function TFW_Currency._Ceil: Integer; +begin + result := Math.Ceil(val); +end; + +function TFW_Currency._Min(const Value: Currency): Currency; +begin + if val < Value then + result := val + else + result := Value; +end; + +function TFW_Currency._Max(const Value: Currency): Currency; +begin + if val > Value then + result := val + else + result := Value; +end; + +function TFW_Currency._Equals(const Value: Currency): boolean; +begin + result := val = Value; +end; + +// TFW_AnsiChar ---------------------------------------------------------------- + +{$IFNDEF PAXARM} +function TFW_AnsiChar._ToString: String; +begin + result := String(val); +end; + +function TFW_AnsiChar._Equals(const Value: AnsiChar): boolean; +begin + result := val = Value; +end; +{$ENDIF} + +// TFW_WideChar ---------------------------------------------------------------- + +function TFW_WideChar._ToString: String; +begin + result := val; +end; + +function TFW_WideChar._Equals(const Value: WideChar): boolean; +begin + result := val = Value; +end; + +// TFW_Integer ----------------------------------------------------------------- + +function TFW_Integer._ToString: String; +begin + result := IntToStr(val); +end; + +function TFW_Integer._ToDate: TDateTime; +var + AYear : Word; + AMonth : Word; + ADay : Word; +begin + AYear := val div (10000); + AMonth := (val - AYear * 10000) div (100); + aDay := val - (AYear * 10000) - (AMonth * 100); + try + result := EncodeDate(AYear, AMonth, aDay); + except + result := 0; + end; +end; + +function TFW_Integer._ToHex(Digits: Integer = 8): String; +begin + result := IntToHex(val, Digits); +end; + +function TFW_Integer._FromHex(const Value: String): Integer; +var + aTemp: String; +begin + aTemp := Value; + if Copy(aTemp, 1, 1) <> '$' then + aTemp := '$' + aTemp; + result := StrToInt(aTemp); +end; + +{$IFNDEF PAXARM} +function TFW_Integer._FromHexAnsi(const Value: AnsiString): Integer; +var + aTemp: String; +begin + aTemp := String(Value); + if Copy(aTemp, 1, 1) <> '$' then + aTemp := '$' + aTemp; + result := StrToInt(aTemp); +end; +{$ENDIF} + +function TFW_Integer._Min(const Value: Integer): Integer; +begin + if val < Value then + result := val + else + result := Value; +end; + +function TFW_Integer._Max(const Value: Integer): Integer; +begin + if val > Value then + result := val + else + result := Value; +end; + +function TFW_Integer._Equals(const Value: Integer): boolean; +begin + result := val = Value; +end; + +function TFW_Integer._MinValue: Integer; +begin + result := -MaxInt +end; + +function TFW_Integer._MaxValue: Integer; +begin + result := MaxInt; +end; + +// TFW_Int64 ----------------------------------------------------------------- + +function TFW_Int64._ToString: String; +begin + result := IntToStr(val); +end; + +function TFW_Int64._ToDate: TDateTime; +var + AYear : Word; + AMonth : Word; + ADay : Word; +begin + AYear := val div (10000); + AMonth := (val - AYear * 10000) div (100); + aDay := val - (AYear * 10000) - (AMonth * 100); + try + result := EncodeDate(AYear, AMonth, aDay); + except + result := 0; + end; +end; + +function TFW_Int64._ToHex(Digits: Integer = 8): String; +begin + result := IntToHex(val, Digits); +end; + +function TFW_Int64._FromHex(const Value: String): Int64; +var + aTemp: String; +begin + aTemp := Value; + if Copy(aTemp, 1, 1) <> '$' then + aTemp := '$' + aTemp; + result := StrToInt64(aTemp); +end; + +{$IFNDEF PAXARM} +function TFW_Int64._FromHexAnsi(const Value: AnsiString): Int64; +var + aTemp: String; +begin + aTemp := String(Value); + if Copy(aTemp, 1, 1) <> '$' then + aTemp := '$' + aTemp; + result := StrToInt64(aTemp); +end; +{$ENDIF} + +function TFW_Int64._Min(const Value: Int64): Int64; +begin + if val < Value then + result := val + else + result := Value; +end; + +function TFW_Int64._Max(const Value: Int64): Int64; +begin + if val > Value then + result := val + else + result := Value; +end; + +function TFW_Int64._Equals(const Value: Int64): boolean; +begin + result := val = Value; +end; + +function TFW_Int64._MinValue: Int64; +begin + result := - 9223372036854775807; +end; + +function TFW_Int64._MaxValue: Int64; +begin + result := 9223372036854775807; +end; + +// TFW_Variant ----------------------------------------------------------------- + +function TFW_Variant._ToString: String; +begin + result := VarToStr(val); +end; + +function TFW_Variant._ToDate: TDateTime; +begin + result := Trunc(_ToDateTime); +end; + +function TFW_Variant._ToDateTime: TDateTime; +begin + result := VarToDateTime(val); +end; + +function TFW_Variant._ToTime: TDateTime; +begin + result := Frac(_ToDateTime); +end; + +function TFW_Variant._IsType: TVarType; +begin + result := VarType(val); +end; + +function TFW_Variant._IsNull: boolean; +begin + result := VarIsNull(val); +end; + +function TFW_Variant._IsEmpty: boolean; +begin + result := VarIsEmpty(val); +end; + +{$IFDEF VARIANTS} +function TFW_Variant._IsEmptyParam: boolean; +begin + result := Variants.VarIsEmptyParam(val); +end; + +function FindVarData(const V: Variant): PVarData; +begin + Result := @TVarData(V); + while Result.VType = varByRef or varVariant do + Result := PVarData(Result.VPointer); +end; + +function VarIsError(const V: Variant; out AResult: HRESULT): Boolean; overload; +var + LVarData: PVarData; +begin + LVarData := FindVarData(V); + Result := Assigned(LVarData) and (LVarData^.VType = varError); + if Result then + AResult := LVarData^.VError; +end; + +function VarIsError(const V: Variant): Boolean; overload; +var + LResult: HRESULT; +begin + Result := PAXCOMP_FRAMEWORK.VarIsError(V, LResult); +end; + +function TFW_Variant._IsError: boolean; +begin + result := PAXCOMP_FRAMEWORK.VarIsError(val); +end; + +function TFW_Variant._IsArray: boolean; +begin + result := Variants.VarIsArray(val); +end; + +function TFW_Variant._IsFilled: boolean; +begin + result := false; + if not PAXCOMP_FRAMEWORK.VarIsError(val) and + not Variants.VarIsEmpty(val) and + not Variants.VarIsEmptyParam(val) and + not Variants.VarIsNULL(val) then + begin + result := true; + end; +end; + +{$ENDIF} + +function TFW_Variant._Null: Variant; +begin + result := Null; +end; + + +function TFW_Variant._Unassigned: Variant; +begin + result := Unassigned; +end; + +function TFW_Variant._Clear: Variant; +begin + result := val; +{$IFDEF FPC} + Variants.VarClear(result); +{$ELSE} + System.VarClear(result); +{$ENDIF} +end; + +function TFW_Variant._DimCount: Integer; +begin + result := VarArrayDimCount(val); +end; + +function TFW_Variant._LowBound(const Dim: integer): integer; +begin + result := VarArrayLowBound(val, Dim); +end; + +function TFW_Variant._HighBound(const Dim: integer): integer; +begin + result := VarArrayHighBound(val, Dim); +end; + +function TFW_Variant._Equals(const Value: Variant): boolean; +begin + result := val = Value; +end; + +// TFW_AnsiString -------------------------------------------------------------- +{$IFNDEF PAXARM} +function TFW_AnsiString._ToString: String; +begin + result := String(val); +end; + +function TFW_AnsiString._Replace(const OldPattern: AnsiString; const NewPattern: AnsiString): AnsiString; +begin + result := StringReplace(val, OldPattern, NewPattern, [rfReplaceAll]); +end; + +function TFW_AnsiString._Equals(const Value: AnsiString): boolean; +begin + result := CompareText(val, value) = 0; +end; + +function TFW_AnsiString._Length: integer; +begin + result := System.Length(val); +end; + +{$IFDEF UNIC} + +function TFW_AnsiString._ToDate: TDateTime; +begin + if not SysUtils.TryStrToDate(String(val), result) then + result := 0; +end; + +function TFW_AnsiString._ToTime: TDateTime; +begin + if not SysUtils.TryStrToTime(String(val), result) then + result := 0; +end; + +function TFW_AnsiString._ToDateTime: TDateTime; +begin + if not SysUtils.TryStrToDateTime(String(val), result) then + result := 0; +end; + +function TFW_AnsiString._ToCurrency: Currency; +begin + if not SysUtils.TryStrToCurr(String(val), result) then + result := 0; +end; + +function TFW_AnsiString._ToExtended: Extended; +begin + if not SysUtils.TryStrToFloat(String(val), result) then + result := 0; +end; + +function TFW_AnsiString._ToDouble: Double; +begin + if not SysUtils.TryStrToFloat(String(val), result) then + result := 0; +end; + +function TFW_AnsiString._ToCardinal: Cardinal; +var + aTemp: integer; +begin + if not SysUtils.TryStrToInt(String(val), aTemp) then + aTemp := 0; + result := aTemp; +end; + +function TFW_AnsiString._ToShortInt: ShortInt; +var + aTemp: integer; +begin + if not SysUtils.TryStrToInt(String(val), aTemp) then + aTemp := 0; + result := aTemp; +end; + +function TFW_AnsiString._ToSmallInt: SmallInt; +var + aTemp: integer; +begin + if not SysUtils.TryStrToInt(String(val), aTemp) then + aTemp := 0; + result := aTemp; +end; + +function TFW_AnsiString._ToSingle: Single; +var + aTemp: integer; +begin + if not SysUtils.TryStrToInt(String(val), aTemp) then + aTemp := 0; + result := aTemp; +end; + +function TFW_AnsiString._ToWord: Word; +var + aTemp: integer; +begin + if not SysUtils.TryStrToInt(String(val), aTemp) then + aTemp := 0; + result := aTemp; +end; + +function TFW_AnsiString._ToInt32: Integer; +begin + if not SysUtils.TryStrToInt(String(val), result) then + result := 0; +end; + +function TFW_AnsiString._ToInt64: Int64; +begin + if not SysUtils.TryStrToInt64(String(val), result) then + result := 0; +end; + +function TFW_AnsiString._ToBoolean: Boolean; +begin + if not SysUtils.TryStrToBool(String(val), result) then + result := false; +end; + +function TFW_AnsiString._ToByteBool: ByteBool; +var + aTemp: boolean; +begin + if not SysUtils.TryStrToBool(String(val), aTemp) then + aTemp := false; + result := aTemp; +end; + +function TFW_AnsiString._ToLongBool: LongBool; +var + aTemp: boolean; +begin + if not SysUtils.TryStrToBool(String(val), aTemp) then + aTemp := false; + result := aTemp; +end; + +function TFW_AnsiString._ToWordBool: WordBool; +var + aTemp: boolean; +begin + if not SysUtils.TryStrToBool(String(val), aTemp) then + aTemp := false; + result := aTemp; +end; + +function TFW_AnsiString._ToUTF8: UTF8String; +begin + result := System.AnsiToUtf8(String(val)); +end; + +function TFW_AnsiString._FromUTF8(const Value: UTF8String): AnsiString; +begin + result := AnsiString(System.Utf8ToAnsi(Value)); +end; + +function TFW_AnsiString._ToUnicode: UnicodeString; +begin +{$IFDEF DRTTI} + result := UTF8ToString(Val); +{$ELSE} + result := UTF8Decode(System.AnsiToUtf8(String(val))); +{$ENDIF} +end; + +function TFW_AnsiString._FromUnicode(const Value: UnicodeString): AnsiString; +begin + result := UTF8Encode(System.Utf8ToAnsi(RawByteString(Value))); +end; + +function TFW_AnsiString._ToBase64: AnsiString; +begin + result := AnsiString(UTF8ToAnsi(UTF8Encode(EncdDecd.EncodeString(String(val))))); +end; + +function TFW_AnsiString._FromBase64(const Value: AnsiString): AnsiString; +begin + result := AnsiString(UTF8ToAnsi(UTF8Encode(EncdDecd.DecodeString(String(Value))))); +end; + +function TFW_AnsiString._ISOToBoolean: Boolean; +var + aObj: TFW_Boolean; +begin + aObj := TFW_Boolean.create; + try + result := aObj._FromISOString(String(val)); + finally + FreeAndNil(aObj); + end; +end; + +function TFW_AnsiString._ISOToDate: TDateTime; +var + aObj: TFW_DateTime; +begin + aObj := TFW_DateTime.create; + try + result := DateOf(aObj._FromISOAnsiString(val)); + finally + FreeAndNil(aObj); + end; +end; + +function TFW_AnsiString._ISOToTime: TDateTime; +var + aObj: TFW_DateTime; +begin + aObj := TFW_DateTime.create; + try + result := TimeOf(aObj._FromISOAnsiString(val)); + finally + FreeAndNil(aObj); + end; +end; + +function TFW_AnsiString._ISOToDateTime: TDateTime; +var + aObj: TFW_DateTime; +begin + aObj := TFW_DateTime.create; + try + result := aObj._FromISOAnsiString(val); + finally + FreeAndNil(aObj); + end; +end; + +function TFW_AnsiString._ISOToCurrency: Currency; +var + aObj: TFW_Currency; +begin + aObj := TFW_Currency.create; + try + result := aObj._FromISOAnsiString(val); + finally + FreeAndNil(aObj); + end; +end; + +function TFW_AnsiString._ISOToExtended: Extended; +var + aObj: TFW_Extended; +begin + aObj := TFW_Extended.create; + try + result := aObj._FromISOAnsiString(val); + finally + FreeAndNil(aObj); + end; +end; + +function TFW_AnsiString._ISOToDouble: Double; +var + aObj: TFW_Double; +begin + aObj := TFW_Double.create; + try + result := aObj._FromISOAnsiString(val); + finally + FreeAndNil(aObj); + end; +end; + +function TFW_AnsiString._Copy(Index: integer; Count: integer): AnsiString; +begin + result := System.Copy(val, Index, Count); +end; + +function TFW_AnsiString._Delete(Index: integer; Count: integer): AnsiString; +begin + result := val; + System.Delete(result, Index, Count); +end; + +function TFW_AnsiString._Trim: AnsiString; +begin + result := AnsiStrings.Trim(val); +end; + +function TFW_AnsiString._TrimLeft: AnsiString; +begin + result := AnsiStrings.TrimLeft(val); +end; + +function TFW_AnsiString._TrimRight: AnsiString; +begin + result := AnsiStrings.TrimRight(val); +end; + +function TFW_AnsiString._Contains(const Value: AnsiString): boolean; +begin + result := AnsiStrings.PosEx(value, val, 1) <> 0; +end; + +function TFW_AnsiString._Pos(const Value: AnsiString): integer; +begin + result := AnsiStrings.PosEx(value, val, 1); +end; + +function TFW_AnsiString._IndexOf(const Value: AnsiString; const StartIndex: integer = 1): integer; +begin + result := AnsiStrings.PosEx(value, val, StartIndex); +end; + +function TFW_AnsiString._Quoted(const Quote: AnsiChar = '"'): AnsiString; +begin + result := AnsiStrings.AnsiQuotedStr(val, Quote); +end; + +function TFW_AnsiString._Dequoted(const Quote: AnsiChar = '"'): AnsiString; +begin + result := AnsiStrings.AnsiDequotedStr(val, Quote); +end; + +function TFW_AnsiString._ToUpper: AnsiString; +begin + result := AnsiStrings.UpperCase(val); +end; + +function TFW_AnsiString._ToLower: AnsiString; +begin + result := AnsiStrings.LowerCase(val); +end; + +function TFW_AnsiString._Split(const Seperator: AnsiString): TAnsiStringDynArray; +var + i: Integer; + S: AnsiString; +begin + S := val; + SetLength(Result, 0); + i := 0; + while AnsiStrings.PosEx(Seperator, S, 1) > 0 do + begin + SetLength(Result, Length(Result) +1); + Result[i] := Copy(S, 1, Pos(Seperator, S) -1); + Inc(i); + S := Copy(S, AnsiStrings.PosEx(Seperator, S, 1) + Length(Seperator), Length(S)); + end; + SetLength(Result, Length(Result) + 1); + Result[i] := Copy(S, 1, Length(S)); +end; + +function TFW_AnsiString._SplitEx(const Seperator: AnsiChar; const Quotes: Boolean; const Quote: AnsiChar = '"'; const TrimText: Boolean = false): TAnsiStringDynArray; +var + i : Integer; + a : integer; + aBuffer : AnsiString; + aQuote : Boolean; +begin + SetLength(Result, 0); + + aBuffer := ''; + a := -1; + aQuote := true; + for i := 1 to Length(val) do + begin + if (Quotes and (val[I] = Seperator) and aQuote) or + (not (Quotes) and (val[I] = Seperator)) then + begin + if TrimText then aBuffer := Trim(aBuffer); + if aBuffer = '' then aBuffer := Seperator; + if aBuffer[1] = Seperator then + aBuffer := Copy(aBuffer, 2, Length(aBuffer)); + inc(a); + SetLength(Result, a + 1); + result[a] := aBuffer; + aBuffer := ''; + end; + if Quotes then + begin + if val[I] = Quote then + begin + aQuote := not(aQuote); + Continue; + end; + if (val[i] <> Seperator) or + ((val[i] = Seperator) and (aQuote=false)) then + begin + aBuffer := aBuffer + val[i]; + end; + end else + begin + if val[i] <> Seperator then + aBuffer := aBuffer + val[i]; + end; + end; + if aBuffer <> '' then + begin + if TrimText then aBuffer := Trim(aBuffer); + inc(a); + SetLength(Result, a + 1); + result[a] := aBuffer; + end; +end; + +function TFW_AnsiString._Join(const Value: TAnsiStringDynArray; const Seperator: AnsiString): AnsiString; +var + i: integer; +begin + result := ''; + for i := low(Value) to high(Value) do + begin + if i > 0 then + result := result + Seperator; + result := result + Value[i]; + end; +end; + +function TFW_AnsiString._Insert(const Value: AnsiString; Index: integer): AnsiString; +begin + result := val; + Insert(Value, result, Index); +end; + +function TFW_AnsiString._EndsWith(const Value: AnsiString): boolean; +begin + result := StrUtils.AnsiEndsText(String(Value), String(val)); +end; + +function TFW_AnsiString._StartsWith(const Value: AnsiString): boolean; +begin + result := StrUtils.AnsiStartsText(String(Value), String(val)); +end; + +function TFW_AnsiString._IsNumeric: boolean; +var + i : integer; + aLen : integer; + aChar: AnsiChar; +begin + result := true; + aLen := Length(val); + if aLen > 0 then + begin + for i := 1 to aLen - 1 do + begin + aChar := val[i]; + if not (aChar in ['0'..'9']) then + begin + result := false; + break; + end; + end; + end else + begin + result := false; + end; +end; + +function TFW_AnsiString._IsAlpha: boolean; +var + i : integer; + aLen : integer; + aChar: AnsiChar; +begin + result := true; + aLen := Length(val); + if aLen > 0 then + begin + for i := 1 to aLen - 1 do + begin + aChar := val[i]; + if not (aChar in ['A'..'Z', ' ']) and + not (aChar in ['a'..'z']) then + begin + result := false; + break; + end; + end; + end else + begin + result := false; + end; +end; + +function TFW_AnsiString._IsAlphaNumeric: boolean; +var + i : integer; + aLen : integer; + aChar: AnsiChar; +begin + result := true; + aLen := Length(val); + if aLen > 0 then + begin + for i := 1 to aLen - 1 do + begin + aChar := val[i]; + if not (aChar in ['A'..'Z', ' ']) and + not (aChar in ['0'..'9']) and + not (aChar in ['a'..'z']) then + begin + result := false; + break; + end; + end; + end else + begin + result := false; + end; +end; + +function TFW_AnsiString._Match(const Mask: String): boolean; +begin + result := Masks.MatchesMask(String(val), Mask); +end; + +function TFW_AnsiString._Reverse: AnsiString; +begin + result := AnsiString(StrUtils.AnsiReverseString(String(val))); +end; + +function TFW_AnsiString._Left(const Length: Integer): AnsiString; +begin + result := AnsiString(StrUtils.LeftStr(String(val), Length)); +end; + +function TFW_AnsiString._Right(const Length: Integer): AnsiString; +begin + result := AnsiStrings.RightStr(val, Length); +end; + +function TFW_AnsiString._AppendA(const Value: AnsiString): AnsiString; +begin + result := val + Value; +end; + +function TFW_AnsiString._AppendW(const Value: String): AnsiString; +begin + result := AnsiString(val + AnsiString(UTF8ToAnsi(UTF8Encode(Value)))); +end; + +function TFW_AnsiString._AppendLineA(const Value: AnsiString): AnsiString; +begin + result := val + Value + #13#10; +end; + +function TFW_AnsiString._AppendLineW(const Value: String): AnsiString; +begin + result := AnsiString(val + AnsiString(UTF8ToAnsi(UTF8Encode(Value))) + #13#10); +end; + +function TFW_AnsiString._Lastchar: AnsiChar; +var +{$IFDEF GE_DXE3} + aResult: PWideChar; +{$ELSE} + aResult: PAnsiChar; +{$ENDIF} +begin + aResult := Sysutils.AnsiLastChar(AnsiString(val)); + if aResult <> nil then + result := AnsiChar(aResult^) + else + result := #0; +end; + +function TFW_AnsiString._LastDelimiter(const Delimiters: AnsiString = ';'): Integer; +begin + result := AnsiStrings.LastDelimiter(Delimiters, val); +end; + +function TFW_AnsiString._FindDelimiter(const Delimiters: AnsiString = ';'; const StartIdx: integer = 1): Integer; +begin + result := FindDelimiter(String(Delimiters), String(val), StartIdx); +end; + +function TFW_AnsiString._StringOfChar(const Ch: AnsiChar; const Count: integer): AnsiString; +begin + result := StringOfChar(Ch, Count) +end; +{$ENDIF} +{$ENDIF} + +// TFW_UnicString -------------------------------------------------------------- + +constructor TFW_UnicString.Create; +begin + inherited; +end; + +function TFW_UnicString._ToString: String; +begin + result := val; +end; + +function TFW_UnicString._Replace(const OldPattern: String; const NewPattern: String): String; +begin + result := SysUtils.StringReplace(val, OldPattern, NewPattern, [rfReplaceAll]); +end; + +function TFW_UnicString._Equals(const Value: String): boolean; +begin + result := SysUtils.CompareText(val, value) = 0; +end; + +function TFW_UnicString._Length: integer; +begin + result := Length(val); +end; + +{$IFDEF UNIC} +function TFW_UnicString._ToDate: TDateTime; +begin + if not SysUtils.TryStrToDate(val, result) then + result := 0; +end; + +function TFW_UnicString._ToTime: TDateTime; +begin + if not SysUtils.TryStrToTime(val, result) then + result := 0; +end; + +function TFW_UnicString._ToDateTime: TDateTime; +begin + if not SysUtils.TryStrToDateTime(val, result) then + result := 0; +end; + +function TFW_UnicString._ToCurrency: Currency; +begin + if not SysUtils.TryStrToCurr(val, result) then + result := 0; +end; + +function TFW_UnicString._ToExtended: Extended; +begin + if not SysUtils.TryStrToFloat(val, result) then + result := 0; +end; + +function TFW_UnicString._ToDouble: Double; +begin + if not SysUtils.TryStrToFloat(val, result) then + result := 0; +end; + +function TFW_UnicString._ToCardinal: Cardinal; +var + aTemp: integer; +begin + if not SysUtils.TryStrToInt(val, aTemp) then + aTemp := 0; + result := aTemp; +end; + +function TFW_UnicString._ToShortInt: ShortInt; +var + aTemp: integer; +begin + if not SysUtils.TryStrToInt(val, aTemp) then + aTemp := 0; + result := aTemp; +end; + +function TFW_UnicString._ToSmallInt: SmallInt; +var + aTemp: integer; +begin + if not SysUtils.TryStrToInt(val, aTemp) then + aTemp := 0; + result := aTemp; +end; + +function TFW_UnicString._ToSingle: Single; +var + aTemp: integer; +begin + if not SysUtils.TryStrToInt(val, aTemp) then + aTemp := 0; + result := aTemp; +end; + +function TFW_UnicString._ToWord: Word; +var + aTemp: integer; +begin + if not SysUtils.TryStrToInt(val, aTemp) then + aTemp := 0; + result := aTemp; +end; + +function TFW_UnicString._ToInt32: Integer; +begin + if not SysUtils.TryStrToInt(val, result) then + result := 0; +end; + +function TFW_UnicString._ToInt64: Int64; +begin + if not SysUtils.TryStrToInt64(val, result) then + result := 0; +end; + +function TFW_UnicString._ToBoolean: Boolean; +begin + if not SysUtils.TryStrToBool(val, result) then + result := false; +end; + +function TFW_UnicString._ToByteBool: ByteBool; +var + aTemp: boolean; +begin + if not SysUtils.TryStrToBool(val, aTemp) then + aTemp := false; + result := aTemp; +end; + +function TFW_UnicString._ToLongBool: LongBool; +var + aTemp: boolean; +begin + if not SysUtils.TryStrToBool(val, aTemp) then + aTemp := false; + result := aTemp; +end; + +function TFW_UnicString._ToWordBool: WordBool; +var + aTemp: boolean; +begin + if not SysUtils.TryStrToBool(val, aTemp) then + aTemp := false; + result := aTemp; +end; + +{$IFNDEF PAXARM} +function TFW_UnicString._ToUTF8: UTF8String; +begin + result := System.UTF8Encode(val); +end; + +function TFW_UnicString._FromUTF8(const Value: UTF8String): String; +begin +{$IFDEF DRTTI} + result := UTF8ToString(Value); +{$ELSE} + result := System.UTF8Decode(Value); +{$ENDIF} +end; + +function TFW_UnicString._ToAnsi: AnsiString; +begin + result := AnsiString(Utf8ToAnsi(System.UTF8Encode(val))); +end; + +function TFW_UnicString._FromAnsi(const Value: AnsiString): String; +begin +{$IFDEF DRTTI} + result := UTF8ToString(Value); +{$ELSE} + result := System.UTF8Decode(AnsiToUtf8(String(Value))); +{$ENDIF} +end; +{$ENDIF} + +function TFW_UnicString._ToBase64: String; +begin + result := EncdDecd.EncodeString(val); +end; + +function TFW_UnicString._FromBase64(const Value: String): String; +begin + result := EncdDecd.DecodeString(Value); +end; + +function TFW_UnicString._ISOToBoolean: Boolean; +var + aObj: TFW_Boolean; +begin + aObj := TFW_Boolean.create; + try + result := aObj._FromISOString(val); + finally + FreeAndNil(aObj); + end; +end; + +function TFW_UnicString._ISOToDate: TDateTime; +var + aObj: TFW_DateTime; +begin + aObj := TFW_DateTime.create; + try + result := DateOf(aObj._FromISOString(val)); + finally + FreeAndNil(aObj); + end; +end; + +function TFW_UnicString._ISOToTime: TDateTime; +var + aObj: TFW_DateTime; +begin + aObj := TFW_DateTime.create; + try + result := TimeOf(aObj._FromISOString(val)); + finally + FreeAndNil(aObj); + end; +end; + +function TFW_UnicString._ISOToDateTime: TDateTime; +var + aObj: TFW_DateTime; +begin + aObj := TFW_DateTime.create; + try + result := aObj._FromISOString(val); + finally + FreeAndNil(aObj); + end; +end; + +function TFW_UnicString._ISOToCurrency: Currency; +var + aObj: TFW_Currency; +begin + aObj := TFW_Currency.create; + try + result := aObj._FromISOString(val); + finally + FreeAndNil(aObj); + end; +end; + +function TFW_UnicString._ISOToExtended: Extended; +var + aObj: TFW_Extended; +begin + aObj := TFW_Extended.create; + try + result := aObj._FromISOString(val); + finally + FreeAndNil(aObj); + end; +end; + +function TFW_UnicString._ISOToDouble: Double; +var + aObj: TFW_Double; +begin + aObj := TFW_Double.create; + try + result := aObj._FromISOString(val); + finally + FreeAndNil(aObj); + end; +end; + +function TFW_UnicString._Copy(Index: integer; Count: integer): String; +begin + result := System.Copy(val, Index, Count); +end; + +function TFW_UnicString._Delete(Index: integer; Count: integer): String; +begin + result := val; + System.Delete(result, Index, Count); +end; + +function TFW_UnicString._Trim: String; +begin + result := SysUtils.Trim(val); +end; + +function TFW_UnicString._TrimLeft: String; +begin + result := SysUtils.TrimLeft(val); +end; + +function TFW_UnicString._TrimRight: String; +begin + result := SysUtils.TrimRight(val); +end; + +function TFW_UnicString._Contains(const Value: String): boolean; +begin + result := System.Pos(value, val) <> 0; +end; + +function TFW_UnicString._Pos(const Value: String): integer; +begin + result := System.Pos(value, val); +end; + +function TFW_UnicString._IndexOf(const Value: String; const StartIndex: integer = 1): integer; +var + aTemp: String; +begin + if StartIndex <> 1 then + begin + aTemp := Copy(val, StartIndex, Length(val) - StartIndex + 1); + result := System.Pos(Value, aTemp); + if result <> 0 then + result := result + StartIndex - 1; + end else + begin + result := System.Pos(Value, val); + end; +end; + +function TFW_UnicString._Quoted(const Quote: WideChar = '"'): String; +begin + result := SysUtils.AnsiQuotedStr(val, Quote); +end; + +function TFW_UnicString._Dequoted(const Quote: WideChar = '"'): String; +begin + result := SysUtils.AnsiDequotedStr(val, Quote); +end; + +function TFW_UnicString._ToUpper: String; +begin + result := SysUtils.UpperCase(val); +end; + +function TFW_UnicString._ToLower: String; +begin + result := SysUtils.LowerCase(val); +end; + +function TFW_UnicString._Split(const Seperator: String): TStringDynArray; +var + i: Integer; + S: String; +begin + S := val; + SetLength(Result, 0); + i := 0; + while Pos(Seperator, S) > 0 do + begin + SetLength(Result, System.Length(Result) +1); + Result[i] := Copy(S, 1, Pos(Seperator, S) -1); + Inc(i); + S := Copy(S, Pos(Seperator, S) + Length(Seperator), Length(S)); + end; + SetLength(Result, System.Length(Result) + 1); + Result[i] := Copy(S, 1, Length(S)); +end; + +function TFW_UnicString._SplitEx(const Seperator: WideChar; const Quotes: Boolean; const Quote: WideChar = '"'; const TrimText: Boolean = false): TStringDynArray; +var + i : Integer; + a : integer; + aBuffer : String; + aQuote : Boolean; +begin + SetLength(Result, 0); + + aBuffer := ''; + a := -1; + aQuote := true; + for i := 1 to Length(val) do + begin + if (Quotes and (val[I] = Seperator) and aQuote) or + (not (Quotes) and (val[I] = Seperator)) then + begin + if TrimText then aBuffer := Trim(aBuffer); + if aBuffer = '' then aBuffer := Seperator; + if aBuffer[1] = Seperator then + aBuffer := Copy(aBuffer, 2, Length(aBuffer)); + inc(a); + SetLength(Result, a + 1); + result[a] := aBuffer; + aBuffer := ''; + end; + if Quotes then + begin + if val[I] = Quote then + begin + aQuote := not(aQuote); + Continue; + end; + if (val[i] <> Seperator) or + ((val[i] = Seperator) and (aQuote=false)) then + begin + aBuffer := aBuffer + val[i]; + end; + end else + begin + if val[i] <> Seperator then + aBuffer := aBuffer + val[i]; + end; + end; + if aBuffer <> '' then + begin + if TrimText then aBuffer := Trim(aBuffer); + inc(a); + SetLength(Result, a + 1); + result[a] := aBuffer; + end; +end; + +function TFW_UnicString._Join(const Value: TStringDynArray; const Seperator: String): String; +var + i: integer; +begin + result := ''; + for i := low(Value) to high(Value) do + begin + if i > 0 then + result := result + Seperator; + result := result + Value[i]; + end; +end; + +function TFW_UnicString._Insert(const Value: String; Index: integer): String; +begin + result := val; + Insert(Value, result, Index); +end; + +function TFW_UnicString._EndsWith(const Value: String): boolean; +begin + result := StrUtils.EndsText(Value, val); +end; + +function TFW_UnicString._StartsWith(const Value: String): boolean; +begin + result := StrUtils.StartsText(Value, val); +end; + +function TFW_UnicString._IsNumeric: boolean; +var + i : integer; + aLen : integer; + aChar: WideChar; +begin + result := true; + aLen := Length(val); + if aLen > 0 then + begin + for i := 1 to aLen - 1 do + begin + aChar := val[i]; + if not IsDigit(aChar) then + begin + result := false; + break; + end; + end; + end else + begin + result := false; + end; +end; + +function TFW_UnicString._IsAlpha: boolean; +var + i : integer; + aLen : integer; + aChar: WideChar; +begin + result := true; + aLen := Length(val); + if aLen > 0 then + begin + for i := 1 to aLen - 1 do + begin + aChar := val[i]; + if not IsAlpha(aChar) then + begin + result := false; + break; + end; + end; + end else + begin + result := false; + end; +end; + +function TFW_UnicString._IsAlphaNumeric: boolean; +var + i : integer; + aLen : integer; + aChar: WideChar; +begin + result := true; + aLen := Length(val); + if aLen > 0 then + begin + for i := 1 to aLen - 1 do + begin + aChar := val[i]; + if not ByteInSet(aChar, IdsSet) then + begin + result := false; + break; + end; + end; + end else + begin + result := false; + end; +end; + +function TFW_UnicString._Match(const Mask: String): boolean; +begin + result := Masks.MatchesMask(val, Mask); +end; + +function TFW_UnicString._Reverse: String; +begin + result := StrUtils.ReverseString(val); +end; + +function TFW_UnicString._Left(const Length: Integer): String; +begin + result := StrUtils.LeftStr(val, Length); +end; + +function TFW_UnicString._Right(const Length: Integer): String; +begin + result := StrUtils.RightStr(val, Length); +end; + +{$IFNDEF PAXARM} +function TFW_UnicString._AppendA(const Value: AnsiString): String; +begin +{$IFDEF DRTTI} + result := val + String(AnsiToUtf8(UTF8ToString(Value))); +{$ELSE} + result := val + String(AnsiToUtf8(UTF8Decode(Value))); +{$ENDIF} +end; + +function TFW_UnicString._AppendLineA(const Value: AnsiString): String; +begin +{$IFDEF DRTTI} + result := val + String(AnsiToUtf8(UTF8ToString(Value))) + #13#10; +{$ELSE} + result := val + String(AnsiToUtf8(UTF8Decode(Value))) + #13#10; +{$ENDIF} +end; +{$ENDIF} + +function TFW_UnicString._AppendW(const Value: String): String; +begin + result := val + Value; +end; + +function TFW_UnicString._AppendLineW(const Value: String): String; +begin + result := val + Value + #13#10; +end; + +function TFW_UnicString._Lastchar: WideChar; +var + aResult: PWideChar; +begin + aResult := AnsiLastChar(val); + if aResult <> nil then + result := aResult^ + else + result := #0; +end; + +function TFW_UnicString._LastDelimiter(const Delimiters: String = ';'): Integer; +begin + result := Sysutils.LastDelimiter(Delimiters, val); +end; + +function TFW_UnicString._FindDelimiter(const Delimiters: String = ';'; const StartIdx: integer = 1): Integer; +begin + result := FindDelimiter(Delimiters, val, StartIdx); +end; + +function TFW_UnicString._StringOfChar(const Ch: WideChar; const Count: integer): String; +begin + result := StringOfChar(Ch, Count) +end; + +{$ENDIF} + +// TFW_Array ------------------------------------------------------------------- + +constructor TFW_Array.Create; +begin + inherited; + P := nil; +end; + +destructor TFW_Array.Destroy; +begin + Clear; + inherited; +end; + +function TFW_Array.GetBound(I: Integer): Integer; +var + A: Pointer; +begin + result := -1; + if P = nil then + begin + result := 0; + Exit; + end; + + case I of + 1: result := _DynArrayLength(P); + 2: result := _DynArrayLength(DynarrayPointer(P)[0]); + 3: begin + A := DynarrayPointer(P)[0]; + result := _DynArrayLength(DynarrayPointer(A)[0]); + end; + end; +end; + +function TFW_Array.GetLength: Integer; +begin + result := GetBound(1); +end; + +procedure TFW_Array.SetLength(const Bounds: array of Integer); +begin + NBounds := System.Length(Bounds); + case NBounds of + 1: _DynarraySetLength(P, Bounds[0], + ElFinalTypeID, ElTypeID, ElSize); + 2: _DynarraySetLength2(P, Bounds[0], Bounds[1], + ElFinalTypeID, ElTypeID, ElSize); + 3: _DynarraySetLength3(P, Bounds[0], Bounds[1], Bounds[2], + ElFinalTypeID, ElTypeID, ElSize); + end; +end; + +function TFW_Array.AddressOfElement(const Indexes: array of Integer): Pointer; +var + L: Integer; +begin + L := System.Length(Indexes); + case L of + 1: result := ShiftPointer(P, ElSize * Indexes[0]); + 2: + begin + result := ShiftPointer(P, SizeOf(Pointer) * Indexes[0]); + if Pointer(result^) = nil then + begin + result := nil; + Exit; + end; + result := ShiftPointer(Pointer(result^), ElSize * Indexes[1]); + end; + 3: + begin + result := ShiftPointer(P, SizeOf(Pointer) * Indexes[0]); + if Pointer(result^) = nil then + begin + result := nil; + Exit; + end; + result := ShiftPointer(Pointer(result^), SizeOf(Pointer) * Indexes[1]); + if Pointer(result^) = nil then + begin + result := nil; + Exit; + end; + result := ShiftPointer(Pointer(result^), ElSize * Indexes[2]); + end; + else + raise Exception.Create(errInternalError); + end; +end; + +procedure TFW_Array.Put(const Indexes: array of Integer; const Value: Variant); +var + Q: Pointer; +begin + Q := AddressOfElement(Indexes); + PutVariantValue(Q, ElFinalTypeID, Value); +end; + +function TFW_Array.Get(const Indexes: array of Integer): Variant; +var + Q: Pointer; +begin + Q := AddressOfElement(Indexes); + result := GetVariantValue(Q, ElFinalTypeID); +end; + +procedure TFW_Array.Clear; +begin + case NBounds of + 1: _DynarrayClr1(P, ElFinalTypeId, ElTypeId, ElSize); + 2: _DynarrayClr2(P, ElFinalTypeId, ElTypeId, ElSize); + 3: _DynarrayClr3(P, ElFinalTypeId, ElTypeId, ElSize); + end; +end; + +procedure _InitFWArray(P: Pointer; + A: TFW_Array; + NBounds: Integer; + ElFinalTypeId: Integer; + ElTypeId: Integer; + ElSize: Integer; + DecRefCount: Integer); pascal; +begin + A.prog := P; + A.NBounds := NBounds; + A.ElFinalTypeId := ElFinalTypeId; + A.ElTypeId := ElTypeId; + A.ElSize := ElSize; + if DecRefCount > 0 then + A.RefCount := A.RefCount - 1; +end; + +function _FWArrayLength(A: TFW_Array): Integer; +begin + result := A.GetLength; +end; + +const + ByRef = true; + +procedure Register_Framework(st: TBaseSymbolTable); +var + H, G, H_Sub: Integer; +begin + with st do + begin + H := RegisterNamespace(0, 'PaxCompilerFramework'); + H_PaxCompilerFramework := H; + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_ToFWObject); + Id_ToFWObject := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); //runner + RegisterParameter(H_Sub, typePOINTER, Unassigned); //adr + RegisterParameter(H_Sub, typeINTEGER, Unassigned); //kind + RegisterParameter(H_Sub, typeINTEGER, Unassigned); //ft + RegisterParameter(H_Sub, typeINTEGER, Unassigned); //type_id + RegisterParameter(H_Sub, typePOINTER, Unassigned, ByRef); //ret object + + G := RegisterClassType(H, TFW_Object); + H_TFW_Object := G; + +{$IFNDEF PAXARM} + RegisterDynamicArrayType(H, 'TAnsiStringDynArray', typeANSISTRING); +{$ENDIF} + RegisterDynamicArrayType(H, 'TStringDynArray', typeUNICSTRING); + + G := RegisterClassType(H, TFW_Boolean); + H_TFW_Boolean := G; + RegisterHeader(G, 'function ToString: String; override;', @TFW_Boolean._ToString); + RegisterHeader(G, 'function Equals(const Value: Boolean): boolean;', @TFW_Boolean._Equals); + RegisterHeader(G, 'function ToInt32: integer;', @TFW_Boolean._toInt32); + RegisterHeader(G, 'function ToISOString: String;', @TFW_Boolean._ToISOString); +{$IFNDEF PAXARM} + RegisterHeader(G, 'function ToISOAnsiString: AnsiString;', @TFW_Boolean._ToISOAnsiString); + RegisterHeader(G, 'function FromISOString(const Value: AnsiString): Boolean; overload;', @TFW_Boolean._FromISOAnsiString); +{$ENDIF} + RegisterHeader(G, 'function FromISOString(const Value: String): Boolean; overload;', @TFW_Boolean._FromISOString); + + G := RegisterClassType(H, TFW_ByteBool); + H_TFW_ByteBool := G; + RegisterHeader(G, 'function ToString: String; override;', @TFW_ByteBool._ToString); + RegisterHeader(G, 'function Equals(const Value: ByteBool): boolean;', @TFW_ByteBool._Equals); + RegisterHeader(G, 'function ToInt32: integer;', @TFW_ByteBool._toInt32); + + G := RegisterClassType(H, TFW_WordBool); + H_TFW_WordBool := G; + RegisterHeader(G, 'function ToString: String; override;', @TFW_WordBool._ToString); + RegisterHeader(G, 'function Equals(const Value: WordBool): boolean;', @TFW_WordBool._Equals); + RegisterHeader(G, 'function ToInt32: integer;', @TFW_WordBool._toInt32); + + G := RegisterClassType(H, TFW_LongBool); + H_TFW_LongBool := G; + RegisterHeader(G, 'function ToString: String; override;', @TFW_LongBool._ToString); + RegisterHeader(G, 'function Equals(const Value: LongBool): boolean;', @TFW_LongBool._Equals); + RegisterHeader(G, 'function ToInt32: integer;', @TFW_LongBool._toInt32); + + G := RegisterClassType(H, TFW_Byte); + H_TFW_Byte := G; + RegisterHeader(G, 'function ToString: String; override;', @TFW_Byte._ToString); + RegisterHeader(G, 'function Equals(const Value: Byte): boolean;', @TFW_Byte._Equals); + + G := RegisterClassType(H, TFW_SmallInt); + H_TFW_SmallInt := G; + RegisterHeader(G, 'function ToString: String; override;', @TFW_SmallInt._ToString); + RegisterHeader(G, 'function Equals(const Value: SmallInt): boolean;', @TFW_SmallInt._Equals); + RegisterHeader(G, 'function MinValue: SmallInt;', @TFW_SmallInt._MinValue); + RegisterHeader(G, 'function MaxValue: SmallInt;', @TFW_SmallInt._MaxValue); + + G := RegisterClassType(H, TFW_ShortInt); + H_TFW_ShortInt := G; + RegisterHeader(G, 'function ToString: String; override;', @TFW_ShortInt._ToString); + RegisterHeader(G, 'function Equals(const Value: ShortInt): boolean;', @TFW_ShortInt._Equals); + RegisterHeader(G, 'function MinValue: ShortInt;', @TFW_ShortInt._MinValue); + RegisterHeader(G, 'function MaxValue: ShortInt;', @TFW_ShortInt._MaxValue); + + G := RegisterClassType(H, TFW_Word); + H_TFW_Word := G; + RegisterHeader(G, 'function ToString: String; override;', @TFW_Word._ToString); + RegisterHeader(G, 'function Equals(const Value: Word): boolean;', @TFW_Word._Equals); + RegisterHeader(G, 'function MinValue: Word;', @TFW_Word._MinValue); + RegisterHeader(G, 'function MaxValue: Word;', @TFW_Word._MaxValue); + + G := RegisterClassType(H, TFW_Cardinal); + H_TFW_Cardinal := G; + RegisterHeader(G, 'function ToString: String; override;', @TFW_Cardinal._ToString); + RegisterHeader(G, 'function Equals(const Value: Cardinal): boolean;', @TFW_Cardinal._Equals); + RegisterHeader(G, 'function MinValue: Cardinal;', @TFW_Cardinal._MinValue); + RegisterHeader(G, 'function MaxValue: Cardinal;', @TFW_Cardinal._MaxValue); + + G := RegisterClassType(H, TFW_Double); + H_TFW_Double := G; + RegisterHeader(G, 'function ToString: String; override;', @TFW_Double._ToString); + RegisterHeader(G, 'function ToString(const Format: String): String; overload;', @TFW_Double._ToStringFormat); + RegisterHeader(G, 'function Equals(const Value: Double): boolean;', @TFW_Double._Equals); +{$IFDEF UNIC} + RegisterHeader(G, 'function ToISOString: String;', @TFW_Double._ToISOString); +{$IFNDEF PAXARM} + RegisterHeader(G, 'function ToISOAnsiString: AnsiString;', @TFW_Double._ToISOAnsiString); + RegisterHeader(G, 'function FromISOString(const Value: AnsiString): double; overload;', @TFW_Double._FromISOAnsiString); +{$ENDIF} + RegisterHeader(G, 'function FromISOString(const Value: String): double; overload;', @TFW_Double._FromISOString); + RegisterHeader(G, 'function RoundTo(const Digit: integer): double;', @TFW_Double._RoundTo); +{$ENDIF} + RegisterHeader(G, 'function Round: Int64;', @TFW_Double._Round); + RegisterHeader(G, 'function Trunc: Int64;', @TFW_Double._Trunc); + RegisterHeader(G, 'function Floor: Integer;', @TFW_Double._Floor); + RegisterHeader(G, 'function Min(const Value: double): double;', @TFW_Double._Min); + RegisterHeader(G, 'function Max(const Value: double): double;', @TFW_Double._Max); + + G := RegisterClassType(H, TFW_Single); + H_TFW_Single := G; + RegisterHeader(G, 'function ToString: String; override;', @TFW_Single._ToString); + RegisterHeader(G, 'function Equals(const Value: Single): boolean;', @TFW_Single._Equals); + RegisterHeader(G, 'function Min(const Value: Single): Single;', @TFW_Single._Min); + RegisterHeader(G, 'function Max(const Value: Single): Single;', @TFW_Single._Max); + + G := RegisterClassType(H, TFW_Extended); + H_TFW_Extended := G; + RegisterHeader(G, 'function ToString: String; override;', @TFW_Extended._ToString); + RegisterHeader(G, 'function ToString(const Format: String): String; overload;', @TFW_Extended._ToStringFormat); + RegisterHeader(G, 'function Equals(const Value: Extended): boolean;', @TFW_Extended._Equals); +{$IFDEF UNIC} + RegisterHeader(G, 'function ToISOString: String;', @TFW_Extended._ToISOString); +{$IFNDEF PAXARM} + RegisterHeader(G, 'function ToISOAnsiString: AnsiString;', @TFW_Extended._ToISOAnsiString); + RegisterHeader(G, 'function FromISOString(const Value: AnsiString): Extended; overload;', @TFW_Extended._FromISOAnsiString); +{$ENDIF} + RegisterHeader(G, 'function FromISOString(const Value: String): Extended; overload;', @TFW_Extended._FromISOString); + RegisterHeader(G, 'function RoundTo(const Digit: integer): Extended;', @TFW_Extended._RoundTo); +{$ENDIF} + RegisterHeader(G, 'function Round: Int64;', @TFW_Extended._Round); + RegisterHeader(G, 'function Trunc: Int64;', @TFW_Extended._Trunc); + RegisterHeader(G, 'function Floor: Integer;', @TFW_Extended._Floor); + RegisterHeader(G, 'function Min(const Value: Extended): Extended;', @TFW_Extended._Min); + RegisterHeader(G, 'function Max(const Value: Extended): Extended;', @TFW_Extended._Max); + + G := RegisterClassType(H, TFW_Currency); + H_TFW_Currency := G; + RegisterHeader(G, 'function ToString: String; override;', @TFW_Currency._ToString); + RegisterHeader(G, 'function ToString(const Format: String): String; overload;', @TFW_Currency._ToStringFormat); + RegisterHeader(G, 'function Equals(const Value: Currency): boolean;', @TFW_Currency._Equals); +{$IFDEF UNIC} + RegisterHeader(G, 'function ToISOString: String;', @TFW_Currency._ToISOString); +{$IFNDEF PAXARM} + RegisterHeader(G, 'function ToISOAnsiString: AnsiString;', @TFW_Currency._ToISOAnsiString); + RegisterHeader(G, 'function FromISOString(const Value: AnsiString): Currency; overload;', @TFW_Currency._FromISOAnsiString); +{$ENDIF} + RegisterHeader(G, 'function FromISOString(const Value: String): Currency; overload;', @TFW_Currency._FromISOString); + RegisterHeader(G, 'function RoundTo(const Digit: integer): Currency;', @TFW_Currency._RoundTo); +{$ENDIF} + RegisterHeader(G, 'function Round: Int64;', @TFW_Currency._Round); + RegisterHeader(G, 'function Trunc: Int64;', @TFW_Currency._Trunc); + RegisterHeader(G, 'function Floor: Integer;', @TFW_Currency._Floor); + RegisterHeader(G, 'function Min(const Value: Currency): Currency;', @TFW_Currency._Min); + RegisterHeader(G, 'function Max(const Value: Currency): Currency;', @TFW_Currency._Max); + + G := RegisterClassType(H, TFW_Integer); + H_TFW_Integer := G; + RegisterHeader(G, 'function ToString: String; override;', @TFW_Integer._ToString); + RegisterHeader(G, 'function Equals(const Value: Integer): boolean;', @TFW_Integer._Equals); + RegisterHeader(G, 'function ToDate: TDateTime; override;', @TFW_Integer._ToDate); + RegisterHeader(G, 'function ToHex(Digits: Integer = 8): String;', @TFW_Integer._ToHex); + RegisterHeader(G, 'function FromHex(const Value: String): Integer; overload;', @TFW_Integer._FromHex); +{$IFNDEF PAXARM} + RegisterHeader(G, 'function FromHex(const Value: AnsiString): Integer; overload;', @TFW_Integer._FromHexAnsi); +{$ENDIF} + RegisterHeader(G, 'function Min(const Value: Integer): Integer;', @TFW_Integer._Min); + RegisterHeader(G, 'function Max(const Value: Integer): Integer;', @TFW_Integer._Max); + RegisterHeader(G, 'function MinValue: Integer;', @TFW_Integer._MinValue); + RegisterHeader(G, 'function MaxValue: Integer;', @TFW_Integer._MaxValue); + + G := RegisterClassType(H, TFW_Int64); + H_TFW_Int64 := G; + RegisterHeader(G, 'function ToString: String; override;', @TFW_Int64._ToString); + RegisterHeader(G, 'function Equals(const Value: Int64): boolean;', @TFW_Int64._Equals); + RegisterHeader(G, 'function ToDate: TDateTime; override;', @TFW_Int64._ToDate); + RegisterHeader(G, 'function ToHex(Digits: Integer = 8): String;', @TFW_Int64._ToHex); + RegisterHeader(G, 'function FromHex(const Value: String): Int64; overload;', @TFW_Int64._FromHex); +{$IFNDEF PAXARM} + RegisterHeader(G, 'function FromHex(const Value: AnsiString): Int64; overload;', @TFW_Int64._FromHexAnsi); +{$ENDIF} + RegisterHeader(G, 'function Min(const Value: Int64): Int64;', @TFW_Int64._Min); + RegisterHeader(G, 'function Max(const Value: Int64): Int64;', @TFW_Int64._Max); + RegisterHeader(G, 'function MinValue: Int64;', @TFW_Int64._MinValue); + RegisterHeader(G, 'function MaxValue: Int64;', @TFW_Int64._MaxValue); + + G := RegisterClassType(H, TFW_Variant); + H_TFW_Variant := G; + RegisterHeader(G, 'function ToString: String; override;', @TFW_Variant._ToString); + RegisterHeader(G, 'function Equals(const Value: Variant): boolean;', @TFW_Variant._Equals); + RegisterHeader(G, 'function ToDate: TDateTime;', @TFW_Variant._ToDate); + RegisterHeader(G, 'function ToDateTime: TDateTime;', @TFW_Variant._ToDateTime); + RegisterHeader(G, 'function ToTime: TDateTime;', @TFW_Variant._ToTime); + + RegisterHeader(G, 'function Clear: Variant;', @TFW_Variant._Clear); + RegisterHeader(G, 'function IsType: TVarType;', @TFW_Variant._IsType); + RegisterHeader(G, 'function IsNull: boolean;', @TFW_Variant._IsNull); + RegisterHeader(G, 'function IsEmpty: boolean;', @TFW_Variant._IsEmpty); +{$IFDEF VARIANTS} + RegisterHeader(G, 'function IsEmptyParam: boolean;', @TFW_Variant._IsEmptyParam); + RegisterHeader(G, 'function IsError: boolean;', @TFW_Variant._IsError); + RegisterHeader(G, 'function IsArray: boolean;', @TFW_Variant._IsArray); + RegisterHeader(G, 'function IsFilled: boolean;', @TFW_Variant._IsFilled); +{$ENDIF} + RegisterHeader(G, 'function Null: Variant;', @TFW_Variant._Null); + RegisterHeader(G, 'function Unassigned: Variant;', @TFW_Variant._Unassigned); + RegisterHeader(G, 'function DimCount: Integer;', @TFW_Variant._DimCount); + RegisterHeader(G, 'function LowBound(const Dim: integer): integer;', @TFW_Variant._LowBound); + RegisterHeader(G, 'function HighBound(const Dim: integer): integer;', @TFW_Variant._HighBound); + + G := RegisterClassType(H, TFW_DateTime); + H_TFW_DateTime := G; + RegisterHeader(G, 'function ToString: String; override;', @TFW_DateTime._ToString); + RegisterHeader(G, 'function ToString(const Format: String): String; overload;', @TFW_DateTime._ToStringFormat); + RegisterHeader(G, 'function Equals(const Value: TDateTime): boolean;', @TFW_DateTime._Equals); + RegisterHeader(G, 'function ToInt32: Integer;', @TFW_DateTime._ToInt32); + RegisterHeader(G, 'function ToISOString: String;', @TFW_DateTime._ToStringISO); +{$IFDEF UNIC} +{$IFNDEF PAXARM} + RegisterHeader(G, 'function ToISOAnsiString: AnsiString;', @TFW_DateTime._ToAnsiStringISO); +{$ENDIF} +{$ENDIF} + RegisterHeader(G, 'function FromISOString(const Value: String): TDateTime; overload;', @TFW_DateTime._FromISOString); +{$IFNDEF PAXARM} + RegisterHeader(G, 'function FromISOString(const Value: AnsiString): TDateTime; overload;', @TFW_DateTime._FromISOAnsiString); +{$ENDIF} + + RegisterHeader(G, 'function IsDate: boolean;', @TFW_DateTime._IsDate); + RegisterHeader(G, 'function IsDateTime: boolean;', @TFW_DateTime._IsDateTime); + RegisterHeader(G, 'function IsTime: boolean;', @TFW_DateTime._IsTime); + + RegisterHeader(G, 'function Date: TDateTime;', @TFW_DateTime._Date); + RegisterHeader(G, 'function Time: TDateTime;', @TFW_DateTime._Time); + RegisterHeader(G, 'function Now: TDateTime;', @TFW_DateTime._Now); + + RegisterHeader(G, 'function IsInLeapYear: boolean;', @TFW_DateTime._IsInLeapYear); + RegisterHeader(G, 'function DateOf: TDateTime;', @TFW_DateTime._DateOf); + RegisterHeader(G, 'function TimeOf: TDateTime;', @TFW_DateTime._TimeOf); + RegisterHeader(G, 'function YearOf: Word;', @TFW_DateTime._YearOf); + RegisterHeader(G, 'function MonthOf: Word;', @TFW_DateTime._MonthOf); + RegisterHeader(G, 'function DayOf: Word;', @TFW_DateTime._DayOf); + RegisterHeader(G, 'function HourOf: Word;', @TFW_DateTime._HourOf); + RegisterHeader(G, 'function MinuteOf: Word;', @TFW_DateTime._MinuteOf); + RegisterHeader(G, 'function SecondOf: Word;', @TFW_DateTime._SecondOf); + RegisterHeader(G, 'function MilliSecondOf: Word;', @TFW_DateTime._MilliSecondOf); + RegisterHeader(G, 'function WeeksInYear: Word;', @TFW_DateTime._WeeksInYear); + RegisterHeader(G, 'function DaysInYear: Word;', @TFW_DateTime._DaysInYear); + RegisterHeader(G, 'function Today: TDateTime;', @TFW_DateTime._Today); + RegisterHeader(G, 'function Yesterday: TDateTime;', @TFW_DateTime._Yesterday); + RegisterHeader(G, 'function Tomorrow: TDateTime;', @TFW_DateTime._Tomorrow); + RegisterHeader(G, 'function YearSpan(const Value: TDateTime): Double;', @TFW_DateTime._YearSpan); + RegisterHeader(G, 'function MonthSpan(const Value: TDateTime): Double;', @TFW_DateTime._MonthSpan); + RegisterHeader(G, 'function WeekSpan(const Value: TDateTime): Double;', @TFW_DateTime._WeekSpan); + RegisterHeader(G, 'function DaySpan(const Value: TDateTime): Double;', @TFW_DateTime._DaySpan); + RegisterHeader(G, 'function HourSpan(const Value: TDateTime): Double;', @TFW_DateTime._HourSpan); + RegisterHeader(G, 'function MinuteSpan(const Value: TDateTime): Double;', @TFW_DateTime._MinuteSpan); + RegisterHeader(G, 'function SecondSpan(const Value: TDateTime): Double;', @TFW_DateTime._SecondSpan); + RegisterHeader(G, 'function MilliSecondSpan(const Value: TDateTime): Double;', @TFW_DateTime._MilliSecondSpan); + RegisterHeader(G, 'function AddYears(const ANumberOfYears: Integer = 1): TDateTime;', @TFW_DateTime._AddYears); + RegisterHeader(G, 'function AddWeeks(const ANumberOfWeeks: Integer = 1): TDateTime;', @TFW_DateTime._AddWeeks); + RegisterHeader(G, 'function AddDays(const ANumberOfDays: Integer = 1): TDateTime;', @TFW_DateTime._AddDays); + RegisterHeader(G, 'function AddHours(const ANumberOfHours: Int64 = 1): TDateTime;', @TFW_DateTime._AddHours); + RegisterHeader(G, 'function AddMinutes(const ANumberOfMinutes: Int64 = 1): TDateTime;', @TFW_DateTime._AddMinutes); + RegisterHeader(G, 'function AddSeconds(const ANumberOfSeconds: Int64 = 1): TDateTime;', @TFW_DateTime._AddSeconds); + RegisterHeader(G, 'function AddMilliSeconds(const ANumberOfMilliSeconds: Int64 = 1): TDateTime;', @TFW_DateTime._AddMilliSeconds); +{$IFDEF UNIC} + RegisterHeader(G, 'function EncodeDateTime(const AYear, AMonth, ADay, AHour, AMinute, ASecond, AMilliSecond: Word): TDateTime;', @TFW_DateTime._EncodeDateTime); +{$ENDIF} + RegisterHeader(G, 'function EncodeDate(const AYear, AMonth, ADay: Word): TDateTime;', @TFW_DateTime._EncodeDate); + RegisterHeader(G, 'function EncodeTime(const AHour, AMinute, ASecond, AMilliSecond: Word): TDateTime;', @TFW_DateTime._EncodeTime); + RegisterHeader(G, 'function Min(const Value: TDateTime): TDateTime;', @TFW_DateTime._Min); + RegisterHeader(G, 'function Max(const Value: TDateTime): TDateTime;', @TFW_DateTime._Max); + RegisterHeader(G, 'function MinValue: TDateTime;', @TFW_DateTime._MinValue); + RegisterHeader(G, 'function MaxValue: TDateTime;', @TFW_DateTime._MaxValue); +{$IFNDEF PAXARM} + G := RegisterClassType(H, TFW_AnsiChar); + H_TFW_AnsiChar := G; + RegisterHeader(G, 'function ToString: String; override;', @TFW_AnsiChar._ToString); + RegisterHeader(G, 'function Equals(const Value: AnsiChar): boolean;', @TFW_AnsiChar._Equals); +{$ENDIF} + G := RegisterClassType(H, TFW_WideChar); + H_TFW_WideChar := G; + RegisterHeader(G, 'function ToString: String; override;', @TFW_WideChar._ToString); + RegisterHeader(G, 'function Equals(const Value: WideChar): boolean;', @TFW_WideChar._Equals); +{$IFNDEF PAXARM} + G := RegisterClassType(H, TFW_AnsiString); + H_TFW_AnsiString := G; + RegisterHeader(G, 'function ToString: String; override;', @TFW_AnsiString._ToString); + RegisterHeader(G, 'function Replace(const OldPattern: String; const NewPattern: String): String;', @TFW_AnsiString._Replace); + RegisterHeader(G, 'function Equals(const Value: AnsiString): boolean;', @TFW_AnsiString._Equals); + RegisterHeader(G, 'function Length: integer;', @TFW_AnsiString._Length); +{$IFDEF UNIC} + RegisterHeader(G, 'function ToUTF8: UTF8String;', @TFW_AnsiString._ToUTF8); + RegisterHeader(G, 'function FromUTF8(const Value: UTF8String): AnsiString;', @TFW_AnsiString._FromUTF8); + RegisterHeader(G, 'function ToUnicode: UnicodeString;', @TFW_AnsiString._ToUnicode); + RegisterHeader(G, 'function FromUnicode(const Value: UnicodeString): AnsiString;', @TFW_AnsiString._FromUniCode); + RegisterHeader(G, 'function ToBase64: AnsiString;', @TFW_AnsiString._ToBase64); + RegisterHeader(G, 'function FromBase64(const Value: AnsiString): AnsiString;', @TFW_AnsiString._FromBase64); + + RegisterHeader(G, 'function ToDate: TDateTime;', @TFW_AnsiString._ToDate); + RegisterHeader(G, 'function ToTime: TDateTime;', @TFW_AnsiString._ToTime); + RegisterHeader(G, 'function ToDateTime: TDateTime;', @TFW_AnsiString._ToDateTime); + RegisterHeader(G, 'function ToCurrency: Currency;', @TFW_AnsiString._ToCurrency); + RegisterHeader(G, 'function ToExtended: Extended;', @TFW_AnsiString._ToExtended); + RegisterHeader(G, 'function ToDouble: Double;', @TFW_AnsiString._ToDouble); + RegisterHeader(G, 'function ToCardinal: Cardinal;', @TFW_AnsiString._ToCardinal); + RegisterHeader(G, 'function ToShortInt: ShortInt;', @TFW_AnsiString._ToShortInt); + RegisterHeader(G, 'function ToSmallInt: SmallInt;', @TFW_AnsiString._ToSmallInt); + RegisterHeader(G, 'function ToSingle: Single;', @TFW_AnsiString._ToSingle); + RegisterHeader(G, 'function ToWord: Word;', @TFW_AnsiString._ToWord); + RegisterHeader(G, 'function ToInt32: Integer;', @TFW_AnsiString._ToInt32); + RegisterHeader(G, 'function ToInt64: Int64;', @TFW_AnsiString._ToInt64); + RegisterHeader(G, 'function ToBoolean: Boolean;', @TFW_AnsiString._ToBoolean); + RegisterHeader(G, 'function ToByteBool: ByteBool;', @TFW_AnsiString._ToByteBool); + RegisterHeader(G, 'function ToLongBool: LongBool;', @TFW_AnsiString._ToLongBool); + RegisterHeader(G, 'function ToWordBool: WordBool;', @TFW_AnsiString._ToWordBool); + + RegisterHeader(G, 'function ISOToBoolean: Boolean;', @TFW_AnsiString._ISOToBoolean); + RegisterHeader(G, 'function ISOToDate: TDateTime;', @TFW_AnsiString._ISOToDate); + RegisterHeader(G, 'function ISOToTime: TDateTime;', @TFW_AnsiString._ISOToTime); + RegisterHeader(G, 'function ISOToDateTime: TDateTime;', @TFW_AnsiString._ISOToDateTime); + RegisterHeader(G, 'function ISOToCurrency: Currency;', @TFW_AnsiString._ISOToCurrency); + RegisterHeader(G, 'function ISOToExtended: Extended;', @TFW_AnsiString._ISOToExtended); + RegisterHeader(G, 'function ISOToDouble: Double;', @TFW_AnsiString._ISOToDouble); + + RegisterHeader(G, 'function Copy(Index: integer; Count: integer): AnsiString;', @TFW_AnsiString._Copy); + RegisterHeader(G, 'function Delete(Index: integer; Count: integer): AnsiString;', @TFW_AnsiString._Delete); + RegisterHeader(G, 'function Trim: AnsiString;', @TFW_AnsiString._Trim); + RegisterHeader(G, 'function TrimLeft: AnsiString;', @TFW_AnsiString._TrimLeft); + RegisterHeader(G, 'function TrimRight: AnsiString;', @TFW_AnsiString._TrimRight); + RegisterHeader(G, 'function Contains(const Value: AnsiString): boolean;', @TFW_AnsiString._Contains); + RegisterHeader(G, 'function Pos(const Value: AnsiString): integer;', @TFW_AnsiString._Pos); + RegisterHeader(G, 'function IndexOf(const Value: AnsiString; const StartIndex: integer = 0): integer;', @TFW_AnsiString._IndexOf); + RegisterHeader(G, 'function Quoted(const Quote: AnsiChar = ' + #39 + '"' + #39 + '): AnsiString;', @TFW_AnsiString._Quoted); + RegisterHeader(G, 'function Dequoted(const Quote: AnsiChar = ' + #39 + '"' + #39 + '): AnsiString;', @TFW_AnsiString._Dequoted); + RegisterHeader(G, 'function ToUpper: AnsiString;', @TFW_AnsiString._ToUpper); + RegisterHeader(G, 'function ToLower: AnsiString;', @TFW_AnsiString._ToLower); + RegisterHeader(G, 'function Split(const Seperator: AnsiString): TAnsiStringDynArray; overload;', @TFW_AnsiString._Split); + RegisterHeader(G, 'function Split(const Seperator: AnsiChar; const Quotes: Boolean; const Quote: AnsiChar = ' + #39 + '"' + #39 + '; const TrimText: Boolean = false): TAnsiStringDynArray; overload;', @TFW_AnsiString._SplitEx); + RegisterHeader(G, 'function Join(const Value: TAnsiStringDynArray; const Seperator: AnsiString): AnsiString;', @TFW_UnicString._Join); + RegisterHeader(G, 'function Insert(const Value: AnsiString; Index: integer): AnsiString;', @TFW_AnsiString._Insert); + RegisterHeader(G, 'function IsNumeric: boolean;', @TFW_AnsiString._IsNumeric); + RegisterHeader(G, 'function IsAlpha: boolean;', @TFW_AnsiString._IsAlpha); + RegisterHeader(G, 'function IsAlphaNumeric: boolean;', @TFW_AnsiString._IsAlphaNumeric); + RegisterHeader(G, 'function Match(const Mask: String): boolean;', @TFW_AnsiString._Match); + RegisterHeader(G, 'function EndsWith(const Value: AnsiString): boolean;', @TFW_AnsiString._EndsWith); + RegisterHeader(G, 'function StartsWith(const Value: AnsiString): boolean;', @TFW_AnsiString._StartsWith); + RegisterHeader(G, 'function Reverse: AnsiString;', @TFW_AnsiString._Reverse); + RegisterHeader(G, 'function Left(const Length: Integer): AnsiString;', @TFW_AnsiString._Left); + RegisterHeader(G, 'function Right(const Length: Integer): AnsiString;', @TFW_AnsiString._Right); + RegisterHeader(G, 'function Append(const Value: AnsiString): AnsiString; overload;', @TFW_AnsiString._AppendA); + RegisterHeader(G, 'function Append(const Value: String): AnsiString; overload;', @TFW_AnsiString._AppendW); + RegisterHeader(G, 'function AppendLine(const Value: AnsiString): AnsiString; overload;', @TFW_AnsiString._AppendLineA); + RegisterHeader(G, 'function AppendLine(const Value: String): AnsiString; overload;', @TFW_AnsiString._AppendLineW); + RegisterHeader(G, 'function Lastchar: AnsiChar;', @TFW_AnsiString._Lastchar); + RegisterHeader(G, 'function LastDelimiter(const Delimiters: AnsiString = ' + #39 + ';' + #39 + '): Integer;', @TFW_AnsiString._LastDelimiter); + RegisterHeader(G, 'function FindDelimiter(const Delimiters: AnsiString = ' + #39 + ';' + #39 + '; const StartIdx: integer = 1): Integer;', @TFW_AnsiString._FindDelimiter); + RegisterHeader(G, 'function StringOfChar(const Ch: AnsiChar; const Count: integer): AnsiString;', @TFW_AnsiString._StringOfChar); +{$ENDIF} +{$ENDIF} + + G := RegisterClassType(H, TFW_UnicString); + H_TFW_UnicString := G; + RegisterHeader(G, 'constructor Create;', @TFW_UnicString.Create); + RegisterHeader(G, 'function ToString: String; override;', @TFW_UnicString._ToString); + RegisterHeader(G, 'function Replace(const OldPattern: String; const NewPattern: String): String;', @TFW_UnicString._Replace); + RegisterHeader(G, 'function StringReplace(const OldPattern: String; const NewPattern: String): String;', @TFW_UnicString._Replace); + RegisterHeader(G, 'function Equals(const Value: String): boolean;', @TFW_UnicString._Equals); + RegisterHeader(G, 'function Length: integer;', @TFW_UnicString._Length); +{$IFDEF UNIC} +{$IFNDEF PAXARM} + RegisterHeader(G, 'function ToUTF8: UTF8String;', @TFW_UnicString._ToUTF8); + RegisterHeader(G, 'function FromUTF8(const Value: UTF8String): String;', @TFW_UnicString._FromUTF8); + RegisterHeader(G, 'function ToAnsi: AnsiString;', @TFW_UnicString._ToAnsi); + RegisterHeader(G, 'function FromAnsi(const Value: AnsiString): String;', @TFW_UnicString._FromAnsi); + RegisterHeader(G, 'function Append(const Value: AnsiString): String; overload;', @TFW_UnicString._AppendA); + RegisterHeader(G, 'function AppendLine(const Value: AnsiString): String; overload;', @TFW_UnicString._AppendLineA); +{$ENDIF} + RegisterHeader(G, 'function ToBase64: String;', @TFW_UnicString._ToBase64); + RegisterHeader(G, 'function FromBase64(const Value: String): String;', @TFW_UnicString._FromBase64); + + RegisterHeader(G, 'function ToDate: TDateTime;', @TFW_UnicString._ToDate); + RegisterHeader(G, 'function ToTime: TDateTime;', @TFW_UnicString._ToTime); + RegisterHeader(G, 'function ToDateTime: TDateTime;', @TFW_UnicString._ToDateTime); + RegisterHeader(G, 'function ToCurrency: Currency;', @TFW_UnicString._ToCurrency); + RegisterHeader(G, 'function ToExtended: Extended;', @TFW_UnicString._ToExtended); + RegisterHeader(G, 'function ToDouble: Double;', @TFW_UnicString._ToDouble); + RegisterHeader(G, 'function ToCardinal: Cardinal;', @TFW_UnicString._ToCardinal); + RegisterHeader(G, 'function ToShortInt: ShortInt;', @TFW_UnicString._ToShortInt); + RegisterHeader(G, 'function ToSmallInt: SmallInt;', @TFW_UnicString._ToSmallInt); + RegisterHeader(G, 'function ToSingle: Single;', @TFW_UnicString._ToSingle); + RegisterHeader(G, 'function ToWord: Word;', @TFW_UnicString._ToWord); + RegisterHeader(G, 'function ToInt32: Integer;', @TFW_UnicString._ToInt32); + RegisterHeader(G, 'function ToInt64: Int64;', @TFW_UnicString._ToInt64); + RegisterHeader(G, 'function ToBoolean: Boolean;', @TFW_UnicString._ToBoolean); + RegisterHeader(G, 'function ToByteBool: ByteBool;', @TFW_UnicString._ToByteBool); + RegisterHeader(G, 'function ToLongBool: LongBool;', @TFW_UnicString._ToLongBool); + RegisterHeader(G, 'function ToWordBool: WordBool;', @TFW_UnicString._ToWordBool); + RegisterHeader(G, 'function ISOToBoolean: Boolean;', @TFW_UnicString._ISOToBoolean); + RegisterHeader(G, 'function ISOToDate: TDateTime;', @TFW_UnicString._ISOToDate); + RegisterHeader(G, 'function ISOToTime: TDateTime;', @TFW_UnicString._ISOToTime); + RegisterHeader(G, 'function ISOToDateTime: TDateTime;', @TFW_UnicString._ISOToDateTime); + RegisterHeader(G, 'function ISOToCurrency: Currency;', @TFW_UnicString._ISOToCurrency); + RegisterHeader(G, 'function ISOToExtended: Extended;', @TFW_UnicString._ISOToExtended); + RegisterHeader(G, 'function ISOToDouble: Double;', @TFW_UnicString._ISOToDouble); + + RegisterHeader(G, 'function Copy(Index: integer; Count: integer): String;', @TFW_UnicString._Copy); + RegisterHeader(G, 'function Delete(Index: integer; Count: integer): String;', @TFW_UnicString._Delete); + RegisterHeader(G, 'function Trim: String;', @TFW_UnicString._Trim); + RegisterHeader(G, 'function TrimLeft: String;', @TFW_UnicString._TrimLeft); + RegisterHeader(G, 'function TrimRight: String;', @TFW_UnicString._TrimRight); + RegisterHeader(G, 'function Contains(const Value: String): boolean;', @TFW_UnicString._Contains); + RegisterHeader(G, 'function Pos(const Value: String): integer;', @TFW_UnicString._Pos); + RegisterHeader(G, 'function IndexOf(const Value: String; const StartIndex: integer = 0): integer;', @TFW_UnicString._IndexOf); + RegisterHeader(G, 'function Quoted(const Quote: WideChar = ' + #39 + '"' + #39 + '): String;', @TFW_UnicString._Quoted); + RegisterHeader(G, 'function Dequoted(const Quote: WideChar = ' + #39 + '"' + #39 + '): String;', @TFW_UnicString._Dequoted); + RegisterHeader(G, 'function ToUpper: String;', @TFW_UnicString._ToUpper); + RegisterHeader(G, 'function ToLower: String;', @TFW_UnicString._ToLower); + RegisterHeader(G, 'function Split(const Seperator: String): TStringDynArray; overload;', @TFW_UnicString._Split); + RegisterHeader(G, 'function Split(const Seperator: WideChar; const Quotes: Boolean; const Quote: WideChar = ' + #39 + '"' + #39 + '; const TrimText: Boolean = false): TStringDynArray; overload;', @TFW_UnicString._SplitEx); + RegisterHeader(G, 'function Join(const Value: TStringDynArray; const Seperator: String): String;', @TFW_UnicString._Join); + RegisterHeader(G, 'function Insert(const Value: String; Index: integer): String;', @TFW_UnicString._Insert); + RegisterHeader(G, 'function IsNumeric: boolean;', @TFW_UnicString._IsNumeric); + RegisterHeader(G, 'function IsAlpha: boolean;', @TFW_UnicString._IsAlpha); + RegisterHeader(G, 'function IsAlphaNumeric: boolean;', @TFW_UnicString._IsAlphaNumeric); + RegisterHeader(G, 'function Match(const Mask: String): boolean;', @TFW_UnicString._Match); + RegisterHeader(G, 'function EndsWith(const Value: String): boolean;', @TFW_UnicString._EndsWith); + RegisterHeader(G, 'function StartsWith(const Value: String): boolean;', @TFW_UnicString._StartsWith); + RegisterHeader(G, 'function Reverse: String;', @TFW_UnicString._Reverse); + RegisterHeader(G, 'function Left(const Length: Integer): String;', @TFW_UnicString._Left); + RegisterHeader(G, 'function Right(const Length: Integer): String;', @TFW_UnicString._Right); + + RegisterHeader(G, 'function Append(const Value: String): String; overload;', @TFW_UnicString._AppendW); + RegisterHeader(G, 'function AppendLine(const Value: String): String; overload;', @TFW_UnicString._AppendLineW); + RegisterHeader(G, 'function Lastchar: WideChar;', @TFW_UnicString._Lastchar); + RegisterHeader(G, 'function LastDelimiter(const Delimiters: String = ' + #39 + ';' + #39 + '): Integer;', @TFW_UnicString._LastDelimiter); + RegisterHeader(G, 'function FindDelimiter(const Delimiters: String = ' + #39 + ';' + #39 + '; const StartIdx: integer = 1): Integer;', @TFW_UnicString._FindDelimiter); + RegisterHeader(G, 'function StringOfChar(const Ch: WideChar; const Count: integer): String;', @TFW_UnicString._StringOfChar); +{$ENDIF} + + G := RegisterClassType(H, TFW_Array); + H_TFW_Array := G; + FWArrayOffset := Integer(@TFW_Array(nil).P); + RegisterTypeField(G, strNBounds, typeINTEGER, Integer(@TFW_Array(nil).NBounds)); + RegisterTypeField(G, strElFinalTypeId, typeINTEGER, Integer(@TFW_Array(nil).ElFinalTypeId)); + RegisterTypeField(G, strElTypeId, typeINTEGER, Integer(@TFW_Array(nil).ElTypeId)); + RegisterTypeField(G, strElSize, typeINTEGER, Integer(@TFW_Array(nil).ElSize)); + RegisterHeader(G, 'constructor ' + strInternalFWArrayCreate + ';', @TFW_Array.Create); + Id_FWArray_Create := LastSubId; + + H_Sub := RegisterRoutine(0, 'length', typeINTEGER, ccREGISTER, @_FWArrayLength); + RegisterParameter(H_Sub, H_TFW_Array, Unassigned, false, 'X'); + Id_FWArray_GetLength := LastSubId; + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_InitFWArray); + Id_InitFWArray := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + end; +end; + +end. + + + diff --git a/Sources/PAXCOMP_GC.pas b/Sources/PAXCOMP_GC.pas new file mode 100644 index 0000000..7dab82e --- /dev/null +++ b/Sources/PAXCOMP_GC.pas @@ -0,0 +1,225 @@ +//////////////////////////////////////////////////////////////////////////// +// PaxCompiler +// Site: http://www.paxcompiler.com +// Author: Alexander Baranovsky (paxscript@gmail.com) +// ======================================================================== +// Copyright (c) Alexander Baranovsky, 2006-2014. All rights reserved. +// Code Version: 4.2 +// ======================================================================== +// Unit: PAXCOMP_GC.pas +// ======================================================================== +//////////////////////////////////////////////////////////////////////////// + +{$I PaxCompiler.def} +{$O-} + +unit PAXCOMP_GC; +interface +uses {$I uses.def} + SysUtils, + Classes, + PAXCOMP_TYPES, + PAXCOMP_SYS; + +const + MAX_OBJECTS: Integer = 1024; + +type + TGC = class; + + TGC_Object = class(TPersistent) + private + fRefCount: Integer; + public + constructor Create; + function AddRef: Integer; + function __toString: String; virtual; + function GetGC: TGC; virtual; abstract; + property RefCount: Integer read fRefCount write fRefCount; + end; + + PGC_Object = ^TGC_Object; + + TGC = class(TTypedList) + private + GC_Ref: TPtrList; + Bound: Integer; + function GetRecord(I: Integer): TGC_Object; + public + constructor Create; + destructor Destroy; override; + procedure Clear; override; + procedure ClearRef; + procedure ClearObjects; + function AddObject(X: TGC_Object): Integer; + function AddReference(X: TGC_Object): Integer; + procedure Remove(X: TGC_Object); + procedure Collect; + procedure Mark; + property Records[I: Integer]: TGC_Object read GetRecord; default; + end; + +procedure GC_Assign(Dest: PGC_Object; Source: TGC_Object); + +implementation + +procedure GC_Assign(Dest: PGC_Object; Source: TGC_Object); +var + GC: TGC; +begin + if Source = nil then + begin + if Dest = nil then + Exit; + if Dest^ = nil then + Exit; + + GC := Dest^.GetGC; + + Dec(Dest^.fRefCount); + if Dest^.fRefCount = 0 then + GC.Remove(Dest^); + Exit; + end; + + GC := Source.GetGC; + + Inc(Source.fRefCount); + if Dest^ <> nil then + begin + Dec(Dest^.fRefCount); + if Dest^.fRefCount = 0 then + GC.Remove(Dest^); + end; + Dest^ := Source; +end; + +// TGC_Object ------------------------------------------------------------------ + +constructor TGC_Object.Create; +begin + inherited; + fRefCount := 1; +end; + +function TGC_Object.__toString: String; +begin + result := ''; +end; + +function TGC_Object.AddRef: Integer; +begin + Inc(fRefCount); + Result := fRefCount; +end; + +// TGC ------------------------------------------------------------------------- + +constructor TGC.Create; +begin + GC_Ref := TPtrList.Create; + Bound := 0; + inherited; +end; + +destructor TGC.Destroy; +begin + Clear; + inherited; + GC_Ref.Free; +end; + +procedure TGC.ClearRef; +var + I, K: Integer; +begin + K := GC_Ref.Count; + if K = 0 then + Exit; + for I := K - 1 downto 0 do +{$IFDEF ARC} + GC_Ref[I] := nil; +{$ELSE} + TObject(GC_Ref[I]).Free; +{$ENDIF} + GC_Ref.Clear; +end; + +procedure TGC.Clear; +var + I: Integer; +begin + ClearRef; + for I := Count - 1 downto 0 do +{$IFDEF ARC} + L[I] := nil; +{$ELSE} + TObject(L[I]).Free; +{$ENDIF} + L.Clear; + Bound := 0; +end; + +function TGC.GetRecord(I: Integer): TGC_Object; +begin + result := TGC_Object(L[I]); +end; + +function TGC.AddObject(X: TGC_Object): Integer; +begin + result := L.IndexOf(X); + if result >= 0 then + Exit; + L.Add(X); + if L.Count = MAX_OBJECTS then + Collect; + result := L.Count; +end; + +function TGC.AddReference(X: TGC_Object): Integer; +begin + result := GC_Ref.Add(X); +end; + +procedure TGC.Remove(X: TGC_Object); +begin + L.Remove(X); + X.Free; +end; + +procedure TGC.Collect; +var + I: Integer; + X: TGC_Object; +begin + for I := Count - 1 downto Bound do + begin + X := Records[I]; + if X.RefCount <= 0 then + begin + L.Delete(I); + X.Free; + end; + end; +end; + +procedure TGC.ClearObjects; +var + I: Integer; + X: TGC_Object; +begin + ClearRef; + for I := Count - 1 downto Bound do + begin + X := Records[I]; + L.Delete(I); + X.Free; + end; +end; + +procedure TGC.Mark; +begin + Bound := Count; +end; + +end. diff --git a/Sources/PAXCOMP_GENERIC.pas b/Sources/PAXCOMP_GENERIC.pas new file mode 100644 index 0000000..a67bcd8 --- /dev/null +++ b/Sources/PAXCOMP_GENERIC.pas @@ -0,0 +1,1029 @@ +//////////////////////////////////////////////////////////////////////////// +// PaxCompiler +// Site: http://www.paxcompiler.com +// Author: Alexander Baranovsky (paxscript@gmail.com) +// ======================================================================== +// Copyright (c) Alexander Baranovsky, 2006-2014. All rights reserved. +// Code Version: 4.2 +// ======================================================================== +// Unit: PAXCOMP_GENERIC.pas +// ======================================================================== +//////////////////////////////////////////////////////////////////////////// + +{$I PaxCompiler.def} +unit PAXCOMP_GENERIC; +interface +uses {$I uses.def} + Classes, + SysUtils, + PAXCOMP_CONSTANTS, + PAXCOMP_TYPES, + PAXCOMP_SYS; + +type + TGenericTypeContainer = class; + + TTypeParams = class(TStringObjectList) + public + procedure AssTo(L: TTypeParams); + end; + + TTypeParamsHistory = class(TTypedList) + private + function GetRecord(I: Integer): TTypeParams; + public + function Add(const Value: TTypeParams): TTypeParams; + property Records[I: Integer]: TTypeParams read GetRecord; default; + end; + + TTypeRestrictionRec = class + public + Id: Integer; + N: Integer; + function Clone: TTypeRestrictionRec; + end; + + TTypeRec = class + public + Name: String; + ParamList: TTypeParams; + IsExtra: Boolean; + IsGeneric: Boolean; + constructor Create; + destructor Destroy; override; + end; + + TTypeExpRec = class(TTypeRec); + + TTypeExtRec = class(TTypeRec) + public + P1, P2: Integer; + LangId: Integer; + Extension: String; + Valid: Boolean; + function Substitute(R: TTypeExpRec): String; + end; + + TTypeExtList = class(TTypedList) + private + function GetRecord(I: Integer): TTypeExtRec; + function GetTop: TTypeExtRec; + public + function Add: TTypeExtRec; + property Top: TTypeExtRec read GetTop; + property Records[I: Integer]: TTypeExtRec read GetRecord; default; + end; + + TTypeDefRec = class(TTypeRec) + public + P1, P2: Integer; + LangId: Integer; + TypeId: Integer; + SubId: Integer; + Definition: String; + IsMethodImplementation: Boolean; // Pascal only + AncestorName: String; + TypeExtList: TTypeExtList; + ModuleName: String; + function Substitute(R: TTypeExpRec): String; + constructor Create(AModuleName: String; ALangId: Integer); + destructor Destroy; override; + end; + + TTypeExpList = class(TTypedList) + private + function GetRecord(I: Integer): TTypeExpRec; + function GetTop: TTypeExpRec; + public + constructor Create; + function IndexOf(const TypeName: String; + TypeParams: TStrings; + Upcase: Boolean): Integer; + function Add: TTypeExpRec; + property Top: TTypeExpRec read GetTop; + property Records[I: Integer]: TTypeExpRec read GetRecord; default; + end; + + TTypeModuleRec = class + public + ModuleName: String; + LangId: Integer; + UsingList: TStringList; + Source: String; + Success: Boolean; + constructor Create; + destructor Destroy; override; + end; + + TTypeModuleList = class(TTypedList) + private + function GetRecord(I: Integer): TTypeModuleRec; + public + function IndexOf(const ModuleName: String): Integer; + function AddModule(const ModuleName: String; LangId: Integer): TTypeModuleRec; + property Records[I: Integer]: TTypeModuleRec read GetRecord; default; + end; + + TTypeDefList = class(TTypedList) + private + procedure RaiseError(const Message: string; params: array of Const); + function GetRecord(I: Integer): TTypeDefRec; + function GetTop: TTypeDefRec; + procedure TryExpansion(const TypeName: String; + LangId: Integer; + result: TStringList; + var Success: Boolean; + I, J: Integer); + public + TypeExpList: TTypeExpList; + Expansions: TAssocIntegers; + RemTypeIds: TIntegerList; + TypeModuleList: TTypeModuleList; + CurrTypeModuleRec: TTypeModuleRec; + constructor Create; + destructor Destroy; override; + function IndexOf(const TypeName: String; + TypeParams: TStringList; + Upcase: Boolean): Integer; + function Add(const ModuleName: String; LangId: Integer): TTypeDefRec; + function FindTypeDef(TypeId: Integer): TTypeDefRec; + function FindMethodDef(SubId: Integer): TTypeDefRec; + procedure Clear; override; + procedure ReplaceId(OldId, NewId: Integer); + procedure GenPascalUnits; + procedure GenBasicUnits; + procedure GenJavaUnits; + procedure CreateConainer(TypeId: Integer; result: TGenericTypeContainer); + property Top: TTypeDefRec read GetTop; + property Records[I: Integer]: TTypeDefRec read GetRecord; default; + end; + + TGenericTypeContainer = class + public + Definition: String; + MethodList: TStringList; + constructor Create; + destructor Destroy; override; + procedure SaveToStream(S: TStream); + procedure LoadFromStream(S: TStream); + end; + +implementation + +function GetExtraPascalUnitName(const ModuleName: String): String; +begin + result := strExtraPascalUnit + ExtractName(ModuleName); +end; + +function GetExtraBasicUnitName(const ModuleName: String): String; +begin + result := strExtraBasicUnit + ExtractName(ModuleName); +end; + +function GetExtraJavaUnitName(const ModuleName: String): String; +begin + result := strExtraJavaUnit + ExtractName(ModuleName); +end; + +function Substitute(const S: String; P1, P2: TTypeParams): String; +var + I: Integer; + Name1, Name2: String; +begin + if P1.Count <> P2.Count then + raise Exception.Create(errInternalError); + + result := S; + for I := 0 to P1.Count - 1 do + begin + Name1 := P1[I]; + Name2 := P2[I]; + result := Subst(result, Name1, Name2); + end; +end; + + +function TTypeExtRec.Substitute(R: TTypeExpRec): String; +var + I: Integer; + Name1, Name2: String; +begin + if ParamList.Count <> R.ParamList.Count then + raise Exception.Create(errInternalError); + + result := Extension; + for I := 0 to ParamList.Count - 1 do + begin + Name1 := ParamList[I]; + Name2 := R.ParamList[I]; + result := Subst(result, Name1, Name2); + end; +end; + +// TTypeExtList ---------------------------------------------------------------- + +function TTypeExtList.GetRecord(I: Integer): TTypeExtRec; +begin + result := TTypeExtRec(L[I]); +end; + +function TTypeExtList.Add: TTypeExtRec; +begin + result := TTypeExtRec.Create; + L.Add(result); +end; + +function TTypeExtList.GetTop: TTypeExtRec; +begin + result := Records[Count - 1]; +end; + +// TTypeRec -------------------------------------------------------------------- + +constructor TTypeRec.Create; +begin + inherited; + ParamList := TTypeParams.Create; +end; + +destructor TTypeRec.Destroy; +begin + ParamList.Free; + inherited; +end; + +function TTypeRestrictionRec.Clone: TTypeRestrictionRec; +begin + result := TTypeRestrictionRec.Create; + result.Id := Id; + result.N := N; +end; + +constructor TTypeDefRec.Create(AModuleName: String; ALangId: Integer); +begin + inherited Create; + ModuleName := AModuleName; + LangId := ALangId; + TypeExtList := TTypeExtList.Create; +end; + +destructor TTypeDefRec.Destroy; +begin + TypeExtList.Free; + inherited; +end; + +function TTypeDefRec.Substitute(R: TTypeExpRec): String; +var + I: Integer; + Name1, Name2: String; +begin + if ParamList.Count <> R.ParamList.Count then + raise Exception.Create(errInternalError); + + result := Definition; + for I := 0 to ParamList.Count - 1 do + begin + Name1 := ParamList[I]; + Name2 := R.ParamList[I]; + result := Subst(result, Name1, Name2); + end; +end; + +// TTypeExpList ---------------------------------------------------------------- + +constructor TTypeExpList.Create; +begin + inherited Create; +end; + +function TTypeExpList.GetRecord(I: Integer): TTypeExpRec; +begin + result := TTypeExpRec(L[I]); +end; + +function TTypeExpList.IndexOf(const TypeName: String; + TypeParams: TStrings; + Upcase: Boolean): Integer; +var + I, J: Integer; + R: TTypeExpRec; + b, b1, b2: Boolean; + S1, S2: String; +begin + result := -1; + for I := 0 to Count - 1 do + begin + R := Records[I]; + if Upcase then + b1 := StrEql(R.Name, TypeName) + else + b1 := R.Name = TypeName; + if b1 then + if R.ParamList.Count = TypeParams.Count then + begin + b := true; + for J := 0 to R.ParamList.Count - 1 do + begin + S1 := ExtractName(R.ParamList[J]); + S2 := ExtractName(TypeParams[J]); + if Upcase then + b2 := StrEql(S1, S2) + else + b2 := S1 = S2; + if not b2 then + begin + b := false; + break; + end; + end; + if b then + begin + result := I; + Exit; + end; + end; + end; +end; + +function TTypeExpList.Add: TTypeExpRec; +begin + result := TTypeExpRec.Create; + L.Add(result); +end; + +function TTypeExpList.GetTop: TTypeExpRec; +begin + result := Records[Count - 1]; +end; + +// TTypeDefList ---------------------------------------------------------------- + +constructor TTypeDefList.Create; +begin + inherited Create; + TypeExpList := TTypeExpList.Create; + Expansions := TAssocIntegers.Create; + RemTypeIds := TIntegerList.Create; + TypeModuleList := TTypeModuleList.Create; +end; + +destructor TTypeDefList.Destroy; +begin + inherited; + Expansions.Free; + TypeExpList.Free; + RemTypeIds.Free; + TypeModuleList.Free; +end; + +procedure TTypeDefList.Clear; +begin + Expansions.Clear; + TypeExpList.Clear; + RemTypeIds.Clear; + inherited; +end; + +function TTypeDefList.GetRecord(I: Integer): TTypeDefRec; +begin + result := TTypeDefRec(L[I]); +end; + +procedure TTypeDefList.RaiseError(const Message: string; params: array of Const); +begin + raise PaxCompilerException.Create(Format(Message, params)); +end; + +function TTypeDefList.IndexOf(const TypeName: String; + TypeParams: TStringList; + Upcase: Boolean): Integer; +var + I, J: Integer; + R: TTypeDefRec; + b, b1, b2: Boolean; + S1, S2: String; +begin + result := -1; + for I := 0 to Count - 1 do + begin + R := Records[I]; + if Upcase then + b1 := StrEql(R.Name, TypeName) + else + b1 := R.Name = TypeName; + if b1 then + if R.ParamList.Count = TypeParams.Count then + begin + b := true; + for J := 0 to R.ParamList.Count - 1 do + begin + S1 := R.ParamList[J]; + S2 := TypeParams[J]; + if Upcase then + b2 := StrEql(S1, S2) + else + b2 := S1 = S2; + if not b2 then + begin + b := false; + break; + end; + end; + if b then + begin + result := I; + Exit; + end; + end; + end; +end; + +function TTypeDefList.Add(const ModuleName: String; LangId: Integer): TTypeDefRec; +var + I: Integer; +begin + result := TTypeDefRec.Create(ModuleName, LangId); + L.Add(result); + + I := TypeModuleList.IndexOf(ModuleName); + if I = -1 then + CurrTypeModuleRec := TypeModuleList.AddModule(ModuleName, LangId); +end; + +function TTypeDefList.FindTypeDef(TypeId: Integer): TTypeDefRec; +var + I: Integer; +begin + result := nil; + for I := 0 to Count - 1 do + if Records[I].TypeId = TypeId then + begin + result := Records[I]; + Exit; + end; + RaiseError(errInternalError, []); +end; + +function TTypeDefList.FindMethodDef(SubId: Integer): TTypeDefRec; +var + I: Integer; +begin + result := nil; + for I := 0 to Count - 1 do + if Records[I].SubId = SubId then + begin + result := Records[I]; + Exit; + end; + RaiseError(errInternalError, []); +end; + +function TTypeDefList.GetTop: TTypeDefRec; +begin + result := Records[Count - 1]; +end; + +procedure TTypeDefList.ReplaceId(OldId, NewId: Integer); +var + I, J, K, L: Integer; + ParamList: TStringObjectList; + TR: TTypeRestrictionRec; +begin + for I := 0 to Count - 1 do + begin + ParamList := Records[I].ParamList; + for J := 0 to ParamList.Count - 1 do + begin + TR := TTypeRestrictionRec(ParamList.Objects[J]); + if TR <> nil then + if TR.Id = OldId then + TR.Id := NewId; + + for K := 0 to Records[I].TypeExtList.Count - 1 do + begin + for L := 0 to Records[I].TypeExtList[K].ParamList.Count - 1 do + begin + TR := TTypeRestrictionRec(Records[I].TypeExtList[K].ParamList.Objects[L]); + if TR <> nil then + if TR.Id = OldId then + TR.Id := NewId; + end; + end; + + end; + end; + for I := 0 to TypeExpList.Count - 1 do + begin + ParamList := TypeExpList[I].ParamList; + for J := 0 to ParamList.Count - 1 do + begin + TR := TTypeRestrictionRec(ParamList.Objects[J]); + if TR <> nil then + if TR.Id = OldId then + TR.Id := NewId; + end; + end; +end; + +procedure TTypeDefList.TryExpansion(const TypeName: String; + LangId: Integer; + result: TStringList; + var Success: Boolean; + I, J: Integer); +var + RI, RL: TTypeExpRec; + RJ: TTypeDefRec; + RK: TTypeExtRec; + S, Q, S1: String; + K, L: Integer; +begin + RI := TypeExpList[I]; + RJ := Records[J]; + + if RJ.IsExtra then + Exit; + if not RJ.IsGeneric then + Exit; + + if RJ.LangId = LangId then + if not RJ.IsMethodImplementation then + if RI.ParamList.Count = RJ.ParamList.Count then + if StrEql(TypeName, RJ.Name) then + begin + Success := true; + + if RJ.AncestorName <> '' then + begin + for K:=0 to Count - 1 do + if Expansions.IndexOf(I, K) = -1 then + TryExpansion(RJ.AncestorName, + LangId, + result, + Success, + I, K); + end; + + S := RJ.Substitute(RI); + + if RJ.TypeExtList.Count > 0 then + begin + if LangId = PASCAL_LANGUAGE then + begin + S1 := Copy(S, 1, Length(S) - 4); + + for K := 0 to RJ.TypeExtList.Count - 1 do + begin + RK := RJ.TypeExtList[K]; + for L := 0 to TypeExpList.Count - 1 do + begin + RL := TypeExpList[L]; + if RK.ParamList.Count = RL.ParamList.Count then + if StrEql(RK.Name, RL.Name) then + begin + Q := Substitute(RK.Extension, RJ.ParamList, RI.ParamList); + Q := Substitute(Q, RK.ParamList, RL.ParamList); + + Q := EXTRA_KEYWORD + ' ' + Q; + + S1 := S1 + Q + #13#10; + end; + end; + end; + + S := S1 + 'end;'; + end; + end; + + result.Add(S); + + Expansions.Add(I, J); + end; +end; + +procedure TTypeDefList.CreateConainer(TypeId: Integer; result: TGenericTypeContainer); +var + I: Integer; + R: TTypeDefRec; +begin + for I := 0 to Count - 1 do + begin + R := Records[I]; + if not R.IsGeneric then + continue; + + if R.TypeId <> TypeId then + continue; + if R.IsMethodImplementation then + result.MethodList.Add(R.Definition) + else + result.Definition := R.Definition; + end; +end; + +procedure TTypeDefList.GenPascalUnits; + + function GenUnit(TypeModuleRec: TTypeModuleRec): TStringList; + var + I, J, K, L: Integer; + RI, RL: TTypeExpRec; + RJ: TTypeDefRec; + RK: TTypeExtRec; + S, S1, Q, ModuleName: String; + begin + TypeModuleRec.Success := false; + ModuleName := TypeModuleRec.ModuleName; + + result := TStringList.Create; + result.Add('unit ' + GetExtraPascalUnitName(ModuleName) + ';'); + result.Add('interface'); + + if TypeModuleRec.UsingList.Count > 0 then + begin + result.Add('uses '); + for I := 0 to TypeModuleRec.UsingList.Count - 1 do + begin + S := TypeModuleRec.UsingList[I]; + if I = TypeModuleRec.UsingList.Count - 1 then + S := S + ';' + else + S := S + ','; + result.Add(S); + end; + end; + + result.Add('type'); + + for I := 0 to TypeExpList.Count - 1 do + begin + RI := TypeExpList[I]; + + if IndexOf(RI.Name, RI.ParamList, true) >= 0 then + continue; + + for J:= 0 to Count - 1 do + begin + RJ := Records[J]; + if not StrEql(ModuleName, RJ.ModuleName) then + continue; + + if Expansions.IndexOf(I, J) = -1 then + TryExpansion(RI.Name, PASCAL_LANGUAGE, result, TypeModuleRec.Success, I, J); + end; + end; + + for J := 0 to Count - 1 do + begin + RJ := Records[J]; + if RJ.LangId = PASCAL_LANGUAGE then + if RJ.IsGeneric and (RJ.ParamList.Count = 0) then + if not RJ.IsMethodImplementation then + begin + if RJ.TypeExtList.Count = 0 then + RaiseError(errInternalError, []); + + S := RJ.Definition; + S1 := Copy(S, 1, Length(S) - 4); + + for K := 0 to RJ.TypeExtList.Count - 1 do + begin + RK := RJ.TypeExtList[K]; + for L := 0 to TypeExpList.Count - 1 do + begin + RL := TypeExpList[L]; + if RK.ParamList.Count = RL.ParamList.Count then + if StrEql(RK.Name, RL.Name) then + begin + Q := Substitute(RK.Extension, RK.ParamList, RL.ParamList); + + Q := EXTRA_KEYWORD + ' ' + Q; + + S1 := S1 + Q + #13#10; + end; + end; + end; + + S := S1 + 'end;'; + + result.Add(S); + + TypeModuleRec.Success := true; + end; + end; + + result.Add('implementation'); + + for I := 0 to TypeExpList.Count - 1 do + begin + RI := TypeExpList[I]; + if IndexOf(RI.Name, RI.ParamList, true) >= 0 then + continue; + + for J:= 0 to Count - 1 do + if Expansions.IndexOf(I, J) = -1 then + begin + RJ := Records[J]; + + if RJ.IsExtra then + continue; + if not RJ.IsGeneric then + continue; + + if RJ.LangId = PASCAL_LANGUAGE then + if RJ.IsMethodImplementation then + if RI.ParamList.Count = RJ.ParamList.Count then + if StrEql(RI.Name, RJ.Name) then + begin + TypeModuleRec.Success := true; + S := RJ.Substitute(RI); + + result.Add(S); + + for K := 0 to RJ.TypeExtList.Count - 1 do + begin + RK := RJ.TypeExtList[K]; + for L := 0 to TypeExpList.Count - 1 do + begin + RL := TypeExpList[L]; + if RK.ParamList.Count = RL.ParamList.Count then + if StrEql(RK.Name, RL.Name) then + begin + S := Substitute(RK.Extension, RJ.ParamList, RI.ParamList); + S := Substitute(S, RK.ParamList, RL.ParamList); + result.Add(S); + end; + end; + end; + + Expansions.Add(I, J); + end; + end; + end; + + for J := 0 to Count - 1 do + begin + RJ := Records[J]; + if RJ.LangId = PASCAL_LANGUAGE then + if RJ.IsGeneric and (RJ.ParamList.Count = 0) then + if RJ.IsMethodImplementation then + begin + TypeModuleRec.Success := true; + + S := RJ.Definition; + result.Add(S); + for K := 0 to RJ.TypeExtList.Count - 1 do + begin + RK := RJ.TypeExtList[K]; + for L := 0 to TypeExpList.Count - 1 do + begin + RL := TypeExpList[L]; + if RK.ParamList.Count = RL.ParamList.Count then + if StrEql(RK.Name, RL.Name) then + begin + S := RK.Extension; + S := Substitute(S, RK.ParamList, RL.ParamList); + result.Add(S); + end; + end; + end; + end; + end; + + result.Add('end.'); + + if IsDump then + result.SaveToFile(DUMP_PATH + GetExtraPascalUnitName(ModuleName) + '.txt'); + end; // GenUnit + +var + I: Integer; + temp: TStringList; +begin + for I := 0 to TypeModuleList.Count - 1 do + if TypeModuleList[I].LangId = PASCAL_LANGUAGE then + begin + temp := GenUnit(TypeModuleList[I]); + TypeModuleList[I].Source := temp.Text; + temp.Free; + end; +end; + +procedure TTypeDefList.GenBasicUnits; + function GenUnit(TypeModuleRec: TTypeModuleRec): TStringList; + var + I, J: Integer; + RI: TTypeExpRec; + S, ModuleName: String; + begin + TypeModuleRec.Success := false; + ModuleName := TypeModuleRec.ModuleName; + + result := TStringList.Create; + result.Add('Module ' + GetExtraBasicUnitName(ModuleName)); + + if TypeModuleRec.UsingList.Count > 0 then + begin + S := 'Imports '; + for I := 0 to TypeModuleRec.UsingList.Count - 1 do + begin + S := S + TypeModuleRec.UsingList[I]; + if I < TypeModuleRec.UsingList.Count - 1 then + S := S + ','; + end; + result.Add(S); + end; + + for I := 0 to TypeExpList.Count - 1 do + begin + RI := TypeExpList[I]; + if IndexOf(RI.Name, RI.ParamList, true) >= 0 then + continue; + + for J:= 0 to Count - 1 do + if Expansions.IndexOf(I, J) = -1 then + TryExpansion(RI.Name, BASIC_LANGUAGE, result, TypeModuleRec.Success, I, J); + end; + + result.Add('End Module'); + + if IsDump then + result.SaveToFile(DUMP_PATH + GetExtraBasicUnitName(ModuleName) + '.txt'); + end; +var + I: Integer; + temp: TStringList; +begin + for I := 0 to TypeModuleList.Count - 1 do + if TypeModuleList[I].LangId = BASIC_LANGUAGE then + begin + temp := GenUnit(TypeModuleList[I]); + TypeModuleList[I].Source := temp.Text; + temp.Free; + end; +end; + +procedure TTypeDefList.GenJavaUnits; + function GenUnit(TypeModuleRec: TTypeModuleRec): TStringList; + var + I, J: Integer; + RI: TTypeExpRec; + ModuleName: String; + begin + TypeModuleRec.Success := false; + ModuleName := TypeModuleRec.ModuleName; + + result := TStringList.Create; + result.Add('package ' + GetExtraJavaUnitName(ModuleName) + ';'); + + for I := 0 to TypeExpList.Count - 1 do + begin + RI := TypeExpList[I]; + if IndexOf(RI.Name, RI.ParamList, true) >= 0 then + continue; + + for J:= 0 to Count - 1 do + if Expansions.IndexOf(I, J) = -1 then + TryExpansion(RI.Name, JAVA_LANGUAGE, result, TypeModuleRec.Success, I, J); + end; + + if IsDump then + result.SaveToFile(DUMP_PATH + GetExtraJavaUnitName(ModuleName) + '.txt'); + end; +var + I: Integer; + temp: TStringList; +begin + for I := 0 to TypeModuleList.Count - 1 do + if TypeModuleList[I].LangId = BASIC_LANGUAGE then + begin + temp := GenUnit(TypeModuleList[I]); + TypeModuleList[I].Source := temp.Text; + temp.Free; + end; +end; + +// TTypeParams ----------------------------------------------------------------- + +procedure TTypeParams.AssTo(L: TTypeParams); +var + I: Integer; + S: String; + TR: TTypeRestrictionRec; +begin + L.Clear; + for I := 0 to Count - 1 do + begin + S := Self[I]; + TR := TTypeRestrictionRec(Objects[I]); + if TR = nil then + L.Add(S) + else + L.AddObject(S, TR.Clone); + end; +end; + +// TTypeParamsHistory ---------------------------------------------------------- + +function TTypeParamsHistory.GetRecord(I: Integer): TTypeParams; +begin + result := TTypeParams(L[I]); +end; + +function TTypeParamsHistory.Add(const Value: TTypeParams): TTypeParams; +begin + result := TTypeParams.Create; + Value.AssTo(result); + L.Add(result); +end; + +// TTypeModuleRec ------------------------------------------------------------- + +constructor TTypeModuleRec.Create; +begin + inherited; + UsingList := TStringList.Create; +end; + +destructor TTypeModuleRec.Destroy; +begin + UsingList.Free; + inherited; +end; + +// TTypeModuleList ------------------------------------------------------------- + +function TTypeModuleList.GetRecord(I: Integer): TTypeModuleRec; +begin + result := TTypeModuleRec(L[I]); +end; + +function TTypeModuleList.IndexOf(const ModuleName: String): Integer; +var + I: Integer; +begin + result := -1; + for I := 0 to Count - 1 do + if StrEql(ModuleName, Records[I].ModuleName) then + begin + result := I; + Exit; + end; +end; + +function TTypeModuleList.AddModule(const ModuleName: String; LangId: Integer): TTypeModuleRec; +begin + result := TTypeModuleRec.Create; + result.ModuleName := ModuleName; + result.LangId := LangId; + L.Add(result); +end; + +// TGenericTypeContainer ------------------------------------------------------ + +constructor TGenericTypeContainer.Create; +begin + inherited; + MethodList := TStringList.Create; +end; + +destructor TGenericTypeContainer.Destroy; +begin + MethodList.Free; + inherited; +end; + +procedure TGenericTypeContainer.SaveToStream(S: TStream); +var + B: Byte; +begin + if not GENERICS_ALLOWED then + Exit; + if Definition <> '' then + B := 1 + else + B := 0; + S.Write(B, SizeOf(B)); + if B = 1 then + begin + SaveStringToStream(Definition, S); + SaveStringListToStream(MethodList, S); + end; +end; + +procedure TGenericTypeContainer.LoadFromStream(S: TStream); +var + B: Byte; +begin + if not GENERICS_ALLOWED then + Exit; + S.Read(B, SizeOf(B)); + if B = 1 then + begin + Definition := LoadStringFromStream(S); + LoadStringListFromStream(MethodList, S); + end; +end; + +end. + + diff --git a/Sources/PAXCOMP_HEADER_PARSER.pas b/Sources/PAXCOMP_HEADER_PARSER.pas new file mode 100644 index 0000000..4a64ed0 --- /dev/null +++ b/Sources/PAXCOMP_HEADER_PARSER.pas @@ -0,0 +1,2478 @@ +//////////////////////////////////////////////////////////////////////////// +// PaxCompiler +// Site: http://www.paxcompiler.com +// Author: Alexander Baranovsky (paxscript@gmail.com) +// ======================================================================== +// Copyright (c) Alexander Baranovsky, 2006-2014. All rights reserved. +// Code Version: 4.2 +// ======================================================================== +// Unit: PAXCOMP_HEADER_PARSER.pas +// ======================================================================== +//////////////////////////////////////////////////////////////////////////// + +{$I PaxCompiler.def} +unit PAXCOMP_HEADER_PARSER; +interface +uses {$I uses.def} + +{$IFDEF DRTTI} + RTTI, +{$ENDIF} + SysUtils, + Classes, + PAXCOMP_CONSTANTS, + PAXCOMP_TYPES, + PAXCOMP_SYS, + PAXCOMP_VAROBJECT; +const + MAX_PARAM = 30; +type + TKindSub = (ksFunction, ksProcedure, ksConstructor, ksDestructor); + TParamMod = (pmByVal, pmByRef, pmConst, pmOut); + + THeaderParser = class + private + Buff: String; + P: Integer; + L: Integer; + symbol_table: Pointer; + LevelId: Integer; + CurrTypeName: String; + DefVal: String; + SignDefVal: Boolean; + GenTypeExpected: Boolean; + operator_list: TAssocStrings; + + procedure AddOperator(const S1, S2: String); + procedure ScanGenType; + procedure ScanIdent; + procedure ScanDigits; + procedure ScanHexDigits; + procedure ScanNumberLiteral; + procedure ScanHexLiteral; + procedure ScanStringLiteral; + procedure ScanNumCharLiteral; + + function MaxTypeId(T1, T2: Integer): Integer; + procedure ScanToken; + function NotMatch(const S: String): Boolean; + function IsCurrText(const S: String): Boolean; + function IsNextText(const S: String): Boolean; + function ParseFullName: String; + function Parse_Type: String; + function Parse_SimpleExpression: Variant; + function Parse_Term: Variant; + function Parse_Factor: Variant; + procedure Parse_ConstantInitialization(ArrObject: TArrObject; var TypeId: Integer); + + procedure Parse_FormalParameterList(ch: Char); + procedure RaiseError(const Message: String; params: array of Const); + function Parse_SetConstructor: Variant; + public + Name: String; + ResType: String; + KS: TKindSub; + NP: Integer; + CC: Integer; + IsShared: Boolean; + IsProperty: Boolean; + IsDeprecated: Boolean; + Params: array[1..MAX_PARAM] of String; + Types: array[1..MAX_PARAM] of String; + Mods: array[1..MAX_PARAM] of TParamMod; + Values: array[1..MAX_PARAM] of Variant; + Optionals: array[1..MAX_PARAM] of Boolean; + DefVals: array[1..MAX_PARAM] of String; + ReadIdent: String; + WriteIdent: String; + IsDefault: Boolean; + CallMode: Integer; + SavedMessage: String; + NamespaceId: Integer; + UsedNamespaceList: TIntegerList; + IsAbstract: Boolean; + + LastFactorTypeId: Integer; + DestFactorTypeId: Integer; + + TokenClass: TTokenClass; + CurrToken: String; + + IsOverloaded: Boolean; + + AbstractMethodCount: Integer; + + CurrImportUnit: String; + kernel: Pointer; + + constructor Create; + destructor Destroy; override; + procedure Init(const Header: String; i_symbol_table: Pointer; + i_LevelId: Integer); + procedure Match(const S: String); + procedure Call_SCANNER; + function Parse_Expression: Variant; + function Parse: Boolean; + function Parse_Ident: String; + function Parse_QualTypeId: Integer; + + function Register_TypeDeclaration: Integer; + function RegisterTypeAlias(const TypeName: String; + OriginTypeId: Integer): Integer; + function Register_SubrangeTypeDeclaration(const TypeName: String): Integer; + function Register_EnumTypeDeclaration(const TypeName: String): Integer; + function Register_SetTypeDeclaration(const TypeName: String): Integer; + function Register_ArrayTypeDeclaration(const TypeName: String): Integer; + function Register_RecordTypeDeclaration(const TypeName: String): Integer; + function Register_StringTypeDeclaration(const TypeName: String): Integer; + function Register_OrdinalType: Integer; + function Register_Type: Integer; + + function LookupId(const S: String): Integer; + function LookupTypeId(const S: String): Integer; + function LookupAllIds(const S: String): TIntegerList; + function Register_Variable(const VarName: String; Address: Pointer): Integer; + function Register_Constant(const ConstName: String): Integer; + function Register_RecordTypeField(const FieldName: String; Offset: Integer = - 1): Integer; + function Register_VariantRecordTypeField(const FieldName: String; + VarCount: Integer): Integer; + function Register_TypeAlias(const TypeName: String): Integer; + end; + + ESilentException = class(EAbort) + end; + +implementation + +uses +{$IFDEF DRTTI} + PAXCOMP_2010, + PAXCOMP_2010REG, +{$ENDIF} + PAXCOMP_KERNEL, + PAXCOMP_BASESYMBOL_TABLE, + PAXCOMP_STDLIB; + +var + Undefined: Variant; + +constructor THeaderParser.Create; +begin + inherited; + NamespaceId := 0; + UsedNamespaceList := TIntegerList.Create; + + operator_list := TAssocStrings.Create; + + AddOperator(pascal_Implicit, gen_Implicit); + AddOperator(pascal_Explicit, gen_Explicit); + AddOperator(pascal_Add, gen_Add); + AddOperator(pascal_Divide, gen_Divide); + AddOperator(pascal_IntDivide, gen_IntDivide); + AddOperator(pascal_Modulus, gen_Modulus); + AddOperator(pascal_Multiply, gen_Multiply); + AddOperator(pascal_Subtract, gen_Subtract); + AddOperator(pascal_Negative, gen_Negative); + AddOperator(pascal_Positive, gen_Positive); + AddOperator(pascal_LogicalNot, gen_LogicalNot); + AddOperator(pascal_LeftShift, gen_LeftShift); + AddOperator(pascal_RightShift, gen_RightShift); + AddOperator(pascal_LogicalAnd, gen_LogicalAnd); + AddOperator(pascal_LogicalOr, gen_LogicalOr); + AddOperator(pascal_LogicalXor, gen_LogicalXor); + AddOperator(pascal_LessThan, gen_LessThan); + AddOperator(pascal_LessThanOrEqual, gen_LessThanOrEqual); + AddOperator(pascal_GreaterThan, gen_GreaterThan); + AddOperator(pascal_GreaterThanOrEqual, gen_GreaterThanOrEqual); + AddOperator(pascal_Equal, gen_Equal); + AddOperator(pascal_NotEqual, gen_NotEqual); + AddOperator(pascal_Inc, gen_Inc); + AddOperator(pascal_Dec, gen_Dec); +end; + +destructor THeaderParser.Destroy; +begin + UsedNamespaceList.Free; + operator_list.Free; + inherited; +end; + +procedure THeaderParser.AddOperator(const S1, S2: String); +begin + operator_list.Add(S1, S2); +end; + +procedure THeaderParser.Init(const Header: String; i_symbol_table: Pointer; + i_LevelId: Integer); +begin + Buff := Header + #255#255#255; + + P := SLow(Buff); + symbol_table := i_symbol_table; + LevelId := i_LevelId; + CallMode := cmNONE; + IsAbstract := false; + LastFactorTypeId := 0; + DestFactorTypeId := 0; + ReadIdent := ''; + WriteIdent := ''; + CurrTypeName := ''; + ResType := ''; + IsOverloaded := false; + IsShared := false; + IsDeprecated := false; +end; + +procedure THeaderParser.ScanIdent; +begin + while ByteInSet(Buff[P + L], IdsSet) do + Inc(L); + TokenClass := tcIdentifier; +end; + +procedure THeaderParser.ScanGenType; +var + K: Integer; +begin + L := 1; + K := 0; + repeat + if Buff[P + L] = '>' then + begin + if K = 0 then + begin + break; + end + else + begin + Dec(K); + Inc(L); + end; + end + else if Buff[P + L] = '<' then + begin + Inc(K); + Inc(L); + end + else + Inc(L); + until false; +end; + +procedure THeaderParser.ScanDigits; +begin + while IsDigit(Buff[P + L]) do + Inc(L); +end; + +procedure THeaderParser.ScanHexDigits; +begin + while ByteInSet(Buff[P + L], [Ord('0')..Ord('9'), + Ord('a')..Ord('f'), Ord('A')..Ord('F')]) do + Inc(L); +end; + +procedure THeaderParser.ScanNumberLiteral; +begin + ScanDigits; + TokenClass := tcIntegerConst; + + if (Buff[P + L] = '.') and (Buff[P + L + 1] <> '.') then + begin + Inc(L); + ScanDigits; + TokenClass := tcDoubleConst; + end; +end; + +procedure THeaderParser.ScanHexLiteral; +begin + Inc(L); + ScanHexDigits; + TokenClass := tcIntegerConst; +end; + +procedure THeaderParser.ScanNumCharLiteral; +begin + Inc(P); // # + if Buff[P] = '$' then + begin + Inc(L); + ScanHexDigits; + end + else + ScanDigits; + TokenClass := tcNumCharConst; +end; + +procedure THeaderParser.ScanStringLiteral; +var + K: Integer; +begin + K := 0; + Inc(P); + if (Buff[P] = CHAR_AP) and (Buff[P+1] <> CHAR_AP) then // empty string + begin + TokenClass := tcPCharConst; + Exit; + end; + + repeat + if Buff[P] = #255 then + begin + RaiseError(errUnterminatedString, []); + Exit; + end; + + if (Buff[P + L] = CHAR_AP) and (Buff[P + L + 1] = CHAR_AP) then + begin + Inc(L); + buff[P + L] := CHAR_REMOVE; + end + else if (Buff[P + L] = CHAR_AP) then + break; + + Inc(L); + Inc(K); + until false; + + if K = 1 then + TokenClass := tcCharConst + else + TokenClass := tcPCharConst; +end; + +procedure THeaderParser.ScanToken; +begin + L := 0; + repeat + case Buff[P] of + 'a'..'z','A'..'Z','_': + begin + ScanIdent; + Exit; + end; + '0'..'9': + begin + ScanNumberLiteral; + Exit; + end; + '$': + begin + ScanHexLiteral; + Exit; + end; + '#': + begin + ScanNumCharLiteral; + Exit; + end; + CHAR_AP: + begin + ScanStringLiteral; + Exit; + end; + '>': + begin + TokenClass := tcSpecial; + L := 1; + if Buff[P+1] = '=' then + L := 2; + Exit; + end; + '<': + begin + if GenTypeExpected then + begin + ScanGenType; + Exit; + end; + TokenClass := tcSpecial; + L := 1; + if ByteInSet(Buff[P+1], [Ord('='), Ord('>')]) then + L := 2; + Exit; + end; + '(', ')','[', ']', ',', ':', ';', '=', '+', '/', '-', '*', #255: + begin + TokenClass := tcSpecial; + L := 1; + Exit; + end; + '.': + begin + TokenClass := tcSpecial; + L := 1; + if Buff[P+1] = '.' then + L := 2; + Exit; + end; + ' ', #9, #13, #10: + begin + Inc(P); + end; + else + RaiseError(errSyntaxError, []); + end; + until false; +end; + +function THeaderParser.IsNextText(const S: String): Boolean; +var + temp_L, temp_P: Integer; + temp_token: String; + tempTokenClass: TTokenClass; +begin + temp_token := CurrToken; + temp_L := L; + temp_P := P; + tempTokenClass := TokenClass; + try + Call_SCANNER; + result := IsCurrText(S); + finally + L := temp_L; + P := temp_P; + CurrToken := temp_token; + TokenClass := tempTokenClass; + end; +end; + +procedure THeaderParser.Call_SCANNER; +begin + ScanToken; + CurrToken := SCopy(Buff, P, L); + Inc(P, L); + + if TokenClass in [tcPCharConst, tcCharConst] then + Inc(P); + + if StrEql(CurrToken, 'Undefined') then + TokenClass := tcVariantConst + else + {$IFDEF UNIC} + begin + if StrEql(CurrToken, 'String') then + CurrToken := 'UnicodeString' + else if StrEql(CurrToken, 'Char') then + CurrToken := 'WideChar' + else if StrEql(CurrToken, 'PChar') then + CurrToken := 'PWideChar'; + end; + {$ELSE} + begin + + end; + {$ENDIF} + + if SignDefVal then + DefVal := DefVal + CurrToken; +end; + +function THeaderParser.Parse_Ident: String; +begin + result := CurrToken; + + if TokenClass <> tcIdentifier then + RaiseError(errIdentifierExpected, [CurrToken]); + Call_SCANNER; +end; + +function THeaderParser.Parse_Type: String; +begin + result := UpperCase(CurrToken); + + if IsCurrText('ARRAY') then + begin + Call_SCANNER; + Match('OF'); + result := 'ARRAY OF ' + CurrToken; + Parse_Ident; + end + else + Parse_Ident; + + while IsCurrText('.') do + begin + Call_SCANNER; + result := result + '.' + UpperCase(CurrToken); + Parse_Ident; + end; + + if IsCurrText('<') then + begin + GenTypeExpected := true; + try + Dec(P); + Call_SCANNER; + result := result + CurrToken; + Call_SCANNER; + result := result + '>'; + Call_SCANNER; + finally + GenTypeExpected := false; + end; + end; +end; + +procedure THeaderParser.Parse_FormalParameterList(ch: Char); +var + I, K: Integer; + S: String; + V: Variant; + PM: TParamMod; + Opt: Boolean; +begin + Call_SCANNER; + NP := 0; + if not IsCurrText(ch) then + begin + repeat + if IsCurrText('var') then + begin + Call_SCANNER; + PM := pmByRef; + end + else if IsCurrText('out') then + begin + Call_SCANNER; + PM := pmOut; + end + else if IsCurrText('const') then + begin + Call_SCANNER; + PM := pmConst; + end + else + PM := pmByVal; + + K := 0; + repeat + Inc(K); + Params[NP + K] := Parse_Ident; + if NotMatch(',') then + break; + until false; + + if PM in [pmByRef, pmOut] then + begin + if IsCurrText(':') then + begin + Match(':'); + S := Parse_Type; + end + else + S := 'PVOID'; + end + else + begin + if (PM = pmConst) and (not IsCurrText(':')) then + begin + S := 'PVOID'; + end + else + begin + Match(':'); + S := Parse_Type; + end; + end; + + if IsCurrText('=') then + begin + CurrTypeName := S; + + DefVal := ''; + SignDefVal := true; + try + Match('='); + V := Parse_Expression; + finally + SignDefVal := false; + DefVal := Copy(DefVal, 1, Length(DefVal) - 1); + end; + Opt := true; + end + else + begin + V := Unassigned; + Opt := false; + end; + + for I:=1 to K do + begin + Inc(NP); + Types[NP] := S; + Mods[NP] := PM; + Values[NP] := V; + Optionals[NP] := Opt; + DefVals[NP] := DefVal; + end; + + if NotMatch(';') then + Break; + until false; + end; + Match(ch); +end; + +function THeaderParser.MaxTypeId(T1, T2: Integer): Integer; +var + F1, F2, S1, S2: Integer; +begin + F1 := TBaseSymbolTable(symbol_table)[T1].FinalTypeId; + F2 := TBaseSymbolTable(symbol_table)[T2].FinalTypeId; + + if F1 = F2 then + begin + result := T1; + Exit; + end; + if (F1 in IntegerTypes) and (F2 in IntegerTypes) then + begin + S1 := PAXCOMP_SYS.Types.GetSize(F1); + S2 := PAXCOMP_SYS.Types.GetSize(F2); + if S1 = S2 then + begin + if F1 in UnsignedIntegerTypes then + result := F1 + else + result := F2; + end + else if S1 > S2 then + result := F1 + else + result := F2; + end + else if F1 in IntegerTypes then + result := F2 + else if F2 in IntegerTypes then + result := F1 +{$IFNDEF PAXARM} + else if TBaseSymbolTable(symbol_table)[T1].HasPAnsiCharType then + result := T1 +{$ENDIF} + else if TBaseSymbolTable(symbol_table)[T1].HasPWideCharType then + result := T1 +{$IFNDEF PAXARM} + else if TBaseSymbolTable(symbol_table)[T2].HasPAnsiCharType then + result := T2 +{$ENDIF} + else if TBaseSymbolTable(symbol_table)[T2].HasPWideCharType then + result := T2 + else if (F1 in RealTypes) and (F2 in RealTypes) then + begin + S1 := PAXCOMP_SYS.Types.GetSize(F1); + S2 := PAXCOMP_SYS.Types.GetSize(F2); + if S1 > S2 then + result := F1 + else + result := F2; + end + else + result := F1; +end; + +function THeaderParser.Parse_Expression: Variant; +var + Op: Integer; +begin + result := Parse_SimpleExpression; + + if CurrToken = '=' then + Op := OP_EQ + else if CurrToken = '<>' then + Op := OP_NE + else if CurrToken = '>' then + Op := OP_GT + else if CurrToken = '>=' then + Op := OP_GE + else if CurrToken = '<' then + Op := OP_LT + else if CurrToken = '<=' then + Op := OP_LT + else + Op := 0; + + while Op <> 0 do + begin + Call_SCANNER; + + if Op = OP_EQ then + result := result = Parse_SimpleExpression + else if Op = OP_NE then + result := result <> Parse_SimpleExpression + else if Op = OP_GT then + result := result > Parse_SimpleExpression + else if Op = OP_GE then + result := result >= Parse_SimpleExpression + else if Op = OP_LT then + result := result < Parse_SimpleExpression + else if Op = OP_LE then + result := result <= Parse_SimpleExpression; + + if CurrToken = '=' then + Op := OP_EQ + else if CurrToken = '<>' then + Op := OP_NE + else if CurrToken = '>' then + Op := OP_GT + else if CurrToken = '>=' then + Op := OP_GE + else if CurrToken = '<' then + Op := OP_LT + else if CurrToken = '<=' then + Op := OP_LT + else + Op := 0; + + LastFactorTypeId := typeBOOLEAN; + end; +end; + +function VarTypeIsString(const V: Variant): Boolean; +var + VT: Integer; +begin + VT := VarType(V); + result := (VT = varString) {$IFDEF UNIC}or (VT = varUString){$ENDIF}; +end; + +function THeaderParser.Parse_SimpleExpression: Variant; +var + Op, T1, FT1: Integer; + V: Variant; + W: Word; + S: String; + SetObject, SetObject1, SetObject2: TSetObject; +begin + result := Parse_Term; + + if CurrToken = '+' then + Op := OP_PLUS + else if CurrToken = '-' then + Op := OP_MINUS + else if StrEql(CurrToken, 'or') then + Op := OP_OR + else if StrEql(CurrToken, 'xor') then + Op := OP_XOR + else + Op := 0; + + while Op <> 0 do + begin + T1 := TBaseSymbolTable(symbol_table)[LastFactorTypeId].TerminalTypeId; + FT1 := TBaseSymbolTable(symbol_table)[T1].FinalTypeId; + + Call_SCANNER; + + V := Parse_Term; + if VarType(result) = varString then +{$IFNDEF PAXARM} + if TBaseSymbolTable(symbol_table)[LastFactorTypeId].FinalTypeId = typeANSICHAR then + begin + S := Chr(Integer(V)); + V := S; + LastFactorTypeId := typePANSICHAR; + end + else +{$ENDIF} + if TBaseSymbolTable(symbol_table)[LastFactorTypeId].FinalTypeId in IntegerTypes then + begin + W := 0; + + if Length(result) = 1 then + begin + S := result; + W := Ord(S[1]) + V; + end + else if Length(result) = 2 then + begin + S := result; + W := 256 * Ord(S[1]) + Ord(S[2]) + V; + end + else + RaiseError(errInternalError, []); + + if W <= 255 then + result := String(chr(W)) + else + result := String(chr(Hi(W))) + String(chr(Lo(W))); + V := ''; + end; + + if Op = OP_PLUS then + begin + if FT1 = typeSET then + begin + SetObject1 := VariantToVarObject(result) as TSetObject; + SetObject2 := VariantToVarObject(V) as TSetObject; + SetObject := TSetObject.Create(symbol_table, + SetObject1.Value + SetObject2.Value, H_TByteSet, typeBYTE); + result := VarObjectToVariant(SetObject); + end + else + begin + if VarTypeIsString(V) and (not VarTypeIsString(result)) then + result := Chr(Integer(result)) + else if (not VarTypeIsString(V)) and VarTypeIsString(result) then + V := Chr(Integer(V)); + + result := result + V; + end; + end + else if Op = OP_MINUS then + begin + if FT1 = typeSET then + begin + SetObject1 := VariantToVarObject(result) as TSetObject; + SetObject2 := VariantToVarObject(V) as TSetObject; + SetObject := TSetObject.Create(symbol_table, + SetObject1.Value - SetObject2.Value, H_TByteSet, typeBYTE); + result := VarObjectToVariant(SetObject); + end + else + result := result - V; + end + else if Op = OP_OR then + result := result or V + else if Op = OP_XOR then + result := result xor V; + + if CurrToken = '+' then + Op := OP_PLUS + else if CurrToken = '-' then + Op := OP_MINUS + else if StrEql(CurrToken, 'or') then + Op := OP_OR + else if StrEql(CurrToken, 'xor') then + Op := OP_XOR + else + Op := 0; + + LastFactorTypeId := MaxTypeId(T1, LastFactorTypeId); + end; +end; + +function THeaderParser.Parse_Term: Variant; +var + Op, FT1: Integer; + V: Variant; + SetObject, SetObject1, SetObject2: TSetObject; +begin + result := Parse_Factor; + + if CurrToken = '*' then + Op := OP_MULT + else if CurrToken = '/' then + Op := OP_DIV + else if StrEql(CurrToken, 'div') then + Op := OP_IDIV + else if StrEql(CurrToken, 'mod') then + Op := OP_MOD + else if StrEql(CurrToken, 'shl') then + Op := OP_SHL + else if StrEql(CurrToken, 'shr') then + Op := OP_SHL + else if StrEql(CurrToken, 'and') then + Op := OP_AND + else + Op := 0; + + while Op <> 0 do + begin + FT1 := TBaseSymbolTable(symbol_table)[LastFactorTypeId].FinalTypeId; + + Call_SCANNER; + + V := Parse_Factor; + + if Op = OP_MULT then + begin + if FT1 = typeSET then + begin + SetObject1 := VariantToVarObject(result) as TSetObject; + SetObject2 := VariantToVarObject(V) as TSetObject; + SetObject := TSetObject.Create(symbol_table, + SetObject1.Value * SetObject2.Value, H_TByteSet, typeBYTE); + result := VarObjectToVariant(SetObject); + end + else + result := result * V; + end + else if Op = OP_DIV then + begin + if V = 0.0 then + begin + if result = 0.0 then + result := NaN + else if result = 1.0 then + result := Infinity + else if result = - 1.0 then + result := NegInfinity + else + RaiseError(errDivisionByZero, []); + end + else + result := result / V; + end + else if Op = OP_IDIV then + result := result div V + else if Op = OP_MOD then + result := result mod V + else if Op = OP_SHL then + result := result shl V + else if Op = OP_SHR then + result := result shr V + else if Op = OP_AND then + result := result and V; + + if CurrToken = '*' then + Op := OP_MULT + else if CurrToken = '/' then + Op := OP_DIV + else if StrEql(CurrToken, 'div') then + Op := OP_IDIV + else if StrEql(CurrToken, 'mod') then + Op := OP_MOD + else if StrEql(CurrToken, 'shl') then + Op := OP_SHL + else if StrEql(CurrToken, 'shr') then + Op := OP_SHL + else if StrEql(CurrToken, 'and') then + Op := OP_AND + else + Op := 0; + + LastFactorTypeId := MaxTypeId(FT1, LastFactorTypeId); + if Op = OP_DIV then + LastFactorTypeId := typeEXTENDED; + + end; +end; + +function THeaderParser.Parse_Factor: Variant; +var + I, J: Integer; + W: Word; + temp_LevelId: Integer; + SubName: String; + D: Double; + curr: Currency; +label + again, fin; +begin + temp_LevelId := LevelId; + + LastFactorTypeId := 0; + +{$IFDEF PAXARM} + if TokenClass = tcCharConst then + begin + LastFactorTypeId := typeWIDECHAR; + result := Ord(CurrToken[1]); + Call_SCANNER; + end + else if TokenClass = tcNumCharConst then + begin + LastFactorTypeId := typeWIDECHAR; + + result := StrToInt(CurrToken); + Call_SCANNER; + end + else if TokenClass = tcPCharConst then + begin + LastFactorTypeId := typePWIDECHAR; + + result := CurrToken; + Call_SCANNER; + end +{$ELSE} + if TokenClass = tcCharConst then + begin + LastFactorTypeId := typeANSICHAR; + result := Ord(CurrToken[1]); + Call_SCANNER; + end + else if TokenClass = tcNumCharConst then + begin + LastFactorTypeId := typeANSICHAR; + + result := StrToInt(CurrToken); + Call_SCANNER; + end + else if TokenClass = tcPCharConst then + begin + LastFactorTypeId := typePANSICHAR; + + result := CurrToken; + Call_SCANNER; + end +{$ENDIF} + else if TokenClass = tcIntegerConst then + begin + LastFactorTypeId := typeINTEGER; + + val(CurrToken, i, j); + if j = 0 then begin + if Pos('$', CurrToken) > 0 then + begin + LastFactorTypeId := typeCARDINAL; +{$IFDEF VARIANTS} + result := Cardinal(i); +{$ELSE} + result := Integer(i); +{$ENDIF} + end + else + begin + LastFactorTypeId := typeINTEGER; + result := i; + end; + end + else begin + LastFactorTypeId := typeINT64; +{$IFDEF VARIANTS} + result := StrToInt64 (CurrToken); +{$ELSE} + result := Integer(StrToInt64 (CurrToken)); +{$ENDIF} + end; + + Call_SCANNER; + end + else if TokenClass = tcVariantConst then + begin + LastFactorTypeId := typeVARIANT; + + result := Undefined; + Call_SCANNER; + end + else if TokenClass = tcDoubleConst then + begin + if DestFactorTypeId <> 0 then + LastFactorTypeId := DestFactorTypeId + else + LastFactorTypeId := typeDOUBLE; + + Val(CurrToken, D, I); + result := D; + Call_SCANNER; + end + else if IsCurrText('nil') then + begin + LastFactorTypeId := typePOINTER; + + result := 0; + Call_SCANNER; + end + else if IsCurrText('true') then + begin + LastFactorTypeId := typeBOOLEAN; + + result := true; + Call_SCANNER; + end + else if IsCurrText('false') then + begin + LastFactorTypeId := typeBOOLEAN; + + result := false; + Call_SCANNER; + end + else if IsCurrText('+') then + begin + Call_SCANNER; + result := Parse_Factor; + end + else if IsCurrText('-') then + begin + Call_SCANNER; + result := - Parse_Factor; + end + else if IsCurrText('not') then + begin + Call_SCANNER; + result := not Parse_Factor; + end + else if IsCurrText('low') then + begin + Call_SCANNER; + Match('('); + I := LookupId(CurrToken); + if I > 0 then + result := TBaseSymbolTable(symbol_table).GetLowBoundRec(I).Value + else + RaiseError(errUndeclaredIdentifier, [CurrToken]); + LastFactorTypeId := TBaseSymbolTable(symbol_table)[I].FinalTypeId; + Call_SCANNER; + Match(')'); + end + else if IsCurrText('high') then + begin + Call_SCANNER; + Match('('); + I := LookupId(CurrToken); + if I > 0 then + result := TBaseSymbolTable(symbol_table).GetHighBoundRec(I).Value + else + RaiseError(errUndeclaredIdentifier, [CurrToken]); + LastFactorTypeId := TBaseSymbolTable(symbol_table)[I].FinalTypeId; + Call_SCANNER; + Match(')'); + end + else if IsCurrText('SizeOf') then + begin + Call_SCANNER; + Match('('); + I := LookupId(CurrToken); + if I > 0 then + result := TBaseSymbolTable(symbol_table)[I].Size + else if TokenClass = tcPCharConst then + result := Length(CurrToken) + 1 + else + RaiseError(errUndeclaredIdentifier, [CurrToken]); + LastFactorTypeId := typeINTEGER; + Call_SCANNER; + Match(')'); + end + else if IsCurrText('pred') then + begin + Call_SCANNER; + Match('('); + result := Parse_Expression - 1; + Match(')'); + end + else if IsCurrText('succ') then + begin + Call_SCANNER; + Match('('); + result := Parse_Expression + 1; + Match(')'); + end + else if IsCurrText('ord') then + begin + Call_SCANNER; + Match('('); + result := Parse_Expression; + Match(')'); + LastFactorTypeId := typeINTEGER; + end + else if IsCurrText('chr') then + begin + Call_SCANNER; + Match('('); + result := Parse_Expression; + Match(')'); +{$IFDEF PAXARM} + LastFactorTypeId := typeWIDECHAR; +{$ELSE} + LastFactorTypeId := typeANSICHAR; +{$ENDIF} + end + else if IsCurrText('(') then + begin + Match('('); + result := Parse_Expression; + Match(')'); + end + else if IsCurrText('[') then + begin + result := Parse_SetConstructor; + LastFactorTypeId := H_TByteSet; + end + else + begin + +again: + + I := TBaseSymbolTable(symbol_table).LookUp(CurrToken, LevelId, true); + if (LevelId > 0) and (I = 0) then + begin + if (NamespaceId > 0) and (I = 0) then + I := TBaseSymbolTable(symbol_table).LookUp(CurrToken, NamespaceId, true); + + if I = 0 then + begin + for J := 0 to UsedNamespaceList.Count - 1 do + begin + I := TBaseSymbolTable(symbol_table).LookUp(CurrToken, + UsedNamespaceList[J], true); + if I > 0 then + break; + end; + end; + end; + + if I = 0 then + I := TBaseSymbolTable(symbol_table).LookUp(CurrToken, H_PascalNamespace, true); + + if I = 0 then + I := TBaseSymbolTable(symbol_table).LookUp(CurrToken, 0, true); + + if I > 0 then + begin + LastFactorTypeId := TBaseSymbolTable(symbol_table)[I].TerminalTypeId; + + if (TBaseSymbolTable(symbol_table)[I].Kind = kindTYPE) and + (TBaseSymbolTable(symbol_table)[I].FinalTypeId = typeCLASS) then + result := Integer(TBaseSymbolTable(symbol_table)[I].PClass) + else + result := TBaseSymbolTable(symbol_table)[I].Value; + + if not IsEmpty(result) then + begin + Call_SCANNER; + goto fin; + end; + end; + + if I = 0 then + begin + I := LookupId(CurrToken); + if I = 0 then + RaiseError(errUndeclaredIdentifier, [CurrToken]); + end; + + if TBaseSymbolTable(symbol_table)[I].Kind = KindTYPE then + begin + Call_SCANNER; + if IsCurrText('(') then + begin + Match('('); + result := Parse_Expression; + Match(')'); +{$IFNDEF PAXARM} + if TBaseSymbolTable(symbol_table)[I].HasPAnsiCharType then + begin + if VarType(result) in [varByte, varInteger] then + begin + W := Word(result); + if W <= 255 then + result := String(chr(W)) + else + result := String(chr(Hi(W))) + String(chr(Lo(W))); + end + else + result := String(result); + + LastFactorTypeId := typePANSICHAR; + end + else +{$ENDIF} + if TBaseSymbolTable(symbol_table)[I].HasPWideCharType then + begin + if VarType(result) in [varByte, varInteger] then + begin + W := Word(result); + if W <= 255 then + result := String(chr(W)) + else + result := String(chr(Hi(W))) + String(chr(Lo(W))); + end + else + result := String(result); + + LastFactorTypeId := typePWIDECHAR; + end + else + LastFactorTypeId := TBaseSymbolTable(symbol_table)[I].TerminalTypeId; + end; + + goto fin; + end + else if TBaseSymbolTable(symbol_table)[I].Kind = KindNAMESPACE then + begin + Call_SCANNER; + Match('.'); + LevelId := I; + goto again; + end + else if TBaseSymbolTable(symbol_table)[I].Kind = KindSUB then + begin + SubName := CurrToken; + Call_SCANNER; + Match('('); + result := Parse_Expression; + if StrEql(SubName, 'Trunc') then + begin +{$IFDEF VARIANTS} + curr := result; + result := Trunc(curr) +{$ELSE} + result := Integer(Trunc(result)) +{$ENDIF} + end + else if StrEql(SubName, 'Abs') then + result := Abs(result); + Match(')'); + Exit; + end; + + I := LookupId(CurrToken); + if I > 0 then + if TBaseSymbolTable(symbol_table)[I].Kind = kindCONST then + begin + result := TBaseSymbolTable(symbol_table)[I].Value; + Call_SCANNER; + Exit; + end; + + RaiseError(errConstantExpressionExpected, []); + end; + + fin: + + LevelId := temp_LevelId; + +end; + +function THeaderParser.IsCurrText(const S: String): Boolean; +begin + result := StrEql(CurrToken, S); +end; + +procedure THeaderParser.Match(const S: String); +begin + if IsCurrText(S) then + Call_SCANNER + else + RaiseError(errTokenExpected, [S, CurrToken]); +end; + +function THeaderParser.NotMatch(const S: String): Boolean; +begin + if not IsCurrText(S) then + result := true + else + begin + result := false; + Call_SCANNER; + end; +end; + +procedure THeaderParser.RaiseError(const Message: String; params: array of Const); +begin + SavedMessage := Message; + + if RaiseE then + raise PaxCompilerException.Create(Format(Message, params)) + else + raise ESilentException.Create(Format(Message, params)); +end; + +function THeaderParser.Parse: Boolean; +var + HasResult, IsOperator: Boolean; + I: Integer; +begin + result := true; + + IsAbstract := false; + + try + Call_SCANNER; + + IsShared := false; + IsDeprecated := false; + IsOverloaded := false; + IsProperty := false; + HasResult := false; + cc := ccREGISTER; + + if IsCurrText('class') then + begin + Call_SCANNER; + IsShared := true; + end; + + if IsCurrText('property') then + begin + Call_SCANNER; + IsProperty := true; + + Name := CurrToken; + + Parse_Ident; + + if IsCurrText(';') then + begin + Match(';'); + ResType := ''; + Exit; + end; + + if IsCurrText('[') then + Parse_FormalParameterList(']') + else + NP := 0; + + Match(':'); + ResType := Parse_Type; + + ReadIdent := ''; + WriteIdent := ''; + + while IsCurrText('read') or IsCurrText('write') do + begin + if IsCurrText('read') then + begin + Call_SCANNER; + ReadIdent := CurrToken; + Parse_Ident; + end + else if IsCurrText('write') then + begin + Call_SCANNER; + WriteIdent := CurrToken; + Parse_Ident; + end; + end; + Match(';'); + IsDefault := IsCurrText('default'); + + Exit; + end; + + IsOperator := false; + + if IsCurrText('function') then + begin + KS := ksFunction; + HasResult := true; + Call_SCANNER; + end + else if IsCurrText('procedure') then + begin + KS := ksProcedure; + Call_SCANNER; + end + else if IsCurrText('operator') then + begin + Call_SCANNER; + CallMode := cmSTATIC; + IsOperator := true; + end + else if IsCurrText('constructor') then + begin + KS := ksConstructor; + Call_SCANNER; + end + else if IsCurrText('destructor') then + begin + KS := ksDestructor; + Call_SCANNER; + end + else + Match('procedure'); + + Name := CurrToken; + if IsOperator then + begin + I := operator_list.Keys.IndexOf(Name); + if I >= 0 then + Name := operator_list.Values[I]; + end; + + if not (IsCurrText('(') or IsCurrText(';')) then + Parse_Ident; + + if IsCurrText('(') then + Parse_FormalParameterList(')') + else + NP := 0; + + if HasResult then + begin + Match(':'); + ResType := UpperCase(CurrToken); + Parse_Ident; + end + else if IsCurrText(':') then + begin + KS := ksFUNCTION; + Match(':'); + ResType := UpperCase(CurrToken); + Parse_Ident; + end + else + ResType := 'VOID'; + + if IsCurrText(';') then + Match(';'); + + repeat + if IsCurrText('abstract') then + begin + Call_SCANNER; + Match(';'); + IsAbstract := true; + Inc(AbstractMethodCount); + end + else if IsCurrText('static') then + begin + CallMode := cmSTATIC; + Call_SCANNER; + Match(';'); + end + else if IsCurrText('virtual') then + begin + CallMode := cmVIRTUAL; + Call_SCANNER; + Match(';'); + end + else if IsCurrText('overload') then + begin + IsOverloaded := true; + Call_SCANNER; + Match(';'); + end + else if IsCurrText('deprecated') then + begin + IsDeprecated := true; + Call_SCANNER; + if not IsCurrText(';') then + Call_SCANNER; + Match(';'); + end + else if IsCurrText('reintroduce') then + begin + Call_SCANNER; + Match(';'); + end + else if IsCurrText('dynamic') then + begin + CallMode := cmDYNAMIC; + Call_SCANNER; + Match(';'); + end + else if IsCurrText('override') then + begin + CallMode := cmOVERRIDE; + Call_SCANNER; + Match(';'); + end + else if IsCurrText('register') then + begin + cc := ccREGISTER; + Call_SCANNER; + Match(';'); + end + else if IsCurrText('stdcall') then + begin + cc := ccSTDCALL; + Call_SCANNER; + Match(';'); + end + else if IsCurrText('safecall') then + begin + cc := ccSAFECALL; + Call_SCANNER; + Match(';'); + end + else if IsCurrText('cdecl') then + begin + cc := ccCDECL; + Call_SCANNER; + Match(';'); + end + else if IsCurrText('msfastcall') then + begin + cc := ccMSFASTCALL; + Call_SCANNER; + Match(';'); + end + else + break; + until false; + + except + result := false; + end; +end; + +function THeaderParser.Parse_SetConstructor: Variant; +var + v1, v2: Variant; + J, TypeId, TypeBaseId: Integer; + ByteSet: TByteSet; + SetObject: TSetObject; +begin + ByteSet := []; + + Match('['); + if not IsCurrText(']') then + begin + repeat + v1 := Parse_Expression; + if IsCurrText('..') then + begin + Match('..'); + v2 := Parse_Expression; + for J:=Integer(V1) to Integer(V2) do + ByteSet := ByteSet + [J]; + end + else + begin + ByteSet := ByteSet + [Integer(v1)]; + end; + + If NotMatch(',') then + break; + until false; + + end + else + result := Undefined; + + Match(']'); + + if ByteSet <> [] then + begin + if CurrTypeName = '' then + begin + TypeId := H_TByteSet; + TypeBaseId := typeBYTE; + end + else + begin + TypeId := LookupId(CurrTypeName); + typeBaseId := TBaseSymbolTable(symbol_table).GetTypeBase(TypeId); + typeBaseId := TBaseSymbolTable(symbol_table)[TypeBaseId].FinalTypeId; + end; + + SetObject := TSetObject.Create(symbol_table, ByteSet, TypeId, typeBaseId); + result := VarObjectToVariant(SetObject); + end; +end; + +function THeaderParser.LookupTypeId(const S: String): Integer; +begin + result := TBaseSymbolTable(symbol_table).LookUpType(S, true); +end; + +function THeaderParser.LookupId(const S: String): Integer; +var + J: Integer; +begin + result := TBaseSymbolTable(symbol_table).LookUp(S, LevelId, true); + if result = 0 then + begin + if NamespaceId > 0 then + result := TBaseSymbolTable(symbol_table).LookUp(S, NamespaceId, true); + + if result = 0 then + begin + for J := 0 to UsedNamespaceList.Count - 1 do + begin + result := TBaseSymbolTable(symbol_table).LookUp(S, UsedNamespaceList[J], true); + if result > 0 then + break; + end; + end; + + if result = 0 then + result := TBaseSymbolTable(symbol_table).LookUp(S, H_PascalNamespace, true); + + if result = 0 then + result := TBaseSymbolTable(symbol_table).LookUp(S, 0, true); + end; +end; + +function THeaderParser.LookupAllIds(const S: String): TIntegerList; +var + Id, J: Integer; +begin + result := TIntegerList.Create; + + Id := TBaseSymbolTable(symbol_table).LookUp(S, LevelId, true); + if Id > 0 then + result.Add(id); + + if NamespaceId > 0 then + begin + Id := TBaseSymbolTable(symbol_table).LookUp(S, NamespaceId, true); + if Id > 0 then + result.Add(id); + end; + + for J := 0 to UsedNamespaceList.Count - 1 do + begin + Id := TBaseSymbolTable(symbol_table).LookUp(S, UsedNamespaceList[J], true); + if Id > 0 then + result.Add(id); + end; + + Id := TBaseSymbolTable(symbol_table).LookUp(S, H_PascalNamespace, true); + if Id > 0 then + result.Add(id); + + Id := TBaseSymbolTable(symbol_table).LookUp(S, 0, true); + if Id > 0 then + result.Add(id); +end; + +function THeaderParser.Register_SubrangeTypeDeclaration(const TypeName: String): Integer; +var + V1, V2: Variant; + TypeBaseId: Integer; +begin + V1 := Parse_Expression; + Match('..'); + V2 := Parse_Expression; + + TypeBaseId := LastFactorTypeId; + + result := TBaseSymbolTable(symbol_table).RegisterSubrangeType(LevelId, TypeName, TypeBaseId, V1, V2); +end; + +function THeaderParser.Register_EnumTypeDeclaration(const TypeName: String): Integer; +var + Temp: Integer; + S: String; +begin + result := TBaseSymbolTable(symbol_table).RegisterEnumType(LevelId, TypeName, typeINTEGER); + + Match('('); + Temp := -1; + + repeat + S := Parse_Ident; + if IsCurrText('=') then + begin + Match('='); + temp := Parse_Expression; + end + else + Inc(temp); + + TBaseSymbolTable(symbol_table).RegisterEnumValue(result, S, temp); + + if NotMatch(',') then + Break; + + until false; + Match(')'); +end; + +function THeaderParser.Register_SetTypeDeclaration(const TypeName: String): Integer; +var + TypeBaseId: Integer; +begin + Match('set'); + Match('of'); + TypeBaseId := Register_OrdinalType; + result := TBaseSymbolTable(symbol_table).RegisterSetType(LevelId, TypeName, TypeBaseId); +end; + +function THeaderParser.Register_ArrayTypeDeclaration(const TypeName: String): Integer; +var + RangeTypeId, ElemTypeId, I: Integer; + RangeTypeIds: TIntegerList; +begin + result := 0; + RangeTypeIds := TIntegerList.Create; + try + Match('array'); + Match('['); + repeat + if IsNextText('..') then + RangeTypeId := Register_SubrangeTypeDeclaration('') + else + begin + RangeTypeId := LookupId(CurrToken); + if RangeTypeId = 0 then + RaiseError(errUndeclaredIdentifier, [CurrToken]); + Call_SCANNER; + end; + RangeTypeIds.Add(RangeTypeId); + if not IsCurrText(',') then + break + else + Call_SCANNER; + until false; + Match(']'); + Match('of'); + + ElemTypeId := Register_Type; + + for I := RangeTypeIds.Count - 1 downto 0 do + begin + RangeTypeId := RangeTypeIds[I]; + result := TBaseSymbolTable(symbol_table).RegisterArrayType(LevelId, TypeName, RangeTypeId, ElemTypeId, 1); + ElemTypeId := result; + end; + finally + RangeTypeIds.Free; + end; +end; + +function THeaderParser.Register_RecordTypeDeclaration(const TypeName: String): Integer; +var + L: TStringList; + I, TypeId: Integer; +begin + result := TBaseSymbolTable(symbol_table).RegisterRecordType(LevelId, TypeName, 1); + + Match('record'); + L := TStringList.Create; + try + repeat + if IsCurrText('end') then + Break; + + L.Clear; + repeat // parse ident list + L.Add(Parse_Ident); + if NotMatch(',') then + break; + until false; + + Match(':'); + + TypeID := Register_Type; + + for I:=0 to L.Count - 1 do + TBaseSymbolTable(symbol_table).RegisterTypeField(result, L[I], TypeId); + + if IsCurrText(';') then + Match(';'); + + until false; + finally + L.Free; + end; + + Match('end'); +end; + +function THeaderParser.Register_OrdinalType: Integer; +begin + if TokenClass = tcIdentifier then + begin + result := LookupId(CurrToken); + if result > 0 then + begin + Call_SCANNER; + Exit; + end; + end; + + if IsCurrText('(') then + result := Register_EnumTypeDeclaration('') + else + result := Register_SubrangeTypeDeclaration(''); +end; + +function THeaderParser.Register_Type: Integer; +const TypeName = ''; +var + Id: Integer; +{$IFNDEF PAXARM} + V: Variant; +{$ENDIF} +begin + if not (IsCurrText('set') or IsCurrText('array') or IsCurrText('record')) then + if TokenClass = tcIdentifier then + begin + Id := LookupId(CurrToken); + if Id > 0 then + if TBaseSymbolTable(symbol_table)[id].Kind = KindTYPE then + begin + Call_SCANNER; +{$IFDEF PAXARM} + result := Id; +{$ELSE} + if (id = typeANSISTRING) and IsCurrText('[') then + begin + result := 0; + + Match('['); + V := Parse_Expression; + if VarType(V) in [varInteger, varByte] then + begin + result := TBaseSymbolTable(symbol_table).RegisterShortStringType(LevelId, + TypeName, V); + end + else + RaiseError(errIncompatibleTypesNoArgs, []); + Match(']'); + end + else + result := Id; +{$ENDIF} + + Exit; + end; + end; + + if IsCurrText('set') then + result := Register_SetTypeDeclaration(TypeName) + else if IsCurrText('array') then + result := Register_ArrayTypeDeclaration(TypeName) + else if IsCurrText('record') then + result := Register_RecordTypeDeclaration(TypeName) + else if IsCurrText('(') then + result := Register_EnumTypeDeclaration(TypeName) + else + result := Register_SubrangeTypeDeclaration(TypeName); +end; + +function THeaderParser.Register_StringTypeDeclaration(const TypeName: String): Integer; +{$IFNDEF PAXARM} +var + V: Variant; +{$ENDIF} +begin + Match('string'); +{$IFDEF PAXARM} + result := typeUNICSTRING; +{$ELSE} + {$IFDEF UNIC} + result := typeUNICSTRING; + {$ELSE} + result := typeANSISTRING; + {$ENDIF} + if IsCurrText('[') then + begin + Match('['); + V := Parse_Expression; + if VarType(V) in [varInteger, varByte] then + begin + result := TBaseSymbolTable(symbol_table).RegisterShortStringType(LevelId, + TypeName, V); + end + else + RaiseError(errIncompatibleTypesNoArgs, []); + Match(']'); + end + else + result := typeANSISTRING; +{$ENDIF} +end; + +function THeaderParser.ParseFullName: String; +begin + result := CurrToken; + while Buff[P] = '.' do + begin + Call_SCANNER; + Call_SCANNER; + result := result + '.' + CurrToken; + end; +end; + +function THeaderParser.Parse_QualTypeId: Integer; +var + S: String; + temp: Integer; +{$IFNDEF PAXARM} + V: Variant; +{$ENDIF} +begin + S := Parse_Ident; + result := LookupId(S); + + temp := LevelId; + + try + + while IsCurrText('.') +{$IFNDEF PAXARM} + or IsCurrText('[') +{$ENDIF} + do + begin + LevelId := result; + + if IsCurrText('.') then + begin + Match('.'); + S := Parse_Ident; + result := LookupId(S); + end +{$IFNDEF PAXARM} + else + begin + Match('['); + V := Parse_Expression; + if VarType(V) in [varInteger, varByte] then + begin + result := TBaseSymbolTable(symbol_table).RegisterShortStringType(LevelId, + '', V); + end + else + RaiseError(errIncompatibleTypesNoArgs, []); + Match(']'); + end; +{$ENDIF} + end; + + finally + + LevelId := temp; + + end; +end; + +function THeaderParser.Register_TypeAlias(const TypeName: String): Integer; +var + OriginTypeId: Integer; +begin + if IsCurrText('=') then + Match('=') + else if IsCurrText(':') then + Match(':'); + + OriginTypeId := Parse_QualTypeId; + result := TBaseSymbolTable(symbol_table).RegisterTypeAlias(LevelId, + TypeName, OriginTypeId); +end; + +function THeaderParser.RegisterTypeAlias(const TypeName: String; + OriginTypeId: Integer): Integer; +begin + result := TBaseSymbolTable(symbol_table).RegisterTypeAlias(LevelId, TypeName, + OriginTypeId); +end; + +function THeaderParser.Register_TypeDeclaration: Integer; +var + TypeName: String; + id: Integer; +{$IFNDEF PAXARM} + V: Variant; +{$ENDIF} +begin + TypeName := Parse_Ident; + Match('='); + + if not (IsCurrText('set') or IsCurrText('array') or IsCurrText('record')) then + if TokenClass = tcIdentifier then + begin + Id := LookupId(CurrToken); + if Id > 0 then + if TBaseSymbolTable(symbol_table)[id].Kind = KindTYPE then + begin + Call_SCANNER; +{$IFNDEF PAXARM} + if (id = typeANSISTRING) and IsCurrText('[') then + begin + result := 0; + + Match('['); + V := Parse_Expression; + if VarType(V) in [varInteger, varByte] then + begin + result := TBaseSymbolTable(symbol_table).RegisterShortStringType(LevelId, + TypeName, V); + end + else + RaiseError(errIncompatibleTypesNoArgs, []); + Match(']'); + end + else +{$ENDIF} + result := RegisterTypeAlias(TypeName, Id); + + Exit; + end; + end; + + if IsCurrText('set') then + result := Register_SetTypeDeclaration(TypeName) + else if IsCurrText('array') then + result := Register_ArrayTypeDeclaration(TypeName) + else if IsCurrText('record') then + result := Register_RecordTypeDeclaration(TypeName) + else if IsCurrText('(') then + result := Register_EnumTypeDeclaration(TypeName) + else + result := Register_SubrangeTypeDeclaration(TypeName); +end; + +function THeaderParser.Register_Variable(const VarName: String; Address: Pointer): Integer; +var + TypeId: Integer; +{$IFNDEF PAXARM} + V: Variant; +{$ENDIF} + S: String; +{$IFDEF DRTTI} + t: TRTTIType; + curr_kernel: TKernel; +{$ENDIF} +begin + TypeId := 0; + + S := ''; + Match(':'); + + if not (IsCurrText('set') or IsCurrText('array') or IsCurrText('record')) then + if TokenClass = tcIdentifier then + begin + S := ParseFullName; + + TypeId := LookupTypeId(S); + if TypeId > 0 then + begin + if TBaseSymbolTable(symbol_table)[TypeId].Kind = KindTYPE then + begin + Call_SCANNER; +{$IFNDEF PAXARM} + if (TypeId = typeANSISTRING) and IsCurrText('[') then + begin + Match('['); + V := Parse_Expression; + if VarType(V) in [varInteger, varByte] then + begin + TypeId := TBaseSymbolTable(symbol_table).RegisterShortStringType(LevelId, + '', V); + end + else + RaiseError(errIncompatibleTypesNoArgs, []); + Match(']'); + end; +{$ENDIF} + result := TBaseSymbolTable(symbol_table).RegisterVariable(LevelId, VarName, TypeId, Address); + Exit; + end; + end + else // TypeId = 0 + begin +{$IFDEF DRTTI} + if CurrImportUnit <> '' then + if kernel <> nil then + begin + curr_kernel := TKernel(kernel); + + S := CurrImportUnit + '.' + S; + t := PaxContext.FindType(S); + if t <> nil then + begin + TypeId := RegisterType(LevelId, t, + curr_kernel.SymbolTable); + result := curr_kernel.SymbolTable.RegisterVariable(LevelId, + VarName, TypeId, Address); + Exit; + end; + end; +{$ENDIF} + end; + end; + + if IsCurrText('set') then + TypeId := Register_SetTypeDeclaration('') + else if IsCurrText('array') then + TypeId := Register_ArrayTypeDeclaration('') + else if IsCurrText('record') then + TypeId := Register_RecordTypeDeclaration('') + else if IsCurrText('(') then + TypeId := Register_EnumTypeDeclaration('') + else if not IsNextText(';') then + TypeId := Register_SubrangeTypeDeclaration(''); + + if TypeId = 0 then + if S <> '' then + with TBaseSymbolTable(symbol_table) do + begin + ExternList.Add(Card + 1, + S, + erTypeId); + end; + + result := TBaseSymbolTable(symbol_table).RegisterVariable(LevelId, VarName, TypeId, Address); +end; + +procedure THeaderParser.Parse_ConstantInitialization(ArrObject: TArrObject; var TypeId: Integer); +var + TempArrObject: TArrObject; + SimpleObject: TSimpleObject; + V: Variant; + S: String; + DummyId, TempId, J: Integer; + AllTypes: TIntegerList; +begin + DummyId := -1; + + Match('('); + repeat + if IsCurrText('(') then + begin + TempArrObject := TArrObject.Create(nil); + Parse_ConstantInitialization(TempArrObject, DummyId); + ArrObject.AddVarObject(TempArrObject); + if NotMatch(',') then + break; + end + else if IsCurrText(')') then + break + else + begin + if IsNextText(':') then // record init + begin + S := CurrToken; + + if TypeId > 0 then + begin + TempId := TBaseSymbolTable(symbol_table).Lookup(S, TypeId, true); + if TempId = 0 then + begin + AllTypes := LookupAllIds(S); + try + for J := 0 to AllTypes.Count - 1 do + begin + TempId := TBaseSymbolTable(symbol_table).Lookup(S, AllTypes[J], true); + if TempId > 0 then + begin + TypeId := Alltypes[J]; + break; + end; + end; + finally + Alltypes.Free; + end; + end; + end; + + Call_SCANNER; + Match(':'); + if IsCurrText('(') then + begin + TempArrObject := TArrObject.Create(nil); + Parse_ConstantInitialization(TempArrObject, DummyId); + ArrObject.AddVarObject(TempArrObject); + end + else + begin + V := Parse_Expression; + SimpleObject := TSimpleObject.Create(nil, V, S); + ArrObject.AddVarObject(SimpleObject); + end; + if NotMatch(';') then + break; + end + else // array init + begin + + V := Parse_Expression; + SimpleObject := TSimpleObject.Create(nil, V, S); + ArrObject.AddVarObject(SimpleObject); + + if NotMatch(',') then + break; + end; + end; + until false; + + Match(')'); +end; + +function THeaderParser.Register_Constant(const ConstName: String): Integer; +var + TypeId, temp, I: Integer; + V: Variant; + ArrObject: TArrObject; + SimpleObject: TSimpleObject; + S: String; +begin + if IsCurrText('=') then + begin + Call_SCANNER; + V := Parse_Expression; + + if LastFactorTypeId = 0 then + result := TBaseSymbolTable(symbol_table).RegisterConstant(LevelId, ConstName, V) + else + result := TBaseSymbolTable(symbol_table).RegisterConstant(LevelId, ConstName, LastFactorTypeId, V); + Exit; + end; + + Match(':'); + + if not (IsCurrText('set') or IsCurrText('array') or IsCurrText('record')) then + begin + if TokenClass = tcIdentifier then + begin + TypeId := LookupTypeId(CurrToken); + if IsNextText('.') then + begin + Call_SCANNER; + Call_SCANNER; + temp := LevelId; + LevelId := TypeId; + TypeId := LookupId(CurrToken); + LevelId := temp; + end; + + if TypeId > 0 then + if TBaseSymbolTable(symbol_table)[TypeId].Kind = KindTYPE then + begin + Call_SCANNER; +{$IFNDEF PAXARM} + if (TypeId = typeANSISTRING) and IsCurrText('[') then + begin + Match('['); + V := Parse_Expression; + if VarType(V) in [varInteger, varByte] then + begin + TypeId := TBaseSymbolTable(symbol_table).RegisterShortStringType(LevelId, + '', V); + end + else + RaiseError(errIncompatibleTypesNoArgs, []); + Match(']'); + end; +{$ENDIF} + Match('='); + + if IsCurrText('(') then + begin + ArrObject := TArrObject.Create(symbol_table); + Parse_ConstantInitialization(ArrObject, TypeId); + V := VarObjectToVariant(ArrObject); + end + else + begin + DestFactorTypeId := TBaseSymbolTable(symbol_table)[TypeId].FinalTypeId; + V := Parse_Expression; + DestFactorTypeId := 0; + end; + + result := TBaseSymbolTable(symbol_table).RegisterConstant(LevelId, ConstName, TypeId, V); + Exit; + end; + end; + end; + + if IsCurrText('set') then + TypeId := Register_SetTypeDeclaration('') + else if IsCurrText('array') then + TypeId := Register_ArrayTypeDeclaration('') + else if IsCurrText('record') then + TypeId := Register_RecordTypeDeclaration('') + else if IsCurrText('(') then + TypeId := Register_EnumTypeDeclaration('') + else + TypeId := Register_SubrangeTypeDeclaration(''); + + Match('='); + + if IsCurrText('(') then + begin + ArrObject := TArrObject.Create(symbol_table); + Parse_ConstantInitialization(ArrObject, TypeId); + V := VarObjectToVariant(ArrObject); + end + else + begin + V := Parse_Expression; + if TBaseSymbolTable(symbol_table)[TypeId].FinalTypeId = typeARRAY then + begin + ArrObject := TArrObject.Create(symbol_table); + + S := V; + for I:=SLow(S) to SHigh(S) do + begin + SimpleObject := TSimpleObject.Create(nil, S[I], ''); + ArrObject.AddVarObject(SimpleObject); + end; + + V := VarObjectToVariant(ArrObject); + end; + end; + + result := TBaseSymbolTable(symbol_table).RegisterConstant(LevelId, ConstName, TypeId, V); +end; + +function THeaderParser.Register_RecordTypeField(const FieldName: String; Offset: Integer = - 1): Integer; +var + TypeId: Integer; +{$IFNDEF PAXARM} + V: Variant; +{$ENDIF} +begin + Match(':'); + if TokenClass = tcIdentifier then + begin + TypeId := LookupTypeId(CurrToken); + if TypeId > 0 then + if TBaseSymbolTable(symbol_table)[TypeId].Kind = KindTYPE then + begin + Call_SCANNER; +{$IFNDEF PAXARM} + if (TypeId = typeANSISTRING) and IsCurrText('[') then + begin + Match('['); + V := Parse_Expression; + if VarType(V) in [varInteger, varByte] then + begin + TypeId := TBaseSymbolTable(symbol_table).RegisterShortStringType(LevelId, + '', V); + end + else + RaiseError(errIncompatibleTypesNoArgs, []); + Match(']'); + end; +{$ENDIF} + result := TBaseSymbolTable(symbol_table).RegisterTypeField(LevelId, FieldName, TypeId, Offset); + Exit; + end; + end; + + if IsCurrText('set') then + TypeId := Register_SetTypeDeclaration('') + else if IsCurrText('(') then + TypeId := Register_EnumTypeDeclaration('') + else + TypeId := Register_SubrangeTypeDeclaration(''); + + result := TBaseSymbolTable(symbol_table).RegisterTypeField(LevelId, FieldName, TypeId, Offset); +end; + +function THeaderParser.Register_VariantRecordTypeField(const FieldName: String; + VarCount: Integer): Integer; +var + TypeId: Integer; +{$IFNDEF PAXARM} + V: Variant; +{$ENDIF} +begin + Match(':'); + if TokenClass = tcIdentifier then + begin + TypeId := LookupTypeId(CurrToken); + if TypeId > 0 then + if TBaseSymbolTable(symbol_table)[TypeId].Kind = KindTYPE then + begin + Call_SCANNER; +{$IFNDEF PAXARM} + if (TypeId = typeANSISTRING) and IsCurrText('[') then + begin + Match('['); + V := Parse_Expression; + if VarType(V) in [varInteger, varByte] then + begin + TypeId := TBaseSymbolTable(symbol_table).RegisterShortStringType(LevelId, + '', V); + end + else + RaiseError(errIncompatibleTypesNoArgs, []); + Match(']'); + end; +{$ENDIF} + result := TBaseSymbolTable(symbol_table).RegisterVariantRecordTypeField(LevelId, FieldName, TypeId, VarCount); + Exit; + end; + end; + + if IsCurrText('set') then + TypeId := Register_SetTypeDeclaration('') + else if IsCurrText('(') then + TypeId := Register_EnumTypeDeclaration('') + else + TypeId := Register_SubrangeTypeDeclaration(''); + + result := TBaseSymbolTable(symbol_table).RegisterVariantRecordTypeField(LevelId, FieldName, TypeId, VarCount); +end; + +end. diff --git a/Sources/PAXCOMP_HOSTCLS.pas b/Sources/PAXCOMP_HOSTCLS.pas new file mode 100644 index 0000000..478c018 --- /dev/null +++ b/Sources/PAXCOMP_HOSTCLS.pas @@ -0,0 +1,234 @@ +//////////////////////////////////////////////////////////////////////////// +// PaxCompiler +// Site: http://www.paxcompiler.com +// Author: Alexander Baranovsky (paxscript@gmail.com) +// ======================================================================== +// Copyright (c) Alexander Baranovsky, 2006-2014. All rights reserved. +// Code Version: 4.2 +// ======================================================================= +// Unit: PAXCOMP_HOSTCLS.pas +// ======================================================================== +//////////////////////////////////////////////////////////////////////////// +{$I PaxCompiler.def} +unit PAXCOMP_HOSTCLS; +interface +uses {$I uses.def} + SysUtils, + Classes, + PAXCOMP_SYS; + +procedure RegisterUsedClasses; + +implementation + +{$IFNDEF LINUX} + +{$IFDEF FPC} +procedure SearchClasses(AnInstance: Cardinal; UsedClasses: TList); +begin +end; +{$ELSE} + +procedure SearchClasses(AnInstance: Cardinal; UsedClasses: TList); +type + PPointer = ^Pointer; + + PIMAGE_DOS_HEADER = ^IMAGE_DOS_HEADER; + IMAGE_DOS_HEADER = packed record { DOS .EXE header } + e_magic : WORD; { Magic number } + e_cblp : WORD; { Bytes on last page of file } + e_cp : WORD; { Pages in file } + e_crlc : WORD; { Relocations } + e_cparhdr : WORD; { Size of header in paragraphs } + e_minalloc : WORD; { Minimum extra paragraphs needed } + e_maxalloc : WORD; { Maximum extra paragraphs needed } + e_ss : WORD; { Initial (relative) SS value } + e_sp : WORD; { Initial SP value } + e_csum : WORD; { Checksum } + e_ip : WORD; { Initial IP value } + e_cs : WORD; { Initial (relative) CS value } + e_lfarlc : WORD; { File address of relocation table } + e_ovno : WORD; { Overlay number } + e_res : packed array [0..3] of WORD; { Reserved words } + e_oemid : WORD; { OEM identifier (for e_oeminfo) } + e_oeminfo : WORD; { OEM information; e_oemid specific } + e_res2 : packed array [0..9] of WORD; { Reserved words } + e_lfanew : LongWord; { File address of new exe header } + end; + + PIMAGE_NT_HEADERS = ^IMAGE_NT_HEADERS; + IMAGE_NT_HEADERS = packed record + Signature : DWORD; + FileHeader : IMAGE_FILE_HEADER; + OptionalHeader : IMAGE_OPTIONAL_HEADER; + end; + + PIMAGE_SECTION_HEADER = ^IMAGE_SECTION_HEADER; + IMAGE_SECTION_HEADER = packed record + Name : packed array [0..IMAGE_SIZEOF_SHORT_NAME-1] of Char; + VirtualSize : DWORD; // or VirtualSize (union); + VirtualAddress : DWORD; + SizeOfRawData : DWORD; + PointerToRawData : DWORD; + PointerToRelocations : DWORD; + PointerToLinenumbers : DWORD; + NumberOfRelocations : WORD; + NumberOfLinenumbers : WORD; + Characteristics : DWORD; + end; + +var + DosHeader: PIMAGE_DOS_HEADER; + NTHeader: PIMAGE_NT_HEADERS; + SectionHeader: PIMAGE_SECTION_HEADER; + pCodeBegin, + pCodeEnd: PChar; + pCode, + p: PChar; + + function GetSectionHeader(const ASectionName: string): Boolean; + var + i: Integer; + begin + SectionHeader := PIMAGE_SECTION_HEADER(NTHeader); + Inc(PIMAGE_NT_HEADERS(SectionHeader)); + Result := True; + for i := 0 to NTHeader.FileHeader.NumberOfSections - 1 do + begin + if Strlicomp(SectionHeader.Name, PChar(ASectionName), + IMAGE_SIZEOF_SHORT_NAME) = 0 then + Exit; + Inc(SectionHeader); + end; + Result := False; + end; + + function InRangeOrNil(APointer, pMin, pMax: Pointer): Boolean; + begin + if (APointer = nil) or + ((Integer(APointer) >= Integer(pMin)) + and (Integer(APointer) <= Integer(pMax))) then + result := true + else + result := false; + end; + + function IsIdent(p: PChar): Boolean; + var + lg, + i: Integer; + begin + lg := ord(p^); + Inc(p); + Result := (lg > 0) and (p^ in ['A'..'Z', 'a'..'z', '_']); + if not Result then + Exit; + for i := 2 to lg do + begin + inc(p); + if not (p^ in ['0'..'9', 'A'..'Z', 'a'..'z', '_']) then + begin + Result := False; + Exit; + end; + end; + end; + + begin + { Read the DOS header } + DosHeader := PIMAGE_DOS_HEADER(AnInstance); + if not DosHeader.e_magic = IMAGE_DOS_SIGNATURE then // POUnrecognizedFileFormat; + begin + ErrMessageBox('No IMAGE_DOS_SIGNATURE'); + Exit; + end; + { Read the NT header (PE format) } + //NTHeader := PIMAGE_NT_HEADERS(Longint(DosHeader) + DosHeader.e_lfanew); + NTHeader := PIMAGE_NT_HEADERS(LongWord(DosHeader) + DosHeader.e_lfanew); + if IsBadReadPtr(NTHeader, SizeOf(IMAGE_NT_HEADERS)) or + (NTHeader.Signature <> IMAGE_NT_SIGNATURE) then // PONotAPEFile + Exit; + { Find the code section } +// if not GetSectionHeader('CODE') then // PONoInitializedData; +// Exit; + { Computes beginning & end of the code section } + pCodeBegin := PChar(AnInstance + SectionHeader.VirtualAddress); + pCodeEnd := pCodeBegin + (SectionHeader.SizeOfRawData - 3); + pCode := pCodeBegin; + while pCode < pCodeEnd do + begin + p := PPointer(pCode)^; + { Search for a class } + if (p = (pCode - vmtSelfPtr)) and // Is it SelfPtr pointer? + InRangeOrNil(PPointer(p+vmtClassName)^, p, pCodeEnd) and + InRangeOrNil(PPointer(p+vmtDynamicTable)^, p, pCodeEnd) and + InRangeOrNil(PPointer(p+vmtMethodTable)^, p, pCodeEnd) and + InRangeOrNil(PPointer(p+vmtFieldTable)^, p, pCodeEnd) and + InRangeOrNil(PPointer(p+vmtTypeInfo)^, pCodeBegin, pCodeEnd) and + InRangeOrNil(PPointer(p+vmtInitTable)^, pCodeBegin, pCodeEnd) and + InRangeOrNil(PPointer(p+vmtAutoTable)^, pCodeBegin, pCodeEnd) and + InRangeOrNil(PPointer(p+vmtIntfTable)^, pCodeBegin, pCodeEnd) and + IsIdent(PPointer(p+vmtClassName)^) then + begin + if UsedClasses.IndexOf(p) = -1 then + UsedClasses.Add(TClass(p)); + Inc(pCode, 4); + end + else + Inc(pCode); + end; +end; + +{$ENDIF} + +function EnumModulesFunc(HInstance: Integer; Data: Pointer): Boolean; +begin + result := true; + TList(Data).Add(Pointer(HInstance)); +end; + +procedure RegisterUsedClasses; +var + I: Integer; + AClass: TClass; + UsedClasses, UsedModules: TList; +begin + UsedModules := TList.Create; +{$IFNDEF FPC} +{$IFNDEF DPULSAR} + EnumModules(EnumModulesFunc, UsedModules); +{$ENDIF} +{$ENDIF} + + UsedClasses := TList.Create; + for I:=0 to UsedModules.Count - 1 do + SearchClasses(Cardinal(UsedModules[I]), UsedClasses); + + for I:=0 to UsedClasses.Count - 1 do + begin + AClass := TClass(UsedClasses[I]); + if AClass.InheritsFrom(TPersistent) then + begin + if GetClass(AClass.ClassName) = nil then + begin + try + Classes.RegisterClass(TPersistentClass(AClass)); + except + end; + end; + end; + end; + + UsedClasses.Free; + UsedModules.Free; +end; + +{$ELSE} + +procedure RegisterUsedClasses; +begin +end; + +{$ENDIF} + +end. diff --git a/Sources/PAXCOMP_IMPORT.pas b/Sources/PAXCOMP_IMPORT.pas new file mode 100644 index 0000000..0e43c89 --- /dev/null +++ b/Sources/PAXCOMP_IMPORT.pas @@ -0,0 +1,1882 @@ +//////////////////////////////////////////////////////////////////////////// +// PaxCompiler +// Site: http://www.paxcompiler.com +// Author: Alexander Baranovsky (paxscript@gmail.com) +// ======================================================================== +// Copyright (c) Alexander Baranovsky, 2006-2014. All rights reserved. +// Code Version: 4.2 +// ======================================================================== +// Unit: PAXCOMP_IMPORT.pas +// ======================================================================== +//////////////////////////////////////////////////////////////////////////// + +{$I PaxCompiler.def} +unit PAXCOMP_IMPORT; +interface +uses {$I uses.def} + SysUtils, + Classes, + PAXCOMP_SYS, + PAXCOMP_CONSTANTS, + PAXCOMP_KERNEL, + PAXCOMP_BYTECODE, + PAXCOMP_STDLIB, + PAXCOMP_BASESYMBOL_TABLE, + PAXCOMP_SYMBOL_REC, + PAXCOMP_SYMBOL_TABLE; + +const + MaxLines = 1000; + +procedure GenImport(kernel: TKernel; + L: TStrings; + StCard: Integer; + const ImportUnitName: String); + +implementation + +function CheckProc(const TypeName: String; Data: Pointer; + errKind: TExternRecKind): Boolean; +begin + result := false; +end; + +procedure GenImport(kernel: TKernel; + L: TStrings; + StCard: Integer; + const ImportUnitName: String); + +var + GTable: TBaseSymbolTable; + H_NS, H_SUB, H_TYPE: Integer; + + function ProcessSub(Id: Integer): Integer; forward; + function ProcessProcType(Id: Integer): Integer; forward; + function ProcessClassType(Id: Integer): Integer; forward; + function ProcessClassRefType(Id: Integer): Integer; forward; + function ProcessInterfaceType(Id: Integer): Integer; forward; + function ProcessRecordType(Id: Integer): Integer; forward; + function ProcessArrayType(Id: Integer): Integer; forward; + function ProcessDynArrayType(Id: Integer): Integer; forward; + function ProcessSetType(Id: Integer): Integer; forward; + function ProcessPointerType(Id: Integer): Integer; forward; + function ProcessAliasType(Id: Integer): Integer; forward; + function ProcessSubrangeType(Id: Integer): Integer; forward; + function ProcessShortstringType(Id: Integer): Integer; forward; + function ProcessEnumType(Id: Integer): Integer; forward; + function ProcessConst(Id: Integer): Integer; forward; + + function CallConvStr(R: TSymbolRec): String; + begin + case R.CallConv of + 0: result := '_ccREGISTER'; + ccSTDCALL: result := '_ccSTDCALL'; + ccREGISTER: result := '_ccREGISTER'; + ccCDECL: result := '_ccCDECL'; + ccPASCAL: result := '_ccPASCAL'; + ccSAFECALL: result := '_ccSAFECALL'; + ccMSFASTCALL: result := '_ccMSFASTCALL'; + else + raise Exception.Create(errInternalError); + end; + end; + + function CallModeStr(R: TSymbolRec): String; + begin + case R.CallMode of + cmNONE: result := '_cmNONE'; + cmVIRTUAL: result := '_cmVIRTUAL'; + cmOVERRIDE: result := '_cmOVERRIDE'; + else + raise Exception.Create(errInternalError); + end; + end; + + function Tab(L: Integer): String; + var + I: Integer; + begin + result := ''; + for I:=1 to L do + result := result + ' '; + end; + +var + LP, L1, L2, LU: TStringList; + Code: TCode; + SymbolTable: TSymbolTable; + Op: Integer; + + procedure AddLine(const S: String); + begin + L.Add(S); + end; + + procedure AddP(const S: String); + begin + LP.Add(S); + end; + + procedure Add1(const S: String); + begin + if L1.IndexOf(S) = -1 then + L1.Add(S); + end; + + procedure Add2(const S: String); + begin + L2.Add(S); + end; + + procedure AddUnit(const S: String); + var + I: Integer; + begin + for I:=0 to LU.Count - 1 do + if StrEql(LU[I], S) then + Exit; + LU.Add(S); + end; + + procedure AddUnits; + var + I: Integer; + begin + AddLine('uses'); + for I:=0 to LU.Count - 1 do + if I < LU.Count - 1 then + AddLine(Tab(2) + LU[I] + ',') + else + AddLine(Tab(2) + LU[I] + ';'); + end; + + function StrLiteral(const S: String): String; + begin + result := '''' + S + ''''; + end; + + function UpdateTypeId(GTableRecNo: Integer; OldTypeId: Integer): Integer; + var + S: String; + begin + if OldTypeId < Types.Count then + begin + result := OldTypeId; + Exit; + end; + S := SymbolTable[OldTypeId].FullName; + result := GTable.LookupFullName(S, true); + if result > 0 then + Exit; + GTable.ExternList.Add(GTableRecNo, + S, + erTypeId); + end; + + function ProcessOldType(OldTypeId: Integer): Integer; + var + S: String; + I: Integer; + R: TCodeRec; + begin + if OldTypeId < Types.Count then + begin + result := OldTypeId; + Exit; + end; + S := SymbolTable[OldTypeId].FullName; + result := GTable.LookupFullName(S, true); + if result > 0 then + Exit; + for I:=1 to Code.Card do + if Code[I].Arg1 = OldTypeId then + begin + R := Code[I]; + Op := R.Op; + + R.Op := OP_NOP; + if Op = OP_BEGIN_PROC_TYPE then + begin + result := ProcessProcType(R.Arg1); + break; + end + else if Op = OP_BEGIN_ALIAS_TYPE then + begin + result := ProcessAliasType(R.Arg1); + break; + end + else if Op = OP_BEGIN_CLASS_TYPE then + begin + result := ProcessClassType(R.Arg1); + break; + end + else if Op = OP_BEGIN_CLASSREF_TYPE then + begin + result := ProcessClassRefType(R.Arg1); + break; + end + else if Op = OP_BEGIN_INTERFACE_TYPE then + begin + result := ProcessInterfaceType(R.Arg1); + break; + end + else if Op = OP_BEGIN_RECORD_TYPE then + begin + result := ProcessRecordType(R.Arg1); + break; + end + else if Op = OP_BEGIN_ARRAY_TYPE then + begin + result := ProcessArrayType(R.Arg1); + break; + end + else if Op = OP_BEGIN_DYNARRAY_TYPE then + begin + result := ProcessDynArrayType(R.Arg1); + break; + end + else if Op = OP_BEGIN_SUBRANGE_TYPE then + begin + result := ProcessSubrangeType(R.Arg1); + break; + end + else if Op = OP_BEGIN_ENUM_TYPE then + begin + result := ProcessEnumType(R.Arg1); + break; + end + else if Op = OP_BEGIN_SET_TYPE then + begin + result := ProcessSetType(R.Arg1); + break; + end + else if Op = OP_BEGIN_POINTER_TYPE then + begin + result := ProcessPointerType(R.Arg1); + break; + end + else if Op = OP_BEGIN_SHORTSTRING_TYPE then + begin + result := ProcessShortstringType(R.Arg1); + break; + end + else if Op = OP_BEGIN_SUB then + begin + result := ProcessSub(R.Arg1); + break; + end + else if Op = OP_BEGIN_CONST then + begin + result := ProcessConst(R.Arg1); + break; + end + end; + end; + + function UpdateLevelId(R: TSymbolRec): Integer; + var + S: String; + begin + result := R.Level; + if result > 0 then + begin + S := SymbolTable[result].FullName; + result := GTable.LookupFullName(S, true); + end; + end; + + function ProcessNamespace(Id: Integer): Integer; + var + S: String; + begin + S := SymbolTable[Id].Name; + result := GTable.RegisterNamespace(0, S); + H_NS := result; + end; + + function ProcessConst(Id: Integer): Integer; + var + ConstID, LevelId, ConstTypeId: Integer; + ConstName: String; + begin + ConstId := Id; + + if SymbolTable[ConstId].OwnerId > 0 then + begin + result := 0; + Exit; + end; + + LevelId := SymbolTable[ConstId].Level; + if LevelId = 0 then + LevelId := 0 + else if SymbolTable[LevelId].Kind = kindNAMESPACE then + LevelId := H_NS + else + LevelId := UpdateLevelId(SymbolTable[ConstId]); + + ConstName := SymbolTable[ConstId].Name; + ConstTypeId := ProcessOldType(SymbolTable[ConstId].TypeID); + + result := GTable.RegisterConstant(LevelId, ConstName, ConstTypeId, + SymbolTable[ConstId].Value); + end; + + function ProcessSub(Id: Integer): Integer; + var + I, SubID, LevelId, ResTypeId, CallConv, ParamId, ParamTypeId: Integer; + SubName: String; + SR: TSymbolRec; + IsMethod, InsideBody: Boolean; + CodeRec: TCodeRec; + begin + IsMethod := false; + + InsideBody := false; + + for I:=1 to Code.Card do + begin + CodeRec := Code[I]; + if CodeRec.Op = OP_BEGIN_SUB then + begin + if CodeRec.Arg1 = Id then + begin + CodeRec.Op := OP_NOP; + InsideBody := true; + end; + end + else if CodeRec.Op = OP_END_SUB then + begin + if CodeRec.Arg1 = Id then + begin + CodeRec.Op := OP_NOP; + InsideBody := false; + end; + end + else if CodeRec.Op = OP_BEGIN_DYNARRAY_TYPE then + begin + if InsideBody then + begin + ProcessDynarrayType(CodeRec.Arg1); + CodeRec.Op := OP_NOP; + end; + end; + end; + + SubId := Id; + + for I:=0 to SymbolTable[SubId].Count - 1 do + begin + ParamId := SymbolTable.GetParamId(SubId, I); + SR := SymbolTable[ParamId]; + if SR.TypeID = 0 then + begin + result := 0; + Exit; + end; + end; + + LevelId := SymbolTable[SubId].Level; + if LevelId = 0 then + LevelId := 0 + else if SymbolTable[LevelId].Kind = kindNAMESPACE then + LevelId := H_NS + else + begin + LevelId := H_TYPE; + IsMethod := true; + + if SymbolTable[SubId].Vis <> cvPublic then + begin + result := 0; + Exit; + end; + end; + + SubName := SymbolTable[SubId].Name; + CallConv := SymbolTable[SubId].CallConv; + + if SubName <> '' then + if SubName[1] = '_' then + begin + result := 0; + Exit; + end; + + ResTypeId := UpdateTypeId(GTable.Card + 1, SymbolTable[SubId].TypeID); + + if IsMethod then + case SymbolTable[SubId].Kind of + kindCONSTRUCTOR: H_SUB := GTable.RegisterConstructor(LevelId, SubName, nil, ccREGISTER); + kindDESTRUCTOR: H_SUB := GTable.RegisterDestructor(LevelId, SubName, nil, ccREGISTER); + else + H_SUB := GTable.RegisterMethod(LevelId, + SubName, + ResTypeId, + CallConv, + nil, + SymbolTable[SubId].IsSharedMethod, + SymbolTable[SubId].CallMode, + SymbolTable[SubId].MethodIndex); + end + else + H_SUB := GTable.RegisterRoutine(LevelId, SubName, ResTypeId, CallConv, nil); + + GTable[GTable.LastSubId].OverCount := SymbolTable[SubId].OverCount; + + result := H_SUB; + + for I:=0 to SymbolTable[SubId].Count - 1 do + begin + ParamId := SymbolTable.GetParamId(SubId, I); + SR := SymbolTable[ParamId]; + + ParamTypeId := UpdateTypeId(GTable.Card + 1, SR.TypeID); + + GTable.RegisterParameter(H_SUB, ParamTypeId, + SR.Value, SR.ByRef, SR.Name); + if SR.IsConst then + GTable[GTable.Card].IsConst := true; + end; + end; + + function ProcessProcType(Id: Integer): Integer; + var + LevelId, TypeId, DummySubId, FinTypeId: Integer; + TypeName: String; + begin + TypeId := Id; + + LevelId := H_NS; + TypeName := SymbolTable[TypeId].Name; + DummySubId := SymbolTable[TypeId].PatternId; + + if TypeName = '' then + begin + result := 0; + Exit; + end; + + DummySubId := ProcessOldType(DummySubId); + + FinTypeId := SymbolTable[TypeId].FinalTypeId; + + case FinTypeId of + typePROC: result := GTable.RegisterProceduralType(LevelId, + TypeName, + DummySubId); + typeEVENT: result := GTable.RegisterEventType(LevelId, + TypeName, + DummySubId); + else + raise Exception.Create(errInternalError); + end; + end; + + function ProcessSubrangeType(Id: Integer): Integer; + var + LevelId, TypeId, TypeBaseId: Integer; + TypeName: String; + B1, B2: Integer; + begin + TypeId := Id; + + LevelId := H_NS; + TypeName := SymbolTable[TypeId].Name; + + if TypeName = '' then + begin + result := 0; + Exit; + end; + + TypeBaseId := ProcessOldType(SymbolTable[TypeId].TypeId); + B1 := SymbolTable.GetLowBoundRec(TypeId).Value; + B2 := SymbolTable.GetHighBoundRec(TypeId).Value; + + result := GTable.RegisterSubrangeType(LevelId, + TypeName, + TypeBaseId, + B1, B2); + end; + + function ProcessEnumType(Id: Integer): Integer; + var + I, LevelId, TypeId, TypeBaseId: Integer; + TypeName: String; + RI: TSymbolRec; + begin + TypeId := Id; + + LevelId := H_NS; + TypeName := SymbolTable[TypeId].Name; + + if TypeName = '' then + begin + result := 0; + Exit; + end; + + TypeBaseId := SymbolTable[TypeId].PatternId; + + TypeBaseId := ProcessOldType(TypeBaseId); + + result := GTable.RegisterEnumType(LevelId, + TypeName, + TypeBaseId); + + for I:=TypeId + 1 to SymbolTable.Card do + begin + RI := SymbolTable[I]; + if RI.OwnerId = TypeId then + GTable.RegisterEnumValue(result, + RI.Name, + RI.Value); + end; + end; + + function ProcessSetType(Id: Integer): Integer; + var + LevelId, TypeId, OriginTypeId: Integer; + TypeName: String; + begin + TypeId := Id; + + LevelId := H_NS; + TypeName := SymbolTable[TypeId].Name; + + if TypeName = '' then + begin + result := 0; + Exit; + end; + + OriginTypeId := SymbolTable[TypeId].PatternId; + + OriginTypeId := ProcessOldType(OriginTypeId); + + result := GTable.RegisterSetType(LevelId, + TypeName, + OriginTypeId); + end; + + function ProcessPointerType(Id: Integer): Integer; + var + LevelId, TypeId, OriginTypeId: Integer; + TypeName: String; + begin + TypeId := Id; + + LevelId := H_NS; + TypeName := SymbolTable[TypeId].Name; + + if TypeName = '' then + begin + result := 0; + Exit; + end; + + OriginTypeId := SymbolTable[TypeId].PatternId; + + OriginTypeId := ProcessOldType(OriginTypeId); + + result := GTable.RegisterPointerType(LevelId, + TypeName, + OriginTypeId); + end; + + function ProcessAliasType(Id: Integer): Integer; + var + LevelId, TypeId, OriginTypeId: Integer; + TypeName: String; + begin + TypeId := Id; + + LevelId := H_NS; + TypeName := SymbolTable[TypeId].Name; + + if TypeName = '' then + begin + result := 0; + Exit; + end; + + OriginTypeId := SymbolTable[TypeId].PatternId; + OriginTypeId := ProcessOldType(OriginTypeId); + + result := GTable.RegisterTypeAlias(LevelId, + TypeName, + OriginTypeId); + end; + + function ProcessShortstringType(Id: Integer): Integer; + var + LevelId, TypeId, L: Integer; + TypeName: String; + begin + TypeId := Id; + + LevelId := H_NS; + TypeName := SymbolTable[TypeId].Name; + L := SymbolTable[TypeId].Count; + + if TypeName = '' then + begin + result := 0; + Exit; + end; + + result := GTable.RegisterShortstringType(LevelId, + TypeName, + L); + end; + + function ProcessClassType(Id: Integer): Integer; + var + I, J, K: Integer; + LevelId, TypeId, FieldTypeId, ReadId, WriteId, ParamTypeId, PropId, + _ReadId, _WriteId: Integer; + TypeName, SubName: String; + RI, RJ: TSymbolRec; + begin + TypeId := Id; + + _ReadId := 0; + _WriteId := 0; + + LevelId := H_NS; + TypeName := SymbolTable[TypeId].Name; + + if TypeName = '' then + begin + result := 0; + Exit; + end; + + H_TYPE := GTable.RegisterClassTypeForImporter(LevelId, TypeName); + result := H_TYPE; + + for I:=TypeId + 1 to SymbolTable.Card do + begin + RI := SymbolTable[I]; + + if RI.Vis <> cvPublic then + continue; + + if RI.Level = TypeId then + case RI.Kind of + kindTYPE_FIELD: + begin + FieldTypeId := UpdateTypeId(GTable.Card + 1, RI.TypeID); + GTable.RegisterTypeField(H_TYPE, + RI.Name, + FieldTypeID, + RI.Shift); + end; + kindPROP: + begin + FieldTypeId := UpdateTypeId(GTable.Card + 1, RI.TypeID); + if RI.ReadId > 0 then + begin + SubName := '@R_' + RI.FullName; + SubName := StringReplace(SubName, '.', '_', [rfReplaceAll, rfIgnoreCase]); + + _ReadId := GTable.Card + 1; + + ReadId := GTable.RegisterMethod(LevelId, SubName, FieldTypeId, ccSTDCALL, nil); + + K := 0; + + for J:=I + 1 to SymbolTable.Card do + begin + RJ := SymbolTable[J]; + if RJ.Level = I then + if RJ.Kind = kindVAR then + if RJ.Name <> '' then + begin + Inc(K); + + ParamTypeId := UpdateTypeId(GTable.Card + 1, RJ.TypeID); + + GTable.RegisterParameter(ReadId, ParamTypeId, + RJ.Value, RJ.ByRef, RJ.Name); + if RJ.IsConst then + GTable[GTable.Card].IsConst := true; + + if K = RI.Count then + break; + end; + end; + + end + else + ReadId := 0; + + if RI.WriteId > 0 then + begin + SubName := '@W_' + RI.FullName; + SubName := StringReplace(SubName, '.', '_', [rfReplaceAll, rfIgnoreCase]); + + _WriteId := GTable.Card + 1; + + WriteId := GTable.RegisterMethod(LevelId, SubName, typeVOID, ccSTDCALL, nil); + + K := 0; + + for J:=I + 1 to SymbolTable.Card do + begin + RJ := SymbolTable[J]; + if RJ.Level = I then + if RJ.Kind = kindVAR then + if RJ.Name <> '' then + begin + Inc(K); + + ParamTypeId := UpdateTypeId(GTable.Card + 1, RJ.TypeID); + + GTable.RegisterParameter(WriteId, ParamTypeId, + RJ.Value, RJ.ByRef, RJ.Name); + if RJ.IsConst then + GTable[GTable.Card].IsConst := true; + + if K = RI.Count then + break; + end; + end; + + FieldTypeId := UpdateTypeId(GTable.Card + 1, RI.TypeID); + GTable.RegisterParameter(WriteId, FieldTypeId, + Unassigned, false, 'Value'); + GTable[GTable.Card].IsConst := true; + end + else + WriteId := 0; + + PropId := GTable.RegisterProperty(H_TYPE, + RI.Name, + FieldTypeId, + ReadId, + WriteId, + RI.IsDefault); + + if RI.ReadId > 0 then + GTable[_ReadId].Position := PropId; + if RI.WriteId > 0 then + GTable[_WriteId].Position := PropId; + + end; + kindSUB, kindCONSTRUCTOR, kindDESTRUCTOR: + begin + ProcessSub(I); + end; + end; + end; + end; + + function ProcessClassRefType(Id: Integer): Integer; + var + LevelId, TypeId, OriginTypeId: Integer; + TypeName: String; + begin + TypeId := Id; + + LevelId := H_NS; + TypeName := SymbolTable[TypeId].Name; + OriginTypeId := SymbolTable[TypeId].PatternId; + + if TypeName = '' then + begin + result := 0; + Exit; + end; + + OriginTypeId := ProcessOldType(OriginTypeId); + + result := GTable.RegisterClassReferenceType(LevelId, + TypeName, + OriginTypeId); + end; + + function ProcessInterfaceType(Id: Integer): Integer; + var + I: Integer; + LevelId, TypeId, FieldTypeId: Integer; + TypeName: String; + RI: TSymbolRec; + GUID: TGUID; + D: packed record D1, D2: Double end; + ReadIndex, WriteIndex: Integer; + begin + TypeId := Id; + + LevelId := H_NS; + TypeName := SymbolTable[TypeId].Name; + D.D1 := SymbolTable[TypeId+1].Value; + D.D2 := SymbolTable[TypeId+2].Value; + GUID := TGUID(D); + + if TypeName = '' then + begin + result := 0; + Exit; + end; + + H_TYPE := GTable.RegisterInterfaceType(LevelId, TypeName, GUID); + result := H_TYPE; + + for I:=TypeId + 1 to SymbolTable.Card do + begin + RI := SymbolTable[I]; + + if RI.Vis <> cvPublic then + continue; + + if RI.Level = TypeId then + case RI.Kind of + kindPROP: + begin + FieldTypeId := UpdateTypeId(GTable.Card + 1, RI.TypeID); + if RI.ReadId > 0 then + ReadIndex := SymbolTable[RI.ReadId].MethodIndex + else + ReadIndex := 0; + if RI.WriteId > 0 then + WriteIndex := SymbolTable[RI.ReadId].MethodIndex + else + WriteIndex := 0; + GTable.RegisterInterfaceProperty(H_TYPE, + RI.Name, + FieldTypeId, + ReadIndex, + WriteIndex); + end; + kindSUB: + begin + ProcessSub(I); + end; + end; + end; + end; + + function ProcessRecordType(Id: Integer): Integer; + var + I, K: Integer; + LevelId, TypeId, Align, FieldTypeId: Integer; + TypeName: String; + RI: TSymbolRec; + L: TIntegerList; + begin + TypeId := Id; + + LevelId := H_NS; + TypeName := SymbolTable[TypeId].Name; + Align := SymbolTable[TypeId].DefaultAlignment; + + if TypeName = '' then + begin + result := 0; + Exit; + end; + + L := TIntegerList.Create; + for I:=TypeId + 1 to SymbolTable.Card do + begin + RI := SymbolTable[I]; + if RI.Level = TypeId then + if RI.Kind = kindTYPE_FIELD then + begin + FieldTypeId := ProcessOldType(RI.TypeID); + L.Add(FieldTypeId); + end; + end; + + try + + H_TYPE := GTable.RegisterRecordType(LevelId, TypeName, Align); + result := H_TYPE; + + K := -1; + + for I:=TypeId + 1 to SymbolTable.Card do + begin + RI := SymbolTable[I]; + if RI.Level = TypeId then + if RI.Kind = kindTYPE_FIELD then + begin + Inc(K); + FieldTypeId := L[K]; + GTable.RegisterTypeField(H_TYPE, + RI.Name, + FieldTypeID, + RI.Shift); + end; + end; + + finally + L.Free; + end; + end; + + function ProcessArrayType(Id: Integer): Integer; + var + LevelId, TypeId, Align, RangeTypeId, ElemTypeId: Integer; + TypeName: String; + begin + TypeId := Id; + + SymbolTable.GetArrayTypeInfo(TypeId, RangeTypeId, ElemTypeId); + + LevelId := H_NS; + TypeName := SymbolTable[TypeId].Name; + Align := SymbolTable[TypeId].DefaultAlignment; + + if TypeName = '' then + begin + result := 0; + Exit; + end; + + RangeTypeId := ProcessOldType(RangeTypeId); + ElemTypeId := ProcessOldType(ElemTypeId); + + result := GTable.RegisterArrayType(LevelId, TypeName, + RangeTypeId, ElemTypeId, Align); + end; + + function ProcessDynArrayType(Id: Integer): Integer; + var + LevelId, TypeId, ElemTypeId: Integer; + TypeName: String; + begin + TypeId := Id; + + LevelId := H_NS; + TypeName := SymbolTable[TypeId].Name; + ElemTypeId := SymbolTable[TypeId].PatternId; + + if TypeName = '' then + begin + result := 0; + Exit; + end; + + ElemTypeId := ProcessOldType(ElemTypeId); + + result := GTable.RegisterDynamicArrayType(LevelId, TypeName, + ElemTypeId); + end; + + function GetStrTypeConst(TypeId: Integer): String; + var + T: Integer; + S: String; + begin + if TypeId in [0, typeVOID] then + result := '_typeVOID' + else + begin + if TypeId >= FirstLocalId then + T := TypeId - FirstLocalId + StCard + else + T := TypeId; + + S := GTable[TypeId].Name; + if PosCh('#', S) > 0 then + S := RemoveCh('#', S); + + if PosCh('$', S) > 0 then + S := 'AType'; + + result := S + '_' + IntToStr(T); + + Add1('const ' + result + ' = ' + IntToStr(T) + '; // ' + IntToStr(TypeId)); + end; + end; + + function GetTypeName(R: TSymbolRec): String; + var + T: Integer; + begin + result := GTable[R.TypeId].Name; + if R.FinalTypeId = typeDYNARRAY then + begin + if Pos('DynarrayType_', result) = 1 then + begin + T := GTable[R.TypeID].PatternId; + if T = H_TVarRec then + result := 'array of const' + else + result := 'array of ' + GTable[T].Name; + end; + end; + end; + + function CheckSub(SubId: Integer): Boolean; + var + I, ParamId: Integer; + begin + result := true; + if GTable[SubId].TypeID = 0 then + begin + result := false; + Exit; + end; + for I:=0 to GTable[SubId].Count - 1 do + begin + ParamId := GTable.GetParamId(SubId, I); + if GTable[ParamId].TypeID = 0 then + begin + result := false; + Exit; + end; + end; + end; + + function SubSize(SubId: Integer): Integer; + var + K: Integer; + begin + K := GTable[SubId].Count; + if K = 0 then + result := 3 + else + result := GTable.GetParamId(SubId, K - 1) - SubId + 1; + end; + + function CheckProp(PropId: Integer): Boolean; + begin + result := GTable[PropId].TypeID <> 0; + end; + + function PropSize(PropId: Integer): Integer; + begin + result := 2; + end; + +var + RegProcName: String; + T, KK, I, J, K, RangeTypeId, ElemTypeId, TotalOverCount: Integer; + RI, RJ: TSymbolRec; + R: TCodeRec; + + S, StrLevelConst, StrTypeConst, StrCallConv, StrCallMode, StrAddress, StrValue, + SubName, TypeName, StrRead, StrWrite: String; + NewKernel: TKernel; + RegisteredClasses: TStringList; +begin + RegProcName := 'Register_' + ImportUnitName; + Code := TKernel(kernel).Code; + SymbolTable := TKernel(kernel).SymbolTable; + + LP := TStringList.Create; + L1 := TStringList.Create; + L2 := TStringList.Create; + LU := TStringList.Create; + RegisteredClasses := TStringList.Create; + + NewKernel := TKernel.Create(nil); + GTable := NewKernel.SymbolTable; + + try + AddUnit('Types'); + AddUnit('Classes'); + AddUnit('PaxCompiler'); + AddUnit('PaxRegister'); + + for I:=1 to Code.Card do + begin + R := Code[I]; + Op := R.Op; + if Op = OP_BEGIN_NAMESPACE then + ProcessNamespace(R.Arg1) + else if Op = OP_BEGIN_PROC_TYPE then + ProcessProcType(R.Arg1) + else if Op = OP_BEGIN_ALIAS_TYPE then + ProcessAliasType(R.Arg1) + else if Op = OP_BEGIN_INTERFACE_TYPE then + ProcessInterfaceType(R.Arg1) + else if Op = OP_BEGIN_CLASS_TYPE then + ProcessClassType(R.Arg1) + else if Op = OP_BEGIN_CLASSREF_TYPE then + ProcessClassRefType(R.Arg1) + else if Op = OP_BEGIN_RECORD_TYPE then + ProcessRecordType(R.Arg1) + else if Op = OP_BEGIN_ARRAY_TYPE then + ProcessArrayType(R.Arg1) + else if Op = OP_BEGIN_DYNARRAY_TYPE then + ProcessDynArrayType(R.Arg1) + else if Op = OP_BEGIN_SUBRANGE_TYPE then + ProcessSubrangeType(R.Arg1) + else if Op = OP_BEGIN_ENUM_TYPE then + ProcessEnumType(R.Arg1) + else if Op = OP_BEGIN_SET_TYPE then + ProcessSetType(R.Arg1) + else if Op = OP_BEGIN_POINTER_TYPE then + ProcessPointerType(R.Arg1) + else if Op = OP_BEGIN_SHORTSTRING_TYPE then + ProcessShortstringType(R.Arg1) + else if Op = OP_BEGIN_SUB then + ProcessSub(R.Arg1) + else if Op = OP_BEGIN_CONST then + ProcessConst(R.Arg1); + R.Op := OP_NOP; + end; + + GTable.ResolveExternList(CheckProc, nil); + + TotalOverCount := 0; + + for I:=FirstLocalId + 1 to GTable.Card do + begin + RI := GTable[I]; + + KK := I - FirstLocalId + StCard; + + if Length(RI.Name) = 0 then + continue; + + case RI.Kind of + KindNAMESPACE: + begin + AddUnit(RI.Name); + + Add2(Tab(2) + 'H_NS := ' + 'RegisterNamespace(0, ' + + StrLiteral(RI.Name) + + ');' + '//' + IntToStr(KK)); + end; + KindCONST: + begin + If RI.OwnerId > 0 then + continue; + + If RI.Level = 0 then + StrLevelConst := '0' + else if GTable[RI.Level].Kind = kindNAMESPACE then + StrLevelConst := 'H_NS'; + StrTypeConst := GetStrTypeConst(RI.TypeId); + StrValue := GTable.ValueStr(I); + if PosCh('[', StrValue) > 0 then + StrValue := '0'; + if RI.FinalTypeId in StringTypes then + StrValue := '''' + StrValue + ''''; + if RI.HasPAnsiCharType then + StrValue := '''' + StrValue + ''''; + Add2(Tab(2) + 'RegisterConstant(' + + StrLevelConst + ',' + + StrLiteral(RI.Name) + ',' + + StrTypeConst + ',' + + StrValue + + ');' + '//' + IntToStr(KK)); + end; + KindSUB, kindCONSTRUCTOR, kindDESTRUCTOR: + begin + if not CheckSub(I) then + begin + Add2(Tab(2) + '// Cannot import "' + RI.FullName + '"'); + Add2(Tab(2) + 'RegisterSpace(' + IntToStr(SubSize(I)) + ');'); + continue; + end; + + If RI.Level = 0 then + StrLevelConst := '0' + else if GTable[RI.Level].Kind = kindNAMESPACE then + StrLevelConst := 'H_NS' + else + StrLevelConst := 'H_TYPE'; + + StrTypeConst := GetStrTypeConst(RI.TypeId); + + StrCallConv := CallConvStr(RI); + StrCallMode := CallModeStr(RI); + + if PosCh('#', RI.Name) = 1 then + StrAddress := 'nil' + else + StrAddress := '@' + RI.FullName; + + case RI.Kind of + kindCONSTRUCTOR: + begin + if RI.OverCount > 0 then + begin + Inc(TotalOverCount); + SubName := RI.FullName + '__' + IntToStr(TotalOverCount); + SubName := StringReplace(SubName, '.', '_', [rfReplaceAll, rfIgnoreCase]); + + StrAddress := '@' + SubName; + + S := 'function ' + SubName + '('; + + for J:=0 to RI.Count - 1 do + begin + RJ := GTable[GTable.GetParamId(I, J)]; + if RJ.IsConst then + S := S + 'const ' + else if RJ.ByRef then + S := S + 'var '; + S := S + RJ.Name; + if not StrEql(GetTypeName(RJ), 'PVOID') then + S := S + ':' + GetTypeName(RJ); + if J <> RI.Count - 1 then + S := S + ';' + end; + + S := S + '):' + GTable[RI.TypeId].Name + ';'; + + AddP(S); + AddP('begin'); + + S := 'result := ' + GTable[RI.TypeId].Name + '.' + RI.Name + '('; + for J:=0 to RI.Count - 1 do + begin + RJ := GTable[GTable.GetParamId(I, J)]; + S := S + RJ.Name; + if J <> RI.Count - 1 then + S := S + ',' + end; + S := S + ');'; + + AddP(Tab(2) + S); + AddP('end;'); + + Add2(Tab(2) + 'H_SUB := ' + 'RegisterMethod(' + + StrLevelConst + ',' + + StrLiteral(RI.Name) + ',' + + StrTypeConst + ',' + + StrAddress + ',' + + StrCallConv + ',' + + 'true' + + ');' + '//' + IntToStr(KK)); + end + else + Add2(Tab(2) + 'H_SUB := ' + 'RegisterConstructor(' + + StrLevelConst + ',' + + StrLiteral(RI.Name) + ',' + + StrAddress + + ');' + '//' + IntToStr(KK)); + end; + kindDESTRUCTOR: + Add2(Tab(2) + 'RegisterDestructor(' + + StrLevelConst + ',' + + StrLiteral(RI.Name) + ',' + + StrAddress + + ');' + '//' + IntToStr(KK)); + else + if StrLevelConst = 'H_TYPE' then + begin + if RI.OverCount > 0 then + begin + Inc(TotalOverCount); + SubName := RI.FullName + '__' + IntToStr(TotalOverCount); + SubName := StringReplace(SubName, '.', '_', [rfReplaceAll, rfIgnoreCase]); + + StrAddress := '@' + SubName; + + if RI.TypeID in [0, typeVOID] then + S := 'procedure ' + else + S := 'function '; + S := S + SubName + '(Self:' + GTable[RI.Level].Name; + + if RI.Count <> 0 then + S := S + ';'; + + for J:=0 to RI.Count - 1 do + begin + RJ := GTable[GTable.GetParamId(I, J)]; + if RJ.IsConst then + S := S + 'const ' + else if RJ.ByRef then + S := S + 'var '; + S := S + RJ.Name; + if not StrEql(GetTypeName(RJ), 'PVOID') then + S := S + ':' + GetTypeName(RJ); + if J <> RI.Count - 1 then + S := S + ';' + end; + + S := S + ')'; + + if not (RI.TypeID in [0, typeVOID]) then + S := S + ':' + GTable[RI.TypeId].Name; + + S := S + ';' + Copy(StrCallConv, 4, Length(StrCallConv) - 3) + ';'; + + AddP(S); + AddP('begin'); + + if not (RI.TypeID in [0, typeVOID]) then // procedure + S := 'result := Self.' + else + S := 'Self.'; + + S := S + RI.Name + '('; + for J:=0 to RI.Count - 1 do + begin + RJ := GTable[GTable.GetParamId(I, J)]; + S := S + RJ.Name; + if J <> RI.Count - 1 then + S := S + ',' + end; + S := S + ');'; + + AddP(Tab(2) + S); + AddP('end;'); + + end; + + if RI.Level > 0 then + if GTable[RI.Level].FinalTypeId = typeINTERFACE then + StrAddress := 'nil'; + + Add2(Tab(2) + 'H_SUB := ' + 'RegisterMethod(' + + StrLevelConst + ',' + + StrLiteral(RI.Name) + ',' + + StrTypeConst + ',' + + StrAddress + ',' + + StrCallConv + ',' + + BoolToStr(RI.IsSharedMethod, true) + ',' + + StrCallMode + ',' + + IntToStr(RI.MethodIndex) + + ');' + '//' + IntToStr(KK)); + end + else + begin + if PosCh('@', RI.Name) = 1 then + begin + SubName := RI.Name; + TypeName := GTable[Gtable[RI.Position].Level].Name; + + if RI.Name[2] = 'R' then + begin + SubName := StringReplace(SubName, '@', '', [rfReplaceAll, rfIgnoreCase]); + + S := 'function ' + SubName + '(Self:' + TypeName; + if RI.Count <> 0 then + S := S + ';'; + + for J:=0 to RI.Count - 1 do + begin + RJ := GTable[GTable.GetParamId(I, J)]; + if RJ.IsConst then + S := S + 'const ' + else if RJ.ByRef then + S := S + 'var '; + S := S + RJ.Name; + if not StrEql(GetTypeName(RJ), 'PVOID') then + S := S + ':' + GetTypeName(RJ); + if J <> RI.Count - 1 then + S := S + ';' + end; + S := S + '):' + GTable[RI.TypeId].Name + '; stdcall;'; + AddP(S); + AddP('begin'); + S := 'result := Self.' + Gtable[RI.Position].Name; + if RI.Count > 0 then + begin + S := S + '['; + for J:=0 to RI.Count - 1 do + begin + RJ := GTable[GTable.GetParamId(I, J)]; + S := S + RJ.Name; + if J <> RI.Count - 1 then + S := S + ',' + end; + S := S + ']'; + end; + AddP(Tab(2) + S + ';'); + AddP('end;'); + + Add2(Tab(2) + 'H_SUB := ' + 'RegisterRoutine(' + + StrLevelConst + ',' + + StrLiteral(SubName) + ',' + + StrTypeConst + ',' + + '@' + SubName + ',' + + StrCallConv + + ');'+ '//' + IntToStr(KK)); + Add2(Tab(2) + 'H_READ := H_SUB;'); + end + else + begin + SubName := StringReplace(SubName, '@', '', [rfReplaceAll, rfIgnoreCase]); + + S := 'procedure ' + SubName + '(Self:' + TypeName; + if RI.Count <> 0 then + S := S + ';'; + + for J:=0 to RI.Count - 1 do + begin + RJ := GTable[GTable.GetParamId(I, J)]; + if RJ.IsConst then + S := S + 'const ' + else if RJ.ByRef then + S := S + 'var '; + S := S + RJ.Name; + if not StrEql(GetTypeName(RJ), 'PVOID') then + S := S + ':' + GetTypeName(RJ); + if J <> RI.Count - 1 then + S := S + ';' + end; + S := S + '); stdcall;'; + AddP(S); + AddP('begin'); + S := 'Self.' + Gtable[RI.Position].Name; + if RI.Count > 1 then + begin + S := S + '['; + for J:=0 to RI.Count - 2 do + begin + RJ := GTable[GTable.GetParamId(I, J)]; + S := S + RJ.Name; + if J <> RI.Count - 2 then + S := S + ',' + end; + S := S + ']'; + end; + AddP(Tab(2) + S + ' := value;'); + AddP('end;'); + + Add2(Tab(2) + 'H_SUB := ' + 'RegisterRoutine(' + + StrLevelConst + ',' + + StrLiteral(SubName) + ',' + + StrTypeConst + ',' + + '@' + SubName + ',' + + StrCallConv + + ');'+ '//' + IntToStr(KK)); + Add2(Tab(2) + 'H_WRITE := H_SUB;'); + end; + end + else + begin + if RI.OverCount > 0 then + begin + Inc(TotalOverCount); + SubName := RI.Name + '__' + IntToStr(TotalOverCount); + + StrAddress := '@' + SubName; + + if RI.TypeID in [0, typeVOID] then + S := 'procedure ' + else + S := 'function '; + S := S + SubName + '('; + + for J:=0 to RI.Count - 1 do + begin + RJ := GTable[GTable.GetParamId(I, J)]; + if RJ.IsConst then + S := S + 'const ' + else if RJ.ByRef then + S := S + 'var '; + S := S + RJ.Name; + if not StrEql(GetTypeName(RJ), 'PVOID') then + S := S + ':' + GetTypeName(RJ); + if J <> RI.Count - 1 then + S := S + ';' + end; + + S := S + ')'; + + if not (RI.TypeID in [0, typeVOID]) then + S := S + ':' + GTable[RI.TypeId].Name; + + S := S + ';' + Copy(StrCallConv, 4, Length(StrCallConv) - 3) + ';'; + + AddP(S); + AddP('begin'); + + S := ''; + + if not (RI.TypeID in [0, typeVOID]) then // procedure + S := 'result := '; + + S := S + RI.Name + '('; + for J:=0 to RI.Count - 1 do + begin + RJ := GTable[GTable.GetParamId(I, J)]; + S := S + RJ.Name; + if J <> RI.Count - 1 then + S := S + ',' + end; + S := S + ');'; + + AddP(Tab(2) + S); + AddP('end;'); + + end; + + Add2(Tab(2) + 'H_SUB := ' + 'RegisterRoutine(' + + StrLevelConst + ',' + + StrLiteral(RI.Name) + ',' + + StrTypeConst + ',' + + StrAddress + ',' + + StrCallConv + + ');'+ '//' + IntToStr(KK)); + end; + end; + end; + + Inc(KK, 2); + + for J:=0 to GTable[I].Count - 1 do + begin + RJ := GTable[GTable.GetParamId(I, J)]; + + if RJ.Optional then + StrValue := VarToStr(RJ.Value) + else + StrValue := 'Undefined'; + + Inc(KK); + + Add2(Tab(4) + 'RegisterParameterEx(H_SUB, ' + + StrLiteral(RJ.Name) + ',' + + GetStrTypeConst(RJ.TypeId) + ',' + + StrValue + ',' + + BoolToStr(RJ.ByRef, true) + ',' + + BoolToStr(RJ.IsConst, true) + + ');'+ '//' + IntToStr(KK)); + end; + + end; + kindPROP: + begin + if not CheckProp(I) then + begin + Add2(Tab(2) + '// Cannot import "' + RI.FullName + '"'); + Add2(Tab(2) + 'RegisterSpace(' + IntToStr(PropSize(I)) + ');'); + continue; + end; + + StrTypeConst := GetStrTypeConst(RI.TypeId); + + if (RI.Level > 0) and (GTable[RI.Level].FinalTypeId = typeINTERFACE) then + begin + if RI.ReadId > 0 then + StrRead := IntToStr(GTable[RI.ReadId].MethodIndex) + else + StrRead := '0'; + + if RI.WriteId > 0 then + StrWrite := IntToStr(GTable[RI.WriteId].MethodIndex) + else + StrWrite := '0'; + + Add2(Tab(2) + 'RegisterInterfaceProperty(H_TYPE,' + + StrLiteral(RI.Name) + ',' + + StrTypeConst + ',' + + StrRead + ',' + + StrWrite + + ');' + '//' + IntToStr(KK)); + end + else + begin + if RI.ReadId > 0 then + StrRead := 'H_READ' + else + StrRead := '0'; + if RI.WriteId > 0 then + StrWrite := 'H_WRITE' + else + StrWrite := '0'; + Add2(Tab(2) + 'RegisterProperty(H_TYPE,' + + StrLiteral(RI.Name) + ',' + + StrTypeConst + ',' + + StrRead + ',' + + StrWrite + ',' + + BoolToStr(RI.IsDefault, true) + + ');' + '//' + IntToStr(KK)); + end; + end; + kindTYPE: + begin + StrLevelConst := 'H_NS'; + + T := RI.TypeId; + if T = typeALIAS then + begin + // alias + end + else + T := RI.FinalTypeId; + + case T of + typeRECORD: + begin + Add2(Tab(2) + 'RegisterAlignment(' + IntToStr(RI.DefaultAlignment) + ');'); + + Add2(Tab(2) + 'H_TYPE := ' + 'RegisterRecordType(' + + StrLevelConst + ',' + + StrLiteral(RI.Name) + + ');' + '//' + IntToStr(KK)); + + for J:=I + 1 to GTable.Card do + begin + RJ := GTable[J]; + if RJ.Level = I then + if RJ.Kind = kindTYPE_FIELD then + begin + StrTypeConst := GetStrTypeConst(RJ.TypeId); + + Inc(KK); + + Add2(Tab(4) + 'RegisterRecordTypeField(H_TYPE, ' + + StrLiteral(RJ.Name) + ',' + + StrTypeConst + ',' + + IntToStr(RJ.Shift) + + ');' + '//' + IntToStr(KK)); + end; + end; + end; + typeCLASS: + begin + Add2(Tab(2) + 'H_TYPE := ' + 'RegisterClassTypeForImporter(' + + StrLevelConst + ',' + + RI.Name + + ');' + '//' + IntToStr(KK)); + + RegisteredClasses.AddObject(RI.Name, TObject(KK)); + + Inc(KK, 3); + + for J:=I + 1 to GTable.Card do + begin + RJ := GTable[J]; + if RJ.Level = I then + case RJ.Kind of + kindTYPE_FIELD: + begin + Inc(KK); + + StrTypeConst := GetStrTypeConst(RJ.TypeId); + Add2(Tab(4) + 'RegisterClassTypeField(H_TYPE, ' + + StrLiteral(RJ.Name) + ',' + + StrTypeConst + ',' + + 'Integer(@' + GTable[RJ.Level].Name + '(nil).' + RJ.Name + ')' + + ');' + '//' + IntToStr(KK)); + end; + end; + end; + end; + typeCLASSREF: + begin + Add2(Tab(2) + 'RegisterClassReferenceType(' + + StrLevelConst + ',' + + StrLiteral(RI.Name) + ',' + + GetStrTypeConst(RI.PatternId) + + ');' + '//' + IntToStr(KK)); + end; + typeINTERFACE: + begin + Add2(Tab(2) + 'H_TYPE := ' + 'RegisterInterfaceType(' + + StrLevelConst + ',' + + StrLiteral(RI.Name) + ',' + + RI.Name + + ');' + '//' + IntToStr(KK)); + end; + typeARRAY: + begin + Add2(Tab(2) + 'RegisterAlignment(' + IntToStr(1) + ');'); + + GTable.GetArrayTypeInfo(I, RangeTypeId, ElemTypeId); + Add2(Tab(2) + 'RegisterArrayType(' + + StrLevelConst + ',' + + StrLiteral(RI.Name) + ',' + + GetStrTypeConst(RangeTypeId) + ',' + + GetStrTypeConst(ElemTypeId) + + ');' + '//' + IntToStr(KK)); + end; + typeDYNARRAY: + begin + Add2(Tab(2) + 'RegisterAlignment(' + IntToStr(1) + ');'); + + ElemTypeId := RI.PatternId; + + Add2(Tab(2) + 'RegisterDynamicArrayType(' + + StrLevelConst + ',' + + StrLiteral(RI.Name) + ',' + + GetStrTypeConst(ElemTypeId) + + ');' + '//' + IntToStr(KK)); + end; + typeENUM: + begin + if (GTable[I+1].Kind = kindCONST) and + (GTable[I+1].TypeId = typeENUM) then + begin + Add2(Tab(2) + 'RegisterSubrangeType(' + + StrLevelConst + ',' + + StrLiteral(RI.Name) + ',' + + GetStrTypeConst(RI.TypeId) + ',' + + IntToStr(GTable.GetLowBoundRec(I).Value) + ',' + + IntToStr(GTable.GetHighBoundRec(I).Value) + + ');' + '//' + IntToStr(KK)); + continue; + end; + + Add2(Tab(2) + 'H_TYPE := ' + 'RegisterEnumType(' + + StrLevelConst + ',' + + StrLiteral(RI.Name) + + ');' + '//' + IntToStr(KK)); + for J:=I + 1 to GTable.Card do + begin + RJ := GTable[J]; + if RJ.OwnerId = I then + begin + Inc(KK); + + Add2(Tab(4) + 'RegisterEnumValue(H_TYPE, ' + + StrLiteral(RJ.Name) + ',' + + IntToStr(RJ.Value) + + ');' + '//' + IntToStr(KK)); + end; + end; + end; + typeSET: + begin + Add2(Tab(2) + 'RegisterSetType(' + + StrLevelConst + ',' + + StrLiteral(RI.Name) + ',' + + GetStrTypeConst(RI.PatternId) + + ');' + '//' + IntToStr(KK)); + end; + typePOINTER: + begin + Add2(Tab(2) + 'RegisterPointerType(' + + StrLevelConst + ',' + + StrLiteral(RI.Name) + ',' + + GetStrTypeConst(RI.PatternId) + + ');' + '//' + IntToStr(KK)); + end; + typeSHORTSTRING: + begin + Add2(Tab(2) + 'RegisterShortstringType(' + + StrLevelConst + ',' + + StrLiteral(RI.Name) + ',' + + IntToStr(RI.Count) + + ');' + '//' + IntToStr(KK)); + end; + typePROC: + begin + Add2(Tab(2) + 'RegisterProceduralType(' + + StrLevelConst + ',' + + StrLiteral(RI.Name) + ',' + + 'H_SUB' + + ');' + '//' + IntToStr(KK)); + end; + typeEVENT: + begin + Add2(Tab(2) + 'RegisterEventType(' + + StrLevelConst + ',' + + StrLiteral(RI.Name) + ',' + + 'H_SUB' + + ');' + '//' + IntToStr(KK)); + end; + else + begin + if RI.TypeID = typeALIAS then + begin + Add2(Tab(2) + 'RegisterTypeAlias(' + + StrLevelConst + ',' + + StrLiteral(RI.Name) + ',' + + GetStrTypeConst(RI.PatternId) + + ');' + '//' + IntToStr(KK)); + continue; + end; + + if (GTable[I + 1].Kind = kindCONST) and (GTable[I + 2].Kind = kindCONST) then + begin // subrange type + Add2(Tab(2) + 'RegisterSubrangeType(' + + StrLevelConst + ',' + + StrLiteral(RI.Name) + ',' + + GetStrTypeConst(RI.TypeId) + ',' + + IntToStr(GTable.GetLowBoundRec(I).Value) + ',' + + IntToStr(GTable.GetHighBoundRec(I).Value) + + ');' + '//' + IntToStr(KK)); + end; + end; + end; + end; + end; + end; + + AddLine('{$O-}'); + + AddLine('////////////////////////////////////////////////////////////////////////////'); + AddLine('// PaxCompiler import unit'); + AddLine('// The unit has been generated by paxCompiler importer'); + AddLine('// Site: http://www.paxcompiler.com'); + AddLine('// Author: Alexander Baranovsky (paxscript@gmail.com)'); + AddLine('// ========================================================================'); + AddLine('// Copyright (c) Alexander Baranovsky, 2006-2008. All rights reserved.'); + AddLine('////////////////////////////////////////////////////////////////////////////'); + + AddLine('unit ' + ImportUnitName + ';'); + AddLine('interface'); + AddUnits; + + AddLine('procedure ' + RegProcName + ';'); + AddLine('implementation'); + + for I:=0 to L1.Count - 1 do + AddLine(L1[I]); + + for I:=0 to LP.Count - 1 do + AddLine(LP[I]); + + AddLine('var H_NS, H_TYPE, H_SUB, H_READ, H_WRITE: Integer;'); + AddLine('var Undefined: Variant;'); + + K := 1; + + AddLine('procedure P1;'); + AddLine('begin'); + + for I:=0 to L2.Count - 1 do + begin + if I > 0 then if I mod MaxLines = 0 then + begin + AddLine('end;'); + Inc(K); + AddLine('procedure P' + IntToStr(K) + ';'); + AddLine('begin'); + end; + + AddLine(L2[I]); + end; + AddLine('end;'); + + AddLine('procedure ' + RegProcName + ';'); + AddLine('begin'); + + for I:=1 to K do + AddLine(Tab(2) + 'P' + IntToStr(I) + '();'); + + for I:=0 to RegisteredClasses.Count - 1 do + begin + J := Integer(RegisteredClasses.Objects[I]); + AddLine(Tab(2) + 'RegisterClassTypeInfos(' + + IntToStr(J) + ',' + + RegisteredClasses[I] + + ');'); + end; + + AddLine('end;'); + + AddLine('initialization'); + AddLine(' ' + RegProcName + ';'); + AddLine('end.'); + + finally + NewKernel.Free; + + L1.Free; + L2.Free; + LU.Free; + LP.Free; + + RegisteredClasses.Free; + end; +end; + + +end. diff --git a/Sources/PAXCOMP_INVOKE.pas b/Sources/PAXCOMP_INVOKE.pas new file mode 100644 index 0000000..fcb3cc9 --- /dev/null +++ b/Sources/PAXCOMP_INVOKE.pas @@ -0,0 +1,2176 @@ +//////////////////////////////////////////////////////////////////////////// +// PaxInvoke +// Site: http://www.paxcompiler.com +// Author: Alexander Baranovsky (paxscript@gmail.com) +// ======================================================================== +// Copyright (c) Alexander Baranovsky, 2006-2014. All rights reserved. +// Code Version: 4.2 +// ======================================================================== +// Unit: PAXCOMP_INVOKE.pas +// ======================================================================== +//////////////////////////////////////////////////////////////////////////// + +{$I PaxCompiler.def} +{$O-} +unit PAXCOMP_INVOKE; +interface +{$IFDEF PAXARM_DEVICE} +implementation +end. +{$ENDIF} + +uses + {$I uses.def} + PAXCOMP_CONSTANTS, + SysUtils, + Classes; + +const + MaxArgs = 20; + typeVALVALUE = 52; + +{$IFDEF MACOS32} + varValValue = varError; +{$ELSE} + varValValue = $0E; +{$ENDIF} + +{$IFDEF PAX64} + INVOKE_RESULT_OFFSET = 152; + INVOKE_ADDRESS_OFFSET = 64; +{$ELSE} + INVOKE_RESULT_OFFSET = 36; +{$ENDIF} + +type + TIntegerArr = array[0..4096] of Integer; + PIntegerArr = ^TIntegerArr; + + TValValue = class + private + fBuff: PIntegerArr; + fSize: Integer; + public + constructor Create(var V; iSize: Integer); + destructor Destroy; override; + procedure Push(P: Pointer); + property Size: Integer read fSize; + end; + + TInvoke = class + private +{$IFDEF PAX64} + fStackFrame: Pointer; //8 + fStackSize: Integer; //16 + dummy: Integer; + fEAX: IntPax; //24 + fEDX: IntPax; //32 + fECX: IntPax; //40 + fR8: IntPax; //48 + fR9: IntPax; //56 + fAddress: Pointer; // 64 + fCallConv: IntPax; // 72 + fResultType: IntPax; // 80 + fXMM0: Double; // 88 + fXMM1: Double; // 96 + fXMM2: Double; // 104 + fXMM3: Double; // 112 + + XMM0type: IntPax; // 120 + XMM1type: IntPax; // 128 + XMM2type: IntPax; // 136 + XMM3type: IntPax; // 144 + + fResult: array[0..SizeOf(Variant) - 1] of Byte; // 152 + +{$ELSE} + fStackFrame: Pointer; //4 + fStackSize: Integer; //8 + + fEAX: IntPax; //12 + fEDX: IntPax; //16 + fECX: IntPax; //20 + fAddress: Pointer; // 24 + fCallConv: Integer; // 28 + fResultType: Integer; // 32 + fResult: array[0..SizeOf(Variant) - 1] of Byte; // 36 +{$ENDIF} + + fResultSize: Integer; + + fCount: Integer; + NeedSetup: Boolean; + A: array of Variant; + Types: array of Integer; + DllList: TStringList; + fIsInternal: Boolean; + public + This: Pointer; + OldESP0: Integer; + CustomResultAddress: Pointer; + IsFakeMethod: Boolean; + IsConstructor: Boolean; + RunnerParam: Pointer; + + Outer: Pointer; + + constructor Create; + constructor CreateInternal; + destructor Destroy; override; + function IsInternal: Boolean; + procedure ClearArguments; + procedure PushArguments; + procedure PushArgumentsBackward; + + procedure AddArg(const value: Variant; T: Integer); + procedure AddArgByVal(var V; Size: Integer); + + property ArgumentCount: Integer read fCount; + procedure Setup; + procedure CallHost; +{$IFDEF MACOS} + procedure CallHostCDECL; + procedure CallHostSTDCALL; +{$ENDIF} + function GetResultPtr: Pointer; + procedure SetResType(value : Integer); + procedure SetResSize(value : Integer); + function ExtraParamNeeded: Boolean; + function GetThis: Pointer; + procedure SetThis(value: Pointer); + procedure LoadAddress(const DllName, ProcName: String); + procedure UloadDlls; + procedure ClearResult; +{$IFDEF PAX64} + procedure SaveResult; +{$ENDIF} + procedure AdjustResult; + procedure RaiseError(const Message: string; params: array of Const); + property CallConv: IntPax read fCallConv write fCallConv; + property Address: Pointer read fAddress write fAddress; + property StackFrame: Pointer read fStackFrame write fStackFrame; + property StackSize: Integer read fStackSize write fStackSize; + property ResultType: IntPax read fResultType; + property _EAX: IntPax read fEAX write fEAX; + property _ECX: IntPax read fECX write fECX; + property _EDX: IntPax read fEDX write fEDX; +{$IFDEF PAX64} + property _R8: IntPax read fR8 write fR8; + property _R9: IntPax read fR9 write fR9; +{$ENDIF} + end; + +var + ARR_R1, ARR_R2, ARR_R3: array[0..1023] of Integer; + +implementation + +uses + PAXCOMP_SYS; + +{$IFDEF MACOS32} +var + STACKFRAME_OFFSET, + STACKSIZE_OFFSET, + RAX_OFFSET, + RCX_OFFSET, + RDX_OFFSET, + ADDRESS_OFFSET, + CALLCONV_OFFSET, + RESULTTYPE_OFFSET, + RESULT_OFFSET: Integer; +{$ENDIF} + +function VariantToValValue(const V: Variant): TValValue; +begin + result := TValValue(TVarData(V).VInteger); +end; + +function ValValueToVariant(X: TValValue): Variant; +begin + with TVarData(result) do + begin + VType := varValValue; + VInteger := Integer(X); + end; +end; + +procedure ClearVariant(var V: Variant); +var + X: TValValue; +begin + if VarType(V) = varValValue then + with TVarData(V) do + begin + X := TValValue(VInteger); + FreeAndNil(X); + VType := varInteger; + end; + + VarClear(V); +end; + +constructor TValValue.Create(var V; iSize: Integer); +begin + inherited Create; + fSize := iSize; + while fSize mod 4 <> 0 do + Inc(fSize); + fBuff := AllocMem(fSize); + Move(V, fBuff^, fSize); +end; + +destructor TValValue.Destroy; +begin + FreeMem(fBuff, fSize); + inherited; +end; + +{$IFDEF PAX64} +procedure TValValue.Push(P: Pointer); +var + I, K: Integer; +begin + K := fSize div 8; + + for I:=K - 1 downto 0 do + begin + IntPax(P^) := fBuff^[I]; + Inc(IntPax(P), SizeOf(IntPax)); + end; +end; +{$ELSE} +procedure TValValue.Push(P: Pointer); +var + I, K: Integer; +begin + K := fSize div 4; + + for I:=K - 1 downto 0 do + begin + Integer(P^) := fBuff^[I]; + Inc(Integer(P), SizeOf(Integer)); + end; +end; +{$ENDIF} + +constructor TInvoke.Create; +begin + inherited; + fCount := 0; + SetLength(A, MaxArgs); + SetLength(Types, MaxArgs); + fCallConv := ccSTDCALL; + fStackFrame := AllocMem(MaxArgs * 16); + fAddress := nil; + This := nil; + NeedSetup := true; + DllList := TStringList.Create; + fIsInternal := false; +end; + +constructor TInvoke.CreateInternal; +begin + inherited; + fCount := 0; +{$IFDEF PAX64} + fCallConv := cc64; +{$ELSE} + fCallConv := ccREGISTER; +{$ENDIF} + fStackFrame := nil; + fAddress := nil; + This := nil; + NeedSetup := false; + fIsInternal := true; +end; + +destructor TInvoke.Destroy; +begin + if IsInternal then + Exit; + + ClearArguments; + + UloadDlls; + FreeAndNil(DllList); + FreeMem(fStackFrame, MaxArgs * 16); + inherited; +end; + +procedure TInvoke.ClearArguments; +var + I: Integer; +begin + CustomResultAddress := nil; + for I:=0 to fCount - 1 do + if Types[I] = typeVALVALUE then + ClearVariant(A[I]) + else + VarClear(A[I]); + + fCount := 0; + NeedSetup := true; +end; + +procedure TInvoke.AddArg(const value: Variant; T: Integer); +begin + A[fCount] := value; + Types[fCount] := T; + Inc(fCount); + NeedSetup := true; +end; + +procedure TInvoke.AddArgByVal(var V; Size: Integer); +var + VV: TValValue; +begin + VV := TValValue.Create(V, Size); +{$IFDEF ARC} + VV.__ObjAddRef; +{$ENDIF} + A[fCount] := ValValueToVariant(VV); + Types[fCount] := typeVALVALUE; + Inc(fCount); + NeedSetup := true; +end; + +procedure TInvoke.Setup; +var + I, T: Integer; + P: Pointer; + EAXbusy, EDXbusy, ECXbusy: Boolean; +{$IFDEF PAX64} + R8busy, R9busy: Boolean; +{$ENDIF} + IDX, ICX: Integer; + X: TValValue; +begin + if not NeedSetup then + Exit; + + EAXbusy := false; + EDXbusy := false; + ECXbusy := false; +{$IFDEF PAX64} + R8busy := false; + R9busy := false; + XMM0type := 0; + XMM1type := 0; + XMM2type := 0; + XMM3type := 0; +{$ENDIF} + P := fStackFrame; + fStackSize := 0; + +{$IFDEF PAX64} + fCallConv := cc64; +{$ENDIF} + + if ExtraParamNeeded and (fCallConv = cc64) then + begin + FillChar(fResult, SizeOf(fResult), 0); + Pointer(P^) := GetResultPtr; + +{$IFDEF PAX64} + if XMM0type = 0 then + begin + XMM0type := 1; + end + else if XMM1type = 0 then + begin + XMM1type := 1; + end + else if XMM2type = 0 then + begin + XMM2type := 1; + end + else if XMM3type = 0 then + begin + XMM3type := 1; + end; +{$ENDIF} + + if IsFakeMethod then + begin + fECX := IntPax(GetResultPtr); + ECXbusy := true; + end + else + begin + if This <> nil then + begin + fEDX := IntPax(GetResultPtr); + EDXbusy := true; + end + else + begin + fECX := IntPax(GetResultPtr); + ECXbusy := true; + end; + end; + + end; + + case fCallConv of + ccSAFECALL: + begin + Pointer(P^) := GetResultPtr; + I := 0; + Move(I, fResult, SizeOf(Integer)); + Inc(IntPax(P), SizeOf(Integer)); + Inc(fStackSize, SizeOf(Integer)); + + for I:= fCount - 1 downto 0 do + begin + T := Types[I]; + case T of + typeINTEGER, typePOINTER, typeINTERFACE: + begin + Integer(P^) := Integer(A[I]); + Inc(IntPax(P), SizeOf(Integer)); + Inc(fStackSize, SizeOf(Integer)); + end; + typeVALVALUE: + begin + X := VariantToValValue(A[I]); + X.Push(P); + Inc(IntPax(P), X.Size); + Inc(fStackSize, X.Size); + end; + typeVARIANT: + begin + Pointer(P^) := @ A[I]; + Inc(IntPax(P), SizeOf(Integer)); + Inc(fStackSize, SizeOf(Integer)); + end; + else + RaiseError(errInternalError, []); + end; + end; + end; // ccSAFECALL + + ccSTDCALL, ccCDECL: + begin + for I:= fCount - 1 downto 0 do + begin + T := Types[I]; + case T of + typeINTEGER, typePOINTER, typeINTERFACE: + begin + Integer(P^) := Integer(A[I]); + Inc(IntPax(P), SizeOf(Integer)); + Inc(fStackSize, SizeOf(Integer)); + end; + typeVALVALUE: + begin + X := VariantToValValue(A[I]); + X.Push(P); + Inc(IntPax(P), X.Size); + Inc(fStackSize, X.Size); + end; + typeVARIANT: + begin + Pointer(P^) := @ A[I]; + Inc(IntPax(P), SizeOf(Integer)); + Inc(fStackSize, SizeOf(Integer)); + end; + else + RaiseError(errInternalError, []); + end; + end; + end; // ccSTDCALL, ccCDECL + + ccMSFASTCALL: + begin + EAXbusy := true; + IDX := -1; + ICX := -1; + + if fResultType in [typeRECORD, typeARRAY] then + begin + if fResultSize <= 4 then + begin + fResultType := typeINTEGER; + end + else if fResultSize <= 8 then + begin + fResultType := typeINT64; + end; + end; + + for I:= 0 to fCount - 1 do + begin + if Types[I] in [typeINTEGER, typePOINTER, typeINTERFACE] then + begin + if not ECXbusy then + begin + fECX := Integer(A[I]); + ECXbusy := true; + ICX := I; + end + else if not EDXbusy then + begin + fEDX := Integer(A[I]); + EDXbusy := true; + IDX := I; + end + end; + end; + + for I:= fCount - 1 downto 0 do + begin + if I = IDX then + continue; + if I = ICX then + continue; + + T := Types[I]; + case T of + typeINTEGER, typePOINTER, typeINTERFACE: + begin + Integer(P^) := Integer(A[I]); + Inc(IntPax(P), SizeOf(Integer)); + Inc(fStackSize, SizeOf(Integer)); + end; + typeVALVALUE: + begin + X := VariantToValValue(A[I]); + X.Push(P); + Inc(IntPax(P), X.Size); + Inc(fStackSize, X.Size); + end; + typeVARIANT: + begin + Pointer(P^) := @ A[I]; + Inc(IntPax(P), SizeOf(Integer)); + Inc(fStackSize, SizeOf(Integer)); + end; + else + RaiseError(errInternalError, []); + end; + end; + end; // ccMSFASTCALL + + ccPASCAL: + begin + for I:= 0 to fCount - 1 do + begin + T := Types[I]; + case T of + typeINTEGER, typePOINTER, typeINTERFACE: + begin + Integer(P^) := Integer(A[I]); + Inc(IntPax(P), SizeOf(Integer)); + Inc(fStackSize, SizeOf(Integer)); + end; + typeVALVALUE: + begin + X := VariantToValValue(A[I]); + X.Push(P); + Inc(IntPax(P), X.Size); + Inc(fStackSize, X.Size); + end; + typeVARIANT: + begin + Pointer(P^) := @ A[I]; + Inc(IntPax(P), SizeOf(Integer)); + Inc(fStackSize, SizeOf(Integer)); + end; + else + RaiseError(errInternalError, []); + end; + end; + end; // ccPASCAL + + ccREGISTER: + begin + + if This <> nil then + begin +{$IFDEF FPC} + if IsConstructor then + begin + fEDX := Integer(This); + EDXbusy := true; + end + else + begin + fEAX := Integer(This); + EAXbusy := true; + end; +{$ELSE} + fEAX := Integer(This); + EAXbusy := true; +{$ENDIF} + end; + + for I:=0 to fCount - 1 do + begin + T := Types[I]; + case T of + typeINTEGER, typePOINTER, typeINTERFACE: + begin + if not EAXbusy then + begin + fEAX := Integer(A[I]); + EAXbusy := true; + end + else if not EDXbusy then + begin + fEDX := Integer(A[I]); + EDXbusy := true; + end + else if not ECXbusy then + begin + fECX := Integer(A[I]); + ECXbusy := true; + end + else + begin + Integer(P^) := Integer(A[I]); + Inc(IntPax(P), SizeOf(Integer)); + Inc(fStackSize, SizeOf(Integer)); + end; + end; + typeVALVALUE: + begin + X := VariantToValValue(A[I]); + X.Push(P); + Inc(IntPax(P), X.Size); + Inc(fStackSize, X.Size); + end; + typeVARIANT: + begin + if not EAXbusy then + begin + fEAX := IntPax(@ A[I]); + EAXbusy := true; + end + else if not EDXbusy then + begin + fEDX := IntPax(@ A[I]); + EDXbusy := true; + end + else if not ECXbusy then + begin + fECX := IntPax(@ A[I]); + ECXbusy := true; + end + else + begin + Pointer(P^) := @ A[I]; + Inc(IntPax(P), SizeOf(Integer)); + Inc(fStackSize, SizeOf(Integer)); + end; + end; + else + RaiseError(errInternalError, []); + end; + end; + end; // ccREGISTER + cc64: + begin + if This <> nil then + begin +{$IFDEF PAX64} + if XMM0type = 0 then + begin + XMM0type := 1; + end + else if XMM1type = 0 then + begin + XMM1type := 1; + end + else if XMM2type = 0 then + begin + XMM2type := 1; + end + else if XMM3type = 0 then + begin + XMM3type := 1; + end; +{$ENDIF} + +{$IFDEF FPC} + if IsConstructor then + begin + fEDX := IntPax(This); + EDXbusy := true; + end + else + begin + if not ECXbusy then + begin + fECX := IntPax(This); + ECXbusy := true; + end + else if not EDXbusy then + begin + fEDX := IntPax(This); + EDXbusy := true; + end + else + RaiseError(errInternalError, []); + end; +{$ELSE} + if not ECXbusy then + begin + fECX := IntPax(This); + ECXbusy := true; + end + else if not EDXbusy then + begin + fEDX := IntPax(This); + EDXbusy := true; + end + else + RaiseError(errInternalError, []); +{$ENDIF} + end; + + for I:=0 to fCount - 1 do + begin + T := Types[I]; + case T of + typeINTEGER, + typePOINTER, +{$IFNDEF PAXARM} + typeANSISTRING, + typeWIDESTRING, +{$ENDIF} + typeUNICSTRING, + typeCLASS, + typeCLASSREF, + typeINT64, + typeUINT64, + typeCURRENCY, + typeINTERFACE: + begin +{$IFDEF PAX64} + if XMM0type = 0 then + begin + XMM0type := 1; + end + else if XMM1type = 0 then + begin + XMM1type := 1; + end + else if XMM2type = 0 then + begin + XMM2type := 1; + end + else if XMM3type = 0 then + begin + XMM3type := 1; + end; +{$ENDIF} + if not ECXbusy then + begin + fECX := IntPax(A[I]); + ECXbusy := true; + end + else if not EDXbusy then + begin + fEDX := IntPax(A[I]); + EDXbusy := true; + end +{$IFDEF PAX64} + else if not R8busy then + begin + fR8 := IntPax(A[I]); + R8busy := true; + end + else if not R9busy then + begin + fR9 := IntPax(A[I]); + R9busy := true; + end +{$ENDIF} + else + begin + Byte(P^) := typeINTEGER; + Inc(IntPax(P), 1); + + IntPax(P^) := IntPax(A[I]); + Inc(IntPax(P), SizeOf(IntPax)); + Inc(fStackSize, SizeOf(IntPax)); + end; + end; + typeDOUBLE, typeSINGLE, typeEXTENDED: + begin +{$IFDEF PAX64} + + if not ECXbusy then + begin + ECXbusy := true; + end + else if not EDXbusy then + begin + EDXbusy := true; + end + else if not R8busy then + begin + R8busy := true; + end + else if not R9busy then + begin + R9busy := true; + end; + + if XMM0type = 0 then + begin + fXMM0 := Double(A[I]); + XMM0type := T; + end + else if XMM1type = 0 then + begin + fXMM1 := Double(A[I]); + XMM1type := T; + end + else if XMM2type = 0 then + begin + fXMM2 := Double(A[I]); + XMM2type := T; + end + else if XMM3type = 0 then + begin + fXMM3 := Double(A[I]); + XMM3type := T; + end + else + begin + Byte(P^) := T; + Inc(IntPax(P), 1); + + Double(P^) := Double(A[I]); + Inc(IntPax(P), SizeOf(Double)); + Inc(fStackSize, SizeOf(Double)); + end; +{$ENDIF} + end; + typeVALVALUE: + begin +{$IFDEF PAX64} + if XMM0type = 0 then + begin + XMM0type := 1; + end + else if XMM1type = 0 then + begin + XMM1type := 1; + end + else if XMM2type = 0 then + begin + XMM2type := 1; + end + else if XMM3type = 0 then + begin + XMM3type := 1; + end; +{$ENDIF} + X := VariantToValValue(A[I]); + if not ECXbusy then + begin + fECX := IntPax(X.fBuff); + ECXbusy := true; + end + else if not EDXbusy then + begin + fEDX := IntPax(X.fBuff); + EDXbusy := true; + end +{$IFDEF PAX64} + else if not R8busy then + begin + fR8 := IntPax(X.fBuff); + R8busy := true; + end + else if not R9busy then + begin + fR9 := IntPax(X.fBuff); + R9busy := true; + end +{$ENDIF} + else + begin + Byte(P^) := typeVARIANT; + Inc(IntPax(P), 1); + + IntPax(P^) := IntPax(X.fBuff); + Inc(IntPax(P), SizeOf(Pointer)); + Inc(fStackSize, SizeOf(Pointer)); + end; + end; + typeVARIANT: + begin +{$IFDEF PAX64} + if XMM0type = 0 then + begin + XMM0type := 1; + end + else if XMM1type = 0 then + begin + XMM1type := 1; + end + else if XMM2type = 0 then + begin + XMM2type := 1; + end + else if XMM3type = 0 then + begin + XMM3type := 1; + end; +{$ENDIF} + if not ECXbusy then + begin + fECX := IntPax(@A[I]); + ECXbusy := true; + end + else if not EDXbusy then + begin + fEDX := IntPax(@A[I]); + EDXbusy := true; + end +{$IFDEF PAX64} + else if not R8busy then + begin + fR8 := IntPax(@A[I]); + R8busy := true; + end + else if not R9busy then + begin + fR9 := IntPax(@A[I]); + R9busy := true; + end +{$ENDIF} + else + begin + Byte(P^) := typeVARIANT; + Inc(IntPax(P), 1); + + IntPax(P^) := IntPax(@A[I]); + Inc(IntPax(P), SizeOf(Pointer)); + Inc(fStackSize, SizeOf(Pointer)); + end; + end; + else + RaiseError(errInternalError, []); + end; + end; + + end; // c64 + end; + + NeedSetup := false; + + if This <> nil then + if fCallConv in [ccSTDCALL, ccCDECL, ccPASCAL, ccSAFECALL] then + begin + Pointer(P^) := This; + Inc(IntPax(P), SizeOf(Pointer)); + Inc(fStackSize, SizeOf(Pointer)); + end; + + if fCallConv = ccSAFECALL then + Exit; + + if ExtraParamNeeded and (fCallConv <> cc64) then + begin + FillChar(fResult, SizeOf(fResult), 0); + Pointer(P^) := GetResultPtr; + + if fCallConv = ccREGISTER then + begin + if not EAXbusy then + fEAX := Integer(GetResultPtr) + else if not EDXbusy then + fEDX := Integer(GetResultPtr) + else if not ECXbusy then + fECX := Integer(GetResultPtr) + else + Inc(fStackSize, SizeOf(Pointer)); + end + else + Inc(fStackSize, SizeOf(Pointer)); + end; + +{$IFNDEF ARC} + if fResultType = typeCLASS then + fResultType := typeINTEGER; +{$ENDIF} + if fResultType = typeUINT64 then + fResultType := typeINT64; +end; + +{$IFDEF PAX64} +procedure TInvoke.PushArguments; assembler; +{$IFDEF FPC} +nostackframe; asm +{$ELSE} +asm + .NOFRAME +{$ENDIF} + + pop rbx // ret address + + mov r10, rcx // Self + + mov rdx, [r10 + 8] // fStackFrame + mov rcx, [r10 + 16] // fStackSize + + cmp rcx, 0 + jz @@Next + + mov r14, rsp + add r14, $20 + + @@loop: + + cmp byte ptr[rdx], typeDOUBLE + jz @@push_double + cmp byte ptr[rdx], typeEXTENDED + jz @@push_double + cmp byte ptr[rdx], typeSINGLE + jz @@push_single + + add rdx, 1 + mov r11, [rdx] + mov [r14], r11 + jmp @@next_param + +@@push_double: + add rdx, 1 + movsd xmm4, [rdx] + movsd [r14], xmm4 + jmp @@next_param + +@@push_single: + add rdx, 1 + cvtsd2ss xmm4, [rdx] + movss [r14], xmm4 + jmp @@next_param + +@@next_param: + + add rdx, 8 //////////// + add r14, 8 + sub rcx, 8 + jnz @@loop + + @@Next: + + mov rax, [r10 + 120] + cmp rax, typeDOUBLE + jz @@mov_double0 + cmp rax, typeEXTENDED + jz @@mov_double0 + cmp rax, typeSINGLE + jz @@mov_single0 + + jmp @@mov_1 + + @@mov_double0: + movsd xmm0, [r10 + 88] + jmp @@mov_1 + + @@mov_single0: + cvtsd2ss xmm0, [r10 + 88] + jmp @@mov_1 + + @@mov_1: + + mov rax, [r10 + 128] + cmp rax, typeDOUBLE + jz @@mov_double1 + cmp rax, typeEXTENDED + jz @@mov_double1 + cmp rax, typeSINGLE + jz @@mov_single1 + + jmp @@mov_2 + + @@mov_double1: + movsd xmm1, [r10 + 96] + jmp @@mov_2 + + @@mov_single1: + cvtsd2ss xmm1, [r10 + 96] + jmp @@mov_2 + + @@mov_2: + + mov rax, [r10 + 136] + cmp rax, typeDOUBLE + jz @@mov_double2 + cmp rax, typeEXTENDED + jz @@mov_double2 + cmp rax, typeSINGLE + jz @@mov_single2 + + jmp @@mov_3 + + @@mov_double2: + movsd xmm2, [r10 + 104] + jmp @@mov_3 + + @@mov_single2: + cvtsd2ss xmm2, [r10 + 104] + jmp @@mov_3 + + @@mov_3: + + mov rax, [r10 + 144] + cmp rax, typeDOUBLE + jz @@mov_double3 + cmp rax, typeEXTENDED + jz @@mov_double3 + cmp rax, typeSINGLE + jz @@mov_single3 + + jmp @@mov_4 + + @@mov_double3: + movsd xmm3, [r10 + 112] + jmp @@mov_4 + + @@mov_single3: + cvtsd2ss xmm3, [r10 + 112] + jmp @@mov_4 + + @@mov_4: + + mov rcx, [r10 + 40] + mov rdx, [r10 + 32] + mov rax, [r10 + 24] + mov r8, [r10 + 48] + mov r9, [r10 + 56] + + jmp rbx +end; +{$ELSE} +procedure TInvoke.PushArguments; +asm + pop ebx // ret address + + mov edx, eax // Self + mov ecx, [edx + 8] // fStackSize + mov edx, [edx + 4] // fStackFrame + + cmp ecx, 0 + jz @@Next + + @@loop: + mov esi, [edx] + push esi + add edx, 4 //////////// + sub ecx, 4 + jnz @@loop + + @@Next: + + mov ecx, [eax + 20] + mov edx, [eax + 16] + mov eax, [eax + 12] + + jmp ebx +end; +{$ENDIF} + +{$IFDEF PAX64} +procedure TInvoke.PushArgumentsBackward; +{$IFDEF FPC} +nostackframe; +{$ENDIF} +asm + pop rbx // ret address + + mov r10, rcx // Self + + mov rdx, [r10 + 8] // fStackFrame + mov rcx, [r10 + 16] // fStackSize + + cmp rcx, 0 + jz @@Next + + mov r14, rsp + add r14, $20 + + @@loop: + + cmp byte ptr[rdx], typeDOUBLE + jz @@push_double + cmp byte ptr[rdx], typeEXTENDED + jz @@push_double + cmp byte ptr[rdx], typeSINGLE + jz @@push_single + + add rdx, 1 + mov r11, [rdx] + mov [r14], r11 + jmp @@next_param + +@@push_double: + add rdx, 1 + movsd xmm4, [rdx] + movsd [r14], xmm4 + jmp @@next_param + +@@push_single: + add rdx, 1 + cvtsd2ss xmm4, [rdx] + movss [r14], xmm4 + jmp @@next_param + +@@next_param: + + sub rdx, 8 //////////// + add r14, 8 + sub rcx, 8 + jnz @@loop + + @@Next: + + mov rax, [r10 + 120] + cmp rax, typeDOUBLE + jz @@mov_double0 + cmp rax, typeEXTENDED + jz @@mov_double0 + cmp rax, typeSINGLE + jz @@mov_single0 + + jmp @@mov_1 + + @@mov_double0: + movsd xmm0, [r10 + 88] + jmp @@mov_1 + + @@mov_single0: + cvtsd2ss xmm0, [r10 + 88] + jmp @@mov_1 + + @@mov_1: + + mov rax, [r10 + 128] + cmp rax, typeDOUBLE + jz @@mov_double1 + cmp rax, typeEXTENDED + jz @@mov_double1 + cmp rax, typeSINGLE + jz @@mov_single1 + + jmp @@mov_2 + + @@mov_double1: + movsd xmm1, [r10 + 96] + jmp @@mov_2 + + @@mov_single1: + cvtsd2ss xmm1, [r10 + 96] + jmp @@mov_2 + + @@mov_2: + + mov rax, [r10 + 136] + cmp rax, typeDOUBLE + jz @@mov_double2 + cmp rax, typeEXTENDED + jz @@mov_double2 + cmp rax, typeSINGLE + jz @@mov_single2 + + jmp @@mov_3 + + @@mov_double2: + movsd xmm2, [r10 + 104] + jmp @@mov_3 + + @@mov_single2: + cvtsd2ss xmm2, [r10 + 104] + jmp @@mov_3 + + @@mov_3: + + mov rax, [r10 + 144] + cmp rax, typeDOUBLE + jz @@mov_double3 + cmp rax, typeEXTENDED + jz @@mov_double3 + cmp rax, typeSINGLE + jz @@mov_single3 + + jmp @@mov_4 + + @@mov_double3: + movsd xmm3, [r10 + 112] + jmp @@mov_4 + + @@mov_single3: + cvtsd2ss xmm3, [r10 + 112] + jmp @@mov_4 + + @@mov_4: + + mov rcx, [r10 + 40] + mov rdx, [r10 + 32] + mov rax, [r10 + 24] + mov r8, [r10 + 48] + mov r9, [r10 + 56] + + jmp rbx +end; + +{$ELSE} + +procedure TInvoke.PushArgumentsBackward; +asm + pop ebx // ret address + + mov edx, eax // Self + mov ecx, [edx + 8] // fStackSize + mov edx, [edx + 4] // fStackFrame + + cmp ecx, 0 + jz @@Next + + @@loop: + mov esi, [edx] + push esi + sub edx, 4 //////////// + sub ecx, 4 + jnz @@loop + + @@Next: + + mov ecx, [eax + 20] + mov edx, [eax + 16] + mov eax, [eax + 12] + + jmp ebx +end; +{$ENDIF} + +{$O-} + +{$IFDEF PAX64} +procedure TInvoke.CallHost; +{$IFDEF FPC} +nostackframe; asm +{$ELSE} +asm + .NOFRAME +{$ENDIF} + push rbp + push rdi + push rsi + push rbx + push r10 + push r11 + push r14 + push r15 + sub rsp, $108 + mov rbp, rsp + + mov r14, rcx + mov [rsp + $100 - 8], rcx + mov [rsp + $100 - 16], r14 + + call TInvoke.PushArguments + mov r14, [rsp + $100 - 16] + + call [r14 + INVOKE_ADDRESS_OFFSET] + + mov rcx, [rsp + $100 - 8] + call TInvoke.SaveResult + + add rsp, $108 + pop r15 + pop r14 + pop r11 + pop r10 + pop rbx + pop rsi + pop rdi + pop rbp + ret +end; + +procedure TInvoke.SaveResult; assembler; +asm + mov r10, rcx + + cmp r10, 0 + jz @@Return + + mov rcx, [r10 + 80] // fResultType + + cmp rcx, typeINTEGER + jnz @@RetUINT64 + mov [r10 + INVOKE_RESULT_OFFSET], rax + jmp @@Return + + @@RetUINT64: + cmp rcx, typeUINT64 + jnz @@RetINT64 + mov [r10 + INVOKE_RESULT_OFFSET], rax + jmp @@Return + + @@RetINT64: + cmp rcx, typeINT64 + jnz @@RetDOUBLE + mov [r10 + INVOKE_RESULT_OFFSET], rax + jmp @@Return + + @@RetDOUBLE: + cmp rcx, typeDOUBLE + jnz @@RetEXTENDED + movsd qword ptr [r10 + INVOKE_RESULT_OFFSET], xmm0 + jmp @@Return + + @@RetEXTENDED: + cmp rcx, typeEXTENDED + jnz @@RetSINGLE + movsd qword ptr [r10 + INVOKE_RESULT_OFFSET], xmm0 + jmp @@Return + + @@RetSINGLE: + movss dword ptr [r10 + INVOKE_RESULT_OFFSET], xmm0 + jmp @@Return + + @@Return: +end; + +{$ELSE} + +{$IFDEF MACOS32} + +procedure TInvoke.CallHostCDECL; assembler; +asm + push ebp + + push ebx + push esi + push edi + + mov ebp, esp + sub esp, $20 + + mov [ebp - 4], eax // save self + + add esp,-$0c + call SysInit.@GetCallerEIP + add esp, $0c + + mov edx, eax // edx := Self + add edx, STACKSIZE_OFFSET + mov ecx, [edx] + mov [ebp - 16], ecx // save fStackSize + + mov edx, eax // edx := Self + add edx, ADDRESS_OFFSET + mov edx, [edx] + mov [ebp - 20], edx // save address of function + + mov edx, eax // edx := Self + add edx, STACKFRAME_OFFSET + mov edx, [edx] // fStackFrameOffset + mov [ebp - 24], edx // save stack fStackFrameOffset + + lea esi, ARR_R1 + mov eax, [esi] + add eax, ecx + mov edx, [eax] + + lea esi, ARR_R2 + mov eax, [esi] + add eax, ecx + mov eax, [eax] + + push edx + push ebp + push $beeffeed + sub esp, eax + + @@push: + cmp ecx, 0 + jz @@Call + + mov edx, [ebp - 24] + + @@loop: + mov esi, [edx] + push esi + add edx, 4 + sub ecx, 4 + jnz @@loop + + @@Call: + + mov edx, [ebp - 20] // restore address of function + call edx + + mov [ebp - 8], eax // save eax + mov [ebp - 12], edx // save edx + + mov ecx, [ebp - 16] // restore fStackSize + + lea esi, ARR_R3 + mov eax, [esi] + add eax, ecx + mov eax, [eax] + + add esp, eax + inc byte ptr [esp-$0c] + + @@result: + + mov eax, [ebp - 4] // restore Self + + mov edx, eax // Self + add edx, RESULTTYPE_OFFSET + mov ecx, [edx] // fResultType + + cmp ecx, typeINTEGER + jnz @@RetINT64 + mov edx, eax // Self + add edx, RESULT_OFFSET + mov eax, [ebp - 8] + mov [edx], eax + jmp @@Return + + @@RetINT64: + cmp ecx, typeINT64 + jnz @@RetDOUBLE + mov ecx, eax // Self + add ecx, RESULT_OFFSET + mov eax, [ebp - 8] + mov edx, [ebp - 12] + mov [ecx], eax + mov [ecx + 4], edx + jmp @@Return + + @@RetDOUBLE: + cmp ecx, typeDOUBLE + jnz @@RetSINGLE + mov edx, eax // Self + add edx, RESULT_OFFSET + fstp qword ptr [edx] + jmp @@Return + + @@RetSINGLE: + cmp ecx, typeSINGLE + jnz @@RetEXTENDED + mov edx, eax // Self + add edx, RESULT_OFFSET + fstp dword ptr [edx] + jmp @@Return + + @@RetEXTENDED: + cmp ecx, typeEXTENDED + jnz @@RetCURRENCY + mov edx, eax // Self + add edx, RESULT_OFFSET + fstp tbyte ptr [edx] + jmp @@Return + + @@RetCURRENCY: + cmp ecx, typeCURRENCY + jnz @@Return + mov edx, eax // Self + add edx, RESULT_OFFSET + fistp qword ptr [edx] + jmp @@Return + + @@Return: + mov eax, [ebp - 8] // retore eax + mov edx, [ebp - 12] // retore eax + + add esp, $20 + + pop edi + pop esi + pop ebx + + pop ebp + ret +end; + +procedure TInvoke.CallHostSTDCALL; assembler; +asm + push ebp + + push ebx + push esi + push edi + + mov ebp, esp + sub esp, $20 + + mov [ebp - 4], eax // save self + + add esp,-$0c + call SysInit.@GetCallerEIP + add esp, $0c + + mov edx, eax // edx := Self + add edx, STACKSIZE_OFFSET + mov ecx, [edx] + mov [ebp - 16], ecx // save fStackSize + + mov edx, eax // edx := Self + add edx, ADDRESS_OFFSET + mov edx, [edx] + mov [ebp - 20], edx // save address of function + + mov edx, eax // edx := Self + add edx, STACKFRAME_OFFSET + mov edx, [edx] // fStackFrameOffset + mov [ebp - 24], edx // save stack fStackFrameOffset + + lea esi, ARR_R1 + mov eax, [esi] + add eax, ecx + mov edx, [eax] + add edx, $80000000 + + lea esi, ARR_R2 + mov eax, [esi] + add eax, ecx + mov eax, [eax] + + push edx + push ebp + push $beeffeed + sub esp, eax + + @@push: + cmp ecx, 0 + jz @@Call + + mov edx, [ebp - 24] + + @@loop: + mov esi, [edx] + push esi + add edx, 4 + sub ecx, 4 + jnz @@loop + + @@Call: + + mov edx, [ebp - 20] // restore address of function + call edx + + mov [ebp - 8], eax // save eax + mov [ebp - 12], edx // save edx + + mov ecx, [ebp - 16] // restore fStackSize + + lea esi, ARR_R2 + mov eax, [esi] + add eax, ecx + mov eax, [eax] + + add eax, $0c + add esp, eax + inc byte ptr [esp-$0c] + + @@result: + mov eax, [ebp - 4] // self + + mov edx, eax // Self + add edx, RESULTTYPE_OFFSET + mov ecx, [edx] // fResultType + + cmp ecx, typeINTEGER + jnz @@RetINT64 + mov edx, eax // Self + add edx, RESULT_OFFSET + mov eax, [ebp - 8] + mov [edx], eax + jmp @@Return + + @@RetINT64: + cmp ecx, typeINT64 + jnz @@RetDOUBLE + mov ecx, eax // Self + add ecx, RESULT_OFFSET + mov eax, [ebp - 8] + mov edx, [ebp - 12] + mov [ecx], eax + mov [ecx + 4], edx + jmp @@Return + + @@RetDOUBLE: + cmp ecx, typeDOUBLE + jnz @@RetSINGLE + mov edx, eax // Self + add edx, RESULT_OFFSET + fstp qword ptr [edx] + jmp @@Return + + @@RetSINGLE: + cmp ecx, typeSINGLE + jnz @@RetEXTENDED + mov edx, eax // Self + add edx, RESULT_OFFSET + fstp dword ptr [edx] + jmp @@Return + + @@RetEXTENDED: + cmp ecx, typeEXTENDED + jnz @@RetCURRENCY + mov edx, eax // Self + add edx, RESULT_OFFSET + fstp tbyte ptr [edx] + jmp @@Return + + @@RetCURRENCY: + cmp ecx, typeCURRENCY + jnz @@Return + mov edx, eax // Self + add edx, RESULT_OFFSET + fistp qword ptr [edx] + jmp @@Return + + @@Return: + mov eax, [ebp - 8] // retore eax + mov edx, [ebp - 12] // retore eax + + add esp, $20 + + pop edi + pop esi + pop ebx + + pop ebp + ret +end; + +procedure TInvoke.CallHost; +asm + push ebp + mov ebp, esp + + push ebx + push esi + push edi + + add esp,-$100 + + mov [esp + $100 - 4], eax + + add esp,-$0c + call SysInit.@GetCallerEIP + add esp, $0c + + mov edx, eax // Self + add edx, STACKSIZE_OFFSET + mov ecx, [edx] // fStackSize + sub edx, STACKSIZE_OFFSET + + add edx, STACKFRAME_OFFSET + mov edx, [edx] // fStackFrame + + mov edi, 12 + cmp ecx, 12 + jg @@L1 + sub edi, ecx +@@L1: + sub esp, edi + + cmp ecx, 0 + jz @@Next + + @@loop: + mov esi, [edx] + push esi + add edx, 4 + sub ecx, 4 + jnz @@loop + + @@Next: + + add eax, ADDRESS_OFFSET + mov esi, [eax] // address of procedure + sub eax, ADDRESS_OFFSET + + add eax, RCX_OFFSET + mov ecx, [eax] + sub eax, RCX_OFFSET + + add eax, RDX_OFFSET + mov edx, [eax] + sub eax, RDX_OFFSET + + add eax, RAX_OFFSET + mov eax, [eax] + + call esi + + add esp, edi + + mov ebx, [esp + $100 - 4] + + // if call convention is cdecl then pop arguments + add ebx, CALLCONV_OFFSET + mov ecx, [ebx] // fCallConv + sub ebx, CALLCONV_OFFSET + cmp ecx, ccCDECL + jnz @@Ret + add ebx, STACKSIZE_OFFSET + mov ecx, [ebx] // fStackSize + sub ebx, STACKSIZE_OFFSET + add esp, ecx + + @@Ret: + + add ebx, RESULTTYPE_OFFSET + mov ecx, [ebx] // fResultType + sub ebx, RESULTTYPE_OFFSET + + cmp ecx, typeINTEGER + jnz @@RetDOUBLE + add ebx, CALLCONV_OFFSET + mov ecx, [ebx] // fCallConv + sub ebx, CALLCONV_OFFSET + cmp ecx, ccSAFECALL + jz @@Return + add ebx, RESULT_OFFSET + mov [ebx], eax + sub ebx, RESULT_OFFSET + jmp @@Return +// + + @@RetDOUBLE: + + cmp ecx, typeDOUBLE + jnz @@RetSINGLE + add ebx, RESULT_OFFSET + fstp qword ptr [ebx] + sub ebx, RESULT_OFFSET + jmp @@Return +// + + @@RetSINGLE: + + cmp ecx, typeSINGLE + jnz @@RetEXTENDED + add ebx, RESULT_OFFSET + fstp dword ptr [ebx] + sub ebx, RESULT_OFFSET + jmp @@Return +// + + @@RetEXTENDED: + + cmp ecx, typeEXTENDED + jnz @@RetCURRENCY + add ebx, RESULT_OFFSET + fstp tbyte ptr [ebx] + sub ebx, RESULT_OFFSET + jmp @@Return +// + + @@RetCURRENCY: + + cmp ecx, typeCURRENCY + jnz @@RetUINT64 + add ebx, RESULT_OFFSET + fistp qword ptr [ebx] + sub ebx, RESULT_OFFSET + jmp @@Return +// + + @@RetUINT64: + cmp ecx, typeUINT64 + jnz @@RetINT64 + add ebx, RESULT_OFFSET + mov [ebx], eax + mov [ebx + 4], edx + sub ebx, RESULT_OFFSET + + @@RetINT64: + cmp ecx, typeINT64 + jnz @@Return + add ebx, RESULT_OFFSET + mov [ebx], eax + mov [ebx + 4], edx + sub ebx, RESULT_OFFSET + + @@Return: + + add esp, $100 + + pop edi + pop esi + pop ebx // TInvoke instance + + pop ebp + ret +end; +{$ELSE} + +procedure TInvoke.CallHost; +asm + push ebp + mov ebp, esp + sub esp, 4 + mov [ebp - 4], eax + + mov edx, eax // Self + mov ecx, [edx + 8] // fStackSize + mov edx, [edx + 4] // fStackFrame + + cmp ecx, 0 + jz @@Next + + @@loop: + mov esi, [edx] + push esi + add edx, 4 + sub ecx, 4 + jnz @@loop + + @@Next: + + mov ebx, [eax + 24] // address of procedure + + mov ecx, [eax + 20] + mov edx, [eax + 16] + mov eax, [eax + 12] + + call ebx + + mov ebx, [ebp - 4] + + // if call convention is cdecl then pop arguments + mov ecx, [ebx + 28] // fCallConv + cmp ecx, ccCDECL + jnz @@Ret + mov ecx, [ebx + 8] // fStackSize + add esp, ecx + + @@Ret: + + mov ecx, [ebx + 32] // fResultType + + cmp ecx, typeINTEGER + jnz @@RetDOUBLE + mov ecx, [ebx + 28] // fCallConv + cmp ecx, ccSAFECALL + jz @@Return + mov [ebx + INVOKE_RESULT_OFFSET], eax + jmp @@Return +// + + @@RetDOUBLE: + + cmp ecx, typeDOUBLE + jnz @@RetSINGLE + fstp qword ptr [ebx + INVOKE_RESULT_OFFSET] + jmp @@Return +// + + @@RetSINGLE: + + cmp ecx, typeSINGLE + jnz @@RetEXTENDED + fstp dword ptr [ebx + INVOKE_RESULT_OFFSET] + jmp @@Return +// + + @@RetEXTENDED: + + cmp ecx, typeEXTENDED + jnz @@RetCURRENCY + fstp tbyte ptr [ebx + INVOKE_RESULT_OFFSET] + jmp @@Return +// + + @@RetCURRENCY: + + cmp ecx, typeCURRENCY + jnz @@RetUINT64 + fistp qword ptr [ebx + INVOKE_RESULT_OFFSET] + jmp @@Return +// + + @@RetUINT64: + cmp ecx, typeUINT64 + jnz @@RetINT64 + mov [ebx + INVOKE_RESULT_OFFSET], eax + mov [ebx + INVOKE_RESULT_OFFSET + 4], edx + + @@RetINT64: + cmp ecx, typeINT64 + jnz @@Return + mov [ebx + INVOKE_RESULT_OFFSET], eax + mov [ebx + INVOKE_RESULT_OFFSET + 4], edx + + @@Return: + + mov esp, ebp + pop ebp + ret +end; +{$ENDIF} +{$ENDIF} + +function TInvoke.GetResultPtr: Pointer; +begin + if CustomResultAddress <> nil then + result := CustomResultAddress + else + result := @ fResult; +end; + +procedure TInvoke.SetResType(value : Integer); +begin + fResultType := value; + NeedSetup := true; +end; + +procedure TInvoke.SetResSize(value : Integer); +begin + fResultSize := value; + NeedSetup := true; +end; + +function TInvoke.GetThis: Pointer; +begin + result := This; + NeedSetup := true; +end; + +procedure TInvoke.SetThis(value: Pointer); +begin + This := value; + NeedSetup := true; +end; + +function TInvoke.ExtraParamNeeded: Boolean; +begin + result := fResultType in [typeUNICSTRING, +{$IFNDEF PAXARM} + typeANSISTRING, + typeWIDESTRING, + typeSHORTSTRING, +{$ENDIF} +{$IFDEF ARC} + typeCLASS, +{$ENDIF} + typeRECORD, + typeARRAY, + typeDYNARRAY, + typeSET, + typeEVENT, + typeVARIANT, + typeOLEVARIANT, + typeINTERFACE]; +end; + +procedure TInvoke.RaiseError(const Message: string; params: array of Const); +begin + raise Exception.Create(Format(Message, params)); +end; + +procedure TInvoke.LoadAddress(const DllName, ProcName: String); +var + H: Cardinal; + I: Integer; +begin + I := DllList.IndexOf(DllName); + if I = - 1 then + begin + {$IFDEF LINUX} + H := HMODULE(dynlibs.LoadLibrary(DLLName)); + Address := dynlibs.GetProcedureAddress(H, ProcName); + {$ELSE} + H := LoadLibrary(PChar(DllName)); + Address := GetProcAddress(H, PChar(ProcName)); + {$ENDIF} + + if Address <> nil then + DllList.AddObject(DllName, TObject(H)); + end + else + begin + H := Cardinal(DllList.Objects[I]); + {$IFDEF LINUX} + Address := dynlibs.GetProcedureAddress(H, ProcName); + {$ELSE} + Address := GetProcAddress(H, PChar(ProcName)); + {$ENDIF} + end; + + if H = 0 then + raise Exception.Create(Format('Dynamic link library %s was not found.', + [DllName])); + + if Address = nil then + raise Exception.Create(Format('The procedure entry point %s could not be located in the' + + ' dynamic link library %s.', + [ProcName, DllName])); +end; + +procedure TInvoke.UloadDlls; +var + H: Cardinal; +begin + while DllList.Count > 0 do + begin + H := Cardinal(DllList.Objects[0]); + FreeLibrary(H); + DllList.Delete(0); + end; +end; + +procedure TInvoke.ClearResult; +begin + case fResultType of + typeSTRING: String(GetResultPtr^) := ''; + typeINTERFACE: IUnknown(GetResultPtr^)._Release; + typeVARIANT: VarClear(Variant(GetResultPtr^)); + end; +end; + +function TInvoke.IsInternal: Boolean; +begin + result := fIsInternal; +end; + +procedure TInvoke.AdjustResult; +begin + if CustomResultAddress <> nil then + if not ExtraParamNeeded then + Move(fResult, CustomResultAddress^, fResultSize); +end; + +procedure CreateMacOSArr; +var + I: Integer; +begin + for I := 0 to High(ARR_R1) do + ARR_R1[I] := R1(I * 4); + for I := 0 to High(ARR_R2) do + ARR_R2[I] := R2(I * 4); + for I := 0 to High(ARR_R3) do + ARR_R3[I] := R3(I * 4); +end; + +initialization +{$IFDEF MACOS} + STACKFRAME_OFFSET := IntPax(@TInvoke(nil).fStackFrame); + STACKSIZE_OFFSET := IntPax(@TInvoke(nil).fStackSize); + RAX_OFFSET := IntPax(@TInvoke(nil).fEAX); + RCX_OFFSET := IntPax(@TInvoke(nil).fECX); + RDX_OFFSET := IntPax(@TInvoke(nil).fEDX); + ADDRESS_OFFSET := IntPax(@TInvoke(nil).fAddress); + CALLCONV_OFFSET := IntPax(@TInvoke(nil).fCallConv); + RESULTTYPE_OFFSET := IntPax(@TInvoke(nil).fResultType); + RESULT_OFFSET := IntPax(@TInvoke(nil).fResult); +{$ENDIF} + CreateMacOSArr; + +end. diff --git a/Sources/PAXCOMP_JS_CONV.pas b/Sources/PAXCOMP_JS_CONV.pas new file mode 100644 index 0000000..1111940 --- /dev/null +++ b/Sources/PAXCOMP_JS_CONV.pas @@ -0,0 +1,1246 @@ +//////////////////////////////////////////////////////////////////////////// +// PaxCompiler +// Site: http://www.paxcompiler.com +// Author: Alexander Baranovsky (paxscript@gmail.com) +// ======================================================================== +// Copyright (c) Alexander Baranovsky, 2006-2014. All rights reserved. +// Code Version: 4.2 +// ======================================================================== +// Unit: PAXCOMP_JS_CONV.pas +// ======================================================================== +//////////////////////////////////////////////////////////////////////////// + +{$I PaxCompiler.def} +unit PAXCOMP_JS_CONV; +interface +uses {$I uses.def} + SysUtils, + Classes, + PAXCOMP_CONSTANTS, + PAXCOMP_TYPES, + PAXCOMP_SYS, + PAXCOMP_KERNEL, + PAXCOMP_BYTECODE, + PAXCOMP_BASESYMBOL_TABLE, + PAXCOMP_SYMBOL_TABLE, + PAXCOMP_SYMBOL_REC, + PAXCOMP_EMIT, + PAXCOMP_JavaScript, + PaxCompiler, PaxProgram, PaxRegister, PaxBasicLanguage; +const + HOST_INSTANCE = 'HostInstance'; +type + TJSConverter = class + private + Kernel: TKernel; + Code: TCode; + CR: TCodeRec; + SymbolTable: TSymbolTable; + + fResult: TStringList; + + indent: Integer; + indent_delta: Integer; + + used_labels: TIntegerList; + PushOperators: TIntegerList; + + EmitList: array of TEmitProc; + + saved_names: TAssocStrings; + + procedure SaveUnusedLabels; + function IsTempName(Id: Integer): Boolean; + function GetName(Id: Integer): String; + function GetLabelName(Id: Integer): String; + function GetSelfName(Id: Integer): String; + function GetSymbolRec(Id: Integer): TSymbolRec; + procedure EmitNothing; + procedure CreateEmitProcList; + procedure Emit(const S: String); + + procedure EmitOP_SEPARATOR; + procedure EmitOP_ASSIGN; + + procedure EmitOP_ADD; + procedure EmitOP_SUB; + procedure EmitOP_MULT; + procedure EmitOP_DIV; + procedure EmitOP_IDIV; + procedure EmitOP_MOD; + procedure EmitOP_AND; + procedure EmitOP_OR; + procedure EmitOP_SHL; + procedure EmitOP_SHR; + + procedure EmitOP_GT; + procedure EmitOP_GE; + procedure EmitOP_LT; + procedure EmitOP_LE; + procedure EmitOP_EQ; + procedure EmitOP_NE; + procedure EmitOP_GO_FALSE; + procedure EmitOP_GO_TRUE; + procedure EmitOP_GO; + procedure EmitOP_EXIT; + procedure EmitOP_LABEL; + procedure EmitOP_PRINT_EX; + procedure EmitOP_INIT_SUB; + procedure EmitOP_END_SUB; + procedure EmitOP_CALL; + procedure EmitOP_ELEM; + procedure EmitOP_DECLARE_LOCAL_VAR; + + procedure EmitOP_SET_PROP; + procedure EmitOP_GET_PROP; + procedure EmitOP_XXX_FROM_XXX; + + procedure EmitOP_TRY_ON; + procedure EmitOP_TRY_OFF; + procedure EmitOP_FINALLY; + + procedure RaiseError(const Message: string; params: array of Const); overload; + procedure RaiseError; overload; + + public + constructor Create(compiler: TPaxCompiler); + destructor Destroy; override; + procedure GenJavaScript(const ModuleName: String); + property JSCode: TStringList read fResult; + end; + +implementation + +constructor TJSConverter.Create(compiler: TPaxCompiler); +begin + inherited Create; + Kernel := TKernel(compiler.GetKernelPtr); + Code := Kernel.Code; + SymbolTable := Kernel.SymbolTable; + fResult := TStringList.Create; + used_labels := TIntegerList.Create; + indent_delta := 2; + + saved_names := TAssocStrings.Create; + + CreateEmitProcList; + + PushOperators := TIntegerList.Create; + + with PushOperators do + begin + Add(OP_PUSH_ADDRESS); + Add(OP_PUSH_STRUCTURE); + Add(OP_PUSH_SET); + + Add(OP_PUSH_BYTE_IMM); + Add(OP_PUSH_BYTE); + Add(OP_PUSH_WORD_IMM); + Add(OP_PUSH_WORD); + Add(OP_PUSH_CARDINAL_IMM); + Add(OP_PUSH_CARDINAL); + Add(OP_PUSH_SMALLINT_IMM); + Add(OP_PUSH_SMALLINT); + Add(OP_PUSH_SHORTINT_IMM); + Add(OP_PUSH_SHORTINT); + Add(OP_PUSH_INT_IMM); + Add(OP_PUSH_INT); + Add(OP_PUSH_DOUBLE); + Add(OP_PUSH_CURRENCY); + Add(OP_PUSH_SINGLE); + Add(OP_PUSH_EXTENDED); + Add(OP_PUSH_ANSISTRING); + Add(OP_PUSH_SHORTSTRING); + Add(OP_PUSH_WIDESTRING); + Add(OP_PUSH_UNICSTRING); + Add(OP_PUSH_PANSICHAR_IMM); + Add(OP_PUSH_PWIDECHAR_IMM); + Add(OP_PUSH_DYNARRAY); + Add(OP_PUSH_OPENARRAY); + Add(OP_PUSH_INT64); + Add(OP_PUSH_DATA); + Add(OP_PUSH_EVENT); + end; + +end; + +destructor TJSConverter.Destroy; +begin + FreeAndNil(fResult); + FreeAndNil(used_labels); + FreeAndNil(PushOperators); + FreeAndNil(saved_names); + + inherited; +end; + +procedure TJSConverter.EmitNothing; +begin +end; + +procedure TJSConverter.CreateEmitProcList; +var + I: Integer; +begin + SetLength(EmitList, - OP_DUMMY); + + for I:=0 to Length(EmitList) - 1 do + EmitList[I] := EmitNothing; + + EmitList[ - OP_SEPARATOR ] := EmitOP_SEPARATOR; +//assign + EmitList[ - OP_ASSIGN ] := EmitOP_ASSIGN; + EmitList[ - OP_ASSIGN_BYTE_I ] := EmitOP_ASSIGN; + EmitList[ - OP_ASSIGN_BYTE_M ] := EmitOP_ASSIGN; + EmitList[ - OP_ASSIGN_WORD_I ] := EmitOP_ASSIGN; + EmitList[ - OP_ASSIGN_WORD_M ] := EmitOP_ASSIGN; + EmitList[ - OP_ASSIGN_CARDINAL_I ] := EmitOP_ASSIGN; + EmitList[ - OP_ASSIGN_CARDINAL_M ] := EmitOP_ASSIGN; + EmitList[ - OP_ASSIGN_SMALLINT_I ] := EmitOP_ASSIGN; + EmitList[ - OP_ASSIGN_SMALLINT_M ] := EmitOP_ASSIGN; + EmitList[ - OP_ASSIGN_SHORTINT_I ] := EmitOP_ASSIGN; + EmitList[ - OP_ASSIGN_SHORTINT_M ] := EmitOP_ASSIGN; + EmitList[ - OP_ASSIGN_INT_I ] := EmitOP_ASSIGN; + EmitList[ - OP_ASSIGN_INT_M ] := EmitOP_ASSIGN; + EmitList[ - OP_ASSIGN_DOUBLE ] := EmitOP_ASSIGN; + EmitList[ - OP_ASSIGN_CURRENCY ] := EmitOP_ASSIGN; + EmitList[ - OP_ASSIGN_EVENT ] := EmitOP_ASSIGN; + EmitList[ - OP_ASSIGN_SINGLE ] := EmitOP_ASSIGN; + EmitList[ - OP_ASSIGN_EXTENDED ] := EmitOP_ASSIGN; + EmitList[ - OP_ASSIGN_PANSICHAR ] := EmitOP_ASSIGN; + EmitList[ - OP_ASSIGN_PWIDECHAR ] := EmitOP_ASSIGN; + EmitList[ - OP_ASSIGN_INT64 ] := EmitOP_ASSIGN; + EmitList[ - OP_ASSIGN_INTERFACE ] := EmitOP_ASSIGN; + EmitList[ - OP_ASSIGN_ANSISTRING ] := EmitOP_ASSIGN; + EmitList[ - OP_ASSIGN_SHORTSTRING ] := EmitOP_ASSIGN; + EmitList[ - OP_ASSIGN_WIDESTRING ] := EmitOP_ASSIGN; + EmitList[ - OP_ASSIGN_UNICSTRING ] := EmitOP_ASSIGN; + EmitList[ - OP_ASSIGN_VARIANT ] := EmitOP_ASSIGN; + EmitList[ - OP_ASSIGN_OLEVARIANT ] := EmitOP_ASSIGN; + EmitList[ - OP_ASSIGN_CLASS ] := EmitOP_ASSIGN; + EmitList[ - OP_ASSIGN_TVarRec ] := EmitOP_ASSIGN; + EmitList[ - OP_ASSIGN_RECORD ] := EmitOP_ASSIGN; + EmitList[ - OP_ASSIGN_ARRAY ] := EmitOP_ASSIGN; +//add + EmitList[ - OP_ADD_ANSISTRING ] := EmitOP_ADD; + EmitList[ - OP_ADD_SHORTSTRING ] := EmitOP_ADD; + EmitList[ - OP_ADD_WIDESTRING ] := EmitOP_ADD; + EmitList[ - OP_ADD_UNICSTRING ] := EmitOP_ADD; + EmitList[ - OP_ADD_STRING ] := EmitOP_ADD; + EmitList[ - OP_ADD_VARIANT ] := EmitOP_ADD; + EmitList[ - OP_ADD_INT_MI ] := EmitOP_ADD; + EmitList[ - OP_ADD_INT_MM ] := EmitOP_ADD; + EmitList[ - OP_ADD_INT64 ] := EmitOP_ADD; + EmitList[ - OP_ADD_CURRENCY ] := EmitOP_ADD; + EmitList[ - OP_ADD_DOUBLE ] := EmitOP_ADD; + EmitList[ - OP_ADD_SINGLE ] := EmitOP_ADD; + EmitList[ - OP_ADD_EXTENDED ] := EmitOP_ADD; +//sub + EmitList[ - OP_SUB_VARIANT ] := EmitOP_SUB; + EmitList[ - OP_SUB_INT_MI ] := EmitOP_SUB; + EmitList[ - OP_SUB_INT_MM ] := EmitOP_SUB; + EmitList[ - OP_SUB_INT64 ] := EmitOP_SUB; + EmitList[ - OP_SUB_CURRENCY ] := EmitOP_SUB; + EmitList[ - OP_SUB_DOUBLE ] := EmitOP_SUB; + EmitList[ - OP_SUB_SINGLE ] := EmitOP_SUB; + EmitList[ - OP_SUB_EXTENDED ] := EmitOP_SUB; +//mult + EmitList[ - OP_MULT_VARIANT ] := EmitOP_MULT; + EmitList[ - OP_IMUL_INT_MI ] := EmitOP_MULT; + EmitList[ - OP_IMUL_INT_MM ] := EmitOP_MULT; + EmitList[ - OP_MULT_INT64 ] := EmitOP_MULT; + EmitList[ - OP_MUL_CURRENCY ] := EmitOP_MULT; + EmitList[ - OP_MUL_DOUBLE ] := EmitOP_MULT; + EmitList[ - OP_MUL_SINGLE ] := EmitOP_MULT; + EmitList[ - OP_MUL_EXTENDED ] := EmitOP_MULT; +//div + EmitList[ - OP_DIV_VARIANT ] := EmitOP_DIV; + EmitList[ - OP_DIV_CURRENCY ] := EmitOP_DIV; + EmitList[ - OP_DIV_DOUBLE ] := EmitOP_DIV; + EmitList[ - OP_DIV_SINGLE ] := EmitOP_DIV; + EmitList[ - OP_DIV_EXTENDED ] := EmitOP_DIV; +//idiv + EmitList[ - OP_IDIV_VARIANT ] := EmitOP_IDIV; + EmitList[ - OP_IDIV_INT64 ] := EmitOP_IDIV; + EmitList[ - OP_IDIV_INT_MI ] := EmitOP_IDIV; + EmitList[ - OP_IDIV_INT_MM] := EmitOP_IDIV; + EmitList[ - OP_IDIV_INT_IM ] := EmitOP_IDIV; +//mod + EmitList[ - OP_MOD_VARIANT ] := EmitOP_MOD; + EmitList[ - OP_MOD_INT64 ] := EmitOP_MOD; + EmitList[ - OP_MOD_INT_MI ] := EmitOP_MOD; + EmitList[ - OP_MOD_INT_MM] := EmitOP_MOD; + EmitList[ - OP_MOD_INT_IM ] := EmitOP_MOD; +//and + EmitList[ - OP_AND_VARIANT ] := EmitOP_AND; + EmitList[ - OP_AND_INT64 ] := EmitOP_AND; + EmitList[ - OP_AND_INT_MI ] := EmitOP_AND; + EmitList[ - OP_AND_INT_MM] := EmitOP_AND; +//or + EmitList[ - OP_OR_VARIANT ] := EmitOP_OR; + EmitList[ - OP_OR_INT64 ] := EmitOP_OR; + EmitList[ - OP_OR_INT_MI ] := EmitOP_OR; + EmitList[ - OP_OR_INT_MM] := EmitOP_OR; +//shl + EmitList[ - OP_SHL_VARIANT ] := EmitOP_SHL; + EmitList[ - OP_SHL_INT64 ] := EmitOP_SHL; + EmitList[ - OP_SHL_INT_MI ] := EmitOP_SHL; + EmitList[ - OP_SHL_INT_MM] := EmitOP_SHL; +//shr + EmitList[ - OP_SHR_VARIANT ] := EmitOP_SHR; + EmitList[ - OP_SHR_INT64 ] := EmitOP_SHR; + EmitList[ - OP_SHR_INT_MI ] := EmitOP_SHR; + EmitList[ - OP_SHR_INT_MM] := EmitOP_SHR; +//gt + EmitList[ - OP_GT_ANSISTRING ] := EmitOP_GT; + EmitList[ - OP_GT_SHORTSTRING ] := EmitOP_GT; + EmitList[ - OP_GT_WIDESTRING ] := EmitOP_GT; + EmitList[ - OP_GT_UNICSTRING ] := EmitOP_GT; + EmitList[ - OP_GT_VARIANT ] := EmitOP_GT; + EmitList[ - OP_GT_INT_MI ] := EmitOP_GT; + EmitList[ - OP_GT_INT_MM ] := EmitOP_GT; + EmitList[ - OP_GT_INT64 ] := EmitOP_GT; + EmitList[ - OP_GT_CURRENCY ] := EmitOP_GT; + EmitList[ - OP_GT_DOUBLE ] := EmitOP_GT; + EmitList[ - OP_GT_SINGLE ] := EmitOP_GT; + EmitList[ - OP_GT_EXTENDED ] := EmitOP_GT; +//ge + EmitList[ - OP_GE_ANSISTRING ] := EmitOP_GE; + EmitList[ - OP_GE_SHORTSTRING ] := EmitOP_GE; + EmitList[ - OP_GE_WIDESTRING ] := EmitOP_GE; + EmitList[ - OP_GE_UNICSTRING ] := EmitOP_GE; + EmitList[ - OP_GE_VARIANT ] := EmitOP_GE; + EmitList[ - OP_GE_INT_MI ] := EmitOP_GE; + EmitList[ - OP_GE_INT_MM ] := EmitOP_GE; + EmitList[ - OP_GE_INT64 ] := EmitOP_GE; + EmitList[ - OP_GE_CURRENCY ] := EmitOP_GE; + EmitList[ - OP_GE_DOUBLE ] := EmitOP_GE; + EmitList[ - OP_GE_SINGLE ] := EmitOP_GE; + EmitList[ - OP_GE_EXTENDED ] := EmitOP_GE; +//lt + EmitList[ - OP_LT_ANSISTRING ] := EmitOP_LT; + EmitList[ - OP_LT_SHORTSTRING ] := EmitOP_LT; + EmitList[ - OP_LT_WIDESTRING ] := EmitOP_LT; + EmitList[ - OP_LT_UNICSTRING ] := EmitOP_LT; + EmitList[ - OP_LT_VARIANT ] := EmitOP_LT; + EmitList[ - OP_LT_INT_MI ] := EmitOP_LT; + EmitList[ - OP_LT_INT_MM ] := EmitOP_LT; + EmitList[ - OP_LT_INT64 ] := EmitOP_LT; + EmitList[ - OP_LT_CURRENCY ] := EmitOP_LT; + EmitList[ - OP_LT_DOUBLE ] := EmitOP_LT; + EmitList[ - OP_LT_SINGLE ] := EmitOP_LT; + EmitList[ - OP_LT_EXTENDED ] := EmitOP_LT; +//le + EmitList[ - OP_LE_ANSISTRING ] := EmitOP_LE; + EmitList[ - OP_LE_SHORTSTRING ] := EmitOP_LE; + EmitList[ - OP_LE_WIDESTRING ] := EmitOP_LE; + EmitList[ - OP_LE_UNICSTRING ] := EmitOP_LE; + EmitList[ - OP_LE_VARIANT ] := EmitOP_LE; + EmitList[ - OP_LE_INT_MI ] := EmitOP_LE; + EmitList[ - OP_LE_INT_MM ] := EmitOP_LE; + EmitList[ - OP_LE_INT64 ] := EmitOP_LE; + EmitList[ - OP_LE_CURRENCY ] := EmitOP_LE; + EmitList[ - OP_LE_DOUBLE ] := EmitOP_LE; + EmitList[ - OP_LE_SINGLE ] := EmitOP_LE; + EmitList[ - OP_LE_EXTENDED ] := EmitOP_LE; +//eq + EmitList[ - OP_EQ_ANSISTRING ] := EmitOP_EQ; + EmitList[ - OP_EQ_SHORTSTRING ] := EmitOP_EQ; + EmitList[ - OP_EQ_WIDESTRING ] := EmitOP_EQ; + EmitList[ - OP_EQ_UNICSTRING ] := EmitOP_EQ; + EmitList[ - OP_EQ_VARIANT ] := EmitOP_EQ; + EmitList[ - OP_EQ_INT_MI ] := EmitOP_EQ; + EmitList[ - OP_EQ_INT_MM ] := EmitOP_EQ; + EmitList[ - OP_EQ_INT64 ] := EmitOP_EQ; + EmitList[ - OP_EQ_CURRENCY ] := EmitOP_EQ; + EmitList[ - OP_EQ_DOUBLE ] := EmitOP_EQ; + EmitList[ - OP_EQ_SINGLE ] := EmitOP_EQ; + EmitList[ - OP_EQ_EXTENDED ] := EmitOP_EQ; + EmitList[ - OP_EQ_STRUCT ] := EmitOP_EQ; +//ne + EmitList[ - OP_NE_ANSISTRING ] := EmitOP_NE; + EmitList[ - OP_NE_SHORTSTRING ] := EmitOP_NE; + EmitList[ - OP_NE_WIDESTRING ] := EmitOP_NE; + EmitList[ - OP_NE_UNICSTRING ] := EmitOP_NE; + EmitList[ - OP_NE_VARIANT ] := EmitOP_NE; + EmitList[ - OP_NE_INT_MI ] := EmitOP_NE; + EmitList[ - OP_NE_INT_MM ] := EmitOP_NE; + EmitList[ - OP_NE_INT64 ] := EmitOP_NE; + EmitList[ - OP_NE_CURRENCY ] := EmitOP_NE; + EmitList[ - OP_NE_DOUBLE ] := EmitOP_NE; + EmitList[ - OP_NE_SINGLE ] := EmitOP_NE; + EmitList[ - OP_NE_EXTENDED ] := EmitOP_NE; + EmitList[ - OP_NE_STRUCT ] := EmitOP_EQ; + + EmitList[ - OP_GO_FALSE ] := EmitOP_GO_FALSE; + EmitList[ - OP_GO_TRUE ] := EmitOP_GO_TRUE; + EmitList[ - OP_GO ] := EmitOP_GO; + EmitList[ - OP_EXIT ] := EmitOP_EXIT; + EmitList[ - OP_LABEL ] := EmitOP_LABEL; + EmitList[ - OP_PRINT_EX ] := EmitOP_PRINT_EX; + EmitList[ - OP_INIT_SUB ] := EmitOP_INIT_SUB; + EmitList[ - OP_END_SUB ] := EmitOP_END_SUB; + EmitList[ - OP_CALL ] := EmitOP_CALL; + EmitList[ - OP_CALL_DEFAULT_CONSTRUCTOR ] := EmitOP_CALL; + EmitList[ - OP_ELEM ] := EmitOP_ELEM; + EmitList[ - OP_DECLARE_LOCAL_VAR ] := EmitOP_DECLARE_LOCAL_VAR; + + EmitList[ - OP_SET_UNICSTR_PROP ] := EmitOP_SET_PROP; + EmitList[ - OP_SET_DRTTI_PROP ] := EmitOP_SET_PROP; + EmitList[ - OP_SET_ANSISTR_PROP ] := EmitOP_SET_PROP; + EmitList[ - OP_SET_WIDESTR_PROP ] := EmitOP_SET_PROP; + EmitList[ - OP_SET_ORD_PROP ] := EmitOP_SET_PROP; + EmitList[ - OP_SET_SET_PROP ] := EmitOP_SET_PROP; + EmitList[ - OP_SET_FLOAT_PROP ] := EmitOP_SET_PROP; + EmitList[ - OP_SET_VARIANT_PROP ] := EmitOP_SET_PROP; + EmitList[ - OP_SET_INT64_PROP ] := EmitOP_SET_PROP; + + EmitList[ - OP_GET_UNICSTR_PROP ] := EmitOP_GET_PROP; + EmitList[ - OP_GET_DRTTI_PROP ] := EmitOP_GET_PROP; + EmitList[ - OP_GET_ANSISTR_PROP ] := EmitOP_GET_PROP; + EmitList[ - OP_GET_WIDESTR_PROP ] := EmitOP_GET_PROP; + EmitList[ - OP_GET_ORD_PROP ] := EmitOP_GET_PROP; + EmitList[ - OP_GET_SET_PROP ] := EmitOP_GET_PROP; + EmitList[ - OP_GET_FLOAT_PROP ] := EmitOP_GET_PROP; + EmitList[ - OP_GET_VARIANT_PROP ] := EmitOP_GET_PROP; + EmitList[ - OP_GET_INT64_PROP ] := EmitOP_GET_PROP; + + EmitList[ - OP_UNICSTRING_FROM_PWIDECHAR_LITERAL ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_VAR_FROM_TVALUE ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_CURRENCY_FROM_INT64 ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_CURRENCY_FROM_INT ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_CURRENCY_FROM_REAL ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_INT_FROM_INT64 ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_BYTE_FROM_INT64 ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_WORD_FROM_INT64 ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_CARDINAL_FROM_INT64 ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_SMALLINT_FROM_INT64 ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_SHORTINT_FROM_INT64 ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_ANSISTRING_FROM_PANSICHAR ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_ANSISTRING_FROM_PWIDECHAR ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_ANSISTRING_FROM_ANSICHAR ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_SHORTSTRING_FROM_PANSICHAR_LITERAL ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_SHORTSTRING_FROM_PWIDECHAR_LITERAL ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_SHORTSTRING_FROM_ANSICHAR ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_SHORTSTRING_FROM_WIDECHAR ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_SHORTSTRING_FROM_ANSISTRING ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_SHORTSTRING_FROM_WIDESTRING ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_UNICSTRING_FROM_WIDESTRING ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_SHORTSTRING_FROM_UNICSTRING ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_ANSISTRING_FROM_SHORTSTRING ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_WIDESTRING_FROM_PANSICHAR_LITERAL ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_WIDESTRING_FROM_PWIDECHAR_LITERAL ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_WIDESTRING_FROM_ANSICHAR ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_WIDESTRING_FROM_WIDECHAR ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_ANSISTRING_FROM_WIDECHAR ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_WIDESTRING_FROM_WIDECHAR_LITERAL ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_WIDESTRING_FROM_ANSISTRING ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_UNICSTRING_FROM_ANSISTRING ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_WIDESTRING_FROM_SHORTSTRING ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_WIDESTRING_FROM_UNICSTRING ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_UNICSTRING_FROM_SHORTSTRING ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_ANSISTRING_FROM_WIDESTRING ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_ANSISTRING_FROM_UNICSTRING ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_UNICSTRING_FROM_PANSICHAR_LITERAL ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_UNICSTRING_FROM_PWIDECHAR_LITERAL ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_UNICSTRING_FROM_ANSICHAR ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_UNICSTRING_FROM_WIDECHAR ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_UNICSTRING_FROM_WIDECHAR_LITERAL ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_INTERFACE_FROM_CLASS ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_VARIANT_FROM_PANSICHAR_LITERAL ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_VARIANT_FROM_PWIDECHAR_LITERAL ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_VARIANT_FROM_ANSISTRING ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_VARIANT_FROM_WIDESTRING ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_VARIANT_FROM_UNICSTRING ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_VARIANT_FROM_SHORTSTRING ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_VARIANT_FROM_ANSICHAR ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_VARIANT_FROM_WIDECHAR ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_VARIANT_FROM_WIDECHAR_LITERAL ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_VARIANT_FROM_INT ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_VARIANT_FROM_INT64 ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_VARIANT_FROM_BYTE ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_VARIANT_FROM_BOOL ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_VARIANT_FROM_WORD ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_VARIANT_FROM_CARDINAL ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_VARIANT_FROM_SMALLINT ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_VARIANT_FROM_SHORTINT ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_VARIANT_FROM_DOUBLE ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_VARIANT_FROM_CURRENCY ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_VARIANT_FROM_SINGLE ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_VARIANT_FROM_EXTENDED ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_VARIANT_FROM_INTERFACE ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_OLEVARIANT_FROM_VARIANT ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_OLEVARIANT_FROM_PANSICHAR_LITERAL ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_OLEVARIANT_FROM_PWIDECHAR_LITERAL ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_OLEVARIANT_FROM_ANSISTRING ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_OLEVARIANT_FROM_WIDESTRING ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_OLEVARIANT_FROM_UNICSTRING ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_OLEVARIANT_FROM_SHORTSTRING ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_OLEVARIANT_FROM_ANSICHAR ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_OLEVARIANT_FROM_WIDECHAR ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_OLEVARIANT_FROM_WIDECHAR_LITERAL ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_OLEVARIANT_FROM_INT ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_OLEVARIANT_FROM_INT64 ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_OLEVARIANT_FROM_BYTE ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_OLEVARIANT_FROM_BOOL ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_OLEVARIANT_FROM_WORD ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_OLEVARIANT_FROM_CARDINAL ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_OLEVARIANT_FROM_SMALLINT ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_OLEVARIANT_FROM_SHORTINT ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_OLEVARIANT_FROM_DOUBLE ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_OLEVARIANT_FROM_CURRENCY ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_OLEVARIANT_FROM_SINGLE ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_OLEVARIANT_FROM_EXTENDED ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_OLEVARIANT_FROM_INTERFACE ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_ANSICHAR_FROM_VARIANT ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_WIDECHAR_FROM_VARIANT ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_ANSISTRING_FROM_VARIANT ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_WIDESTRING_FROM_VARIANT ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_UNICSTRING_FROM_VARIANT ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_SHORTSTRING_FROM_VARIANT ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_DOUBLE_FROM_VARIANT ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_CURRENCY_FROM_VARIANT ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_SINGLE_FROM_VARIANT ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_EXTENDED_FROM_VARIANT ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_INT64_FROM_VARIANT ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_INT_FROM_VARIANT ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_BYTE_FROM_VARIANT ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_WORD_FROM_VARIANT ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_CARDINAL_FROM_VARIANT ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_BOOL_FROM_VARIANT ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_BYTEBOOL_FROM_VARIANT ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_WORDBOOL_FROM_VARIANT ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_LONGBOOL_FROM_VARIANT ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_SMALLINT_FROM_VARIANT ] := EmitOP_XXX_FROM_XXX; + EmitList[ - OP_SHORTINT_FROM_VARIANT ] := EmitOP_XXX_FROM_XXX; + + EmitList[ - OP_TRY_ON ] := EmitOP_TRY_ON; + EmitList[ - OP_TRY_OFF ] := EmitOP_TRY_OFF; + EmitList[ - OP_FINALLY ] := EmitOP_FINALLY; + +end; + +procedure TJSConverter.Emit(const S: String); +begin + if indent >= 0 then + fResult.Add(Space(indent) + S) + else + RaiseError; +end; + +procedure TJSConverter.EmitOP_ASSIGN; +var + S1, S2: String; +begin + S1 := GetName(CR.Arg1); + S2 := GetName(CR.Arg2); + + if IsTempName(CR.Arg1) then + saved_names.Add(S1, S2) + else + Emit(S1 + ' = ' + S2 + ';'); +end; + +procedure TJSConverter.EmitOP_XXX_FROM_XXX; +var + S1, S2, SR: String; +begin + S1 := GetName(CR.Arg1); + S2 := GetName(CR.Arg2); + SR := GetName(CR.Res); + saved_names.Add(S1, S2); +end; + +procedure TJSConverter.EmitOP_SET_PROP; +var + S1, S2, SR: String; +begin + S1 := GetName(CR.Arg1); + S2 := GetName(CR.Arg2); + SR := GetName(CR.Res); + Emit(S1 + '.' + S2 + ' = ' + SR + ';'); +end; + +procedure TJSConverter.EmitOP_GET_PROP; +var + S, S1, S2, SR: String; +begin + S1 := GetName(CR.Arg1); + S2 := GetName(CR.Arg2); + SR := GetName(CR.Res); + + S := S1 + '.' + S2; + saved_names.Add(SR, S); +end; + +procedure TJSConverter.EmitOP_ADD; +var + S1, S2, SR: String; +begin + S1 := GetName(CR.Arg1); + S2 := GetName(CR.Arg2); + SR := GetName(CR.Res); + Emit(SR + ' = ' + S1 + ' + ' + S2 + ';'); +end; + +procedure TJSConverter.EmitOP_SUB; +var + S1, S2, SR: String; +begin + S1 := GetName(CR.Arg1); + S2 := GetName(CR.Arg2); + SR := GetName(CR.Res); + Emit(SR + ' = ' + S1 + ' - ' + S2 + ';'); +end; + +procedure TJSConverter.EmitOP_MULT; +var + S1, S2, SR: String; +begin + S1 := GetName(CR.Arg1); + S2 := GetName(CR.Arg2); + SR := GetName(CR.Res); + Emit(SR + ' = ' + S1 + ' * ' + S2 + ';'); +end; + +procedure TJSConverter.EmitOP_DIV; +var + S1, S2, SR: String; +begin + S1 := GetName(CR.Arg1); + S2 := GetName(CR.Arg2); + SR := GetName(CR.Res); + Emit(SR + ' = ' + S1 + ' / ' + S2 + ';'); +end; + +procedure TJSConverter.EmitOP_IDIV; +var + S1, S2, SR: String; +begin + S1 := GetName(CR.Arg1); + S2 := GetName(CR.Arg2); + SR := GetName(CR.Res); + Emit(SR + ' = ' + S1 + ' / ' + S2 + ';'); +end; + +procedure TJSConverter.EmitOP_MOD; +var + S1, S2, SR: String; +begin + S1 := GetName(CR.Arg1); + S2 := GetName(CR.Arg2); + SR := GetName(CR.Res); + Emit(SR + ' = ' + S1 + ' % ' + S2 + ';'); +end; + +procedure TJSConverter.EmitOP_AND; +var + S1, S2, SR: String; +begin + S1 := GetName(CR.Arg1); + S2 := GetName(CR.Arg2); + SR := GetName(CR.Res); + Emit(SR + ' = ' + S1 + ' && ' + S2 + ';'); +end; + +procedure TJSConverter.EmitOP_OR; +var + S1, S2, SR: String; +begin + S1 := GetName(CR.Arg1); + S2 := GetName(CR.Arg2); + SR := GetName(CR.Res); + Emit(SR + ' = ' + S1 + ' || ' + S2 + ';'); +end; + +procedure TJSConverter.EmitOP_SHL; +var + S1, S2, SR: String; +begin + S1 := GetName(CR.Arg1); + S2 := GetName(CR.Arg2); + SR := GetName(CR.Res); + Emit(SR + ' = ' + S1 + ' << ' + S2 + ';'); +end; + +procedure TJSConverter.EmitOP_SHR; +var + S1, S2, SR: String; +begin + S1 := GetName(CR.Arg1); + S2 := GetName(CR.Arg2); + SR := GetName(CR.Res); + Emit(SR + ' = ' + S1 + ' >> ' + S2 + ';'); +end; + +procedure TJSConverter.EmitOP_GT; +var + S1, S2, SR: String; +begin + S1 := GetName(CR.Arg1); + S2 := GetName(CR.Arg2); + SR := GetName(CR.Res); + + if IsTempName(CR.Res) then + saved_names.Add(SR, '(' + S1 + ' > ' + S2 + ')') + else + Emit(SR + ' = ' + S1 + ' > ' + S2 + ';'); +end; + +procedure TJSConverter.EmitOP_GE; +var + S1, S2, SR: String; +begin + S1 := GetName(CR.Arg1); + S2 := GetName(CR.Arg2); + SR := GetName(CR.Res); + + if IsTempName(CR.Res) then + saved_names.Add(SR, '(' + S1 + ' >= ' + S2 + ')') + else + Emit(SR + ' = ' + S1 + ' >= ' + S2 + ';'); +end; + +procedure TJSConverter.EmitOP_LT; +var + S1, S2, SR: String; +begin + S1 := GetName(CR.Arg1); + S2 := GetName(CR.Arg2); + SR := GetName(CR.Res); + if IsTempName(CR.Res) then + saved_names.Add(SR, '(' + S1 + ' < ' + S2 + ')') + else + Emit(SR + ' = ' + S1 + ' < ' + S2 + ';'); +end; + +procedure TJSConverter.EmitOP_LE; +var + S1, S2, SR: String; +begin + S1 := GetName(CR.Arg1); + S2 := GetName(CR.Arg2); + SR := GetName(CR.Res); + + if IsTempName(CR.Res) then + saved_names.Add(SR, '(' + S1 + ' <= ' + S2 + ')') + else + Emit(SR + ' = ' + S1 + ' <= ' + S2 + ';'); +end; + +procedure TJSConverter.EmitOP_EQ; +var + S1, S2, SR: String; +begin + S1 := GetName(CR.Arg1); + S2 := GetName(CR.Arg2); + SR := GetName(CR.Res); + Emit(SR + ' = ' + S1 + ' == ' + S2 + ';'); +end; + +procedure TJSConverter.EmitOP_NE; +var + S1, S2, SR: String; +begin + S1 := GetName(CR.Arg1); + S2 := GetName(CR.Arg2); + SR := GetName(CR.Res); + Emit(SR + ' = ' + S1 + ' < ' + S2 + ';'); +end; + +procedure TJSConverter.EmitOP_GO_FALSE; +var + S1, S2: String; +begin + S1 := GetLabelName(CR.Arg1); + S2 := GetName(CR.Arg2); + Emit('if ( !' + S2 + ' ) goto ' + S1 + ';'); +end; + +procedure TJSConverter.EmitOP_GO_TRUE; +var + S1, S2: String; +begin + if Code[Code.N - 1].Op = OP_COND_RAISE then + Exit; + + S1 := GetLabelName(CR.Arg1); + S2 := GetName(CR.Arg2); + Emit('if ( ' + S2 + ' ) goto ' + S1 + ';'); +end; + +procedure TJSConverter.EmitOP_GO; +var + S1: String; + I, Op: Integer; + ok: Boolean; + CI: TCodeRec; +begin + Op := Code[Code.N+1].Op; + if (Op = OP_BEGIN_SUB) or + (Op = OP_BEGIN_RECORD_TYPE) or + (Op = OP_BEGIN_CLASS_TYPE) then + begin + I := used_labels.IndexOf(CR.Arg1); + if I >= 0 then + used_labels.RemoveAt(I); + Exit; + end; + + ok := false; + for I := Code.N + 1 to Code.Card do + begin + CI := Code[I]; + Op := CI.Op; + + if Op = OP_LABEL then + if CI.Arg1 = CR.Arg1 then + break; + + if not ( + (Op = OP_LABEL) or + (Op = OP_SEPARATOR) or + (Op = OP_STMT) or + (Op = OP_SET_CODE_LINE) + ) then + begin + ok := true; + break; + end; + end; + + if not ok then + begin + I := used_labels.IndexOf(CR.Arg1); + if I >= 0 then + used_labels.RemoveAt(I); + Exit; + end; + + S1 := GetLabelName(CR.Arg1); + Emit('goto ' + S1 + ';'); +end; + +procedure TJSConverter.EmitOP_EXIT; +begin + if CR.Op = OP_GO then + EmitOP_GO + else + RaiseError; +end; + +procedure TJSConverter.EmitOP_LABEL; +var + S1: String; +begin + if used_labels.IndexOf(CR.Arg1) = -1 then + Exit; + + S1 := GetLabelName(CR.Arg1); + Emit(S1 + ' :'); +end; + +procedure TJSConverter.EmitOP_PRINT_EX; +var + S1: String; +begin + S1 := GetName(CR.Arg1); + Emit('print ' + S1 + ';'); +end; + +procedure TJSConverter.EmitOP_INIT_SUB; +var + SubId, ParamCount, ParamId, SelfId, TypeId, I: Integer; + S, S1, S2, SubName, ParamName: String; +begin + SubId := CR.Arg1; + SubName := GetName(SubId); + ParamCount := SymbolTable[SubId].Count; + SelfId := SymbolTable.GetSelfId(SubId); + + S := 'function ' + SubName + '('; + + for I := 0 to ParamCount - 1 do + begin + ParamId := SymbolTable.GetParamId(SubId, I); + ParamName := GetSymbolRec(ParamId).Name; + S := S + ParamName; + if I < ParamCount - 1 then + S := S + ','; + end; + S := S + ')'; + Emit(S); + Emit('{'); + Inc(indent, indent_delta); + + if GetSymbolRec(SubId).Kind = kindCONSTRUCTOR then + begin + Emit(GetSelfName(SelfId) + ' = new Object();'); + TypeId := GetSymbolRec(SubId).Level; + for I := TypeId + 1 to SymbolTable.Card do + if SymbolTable[I].Level = TypeId then + if SymbolTable[I].Kind in [KindSUB, KindDESTRUCTOR] then + begin + S1 := SymbolTable[I].Name; + if S1 = '' then + S1 := GetName(I); + S2 := GetName(I); + Emit(GetSelfName(SelfId) + '.' + S1 + ' = ' + S2 + ';'); + end; + end; +end; + +procedure TJSConverter.EmitOP_END_SUB; +var + SubId, ResultId, SelfId: Integer; +begin + SubId := CR.Arg1; + ResultId := SymbolTable.GetResultId(SubId); + + if GetSymbolRec(SubId).Kind = kindCONSTRUCTOR then + begin + SelfId := SymbolTable.GetSelfId(SubId); + Emit('return ' + GetSelfName(SelfId) + ';'); + end + else if not (GetSymbolRec(ResultId).FinalTypeId in [0, typeVOID]) then + Emit('return ' + GetName(ResultId) + ';'); + + Dec(indent, indent_delta); + Emit('}'); +end; + +procedure TJSConverter.EmitOP_CALL; +var + S: String; + SubId, NP, I, J, K, ParamId, TypeId, InstanceId, ClassRefId: Integer; + ParamIds: array[0..100] of Integer; +begin + SubId := CR.Arg1; + NP := CR.Arg2; + I := Code.N; + K := 0; + InstanceId := 0; + ClassRefId := 0; + repeat + Dec(I); + if Code[I].Op = OP_BEGIN_CALL then + if Code[I].Arg1 = SubId then + break; + if Code[I].Res = SubId then + begin + if PushOperators.IndexOf(Code[I].Op) >= 0 then + begin + J := Code[I].Arg2; + ParamIds[J] := Code[I].Arg1; + Inc(K); + if K = NP then + break; + end + else if Code[I].Op = OP_PUSH_INST then + InstanceId := Code[I].Arg1 + else if Code[I].Op = OP_PUSH_CLSREF then + ClassRefId := Code[I].Arg1; + end; + until false; + + if K <> NP then + RaiseError; + + S := GetName(SubId); + if StrEql('Implicit', S) then + begin + S := ''; + end + else + S := S + '('; + + if GetSymbolRec(SubId).Kind = kindCONSTRUCTOR then + begin + TypeId := GetSymbolRec(SubId).TypeID; + if ClassRefId <> 0 then + TypeId := GetSymbolRec(ClassRefId + 1).PatternId; + if GetSymbolRec(SubId).Host then + S := 'new ' + GetSymbolRec(TypeId).Name + '('; + end + else if GetSymbolRec(SubId).Kind = kindDESTRUCTOR then + begin + S := 'delete this;'; + Emit(S); + Exit; + end + else if InstanceId <> 0 then + begin + TypeId := GetSymbolRec(InstanceId).TypeID; + if GetSymbolRec(SubId).Host and (not GetSymbolRec(TypeId).Host) then + S := GetName(InstanceId) + '.' + HOST_INSTANCE + '.' + S + else + S := GetName(InstanceId) + '.' + S; + end; + + for I := 0 to NP - 1 do + begin + ParamId := ParamIds[I]; + S := S + GetName(ParamId); + if I < NP - 1 then + S := S + ','; + end; + + if StrEql('Implicit', GetName(SubId)) then + S := S + ';' + else + S := S + ');'; + + if InstanceId <> 0 then + if GetSymbolRec(SubId).Kind = kindCONSTRUCTOR then + if GetSymbolRec(InstanceId).FinalTypeId = typeRECORD then + begin + S := GetName(InstanceId) + ' = ' + S; + Emit(S); + Exit; + end; + + if CR.Res <> 0 then + if GetSymbolRec(CR.Res).FinalTypeId <> typeVOID then + S := GetName(CR.Res) + ' = ' + S; + if Code[Code.N + 1].Op = OP_UPDATE_INSTANCE then + S := 'this.' + HOST_INSTANCE + ' = ' + S; + Emit(S); +end; + +procedure TJSConverter.EmitOP_ELEM; +var + S, Index, Res: String; +begin + S := GetName(CR.Arg1); + Index := GetName(CR.Arg2); + S := S + '[' + Index + ']'; + Res := GetName(CR.Res); + saved_names.Add(Res, S); +end; + +procedure TJSConverter.EmitOP_DECLARE_LOCAL_VAR; +var + S: String; +begin + S := GetName(CR.Arg2); + if GetSymbolRec(CR.Arg2).IsFWArrayVar then + S := 'var ' + S + ' = new Array();' + else + S := 'var ' + S + ';'; + Emit(S); +end; + +procedure TJSConverter.EmitOP_TRY_ON; +begin + Emit('try'); + Emit('{'); +end; + +procedure TJSConverter.EmitOP_TRY_OFF; +begin + Emit('}'); +end; + +procedure TJSConverter.EmitOP_FINALLY; +begin + Emit('}'); + Emit('finally'); + Emit('{'); +end; + +procedure TJSConverter.EmitOP_SEPARATOR; +var + S: String; +begin + S := Code.GetSourceLine(Code.N); + Emit('// ' + S); +end; + +procedure TJSConverter.GenJavaScript(const ModuleName: String); +var + I, I1, I2, Op: Integer; + S: String; + ModuleId: Integer; + ok: Boolean; +begin + ModuleId := kernel.Modules.IndexOf(ModuleName); + if ModuleId = -1 then + RaiseError(errModuleNotFound, []); + + SaveUnusedLabels; + Code.Optimization2; + + S := ''; + + I1 := 0; + I2 := 0; + ok := false; + for I := 1 to Code.Card do + begin + CR := Code[I]; + if CR.Op = OP_BEGIN_MODULE then + begin + if CR.Arg1 = ModuleId then + begin + I1 := I; + ok := true; + end; + end + else if CR.Op = OP_END_MODULE then + begin + if CR.Arg1 = ModuleId then + begin + I2 := I; + break; + end; + end + else if ok and (CR.Op = OP_BEGIN_USING) then + begin + if Cr.Arg1 > 0 then + S := S + GetSymbolRec(CR.Arg1).Name + ','; + end; + end; + + if S <> '' then + begin + S[SHigh(S)] := ';'; + Emit('using ' + S); + end; + + for I := I1 to I2 do + begin + CR := Code[I]; + Op := CR.Op; + Code.N := I; + + EmitList[-Op]; + end; +end; + +procedure TJSConverter.RaiseError(const Message: string; params: array of Const); +begin + kernel.RaiseError(Message, params); +end; + +procedure TJSConverter.RaiseError; +begin + RaiseError(errInternalError, []); +end; + +function TJSConverter.GetLabelName(Id: Integer): String; +begin + result := 'label_' + IntToStr(Id); +end; + +function TJSConverter.GetSelfName(Id: Integer): String; +begin + result := 'this'; +end; + +function TJSConverter.GetName(Id: Integer): String; +var + OwnerId, LevelId, I: Integer; +begin + result := SymbolTable[Id].Name; + + if IsTempName(Id) then + begin + I := saved_names.Keys.IndexOf(result); + if I >= 0 then + begin + result := saved_names.Values[I]; + saved_names.RemoveAt(I); + Exit; + end; + end; + + if IsValidName(result) then + begin + if SymbolTable[Id].Kind = KindCONST then + begin + result := SymbolTable.ValueStr(Id); + Exit; + end; + + if result = 'Me' then + result := 'this'; + OwnerId := GetSymbolRec(Id).OwnerId; + if OwnerId > 0 then + result := GetName(OwnerId) + '.' + result + else if GetSymbolRec(Id).Kind in [kindCONSTRUCTOR, kindDESTRUCTOR] then + begin + LevelId := GetSymbolRec(Id).Level; + result := GetName(LevelId) + '_' + result + end + else if GetSymbolRec(Id).IsMethod then + begin + if not GetSymbolRec(Id).Host then + begin + LevelId := GetSymbolRec(Id).Level; + result := GetName(LevelId) + '_' + result; + end; + end; + + Exit; + end; + if SymbolTable[Id].Kind = KindCONST then + begin + result := SymbolTable.ValueStr(Id); + if SymbolTable[Id].FinaltypeId in CharTypes then + result := '"' + result + '"' + else if SymbolTable[Id].FinaltypeId in StringTypes then + result := '"' + result + '"' + else if SymbolTable[Id].HasPAnsiCharType then + result := '"' + result + '"' + else if SymbolTable[Id].HasPWideCharType then + result := '"' + result + '"'; + Exit; + end; + result := 'temp_' + IntToStr(Id); + + I := saved_names.Keys.IndexOf(result); + if I >= 0 then + begin + result := saved_names.Values[I]; + saved_names.RemoveAt(I); + end; +end; + +function TJSConverter.IsTempName(Id: Integer): Boolean; +var + S: String; + PatternId: Integer; +begin + S := GetSymbolRec(Id).Name; + result := (S = '') or (S = '@'); + if not result then + if GetSymbolRec(Id).Kind = KindVAR then + begin + PatternId := GetSymbolRec(Id).PatternId; + if PatternId > 0 then + result := GetSymbolRec(PatternId).Kind = KindPROP; + end; +end; + +function TJSConverter.GetSymbolRec(Id: Integer): TSymbolRec; +begin + result := SymbolTable[Id]; +end; + +procedure TJSConverter.SaveUnusedLabels; +var + I, Op: Integer; +begin + for I := 1 to Code.Card do + begin + Op := Code[I].Op; + if (Op = OP_GO) or + (Op = OP_GO_FALSE) or + (Op = OP_GO_TRUE) or + (Op = OP_GO_TRUE_BOOL) or + (Op = OP_GO_FALSE_BOOL) then + used_labels.Add(Code[I].Arg1); + end; +end; + +end. diff --git a/Sources/PAXCOMP_JS_PARSER.pas b/Sources/PAXCOMP_JS_PARSER.pas new file mode 100644 index 0000000..63e247a --- /dev/null +++ b/Sources/PAXCOMP_JS_PARSER.pas @@ -0,0 +1,2396 @@ +/////////////////////////////////////////////////////////////////////////// +// PaxCompiler +// Site: http://www.paxcompiler.com +// Author: Alexander Baranovsky (paxscript@gmail.com) +// ======================================================================== +// Copyright (c) Alexander Baranovsky, 2006-2014. All rights reserved. +// Code Version: 4.2 +// ======================================================================== +// Unit: PAXCOMP_JS_PARSER.pas +// ======================================================================== +//////////////////////////////////////////////////////////////////////////// + +{$I PaxCompiler.def} +unit PAXCOMP_JS_PARSER; +interface +uses {$I uses.def} + SysUtils, + PAXCOMP_CONSTANTS, + PAXCOMP_TYPES, + PAXCOMP_SYS, + PAXCOMP_SCANNER, + PAXCOMP_BYTECODE, + PAXCOMP_BASESYMBOL_TABLE, + PAXCOMP_BASERUNNER, + PAXCOMP_MODULE, + PAXCOMP_STDLIB, + PAXCOMP_PARSER; + +type + TJavaScriptParser = class(TBaseParser) + private + anonymous_count: Integer; + StatementLabel: String; + ProcessedLineTerminator: Boolean; + ClosureIds: TIntegerList; + + function DupRes(res: Integer): Integer; + + function IsLabelId: boolean; + function Parse_SetLabel: Integer; + function InContext: Boolean; + + procedure Parse_SourceElements; + procedure Parse_SourceElement; + + function Parse_FunctionDeclaration: Integer; + function Parse_FormalParameterList(SubId: Integer): Integer; + function Parse_ArrayLiteral: Integer; + function Parse_ObjectLiteral: Integer; + function Parse_RegExpLiteral: Integer; + + function Parse_ArgumentList(SubId: Integer): Integer; + + function Parse_PrimaryExpression(ResId: Integer = 0): Integer; + function Parse_MemberExpression(res: Integer): Integer; + function Parse_NewExpression(res: Integer): Integer; + function Parse_CallExpression(res: Integer): Integer; + function Parse_PostfixExpression(res: Integer): Integer; + function Parse_UnaryExpression(res: Integer): Integer; + function Parse_LeftHandSideExpression(res: Integer): Integer; + function Parse_MultiplicativeExpression(res: Integer): Integer; + function Parse_AdditiveExpression(res: Integer): Integer; + function Parse_ShiftExpression(res: Integer): Integer; + function Parse_RelationalExpression(res: Integer): Integer; + function Parse_EqualityExpression(res: Integer): Integer; + function Parse_BitwiseANDExpression(res: Integer): Integer; + function Parse_BitwiseXORExpression(res: Integer): Integer; + function Parse_BitwiseORExpression(res: Integer): Integer; + function Parse_LogicalANDExpression(res: Integer): Integer; + function Parse_LogicalORExpression(res: Integer): Integer; + + function Parse_AssignmentExpression: Integer; + function Parse_FunctionExpression: Integer; + + procedure Parse_Module; + procedure Parse_Statement; + procedure Parse_Namespace; + procedure Parse_Block; + procedure Parse_StatementList; + procedure Parse_VariableStatement; + procedure Parse_VariableDeclarationList; + procedure Parse_VariableDeclaration; + procedure Parse_EmptyStatement; + procedure Parse_IfStatement; + procedure Parse_DoStatement; + procedure Parse_WhileStatement; + procedure Parse_WithStatement; + procedure Parse_SwitchStatement; + procedure Parse_TryStatement; + procedure Parse_ThrowStatement; + procedure Parse_ForStatement; + procedure Parse_BreakStatement; + procedure Parse_GotoStatement; + procedure Parse_ContinueStatement; + procedure Parse_ReturnStatement; + procedure Parse_ExpressionStatement; + + procedure Parse_LoopStmt(l_break, l_continue, l_loop: Integer); + // misc + + function IsLineTerminator: Boolean; + procedure MatchLineTerminator; + + function Parse_Label: Integer; + function IsAssignment_operator(const S: String): Boolean; + function Parse_Assignment_operator: Integer; + function Parse_LogicalOR_operator: Integer; + function Parse_LogicalAND_operator: Integer; + function Parse_BitwiseOR_operator: Integer; + function Parse_BitwiseXOR_operator: Integer; + function Parse_BitwiseAND_operator: Integer; + function Parse_Equality_operator: Integer; + function Parse_Relational_operator: Integer; + function Parse_Shift_operator: Integer; + function Parse_Additive_operator: Integer; + function Parse_Multiplicative_operator: Integer; + + // extension + procedure Parse_UsingStatement; + procedure Parse_PrintStatement; + procedure Parse_PrintlnStatement; + + protected + function CreateScanner: TBaseScanner; override; + function GetLanguageName: String; override; + function GetFileExt: String; override; + function GetLanguageId: Integer; override; + function GetUpcase: Boolean; override; + function GetCurrSelfId: Integer; override; + function ConvString(const S: String): String; override; + public + constructor Create; override; + destructor Destroy; override; + function Parse_Expression: Integer; override; + function GetIncludedFileExt: String; override; + procedure Init(i_kernel: Pointer; M: TModule); override; + + procedure ParseProgram; override; + procedure Call_SCANNER; override; + procedure Match(const S: String); override; + function Parse_Ident: Integer; override; + end; + +implementation + +uses + PAXCOMP_KERNEL, + PAXCOMP_JS_SCANNER; + +constructor TJavaScriptParser.Create; +begin + inherited; + AddKeyword('base'); + AddKeyword('break'); + AddKeyword('case'); + AddKeyword('catch'); + AddKeyword('continue'); + AddKeyword('debugger'); + AddKeyword('default'); + AddKeyword('delete'); + AddKeyword('do'); + + AddKeyword('else'); + AddKeyword('finally'); + AddKeyword('for'); + AddKeyword('function'); + AddKeyword('if'); + AddKeyword('in'); + AddKeyword('instanceof'); + + AddKeyword('new'); + AddKeyword('return'); + AddKeyword('switch'); + AddKeyword('this'); + AddKeyword('throw'); + AddKeyword('try'); + AddKeyword('typeof'); + + AddKeyword('var'); + AddKeyword('void'); + AddKeyword('while'); + AddKeyword('with'); + + AddKeyword('using'); // extension + AddKeyword('print'); // extension + AddKeyword('println'); // extension + AddKeyword('namespace'); // extension +// AddKeyword('module'); // extension + + ClosureIds := TIntegerList.Create(true); +end; + +destructor TJavaScriptParser.Destroy; +begin + FreeAndNil(ClosureIds); + inherited; +end; + +procedure TJavaScriptParser.Init(i_kernel: Pointer; M: TModule); +begin + ClosureIds.Clear; + inherited; +end; + +function TJavaScriptParser.CreateScanner: TBaseScanner; +begin + result := TJavaScriptScanner.Create; +end; + +function TJavaScriptParser.GetLanguageName: String; +begin + result := 'JavaScript'; +end; + +function TJavaScriptParser.GetFileExt: String; +begin + result := 'js'; +end; + +function TJavaScriptParser.GetLanguageId: Integer; +begin + result := JS_LANGUAGE; +end; + +function TJavaScriptParser.GetUpcase: Boolean; +begin + result := false; +end; + +function TJavaScriptParser.GetIncludedFileExt: String; +begin + result := 'js'; +end; + +procedure TJavaScriptParser.ParseProgram; +var + B1, B2: Integer; +begin + ProcessedLineTerminator := false; + + if IsLineTerminator then + MatchLineTerminator; + + anonymous_count := 0; + EXECUTABLE_SWITCH := 0; + DECLARE_SWITCH := false; + Call_SCANNER; + + if IsEOF then + begin + Exit; + end; + + if IsCurrText('module') then + begin + Parse_Module; + Exit; + end; + Gen(OP_END_INTERFACE_SECTION, CurrModule.ModuleNumber, 0, 0); + + B1 := CodeCard; + Parse_SourceElements; + B2 := CodeCard; + + BeginFinalization; + + Gen(OP_BEGIN_GLOBAL_BLOCK, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + + Gen(OP_EPILOGUE_GLOBAL_BLOCK, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + Gen(OP_EPILOGUE_GLOBAL_BLOCK2, 0, 0, 0); + + GenDestroyGlobalDynamicVariables(B1, B2); + + Gen(OP_NOP, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + Gen(OP_END_GLOBAL_BLOCK, 0, 0, 0); + + EndFinalization; +end; + +procedure TJavaScriptParser.Parse_Module; +var + namespace_id, B1, B2: Integer; + S: String; +begin + DECLARE_SWITCH := true; + Match('module'); + + namespace_id := Parse_UnitName(S); + + BeginNamespace(namespace_id); + Match('{'); + + while IsCurrText('using') do + Parse_UsingStatement; + + Gen(OP_END_IMPORT, 0, 0, 0); + + B1 := CodeCard; + + repeat + if IsEOF then + break; + if IsCurrText('}') then + break; + + if IsCurrText('namespace') then + Parse_Namespace + else if IsCurrText('function') then + Parse_FunctionDeclaration + else if IsCurrText('var') then + Parse_VariableStatement + else + Parse_ExpressionStatement; + until false; + + EndNamespace(namespace_id); + + Gen(OP_END_INTERFACE_SECTION, CurrModule.ModuleNumber, 0, 0); + + B2 := CodeCard; + + Match('}'); + + BeginFinalization; + + Gen(OP_BEGIN_GLOBAL_BLOCK, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + + Gen(OP_EPILOGUE_GLOBAL_BLOCK, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + Gen(OP_EPILOGUE_GLOBAL_BLOCK2, 0, 0, 0); + + GenDestroyGlobalDynamicVariables(B1, B2); + + Gen(OP_NOP, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + Gen(OP_END_GLOBAL_BLOCK, 0, 0, 0); + + EndFinalization; +end; + +procedure TJavaScriptParser.Parse_Namespace; +var + namespace_id: Integer; + S: String; +begin + Match('namespace'); + namespace_id := Parse_UnitName(S); + + Match('{'); + + repeat + if IsEOF then + break; + if IsCurrText('}') then + break; + + if IsCurrText('namespace') then + Parse_Namespace + else if IsCurrText('function') then + Parse_FunctionDeclaration + else if IsCurrText('var') then + Parse_VariableStatement + else + Parse_ExpressionStatement; + until false; + + EndNamespace(namespace_id); + + Match('}'); +end; + +procedure TJavaScriptParser.Parse_SourceElements; +begin + repeat + if IsCurrText('}') then + break; + if IsEOF then + break; + Parse_SourceElement; + until false; +end; + +procedure TJavaScriptParser.Parse_SourceElement; +var + L, Id, RefId: Integer; + S: String; +begin + if IsCurrText('function') then + begin + if CurrLevel = 0 then + Parse_FunctionDeclaration + else + begin + L := CurrLevel; + if GetKind(L) = KindSUB then + begin + Id := Parse_FunctionDeclaration; + SetLevel(Id, 0); + + S := GetName(Id); + RefId := NewField(S, CurrSelfId); + Gen(OP_FIELD, CurrSelfId, RefId, RefId); + Gen(OP_ASSIGN, RefId, Id, RefId); + end + else + RaiseError(errSyntaxError, []); + end; + end + else + Parse_Statement; +end; + +function TJavaScriptParser.Parse_FunctionDeclaration: Integer; +begin + result := Parse_FunctionExpression; +end; + +function TJavaScriptParser.Parse_FunctionExpression: Integer; +var + I, SubId, NP, L, + FunctionConstructorId, ObjectConstructorId, ProtoObjectId, RefId, + ObjectId, AddressId: Integer; + global: Boolean; + Id: Integer; + S: String; +begin + EXECUTABLE_SWITCH := 0; + DECLARE_SWITCH := true; + global := true; + + ClosureIds.Clear; + +// JS only + ObjectId := NewTempVar; + result := ObjectId; +// Gen(OP_DECLARE_LOCAL_VAR, JS_TempNamespaceId, ObjectId, 0); +// + + Match('function'); + + if IsCurrText('(') then + begin + SubId := NewTempVar; // anonymous function + Inc(anonymous_count); + SetName(SubId, IntToStr(anonymous_count)); + end + else + SubId := Parse_Ident; + + L := CurrLevel; + if L > 0 then + if GetKind(L) in KindSUBS then + global := false; + +// JS only + SetCallConvention(SubId, ccSTDCALL); + SetType(ObjectId, JS_FunctionClassId); + SetName(ObjectId, GetName(SubId)); + SetName(SubId, '#' + GetName(SubId)); +// + + BeginSub(SubId); + + if IsCurrText('(') then + NP := Parse_FormalParameterList(SubId) + else + begin + NP := 0; + Match(')'); + end; + SetCount(SubId, NP); + SetType(SubId, typeVARIANT); + SetType(CurrResultId, typeVARIANT); + SetType(CurrSelfId, JS_FunctionClassId); + SetName(CurrSelfId, 'this'); + SetKind(CurrSelfId, KindVAR); + SetParam(CurrSelfId, true); + DECLARE_SWITCH := false; + + GetSymbolRec(SubId).IsJSFunction := true; + + InitSub(SubId); + Match('{'); + + Parse_SourceElements; + + EndSub(SubId); + Match('}'); + +// if global then + begin + L := NewLabel; + Gen(OP_GO, L, 0, 0); + Gen(OP_BEGIN_CRT_JS_FUNC_OBJECT, 0, 0, 0); + end; + + FunctionConstructorId := NewField(strInternalCreate, JS_FunctionClassId); + Gen(OP_FIELD, JS_FunctionClassId, FunctionConstructorId, FunctionConstructorId); + + AddressId := NewTempVar(); + SetLevel(AddressId, JS_TempNamespaceId); + Gen(OP_ADDRESS, SubId, 0, AddressId); + Gen(OP_PUSH, AddressId, 0, FunctionConstructorId); + Gen(OP_PUSH, NewConst(typeVARIANT, NP), 1, FunctionConstructorId); + AddressId := NewTempVar(typePOINTER); + SetLevel(AddressId, JS_TempNamespaceId); + Gen(OP_ADDRESS_PROG, 0, 0, AddressId); + Gen(OP_PUSH, AddressId, 2, FunctionConstructorId); + Gen(OP_CALL, FunctionConstructorId, 3, ObjectId); + +// create prototype object + ProtoObjectId := NewTempVar(); + SetLevel(ProtoObjectId, JS_TempNamespaceId); + ObjectConstructorId := NewField(strCreate, JS_ObjectClassId); + Gen(OP_FIELD, JS_ObjectClassId, ObjectConstructorId, ObjectConstructorId); + Gen(OP_CALL, ObjectConstructorId, 0, ProtoObjectId); + + Gen(OP_ASSIGN_PROG, 0, 0, ProtoObjectId); + +// create constructor property + RefId := NewField(strInternalConstructor, ProtoObjectId); + SetLevel(RefId, JS_TempNamespaceId); + Gen(OP_FIELD, ProtoObjectId, RefId, RefId); + Gen(OP_ASSIGN, RefId, ObjectId, RefId); + +// create prototype property + RefId := NewField('prototype', ObjectId); + SetLevel(RefId, JS_TempNamespaceId); + Gen(OP_FIELD, ObjectId, RefId, RefId); + Gen(OP_ASSIGN, RefId, ProtoObjectId, RefId); + +// if global then + begin + Gen(OP_END_CRT_JS_FUNC_OBJECT, 0, 0, 0); + SetLabelHere(L); +// Exit; + end; + + if global then + Exit; + + FunctionConstructorId := NewField(strInternalCreate, JS_FunctionClassId); + Gen(OP_FIELD, JS_FunctionClassId, FunctionConstructorId, FunctionConstructorId); + + AddressId := NewTempVar(); + SetLevel(AddressId, JS_TempNamespaceId); + Gen(OP_ADDRESS, SubId, 0, AddressId); + Gen(OP_PUSH, AddressId, 0, FunctionConstructorId); + Gen(OP_PUSH, NewConst(typeVARIANT, NP), 1, FunctionConstructorId); + AddressId := NewTempVar(typePOINTER); + SetLevel(AddressId, JS_TempNamespaceId); + Gen(OP_ADDRESS_PROG, 0, 0, AddressId); + Gen(OP_PUSH, AddressId, 2, FunctionConstructorId); + Gen(OP_CALL, FunctionConstructorId, 3, ObjectId); + +// create prototype object + ProtoObjectId := NewTempVar(); + SetLevel(ProtoObjectId, JS_TempNamespaceId); + ObjectConstructorId := NewField(strCreate, JS_ObjectClassId); + Gen(OP_FIELD, JS_ObjectClassId, ObjectConstructorId, ObjectConstructorId); + Gen(OP_CALL, ObjectConstructorId, 0, ProtoObjectId); + + Gen(OP_ASSIGN_PROG, 0, 0, ProtoObjectId); + +// create constructor property + RefId := NewField(strInternalConstructor, ProtoObjectId); + SetLevel(RefId, JS_TempNamespaceId); + Gen(OP_FIELD, ProtoObjectId, RefId, RefId); + Gen(OP_ASSIGN, RefId, ObjectId, RefId); + +// create prototype property + RefId := NewField('prototype', ObjectId); + SetLevel(RefId, JS_TempNamespaceId); + Gen(OP_FIELD, ObjectId, RefId, RefId); + Gen(OP_ASSIGN, RefId, ProtoObjectId, RefId); + +// closure: + + for I := 0 to ClosureIds.Count - 1 do + begin + Id := ClosureIds[I]; + if GetLevel(Id) = SubId then + continue; + + S := GetName(Id); + RefId := NewField(S, ObjectId); + SetLevel(RefId, JS_TempNamespaceId); + Gen(OP_FIELD, ObjectId, RefId, RefId); + Gen(OP_ASSIGN, RefId, Id, RefId); + end; +end; + + +function TJavaScriptParser.Parse_FormalParameterList(SubId: Integer): Integer; +var + ID: Integer; +begin + result := 0; + + DECLARE_SWITCH := true; + Match('('); + if not IsCurrText(')') then + repeat + Inc(result); + ID := Parse_FormalParameter; + SetType(ID, typeVARIANT); + Gen(OP_DECLARE_LOCAL_VAR, SubId, ID, 0); + if NotMatch(',') then + break; + until false; + + DECLARE_SWITCH := false; + Match(')'); +end; + +function TJavaScriptParser.Parse_ArrayLiteral: Integer; +var + sub_id, type_id, RefId, elem_id, expr_id, K: Integer; +label Next; +begin + type_id := JS_ArrayClassId; + sub_id := NewTempVar(); + Gen(OP_FIND_CONSTRUCTOR, type_id, 0, sub_id); + + result := NewTempVar(); + Gen(OP_CALL, sub_id, 0, result); + + Gen(OP_ASSIGN_PROG, 0, 0, result); + + RefId := NewField(strInternalConstructor, result); + Gen(OP_FIELD, result, RefId, RefId); + Gen(OP_ASSIGN, RefId, result, RefId); + + K := 0; + + Match('['); + repeat + Next: + + if IsCurrText(',') then + begin + Match(','); + Inc(K); + goto Next; + end + else if IsCurrText(']') then + break + else + begin + elem_id := NewTempVar; + expr_id := Parse_AssignmentExpression; + Gen(OP_ELEM, result, NewConst(typeINTEGER, K), elem_id); + Gen(OP_ASSIGN, elem_id, expr_id, elem_id); + end; + if NotMatch(',') then + Break + else + Inc(K); + until false; + + Match(']'); +end; + +function TJavaScriptParser.Parse_RegExpLiteral: Integer; +var + S: String; + I, sub_id, type_id, RefId: Integer; + c: Char; +begin + S := ScanRegExpLiteral; + + type_id := JS_RegExpClassId; + sub_id := NewTempVar(); + Gen(OP_FIND_CONSTRUCTOR, type_id, 0, sub_id); + + result := NewTempVar(); + Gen(OP_CALL, sub_id, 0, result); + + Gen(OP_ASSIGN_PROG, 0, 0, result); + + RefId := NewField(strInternalConstructor, result); + Gen(OP_FIELD, result, RefId, RefId); + Gen(OP_ASSIGN, RefId, result, RefId); + + RefId := NewField('source', result); + Gen(OP_FIELD, result, RefId, RefId); + Gen(OP_ASSIGN, RefId, NewConst(typeSTRING, S), RefId); + + Call_SCANNER; + Match('/'); + + c := CurrToken.Text[SLow(CurrToken.Text)]; + + if ByteInSet(c, [Ord('i'), Ord('I'), Ord('g'), Ord('G'), Ord('m'), Ord('M')]) then + begin + for I:=SLow(CurrToken.Text) to SHigh(CurrToken.Text) do + case CurrToken.Text[I] of + 'g','G': + begin + RefId := NewField('global', result); + Gen(OP_FIELD, result, RefId, RefId); + Gen(OP_ASSIGN, RefId, TrueId, RefId); + end; + 'i','I': + begin + RefId := NewField('ignoreCase', result); + Gen(OP_FIELD, result, RefId, RefId); + Gen(OP_ASSIGN, RefId, TrueId, RefId); + end; + 'm','M': + begin + RefId := NewField('multiline', result); + Gen(OP_FIELD, result, RefId, RefId); + Gen(OP_ASSIGN, RefId, TrueId, RefId); + end; + end; + Call_SCANNER; + end; +end; + +function TJavaScriptParser.Parse_ObjectLiteral: Integer; +var + sub_id, type_id, RefId, elem_id, expr_id, right_id: Integer; + S: String; + R: TCodeRec; +begin + type_id := JS_ObjectClassId; + sub_id := NewTempVar(); + Gen(OP_FIND_CONSTRUCTOR, type_id, 0, sub_id); + + result := NewTempVar(); + Gen(OP_CALL, sub_id, 0, result); + + Gen(OP_ASSIGN_PROG, 0, 0, result); + + RefId := NewField(strInternalConstructor, result); + Gen(OP_FIELD, result, RefId, RefId); + Gen(OP_ASSIGN, RefId, result, RefId); + + Match('{'); + if not IsCurrText('}') then + repeat + elem_id := NewTempVar; + expr_id := Parse_Expression; + if GetKind(expr_id) <> KindCONST then + begin + S := GetName(expr_id); + R := LastEvalRec(expr_id); + if R <> nil then + R.Op := OP_NOP; + SetName(expr_id, ''); + SetKind(expr_id, KindNONE); + {$IFDEF UNIC} + expr_id := NewConst(typeUNICSTRING, S); + {$ELSE} + expr_id := NewConst(typeANSISTRING, S); + {$ENDIF} + end; + Match(':'); + right_id := Parse_AssignmentExpression; + Gen(OP_ELEM, result, expr_id, elem_id); + Gen(OP_ASSIGN, elem_id, right_id, elem_id); + if NotMatch(',') then + Break; + until False; + Match('}'); +end; + +function TJavaScriptParser.Parse_ArgumentList(SubId: Integer): Integer; +var + I: Integer; + L: TIntegerList; +begin + L := TIntegerList.Create; + try + Match('('); + result := 0; + + if (not IsCurrText(')')) then + begin + repeat + Inc(result); + L.Add(Parse_Expression); + if NotMatch(',') then + Break; + until false; + end; + + for I:=0 to L.Count - 1 do + Gen(OP_PUSH, L[I], I, SubID); + + Match(')'); + finally + FreeAndNil(L); + end; +end; + +// EXPRESSIONS ----------------------------------------------------------------- + +function TJavaScriptParser.DupRes(res: Integer): Integer; +var + id, res_owner, I: Integer; + R: TCodeRec; +begin + res_owner := GetSymbolRec(res).OwnerId; + R := LastCodeRec(I); + if (R.Op = OP_PLUS) or (R.Op = OP_MINUS) then + R := GetCodeRec(I-1); + + id := 0; + + if res_owner > 0 then + begin + if R.Op = OP_ELEM then + begin + Id := NewTempVar; + Gen(OP_ELEM, R.Arg1, R.Arg2, Id); + end + else if R.Op = OP_FIELD then + begin + id := NewField(GetName(res), res_owner); + Gen(OP_FIELD, R.Arg1, id, id); + end + else + RaiseError(errInternalError, []); + result := id; + end + else + result := res; +end; + +function TJavaScriptParser.Parse_PrimaryExpression(ResId: Integer = 0): Integer; +begin + if ResId > 0 then + result := ResId + else if IsCurrText('this') then + begin + result := CurrSelfId; + Match('this'); + end + else if CurrToken.TokenClass = tcBooleanConst then + result := Parse_BooleanLiteral + else if CurrToken.TokenClass = tcPCharConst then + result := Parse_PCharLiteral + else if CurrToken.TokenClass = tcIntegerConst then + result := Parse_IntegerLiteral + else if CurrToken.TokenClass = tcDoubleConst then + result := Parse_DoubleLiteral + else if IsCurrText('[') then + result := Parse_ArrayLiteral + else if IsCurrText('{') then + result := Parse_ObjectLiteral + else if IsCurrText('/') then + result := Parse_RegExpLiteral + else if IsCurrText('(') then + begin + Match('('); + result := Parse_Expression; + Match(')'); + end + else if IsCurrText('@') then + begin + Match('@'); + result := NewTempVar; + Gen(OP_ADDRESS, Parse_Ident, 0, result); + end + else + result := Parse_Ident; +end; + +function TJavaScriptParser.Parse_MemberExpression(res: Integer): Integer; +var + id, type_id, sub_id, RefId, ip, expr_id, K1, K2: Integer; +begin + if IsCurrText('function') then + begin + result := Parse_FunctionExpression; + SetLevel(result, JS_TempNamespaceId); + end + else if IsCurrText('new') then + begin + Match('new'); + type_id := Parse_MemberExpression(res); + sub_id := NewTempVar(); + Gen(OP_FIND_CONSTRUCTOR, type_id, 0, sub_id); + + result := NewTempVar(); + if IsCurrText('(') then // invocation + begin + Gen(OP_CALL, sub_id, Parse_ArgumentList(sub_id), result); + end + else + Gen(OP_CALL, sub_id, 0, result); + + RefId := NewField(strProgram, result); + Gen(OP_FIELD, result, RefId, RefId); + Gen(OP_ASSIGN_PROG, 0, 0, result); + + RefId := NewField(strInternalConstructor, result); + Gen(OP_FIELD, result, RefId, RefId); + Gen(OP_ASSIGN, RefId, result, RefId); + end + else + result := Parse_PrimaryExpression(res); + + ip := CodeCard; + + while IsCurrText('.') or IsCurrText('[') do + begin + if IsCurrText('[') then // element access + begin + Match('['); + repeat + id := result; + result := NewTempVar; + K1 := CodeCard; + expr_id := Parse_Expression; + K2 := CodeCard; + if K2 - K1 > 0 then + RelocateCode(Ip, K1, K2); + Gen(OP_ELEM, id, expr_id, result); + if NotMatch(',') then + Break; + until false; + Match(']'); + end + else if (IsCurrText('.')) then // member access + begin + FIELD_OWNER_ID := result; + id := FIELD_OWNER_ID; + Match('.'); + result := Parse_Ident; + Gen(OP_FIELD, id, result, result); + end; + end; +end; + +function TJavaScriptParser.Parse_NewExpression(res: Integer): Integer; +begin + result := Parse_MemberExpression(res); +end; + +function TJavaScriptParser.Parse_CallExpression(res: Integer): Integer; +var + sub_id, id: Integer; +begin + result := Parse_MemberExpression(res); + if not IsCurrText('(') then + Exit; + sub_id := result; + result := NewTempVar(); + Gen(OP_CALL, sub_id, Parse_ArgumentList(sub_id), result); + repeat + if IsCurrText('(') then // invocation + begin + sub_id := result; + result := NewTempVar(); + Gen(OP_CALL, sub_id, Parse_ArgumentList(sub_id), result); + end + else if IsCurrText('[') then // element access + begin + Match('['); + repeat + id := result; + result := NewTempVar; + Gen(OP_ELEM, id, Parse_Expression, result); + if NotMatch(',') then + Break; + until false; + Match(']'); + end + else if (IsCurrText('.')) then // member access + begin + if GetKind(result) = kindCONST then + begin + id := NewTempVar; + Gen(OP_ASSIGN, id, result, id); + result := Id; + end; + + FIELD_OWNER_ID := result; + id := FIELD_OWNER_ID; + + Match('.'); + result := Parse_Ident; + Gen(OP_FIELD, id, result, result); + end + else + break; + until false; +end; + +function TJavaScriptParser.Parse_LeftHandSideExpression(res: Integer): Integer; +begin + if IsCurrText('new') then + result := Parse_NewExpression(res) + else + result := Parse_CallExpression(res); +end; + +function TJavaScriptParser.Parse_PostfixExpression(res: Integer): Integer; +var + temp, r: Integer; +begin + if res > 0 then + begin + result := res; + Exit; + end; + + result := Parse_LeftHandSideExpression(res); + repeat + if IsCurrText('++') then + begin + Match('++'); + + temp := NewTempVar; + + if IsCurrText(';') then + begin + Gen(OP_PLUS, DupRes(result), NewConst(typeINTEGER, 1), temp); + Gen(OP_ASSIGN, result, temp, result); + Exit; + end; + + res := DupRes(result); + Gen(OP_ASSIGN, temp, res, temp); + r := NewTempVar; + Gen(OP_PLUS, res, NewConst(typeINTEGER, 1), r); + Gen(OP_ASSIGN, result, r, result); + result := temp; + end + else if IsCurrText('--') then + begin + Match('--'); + + temp := NewTempVar; + + if IsCurrText(';') then + begin + Gen(OP_PLUS, DupRes(result), NewConst(typeINTEGER, 1), temp); + Gen(OP_ASSIGN, result, temp, result); + Exit; + end; + + res := DupRes(result); + Gen(OP_ASSIGN, temp, res, temp); + r := NewTempVar; + Gen(OP_MINUS, res, NewConst(typeINTEGER, 1), r); + Gen(OP_ASSIGN, result, r, result); + result := temp; + end + else + break; + until false; +end; + +function TJavaScriptParser.Parse_UnaryExpression(res: Integer): Integer; +var + temp: Integer; +begin + if res > 0 then + begin + result := res; + Exit; + end; + + if IsCurrText('delete') then + begin + Match('delete'); + result := UnaryOp(OP_JS_DELETE, Parse_UnaryExpression(0)); + end + else if IsCurrText('void') then + begin + Match('void'); + result := UnaryOp(OP_JS_VOID, Parse_UnaryExpression(0)); + end + else if IsCurrText('typeof') then + begin + Match('typeof'); + result := UnaryOp(OP_JS_TYPEOF, Parse_UnaryExpression(0)); + end + else if IsCurrText('+') then + begin + Match('+'); + result := Parse_UnaryExpression(0); + end + else if IsCurrText('-') then + begin + Match('-'); + result := UnaryOp(OP_NEG, Parse_UnaryExpression(0)); + end + else if IsCurrText('++') then + begin + Match('++'); + result := Parse_UnaryExpression(0); + temp := NewTempVar; + Gen(OP_PLUS, result, NewConst(typeINTEGER, 1), temp); + Gen(OP_ASSIGN, DupRes(result), temp, result); + result := temp; + end + else if IsCurrText('--') then + begin + Match('--'); + result := Parse_UnaryExpression(0); + temp := NewTempVar; + Gen(OP_MINUS, result, NewConst(typeINTEGER, 1), temp); + Gen(OP_ASSIGN, DupRes(result), temp, result); + result := temp; + end + else if IsCurrText('!') then + begin + Match('!'); + result := UnaryOp(OP_NOT, Parse_UnaryExpression(0)); + end + else if IsCurrText('~') then + begin + Match('~'); + result := UnaryOp(OP_NOT, Parse_UnaryExpression(0)); + end + else + result := Parse_PostfixExpression(res); +end; + +function TJavaScriptParser.Parse_MultiplicativeExpression(res: Integer): Integer; +var + op: Integer; +begin + result := Parse_UnaryExpression(res); + + op := Parse_Multiplicative_operator; + while op <> 0 do + begin + Call_SCANNER; + result := BinOp(op, result, Parse_UnaryExpression(0)); + op := Parse_Multiplicative_operator; + end; +end; + +function TJavaScriptParser.Parse_AdditiveExpression(res: Integer): Integer; +var + op: Integer; +begin + result := Parse_MultiplicativeExpression(res); + + op := Parse_Additive_operator; + while op <> 0 do + begin + Call_SCANNER; + result := BinOp(op, result, Parse_MultiplicativeExpression(0)); + op := Parse_Additive_operator; + end; +end; + +function TJavaScriptParser.Parse_ShiftExpression(res: Integer): Integer; +var + op: Integer; +begin + result := Parse_AdditiveExpression(res); + + op := Parse_Shift_operator; + while op <> 0 do + begin + Call_SCANNER; + result := BinOp(op, result, Parse_AdditiveExpression(0)); + op := Parse_Shift_operator; + end; +end; + +function TJavaScriptParser.Parse_RelationalExpression(res: Integer): Integer; +var + op: Integer; +begin + result := Parse_ShiftExpression(res); + + op := Parse_Relational_operator; + while op <> 0 do + begin + Call_SCANNER; + result := BinOp(op, result, Parse_ShiftExpression(0)); + op := Parse_Relational_operator; + end; +end; + +function TJavaScriptParser.Parse_EqualityExpression(res: Integer): Integer; +var + op: Integer; +begin + result := Parse_RelationalExpression(res); + + op := Parse_Equality_operator; + while op <> 0 do + begin + Call_SCANNER; + result := BinOp(op, result, Parse_RelationalExpression(0)); + op := Parse_Equality_operator; + end; +end; + +function TJavaScriptParser.Parse_BitwiseANDExpression(res: Integer): Integer; +var + op: Integer; +begin + result := Parse_EqualityExpression(res); + + op := Parse_BitwiseAND_operator; + while op <> 0 do + begin + Call_SCANNER; + result := BinOp(op, result, Parse_EqualityExpression(0)); + op := Parse_BitwiseAND_operator; + end; +end; + +function TJavaScriptParser.Parse_BitwiseXORExpression(res: Integer): Integer; +var + op: Integer; +begin + result := Parse_BitwiseANDExpression(res); + + op := Parse_BitwiseXOR_operator; + while op <> 0 do + begin + Call_SCANNER; + result := BinOp(op, result, Parse_BitwiseANDExpression(0)); + op := Parse_BitwiseXOR_operator; + end; +end; + +function TJavaScriptParser.Parse_BitwiseORExpression(res: Integer): Integer; +var + op: Integer; +begin + result := Parse_BitwiseXORExpression(res); + + op := Parse_BitwiseOR_operator; + while op <> 0 do + begin + Call_SCANNER; + result := BinOp(op, result, Parse_BitwiseXORExpression(0)); + op := Parse_BitwiseOR_operator; + end; +end; + +function TJavaScriptParser.Parse_LogicalANDExpression(res: Integer): Integer; +var + op: Integer; +begin + result := Parse_BitwiseORExpression(res); + + op := Parse_LogicalAND_operator; + while op <> 0 do + begin + Call_SCANNER; + result := BinOp(op, result, Parse_BitwiseORExpression(0)); + op := Parse_LogicalAND_operator; + end; +end; + +function TJavaScriptParser.Parse_LogicalORExpression(res: Integer): Integer; +var + op: Integer; +begin + result := Parse_LogicalANDExpression(res); + + op := Parse_LogicalOR_operator; + while op <> 0 do + begin + Call_SCANNER; + result := BinOp(op, result, Parse_LogicalANDExpression(0)); + op := Parse_LogicalOR_operator; + end; +end; + +function TJavaScriptParser.Parse_Expression: Integer; +begin + result := Parse_AssignmentExpression; +end; + +function TJavaScriptParser.Parse_AssignmentExpression: Integer; +var + op, temp, lg, lf, id1, id2, L, K1, K2: Integer; + R: TCodeRec; + S1: String; + NotDeclared: Boolean; +begin + R := LastEvalRec(CurrToken.Id, K1); + if R <> nil then + if IsAssignment_operator(GetNextText) then + begin + if not InContext then + begin + SetKind(R.Res, KindVAR); + R.Op := OP_NOP; + R := nil; + end; + end; + + S1 := CurrToken.Text; + + if R = nil then + K1 := CodeCard + 1; + + result := Parse_UnaryExpression(0); + K2 := CodeCard; + + if IsCurrText(';') then + Exit; + if IsCurrText(')') then + Exit; + + NotDeclared := (not HasBeenDeclared(result)) and (GetSymbolRec(result).Name <> ''); + + op := Parse_Assignment_operator; + if op <> 0 then + begin + Gen(OP_LVALUE, result, 0, 0); + + Call_SCANNER; + if op = OP_ASSIGN then + begin + if NotDeclared then + Gen(OP_DECLARE_LOCAL_VAR, CurrLevel, result, 0); + + id1 := result; + id2 := Parse_AssignmentExpression; + + R := LastCodeRec; + +// if K2 - K1 > 0 then + begin + RelocateCode(K1, K2); + end; + + if (R.Op = op) and (R.Arg1 = Id2) then + Gen(op, id1, R.Arg2, id1) + else + Gen(op, id1, id2, id1); + end + else + begin + if NotDeclared then + Gen(OP_DECLARE_LOCAL_VAR, CurrLevel, result, 0); + + temp := NewTempVar; + Gen(op, result, Parse_AssignmentExpression, temp); + Gen(OP_ASSIGN, result, temp, result); + end; + end + else + result := Parse_LogicalORExpression(result); + if IsCurrText('?') then + begin + Match('?'); + lg := NewLabel; + lf := NewLabel; + Gen(OP_GO_FALSE, lf, result, 0); + result := NewTempVar; + id1 := Parse_AssignmentExpression; + Gen(OP_ASSIGN, result, id1, result); + Match(':'); + Gen(OP_GO, lg, 0, 0); + SetLabelHere(lf); + id2 := Parse_AssignmentExpression; + Gen(OP_ASSIGN, result, id2, result); + SetLabelHere(lg); + end; +end; + +// STATEMENTS ------------------------------------------------------------------ + +procedure TJavaScriptParser.Parse_Statement; +begin + EXECUTABLE_SWITCH := 1; + + Gen(OP_STMT, 0, 0, 0); + + if IsLabelID then + begin + StatementLabel := CurrToken.Text; + Parse_SetLabel; + Match(':'); + end; + + if IsCurrText('using') then + begin + EXECUTABLE_SWITCH := 0; + Parse_UsingStatement; + end + else if IsCurrText('namespace') then + Parse_Namespace + else if IsCurrText('{') then + Parse_Block + else if IsCurrText('var') then + begin + Parse_VariableStatement; + if WithStack.Count > 0 then + Gen(OP_CLEAR_REFERENCES, 0, 0, 0); + end + else if IsCurrText(';') then + Parse_EmptyStatement + else if IsCurrText('if') then + begin + Parse_IfStatement; + end + else if IsCurrText('do') then + Parse_DoStatement + else if IsCurrText('for') then + Parse_ForStatement + else if IsCurrText('goto') then + Parse_GotoStatement + else if IsCurrText('break') then + Parse_BreakStatement + else if IsCurrText('continue') then + Parse_ContinueStatement + else if IsCurrText('return') then + Parse_ReturnStatement + else if IsCurrText('while') then + Parse_WhileStatement + else if IsCurrText('with') then + Parse_WithStatement + else if IsCurrText('switch') then + Parse_SwitchStatement + else if IsCurrText('throw') then + Parse_ThrowStatement + else if IsCurrText('try') then + Parse_TryStatement + else if IsCurrText('print') then + begin + Match('print'); + Parse_PrintStatement; + end + else if IsCurrText('println') then + begin + Match('println'); + Parse_PrintlnStatement; + end + else + Parse_ExpressionStatement; +end; + +procedure TJavaScriptParser.Parse_Block; +begin + Match('{'); + if not IsCurrText('}') then + Parse_StatementList; + Match('}'); +end; + +procedure TJavaScriptParser.Parse_StatementList; +begin + repeat + if IsCurrText('}') then + break; + if IsEOF then + break; + Parse_Statement; + until false; +end; + +procedure TJavaScriptParser.Parse_VariableStatement; +begin + DECLARE_SWITCH := true; + Match('var'); + Parse_VariableDeclarationList; + DECLARE_SWITCH := false; + Match(';'); + if WithStack.Count > 0 then + Gen(OP_CLEAR_REFERENCES, 0, 0, 0); +end; + +procedure TJavaScriptParser.Parse_VariableDeclarationList; +begin + repeat + Parse_VariableDeclaration; + if NotMatch(',') then + break; + until false; +end; + +procedure TJavaScriptParser.Parse_VariableDeclaration; +var + Id, temp, L: Integer; +begin + Id := Parse_Ident; + Gen(OP_DECLARE_LOCAL_VAR, CurrLevel, Id, 0); + if IsCurrText('=') then + begin + DECLARE_SWITCH := false; + Match('='); + if Scanner.IsConstToken(CurrToken) then + begin + L := CurrLevel; + if (L = 0) or (GetKind(L) = KindNAMESPACE) then + Gen(OP_BEGIN_INIT_CONST, ID, 0, 0); + + temp := Parse_AssignmentExpression; + Gen(OP_ASSIGN, Id, temp, Id); + if GetKind(temp) = KindCONST then + begin +{$IFNDEF PAXARM} + if GetSymbolRec(temp).HasPAnsiCharType then + Gen(OP_ASSIGN_TYPE, Id, typeSTRING, 0) + else +{$ENDIF} + if GetSymbolRec(temp).HasPWideCharType then + Gen(OP_ASSIGN_TYPE, Id, typeSTRING, 0) + else + Gen(OP_ASSIGN_TYPE, Id, GetType(temp), 0); + end; + + if (L = 0) or (GetKind(L) = KindNAMESPACE) then + Gen(OP_END_INIT_CONST, ID, 0, 0); + end + else + Gen(OP_ASSIGN, Id, Parse_AssignmentExpression, Id); + DECLARE_SWITCH := true; + end; +end; + +procedure TJavaScriptParser.Parse_EmptyStatement; +begin + Match(';'); +end; + +procedure TJavaScriptParser.Parse_IfStatement; +var + lf, lg: Integer; +begin + lf := NewLabel(); + Match('if'); + Match('('); + Gen(OP_GO_FALSE, lf, Parse_Expression, 0); + Match(')'); + Parse_Statement; + if IsCurrText('else') then + begin + lg := NewLabel; + Gen(OP_GO, lg, 0, 0); + SetLabelHere(lf); + Match('else'); + Parse_Statement; + SetLabelHere(lg); + end + else + SetLabelHere(lf); + if WithStack.Count > 0 then + Gen(OP_CLEAR_REFERENCES, 0, 0, 0); +end; + +procedure TJavaScriptParser.Parse_DoStatement; +var + lt, lg, l_loop: Integer; +begin + lt := NewLabel(); + lg := NewLabel(); + SetLabelHere(lt); + l_loop := lt; + Match('do'); + + Parse_LoopStmt(lg, lt, l_loop); + + Match('while'); + Match('('); + Gen(OP_GO_TRUE, lt, Parse_Expression, 0); + SetLabelHere(lg); + Match(')'); + Match(';'); +end; + +procedure TJavaScriptParser.Parse_WithStatement; +var + id, temp_id, object_id, l_try, cond_id: Integer; +begin + Match('with'); + Match('('); + + id := Parse_Expression; + + if GetKind(id) = kindCONST then + begin + temp_id := NewTempVar; + Gen(OP_ASSIGN, temp_id, id, temp_id); + id := temp_id; + end; + + object_id := NewTempVar(typeVARIANT); + Gen(OP_TO_JS_OBJECT, id, 0, object_id); + + Gen(OP_BEGIN_WITH, id, 0, 0); + WithStack.Push(id); + Gen(OP_PUSH_CONTEXT, object_id, 0, 0); + + l_try := GenBeginTry; + + Match(')'); + Parse_Statement; + + Gen(OP_EXCEPT_SEH, 0, 0, 0); + GenFinally; + + Gen(OP_POP_CONTEXT, object_id, 0, 0); + Gen(OP_END_WITH, id, 0, 0); + WithStack.Pop; + + Gen(OP_COND_RAISE, 0, 0, 0); + cond_id := LastCodeRec.Res; + Gen(OP_GO_TRUE, SkipLabelStack.Top, cond_id, 0); + + SetLabelHere(l_try); + GenEndTry; +end; + +procedure TJavaScriptParser.Parse_SwitchStatement; +var + lg, l_loop, l_default, bool_id, expr_id, case_expr_id, lf, l_skip, I, N1, N2: Integer; + lt: TIntegerStack; + n_skips: TIntegerList; +begin + l_loop := NewLabel; + SetLabelHere(l_loop); + lg := NewLabel(); + l_default := NewLabel(); + + lt := TIntegerStack.Create; + n_skips := TIntegerList.Create; + + bool_id := NewTempVar; + Gen(OP_ASSIGN, bool_id, TrueId, bool_id); + BreakStack.Push(lg, StatementLabel, l_loop); + + Match('switch'); + Match('('); + expr_id := Parse_Expression(); + Match(')'); + Match('{'); // parse switch block + + repeat // parse switch sections + + repeat // parse switch labels + if (IsCurrText('case')) then + begin + Match('case'); + + lt.Push(NewLabel()); + case_expr_id := Parse_Expression(); + Gen(OP_EQ, expr_id, case_expr_id, bool_id); + Gen(OP_GO_TRUE, lt.Top(), bool_id, 0); + end + else if (IsCurrText('default')) then + begin + Match('default'); + SetLabelHere(l_default); + Gen(OP_ASSIGN, bool_id, TrueId, bool_id); + end + else + break; //switch labels + Match(':'); + until false; + + while (lt.Count > 0) do + SetLabelHere(lt.Pop); + + lf := NewLabel(); + Gen(OP_GO_FALSE, lf, bool_id, 0); + + // parse statement list + repeat + if (IsCurrText('case')) then + break; + if (IsCurrText('default')) then + break; + if (IsCurrText('}')) then + break; + + l_skip := NewLabel(); + SetLabelHere(l_skip); + Parse_Statement; + Gen(OP_GO, l_skip, 0, 0); + n_skips.Add(CodeCard); + + until false; + SetLabelHere(lf); + + if (IsCurrText('}')) then + break; + until false; + + BreakStack.Pop(); + SetLabelHere(lg); + Match('}'); + + if n_skips.Count >= 2 then + for I:=0 to n_skips.Count - 2 do + begin + N1 := n_skips[I]; + N2 := n_skips[I+1]; + GetCodeRec(N1).Arg1 := GetCodeRec(N2).Arg1; + end; + N1 := n_skips[n_skips.Count - 1]; + GetCodeRec(N1).Op := OP_NOP; + + FreeAndNil(lt); + + FreeAndNil(n_skips); + + if WithStack.Count > 0 then + Gen(OP_CLEAR_REFERENCES, 0, 0, 0); +end; + +procedure TJavaScriptParser.Parse_WhileStatement; +var + lf, lg, l_loop: Integer; +begin + lf := NewLabel; + lg := NewLabel; + SetLabelHere(lg); + l_loop := lg; + Match('while'); + Match('('); + Gen(OP_GO_FALSE, lf, Parse_Expression, 0); + Match(')'); + + Parse_LoopStmt(lf, lg, l_loop); + + if WithStack.Count > 0 then + Gen(OP_CLEAR_REFERENCES, 0, 0, 0); + Gen(OP_GO, lg, 0, 0); + SetLabelHere(lf); +end; + +procedure TJavaScriptParser.Parse_ThrowStatement; +begin + Match('throw'); + + if ProcessedLineTerminator then + begin + Gen(OP_RAISE, 0, RaiseMode, 0); + Exit; + end; + + if IsCurrText(';') then + Gen(OP_RAISE, 0, RaiseMode, 0) + else + Gen(OP_RAISE, Parse_Expression, RaiseMode, 0); + + Match(';'); +end; + +procedure TJavaScriptParser.Parse_TryStatement; +var + id, type_id, l_try, BlockId: Integer; +begin + Match('try'); + l_try := GenBeginTry; + + Parse_Block; + Gen(OP_EXCEPT_SEH, 0, 0, 0); + + if IsCurrText('catch') then + begin + Gen(OP_GO, l_try, 0, 0); + Match('catch'); + + //ExceptionBlock + + GenExcept; + + BlockId := NewTempVar; + LevelStack.push(BlockId); + Gen(OP_BEGIN_BLOCK, BlockId, 0, 0); + + DECLARE_SWITCH := true; + Match('('); + id := Parse_Ident; + DECLARE_SWITCH := false; + Match(')'); + + type_id := JS_ObjectClassId; + + Gen(OP_ASSIGN_TYPE, id, type_id, 0); + + GenExceptOn(type_id); + Gen(OP_ASSIGN, id, CurrExceptionObjectId, id); + + Gen(OP_BEGIN_EXCEPT_BLOCK, 0, 0, 0); + Parse_Block; + if WithStack.Count > 0 then + Gen(OP_CLEAR_REFERENCES, 0, 0, 0); + Gen(OP_END_EXCEPT_BLOCK, 0, 0, 0); + Gen(OP_GO, l_try, 0, 0); + Gen(OP_END_BLOCK, BlockId, 0, 0); + LevelStack.Pop; + + GenExceptOn(0); + + if IsCurrText('finally') then + begin + Match('finally'); + GenFinally; + Parse_Block; + if WithStack.Count > 0 then + Gen(OP_CLEAR_REFERENCES, 0, 0, 0); + GenCondRaise; + end; + + end // except + else if IsCurrText('finally') then + begin + Match('finally'); + GenFinally; + Parse_Block; + if WithStack.Count > 0 then + Gen(OP_CLEAR_REFERENCES, 0, 0, 0); + GenCondRaise; + end // finally + else + Match('finally'); + SetLabelHere(l_try); + GenEndTry; +end; + +procedure TJavaScriptParser.Parse_ForStatement; +var + lf, l_iter, l_cond, l_stmt, l_loop: Integer; + prop_id, obj_id, success_id: Integer; +begin + l_loop := NewLabel; + SetLabelHere(l_loop); + + Match('for'); + + lf := NewLabel; + l_iter := NewLabel; + l_cond := NewLabel; + l_stmt := NewLabel; + + Match('('); + + // parse for-initializer + if not IsCurrText(';') then + begin + if IsNextText('in') then + begin + success_id := NewTempVar; + obj_id := NewTempVar(typeVARIANT); + prop_id := Parse_Ident; + Match('in'); + SetLabelHere(l_iter); + Gen(OP_TO_JS_OBJECT, Parse_Expression, 0, obj_id); + Gen(OP_GET_NEXTJSPROP, obj_id, prop_id, success_id); + Gen(OP_GO_FALSE, lf, success_id, 0); + Match(')'); + // parse embedded statement + + Parse_LoopStmt(lf, l_iter, l_loop); + + if WithStack.Count > 0 then + Gen(OP_CLEAR_REFERENCES, 0, 0, 0); + Gen(OP_GO, l_iter, 0, 0); + SetLabelHere(lf); + + Exit; + end; + + if IsCurrText('var') then + begin + DECLARE_SWITCH := true; + Match('var'); + + repeat + prop_id := CurrToken.Id; + Parse_VariableDeclaration; + DECLARE_SWITCH := false; + + if IsCurrText('in') then + begin + success_id := NewTempVar; + obj_id := NewTempVar(typeVARIANT); + Match('in'); + SetLabelHere(l_iter); + Gen(OP_TO_JS_OBJECT, Parse_Expression, 0, obj_id); + Gen(OP_GET_NEXTJSPROP, obj_id, prop_id, success_id); + Gen(OP_GO_FALSE, lf, success_id, 0); + Match(')'); + // parse embedded statement + Parse_LoopStmt(lf, l_iter, l_loop); + + if WithStack.Count > 0 then + Gen(OP_CLEAR_REFERENCES, 0, 0, 0); + Gen(OP_GO, l_iter, 0, 0); + SetLabelHere(lf); + + Exit; + end; + + if IsCurrText(',') then + DECLARE_SWITCH := true; + + if NotMatch(',') then + break; + + until false; + end + else + while true do + begin + Parse_Expression; + if NotMatch(',') then + break; + end; + end; + + // parse for-condition + SetLabelHere(l_cond); + Match(';'); + if not IsCurrText(';') then + Gen(OP_GO_FALSE, lf, Parse_Expression, 0); + Gen(OP_GO, l_stmt, 0, 0); + + // parse for-iterator + SetLabelHere(l_iter); + Match(';'); + if not IsCurrText(')') then + while true do + begin + Parse_Expression; + if NotMatch(',') then + break; + end; + + Gen(OP_GO, l_cond, 0, 0); + + // parse embedded statement + SetLabelHere(l_stmt); + Match(')'); + + Parse_LoopStmt(lf, l_iter, l_loop); + + if WithStack.Count > 0 then + Gen(OP_CLEAR_REFERENCES, 0, 0, 0); + Gen(OP_GO, l_iter, 0, 0); + SetLabelHere(lf); +end; + +procedure TJavaScriptParser.Parse_GotoStatement; +begin + Match('goto'); + Gen(OP_GO, Parse_Label, 0, 0); +end; + +procedure TJavaScriptParser.Parse_BreakStatement; +begin + if BreakStack.Count = 0 then + RaiseError(errBreakOrContinueOutsideOfLoop, []); + Match('break'); + Gen(OP_GO, BreakStack.TopLabel, 0, 0); + Match(';'); +end; + +procedure TJavaScriptParser.Parse_ContinueStatement; +begin + if ContinueStack.Count = 0 then + RaiseError(errBreakOrContinueOutsideOfLoop, []); + Match('continue'); + Gen(OP_GO, ContinueStack.TopLabel, 0, 0); + Match(';'); +end; + +procedure TJavaScriptParser.Parse_ReturnStatement; +begin + Match('return'); + if ProcessedLineTerminator then + begin + if WithStack.Count > 0 then + Gen(OP_CLEAR_REFERENCES, 0, 0, 0); + Gen(OP_GO, SkipLabelStack.Top, 0, 0); +// Gen(OP_EXIT, SkipLabelStack.Top, 0, CurrLevel); + Exit; + end; + + if not IsCurrText(';') then + Gen(OP_ASSIGN, CurrResultId, Parse_Expression, CurrResultId); + if WithStack.Count > 0 then + Gen(OP_CLEAR_REFERENCES, 0, 0, 0); + Gen(OP_GO, SkipLabelStack.Top, 0, 0); +// Gen(OP_EXIT, SkipLabelStack.Top, 0, CurrLevel); + Match(';'); +end; + +procedure TJavaScriptParser.Parse_ExpressionStatement; +begin + Parse_Expression; + Match(';'); + if WithStack.Count > 0 then + Gen(OP_CLEAR_REFERENCES, 0, 0, 0); +end; + +procedure TJavaScriptParser.Parse_PrintStatement; +var + ID, ID_L1, ID_L2: Integer; + b: Boolean; +begin + if IsCurrText('(') then + begin + Match('('); + b := true; + end + else + b := false; + + repeat + ID := Parse_Expression; + ID_L1 := 0; + ID_L2 := 0; + if IsCurrText(':') then + begin + Match(':'); + ID_L1 := Parse_Expression; + end; + if IsCurrText(':') then + begin + Match(':'); + ID_L2 := Parse_Expression; + end; + + Gen(OP_PRINT_EX, ID, ID_L1, ID_L2); + if NotMatch(',') then + Break; + until false; + + if b then + Match(')'); + + if WithStack.Count > 0 then + Gen(OP_CLEAR_REFERENCES, 0, 0, 0); +end; + +procedure TJavaScriptParser.Parse_PrintlnStatement; +begin + Parse_PrintStatement; +{$IFDEF PAXARM} + Gen(OP_PRINT_EX, NewConst(typeUNICSTRING, #13#10), 0, 0); +{$ELSE} + Gen(OP_PRINT_EX, NewConst(typeANSISTRING, #13#10), 0, 0); +{$ENDIF} +end; + +procedure TJavaScriptParser.Parse_UsingStatement; +var + unit_id, id: Integer; + S: String; + AlreadyExists: Boolean; +begin + DECLARE_SWITCH := false; + Match('using'); + + UsedUnitList.Clear; + + repeat + unit_id := Parse_UnitName(S); + + Gen(OP_BEGIN_USING, unit_id, 0, 0); + AlreadyExists := GetKind(unit_id) = kindNAMESPACE; + + if IsCurrText('in') then + begin + Match('in'); + id := Parse_PCharLiteral; + S := GetValue(id); + + if (PosCh('\', S) > 0) or (PosCh('/', S) > 0) then + begin + if (Pos('.\', S) > 0) or (Pos('./', S) > 0) then + S := ExpandFileName(S) + else + S := GetCurrentDir + S; + end; + + AlreadyExists := false; + end + else + S := S + '.' + GetFileExt; + + if not AlreadyExists then + AddModuleFromFile(S, unit_id, false); + + if NotMatch(',') then + Break; + until false; + + Match(';'); +end; + +function TJavaScriptParser.IsLineTerminator: Boolean; +begin + result := IsNewLine; +end; + +procedure TJavaScriptParser.MatchLineTerminator; +begin + if IsEOF then + Exit; + + if not IsNewLine then + RaiseError(errLineTerminatorExpected, []); + + while CurrToken.TokenClass = tcSeparator do + begin + Gen(OP_SEPARATOR, CurrModule.ModuleNumber, CurrToken.Id, 0); + inherited Call_SCANNER; + + if IsEOF then + Exit; + end; +end; + +function TJavaScriptParser.Parse_Label: Integer; +begin + if not (CurrToken.TokenClass in [tcIntegerConst, tcIdentifier]) then + RaiseError(errIdentifierExpected, [CurrToken.Text]); + result := CurrToken.Id; + if DECLARE_SWITCH then + SetKind(result, KindLABEL) + else if GetKind(result) <> KindLABEL then + RaiseError(errLabelExpected, []); + Call_SCANNER; +end; + +function TJavaScriptParser.IsAssignment_operator(const S: String): Boolean; +begin + if S = '=' then + result := true + else if S = '*=' then + result := true + else if S = '/=' then + result := true + else if S = '%=' then + result := true + else if S = '+=' then + result := true + else if S = '-=' then + result := true + else if S = '<<=' then + result := true + else if S = '>>=' then + result := true + else if S = '>>>=' then + result := true + else if S = '&=' then + result := true + else if S = '^=' then + result := true + else if S = '|=' then + result := true + else + result := false; +end; + +function TJavaScriptParser.Parse_Assignment_operator: Integer; +begin + result := 0; + if IsCurrText('=') then + result := OP_ASSIGN + else if IsCurrText('*=') then + result := OP_MULT + else if IsCurrText('/=') then + result := OP_DIV + else if IsCurrText('%=') then + result := OP_MOD + else if IsCurrText('+=') then + result := OP_PLUS + else if IsCurrText('-=') then + result := OP_MINUS + else if IsCurrText('<<=') then + result := OP_SHL + else if IsCurrText('>>=') then + result := OP_SHR + else if IsCurrText('>>>=') then + result := OP_SHR + else if IsCurrText('&=') then + result := OP_AND + else if IsCurrText('^=') then + result := OP_XOR + else if IsCurrText('|=') then + result := OP_OR +end; + +function TJavaScriptParser.Parse_LogicalOR_operator: Integer; +begin + result := 0; + if IsCurrText('||') then + result := OP_OR; +end; + +function TJavaScriptParser.Parse_LogicalAND_operator: Integer; +begin + result := 0; + if IsCurrText('&&') then + result := OP_AND; +end; + +function TJavaScriptParser.Parse_BitwiseOR_operator: Integer; +begin + result := 0; + if IsCurrText('|') then + result := OP_OR; +end; + +function TJavaScriptParser.Parse_BitwiseXOR_operator: Integer; +begin + result := 0; + if IsCurrText('^') then + result := OP_XOR; +end; + +function TJavaScriptParser.Parse_BitwiseAND_operator: Integer; +begin + result := 0; + if IsCurrText('&') then + result := OP_AND; +end; + +function TJavaScriptParser.Parse_Equality_operator: Integer; +begin + result := 0; + if IsCurrText('==') then + result := OP_EQ + else if IsCurrText('!=') then + result := OP_NE + else if IsCurrText('===') then + result := OP_EQ + else if IsCurrText('!==') then + result := OP_NE +end; + +function TJavaScriptParser.Parse_Relational_operator: Integer; +begin + result := 0; + if IsCurrText('>') then + result := OP_GT + else if IsCurrText('>=') then + result := OP_GE + else if IsCurrText('<') then + result := OP_LT + else if IsCurrText('<=') then + result := OP_LE + else if IsCurrText('instanceof') then + result := OP_INSTANCE_OF +end; + +function TJavaScriptParser.Parse_Shift_operator: Integer; +begin + result := 0; + if IsCurrText('<<') then + result := OP_SHL + else if IsCurrText('>>') then + result := OP_SHR + else if IsCurrText('>>>') then + result := OP_SHR +end; + +function TJavaScriptParser.Parse_Additive_operator: Integer; +begin + result := 0; + if IsCurrText('+') then + result := OP_PLUS + else if IsCurrText('-') then + result := OP_MINUS; +end; + +function TJavaScriptParser.Parse_Multiplicative_operator: Integer; +begin + result := 0; + if IsCurrText('*') then + result := OP_MULT + else if IsCurrText('/') then + result := OP_DIV + else if IsCurrText('%') then + result := OP_MOD; +end; + +function TJavaScriptParser.IsLabelId: boolean; +begin + result := (CurrToken.TokenClass = tcIdentifier) and IsNextText(':'); +end; + +function TJavaScriptParser.Parse_SetLabel: Integer; +begin + result := Parse_Ident; + Gen(OP_LABEL, 0, 0, 0); + SetKind(result, KindLABEL); +end; + +function TJavaScriptParser.InContext: Boolean; +begin + result := WithStack.Count > 0; +end; + +procedure TJavaScriptParser.Call_SCANNER; +begin + ProcessedLineTerminator := false; + inherited Call_SCANNER; + if IsLineTerminator then + begin + ProcessedLineTerminator := true; + MatchLineTerminator; + end; +end; + +procedure TJavaScriptParser.Match(const S: String); +begin + if S = ';' then + begin + if IsLineTerminator then + MatchLineTerminator + else if IsCurrText(';') then + begin + Call_SCANNER; + end + else if ProcessedLineTerminator then + begin + // ok + end + else // error + inherited Match(S); + + Exit; + end; + + inherited Match(S); +end; + +function TJavaScriptParser.GetCurrSelfId: Integer; +begin + result := levelStack.Top; + result := TKernel(kernel).SymbolTable.GetSelfId(result); +end; + +function TJavaScriptParser.ConvString(const S: String): String; +begin + result := PAXCOMP_SCANNER.ConvertString(S); +end; + +function TJavaScriptParser.Parse_Ident: Integer; +var + L, RefId, ObjectId: Integer; + S: String; +begin + result := inherited Parse_Ident; + + if DECLARE_SWITCH then + Exit; + L := GetLevel(result); + if L = 0 then + Exit; + if L = CurrLevel then + Exit; + + if GetKind(L) in KindSUBS then + begin + ClosureIds.Add(result); + + S := GetName(result); + ObjectId := CurrSelfId; + RefId := NewField(S, ObjectId); + Gen(OP_FIELD, ObjectId, RefId, RefId); + result := RefId; + end; +end; + +procedure TJavaScriptParser.Parse_LoopStmt(l_break, l_continue, l_loop: Integer); +begin + BreakStack.Push(l_break, l_loop); + ContinueStack.Push(l_continue, l_loop); + BeginLoop; + Parse_Statement; + EndLoop; + BreakStack.Pop; + ContinueStack.Pop; +end; + + +end. diff --git a/Sources/PAXCOMP_JS_SCANNER.pas b/Sources/PAXCOMP_JS_SCANNER.pas new file mode 100644 index 0000000..a8f572c --- /dev/null +++ b/Sources/PAXCOMP_JS_SCANNER.pas @@ -0,0 +1,480 @@ +//////////////////////////////////////////////////////////////////////////// +// PaxCompiler +// Site: http://www.paxcompiler.com +// Author: Alexander Baranovsky (paxscript@gmail.com) +// ======================================================================== +// Copyright (c) Alexander Baranovsky, 2006-2014. All rights reserved. +// Code Version: 4.2 +// ======================================================================== +// Unit: PAXCOMP_JS_SCANNER.pas +// ======================================================================== +//////////////////////////////////////////////////////////////////////////// + +{$I PaxCompiler.def} +unit PAXCOMP_JS_SCANNER; +interface +uses {$I uses.def} + SysUtils, + PAXCOMP_CONSTANTS, + PAXCOMP_SYS, + PAXCOMP_SCANNER; + +type + TJavaScriptScanner = class(TBaseScanner) + private + procedure ScanCustDir; + procedure ScanOctalLiteral; + procedure ScanHexLiteral; + function GetNextSpecialChar: Char; + public + procedure ScanStringLiteral(ch: Char); override; + procedure ReadCustomToken; override; + end; + +implementation + +uses + PAXCOMP_KERNEL; + +procedure TJavaScriptScanner.ReadCustomToken; +var + c: Char; +begin + repeat + GetNextChar; + c := LA(0); + Token.Position := Position; + if IsWhiteSpace(c) then + continue + else if c = #13 then + ScanSeparator +{$IFDEF MACOS} + else if c = #10 then + ScanSeparator +{$ENDIF} +{$IFDEF LINUX} + else if c = #10 then + ScanSeparator +{$ENDIF} +{$IFDEF ANDROID} + else if c = #10 then + ScanSeparator +{$ENDIF} + else if IsEOF(c) then + ScanSpecial + else if IsEOF(c) then + ScanSpecial + else if IsEOF then + ScanEOF + + else if IsAlpha(c) or (c = '$') then + begin + while IsAlpha(LA(1)) or IsDigit(LA(1)) or (LA(1) = '$') do + GetNextChar; + Token.TokenClass := tcIdentifier; + SetScannerState(scanProg); + token.Length := Position - token.Position + 1; + if StrEql(Token.Text, 'in') then + ScanSpecial; + end + else if c = CHAR_DOUBLE_AP then + begin + ScanStringLiteral(CHAR_DOUBLE_AP); + Token.TokenClass := tcPCharConst; + end + else if c = CHAR_AP then + begin + ScanStringLiteral(CHAR_AP); + Token.TokenClass := tcPCharConst; + end + else if IsDigit(c) then + begin + if (c = '0') and (LA(1) = 'x') then + begin + GetNextChar; + ScanHexLiteral; + end + else + ScanNumberLiteral; + end + + else if c = '{' then + ScanSpecial + else if c = '}' then + ScanSpecial + else if c = '(' then + ScanSpecial + else if c = ')' then + ScanSpecial + else if c = '[' then + ScanSpecial + else if c = ']' then + ScanSpecial + else if c = '.' then + ScanSpecial + else if c = ';' then + ScanSpecial + else if c = ',' then + ScanSpecial + else if c = '<' then + begin + ScanSpecial; + if LA(1) = '<' then + begin + GetNextChar; + if LA(1) = '=' then + GetNextChar; + end + else if LA(1) = '=' then + GetNextChar; + end + else if c = '>' then + begin + ScanSpecial; + if LA(1) = '>' then + begin + GetNextChar; + if LA(1) = '>' then + begin + GetNextChar; + if LA(1) = '=' then + GetNextChar; + end + else if LA(1) = '=' then + GetNextChar; + end + else if LA(1) = '=' then + GetNextChar; + end + else if c = '=' then + begin + ScanSpecial; + if LA(1) = '=' then + begin + GetNextChar; + if LA(1) = '=' then + GetNextChar; + end; + end + else if c = '!' then + begin + ScanSpecial; + if LA(1) = '=' then + begin + GetNextChar; + if LA(1) = '=' then + GetNextChar; + end + end + else if c = '+' then + begin + ScanSpecial; + if LA(1) = '+' then + GetNextChar + else if LA(1) = '=' then + GetNextChar; + end + else if c = '-' then + begin + ScanSpecial; + if LA(1) = '-' then + GetNextChar + else if LA(1) = '=' then + GetNextChar; + end + else if c = '*' then + begin + ScanSpecial; + if LA(1) = '=' then + GetNextChar; + end + else if c = '%' then + begin + ScanSpecial; + if LA(1) = '=' then + GetNextChar; + end + else if c = '|' then + begin + ScanSpecial; + if LA(1) = '|' then + GetNextChar + else if LA(1) = '=' then + GetNextChar; + end + else if c = '^' then + begin + ScanSpecial; + if LA(1) = '=' then + GetNextChar; + end + else if c = '~' then + begin + ScanSpecial; + if LA(1) = '=' then + GetNextChar; + end + else if c = '&' then + begin + ScanSpecial; + if LA(1) = '&' then + GetNextChar + else if LA(1) = '=' then + GetNextChar; + end + else if c = '?' then + ScanSpecial + else if c = ':' then + ScanSpecial + else if c = '@' then + begin + if LA(1) = '@' then + begin + GetNextChar; + ScanCustDir; + Token.TokenClass := tcNone; + continue; + end + else + ScanSpecial; + end + else if c = '/' then + begin + if LA(1) = '/' then + begin + ScanSingleLineComment(); + continue; + end + else if LA(1) = '*' then + begin + BeginComment(1); + repeat + GetNextChar; + + if IsEOF then + break; + + c := LA(0); + if ByteInSet(c, [10,13]) then + begin + Inc(LineCount); + GenSeparator; + if c = #13 then + GetNextChar; + end; + + if LA(1) = '*' then + begin + if Position + 1 >= BuffLength then + break + else if LA(2) = '/' then + begin + GetNextChar; + GetNextChar; + break; + end + end; + until false; + EndComment(2); + end + else + ScanSpecial; + end + else + RaiseError(errSyntaxError, []); + until Token.TokenClass <> tcNone; +end; + +procedure TJavaScriptScanner.ScanCustDir; +label + NextComment, Fin; +const + IdsSet = paxcomp_constants.IdsSet + [Ord('\'), Ord('/'), Ord('"')]; + Start1 = '@'; +var + S: String; + DirName: String; + ok: Boolean; +begin + DirName := ''; + + S := ''; + repeat + GetNextChar; + if ByteInSet(LA(0), [10,13]) then + begin + Inc(LineCount); + GenSeparator; + + if LA(0) = #13 then + GetNextChar; + end + else + S := S + LA(0); + until not ByteInSet(LA(0), IdsSet); + + + ScanChars(IdsSet + [Ord('.'), Ord('-'), Ord('['), Ord(']'), Ord('('), Ord(')'), + Ord(','), Ord('\'), Ord('/'), Ord('"'), Ord(' '), Ord(':')]); + + DirName := s + Token.Text; + + with TKernel(kernel) do + if Assigned(OnUnknownDirective) then + begin + ok := true; + OnUnknownDirective(Owner, DirName, ok); + if not ok then + Self.RaiseError(errInvalidCompilerDirective, [DirName]); + end; + + ScanChars(WhiteSpaces); + GenSeparator; +end; + + +procedure TJavaScriptScanner.ScanOctalLiteral; +var + c: Char; + V: array[1..30] of Integer; + L, P: Integer; +begin + L := 0; + while IsDigit(LA(1)) do + begin + c := GetNextChar; + if ByteInSet(c, [8,9]) then + RaiseError(errSyntaxError, []); + Inc(L); + V[L] := ord(c) - ord('0'); + end; + CustomInt64Val := 0; + if L > 0 then + begin + CustomInt64Val := V[L]; + P := 1; + while L > 1 do + begin + Dec(L); + P := P * 8; + CustomInt64Val := CustomInt64Val + P * V[L]; + end; + end; + Token.TokenClass := tcIntegerConst; + Token.Tag := 2; + SetScannerState(scanProg); +end; + +procedure TJavaScriptScanner.ScanHexLiteral; +var + c: Char; + V: array[1..30] of Integer; + L, P: Integer; +begin + GetNextChar; + L := 0; + while IsHexDigit(LA(1)) do + begin + c := GetNextChar; + Inc(L); + if IsDigit(c) then + V[L] := ord(c) - ord('0') + else + V[L] := ord(c) - ord('A') + 10 + end; + CustomInt64Val := 0; + if L > 0 then + begin + CustomInt64Val := V[L]; + P := 1; + while L > 1 do + begin + Dec(L); + P := P * 16; + CustomInt64Val := CustomInt64Val + P * V[L]; + end; + end; + Token.TokenClass := tcIntegerConst; + Token.Tag := 2; + SetScannerState(scanProg); +end; + +function TJavaScriptScanner.GetNextSpecialChar: Char; +var + c: Char; +begin + c := LA(1); + if ByteInSet(c, [Ord('u'),Ord('U')]) then + ScanHexLiteral + else if ByteInSet(c, [Ord('0')..Ord('7')]) then + ScanOctalLiteral + else if ByteInSet(c, [Ord(CHAR_AP), Ord(CHAR_DOUBLE_AP), Ord('\')]) then + begin + CustomInt64Val := Ord(c); + GetNextChar; + end + else if c = 'r' then + begin + CustomInt64Val := 13; + GetNextChar; + end + else if c = 'n' then + begin + CustomInt64Val := 10; + GetNextChar; + end + else if c = 't' then + begin + CustomInt64Val := 9; + GetNextChar; + end + else if c = 'f' then + begin + CustomInt64Val := 12; + GetNextChar; + end + else if c = 'b' then + begin + CustomInt64Val := 8; + GetNextChar; + end; + result := Char(CustomInt64Val); +end; + + +procedure TJavaScriptScanner.ScanStringLiteral(ch: Char); +var + c: Char; +begin + CustomStringVal := ''; + c := #0; + + repeat + if LA(1) = '\' then + begin + GetNextChar; + CustomStringVal := CustomStringVal + GetNextSpecialChar; + continue; + end + else + c := GetNextChar; + if IsEOF then + begin + RaiseError(errUnterminatedString, []); + Exit; + end; + if c = ch then + begin + break; + end + else + CustomStringVal := CustomStringVal + c + until false; + + Token.TokenClass := tcPCharConst; + Token.Tag := 2; + SetScannerState(scanProg); +end; + + +end. diff --git a/Sources/PAXCOMP_JavaScript.pas b/Sources/PAXCOMP_JavaScript.pas new file mode 100644 index 0000000..be1a4bf --- /dev/null +++ b/Sources/PAXCOMP_JavaScript.pas @@ -0,0 +1,6898 @@ +//////////////////////////////////////////////////////////////////////////// +// PaxCompiler +// Site: http://www.paxcompiler.com +// Author: Alexander Baranovsky (paxscript@gmail.com) +// ======================================================================== +// Copyright (c) Alexander Baranovsky, 2006-2014. All rights reserved. +// Code Version: 4.2 +// ======================================================================== +// Unit: PAXCOMP_JavaScript.pas +// ======================================================================== +//////////////////////////////////////////////////////////////////////////// + +{$I PaxCompiler.def} +{$O-} +{$Q-} +{$B-} +{$R-} +unit PAXCOMP_JavaScript; +interface + +{$IFNDEF LINUX} +{$IFDEF UNIX} // {just to compile PASCAL ONLY!} + +function GetVariantValue(Address: Pointer; FinTypeId: Integer): Variant; +procedure PutVariantValue(Address: Pointer; FinTypeId: Integer; const value: Variant); + +implementation +Uses + Variants, + PAXCOMP_SYS, + PAXCOMP_CONSTANTS; + +procedure _VariantFromClass(Dest: PVariant; + SourceAddress: Pointer); stdcall; +begin + VarClear(dest^); + with TVarData(dest^) do + begin + VType := varClass; + VInteger := IntPax(SourceAddress^); + end; +end; + +procedure _ClassFromVariant(DestAddress: Pointer; + Source: PVariant); stdcall; +var + V: Variant; +begin + if TVarData(source^).VType = varClass then + begin + TObject(DestAddress^) := TObject(TVarData(source^).VInteger); + (*if TObject(DestAddress^) is TJS_Reference then + begin + V := TJS_Reference(DestAddress^).GetValue(); + if TVarData(V).VType = varClass then + TObject(DestAddress^) := TObject(TVarData(V).VInteger) + else + TObject(DestAddress^) := nil; + end; *) + end + else + TObject(DestAddress^) := nil; +end; + +function GetVariantValue(Address: Pointer; FinTypeId: Integer): Variant; +begin + case FinTypeId of + typeBOOLEAN: result := Boolean(Address^); + typeBYTE: result := Byte(Address^); + typeWORD: result := Word(Address^); + typeINTEGER: result := Integer(Address^); + typeDOUBLE: result := Double(Address^); + typePOINTER: result := Integer(Address^); + typeENUM: result := Byte(Address^); + typePROC: result := Integer(Address^); +{$IFNDEF PAXARM} + typeANSICHAR: result := AnsiChar(Address^); + typeANSISTRING: result := AnsiString(Address^); + typeSHORTSTRING: result := ShortString(Address^); + typeWIDESTRING: result := WideString(Address^); +{$ENDIF} + typeSINGLE: result := Single(Address^); + typeEXTENDED: result := Extended(Address^); + typeCLASS: + begin + _VariantFromClass(@result, Address); + end; + typeCLASSREF: result := Integer(Address^); + typeWIDECHAR: result := WideChar(Address^); + typeVARIANT: result := Variant(Address^); + typeDYNARRAY: result := Integer(Address^); +{$IFDEF VARIANTS} + typeEVENT: result := Int64(Address^); + typeINT64: result := Int64(Address^); +{$ELSE} + typeINT64: result := Integer(Address^); +{$ENDIF} + typeINTERFACE: result := Integer(Address^); + typeCARDINAL: result := Cardinal(Address^); + typeCURRENCY: result := Currency(Address^); + typeSMALLINT: result := SmallInt(Address^); + typeSHORTINT: result := ShortInt(Address^); + typeWORDBOOL: result := WordBool(Address^); + typeLONGBOOL: result := LongBool(Address^); + typeBYTEBOOL: result := ByteBool(Address^); + typeOLEVARIANT: result := OleVariant(Address^); + typeUNICSTRING: result := UnicString(Address^); + end; +end; + +procedure PutVariantValue(Address: Pointer; FinTypeId: Integer; const value: Variant); +var + X, Y: TObject; +begin + case FinTypeId of + typeBOOLEAN: Boolean(Address^) := value; + typeBYTE: Byte(Address^) := value; + typeWORD: Word(Address^) := value; + typeINTEGER: Integer(Address^) := value; + typeDOUBLE: Double(Address^) := value; + typePOINTER: Integer(Address^) := value; + typeENUM: Byte(Address^) := value; + typePROC: Integer(Address^) := value; +{$IFNDEF PAXARM} + typeSHORTSTRING: ShortString(Address^) := ShortString(value); + typeANSICHAR: AnsiChar(Address^) := AnsiChar(Byte(value)); + typeANSISTRING: AnsiString(Address^) := AnsiString(value); + typeWIDESTRING: WideString(Address^) := value; +{$ENDIF} + typeSINGLE: Single(Address^) := value; + typeEXTENDED: Extended(Address^) := value; + typeCLASS: + begin + X := TObject(Address^); + _ClassFromVariant(@Y, @value); + if Y = nil then + begin + if X = nil then + Exit; + //if X is TJS_Object then + //else + TObject(Address^) := nil; + Exit; + end; + //if (X is TJS_Object) and (Y is TGC_Object) then + // GC_Assign(PGC_Object(Address), TGC_Object(Y)) + //else + TObject(Address^) := Y; + end; + typeCLASSREF: Integer(Address^) := value; + typeWIDECHAR: WideChar(Address^) := WideChar(Word(value)); + typeVARIANT: Variant(Address^) := value; + typeDYNARRAY: Integer(Address^) := value; +{$IFDEF VARIANTS} + typeINT64: Int64(Address^) := value; + typeEVENT: Int64(Address^) := value; +{$ELSE} + typeINT64: Integer(Address^) := value; +{$ENDIF} + typeINTERFACE: Integer(Address^) := value; + typeCARDINAL: Cardinal(Address^) := value; + typeCURRENCY: Currency(Address^) := value; + typeSMALLINT: SmallInt(Address^) := value; + typeSHORTINT: ShortInt(Address^) := value; + typeWORDBOOL: WordBool(Address^) := value; + typeLONGBOOL: LongBool(Address^) := value; +{$IFDEF FPC} + typeBYTEBOOL: + if value <> 0 then + ByteBool(Address^) := true + else + ByteBool(Address^) := false; +{$ELSE} + typeBYTEBOOL: ByteBool(Address^) := value; +{$ENDIF} + typeOLEVARIANT: OleVariant(Address^) := value; + typeUNICSTRING: UnicString(Address^) := value; + end; +end; +end. +{$ENDIF} // ndef linux +{$ENDIF} // ndef unix + +uses {$I uses.def} + SysUtils, + Classes, + Math, + RegExpr2, + PAXCOMP_CONSTANTS, + PAXCOMP_TYPES, + PAXCOMP_SYS, + PAXCOMP_STDLIB, + PAXCOMP_GC, + PAXCOMP_BASERUNNER, + PAXCOMP_BASESYMBOL_TABLE; + +const + Delta = 100; + + TYP_JS_OBJECT = 1; + TYP_JS_DATE = 2; + TYP_JS_ARRAY = 3; + TYP_JS_BOOLEAN = 4; + TYP_JS_NUMBER = 5; + TYP_JS_STRING = 6; + TYP_JS_FUNCTION = 7; + TYP_JS_MATH = 8; + TYP_JS_REGEXP = 9; + TYP_JS_ERROR = 10; + + MaxPrimes = 2; + Primes: array[1..MaxPrimes] of Integer = (103, 199); + +var + MaxArgs: Variant; +{$IFDEF PAX64} + RetAdr_OFFSET: IntPax = 0; + ParArr_OFFSET: IntPax = 0; +{$ENDIF} + +type + TJS_Object = class; + + THashFunction = function (S : PChar; TableSize: Integer) : longint; + + TJS_PropRec = class + public + Key: PChar; + Value: Variant; + end; + + THashTable = class + private + PrimeIndex: Integer; + MaxCard: Integer; + A: array of TJS_PropRec; + public + HashFunction: THashFunction; + TableSize: Integer; + LastIndex: Integer; + Card: Integer; + constructor Create; + destructor Destroy; override; + procedure Clear; + function IndexOf(const S: PChar; var I: Integer): Boolean; + end; + + TJS_PropList = class + private + Owner: TJS_Object; + HashTable: THashTable; + Arr: array of Variant; + AvailArrIndex: array of boolean; + CardArr: Integer; + LastPropAddress: PVariant; + public + constructor Create(i_Owner: TJS_Object); + destructor Destroy; override; + procedure Clear; + + function IndexOfProperty(PropName: PChar; var I: Integer; + var PositiveInt: Boolean): Boolean; + + procedure SetArrLength(N: Integer); + function GetArrProperty(PropName: Integer): PVariant; + procedure PutArrProperty(PropName: Integer; const Value: Variant); + + function GetProperty(PropName: PChar): PVariant; + procedure PutProperty(PropName: PChar; const Value: Variant); + function HasProperty(PropName: PChar): Boolean; + end; + + TJS_ObjectBase = class(TGC_Object) + public + function GetGC: TGC; override; + end; + + TJS_Object = class(TJS_ObjectBase) + private + L: TJS_PropList; + fLength: Integer; + fDefaultValue: Variant; + aconstructor: TJS_Object; + Tag: Integer; + NextPropIndex: Integer; + public + typ: Integer; + prototype: TJS_Object; + prog: TBaseRunner; + function GetConstructor: TJS_Object; + function HasProperty(PropName: PChar): Boolean; + procedure PutProperty(PropName: PChar; const Value: Variant); + function GetProperty(PropName: PChar): Variant; + function GetPropertyAsObject(PropName: PChar): TJS_Object; + procedure PutArrProperty(PropName: Integer; const Value: Variant); + function GetArrProperty(PropName: Integer): Variant; + function GetVarProperty(const PropName: Variant): Variant; + procedure PutVarProperty(const PropName: Variant; const Value: Variant); + procedure AddToGC; + constructor Create; + destructor Destroy; override; + function GetGC: TGC; override; + function __toString: String; override; + property Prop[PropertyName: PChar]: Variant read GetProperty + write PutProperty; default; + end; + + TJS_Reference = class(TJS_ObjectBase) + public + Address: Pointer; + FinTypeId: Integer; + constructor Create(AFinTypeId: Integer); + function GetValue(): Variant; + function GetValueAsObject(): TJS_Object; + procedure PutValue(const value: Variant); + function __toString: String; override; + end; + + TJS_Date = class(TJS_Object) + private + DelphiDate: TDateTime; + function GetValue: Variant; + function UTCDelphiDate: TDateTime; + function DelphiDateFromUTCDate(D: TDateTime): TDateTime; + public + property Value: Variant read GetValue; + constructor Create(Year: PVariant = nil; + Month: PVariant = nil; + Day: PVariant = nil; + Hours: PVariant = nil; + Minutes: PVariant = nil; + Seconds: PVariant = nil; + Ms: PVariant = nil); + function toGMTString: Variant; stdcall; + function getTime: Variant; stdcall; + function getFullYear: Variant; stdcall; + function getUTCFullYear: Variant; stdcall; + function getMonth: Variant; stdcall; + function getUTCMonth: Variant; stdcall; + function getDate: Variant; stdcall; + function getUTCDate: Variant; stdcall; + function getDay: Variant; stdcall; + function getUTCDay: Variant; stdcall; + function getHours: Variant; stdcall; + function getUTCHours: Variant; stdcall; + function getMinutes: Variant; stdcall; + function getUTCMinutes: Variant; stdcall; + function getSeconds: Variant; stdcall; + function getUTCSeconds: Variant; stdcall; + function getMilliseconds: Variant; stdcall; + function getUTCMilliseconds: Variant; stdcall; + function setTime(const P: Variant): Variant; stdcall; + function setMilliseconds(const ms: Variant): Variant; stdcall; + function setUTCMilliseconds(const ms: Variant): Variant; stdcall; + function setSeconds(const sec, ms: Variant): Variant; stdcall; + function setUTCSeconds(const sec, ms: Variant): Variant; stdcall; + function setMinutes(const min, sec, ms: Variant): Variant; stdcall; + function setUTCMinutes(const min, sec, ms: Variant): Variant; stdcall; + function setHours(const hour, min, sec, ms: Variant): Variant; stdcall; + + function setUTCHours(const hour, min, sec, ms: Variant): Variant; stdcall; + function setDate(const date: Variant): Variant; stdcall; + function _toString: Variant; stdcall; + function __toString: String; override; + end; + + TJS_Array = class(TJS_Object) + private + function GetLength: Integer; + procedure SetLength(value: Integer); + public + constructor Create(const V: array of Variant); + destructor Destroy; override; + function _toString: Variant; stdcall; + function __toString: String; override; + function _pop: Variant; stdcall; + function _push(P0: PVariant; + P1: PVariant = nil; + P2: PVariant = nil; + P3: PVariant = nil; + P4: PVariant = nil; + P5: PVariant = nil; + P6: PVariant = nil; + P7: PVariant = nil; + P8: PVariant = nil; + P9: PVariant = nil): Variant; stdcall; + property Length: Integer read GetLength write SetLength; + end; + + TJS_Boolean = class(TJS_Object) + constructor Create(P: PVariant = nil); + function _toString: Variant; stdcall; + function __toString: String; override; + end; + + TJS_Number = class(TJS_Object) + constructor Create(P: PVariant = nil); + function _toString(): Variant; stdcall; + function __toString: String; override; + end; + + TJS_String = class(TJS_Object) + constructor Create(P: PVariant = nil); + function _toString: Variant; stdcall; + function __toString: String; override; + function _valueOf: Variant; stdcall; + function _length: Variant; stdcall; + function _charAt(const P: Variant): Variant; stdcall; + function _charCodeAt(const P: Variant): Variant; stdcall; + function _concat(P0: PVariant; + P1: PVariant = nil; + P2: PVariant = nil; + P3: PVariant = nil; + P4: PVariant = nil; + P5: PVariant = nil; + P6: PVariant = nil; + P7: PVariant = nil; + P8: PVariant = nil; + P9: PVariant = nil): Variant; stdcall; + function _fromCharCode(P0: PVariant; + P1: PVariant = nil; + P2: PVariant = nil; + P3: PVariant = nil; + P4: PVariant = nil; + P5: PVariant = nil; + P6: PVariant = nil; + P7: PVariant = nil; + P8: PVariant = nil; + P9: PVariant = nil): Variant; stdcall; + function _slice(const VStart, VEnd: Variant): Variant; stdcall; + function _substr(const VStart, VLength: Variant): Variant; stdcall; + function _substring(const VStart, VLength: Variant): Variant; stdcall; + function _indexOf(const P: Variant): Variant; stdcall; + function _lastIndexOf(const P: Variant): Variant; stdcall; + function _anchor(const P: Variant): Variant; stdcall; + function _link(const P: Variant): Variant; stdcall; + function _big: Variant; stdcall; + function _small: Variant; stdcall; + function _blink: Variant; stdcall; + function _bold: Variant; stdcall; + function _italics: Variant; stdcall; + function _strike: Variant; stdcall; + function _sub: Variant; stdcall; + function _sup: Variant; stdcall; + function _fixed: Variant; stdcall; + function _fontcolor(const P: Variant): Variant; stdcall; + function _fontsize(const P: Variant): Variant; stdcall; + function _toUpperCase: Variant; stdcall; + function _toLowerCase: Variant; stdcall; + function _replace(const SearchValue, ReplaceValue: Variant): Variant; stdcall; + end; + + TJS_Function = class(TJS_Object) + private +// DataPtr: Pointer; +// CodePtr: Pointer; + CoolCall: Integer; + DefaultNP: Integer; + public + InternalFuncAddr: Pointer; + arguments: TJS_Array; + InternalLength: Integer; + __this: TObject; +{$IFDEF PAX64} + private + ParArr: Pointer; + RetAdr: Pointer; + procedure InternalCall2(NP: Integer); + public +{$ENDIF} + constructor InternalCreate(i_InternalFuncAddr: Pointer; + i_NP: Integer; + i_ProgPtr: Pointer); + destructor Destroy; override; + function InternalCall(NP: Integer): Variant; stdcall; + function Invoke(const Params: array of Variant): Variant; stdcall; + function _toString: Variant; stdcall; + function __toString: String; override; + end; + + TJS_Math = class(TJS_Object) + public + constructor Create; + function _abs(const P: Variant): Variant; stdcall; + function _acos(const P: Variant): Variant; stdcall; + function _asin(const P: Variant): Variant; stdcall; + function _atan(const P: Variant): Variant; stdcall; + function _atan2(const X, Y: Variant): Variant; stdcall; + function _ceil(const P: Variant): Variant; stdcall; + function _cos(const P: Variant): Variant; stdcall; + function _exp(const P: Variant): Variant; stdcall; + function _floor(const P: Variant): Variant; stdcall; + function _log(const P: Variant): Variant; stdcall; + function _max(P1, P2, P3, P4, P5: PVariant): Variant; stdcall; + function _min(P1, P2, P3, P4, P5: PVariant): Variant; stdcall; + function _pow(const X, Y: Variant): Variant; stdcall; + function _random: Variant; stdcall; + function _round(const P: Variant): Variant; stdcall; + function _sin(const P: Variant): Variant; stdcall; + function _sqrt(const P: Variant): Variant; stdcall; + function _tan(const P: Variant): Variant; stdcall; + end; + + TJS_RegExp = class(TJS_Object) + private + fLastIndex: Integer; +{$IFNDEF PAXARM} + fRegExpr: TRegExpr; + fZERO_BASED_STRINGS: Boolean; +{$ENDIF} + function GetMatch(I: Integer): String; + function GetMatchLen(I: Integer): Integer; + function GetMatchPos(I: Integer): Integer; + function GetSource: Variant; + procedure SetSource(const Value: Variant); + function GetInput: Variant; + procedure SetInput(const Value: Variant); + function GetGlobal: Boolean; + procedure SetGlobal(const Value: Boolean); + function GetIgnoreCase: Boolean; + procedure SetIgnoreCase(const Value: Boolean); + function GetMultiLine: Boolean; + procedure SetMultiLine(const Value: Boolean); + public + constructor Create(Source: PVariant = nil; Modifiers: PVariant = nil); + destructor Destroy; override; + function Test(const InputString: Variant): Boolean; + procedure Compile; + function MatchCount: Integer; + function Exec(const InputString: Variant): TJS_Array; + function Execute(const InputString: Variant): TJS_Array; + function Replace(const Expression, ReplaceStr: Variant): String; + function _toString: Variant; stdcall; + function __toString: String; override; + published + property global: Boolean read GetGlobal write SetGlobal; + property ignoreCase: Boolean read GetIgnoreCase write SetIgnoreCase; + property multiLine: Boolean read GetMultiLine write SetMultiLine; + property lastIndex: Integer read fLastIndex write fLastIndex; + property source: Variant read GetSource write SetSource; + property input: Variant read GetInput write SetInput; + end; + + TJS_Error = class(TJS_Object) + constructor Create(P: PVariant = nil); + function _toString: Variant; stdcall; + function __toString: String; override; + end; + +procedure Register_StdJavaScript(st: TBaseSymbolTable); +function IsDateObject(const V: Variant): Boolean; +function VariantToDateObject(const V: Variant): TJS_Date; +function JS_IsObject(const V: Variant): Boolean; +function JS_IsPointer(const V: Variant): Boolean; +function JS_IsRef(const V: Variant): Boolean; +function JS_IsString(const V: Variant): Boolean; +function JS_IsBoolean(const V: Variant): Boolean; +function JS_IsUndefined(const V: Variant): Boolean; +function JS_GetValue(const V: Variant): Variant; +procedure JS_PutValue(const V: Variant; const value: Variant); +function JS_ToPrimitive(const V: Variant): Variant; +function JS_ToString(const V: Variant): Variant; +function JS_ToBoolean(const V: Variant): Variant; +function JS_ToNumber(const V: Variant): Variant; +function JS_ToNumberE(const V: Variant): Extended; +function JS_ToInt32(const V: Variant): Variant; +function JS_IsSimpleNumber(const V: Variant): Boolean; +function JS_IsNumber(const V: Variant): Boolean; +function JS_RelationalComparison(const V1, V2: Variant): Variant; + //performs x < y comparison +function JS_EqualityComparison(const V1, V2: Variant): Boolean; + +procedure _VariantFromClass(Dest: PVariant; + SourceAddress: Pointer); stdcall; +procedure _VariantFromPointer(Dest: PVariant; + SourceAddress: Pointer); stdcall; +procedure _ClassFromVariant(DestAddress: Pointer; + Source: PVariant); stdcall; +function GetVariantValue(Address: Pointer; FinTypeId: Integer): Variant; +procedure PutVariantValue(Address: Pointer; FinTypeId: Integer; const value: Variant); +procedure _JS_ToObject(P:TBaseRunner; + Address: Pointer; + FinTypeId: Integer; + result: PVariant); stdcall; +procedure _AssignProg(X: TJS_Object; P: TBaseRunner); stdcall; +procedure _JS_GetNextProp(VObject: PVariant; + Prop: PString; + result: PBoolean); stdcall; +procedure _ClearReferences(P: TBaseRunner); stdcall; +procedure _ClassClr(Address: Pointer); stdcall; +procedure _FuncObjFromVariant(source: PVariant; DestAddress: Pointer); stdcall; +procedure _JS_TypeOf(V: PVariant; + result: PString); stdcall; +procedure _PushContext(P: TBaseRunner; value: PVariant); stdcall; +procedure _PopContext(P: TBaseRunner); stdcall; +procedure _FindContext(P: TBaseRunner; PropName: PChar; + AltAddress: Pointer; + FinTypeId: Integer; + result: PVariant); stdcall; +procedure _FindFunc(P: TBaseRunner; PropName: PChar; + Alt, result: PVariant); stdcall; + +{$IFNDEF PAXARM} +procedure _VariantFromPAnsiChar(source: PAnsiChar; dest: PVariant); stdcall; +procedure _VariantFromAnsiString(Dest: PVariant; Source: PAnsiString); stdcall; +procedure _VariantFromWideString(Dest: PVariant; Source: PWideString); stdcall; +procedure _VariantFromAnsiChar(source: AnsiChar; dest: PVariant); stdcall; +{$ENDIF} +procedure _VariantFromPWideChar(source: PWideChar; dest: PVariant); stdcall; +procedure _VariantFromInterface(const source: IDispatch; dest: PVariant); stdcall; +procedure _VariantFromShortString(Dest: PVariant; Source: PShortString); stdcall; +procedure _VariantFromUnicString(Dest: PVariant; Source: PUnicString); stdcall; +procedure _VariantFromWideChar(source: WideChar; dest: PVariant); stdcall; +procedure _VariantFromInt(source: Integer; dest: PVariant); stdcall; +procedure _VariantFromInt64(dest: PVariant; source: PInt64); stdcall; +procedure _VariantFromByte(source: Byte; dest: PVariant); stdcall; +procedure _VariantFromBool(source: Boolean; dest: PVariant); stdcall; +procedure _VariantFromWord(source: Word; dest: PVariant); stdcall; +procedure _VariantFromCardinal(source: Cardinal; dest: PVariant); stdcall; +procedure _VariantFromSmallInt(source: SmallInt; dest: PVariant); stdcall; +procedure _VariantFromShortInt(source: ShortInt; dest: PVariant); stdcall; +procedure _VariantFromDouble(dest: PVariant; source: PDouble); stdcall; +procedure _VariantFromCurrency(dest: PVariant; source: PCurrency); stdcall; +procedure _VariantFromSingle(dest: PVariant; source: PSingle); stdcall; +procedure _VariantFromExtended(dest: PVariant; source: PExtended); stdcall; +procedure _VariantAssign(dest, source: PVariant); stdcall; +procedure _VariantAddition(Language: Integer; + v1, v2, dest: PVariant); stdcall; +procedure _VariantSubtraction(Language: Integer; + v1, v2, dest: PVariant); stdcall; +procedure _VariantMultiplication(Language: Integer; + v1, v2, dest: PVariant); stdcall; +procedure _VariantDivision(Language: Integer; + v1, v2, dest: PVariant); stdcall; +procedure _VariantIDivision(Language: Integer; + v1, v2, dest: PVariant); stdcall; +procedure _VariantModulo(Language: Integer; + v1, v2, dest: PVariant); stdcall; +procedure _VariantLeftShift(Language: Integer; + v1, v2, dest: PVariant); stdcall; +procedure _VariantRightShift(Language: Integer; + v1, v2, dest: PVariant); stdcall; +procedure _VariantAnd(Language: Integer; + v1, v2, dest: PVariant); stdcall; +procedure _VariantOr(Language: Integer; + v1, v2, dest: PVariant); stdcall; +procedure _VariantXor(Language: Integer; + v1, v2, dest: PVariant); stdcall; +procedure _VariantLessThan(Language: Integer; + v1, v2: PVariant; dest: PBoolean); stdcall; +procedure _VariantLessThanOrEqual(Language: Integer; + v1, v2: PVariant; dest: PBoolean); stdcall; +procedure _VariantGreaterThan(Language: Integer; + v1, v2: PVariant; dest: PBoolean); stdcall; +procedure _VariantGreaterThanOrEqual(Language: Integer; + v1, v2: PVariant; dest: PBoolean); stdcall; +procedure _VariantEquality(Language: Integer; + v1, v2: PVariant; dest: PBoolean); stdcall; +procedure _VariantNotEquality(Language: Integer; + v1, v2: PVariant; dest: PBoolean); stdcall; +procedure _ClassAssign(dest, source: PObject); stdcall; +procedure _alert(Prog: TBaseRunner; + P1: PVariant; + P2: PVariant = nil; + P3: PVariant = nil; + P4: PVariant = nil; + P5: PVariant = nil); stdcall; + +var + VarIntTypes: set of byte; + +implementation + +{$IFDEF PAX64} +procedure Push_And_Call(NP: Integer; Instance, Params, RetAdr: Pointer); forward; +procedure AssignRBX(P: Pointer); forward; +{$ENDIF} + +const + varEmpty = $0000; { vt_empty 0 } + varNull = $0001; { vt_null 1 } + varSmallint = $0002; { vt_i2 2 } + varInteger = $0003; { vt_i4 3 } + varSingle = $0004; { vt_r4 4 } + varDouble = $0005; { vt_r8 5 } + varCurrency = $0006; { vt_cy 6 } + varDate = $0007; { vt_date 7 } + varOleStr = $0008; { vt_bstr 8 } + varDispatch = $0009; { vt_dispatch 9 } + varError = $000A; { vt_error 10 } + varBoolean = $000B; { vt_bool 11 } + varVariant = $000C; { vt_variant 12 } + varUnknown = $000D; { vt_unknown 13 } +//varDecimal = $000E; { vt_decimal 14 } {UNSUPPORTED as of v6.x code base} +//varUndef0F = $000F; { undefined 15 } {UNSUPPORTED per Microsoft} + varShortInt = $0010; { vt_i1 16 } + varByte = $0011; { vt_ui1 17 } + varWord = $0012; { vt_ui2 18 } + varLongWord = $0013; { vt_ui4 19 } + varInt64 = $0014; { vt_i8 20 } +//varWord64 = $0015; { vt_ui8 21 } {UNSUPPORTED as of v6.x code base} +{ if adding new items, update Variants' varLast, BaseTypeMap and OpTypeMap } + + varStrArg = $0048; { vt_clsid 72 } + varString = $0100; { Pascal string 256 } {not OLE compatible } + varAny = $0101; { Corba any 257 } {not OLE compatible } + varUString = $0102; { Unicode string 258 } {not OLE compatible} + +// + varUndefined = varEmpty; + +var + Undefined: Variant; + +var + EmptyFunction: TJS_Function; + +procedure RaiseError(const Message: string; params: array of Const); +begin + raise PaxCompilerException.Create(Format(Message, params)); +end; + +{$IFNDEF VARIANTS} + +function StrToFloatDef(const S: string; const Default: Extended): Extended; +begin + if not TextToFloat(PChar(S), Result, fvExtended) then + Result := Default; +end; + +function IsNan(const AValue: Single): Boolean; overload; +begin + Result := ((PLongWord(@AValue)^ and $7F800000) = $7F800000) and + ((PLongWord(@AValue)^ and $007FFFFF) <> $00000000); +end; + +function IsNan(const AValue: Double): Boolean; overload; +begin + Result := ((PInt64(@AValue)^ and $7FF0000000000000) = $7FF0000000000000) and + ((PInt64(@AValue)^ and $000FFFFFFFFFFFFF) <> $0000000000000000); +end; + +function IsNan(const AValue: Extended): Boolean; overload; +type + TExtented = packed record + Mantissa: Int64; + Exponent: Word; + end; + PExtended = ^TExtented; +begin + Result := ((PExtended(@AValue)^.Exponent and $7FFF) = $7FFF) and + ((PExtended(@AValue)^.Mantissa and $7FFFFFFFFFFFFFFF) <> 0); +end; + +function IsInfinite(const AValue: Double): Boolean; +begin + Result := ((PInt64(@AValue)^ and $7FF0000000000000) = $7FF0000000000000) and + ((PInt64(@AValue)^ and $000FFFFFFFFFFFFF) = $0000000000000000); +end; +{$ENDIF} + +function VarFromClass(Source: TJS_ObjectBase): Variant; +begin + TVarData(result).VInteger := Integer(Source); + TVarData(result).VType := varClass; +end; + +procedure Create_DateObject(P: TBaseRunner; R: TJS_Record); +var + X: TJS_Object; +begin + P.JS_Date := TJS_Date.Create; + P.SetAddress(P.GetOffset(R.H_JS_Date), @P.JS_Date); + + X := P.JS_Date as TJS_Object; + X.prog := P; + X.aconstructor := X; + X.Tag := 1; + X.AddToGC; + + X.prototype := TJS_Date.Create; + with X.prototype do + begin + aconstructor := X; + prog := P; + AddToGC; + + PutProperty('toString', VarFromClass( + TJS_Function.InternalCreate(@TJS_Date._toString, 0, @P))); + + PutProperty('toGMTString', VarFromClass( + TJS_Function.InternalCreate(@TJS_Date.toGMTString, 0, @P))); + + PutProperty('getTime', VarFromClass( + TJS_Function.InternalCreate(@TJS_Date.getTime, 0, @P))); + + PutProperty('getFullYear', VarFromClass( + TJS_Function.InternalCreate(@TJS_Date.getFullYear, 0, @P))); + + PutProperty('getUTCFullYear', VarFromClass( + TJS_Function.InternalCreate(@TJS_Date.getUTCFullYear, 0, @P))); + + PutProperty('getMonth', VarFromClass( + TJS_Function.InternalCreate(@TJS_Date.getMonth, 0, @P))); + + PutProperty('getUTCMonth', VarFromClass( + TJS_Function.InternalCreate(@TJS_Date.getUTCMonth, 0, @P))); + + PutProperty('getDate', VarFromClass( + TJS_Function.InternalCreate(@TJS_Date.getDate, 0, @P))); + + PutProperty('getUTCDate', VarFromClass( + TJS_Function.InternalCreate(@TJS_Date.getUTCDate, 0, @P))); + + PutProperty('getDay', VarFromClass( + TJS_Function.InternalCreate(@TJS_Date.getDay, 0, @P))); + + PutProperty('getUTCDay', VarFromClass( + TJS_Function.InternalCreate(@TJS_Date.getUTCDay, 0, @P))); + + PutProperty('getHours', VarFromClass( + TJS_Function.InternalCreate(@TJS_Date.getHours, 0, @P))); + + PutProperty('getUTCHours', VarFromClass( + TJS_Function.InternalCreate(@TJS_Date.getUTCHours, 0, @P))); + + PutProperty('getMinutes', VarFromClass( + TJS_Function.InternalCreate(@TJS_Date.getMinutes, 0, @P))); + + PutProperty('getUTCMinutes', VarFromClass( + TJS_Function.InternalCreate(@TJS_Date.getUTCMinutes, 0, @P))); + + PutProperty('getSeconds', VarFromClass( + TJS_Function.InternalCreate(@TJS_Date.getSeconds, 0, @P))); + + PutProperty('getUTCSeconds', VarFromClass( + TJS_Function.InternalCreate(@TJS_Date.getUTCSeconds, 0, @P))); + + PutProperty('getMilliseconds', VarFromClass( + TJS_Function.InternalCreate(@TJS_Date.getMilliseconds, 0, @P))); + + PutProperty('getUTCMilliseconds', VarFromClass( + TJS_Function.InternalCreate(@TJS_Date.getUTCMilliseconds, 0, @P))); + + PutProperty('setTime', VarFromClass( + TJS_Function.InternalCreate(@TJS_Date.setTime, 1, @P))); + + PutProperty('setMilliseconds', VarFromClass( + TJS_Function.InternalCreate(@TJS_Date.setMilliseconds, 1, @P))); + + PutProperty('setUTCMilliseconds', VarFromClass( + TJS_Function.InternalCreate(@TJS_Date.setUTCMilliseconds, 1, @P))); + + PutProperty('setSeconds', VarFromClass( + TJS_Function.InternalCreate(@TJS_Date.setSeconds, 2, @P))); + + PutProperty('setUTCSeconds', VarFromClass( + TJS_Function.InternalCreate(@TJS_Date.setUTCSeconds, 2, @P))); + + PutProperty('setMinutes', VarFromClass( + TJS_Function.InternalCreate(@TJS_Date.setMinutes, 3, @P))); + + PutProperty('setUTCMinutes', VarFromClass( + TJS_Function.InternalCreate(@TJS_Date.setUTCSeconds, 3, @P))); + + PutProperty('setHours', VarFromClass( + TJS_Function.InternalCreate(@TJS_Date.setHours, 4, @P))); + + PutProperty('setUTCHours', VarFromClass( + TJS_Function.InternalCreate(@TJS_Date.setUTCHours, 4, @P))); + end; +end; + +procedure Create_BooleanObject(P: TBaseRunner; R: TJS_Record); +var + X: TJS_Object; +begin + P.JS_Boolean := TJS_Boolean.Create; + X := P.JS_Boolean as TJS_Object; + X.prog := P; + X.aconstructor := X; + X.Tag := 1; + X.AddToGC; + + X.prototype := TJS_Object.Create; + X.prototype.aconstructor := X; + X.prototype.prog := P; + X.prototype.AddToGC; + + P.SetAddress(P.GetOffset(R.H_JS_Boolean), @P.JS_Boolean); +end; + +procedure Create_ErrorObject(P: TBaseRunner; R: TJS_Record); +var + X: TJS_Object; +begin + P.JS_Error := TJS_Error.Create; + X := P.JS_Error as TJS_Object; + X.prog := P; + X.aconstructor := X; + X.Tag := 1; + X.AddToGC; + + X.prototype := TJS_Object.Create; + X.prototype.aconstructor := X; + X.prototype.prog := P; + X.prototype.AddToGC; + + P.SetAddress(P.GetOffset(R.H_JS_Error), @P.JS_Error); +end; + +procedure Create_NumberObject(P: TBaseRunner; R: TJS_Record); +var + X: TJS_Object; +begin + P.JS_Number := TJS_Number.Create; + X := P.JS_Number as TJS_Object; + X.prog := P; + X.aconstructor := X; + X.Tag := 1; + X.AddToGC; + + X.prototype := TJS_Object.Create; + X.prototype.aconstructor := X; + X.prototype.prog := P; + X.prototype.AddToGC; + + P.SetAddress(P.GetOffset(R.H_JS_Number), @P.JS_Number); + + with X.prototype do + begin + aconstructor := X; + prog := P; + + PutProperty('toString', VarFromClass( + TJS_Function.InternalCreate(@TJS_Function._toString, 0, @P))); + end; +end; + +procedure Create_StringObject(P: TBaseRunner; R: TJS_Record); +var + X: TJS_Object; + F: TJS_Function; +begin + P.JS_String := TJS_String.Create; + X := P.JS_String as TJS_Object; + X.prog := P; + X.aconstructor := X; + X.Tag := 1; + X.AddToGC; + + X.prototype := TJS_Object.Create; + X.prototype.aconstructor := X; + X.prototype.prog := P; + X.prototype.AddToGC; + + P.SetAddress(P.GetOffset(R.H_JS_String), @P.JS_String); + + with X.prototype do + begin + aconstructor := X; + prog := P; + + PutProperty('toString', VarFromClass( + TJS_Function.InternalCreate(@TJS_String._toString, 0, @P))); + PutProperty('valueOf', VarFromClass( + TJS_Function.InternalCreate(@TJS_String._valueOf, 0, @P))); + PutProperty('charAt', VarFromClass( + TJS_Function.InternalCreate(@TJS_String._charAt, 1, @P))); + PutProperty('charCodeAt', VarFromClass( + TJS_Function.InternalCreate(@TJS_String._charCodeAt, 1, @P))); + + F := TJS_Function.InternalCreate(@TJS_String._concat, 1, @P); + F.DefaultNP := 10; + PutProperty('concat', VarFromClass(F)); + + F := TJS_Function.InternalCreate(@TJS_String._fromCharCode, 1, @P); + F.DefaultNP := 10; + PutProperty('fromCharCode', VarFromClass(F)); + + PutProperty('length', VarFromClass( + TJS_Function.InternalCreate(@TJS_String._length, 0, @P))); + PutProperty('indexOf', VarFromClass( + TJS_Function.InternalCreate(@TJS_String._indexOf, 1, @P))); + PutProperty('lastIndexOf', VarFromClass( + TJS_Function.InternalCreate(@TJS_String._lastIndexOf, 1, @P))); + PutProperty('slice', VarFromClass( + TJS_Function.InternalCreate(@TJS_String._slice, 2, @P))); + PutProperty('substr', VarFromClass( + TJS_Function.InternalCreate(@TJS_String._substr, 2, @P))); + PutProperty('substring', VarFromClass( + TJS_Function.InternalCreate(@TJS_String._substring, 2, @P))); + PutProperty('anchor', VarFromClass( + TJS_Function.InternalCreate(@TJS_String._anchor, 1, @P))); + PutProperty('link', VarFromClass( + TJS_Function.InternalCreate(@TJS_String._link, 1, @P))); + PutProperty('big', VarFromClass( + TJS_Function.InternalCreate(@TJS_String._big, 0, @P))); + PutProperty('small', VarFromClass( + TJS_Function.InternalCreate(@TJS_String._small, 0, @P))); + PutProperty('blink', VarFromClass( + TJS_Function.InternalCreate(@TJS_String._blink, 0, @P))); + PutProperty('bold', VarFromClass( + TJS_Function.InternalCreate(@TJS_String._bold, 0, @P))); + PutProperty('italics', VarFromClass( + TJS_Function.InternalCreate(@TJS_String._italics, 0, @P))); + PutProperty('strike', VarFromClass( + TJS_Function.InternalCreate(@TJS_String._strike, 0, @P))); + PutProperty('sub', VarFromClass( + TJS_Function.InternalCreate(@TJS_String._sub, 0, @P))); + PutProperty('sup', VarFromClass( + TJS_Function.InternalCreate(@TJS_String._sup, 0, @P))); + PutProperty('fixed', VarFromClass( + TJS_Function.InternalCreate(@TJS_String._fixed, 0, @P))); + PutProperty('fontcolor', VarFromClass( + TJS_Function.InternalCreate(@TJS_String._fontcolor, 1, @P))); + PutProperty('fontsize', VarFromClass( + TJS_Function.InternalCreate(@TJS_String._fontsize, 1, @P))); + PutProperty('toUpperCase', VarFromClass( + TJS_Function.InternalCreate(@TJS_String._toUpperCase, 0, @P))); + PutProperty('toLowerCase', VarFromClass( + TJS_Function.InternalCreate(@TJS_String._toLowerCase, 0, @P))); + PutProperty('replace', VarFromClass( + TJS_Function.InternalCreate(@TJS_String._replace, 2, @P))); + end; +end; + +procedure Create_ArrayObject(P: TBaseRunner; R: TJS_Record); +var + X: TJS_Object; + F: TJS_Function; +begin + P.JS_Array := TJS_Array.Create([]); + X := P.JS_Array as TJS_Object; + X.prog := P; + X.aconstructor := X; + X.Tag := 1; + X.AddToGC; + + X.prototype := TJS_Object.Create; + X.prototype.aconstructor := X; + X.prototype.prog := P; + X.prototype.AddToGC; + + P.SetAddress(P.GetOffset(R.H_JS_Array), @P.JS_Array); + + with X.prototype do + begin + aconstructor := X; + prog := P; + + PutProperty('pop', VarFromClass( + TJS_Function.InternalCreate(@TJS_Array._pop, 0, @P))); + + F := TJS_Function.InternalCreate(@TJS_Array._push, 1, @P); + F.DefaultNP := 10; + PutProperty('push', VarFromClass(F)); + end; +end; + +procedure Create_RegExpObject(P: TBaseRunner; R: TJS_Record); +var + X: TJS_Object; +begin + P.JS_RegExp := TJS_RegExp.Create; + X := P.JS_RegExp as TJS_Object; + X.prog := P; + X.aconstructor := X; + X.Tag := 1; + X.AddToGC; + + X.prototype := TJS_Object.Create; + X.prototype.aconstructor := X; + X.prototype.prog := P; + X.prototype.AddToGC; + + P.SetAddress(P.GetOffset(R.H_JS_RegExp), @P.JS_RegExp); + + with X.prototype do + begin + aconstructor := X; + prog := P; + + PutProperty('toString', VarFromClass( + TJS_Function.InternalCreate(@TJS_RegExp._toString, 0, @P))); + end; +end; + +procedure Create_FunctionObject(P: TBaseRunner; R: TJS_Record); +var + X: TJS_Object; +begin + P.JS_Function := TJS_Function.Create; + X := P.JS_Function as TJS_Object; + X.prog := P; + X.aconstructor := X; + X.Tag := 1; + X.AddToGC; + + X.prototype := TJS_Object.Create; + X.prototype.aconstructor := X; + X.prototype.prog := P; + X.prototype.AddToGC; + + P.SetAddress(P.GetOffset(R.H_JS_Function), @P.JS_Function); +end; + +var + JS_MATH_ABS: Integer = -1; + JS_MATH_ACOS: Integer = -1; + JS_MATH_ASIN: Integer = -1; + JS_MATH_ATAN: Integer = -1; + JS_MATH_ATAN2: Integer = -1; + JS_MATH_CEIL: Integer = -1; + JS_MATH_COS: Integer = -1; + JS_MATH_EXP: Integer = -1; + JS_MATH_FLOOR: Integer = -1; + JS_MATH_LOG: Integer = -1; + JS_MATH_MAX: Integer = -1; + JS_MATH_MIN: Integer = -1; + JS_MATH_POW: Integer = -1; + JS_MATH_RANDOM: Integer = -1; + JS_MATH_ROUND: Integer = -1; + JS_MATH_SIN: Integer = -1; + JS_MATH_SQRT: Integer = -1; + JS_MATH_TAN: Integer = -1; + + JS_MATH_PI: Integer = -1; + JS_MATH_E: Integer = -1; + JS_MATH_LN10: Integer = -1; + JS_MATH_LN2: Integer = -1; + JS_MATH_LOG2E: Integer = -1; + JS_MATH_LOG10E: Integer = -1; + JS_MATH_SQRT1_2: Integer = -1; + JS_MATH_SQRT2: Integer = -1; + +procedure Create_MathObject(P: TBaseRunner; R: TJS_Record); +var + X: TJS_Object; + F: TJS_Function; +begin + P.JS_Math := TJS_Math.Create; + P.SetAddress(P.GetOffset(R.H_JS_Math), @P.JS_Math); + + X := P.JS_Math as TJS_Object; + X.prog := P; + X.aconstructor := X; + X.Tag := 1; + X.AddToGC; + + X.prototype := TJS_Object.Create; + X.prototype.aconstructor := X; + X.prototype.prog := P; + X.prototype.AddToGC; + + with X do + begin + F := TJS_Function.InternalCreate(@TJS_Math._abs, 1, @P); + F.CoolCall := 1; + PutProperty('abs', VarFromClass(F)); //0 + JS_MATH_ABS := L.HashTable.LastIndex; + + F := TJS_Function.InternalCreate(@TJS_Math._acos, 1, @P); + F.CoolCall := 1; + PutProperty('acos', VarFromClass(F)); //1 + JS_MATH_ACOS := L.HashTable.LastIndex; + + F := TJS_Function.InternalCreate(@TJS_Math._asin, 1, @P); + F.CoolCall := 1; + PutProperty('asin', VarFromClass(F)); //2 + JS_MATH_ASIN := L.HashTable.LastIndex; + + F := TJS_Function.InternalCreate(@TJS_Math._atan, 1, @P); + F.CoolCall := 1; + PutProperty('atan', VarFromClass(F)); //3 + JS_MATH_ATAN := L.HashTable.LastIndex; + + F := TJS_Function.InternalCreate(@TJS_Math._atan2, 2, @P); + F.CoolCall := 1; + PutProperty('atan2', VarFromClass(F)); //4 + JS_MATH_ATAN2 := L.HashTable.LastIndex; + + F := TJS_Function.InternalCreate(@TJS_Math._ceil, 1, @P); + F.CoolCall := 1; + PutProperty('ceil', VarFromClass(F)); //5 + JS_MATH_CEIL := L.HashTable.LastIndex; + + F := TJS_Function.InternalCreate(@TJS_Math._cos, 1, @P); + F.CoolCall := 1; + PutProperty('cos', VarFromClass(F)); //6 + JS_MATH_COS := L.HashTable.LastIndex; + + F := TJS_Function.InternalCreate(@TJS_Math._exp, 1, @P); + F.CoolCall := 1; + PutProperty('exp', VarFromClass(F)); //7 + JS_MATH_EXP := L.HashTable.LastIndex; + + F := TJS_Function.InternalCreate(@TJS_Math._floor, 1, @P); + F.CoolCall := 1; + PutProperty('floor', VarFromClass(F)); //8 + JS_MATH_FLOOR := L.HashTable.LastIndex; + + F := TJS_Function.InternalCreate(@TJS_Math._log, 1, @P); + F.CoolCall := 1; + PutProperty('log', VarFromClass(F)); //9 + JS_MATH_LOG := L.HashTable.LastIndex; + + F := TJS_Function.InternalCreate(@TJS_Math._max, 5, @P); + F.CoolCall := 1; + PutProperty('max', VarFromClass(F)); //10 + JS_MATH_MAX := L.HashTable.LastIndex; + + F := TJS_Function.InternalCreate(@TJS_Math._min, 5, @P); + F.CoolCall := 1; + PutProperty('min', VarFromClass(F)); //11 + JS_MATH_MIN := L.HashTable.LastIndex; + + F := TJS_Function.InternalCreate(@TJS_Math._pow, 2, @P); + F.CoolCall := 1; + PutProperty('pow', VarFromClass(F)); //12 + JS_MATH_POW := L.HashTable.LastIndex; + + F := TJS_Function.InternalCreate(@TJS_Math._random, 0, @P); + F.CoolCall := 1; + PutProperty('random', VarFromClass(F)); //13 + JS_MATH_RANDOM := L.HashTable.LastIndex; + + F := TJS_Function.InternalCreate(@TJS_Math._round, 1, @P); + F.CoolCall := 1; + PutProperty('round', VarFromClass(F)); //14 + JS_MATH_ROUND := L.HashTable.LastIndex; + + F := TJS_Function.InternalCreate(@TJS_Math._sin, 1, @P); + F.CoolCall := 1; + PutProperty('sin', VarFromClass(F)); //15 + JS_MATH_SIN := L.HashTable.LastIndex; + + F := TJS_Function.InternalCreate(@TJS_Math._sqrt, 1, @P); + F.CoolCall := 1; + PutProperty('sqrt', VarFromClass(F)); //16 + JS_MATH_SQRT := L.HashTable.LastIndex; + + F := TJS_Function.InternalCreate(@TJS_Math._tan, 1, @P); + F.CoolCall := 1; + PutProperty('tan', VarFromClass(F)); //17 + JS_MATH_TAN := L.HashTable.LastIndex; + + PutProperty('PI', PI); //18 + JS_MATH_PI := L.HashTable.LastIndex; + + PutProperty('E', 2.7182818284590452354); //19 + JS_MATH_E := L.HashTable.LastIndex; + + PutProperty('LN10', 2.302585092994046); //20 + JS_MATH_LN10 := L.HashTable.LastIndex; + + PutProperty('LN2', 0.6931471805599453); //21 + JS_MATH_LN2 := L.HashTable.LastIndex; + + PutProperty('LOG2E', 1.4426950408889634); //22 + JS_MATH_LOG2E := L.HashTable.LastIndex; + + PutProperty('LOG10E', 0.434294819032518); //23 + JS_MATH_LOG10E := L.HashTable.LastIndex; + + PutProperty('SQRT1_2', 0.7071067811865476); //24 + JS_MATH_SQRT1_2 := L.HashTable.LastIndex; + + PutProperty('SQRT2', 1.4142135623730951); //25 + JS_MATH_SQRT2 := L.HashTable.LastIndex; + end; +end; + +procedure Create_JSObjects(Prog: Pointer; R: TJS_Record); +var + X: TJS_Object; + P: TBaseRunner; +begin + P := TBaseRunner(Prog); + + P.ProgTag := 1; + +// global Object object + P.JS_Object := TJS_Object.Create; + X := P.JS_Object as TJS_Object; + X.prog := P; + X.aconstructor := X; + X.Tag := 1; + X.AddToGC; + + X.prototype := TJS_Object.Create; + X.prototype.aconstructor := X; + X.prototype.prog := P; + X.prototype.AddToGC; + + P.SetAddress(P.GetOffset(R.H_JS_Object), @P.JS_Object); + + Create_BooleanObject(P, R); + Create_StringObject(P, R); + Create_NumberObject(P, R); + Create_DateObject(P, R); + Create_FunctionObject(P, R); + Create_ArrayObject(P, R); + Create_RegExpObject(P, R); + Create_MathObject(P, R); + Create_ErrorObject(P, R); + + P.RootGC.Mark; +// P.ProgTag := 0; +end; + +// VARIANT OPERATORS + +procedure _FuncObjFromVariant(source: PVariant; DestAddress: Pointer); stdcall; +begin + with TVarData(source^) do + begin + if VType <> varClass then + begin + if VType in [varEmpty, varDispatch] then + begin + TObject(DestAddress^) := EmptyFunction; + Exit; + end; + + RaiseError(errCannotConvertToFunctionObject, []); + end; + TObject(DestAddress^) := TObject(VInteger); + if TObject(DestAddress^).ClassType <> TJS_Function then + RaiseError(errCannotConvertToFunctionObject, []); + end; +end; + +procedure _VariantAddition(Language: Integer; + v1, v2, dest: PVariant); stdcall; +var + w1, w2: Variant; +begin + if Language = JS_LANGUAGE then + begin + w1 := JS_ToPrimitive(v1^); + w2 := JS_ToPrimitive(v2^); + + if JS_IsString(w1) or JS_IsString(w2) then + begin + if not JS_IsString(w1) then + w1 := JS_ToString(w1); + if not JS_IsString(w2) then + w2 := JS_ToString(w2); + + if JS_IsRef(dest^) then + JS_PutValue(dest^, w1 + w2) + else + dest^ := w1 + w2; + end + else + begin + if JS_IsRef(dest^) then + JS_PutValue(dest^, JS_ToNumber(w1) + JS_ToNumber(w2)) + else + dest^ := JS_ToNumber(w1) + JS_ToNumber(w2); + end; + end + else + begin + dest^ := v1^ + v2^; + end; +end; + +procedure _VariantSubtraction(Language: Integer; + v1, v2, dest: PVariant); stdcall; +var + w1, w2: Variant; +begin + if Language = JS_LANGUAGE then + begin + w1 := JS_GetValue(v1^); + w2 := JS_GetValue(v2^); + + if IsDateObject(w1) and IsDateObject(w2) then + begin + if JS_IsRef(dest^) then + JS_PutValue(dest^, VariantToDateObject(w1).Value - + VariantToDateObject(w2).Value) + else + dest^ := VariantToDateObject(w1).Value - + VariantToDateObject(w2).Value; + Exit; + end + else if IsDateObject(w1) then + begin + if JS_IsRef(dest^) then + JS_PutValue(dest^, VariantToDateObject(w1).Value - JS_ToNumber(w2)) + else + dest^ := VariantToDateObject(w1).Value - JS_ToNumber(w2); + Exit; + end + else if IsDateObject(w2) then + begin + if JS_IsRef(dest^) then + JS_PutValue(dest^, VariantToDateObject(w2).Value - JS_ToNumber(w1)) + else + dest^ := VariantToDateObject(w2).Value - JS_ToNumber(w1); + Exit; + end; + + if JS_IsRef(dest^) then + JS_PutValue(dest^, JS_ToNumber(w1) - JS_ToNumber(w2)) + else + dest^ := JS_ToNumber(w1) - JS_ToNumber(w2); + end + else + begin + dest^ := v1^ - v2^; + end; +end; + +procedure _VariantMultiplication(Language: Integer; + v1, v2, dest: PVariant); stdcall; +var + w1, w2: Variant; +begin + if Language = JS_LANGUAGE then + begin + w1 := JS_ToPrimitive(v1^); + w2 := JS_ToPrimitive(v2^); + + if JS_IsRef(dest^) then + JS_PutValue(dest^, JS_ToNumber(w1) * JS_ToNumber(w2)) + else + dest^ := JS_ToNumber(w1) * JS_ToNumber(w2); + end + else + begin + dest^ := v1^ * v2^; + end; +end; + +procedure _VariantDivision(Language: Integer; + v1, v2, dest: PVariant); stdcall; +var + w1, w2: Variant; +begin + if Language = JS_LANGUAGE then + begin + w1 := JS_ToPrimitive(v1^); + w2 := JS_ToPrimitive(v2^); + + if JS_IsRef(dest^) then + JS_PutValue(dest^, JS_ToNumber(w1) / JS_ToNumber(w2)) + else + dest^ := JS_ToNumber(w1) - JS_ToNumber(w2); + end + else + begin + dest^ := v1^ / v2^; + end; +end; + +procedure _VariantIDivision(Language: Integer; + v1, v2, dest: PVariant); stdcall; +var + w1, w2: Variant; +begin + if Language = JS_LANGUAGE then + begin + w1 := JS_ToPrimitive(v1^); + w2 := JS_ToPrimitive(v2^); + + if JS_IsRef(dest^) then + JS_PutValue(dest^, JS_ToInt32(w1) div JS_ToInt32(w2)) + else + dest^ := JS_ToInt32(w1) div JS_ToInt32(w2); + end + else + dest^ := v1^ div v2^; +end; + +procedure _VariantModulo(Language: Integer; + v1, v2, dest: PVariant); stdcall; +var + w1, w2: Variant; +begin + if Language = JS_LANGUAGE then + begin + w1 := JS_ToPrimitive(v1^); + w2 := JS_ToPrimitive(v2^); + + if JS_IsRef(dest^) then + JS_PutValue(dest^, JS_ToInt32(w1) mod JS_ToInt32(w2)) + else + dest^ := JS_ToInt32(w1) mod JS_ToInt32(w2); + end + else + dest^ := v1^ mod v2^; +end; + +procedure _VariantLeftShift(Language: Integer; + v1, v2, dest: PVariant); stdcall; +var + w1, w2: Variant; +begin + if Language = JS_LANGUAGE then + begin + w1 := JS_ToPrimitive(v1^); + w2 := JS_ToPrimitive(v2^); + w1 := JS_ToInt32(w1); + w2 := JS_ToInt32(w2); + if JS_IsRef(dest^) then + JS_PutValue(dest^, w1 shl w2) + else + dest^ := w1 shl w2; + end + else + dest^ := v1^ shl v2^; +end; + +procedure _VariantRightShift(Language: Integer; + v1, v2, dest: PVariant); stdcall; +var + w1, w2: Variant; +begin + if Language = JS_LANGUAGE then + begin + w1 := JS_ToPrimitive(v1^); + w2 := JS_ToPrimitive(v2^); + w1 := JS_ToInt32(w1); + w2 := JS_ToInt32(w2); + if JS_IsRef(dest^) then + JS_PutValue(dest^, w1 shr w2) + else + dest^ := w1 shr w2; + end + else + dest^ := v1^ shr v2^; +end; + +procedure _VariantAnd(Language: Integer; + v1, v2, dest: PVariant); stdcall; +var + w1, w2: Variant; +begin + if Language = JS_LANGUAGE then + begin + w1 := JS_ToPrimitive(v1^); + w2 := JS_ToPrimitive(v2^); + w1 := JS_ToInt32(w1); + w2 := JS_ToInt32(w2); + if JS_IsRef(dest^) then + JS_PutValue(dest^, w1 and w2) + else + dest^ := w1 and w2; + end + else + dest^ := v1^ and v2^; +end; + +procedure _VariantOr(Language: Integer; + v1, v2, dest: PVariant); stdcall; +var + w1, w2: Variant; +begin + if Language = JS_LANGUAGE then + begin + w1 := JS_ToPrimitive(v1^); + w2 := JS_ToPrimitive(v2^); + w1 := JS_ToInt32(w1); + w2 := JS_ToInt32(w2); + if JS_IsRef(dest^) then + JS_PutValue(dest^, w1 or w2) + else + dest^ := w1 or w2; + end + else + dest^ := v1^ or v2^; +end; + +procedure _VariantXor(Language: Integer; + v1, v2, dest: PVariant); stdcall; +var + w1, w2: Variant; +begin + if Language = JS_LANGUAGE then + begin + w1 := JS_ToPrimitive(v1^); + w2 := JS_ToPrimitive(v2^); + w1 := JS_ToInt32(w1); + w2 := JS_ToInt32(w2); + if JS_IsRef(dest^) then + JS_PutValue(dest^, w1 xor w2) + else + dest^ := w1 xor w2; + end + else + dest^ := v1^ xor v2^; +end; + +procedure _VariantLessThan(Language: Integer; + v1, v2: PVariant; dest: PBoolean); stdcall; +begin + if Language = JS_LANGUAGE then + begin + if JS_IsRef(dest^) then + JS_PutValue(dest^, JS_RelationalComparison(v1^, v2^)) + else + dest^ := JS_RelationalComparison(v1^, v2^); + end + else + dest^ := Boolean(v1^ < v2^); +end; + +procedure _VariantLessThanOrEqual(Language: Integer; + v1, v2: PVariant; dest: PBoolean); stdcall; +var + temp: Variant; +begin + if Language = JS_LANGUAGE then + begin + temp := JS_RelationalComparison(v2^, v1^); + if JS_IsUndefined(temp) then + temp := false + else if JS_IsBoolean(temp) then + temp := not temp + else + temp := true; + if JS_IsRef(dest^) then + JS_PutValue(dest^, temp) + else + dest^ := temp; + end + else + dest^ := v1^ <= v2^; +end; + +procedure _VariantGreaterThan(Language: Integer; + v1, v2: PVariant; dest: PBoolean); stdcall; +var + temp: Variant; +begin + if Language = JS_LANGUAGE then + begin + temp := JS_RelationalComparison(v2^, v1^); + if JS_IsUndefined(temp) then + temp := false; + if JS_IsRef(dest^) then + JS_PutValue(dest^, temp) + else + dest^ := temp; + end + else + dest^ := v1^ > v2^; +end; + +procedure _VariantGreaterThanOrEqual(Language: Integer; + v1, v2: PVariant; dest: PBoolean); stdcall; +var + temp: Variant; +begin + if Language = JS_LANGUAGE then + begin + temp := JS_RelationalComparison(v1^, v2^); + if JS_IsUndefined(temp) then + temp := false + else if JS_IsBoolean(dest^) then + temp := not temp + else + temp := true; + if JS_IsRef(dest^) then + JS_PutValue(dest^, temp) + else + dest^ := temp; + end + else + dest^ := v1^ >= v2^; +end; + +procedure _VariantEquality(Language: Integer; + v1, v2: PVariant; dest: PBoolean); stdcall; +begin + if Language = JS_LANGUAGE then + begin + if JS_IsRef(dest^) then + JS_PutValue(dest^, JS_EqualityComparison(v1^, v2^)) + else + dest^ := JS_EqualityComparison(v1^, v2^); + end + else + dest^ := v1^ = v2^; +end; + +procedure _VariantNotEquality(Language: Integer; + v1, v2: PVariant; dest: PBoolean); stdcall; +begin + if Language = JS_LANGUAGE then + begin + if JS_IsRef(dest^) then + JS_PutValue(dest^, not JS_EqualityComparison(v1^, v2^)) + else + dest^ := not JS_EqualityComparison(v1^, v2^); + end + else + dest^ := v1^ <> v2^; +end; + +function JS_PointerToVariant(P: Pointer): Variant; +begin + with TVarData(result) do + begin + VType := varPointer; + VInteger := Integer(P); + end; +end; + +function JS_VariantToPointer(const V: Variant): Pointer; +begin + with TVarData(V) do + begin + result := Pointer(VInteger); + end; +end; + +function Empty(P: PVariant): Boolean; +begin + result := (P = nil) or (VarType(P^) = varEmpty); +end; + +function JS_IsObject(const V: Variant): Boolean; +begin + result := VarType(V) = varClass; +end; + +function JS_IsPointer(const V: Variant): Boolean; +begin + result := VarType(V) = varPointer; +end; + +function JS_IsString(const V: Variant): Boolean; +var + T: Integer; +begin + T := VarType(V); + result := (T = varOleStr) or (T = varString) or (T = varUString); +end; + +function JS_IsBoolean(const V: Variant): Boolean; +begin + result := VarType(V) = varBoolean; +end; + +function JS_IsUndefined(const V: Variant): Boolean; +begin + result := VarType(V) = varEmpty; +end; + +function JS_ToPrimitive(const V: Variant): Variant; +var + X: TJS_ObjectBase; +begin + if VarType(V) = varClass then + begin + X := TJS_ObjectBase(TVarData(V).VInteger); + if X is TJS_Reference then + begin + result := (X as TJS_Reference).GetValue(); + if VarType(result) = varClass then + begin + X := TJS_ObjectBase(TVarData(result).VInteger); + result := (X as TJS_Object).fDefaultValue; + end; + end + else + result := (X as TJS_Object).fDefaultValue; + end + else + result := V; +end; + +function JS_ToString(const V: Variant): Variant; +var + X: TJS_ObjectBase; +begin + case VarType(V) of + varClass: + begin + X := TJS_ObjectBase(TVarData(V).VInteger); + if X is TJS_Reference then + X := (X as TJS_Reference).GetValueAsObject(); + + result := VarToStr((X as TJS_Object).fDefaultValue); + end; + else + result := VarToStr(V); + end; +end; + +function JS_ToNumber(const V: Variant): Variant; +var + X: TJS_ObjectBase; + Code1: Integer; + D: Double; +begin + case VarType(V) of + varEmpty: result := NaN; + varNull: result := 0; + varBoolean: + if V then + result := 1 + else + result := 0; + varString, varOleStr, varUString: + begin + Val(V, D, Code1); + result := D; +// result := StrToFloatDef(StringReplace(V, '.', PAXCOMP_SYS.DecimalSeparator, []), NaN); + end; + varClass: + begin + X := TJS_ObjectBase(TVarData(V).VInteger); + if X is TJS_Reference then + X := (X as TJS_Reference).GetValueAsObject(); + + result := JS_ToNumber((X as TJS_Object).fDefaultValue); + end + else + result := V; + end; +end; + +function JS_ToNumberE(const V: Variant): Extended; +var + X: TJS_ObjectBase; + D: Double; + Code1: Integer; +begin + case VarType(V) of + varEmpty: result := NaN; + varNull: result := 0; + varBoolean: + if V then + result := 1 + else + result := 0; + varString, varOleStr, varUString: + begin + Val(V, D, Code1); + result := D; +// result := StrToFloatDef(StringReplace(V, '.', PAXCOMP_SYS.DecimalSeparator, []), NaN); + end; + varClass: + begin + X := TJS_ObjectBase(TVarData(V).VInteger); + if X is TJS_Reference then + X := (X as TJS_Reference).GetValueAsObject(); + + result := JS_ToNumber((X as TJS_Object).fDefaultValue); + end + else + result := V; + end; +end; + +function JS_ToBoolean(const V: Variant): Variant; +begin + result := V; +end; + +function JS_ToInt32(const V: Variant): Variant; +var + N: Variant; + D: Double; + I: Integer; +begin + N := JS_ToNumber(V); + case VarType(N) of + varDouble: begin + D := N; + if IsNaN(D) or IsInfinite(D) then + result := 0 + else + begin + D := N; +{$IFDEF VARIANTS} + result := Round(D); +{$ELSE} + I := Round(D); + result := I; +{$ENDIF} + end; + end; + varInteger, varByte: Result := N; +{$IFDEF VARIANTS} + varInt64: + begin + D := N; + I := Round(D); + result := I; + end; +{$ENDIF} + end; +end; + +function JS_IsSimpleNumber(const V: Variant): Boolean; +begin + result := VarType(V) in [varSmallint, + varInteger, + varSingle, + varDouble, + varCurrency, + varShortInt, + varByte, + varWord, + varLongWord, + varInt64]; +end; + +function JS_IsNumber(const V: Variant): Boolean; +begin + result := JS_IsSimpleNumber(V); +end; + +function JS_RelationalComparison(const V1, V2: Variant): Variant; + //performs x < y comparison +var + I, L: Integer; + S1, S2: String; + P1, P2, N1, N2: Variant; +begin + P1 := JS_ToPrimitive(V1); + P2 := JS_ToPrimitive(V2); + + if JS_IsString(P1) and JS_IsString(P2) then + begin + S1 := P1; + S2 := P2; + if Pos(S1, S2) > 0 then + result := true + else if Pos(S2, S1) > 0 then + result := false + else + begin + L := Length(S1); + if Length(S2) < L then + L := Length(S2); + for I:=1 to L do + if S1[I] <> S2[I] then + begin + if Ord(S1[I]) < Ord(S2[I]) then + result := true + else + result := false; + Exit; + end; + result := false; + end; + end + else + begin + N1 := JS_ToNumber(P1); + N2 := JS_ToNumber(P2); + if IsNAN(N1) then + Exit; + if IsNAN(N2) then + Exit; + result := N1 < N2; + end; +end; + +function JS_EqualityComparison(const V1, V2: Variant): Boolean; +var + T1, T2: Integer; + W1, W2: Variant; +begin + result := false; + if (VarType(V1) = varClass) and (VarType(V2) = varEmpty) then + Exit; + if (VarType(V2) = varClass) and (VarType(V1) = varEmpty) then + Exit; + + W1 := JS_ToPrimitive(V1); + W2 := JS_ToPrimitive(V2); + + T1 := VarType(W1); + T2 := VarType(W2); + if T1 = T2 then begin + if T1 = varUndefined then + begin + result := true; + Exit; + end; + if T1 = varNull then + begin + result := true; + Exit; + end; + if JS_IsNumber(W1) then + begin + if IsNaN(W1) or IsNaN(W2) then + begin + result := false; + Exit; + end; + result := W1 = W2; + Exit; + end; + + result := W1 = W2; + end + else + begin + if (T1 = varNull) and (T2 = varUndefined) then + result := true + else if (T2 = varNull) and (T1 = varUndefined) then + result := true + else if JS_IsNumber(W1) and JS_IsString(W2) then + result := JS_EqualityComparison(W1, JS_ToNumber(W2)) + else if JS_IsNumber(W2) and JS_IsString(W1) then + result := JS_EqualityComparison(W2, JS_ToNumber(W1)) + else if JS_IsNumber(W1) and JS_IsBoolean(W2) then + result := JS_EqualityComparison(W1, JS_ToNumber(W2)) + else if JS_IsNumber(W2) and JS_IsBoolean(W1) then + result := JS_EqualityComparison(W2, JS_ToNumber(W1)) + else if JS_IsObject(W1) and (JS_IsNumber(W2) or JS_IsBoolean(W2) or JS_IsString(W2)) then + result := JS_EqualityComparison(JS_ToPrimitive(W1), W2) + else if JS_IsObject(W2) and (JS_IsNumber(W1) or JS_IsBoolean(W1) or JS_IsString(W1)) then + result := JS_EqualityComparison(JS_ToPrimitive(W2), W1) + else if JS_IsNumber(W1) and JS_IsNumber(W2) then + result := W1 = W2 + else + result := false; + end; +end; + +//-- THashTable ---------------------------------------------------------------- + +function HashPJW(S : PChar; TableSize: Integer) : longint; +{Note: this hash function is described in "Practical Algorithms For + Programmers" by Andrew Binstock and John Rex, Addison Wesley} +const + BitsInLongint = sizeof(longint) * 8; + ThreeQuarters = (BitsInLongint * 3) div 4; + OneEighth = BitsInLongint div 8; + HighBits : longint = + (not longint(0)) shl (BitsInLongint - OneEighth); +var + Test : longint; + c: Char; +begin + Result := 0; + + repeat + c := S^; + if c = #0 then + break; + + Result := (Result shl OneEighth) + ord(c); + Test := Result and HighBits; + if (Test <> 0) then + Result := (Result xor (Test shr ThreeQuarters)) and + not HighBits; + Inc(S); + until false; + result := Result mod TableSize; + if result < 0 then + writeln(123); +end; +{--------} +function HashELF(const S : string; TableSize: Integer) : longint; +{Note: this hash function is described in "Practical Algorithms For + Programmers" by Andrew Binstock and John Rex, Addison Wesley, + with modifications in Dr Dobbs Journal, April 1996} +var + G : longint; + i : integer; +begin + Result := 0; + for i := SLow(S) to SHigh(S) do begin + Result := (Result shl 4) + ord(S[i]); + G := Result and $F0000000; + if (G <> 0) then + Result := Result xor (G shr 24); + Result := Result and (not G); + end; + result := Result mod TableSize; +end; +{--------} +function HashBKDR(const S : string; TableSize: Integer) : longint; +{Note: this hash function is described in "The C Programming Language" + by Brian Kernighan and Donald Ritchie, Prentice Hall} +var + i : integer; +begin + Result := 0; + for i := SLow(S) to SHigh(S) do begin + Result := (Result * 31) + ord(S[i]); + end; + result := Result mod TableSize; +end; + +constructor THashTable.Create; +begin + inherited; + PrimeIndex := 1; + TableSize := Primes[PrimeIndex]; + SetLength(A, TableSize + 1); + Card := 0; + MaxCard := TableSize div 2; + HashFunction := HashPJW; +end; + +destructor THashTable.Destroy; +begin + Clear; + inherited; +end; + +function THashTable.IndexOf(const S: PChar; var I: Integer): Boolean; +var + N: Integer; +begin + result := false; + + N := HashFunction(S, TableSize); + I := N; + while I < TableSize do + begin + if A[I] = nil then + begin + LastIndex := I; + result := false; + Exit; + end + else + if StrComp(A[I].Key, S) = 0 then + begin + LastIndex := I; + result := true; + Exit; + end; + Inc(I); + end; + + I := 0; + while I < N do + begin + if A[I] = nil then + begin + LastIndex := I; + result := false; + Exit; + end + else + if StrComp(A[I].Key, S) = 0 then + begin + LastIndex := I; + result := true; + Exit; + end; + Inc(I); + end; +end; + +procedure THashTable.Clear; +var + I: Integer; +begin + Card := 0; + for I:=0 to TableSize - 1 do + if A[I] <> nil then + begin + StrDispose(A[I].Key); + FreeAndNil(A[I]); + end; +end; + +//-- TJS_PropList -------------------------------------------------------------- + +constructor TJS_PropList.Create(i_Owner: TJS_Object); +begin + inherited Create; + Owner := i_Owner; + HashTable := THashTable.Create; + CardArr := 0; +end; + +destructor TJS_PropList.Destroy; +begin + Clear; + FreeAndNil(HashTable); + inherited; +end; + +procedure TJS_PropList.Clear; +begin + HashTable.Clear; +end; + +procedure TJS_PropList.SetArrLength(N: Integer); +begin + CardArr := N; + SetLength(Arr, CardArr); + SetLength(AvailArrIndex, CardArr); +end; + +function TJS_PropList.GetArrProperty(PropName: Integer): PVariant; +begin + if PropName >= 0 then + begin + if owner.typ = TYP_JS_ARRAY then + begin + if CardArr <= PropName then + SetArrLength(PropName + Delta); + result := @ Arr[PropName]; + end + else + begin + if CardArr <= PropName then + SetArrLength(PropName + Delta); + + if AvailArrIndex[PropName] then + begin + result := @ Arr[PropName]; + Exit; + end; + + if owner.prototype <> nil then + begin + + if owner.prototype.L.CardArr <= PropName then + owner.prototype.L.SetArrLength(PropName + Delta); + if owner.prototype.L.AvailArrIndex[PropName] then + begin + result := @ owner.prototype.L.Arr[PropName]; + Exit; + end; + + end; + + if TJS_Object(owner.prog.JS_Object).prototype.L.CardArr <= PropName then + TJS_Object(owner.prog.JS_Object).prototype.L.SetArrLength(PropName + Delta); + if TJS_Object(owner.prog.JS_Object).prototype.L.AvailArrIndex[PropName] then + begin + result := @ TJS_Object(owner.prog.JS_Object).prototype.L.Arr[PropName]; + Exit; + end; + + result := @ Arr[PropName]; + AvailArrIndex[PropName] := true; + end; + end + else + result := GetProperty(PChar(IntToStr(PropName))); +end; + +procedure TJS_PropList.PutArrProperty(PropName: Integer; const Value: Variant); +begin + if PropName >= 0 then + begin + if CardArr <= PropName then + SetArrLength(PropName + Delta); + Arr[PropName] := Value; + AvailArrIndex[PropName] := true; + end + else + PutProperty(PChar(IntToStr(PropName)), Value); +end; + +function TJS_PropList.IndexOfProperty(PropName: PChar; var I: Integer; + var PositiveInt: Boolean): Boolean; +var + b: Boolean; +begin + if PositiveInt then + b := true + else + b := IsPositiveInt(PropName); + + if b then + begin + PositiveInt := true; + I := StrToInt(PropName); + + if CardArr <= I then + SetArrLength(I + Delta); + + if Owner.Typ = TYP_JS_ARRAY then + result := true + else + result := AvailArrIndex[I]; + Exit; + end; + + PositiveInt := false; + result := HashTable.IndexOf(PropName, I); +end; + +procedure TJS_PropList.PutProperty(PropName: PChar; + const Value: Variant); +var + R: TJS_PropRec; + I: Integer; + PositiveInt: Boolean; +begin + PositiveInt := false; + + if IndexOfProperty(PropName, I, PositiveInt) then + begin + if PositiveInt then + Arr[I] := Value + else + HashTable.A[I].Value := Value; + end + else + begin + if PositiveInt then + Arr[I] := Value + else + begin + R := TJS_PropRec.Create; + R.Key := StrAlloc(StrLen(PropName) + 1); + StrCopy(R.Key, PropName); + R.Value := Value; + HashTable.A[I] := R; + Inc(HashTable.Card); + end; + end; +end; + +function TJS_PropList.GetProperty(PropName: PChar): PVariant; +var + R: TJS_PropRec; + I: Integer; + PositiveInt: Boolean; + X: TJS_Object; +begin + +{ + JS_MATH_LN10 = 20; + JS_MATH_LN2 = 21; + JS_MATH_LOG2E = 22; + JS_MATH_LOG10E = 23; + JS_MATH_SQRT1_2 = 24; + JS_MATH_SQRT2 = 25; +} + + case owner.typ of + TYP_JS_MATH: + case PropName[0] of + 'a': + case PropName[1] of + 'b': + if PropName[2] = 's' then + if PropName[3] = #0 then // 'abs' + begin + result := @ HashTable.A[JS_MATH_ABS].Value; + Exit; + end; + 'c': + if PropName[2] = 'o' then + if PropName[3] = 's' then + if PropName[4] = #0 then // 'acos' + begin + result := @ HashTable.A[JS_MATH_ACOS].Value; + Exit; + end; + 's': + if PropName[2] = 'i' then + if PropName[3] = 'n' then + if PropName[4] = #0 then // 'asin' + begin + result := @ HashTable.A[JS_MATH_ASIN].Value; + Exit; + end; + 't': // PropName[1] + if PropName[2] = 'a' then + if PropName[3] = 'n' then + begin + if PropName[4] = #0 then // 'atan' + begin + result := @ HashTable.A[JS_MATH_ATAN].Value; + Exit; + end + else if PropName[4] = '2' then + if PropName[5] = #0 then // 'atan2' + begin + result := @ HashTable.A[JS_MATH_ATAN2].Value; + Exit; + end; + end; + end; + 'c': + case PropName[1] of + 'e': + if PropName[2] = 'i' then + if PropName[3] = 'l' then + if PropName[4] = #0 then // 'ceil' + begin + result := @ HashTable.A[JS_MATH_CEIL].Value; + Exit; + end; + 'o': + if PropName[2] = 's' then + if PropName[3] = #0 then // 'cos' + begin + result := @ HashTable.A[JS_MATH_COS].Value; + Exit; + end; + end; + 'e': + if StrComp(PropName, 'exp') = 0 then + begin + result := @ HashTable.A[JS_MATH_EXP].Value; + Exit; + end; + 'f': + if StrComp(PropName, 'floor') = 0 then + begin + result := @ HashTable.A[JS_MATH_FLOOR].Value; + Exit; + end; + 'l': + if PropName[1] = 'o' then + if PropName[2] = 'g' then + if PropName[3] = #0 then // 'log' + begin + result := @ HashTable.A[JS_MATH_LOG].Value; + Exit; + end; + 'm': + case PropName[1] of + 'a': if StrComp(PropName, 'max') = 0 then + begin + result := @ HashTable.A[JS_MATH_MAX].Value; + Exit; + end; + 'i': if StrComp(PropName, 'min') = 0 then + begin + result := @ HashTable.A[JS_MATH_MIN].Value; + Exit; + end; + end; + 'p': + if StrComp(PropName, 'pow') = 0 then + begin + result := @ HashTable.A[JS_MATH_POW].Value; + Exit; + end; + 'r': + case PropName[1] of + 'a': if StrComp(PropName, 'random') = 0 then + begin + result := @ HashTable.A[JS_MATH_RANDOM].Value; + Exit; + end; + 'o': if StrComp(PropName, 'round') = 0 then + begin + result := @ HashTable.A[JS_MATH_ROUND].Value; + Exit; + end; + end; + 's': + case PropName[1] of + 'i': if StrComp(PropName, 'sin') = 0 then + begin + result := @ HashTable.A[JS_MATH_SIN].Value; + Exit; + end; + 'q': if StrComp(PropName, 'sqrt') = 0 then + begin + result := @ HashTable.A[JS_MATH_SQRT].Value; + Exit; + end; + end; + 't': + if StrComp(PropName, 'tan') = 0 then + begin + result := @ HashTable.A[JS_MATH_TAN].Value; + Exit; + end; + 'P': + if StrComp(PropName, 'PI') = 0 then + begin + result := @ HashTable.A[JS_MATH_PI].Value; + Exit; + end; + 'E': + if PropName[1] = #0 then + begin + result := @ HashTable.A[JS_MATH_E].Value; + Exit; + end; + end; + // end of math + end; + + PositiveInt := false; + + if IndexOfProperty(PropName, I, PositiveInt) then + begin + if PositiveInt then + result := @ Arr[I] + else + result := @ HashTable.A[I].Value; + end + else + begin + R := nil; + + // find property in prototype chain + + X := owner.prototype; + while X <> nil do + begin + if X.L.IndexOfProperty(PropName, I, PositiveInt) then + begin + if PositiveInt then + begin + result := @ X.L.Arr[I]; + Exit; + end; + R := HashTable.A[I]; + break; + end; + X := X.prototype; + end; + + if R = nil then + begin + case owner.typ of + TYP_JS_BOOLEAN: X := TJS_Object(owner.prog.JS_Boolean).prototype; + TYP_JS_STRING: X := TJS_Object(owner.prog.JS_String).prototype; + TYP_JS_NUMBER: X := TJS_Object(owner.prog.JS_Number).prototype; + TYP_JS_DATE: X := TJS_Object(owner.prog.JS_Date).prototype; + TYP_JS_FUNCTION: X := TJS_Object(owner.prog.JS_Function).prototype; + TYP_JS_ARRAY: X := TJS_Object(owner.prog.JS_Array).prototype; + TYP_JS_REGEXP: X := TJS_Object(owner.prog.JS_RegExp).prototype; + TYP_JS_ERROR: X := TJS_Object(owner.prog.JS_Error).prototype; + else + X := nil; + end; + + if X <> nil then + if X.L.IndexOfProperty(PropName, I, PositiveInt) then + begin + if PositiveInt then + begin + result := @ X.L.Arr[I]; + Exit; + end; + R := X.L.HashTable.A[I]; + end; + + if R = nil then + begin + X := TJS_Object(owner.prog.JS_Object).prototype; + if X.L.IndexOfProperty(PropName, I, PositiveInt) then + begin + if PositiveInt then + begin + result := @ X.L.Arr[I]; + Exit; + end; + R := X.L.HashTable.A[I]; + end; + end; + end; + + if R = nil then + result := @ Undefined + else + result := @ R.Value; + end; +end; + +function TJS_PropList.HasProperty(PropName: PChar): Boolean; +begin + LastPropAddress := GetProperty(PropName); + result := LastPropAddress <> (@ Undefined); +end; + +// -- TJS_Reference ------------------------------------------------------------ + +constructor TJS_Reference.Create(AFinTypeId: Integer); +begin + inherited Create; + FinTypeId := AFinTypeId; +end; + +function TJS_Reference.GetValue(): Variant; +begin + result := GetVariantValue(Address, FinTypeId); +end; + +function TJS_Reference.GetValueAsObject(): TJS_Object; +begin + result := TJS_Object(TVarData(Address^).VInteger); +end; + +procedure TJS_Reference.PutValue(const value: Variant); +begin + PutVariantValue(Address, FinTypeId, value); +end; + +function TJS_Reference.__toString: String; +begin + result := ''; +end; + +function JS_IsRef(const V: Variant): Boolean; +var + X: TJS_ObjectBase; + VT: Word; +begin + VT := TVarData(V).VType; + if VT = varClass then + begin + X := TJS_ObjectBase(TVarData(V).VInteger); + result := X is TJS_Reference; + end + else + result := false; +end; + +function JS_GetValue(const V: Variant): Variant; +begin + if JS_IsRef(V) then + result := TJS_Reference(TVarData(V).VInteger).GetValue() + else + result := V; +end; + +procedure JS_PutValue(const V: Variant; const value: Variant); +begin + if not JS_IsRef(V) then + RaiseError(errReferenceError, []); + TJS_Reference(TVarData(V).VInteger).PutValue(value); +end; + +//-- TJS_ObjectBase ------------------------------------------------------------ + +function TJS_ObjectBase.GetGC: TGC; +begin + result := nil; + RaiseError(errInternalError, []); +end; + +//-- TJS_Object ---------------------------------------------------------------- + +constructor TJS_Object.Create; +begin + inherited; + Typ := TYP_JS_OBJECT; + L := TJS_PropList.Create(Self); + prototype := nil; + Tag := 0; + prog := nil; + aconstructor := nil; + NextPropIndex := -1; +end; + +destructor TJS_Object.Destroy; +begin + FreeAndNil(L); + inherited; +end; + +function TJS_Object.__toString: String; +begin + result := 'Object[]'; +end; + +function TJS_Object.GetConstructor: TJS_Object; +var + X: TJS_Object; +begin + + if aconstructor <> nil then + begin + result := aconstructor; + Exit; + end; + + X := Self.prototype; + while X <> nil do + begin + if X.aconstructor <> nil then + begin + result := X.aconstructor; + Exit; + end; + X := X.prototype; + end; + result := nil; +end; + +procedure TJS_Object.PutProperty(PropName: PChar; const Value: Variant); +begin + L.PutProperty(PropName, Value); +end; + +function TJS_Object.HasProperty(PropName: PChar): Boolean; +begin + result := L.HasProperty(PropName); +end; + +function TJS_Object.GetProperty(PropName: PChar): Variant; +var + P: Pointer; +begin + P := L.GetProperty(PropName); + if TVarData(P^).VType = varClass then + begin + TVarData(result).VType := varClass; + TVarData(result).VInteger := TVarData(P^).VInteger; + end + else + result := Variant(P^); +end; + +function TJS_Object.GetVarProperty(const PropName: Variant): Variant; +var + S: String; +begin + S := JS_ToString(PropName); + result := GetProperty(PChar(S)); +end; + +procedure TJS_Object.PutVarProperty(const PropName: Variant; const Value: Variant); +var + S: String; +begin + S := JS_ToString(PropName); + PutProperty(PChar(S), Value); +end; + +function TJS_Object.GetPropertyAsObject(PropName: PChar): TJS_Object; +begin + result := TObject(TVarData(L.GetProperty(PropName)^).VInteger) as TJS_Object; + if result = nil then + RaiseError(errPropertyNotFound, [String(PropName)]); +end; + +procedure TJS_Object.PutArrProperty(PropName: Integer; const Value: Variant); +begin + if PropName >= fLength then + fLength := PropName + 1; + L.PutArrProperty(PropName, Value); +end; + +function TJS_Object.GetArrProperty(PropName: Integer): Variant; +begin + if PropName >= fLength then + fLength := PropName + 1; + result := L.GetArrProperty(PropName)^; +end; + +procedure TJS_Object.AddToGC; +begin + if prog = nil then + RaiseError(errInternalError, []); + prog.RootGC.AddObject(Self); +end; + +function TJS_Object.GetGC: TGC; +begin + if prog = nil then + RaiseError(errInternalError, []); + result := TBaseRunner(prog).RootGC; +end; + +//-- TJS_Date ------------------------------------------------------------------ + +function IsDateObject(const V: Variant): Boolean; +begin + result := TVarData(V).VType = varClass; + if result then + result := TObject(TVarData(V).VInteger).ClassType = TJS_Date; +end; + +function VariantToDateObject(const V: Variant): TJS_Date; +begin + result := TJS_Date(TVarData(V).VInteger); +end; + +function _Floor(X: Extended): Int64; +begin + result := Trunc(X); + if Frac(X) < 0 then + Dec(result); +end; + +function DelphiDateTimeToEcmaTime(const AValue: TDateTime): Double; +var + T: TTimeStamp; + D1970: TDateTime; +begin + D1970 := EncodeDate(1970,1,1); + + T := DateTimeToTimeStamp(AValue); + Result := (_Floor(AValue) - _Floor(D1970)) * MSecsPerDay + T.Time; +end; + +function EcmaTimeToDelphiDateTime(const AValue: Variant): TDateTime; +var + TimeStamp: TTimeStamp; + D1970: TDateTime; +begin + D1970 := EncodeDate(1970,1,1); + + TimeStamp := DateTimeToTimeStamp(D1970); + + TimeStamp.Time := _Floor(AValue) mod MSecsPerDay; + TimeStamp.Date := TimeStamp.Date + _Floor(AValue) div MSecsPerDay; + + result := TimeStampToDateTime(TimeStamp); +end; + +{$IFDEF PAXARM} +function GetGMTDifference: Double; +begin + result := 0; +end; +{$ELSE} +{$IFDEF LINUX} +function GetGMTDifference: Double; +begin + result := 0; +end; +{$ELSE} + {$IFDEF MACOS32} +function GetGMTDifference: Double; +begin + result := 0; +end; + {$ELSE} +function GetGMTDifference: Double; +var + TZ: TTimeZoneInformation; +begin + GetTimeZoneInformation(TZ); + if TZ.Bias = 0 then + Result := 0 + else if TZ.Bias < 0 then + begin + if TZ.Bias mod 60 = 0 then + Result := Abs(TZ.Bias) div 60 + else + Result := Abs(TZ.Bias) / 60; + end + else + begin + if TZ.Bias mod 60 = 0 then + Result := - TZ.Bias div 60 + else + Result := - TZ.Bias / 60; + end; +end; + {$ENDIF} +{$ENDIF} +{$ENDIF} + + +constructor TJS_Date.Create(Year: PVariant = nil; + Month: PVariant = nil; + Day: PVariant = nil; + Hours: PVariant = nil; + Minutes: PVariant = nil; + Seconds: PVariant = nil; + Ms: PVariant = nil); +begin + inherited Create; + + Typ := TYP_JS_DATE; + + DelphiDate := 0; + if Empty(Year) then + begin + DelphiDate := Now; + end + else if Empty(Month) then + begin + DelphiDate := EncodeDate(Year^, 1, 1); + end + else if Empty(Day) then + begin + DelphiDate := EncodeDate(Year^, Month^, 1); + end + else if Empty(Hours) then + begin + DelphiDate := EncodeDate(Year^, Month^, Day^); + end + else if Empty(Minutes) then + begin + DelphiDate := EncodeDate(Year^, Month^, Day^); + setHours(Hours^, 0, 0 , 0); + end + else if Empty(Seconds) then + begin + DelphiDate := EncodeDate(Year^, Month^, Day^); + setMinutes(Minutes^, 0 , 0); + end + else + begin + DelphiDate := EncodeDate(Year^, Month^, Day^); + setSeconds(Seconds^, 0); + end; + fDefaultValue := DelphiDate; +end; + +function TJS_Date.UTCDelphiDate: TDateTime; +var + Diff: Integer; +begin + Diff := Floor(GetGMTDifference); + result := EcmaTimeToDelphiDateTime(GetValue - MSecsPerHour * Diff); +end; + +function TJS_Date.DelphiDateFromUTCDate(D: TDateTime): TDateTime; +var + T: Double; + Diff: Integer; +begin + T := DelphiDateTimeToEcmaTime(D); + Diff := Floor(GetGMTDifference); + result := EcmaTimeToDelphiDateTime(T + MSecsPerHour * Diff); +end; + +function TJS_Date.GetValue: Variant; +begin + result := DelphiDateTimeToEcmaTime(DelphiDate); +end; + +function TJS_Date._toString: Variant; stdcall; +begin + result := JS_ToString(DelphiDate); +end; + +function TJS_Date.__toString: String; +begin + result := _toString(); +end; + +function TJS_Date.toGMTString: Variant; stdcall; +begin + result := JS_ToString(UTCDelphiDate); +end; + +function TJS_Date.getTime: Variant; stdcall; +begin + result := JS_ToNumber(GetValue); +end; + +function TJS_Date.getFullYear: Variant; stdcall; +var + Year, Month, Day: Word; +begin + DecodeDate(DelphiDate, Year, Month, Day); + result := Integer(Year); +end; + +function TJS_Date.getUTCFullYear: Variant; stdcall; +var + Year, Month, Day: Word; +begin + DecodeDate(UTCDelphiDate, Year, Month, Day); + result := Integer(Year); +end; + +function TJS_Date.getMonth: Variant; stdcall; +var + Year, Month, Day: Word; +begin + DecodeDate(DelphiDate, Year, Month, Day); + result := Integer(Month); +end; + +function TJS_Date.getUTCMonth: Variant; stdcall; +var + Year, Month, Day: Word; +begin + DecodeDate(UTCDelphiDate, Year, Month, Day); + result := Integer(Month); +end; + +function TJS_Date.getDate: Variant; stdcall; +var + Year, Month, Day: Word; +begin + DecodeDate(DelphiDate, Year, Month, Day); + result := Integer(Day); +end; + +function TJS_Date.getUTCDate: Variant; stdcall; +var + Year, Month, Day: Word; +begin + DecodeDate(UTCDelphiDate, Year, Month, Day); + result := Integer(Day); +end; + +function TJS_Date.getDay: Variant; stdcall; +begin + result := DayOfWeek(DelphiDate) - 1; +end; + +function TJS_Date.getUTCDay: Variant; stdcall; +begin + result := DayOfWeek(UTCDelphiDate) - 1; +end; + +function TJS_Date.getHours: Variant; stdcall; +var + Hour, Min, Sec, MSec: Word; +begin + DecodeTime(DelphiDate, Hour, Min, Sec, MSec); + result := Integer(Hour); +end; + +function TJS_Date.getUTCHours: Variant; stdcall; +var + Hour, Min, Sec, MSec: Word; +begin + DecodeTime(UTCDelphiDate, Hour, Min, Sec, MSec); + result := Integer(Hour); +end; + +function TJS_Date.getMinutes: Variant; stdcall; +var + Hour, Min, Sec, MSec: Word; +begin + DecodeTime(DelphiDate, Hour, Min, Sec, MSec); + result := Integer(Min); +end; + +function TJS_Date.getUTCMinutes: Variant; stdcall; +var + Hour, Min, Sec, MSec: Word; +begin + DecodeTime(UTCDelphiDate, Hour, Min, Sec, MSec); + result := Integer(Min); +end; + +function TJS_Date.getSeconds: Variant; stdcall; +var + Hour, Min, Sec, MSec: Word; +begin + DecodeTime(DelphiDate, Hour, Min, Sec, MSec); + result := Integer(Sec); +end; + +function TJS_Date.getUTCSeconds: Variant; stdcall; +var + Hour, Min, Sec, MSec: Word; +begin + DecodeTime(UTCDelphiDate, Hour, Min, Sec, MSec); + result := Integer(Sec); +end; + +function TJS_Date.getMilliseconds: Variant; stdcall; +var + Hour, Min, Sec, MSec: Word; +begin + DecodeTime(DelphiDate, Hour, Min, Sec, MSec); + result := Integer(MSec); +end; + +function TJS_Date.getUTCMilliseconds: Variant; stdcall; +var + Hour, Min, Sec, MSec: Word; +begin + DecodeTime(DelphiDate, Hour, Min, Sec, MSec); + result := Integer(MSec); +end; + +function TJS_Date.setTime(const P: Variant): Variant; stdcall; +begin + result := JS_ToNumber(P); + DelphiDate := EcmaTimeToDelphiDateTime(result); +end; + +function TJS_Date.setMilliseconds(const ms: Variant): Variant; stdcall; +var + aHour, aMin, aSec, aMsec: Word; +begin + DecodeTime(DelphiDate, aHour, aMin, aSec, aMsec); + if VarType(ms) <> varEmpty then + aMsec := JS_ToInt32(ms); + DelphiDate := EncodeTime(aHour, aMin, aSec, aMsec); + result := GetValue; +end; + +function TJS_Date.setUTCMilliseconds(const ms: Variant): Variant; stdcall; +var + aHour, aMin, aSec, aMsec: Word; +begin + DecodeTime(UTCDelphiDate, aHour, aMin, aSec, aMsec); + if VarType(ms) <> varEmpty then + aMsec := JS_ToInt32(ms); + DelphiDate := EncodeTime(aHour, aMin, aSec, aMsec); + DelphiDate := DelphiDateFromUTCDate(DelphiDate); + result := GetValue; +end; + +function TJS_Date.setSeconds(const sec, ms: Variant): Variant; stdcall; +var + aHour, aMin, aSec, aMsec: Word; +begin + DecodeTime(DelphiDate, aHour, aMin, aSec, aMsec); + if VarType(sec) <> varEmpty then + aSec := JS_ToInt32(sec); + if VarType(ms) <> varEmpty then + aMsec := JS_ToInt32(ms); + DelphiDate := EncodeTime(aHour, aMin, aSec, aMsec); + result := GetValue; +end; + +function TJS_Date.setUTCSeconds(const sec, ms: Variant): Variant; stdcall; +var + aHour, aMin, aSec, aMsec: Word; +begin + DecodeTime(UTCDelphiDate, aHour, aMin, aSec, aMsec); + if VarType(sec) <> varEmpty then + aSec := JS_ToInt32(sec); + if VarType(ms) <> varEmpty then + aMsec := JS_ToInt32(ms); + DelphiDate := EncodeTime(aHour, aMin, aSec, aMsec); + DelphiDate := DelphiDateFromUTCDate(DelphiDate); + result := GetValue; +end; + +function TJS_Date.setMinutes(const min, sec, ms: Variant): Variant; stdcall; +var + aHour, aMin, aSec, aMsec: Word; +begin + DecodeTime(DelphiDate, aHour, aMin, aSec, aMsec); + if VarType(min) <> varEmpty then + aMin := JS_ToInt32(min); + if VarType(sec) <> varEmpty then + aSec := JS_ToInt32(sec); + if VarType(ms) <> varEmpty then + aMsec := JS_ToInt32(ms); + DelphiDate := EncodeTime(aHour, aMin, aSec, aMsec); + result := GetValue; +end; + +function TJS_Date.setUTCMinutes(const min, sec, ms: Variant): Variant; stdcall; +var + aHour, aMin, aSec, aMsec: Word; +begin + DecodeTime(UTCDelphiDate, aHour, aMin, aSec, aMsec); + if VarType(min) <> varEmpty then + aMin := JS_ToInt32(min); + if VarType(sec) <> varEmpty then + aSec := JS_ToInt32(sec); + if VarType(ms) <> varEmpty then + aMsec := JS_ToInt32(ms); + DelphiDate := EncodeTime(aHour, aMin, aSec, aMsec); + DelphiDate := DelphiDateFromUTCDate(DelphiDate); + result := GetValue; +end; + +function TJS_Date.setHours(const hour, min, sec, ms: Variant): Variant; stdcall; +var + aHour, aMin, aSec, aMsec: Word; +begin + DecodeTime(DelphiDate, aHour, aMin, aSec, aMsec); + if VarType(hour) <> varEmpty then + aHour := JS_ToInt32(hour); + if VarType(min) <> varEmpty then + aMin := JS_ToInt32(min); + if VarType(sec) <> varEmpty then + aSec := JS_ToInt32(sec); + if VarType(ms) <> varEmpty then + aMsec := JS_ToInt32(ms); + DelphiDate := EncodeTime(aHour, aMin, aSec, aMsec); + result := GetValue; +end; + +function TJS_Date.setUTCHours(const hour, min, sec, ms: Variant): Variant; stdcall; +var + aHour, aMin, aSec, aMsec: Word; +begin + DecodeTime(UTCDelphiDate, aHour, aMin, aSec, aMsec); + if VarType(hour) <> varEmpty then + aHour := JS_ToInt32(hour); + if VarType(min) <> varEmpty then + aMin := JS_ToInt32(min); + if VarType(sec) <> varEmpty then + aSec := JS_ToInt32(sec); + if VarType(ms) <> varEmpty then + aMsec := JS_ToInt32(ms); + DelphiDate := EncodeTime(aHour, aMin, aSec, aMsec); + DelphiDate := DelphiDateFromUTCDate(DelphiDate); + result := GetValue; +end; + +function TJS_Date.setDate(const date: Variant): Variant; stdcall; +var + aYear, aMonth, aDay: Word; +begin + DecodeDate(DelphiDate, aYear, aMonth, aDay); + result := GetValue; +end; + +//-- TJS_Array ----------------------------------------------------------------- + +constructor TJS_Array.Create(const V: array of Variant); +var + I, L: Integer; +begin + inherited Create; + Typ := TYP_JS_ARRAY; + L := System.Length(V); + if L = 0 then + Length := 0 + else if L = 1 then + Length := V[0] + else + for I := 0 to L - 1 do + PutArrProperty(I, V[I]); +end; + +destructor TJS_Array.Destroy; +begin + inherited; +end; + +function TJS_Array.GetLength: Integer; +begin + result := fLength; +end; + +procedure TJS_Array.SetLength(value: Integer); +begin + L.SetArrLength(value); + fLength := value; +end; + +function TJS_Array._toString: Variant; stdcall; +var + I: Integer; + V: Variant; +begin + result := '['; + for I := 0 to fLength - 1 do + begin + V := GetArrProperty(I); + result := result + JS_ToString(V); + if I < fLength - 1 then + result := result + ','; + end; + result := result + ']'; +end; + +function TJS_Array.__toString: String; +begin + result := _toString(); +end; + +function TJS_Array._pop: Variant; stdcall; +begin + result := GetArrProperty(fLength - 1); + SetLength(fLength - 1); +end; + +function TJS_Array._push(P0: PVariant; + P1: PVariant = nil; + P2: PVariant = nil; + P3: PVariant = nil; + P4: PVariant = nil; + P5: PVariant = nil; + P6: PVariant = nil; + P7: PVariant = nil; + P8: PVariant = nil; + P9: PVariant = nil): Variant; stdcall; +begin + SetLength(fLength + 1); + PutArrProperty(fLength - 1, P0^); + if Empty(P1) then + begin + result := fLength; + Exit; + end; + + SetLength(fLength + 1); + PutArrProperty(fLength - 1, P1^); + if Empty(P2) then + begin + result := fLength; + Exit; + end; + + SetLength(fLength + 1); + PutArrProperty(fLength - 1, P2^); + if Empty(P3) then + begin + result := fLength; + Exit; + end; + + SetLength(fLength + 1); + PutArrProperty(fLength - 1, P3^); + if Empty(P4) then + begin + result := fLength; + Exit; + end; + + SetLength(fLength + 1); + PutArrProperty(fLength - 1, P4^); + if Empty(P5) then + begin + result := fLength; + Exit; + end; + + SetLength(fLength + 1); + PutArrProperty(fLength - 1, P5^); + if Empty(P6) then + begin + result := fLength; + Exit; + end; + + SetLength(fLength + 1); + PutArrProperty(fLength - 1, P6^); + if Empty(P7) then + begin + result := fLength; + Exit; + end; + + SetLength(fLength + 1); + PutArrProperty(fLength - 1, P7^); + if Empty(P8) then + begin + result := fLength; + Exit; + end; + + SetLength(fLength + 1); + PutArrProperty(fLength - 1, P8^); + if Empty(P9) then + begin + result := fLength; + Exit; + end; + + SetLength(fLength + 1); + PutArrProperty(fLength - 1, P9^); + +end; + +//-- TJS_Error ----------------------------------------------------------------- + +constructor TJS_Error.Create(P: PVariant = nil); +begin + inherited Create; + + Typ := TYP_JS_ERROR; + + if Empty(P) then + fDefaultValue := '' + else + fDefaultValue := JS_ToString(P^); +end; + +function TJS_Error._toString: Variant; stdcall; +begin + result := fDefaultValue; +end; + +function TJS_Error.__toString: String; +begin + result := _toString(); +end; + +//-- TJS_Boolean --------------------------------------------------------------- + +constructor TJS_Boolean.Create(P: PVariant = nil); +begin + inherited Create; + + Typ := TYP_JS_BOOLEAN; + + if Empty(P) then + fDefaultValue := false + else + fDefaultValue := JS_ToBoolean(P^); +end; + +function TJS_Boolean._toString: Variant; stdcall; +begin + if fDefaultValue then + result := 'true' + else + result := 'false'; +end; + +function TJS_Boolean.__toString: String; +begin + result := _toString(); +end; + +//-- TJS_Number ---------------------------------------------------------------- + +constructor TJS_Number.Create(P: PVariant = nil); +begin + inherited Create; + + Typ := TYP_JS_NUMBER; + + if Empty(P) then + fDefaultValue := Undefined + else + fDefaultValue := JS_ToNumber(P^); +end; + +function TJS_Number._toString(): Variant; stdcall; +begin + result := JS_ToString(fDefaultValue); +end; + +function TJS_Number.__toString(): String; +begin + result := _toString(); +end; + +//-- TJS_String ---------------------------------------------------------------- + +constructor TJS_String.Create(P: PVariant = nil); +begin + inherited Create; + + Typ := TYP_JS_STRING; + + if Empty(P) then + fDefaultValue := '' + else + fDefaultValue := JS_ToString(P^); +end; + +function TJS_String._toString: Variant; stdcall; +begin + result := fDefaultValue; +end; + +function TJS_String.__toString: String; +begin + result := _toString(); +end; + +function TJS_String._valueOf: Variant; stdcall; +begin + result := fDefaultValue; +end; + +function TJS_String._length: Variant; stdcall; +begin + result := Length(fDefaultValue); +end; + +function TJS_String._charAt(const P: Variant): Variant; stdcall; +var + I: Integer; +begin + result := ''; + I := JS_ToInt32(P); + if I < 0 then + Exit; + if I >= Length(fDefaultValue) then + Exit; + result := fDefaultValue[I + 1]; +end; + +function TJS_String._charCodeAt(const P: Variant): Variant; stdcall; +var + I: Integer; +begin + result := -1; + I := JS_ToInt32(P); + if I < 0 then + Exit; + if I >= Length(fDefaultValue) then + Exit; + result := ord(String(fDefaultValue)[I + 1]); +end; + +function TJS_String._concat(P0: PVariant; + P1: PVariant = nil; + P2: PVariant = nil; + P3: PVariant = nil; + P4: PVariant = nil; + P5: PVariant = nil; + P6: PVariant = nil; + P7: PVariant = nil; + P8: PVariant = nil; + P9: PVariant = nil): Variant; stdcall; +begin + result := fDefaultValue; + if Empty(P0) then + Exit; + result := result + JS_ToString(P0^); + if Empty(P1) then + Exit; + result := result + JS_ToString(P1^); + if Empty(P2) then + Exit; + result := result + JS_ToString(P2^); + if Empty(P3) then + Exit; + result := result + JS_ToString(P3^); + if Empty(P4) then + Exit; + result := result + JS_ToString(P4^); + if Empty(P5) then + Exit; + result := result + JS_ToString(P5^); + if Empty(P6) then + Exit; + result := result + JS_ToString(P6^); + if Empty(P7) then + Exit; + result := result + JS_ToString(P7^); + if Empty(P8) then + Exit; + result := result + JS_ToString(P8^); + if Empty(P9) then + Exit; + result := result + JS_ToString(P9^); +end; + +function TJS_String._fromCharCode(P0: PVariant; + P1: PVariant = nil; + P2: PVariant = nil; + P3: PVariant = nil; + P4: PVariant = nil; + P5: PVariant = nil; + P6: PVariant = nil; + P7: PVariant = nil; + P8: PVariant = nil; + P9: PVariant = nil): Variant; stdcall; +var + B: Byte; +begin + result := ''; + + if Empty(P0) then + Exit; + B := JS_ToInt32(P0^); + result := result + Chr(B); + + if Empty(P1) then + Exit; + B := JS_ToInt32(P1^); + result := result + Chr(B); + + if Empty(P2) then + Exit; + B := JS_ToInt32(P2^); + result := result + Chr(B); + + if Empty(P3) then + Exit; + B := JS_ToInt32(P3^); + result := result + Chr(B); + + if Empty(P4) then + Exit; + B := JS_ToInt32(P4^); + result := result + Chr(B); + + if Empty(P5) then + Exit; + B := JS_ToInt32(P5^); + result := result + Chr(B); + + if Empty(P6) then + Exit; + B := JS_ToInt32(P6^); + result := result + Chr(B); + + if Empty(P7) then + Exit; + B := JS_ToInt32(P7^); + result := result + Chr(B); + + if Empty(P8) then + Exit; + B := JS_ToInt32(P8^); + result := result + Chr(B); + + if Empty(P9) then + Exit; + B := JS_ToInt32(P9^); + result := result + Chr(B); +end; + +function TJS_String._slice(const VStart, VEnd: Variant): Variant; stdcall; +var + S: String; + IStart, IEnd, L: Integer; +begin + S := fDefaultValue; + + L := Length(S); + + if Empty(@VStart) then + begin + IStart := 0; + IEnd := L - 1; + end + else if Empty(@VEnd) then + begin + IStart := JS_ToInt32(VStart); + if IStart < 0 then + IStart := IStart + L; + IEnd := L - 1; + end + else + begin + IStart := JS_ToInt32(VStart); + IEnd := JS_ToInt32(VEnd); + if IStart < 0 then + IStart := IStart + L; + if IEnd < 0 then + IEnd := IEnd + L; + end; + + L := IEnd - IStart + 1; + + if L > 0 then + result := Copy(S, IStart, L); +end; + +function TJS_String._substr(const VStart, VLength: Variant): Variant; stdcall; +var + S: String; + I, L: Integer; +begin + S := fDefaultValue; + + I := 1; + L := Length(S); + if not Empty(@VStart) then + I := JS_ToInt32(VStart); + if not Empty(@VLength) then + L := JS_ToInt32(VLength); + + result := Copy(S, I + 1, L); +end; + +function TJS_String._substring(const VStart, VLength: Variant): Variant; stdcall; +var + S: String; + I, L: Integer; +begin + S := fDefaultValue; + + I := 1; + L := Length(S); + if not Empty(@VStart) then + I := JS_ToInt32(VStart); + if not Empty(@VLength) then + L := JS_ToInt32(VLength); + + result := Copy(S, I + 1, L); +end; + +function TJS_String._indexOf(const P: Variant): Variant; stdcall; +var + I: Integer; + S, Q: String; +begin + result := Integer(-1); + S := fDefaultValue; + Q := JS_ToString(P); + I := Pos(Q, S); + if I = 0 then + Exit; + result := I - 1; +end; + +function TJS_String._lastIndexOf(const P: Variant): Variant; stdcall; +var + I, L: Integer; + S, Q: String; +begin + result := Integer(-1); + S := fDefaultValue; + Q := JS_ToString(P); + L := Length(Q); + for I:=Length(S) - L downto 1 do + if Copy(S, I, L) = Q then + begin + result := I - 1; + Exit; + end; +end; + +function TJS_String._anchor(const P: Variant): Variant; stdcall; +begin + result := '' + fDefaultValue + ''; +end; + +function TJS_String._link(const P: Variant): Variant; stdcall; +begin + result := '' + fDefaultValue + ''; +end; + +function TJS_String._big: Variant; stdcall; +begin + result := '' + fDefaultValue + ''; +end; + +function TJS_String._small: Variant; stdcall; +begin + result := '' + fDefaultValue + ''; +end; + +function TJS_String._blink: Variant; stdcall; +begin + result := '' + fDefaultValue + ''; +end; + +function TJS_String._bold: Variant; stdcall; +begin + result := '' + fDefaultValue + ''; +end; + +function TJS_String._italics: Variant; stdcall; +begin + result := '' + fDefaultValue + ''; +end; + +function TJS_String._strike: Variant; stdcall; +begin + result := '' + fDefaultValue + ''; +end; + +function TJS_String._sub: Variant; stdcall; +begin + result := '' + fDefaultValue + ''; +end; + +function TJS_String._sup: Variant; stdcall; +begin + result := '' + fDefaultValue + ''; +end; + +function TJS_String._fixed: Variant; stdcall; +begin + result := '' + fDefaultValue + ''; +end; + +function TJS_String._fontcolor(const P: Variant): Variant; stdcall; +begin + result := '' + fDefaultValue + ''; +end; + +function TJS_String._fontsize(const P: Variant): Variant; stdcall; +begin + result := '' + fDefaultValue + ''; +end; + +function TJS_String._toUpperCase: Variant; stdcall; +begin + result := UpperCase(fDefaultValue); +end; + +function TJS_String._toLowerCase: Variant; stdcall; +begin + result := LowerCase(fDefaultValue); +end; + +function TJS_String._Replace(const SearchValue, ReplaceValue: Variant): Variant; stdcall; +var + SearchStr, ReplaceStr: Variant; + X: TJS_ObjectBase; +begin + ReplaceStr := JS_ToString(ReplaceValue); + if JS_IsObject(SearchValue) then + begin + X := TJS_ObjectBase(TVarData(SearchValue).VInteger); + if X is TJS_Reference then + X := (X as TJS_Reference).GetValueAsObject(); + + if X is TJS_RegExp then + begin + result := TJS_RegExp(X).Replace(fDefaultValue, ReplaceStr); + end + else + begin + SearchStr := VarToStr((X as TJS_Object).fDefaultValue); + result := StringReplace(fDefaultValue, SearchStr, ReplaceStr, [rfReplaceAll]); + end; + end + else + begin + SearchStr := VarToStr(SearchValue); + result := StringReplace(fDefaultValue, SearchStr, ReplaceStr, [rfReplaceAll]); + end; +end; + +//-- TJS_Function -------------------------------------------------------------- + +constructor TJS_Function.InternalCreate(i_InternalFuncAddr: Pointer; + i_NP: Integer; + i_ProgPtr: Pointer); +begin + inherited Create; + + Typ := TYP_JS_FUNCTION; + + arguments := TJS_Array.Create([]); + arguments.Length := MaxArgs; + + InternalFuncAddr := i_InternalFuncAddr; + InternalLength := i_NP; + + if i_ProgPtr <> nil then + begin + Prog := TBaseRunner(i_ProgPtr^); + if Prog.ProgTag = 1 then // adding global objects + Prog.RootGC.AddObject(Self); + end; + + __this := nil; + CoolCall := 0; + DefaultNP := 0; +end; + +destructor TJS_Function.Destroy; +begin + FreeAndNil(arguments); + inherited; +end; + +function TJS_Function._toString: Variant; stdcall; +begin + result := 'Function[]'; +end; + +function TJS_Function.__toString: String; +begin + result := _toString(); +end; + +{$IFDEF PAXARM} +function TJS_Function.Invoke(const Params: array of Variant): Variant; stdcall; +begin +end; +{$ELSE} +{$IFDEF PAX64} +function TJS_Function.Invoke(const Params: array of Variant): Variant; stdcall; +var + I, NP: Integer; + A: array of Pointer; +begin + NP := Length(Params); + SetLength(A, NP); + for I := 0 to NP - 1 do + A[I] := @Params[I]; + AssignRBX(InternalFuncAddr); + Push_And_Call(NP, Self, Pointer(A), @result); +end; +{$ELSE} +function TJS_Function.Invoke(const Params: array of Variant): Variant; stdcall; +var + NP: Integer; + P, _Self, Res: Pointer; +begin + NP := Length(Params); + _Self := Self; + Res := @result; + P := @Params; + + Inc(Integer(P), (NP - 1) * VARIANT_SIZE); + + if NP > 0 then + asm + // push parameters + + mov edx, P + mov ecx, NP + @@loop: + + push edx + sub edx, VARIANT_SIZE + sub ecx, 1 + cmp ecx, 0 + jnz @@loop + end; + + asm + push NP + push _Self + push Res + call InternalCall + end; +end; +{$ENDIF} +{$ENDIF} + +{$IFDEF PAX64} +procedure Push_And_Call(NP: Integer; Instance, Params, RetAdr: Pointer); assembler; +asm + // Address = rbx + // np = rcx + // instance = rdx + // params = r8 + // RetAddr = r9 + + push rbp + + sub rsp, $100 + mov rbp, rsp + + cmp rcx, 0 + jnz @@Par1 + jmp @@Ret + +@@Par1: + cmp rcx, 1 + jnz @@Par2 + mov rcx, rdx + mov rdx, r9 + mov r10, r8 + mov r8, [r10] + call rbx + jmp @@Ret + +@@Par2: + cmp rcx, 2 + jnz @@Par3_or_More + mov rcx, rdx + mov rdx, r9 + mov r10, r8 + mov r8, [r10] + add r10, 8 + mov r9, [r10] + call rbx + jmp @@Ret + +@@Par3_or_More: + mov r15, rcx + mov rcx, rdx + mov rdx, r9 + mov r10, r8 + mov r8, [r10] + add r10, 8 + mov r9, [r10] + + sub r15, 1 + mov r11, $20 +@@loop: + add r10, 8 + mov r14, [r10] + mov [rsp + r11], r14 + + add r11, 8 + sub r15, 1 + jz @@Call + jmp @@loop + +@@Call: + call rbx + + @@Ret: + mov rsp, rbp + add rsp, $100 + pop rbp + ret +end; + +procedure Push_And_Call2(NP: Integer; Instance, Params, RetAdr: Pointer); assembler; +asm + // Address = rbx + // np = rcx + // instance = rdx + // params = r8 + // RetAddr = r9 + + push rbp + + sub rsp, $100 + mov rbp, rsp + + cmp rcx, 0 + jnz @@Par1 + jmp @@Ret + +@@Par1: + cmp rcx, 1 + jnz @@Par2 + mov rcx, rdx + mov rdx, r9 + mov r10, r8 + mov r8, r10 + call rbx + jmp @@Ret + +@@Par2: + cmp rcx, 2 + jnz @@Par3_or_More + mov rcx, rdx + mov rdx, r9 + mov r10, r8 + mov r8, r10 + add r10, VARIANT_SIZE + mov r9, r10 + call rbx + jmp @@Ret + +@@Par3_or_More: + mov r15, rcx + mov rcx, rdx + mov rdx, r9 + mov r10, r8 + mov r8, r10 + add r10, VARIANT_SIZE + mov r9, r10 + + sub r15, 1 + mov r11, $20 +@@loop: + add r10, VARIANT_SIZE + mov r14, r10 + mov [rsp + r11], r14 + + add r11, 8 + sub r15, 1 + jz @@Call + jmp @@loop + +@@Call: + call rbx + + @@Ret: + mov rsp, rbp + add rsp, $100 + pop rbp + ret +end; + +procedure AssignRBX(P: Pointer); assembler; +asm + mov rbx, P +end; + +procedure TJS_Function.InternalCall2(NP: Integer); +var + P, SelfPtr: Pointer; + I: Integer; + A: array[0..IntMaxArgs] of Variant; + temp: Pointer; + Q: PVariant; +begin + arguments.fLength := NP; + + temp := Pointer(Arguments.L.Arr); + Pointer(Arguments.L.Arr) := @A; + + P := ParArr; + for I:=0 to NP - 1 do + begin + Q := Pointer(P^); + A[I] := Variant(Q^); + Inc(IntPax(P), SizeOf(Pointer)); + end; + + P := InternalFuncAddr; + if __this <> nil then + begin + SelfPtr := __this; + __this := nil; + end + else + SelfPtr := Self; + AssignRBX(P); + Push_And_Call2(NP, Self, @ A, RetAdr); + Pointer(Arguments.L.Arr) := temp; +end; + +function TJS_Function.InternalCall(NP: Integer): Variant; stdcall; +asm + push rbp + sub rsp, $100 + mov rbp, rsp + + mov [rbp + $110], rcx // instance + mov [rbp + $118], rdx // ret addr + mov [rbp + $120], r8 // number of params + mov [rbp + $128], r9 // first param + + mov r10, rcx + add r10, RetAdr_OFFSET + mov [r10], rdx + + mov r10, rcx + add r10, ParArr_OFFSET + mov r11, rbp + add r11, $128 + mov [r10], r11 + + mov rdx, r8 + call TJS_Function.InternalCall2 + + lea rsp, [rbp + $100] + pop rbp + ret +end; +{$ELSE} +{$IFDEF PAXARM} +function TJS_Function.InternalCall(NP: Integer): Variant; stdcall; +begin +end; +{$ELSE} +function TJS_Function.InternalCall(NP: Integer): Variant; stdcall; + +var + Params: Pointer; + +procedure Nested; +var + P, Q, ResPtr, arg_ptr, SelfPtr, temp: Pointer; + I, NA: Integer; + A: array[0..IntMaxArgs] of Variant; +begin + arguments.fLength := NP; + + temp := Pointer(Arguments.L.Arr); + Pointer(Arguments.L.Arr) := @A; + + for I:=0 to NP - 1 do + begin + Inc(Integer(Params), 4); + Q := Pointer(Params^); + A[I] := Variant(Q^); + end; + +// make call + + P := InternalFuncAddr; + if __this <> nil then + begin + SelfPtr := __this; + __this := nil; + end + else + SelfPtr := Self; + + ResPtr := @Result; + NA := InternalLength; + + if DefaultNP > 0 then + NA := DefaultNP; + + arg_ptr := @A; + Inc(Integer(arg_ptr), (NA - 1) * 16); + + if NA > 0 then + asm + // push parameters + + mov edx, arg_ptr + mov ecx, NA + @@loop: + + push edx + sub edx, 16 + sub ecx, 1 + cmp ecx, 0 + jnz @@loop + end; + + asm + // push self ptr + push SelfPtr + + // push result ptr + push ResPtr + + call P + end; + Pointer(Arguments.L.Arr) := temp; +end; + +var + RetSize: Integer; + P: Pointer; +begin + if InternalFuncAddr = nil then + Exit; + + case CoolCall of + 1:if NP = InternalLength then // project2.dpr + begin + P := InternalFuncAddr; + asm + mov esp, ebp; + + pop esi // old ebp + pop edi // ret addr + pop ecx // result ptr + pop edx // self + + pop eax // np + + push edx + push ecx + + call P + + mov ebp, esi; + jmp edi; + end; + end; // CoolCall = 1 + end; + + asm + mov Params, ebp; + end; + + Inc(Integer(Params), 16); + + Nested; + + RetSize := 12 + NP * 4; + + asm + // emulate ret RetSize + mov ecx, RetSize + + mov esp, ebp + pop ebp + mov ebx, [esp] + + @@loop: + pop edx + sub ecx, 4 + jnz @@loop + pop edx + jmp ebx + end; +end; +{$ENDIF} +{$ENDIF} + +//-- Math ---------------------------------------------------------------------- + +constructor TJS_Math.Create; +begin + inherited; + Typ := TYP_JS_MATH; +end; + +function TJS_Math._abs(const P: Variant): Variant; stdcall; +var + V: Variant; +begin + V := JS_ToNumber(P); + if IsNaN(V) then + result := NaN + else if V >= 0 then + result := V + else + result := - V; +end; + +function TJS_Math._acos(const P: Variant): Variant; stdcall; +var + E: Extended; +begin + E := JS_ToNumberE(P); + if IsNaN(E) then + result := NaN + else if E > 1 then + result := NaN + else if E < -1 then + result := NaN + else + result := Math.ArcCos(E); +end; + +function TJS_Math._asin(const P: Variant): Variant; stdcall; +var + E: Extended; +begin + E := JS_ToNumberE(P); + if IsNaN(E) then + result := NaN + else if E > 1 then + result := NaN + else if E < -1 then + result := NaN + else + result := Math.ArcSin(E); +end; + +function TJS_Math._atan(const P: Variant): Variant; stdcall; +var + E: Extended; +begin + E := JS_ToNumberE(P); + if IsNaN(E) then + result := NaN + else + result := ArcTan(E); +end; + +function TJS_Math._atan2(const X, Y: Variant): Variant; stdcall; +var + VX, VY: Extended; +begin + VX := JS_ToNumberE(X); + VY := JS_ToNumberE(Y); + if IsNaN(VX) then + result := NaN + else if IsNaN(VY) then + result := NaN + else + result := Math.ArcTan2(VX, VY); +end; + +function TJS_Math._ceil(const P: Variant): Variant; stdcall; +var + E: Extended; +begin + E := JS_ToNumberE(P); + if IsNaN(E) then + result := NaN + else + result := Math.Ceil(E); +end; + +function TJS_Math._cos(const P: Variant): Variant; stdcall; +var + E: Extended; +begin + E := JS_ToNumberE(P); + if IsNaN(E) then + result := NaN + else + result := Cos(E); +end; + +function TJS_Math._exp(const P: Variant): Variant; stdcall; +var + E: Extended; +begin + E := JS_ToNumberE(P); + if IsNaN(E) then + result := NaN + else + result := Exp(E); +end; + +function TJS_Math._floor(const P: Variant): Variant; stdcall; +var + E: Extended; +begin + E := JS_ToNumberE(P); + if IsNaN(E) then + result := NaN + else + result := Math.Floor(E); +end; + +function TJS_Math._log(const P: Variant): Variant; stdcall; +var + E: Extended; +begin + E := JS_ToNumberE(P); + + if IsNaN(E) then + result := NaN + else if E < 0 then + result := NaN + else if E = 0 then + result := NegInfinity + else + result := ln(E); +end; + +function TJS_Math._max(P1, P2, P3, P4, P5: PVariant): Variant; stdcall; +var + V: Extended; +begin + result := NegInfinity; + + if Empty(P1) then + Exit; + V := JS_ToNumber(P1^); + if IsNan(V) then + begin + result := NaN; + Exit; + end; + + result := V; + + if Empty(P2) then + Exit; + V := JS_ToNumber(P2^); + if IsNan(V) then + begin + result := NaN; + Exit; + end; + if V > result then + result := V; + + if Empty(P3) then + Exit; + V := JS_ToNumber(P3^); + if IsNan(V) then + begin + result := NaN; + Exit; + end; + if V > result then + result := V; + + if Empty(P4) then + Exit; + V := JS_ToNumber(P4^); + if IsNan(V) then + begin + result := NaN; + Exit; + end; + if V > result then + result := V; + + if Empty(P5) then + Exit; + V := JS_ToNumber(P5^); + if IsNan(V) then + begin + result := NaN; + Exit; + end; + if V > result then + result := V; +end; + +function TJS_Math._min(P1, P2, P3, P4, P5: PVariant): Variant; stdcall; +var + V: Extended; +begin + result := Infinity; + + if Empty(P1) then + Exit; + V := JS_ToNumber(P1^); + if IsNan(V) then + begin + result := NaN; + Exit; + end; + + result := V; + + if Empty(P2) then + Exit; + V := JS_ToNumber(P2^); + if IsNan(V) then + begin + result := NaN; + Exit; + end; + if V < result then + result := V; + + if Empty(P3) then + Exit; + V := JS_ToNumber(P3^); + if IsNan(V) then + begin + result := NaN; + Exit; + end; + if V < result then + result := V; + + if Empty(P4) then + Exit; + V := JS_ToNumber(P4^); + if IsNan(V) then + begin + result := NaN; + Exit; + end; + if V < result then + result := V; + + if Empty(P5) then + Exit; + V := JS_ToNumber(P5^); + if IsNan(V) then + begin + result := NaN; + Exit; + end; + if V < result then + result := V; +end; + +function TJS_Math._pow(const X, Y: Variant): Variant; stdcall; +var + VX, VY: Extended; +begin + VX := JS_ToNumberE(X); + VY := JS_ToNumberE(Y); + + if IsNaN(VX) then + result := NaN + else if IsNaN(VY) then + result := NaN + else + result := Math.Power(VX, VY); +end; + +function TJS_Math._random: Variant; stdcall; +begin + result := Random(10000)/10000; +end; + +function TJS_Math._round(const P: Variant): Variant; stdcall; +var + V: Extended; +begin + V := JS_ToNumberE(P); + if IsNaN(V) then + result := NaN + else +{$IFDEF VARIANTS} + result := round(V); +{$ELSE} + result := Integer(round(V)); +{$ENDIF} +end; + +function TJS_Math._sin(const P: Variant): Variant; stdcall; +var + V: Extended; +begin + V := JS_ToNumberE(P); + if IsNaN(V) then + result := NaN + else + result := Sin(V); +end; + +function TJS_Math._sqrt(const P: Variant): Variant; stdcall; +var + V: Extended; +begin + V := JS_ToNumberE(P); + if IsNaN(P) then + result := NaN + else + result := Sqrt(V); +end; + +function TJS_Math._tan(const P: Variant): Variant; stdcall; +var + V: Extended; +begin + V := JS_ToNumberE(P); + if IsNaN(V) then + result := NaN + else + result := Math.tan(V); +end; + +// TJS_RegExp ------------------------------------------------------------------ + +{$IFDEF PAXARM} +constructor TJS_RegExp.Create(Source: PVariant = nil; Modifiers: PVariant = nil); +begin + inherited Create; + Typ := TYP_JS_REGEXP; +end; + +destructor TJS_RegExp.Destroy; +begin + inherited; +end; + +function TJS_RegExp.GetMatch(I: Integer): String; +begin + result := ''; + RIE; +end; + +function TJS_RegExp.GetMatchLen(I: Integer): Integer; +begin + result := 0; + RIE; +end; + +function TJS_RegExp.GetMatchPos(I: Integer): Integer; +begin + result := 0; + RIE; +end; + +function TJS_RegExp.GetSource: Variant; +begin + RIE; +end; + +procedure TJS_RegExp.SetSource(const Value: Variant); +begin + RIE; +end; + +function TJS_RegExp.GetInput: Variant; +begin + RIE; +end; + +procedure TJS_RegExp.SetInput(const Value: Variant); +begin + RIE; +end; + +function TJS_RegExp.GetGlobal: Boolean; +begin + result := false; + RIE; +end; + +procedure TJS_RegExp.SetGlobal(const Value: Boolean); +begin + RIE; +end; + +function TJS_RegExp.GetIgnoreCase: Boolean; +begin + result := false; + RIE; +end; + +procedure TJS_RegExp.SetIgnoreCase(const Value: Boolean); +begin + RIE; +end; + +function TJS_RegExp.GetMultiLine: Boolean; +begin + result := false; + RIE; +end; + +procedure TJS_RegExp.SetMultiLine(const Value: Boolean); +begin + RIE; +end; + +function TJS_RegExp.Test(const InputString: Variant): Boolean; +begin + result := false; + RIE; +end; + +procedure TJS_RegExp.Compile; +begin + RIE; +end; + +function TJS_RegExp.Exec(const InputString: Variant): TJS_Array; +begin + RIE; + result := nil; +end; + +function TJS_RegExp.Execute(const InputString: Variant): TJS_Array; +begin + RIE; + result := nil; +end; + +function TJS_RegExp.MatchCount: Integer; +begin + result := 0; + RIE; +end; + +function TJS_RegExp.Replace(const Expression, ReplaceStr: Variant): String; +begin + RIE; +end; + +function TJS_RegExp._toString: Variant; +begin + result := '/' + Source + '/'; + if Global then + result := result + 'g'; + if IgnoreCase then + result := result + 'i'; + if MultiLine then + result := result + 'm'; +end; + +function TJS_RegExp.__toString: String; +begin + result := _toString(); +end; + +{$ELSE} +constructor TJS_RegExp.Create(Source: PVariant = nil; Modifiers: PVariant = nil); +begin + inherited Create; + Typ := TYP_JS_REGEXP; + fRegExpr := TRegExpr.Create; + if Source <> nil then + SetSource(Source^); + fLastIndex := 1; + + if Modifiers = nil then + Exit; + + if Length(Modifiers^) = 0 then + begin + Global := false; + IgnoreCase := false; + MultiLine := false; + end + else + begin + Global := PosCh('g', UpperCase(Modifiers^)) > 0; + IgnoreCase := PosCh('i', UpperCase(Modifiers^)) > 0; + MultiLine := PosCh('m', UpperCase(Modifiers^)) > 0; + end; +end; + +destructor TJS_RegExp.Destroy; +begin + FreeAndNil(fRegExpr); + inherited; +end; + +function TJS_RegExp.GetMatch(I: Integer): String; +begin + result := fRegExpr.Match[I]; +end; + +function TJS_RegExp.GetMatchLen(I: Integer): Integer; +begin + result := fRegExpr.MatchLen[I]; +end; + +function TJS_RegExp.GetMatchPos(I: Integer): Integer; +begin + if fZERO_BASED_STRINGS then + result := fRegExpr.MatchPos[I] - 1 + else + result := fRegExpr.MatchPos[I]; +end; + +function TJS_RegExp.GetSource: Variant; +begin + result := fRegExpr.Expression; +end; + +procedure TJS_RegExp.SetSource(const Value: Variant); +begin + fRegExpr.Expression := Value; +end; + +function TJS_RegExp.GetInput: Variant; +begin + result := fRegExpr.InputString; +end; + +procedure TJS_RegExp.SetInput(const Value: Variant); +begin + fRegExpr.InputString := Value; +end; + +function TJS_RegExp.GetGlobal: Boolean; +begin + result := fRegExpr.ModifierG; +end; + +procedure TJS_RegExp.SetGlobal(const Value: Boolean); +begin + fRegExpr.ModifierG := Value; +end; + +function TJS_RegExp.GetIgnoreCase: Boolean; +begin + result := fRegExpr.ModifierI; +end; + +procedure TJS_RegExp.SetIgnoreCase(const Value: Boolean); +begin + fRegExpr.ModifierI := Value; +end; + +function TJS_RegExp.GetMultiLine: Boolean; +begin + result := fRegExpr.ModifierM; +end; + +procedure TJS_RegExp.SetMultiLine(const Value: Boolean); +begin + fRegExpr.ModifierM := Value; +end; + +function TJS_RegExp.Test(const InputString: Variant): Boolean; +begin + result := fRegExpr.Exec(InputString); +end; + +procedure TJS_RegExp.Compile; +begin + fRegExpr.Compile; +end; + +function TJS_RegExp.Exec(const InputString: Variant): TJS_Array; +var + I, L: Integer; + _InputString: String; +begin + _InputString := InputString; + + fRegExpr.InputString := _InputString; + L := Length(_InputString); + if LastIndex >= L then + begin + LastIndex := 1; + result := TJS_Array.Create([]); + result.prog := prog; + result.AddToGC; + result.length := 0; + + result.PutProperty('lastIndex', LastIndex); + result.PutProperty('inputString', InputString); + Exit; + end; + + if fRegExpr.ExecPos(LastIndex) then + begin + result := TJS_Array.Create([]); + result.prog := prog; + result.AddToGC; + + for I:=0 to fRegExpr.SubExprMatchCount do + result.PutArrProperty(I, fRegExpr.Match[I]); + + if fZERO_BASED_STRINGS then + begin + with fRegExpr do + if MatchLen[0] = 0 then + LastIndex := MatchPos[0] + else + LastIndex := MatchPos[0] + MatchLen[0]; + + result.PutProperty('index', fRegExpr.MatchPos[0] - 1); + result.PutProperty('lastIndex', LastIndex - 1); + end + else + begin + with fRegExpr do + if MatchLen[0] = 0 then + LastIndex := MatchPos[0] + 1 + else + LastIndex := MatchPos[0] + MatchLen[0] + 1; + + result.PutProperty('index', fRegExpr.MatchPos[0]); + result.PutProperty('lastIndex', LastIndex); + end; + + result.PutProperty('inputString', InputString); + end + else + begin + result := TJS_Array.Create([]); + result.prog := prog; + result.AddToGC; + result.length := 0; + result.PutProperty('lastIndex', LastIndex); + result.PutProperty('lnputString', InputString); + end; +end; + +function TJS_RegExp.Execute(const InputString: Variant): TJS_Array; +var + I: Integer; + P: TIntegerList; +begin + fRegExpr.InputString := InputString; + P := TIntegerList.Create; + try + if fRegExpr.Exec(InputString) then + begin + repeat + P.Add(fRegExpr.MatchPos[0]); + until not fRegExpr.ExecNext; + end; + result := TJS_Array.Create([]); + result.prog := prog; + result.AddToGC; + for I:=0 to P.Count - 1 do + result.PutArrProperty(I, P[I]); + finally + FreeAndNil(P); + end; +end; + +function TJS_RegExp.MatchCount: Integer; +begin + result := fRegExpr.SubExprMatchCount; +end; + +function TJS_RegExp.Replace(const Expression, ReplaceStr: Variant): String; +begin + result := fRegExpr.Replace(Expression, ReplaceStr); +end; + +function TJS_RegExp._toString: Variant; +begin + result := '/' + Source + '/'; + if Global then + result := result + 'g'; + if IgnoreCase then + result := result + 'i'; + if MultiLine then + result := result + 'm'; +end; + +function TJS_RegExp.__toString: String; +begin + result := _toString(); +end; +{$ENDIF} +//------------------------------------------------------------------------------ + +procedure _alert(Prog: TBaseRunner; + P1: PVariant; + P2: PVariant = nil; + P3: PVariant = nil; + P4: PVariant = nil; + P5: PVariant = nil); stdcall; + +function Show(P: PVariant): Boolean; +begin + result := P <> nil; + if result then + result := VarType(P^) <> varEmpty; + + if result then + ErrMessageBox(JS_ToString(P^)); +end; + +begin + if Assigned(Prog.OnPrint) then + Prog.OnPrint(Prog.Owner, JS_ToString(P1^)) + else + ErrMessageBox(JS_ToString(P1^)); + + if not Show(P2) then Exit; + if not Show(P3) then Exit; + if not Show(P4) then Exit; + if not Show(P5) then Exit; +end; + +procedure _WriteObject(const value: TObject); +var + S: String; +begin + if value = nil then + begin + write('undefined'); + end + else if value is TJS_Object then + begin + S := value.ClassName; + S := 'object ' + Copy(S, 5, Length(S) - 4); + write('[' + S + ']'); + end + else + begin + S := 'object ' + value.ClassName; + write('[' + S + ']'); + end; +end; + +{$IFDEF PAX64} +procedure _GetGenericPropertyEx(Prog: TBaseRunner; + var VObject: Variant; + PropName: PChar; + NP: Integer; + var Result: Variant; + Params: Pointer); +var + b: Boolean; + I, VT: Integer; + S: String; + E: Extended; + X, Y: TJS_Object; + result_addr: Pointer; + Q: Pointer; +begin + b := JS_IsObject(VObject); + if not b then + begin + VT := VarType(VObject); + case VT of + varUString, varString, varOleStr: + begin + S := VObject; + _JS_ToObject(Prog, @S, typeSTRING, @VObject); + b := JS_IsObject(VObject); + end; + varSmallInt, varInteger, varByte, varShortInt, + varWord, varLongWord: + begin + I := VObject; + _JS_ToObject(Prog, @I, typeINTEGER, @VObject); + b := JS_IsObject(VObject); + end; + varSingle, varDouble, varCurrency: + begin + E:= VObject; + _JS_ToObject(Prog, @E, typeEXTENDED, @VObject); + b := JS_IsObject(VObject); + end; + end; + end; + + if b then + begin + case NP of + 0: + begin + X := TJS_Object(TVarData(VObject).VInteger); + result := X.L.GetProperty(PropName)^; + + if JS_IsObject(result) then + begin + Y := TJS_Object(TVarData(result).VInteger); + if Y is TJS_Function then + begin + (Y as TJS_Function).__this := X; + end; + end; + Exit; + end; + 1: + begin + X := TJS_Object(TVarData(VObject).VInteger); + Y := X.GetPropertyAsObject(PropName); + + if Y is TJS_Function then + begin + (Y as TJS_Function).__this := X; + result_addr := @result; +// asm +// jmp TJS_Function.InternalCall +// end; + end; + + Q := Pointer(Params^); + + VT := TVarData(Q^).VType; + if VT = varString then + result := Y.L.GetProperty(PChar(TVarData(Q^).VString))^ + else if VT in VarIntTypes then + result := Y.L.GetArrProperty(TVarData(Q^).VInteger)^ + else + result := Y.GetVarProperty(JS_ToString(Variant(Q^))); + end; + else + begin + X := TJS_Object(TVarData(VObject).VInteger); + Y := X.GetPropertyAsObject(PropName); + + if Y is TJS_Function then + begin + (Y as TJS_Function).__this := X; + result_addr := @result; +// asm +// jmp TJS_Function.InternalCall +// end; + end; + + result := Undefined; + end; + end; // case NP + end + else if Assigned(GetOlePropProc) then + begin + RaiseNotImpl; + end + else + result := Undefined; +end; + +procedure _GetGenericProperty(Prog: TBaseRunner; + var VObject: Variant; + PropName: PChar; + NP: Integer); assembler; +// r10 = result +asm + push rbp + sub rsp, $40 + mov rbp, rsp + + mov [rsp + $20], r10 // result + mov [rsp + $28], rax // address of params + + call _GetGenericPropertyEx + + mov rsp, rbp + add rsp, $40 + pop rbp + ret +end; +{$ELSE} +{$IFNDEF PAXARM} +procedure _GetGenericProperty(Prog: TBaseRunner; + var VObject: Variant; + PropName: PChar; + NP: Integer; + var Result: Variant); stdcall; +var + X, Y: TJS_Object; + P, Q: Pointer; + VT, RetSize: Integer; + b: Boolean; + S: String; + I: Integer; + E: Extended; + result_addr: Pointer; +begin + asm + mov P, ebp + end; + + b := JS_IsObject(VObject); + if not b then + begin + VT := VarType(VObject); + case VT of + varUString, varString, varOleStr: + begin + S := VObject; + _JS_ToObject(Prog, @S, typeSTRING, @VObject); + b := JS_IsObject(VObject); + end; + varSmallInt, varInteger, varByte, varShortInt, + varWord, varLongWord: + begin + I := VObject; + _JS_ToObject(Prog, @I, typeINTEGER, @VObject); + b := JS_IsObject(VObject); + end; + varSingle, varDouble, varCurrency: + begin + E:= VObject; + _JS_ToObject(Prog, @E, typeEXTENDED, @VObject); + b := JS_IsObject(VObject); + end; + end; + end; + + if b then + begin + case NP of + 0: + begin + X := TJS_Object(TVarData(VObject).VInteger); + result := X.L.GetProperty(PropName)^; + + if JS_IsObject(result) then + begin + Y := TJS_Object(TVarData(result).VInteger); + if Y is TJS_Function then + begin + (Y as TJS_Function).__this := X; + end; + end; + Exit; + end; + 1: + begin + X := TJS_Object(TVarData(VObject).VInteger); + Y := X.GetPropertyAsObject(PropName); + + if Y is TJS_Function then + begin + (Y as TJS_Function).__this := X; + result_addr := @result; + asm + mov eax, NP + mov edx, Y + mov ecx, result_addr + + mov esp, ebp + pop ebp // restore old ebp + + pop ebx // pop ret addr + mov [ebp - 512], ebx // save ret address + + pop ebx // pop 5 parametes + pop ebx + pop ebx + pop ebx + pop ebx + + push eax // np + push edx // instance + push ecx // result + + mov ebx, [ebp - 512] + push ebx + jmp TJS_Function.InternalCall + end; + end; + + Inc(Integer(P), 28); + Q := Pointer(P^); + + VT := TVarData(Q^).VType; + if VT = varString then + result := Y.L.GetProperty(PChar(TVarData(Q^).VString))^ + else if VT in VarIntTypes then + result := Y.L.GetArrProperty(TVarData(Q^).VInteger)^ + else + result := Y.GetVarProperty(JS_ToString(Variant(Q^))); + asm + mov esp, ebp + pop ebp + ret 24 + end; + end; + else + begin + X := TJS_Object(TVarData(VObject).VInteger); + Y := X.GetPropertyAsObject(PropName); + + if Y is TJS_Function then + begin + (Y as TJS_Function).__this := X; + result_addr := @result; + asm + mov eax, NP + mov edx, Y + mov ecx, result_addr + + mov esp, ebp + pop ebp // restore old ebp + + pop ebx // pop ret addr + mov [ebp - 512], ebx // save ret address + + pop ebx // pop 5 parametes + pop ebx + pop ebx + pop ebx + pop ebx + + push eax // np + push edx // instance + push ecx // result + + mov ebx, [ebp - 512] + push ebx + jmp TJS_Function.InternalCall + end; + end; + + result := Undefined; + end; + end; // case NP + end + else if Assigned(GetOlePropProc) then + begin + Inc(Integer(P), 28); + + if NP > 0 then + asm + mov edx, P + mov ecx, NP + @@loop: + + mov eax, [edx] + push eax + add edx, 4 + + sub ecx, 1 + cmp ecx, 0 + jnz @@loop + end; + + GetOlePropProc(VObject, + PropName, + result, + NP); + end + else + result := Undefined; + + + RetSize := 20 + NP * 4; + + asm + // emulate ret RetSize + mov ecx, RetSize + + mov esp, ebp + pop ebp + mov ebx, [esp] + + @@loop: + pop edx + sub ecx, 4 + jnz @@loop + pop edx + jmp ebx + end; +end; +{$ENDIF} +{$ENDIF} + +{$IFDEF PAX64} + +procedure _PutGenericPropertyEx(const VObject: Variant; + PropName: PChar; + NP: Integer; + const Value: Variant; + Params: Pointer); +var + X: TJS_Object; + Q: Pointer; + VT: Integer; +begin + if JS_IsObject(VObject) then + begin + case NP of + 0: + begin + X := TJS_Object(TVarData(VObject).VInteger); + X.L.PutProperty(PropName, Value); + Exit; + end; + 1: + begin + Q := Pointer(Params^); + X := TJS_Object(TVarData(VObject).VInteger); + X := X.GetPropertyAsObject(PropName); + VT := TVarData(Q^).VType; + if VT = varString then + X.L.PutProperty(PChar(TVarData(Q^).VString), Value) + else if VT in VarIntTypes then + X.L.PutArrProperty(TVarData(Q^).VInteger, Value) + else + X.PutVarProperty(JS_ToString(Variant(Q^)), Value); + end; + end; // case NP + end + else + RaiseNotImpl; +end; + +procedure _PutGenericProperty(const VObject: Variant; + PropName: PChar; + NP: Integer; + const Value: Variant); assembler; +asm + push rbp + sub rsp, $30 + mov rbp, rsp + + mov [rsp + $20], rax // address of params + + call _PutGenericPropertyEx + + mov rsp, rbp + add rsp, $30 + pop rbp + ret +end; +{$ELSE} +{$IFNDEF PAXARM} +procedure _PutGenericProperty(const VObject: Variant; + PropName: PChar; + NP: Integer; + const Value: Variant); stdcall; +var + X: TJS_Object; + P, Q: Pointer; + RetSize, VT: Integer; +begin + asm + mov P, ebp + end; + + if JS_IsObject(VObject) then + begin + case NP of + 0: + begin + X := TJS_Object(TVarData(VObject).VInteger); + X.L.PutProperty(PropName, Value); + Exit; + end; + 1: + begin + Inc(Integer(P), 24); + Q := Pointer(P^); + X := TJS_Object(TVarData(VObject).VInteger); + X := X.GetPropertyAsObject(PropName); + VT := TVarData(Q^).VType; + if VT = varString then + X.L.PutProperty(PChar(TVarData(Q^).VString), Value) + else if VT in VarIntTypes then + X.L.PutArrProperty(TVarData(Q^).VInteger, Value) + else + X.PutVarProperty(JS_ToString(Variant(Q^)), Value); + asm + mov esp, ebp + pop ebp + ret 20 + end; + end; + end; // case NP + end + else + begin + Inc(Integer(P), 24); + + if NP > 0 then + asm + mov edx, P + mov ecx, NP + @@loop: + + mov eax, [edx] + push eax + add edx, 4 + + sub ecx, 1 + cmp ecx, 0 + jnz @@loop + end; + + PutOlePropProc(VObject, + PropName, + Value, + NP); + end; + + RetSize := 16 + NP * 4; + + asm + // emulate ret RetSize + mov ecx, RetSize + + mov esp, ebp + pop ebp + mov ebx, [esp] + + @@loop: + pop edx + sub ecx, 4 + jnz @@loop + pop edx + jmp ebx + end; +end; +{$ENDIF} +{$ENDIF} +procedure _JS_TypeOf(V: PVariant; + result: PString); stdcall; +var + JS_Object: TJS_Object; +begin + if JS_IsString(V^) then + result^ := 'string' + else if JS_IsBoolean(V^) then + result^ := 'boolean' + else if JS_IsNumber(V^) then + result^ := 'number' + else if JS_IsObject(V^) then + begin + JS_Object := TJS_Object(TVarData(V^).VInteger); + if JS_Object is TJS_Function then + result^ := 'function' + else + result^ := 'object'; + end + else + result^ := 'undefined'; +end; + +procedure _JS_Void(var V: Variant; + var result: Variant); stdcall; +begin + VarClear(result); +end; + +procedure _JS_Delete(VObject: PVariant; + Prop: PString); stdcall; +begin +end; + +procedure _JS_GetNextProp(VObject: PVariant; + Prop: PString; + result: PBoolean); stdcall; +var + I: Integer; + JS_Array: TJS_Array; + JS_Object: TJS_Object; + LA: Integer; +begin + JS_Object := TJS_Object(TVarData(VObject^).VInteger); + I := JS_Object.NextPropIndex; + Inc(I); + if JS_Object is TJS_Array then + begin + JS_Array := TJS_Array(JS_Object); + if I > JS_Array.Length then + begin + JS_Object.NextPropIndex := -1; + result^ := false; + end + else + begin + Prop^ := IntToStr(I); + JS_Object.NextPropIndex := I; + result^ := true; + end; + end + else + begin + LA := System.Length(JS_Object.L.HashTable.A); + with JS_Object.L.HashTable do + repeat + if I >= LA then + begin + JS_Object.NextPropIndex := -1; + result^ := false; + Exit; + end; + + if A[I] = nil then + begin + Inc(I); + continue; + end + else + begin + Prop^ := A[I].Key; + JS_Object.NextPropIndex := I; + result^ := true; + Exit; + end; + until false; + end; +end; + +procedure _JS_ToObject(P:TBaseRunner; Address: Pointer; FinTypeId: Integer; + result: PVariant); stdcall; +var + V: Variant; + XS: TJS_String; + XN: TJS_Number; + XB: TJS_Boolean; + I: Integer; + VT: Word; +begin + case FinTypeId of + typeCLASS: + begin + result^ := VarFromClass(TJS_ObjectBase(Address^)); + end; + typePOINTER: + begin + V := String(PChar(Address^)); + XS := TJS_String.Create(@ V); + XS.prog := P; + XS.prototype := P.JS_String as TJS_Object; + result^ := VarFromClass(XS); + end; +{$IFNDEF PAXARM} + typeANSISTRING: + begin + V := String(Address^); + XS := TJS_String.Create(@ V); + XS.prog := P; + XS.prototype := P.JS_String as TJS_Object; + result^ := VarFromClass(XS); + end; + typeWIDESTRING: + begin + V := WideString(Address^); + XS := TJS_String.Create(@ V); + XS.prog := P; + XS.prototype := P.JS_String as TJS_Object; + result^ := VarFromClass(XS); + end; +{$ENDIF} + typeUNICSTRING: + begin + V := String(Address^); + XS := TJS_String.Create(@ V); + XS.prog := P; + XS.prototype := P.JS_String as TJS_Object; + result^ := VarFromClass(XS); + end; + typeINTEGER: + begin + V := Integer(Address^); + XN := TJS_Number.Create(@ V); + XN.prog := P; + XN.prototype := P.JS_Number as TJS_Object; + result^ := VarFromClass(XN); + end; + typeBYTE: + begin + V := Byte(Address^); + XN := TJS_Number.Create(@ V); + XN.prog := P; + XN.prototype := P.JS_Number as TJS_Object; + result^ := VarFromClass(XN); + end; + typeWORD: + begin + V := Word(Address^); + XN := TJS_Number.Create(@ V); + XN.prog := P; + XN.prototype := P.JS_Number as TJS_Object; + result^ := VarFromClass(XN); + end; + typeCARDINAL: + begin +{$IFDEF VARIANTS} + V := Cardinal(Address^); +{$ELSE} + V := Integer(Address^); +{$ENDIF} + XN := TJS_Number.Create(@ V); + XN.prog := P; + XN.prototype := P.JS_Number as TJS_Object; + result^ := VarFromClass(XN); + end; + typeINT64: + begin + I := Int64(Address^); + V := I; + XN := TJS_Number.Create(@ V); + XN.prog := P; + XN.prototype := P.JS_Number as TJS_Object; + result^ := VarFromClass(XN); + end; + typeDOUBLE: + begin + V := Double(Address^); + XN := TJS_Number.Create(@ V); + XN.prog := P; + XN.prototype := P.JS_Number as TJS_Object; + result^ := VarFromClass(XN); + end; + typeSINGLE: + begin + V := Single(Address^); + XN := TJS_Number.Create(@ V); + XN.prog := P; + XN.prototype := P.JS_Number as TJS_Object; + result^ := VarFromClass(XN); + end; + typeCURRENCY: + begin + V := Currency(Address^); + XN := TJS_Number.Create(@ V); + XN.prog := P; + XN.prototype := P.JS_Number as TJS_Object; + result^ := VarFromClass(XN); + end; + typeEXTENDED: + begin + V := Extended(Address^); + XN := TJS_Number.Create(@ V); + XN.prog := P; + XN.prototype := P.JS_Number as TJS_Object; + result^ := VarFromClass(XN); + end; + typeBOOLEAN: + begin + V := Boolean(Address^); + XB := TJS_Boolean.Create(@ V); + XB.prog := P; + XB.prototype := P.JS_Boolean as TJS_Object; + result^ := VarFromClass(XB); + end; + typeVARIANT: + begin + VT := TVarData(Address^).VType; + case VT of + varInteger, varSmallInt, varShortInt, varByte, varWord, varLongWord, + varInt64, + varSingle, varDouble, varCurrency, varDate: + begin + XN := TJS_Number.Create(PVariant(Address)); + XN.prog := P; + XN.prototype := P.JS_Number as TJS_Object; + result^ := VarFromClass(XN); + end; + varBoolean: + begin + XB := TJS_Boolean.Create(PVariant(Address)); + XB.prog := P; + XB.prototype := P.JS_Boolean as TJS_Object; + result^ := VarFromClass(XB); + end; + varString, varOleStr, varUString: + begin + XS := TJS_String.Create(PVariant(Address)); + XS.prog := P; + XS.prototype := P.JS_String as TJS_Object; + result^ := VarFromClass(XS); + end; + varClass: + begin + result^ := Variant(Address^); + end; + else + RaiseError(errCannotConvertToJS_Object, []); + end; + end; + else + RaiseError(errCannotConvertToJS_Object, []); + end; +end; + +procedure _VariantClr(var V: Variant); stdcall; +//var +// X: TJS_Object; +begin +{ + if JS_IsObject(V) then + begin + X := TJS_Object(TVarData(V).VInteger); + if X <> nil then + begin + X.Free; + TVarData(V).VInteger := 0; + end; + end; +} + VarClear(V); +end; + +procedure _PushContext(P: TBaseRunner; value: PVariant); stdcall; +var + X: TObject; +begin + X := TObject(TVarData(value^).VInteger); + + if X is TJS_Reference then + X := TJS_Reference(X).GetValueAsObject(); + + P.ContextList.Add(X); +end; + +procedure _PopContext(P: TBaseRunner); stdcall; +begin + P.ContextList.Delete(P.ContextList.Count - 1); +end; + +procedure _FindContext(P: TBaseRunner; PropName: PChar; + AltAddress: Pointer; + FinTypeId: Integer; + result: PVariant); stdcall; +var + I: Integer; + X: TJS_Object; +{$IFDEF ARC} + L: TList; +{$ELSE} + L: TList; +{$ENDIF} + R: TJS_Reference; +begin + L := P.ContextList; + for I := L.Count - 1 downto 0 do + if TObject(L[I]) is TJS_Object then + begin + X := TJS_Object(L[I]); + if X.HasProperty(PropName) then + begin + R := TJS_Reference.Create(typeVARIANT); + R.Address := X.L.LastPropAddress; + P.RootGC.AddReference(R); + +// R.Base := X; +// R.PropName := PropName; + + result^ := VarFromClass(R); + Exit; + end; + end; + R := TJS_Reference.Create(FinTypeId); + R.Address := AltAddress; + P.RootGC.AddReference(R); + result^ := VarFromClass(R); +end; + +procedure _FindFunc(P: TBaseRunner; PropName: PChar; + Alt, result: PVariant); stdcall; +var + I: Integer; + X: TJS_Object; +{$IFDEF ARC} + L: TList; +{$ELSE} + L: TList; +{$ENDIF} +begin + L := P.ContextList; + for I := L.Count - 1 downto 0 do + begin + if TObject(L[I]) is TJS_Object then + begin + X := TJS_Object(L[I]); + if X.HasProperty(PropName) then + begin + result^ := X.GetProperty(PropName); + if TVarData(result^).VInteger <> 0 then +{$IFDEF PAX64} + TJS_Function(TVarData(result^).VInt64).__this := X; +{$ELSE} + TJS_Function(TVarData(result^).VInteger).__this := X; +{$ENDIF} + Exit; + end; + end; + end; + result^ := Alt^; +end; + +// overriden routines - begin + +procedure _VarArrayPut1(var V: Variant; var value: Variant; const I1: Variant); +stdcall; +var + X: TJS_Object; + S: String; +begin + if JS_IsObject(V) then + begin + X := TJS_Object(TVarData(V).VInteger); + if VarType(I1) in VarIntTypes then + X.PutArrProperty(I1, Value) + else + begin + S := JS_ToString(I1); + X.PutProperty(PChar(S), Value); + end; + end + else + V[I1] := value; +end; + +procedure _VarArrayGet1(var V: Variant; var result: Variant; const I1: Variant); +stdcall; +var + X: TJS_Object; + S: String; +begin + if JS_IsObject(V) then + begin + X := TJS_Object(TVarData(V).VInteger); + if VarType(I1) in VarIntTypes then + result := X.GetArrProperty(I1) + else + begin + S := JS_ToString(I1); + result := X.GetProperty(PChar(S)); + end; + end + else + result := V[I1]; +end; + +procedure _VarArrayPut2(var V: Variant; var value: Variant; const I2, I1: Variant); +stdcall; +begin + V[I1, I2] := value; +end; + +procedure _VarArrayGet2(var V: Variant; var result: Variant; const I2, I1: Variant); +stdcall; +begin + result := V[I1, I2]; +end; + +procedure _VarArrayPut3(var V: Variant; var value: Variant; const I3, I2, I1: Variant); +stdcall; +begin + V[I1, I2, I3] := value; +end; + +procedure _VarArrayGet3(var V: Variant; var result: Variant; const I3, I2, I1: Variant); +stdcall; +begin + result := V[I1, I2, I3]; +end; + +procedure _VariantFromPWideChar(source: PWideChar; dest: PVariant); stdcall; +begin + if JS_IsRef(dest^) then + JS_PutValue(dest^, UnicString(Source)) + else + dest^ := UnicString(Source); +end; + +{$IFNDEF PAXARM} +procedure _VariantFromPAnsiChar(source: PAnsiChar; dest: PVariant); stdcall; +begin + if JS_IsRef(dest^) then + JS_PutValue(dest^, AnsiString(Source)) + else + dest^ := AnsiString(Source); +end; + +procedure _VariantFromAnsiString(Dest: PVariant; Source: PAnsiString); stdcall; +begin + if JS_IsRef(dest^) then + JS_PutValue(dest^, Source^) + else + Dest^ := Source^; +end; + +procedure _VariantFromWideString(Dest: PVariant; Source: PWideString); stdcall; +begin + if JS_IsRef(dest^) then + JS_PutValue(dest^, Source^) + else + Dest^ := Source^; +end; + +procedure _VariantFromAnsiChar(source: AnsiChar; dest: PVariant); stdcall; +begin + if JS_IsRef(dest^) then + JS_PutValue(dest^, Source) + else + dest^ := source; +end; +{$ENDIF} + +procedure _VariantFromInterface(const source: IDispatch; dest: PVariant); stdcall; +begin + if JS_IsRef(dest^) then + JS_PutValue(dest^, Source) + else + dest^ := Source; +end; + +procedure _VariantFromShortString(Dest: PVariant; Source: PShortString); stdcall; +begin + if JS_IsRef(dest^) then + JS_PutValue(dest^, StringFromPShortString(Source)) + else + Dest^ := StringFromPShortString(Source); +end; + +procedure _VariantFromUnicString(Dest: PVariant; Source: PUnicString); stdcall; +begin + if JS_IsRef(dest^) then + JS_PutValue(dest^, Source^) + else + Dest^ := Source^; +end; + +procedure _VariantFromWideChar(source: WideChar; dest: PVariant); stdcall; +begin + if JS_IsRef(dest^) then + JS_PutValue(dest^, Source) + else + dest^ := source; +end; + +procedure _VariantFromInt(source: Integer; dest: PVariant); stdcall; +begin + if JS_IsRef(dest^) then + JS_PutValue(dest^, Source) + else + dest^ := source; +end; + +{$IFDEF VARIANTS} +procedure _VariantFromInt64(dest: PVariant; source: PInt64); stdcall; +begin + if JS_IsRef(dest^) then + JS_PutValue(dest^, Source^) + else + dest^ := source^; +end; +{$ELSE} +procedure _VariantFromInt64(dest: PVariant; source: PInt64); stdcall; +begin + if JS_IsRef(dest^) then + JS_PutValue(dest^, Integer(Source^)) + else + dest^ := Integer(source^); +end; +{$ENDIF} + +procedure _VariantFromByte(source: Byte; dest: PVariant); stdcall; +begin + if JS_IsRef(dest^) then + JS_PutValue(dest^, Source) + else + dest^ := source; +end; + +procedure _VariantFromBool(source: Boolean; dest: PVariant); stdcall; +begin + if JS_IsRef(dest^) then + JS_PutValue(dest^, Source) + else + dest^ := source; +end; + +procedure _VariantFromWord(source: Word; dest: PVariant); stdcall; +begin + if JS_IsRef(dest^) then + JS_PutValue(dest^, Source) + else + dest^ := source; +end; + +procedure _VariantFromCardinal(source: Cardinal; dest: PVariant); stdcall; +begin +{$IFDEF VARIANTS} + if JS_IsRef(dest^) then + JS_PutValue(dest^, Source) + else + dest^ := source; +{$ELSE} + if JS_IsRef(dest^) then + JS_PutValue(dest^, Integer(Source)) + else + dest^ := Integer(source); +{$ENDIF} +end; + +procedure _VariantFromSmallInt(source: SmallInt; dest: PVariant); stdcall; +begin + if JS_IsRef(dest^) then + JS_PutValue(dest^, Source) + else + dest^ := source; +end; + +procedure _VariantFromShortInt(source: ShortInt; dest: PVariant); stdcall; +begin + if JS_IsRef(dest^) then + JS_PutValue(dest^, Source) + else + dest^ := source; +end; + +procedure _VariantFromDouble(dest: PVariant; source: PDouble); stdcall; +begin + if JS_IsRef(dest^) then + JS_PutValue(dest^, Source^) + else + dest^ := source^; +end; + +procedure _VariantFromCurrency(dest: PVariant; source: PCurrency); stdcall; +begin + if JS_IsRef(dest^) then + JS_PutValue(dest^, Source^) + else + dest^ := source^; +end; + +procedure _VariantFromSingle(dest: PVariant; source: PSingle); stdcall; +begin + if JS_IsRef(dest^) then + JS_PutValue(dest^, Source^) + else + dest^ := source^; +end; + +procedure _VariantFromExtended(dest: PVariant; source: PExtended); stdcall; +begin + if JS_IsRef(dest^) then + JS_PutValue(dest^, Source^) + else + dest^ := source^; +end; + +procedure _VariantAssign(dest, source: PVariant); stdcall; +var + IsRefSource, IsRefDest, IsObjectDest, IsObjectSource: Boolean; + Y: TJS_Object; + temp: Variant; +begin + if VarIsNull(source^) then + begin + VarClear(dest^); + end; + + IsRefSource := JS_IsRef(source^); + IsRefDest := JS_IsRef(dest^); + + if IsRefSource and IsRefDest then + JS_PutValue(dest^, JS_GetValue(Source^)) + else if IsRefDest then + JS_PutValue(dest^, Source^) + else if IsRefSource then + begin + temp := JS_GetValue(Source^); + IsObjectDest := JS_IsObject(dest^); + IsObjectSource := JS_IsObject(temp); + if IsObjectDest and IsObjectSource then + GC_Assign(PGC_Object(@TVarData(Dest^).VInteger), + TJS_Object(TVarData(temp).VInteger)) + else if IsObjectDest then + begin + _ClassFromVariant(@Y, @temp); + GC_Assign(PGC_Object(@TVarData(Dest^).VInteger), TGC_Object(Y)); + if TVarData(Dest^).VInteger <> 0 then + TVarData(Dest^).VType := varClass; + end + else if IsObjectSource then + begin + Y := TJS_Object(TVarData(temp).VInteger); + GC_Assign(PGC_Object(@TVarData(Dest^).VInteger), TGC_Object(Y)); + if TVarData(Dest^).VInteger <> 0 then + TVarData(Dest^).VType := varClass; + end + else + dest^ := temp; + end + else + begin + IsObjectDest := JS_IsObject(dest^); + IsObjectSource := JS_IsObject(source^); + if IsObjectDest and IsObjectSource then + GC_Assign(PGC_Object(@TVarData(Dest^).VInteger), + TJS_Object(TVarData(Source^).VInteger)) + else if IsObjectDest then + begin + _ClassFromVariant(@Y, @Source); + GC_Assign(PGC_Object(@TVarData(Dest^).VInteger), TGC_Object(Y)); + if TVarData(Dest^).VInteger <> 0 then + TVarData(Dest^).VType := varClass + end + else if IsObjectSource then + begin + Y := TJS_Object(TVarData(Source^).VInteger); + GC_Assign(PGC_Object(@TVarData(Dest^).VInteger), Y); + if TVarData(Dest^).VInteger <> 0 then + TVarData(Dest^).VType := varClass; + end + else + dest^ := source^; + end; +end; + +procedure _ClassAssign(dest, source: PObject); stdcall; +var + IsGCSource, IsGCDest: Boolean; +begin + if source^ = nil then + begin + if dest^ = nil then + Exit; + + if dest^ is TGC_Object then + GC_Assign(PGC_Object(dest), nil) + else + begin + FreeAndNil(dest^); + end; + + Exit; + end; + + if dest^ = nil then + begin + if source^ = nil then + Exit; + if source^ is TGC_Object then + begin + TGC_Object(source^).AddRef; + dest^ := source^; + end + else + dest^ := source^; + + Exit; + end; + + IsGCSource := source^ is TGC_Object; + IsGCDest := dest^ is TGC_Object; + + if IsGCSource and IsGCDest then + GC_Assign(PGC_Object(dest), TGC_Object(source)) + else + dest^ := source^; +end; + +// overriden routines - end + +procedure _AssignProg(X: TJS_Object; P: TBaseRunner); stdcall; +begin + X.prog := P; + X.AddToGC; +end; + +procedure _VariantFromClass(Dest: PVariant; + SourceAddress: Pointer); stdcall; +begin + VarClear(dest^); + with TVarData(dest^) do + begin + VType := varClass; + VInteger := IntPax(SourceAddress^); + end; +end; + +procedure _ClassFromVariant(DestAddress: Pointer; + Source: PVariant); stdcall; +var + V: Variant; +begin + if TVarData(source^).VType = varClass then + begin + TObject(DestAddress^) := TObject(TVarData(source^).VInteger); + if TObject(DestAddress^) is TJS_Reference then + begin + V := TJS_Reference(DestAddress^).GetValue(); + if TVarData(V).VType = varClass then + TObject(DestAddress^) := TObject(TVarData(V).VInteger) + else + TObject(DestAddress^) := nil; + end; + end + else + TObject(DestAddress^) := nil; +end; + + +function GetVariantValue(Address: Pointer; FinTypeId: Integer): Variant; +begin + case FinTypeId of + typeBOOLEAN: result := Boolean(Address^); + typeBYTE: result := Byte(Address^); + typeWORD: result := Word(Address^); + typeINTEGER: result := Integer(Address^); + typeDOUBLE: result := Double(Address^); + typePOINTER: result := Integer(Address^); + typeENUM: result := Byte(Address^); + typePROC: result := Integer(Address^); +{$IFNDEF PAXARM} + typeANSICHAR: result := AnsiChar(Address^); + typeANSISTRING: result := AnsiString(Address^); + typeSHORTSTRING: result := ShortString(Address^); + typeWIDESTRING: result := WideString(Address^); +{$ENDIF} + typeSINGLE: result := Single(Address^); + typeEXTENDED: result := Extended(Address^); + typeCLASS: + begin + _VariantFromClass(@result, Address); + end; + typeCLASSREF: result := Integer(Address^); + typeWIDECHAR: result := WideChar(Address^); + typeVARIANT: result := Variant(Address^); + typeDYNARRAY: result := Integer(Address^); +{$IFDEF VARIANTS} + typeEVENT: result := Int64(Address^); + typeINT64: result := Int64(Address^); +{$ELSE} + typeINT64: result := Integer(Address^); +{$ENDIF} + typeINTERFACE: result := Integer(Address^); + typeCARDINAL: result := Cardinal(Address^); + typeCURRENCY: result := Currency(Address^); + typeSMALLINT: result := SmallInt(Address^); + typeSHORTINT: result := ShortInt(Address^); + typeWORDBOOL: result := WordBool(Address^); + typeLONGBOOL: result := LongBool(Address^); + typeBYTEBOOL: result := ByteBool(Address^); + typeOLEVARIANT: result := OleVariant(Address^); + typeUNICSTRING: result := UnicString(Address^); + end; +end; + +procedure PutVariantValue(Address: Pointer; FinTypeId: Integer; const value: Variant); +var + X, Y: TObject; +begin + case FinTypeId of + typeBOOLEAN: Boolean(Address^) := value; + typeBYTE: Byte(Address^) := value; + typeWORD: Word(Address^) := value; + typeINTEGER: Integer(Address^) := value; + typeDOUBLE: Double(Address^) := value; + typePOINTER: Integer(Address^) := value; + typeENUM: Byte(Address^) := value; + typePROC: Integer(Address^) := value; +{$IFNDEF PAXARM} + typeSHORTSTRING: ShortString(Address^) := ShortString(value); + typeANSICHAR: AnsiChar(Address^) := AnsiChar(Byte(value)); + typeANSISTRING: AnsiString(Address^) := AnsiString(value); + typeWIDESTRING: WideString(Address^) := value; +{$ENDIF} + typeSINGLE: Single(Address^) := value; + typeEXTENDED: Extended(Address^) := value; + typeCLASS: + begin + X := TObject(Address^); + _ClassFromVariant(@Y, @value); + if Y = nil then + begin + if X = nil then + Exit; + if X is TJS_Object then + else + TObject(Address^) := nil; + Exit; + end; + if (X is TJS_Object) and (Y is TGC_Object) then + GC_Assign(PGC_Object(Address), TGC_Object(Y)) + else + TObject(Address^) := Y; + end; + typeCLASSREF: Integer(Address^) := value; + typeWIDECHAR: WideChar(Address^) := WideChar(Word(value)); + typeVARIANT: Variant(Address^) := value; + typeDYNARRAY: Integer(Address^) := value; +{$IFDEF VARIANTS} + typeINT64: Int64(Address^) := value; + typeEVENT: Int64(Address^) := value; +{$ELSE} + typeINT64: Integer(Address^) := value; +{$ENDIF} + typeINTERFACE: Integer(Address^) := value; + typeCARDINAL: Cardinal(Address^) := value; + typeCURRENCY: Currency(Address^) := value; + typeSMALLINT: SmallInt(Address^) := value; + typeSHORTINT: ShortInt(Address^) := value; + typeWORDBOOL: WordBool(Address^) := value; + typeLONGBOOL: LongBool(Address^) := value; +{$IFDEF FPC} + typeBYTEBOOL: + if value <> 0 then + ByteBool(Address^) := true + else + ByteBool(Address^) := false; +{$ELSE} + typeBYTEBOOL: ByteBool(Address^) := value; +{$ENDIF} + typeOLEVARIANT: OleVariant(Address^) := value; + typeUNICSTRING: UnicString(Address^) := value; + end; +end; + +procedure _VariantFromPointer(Dest: PVariant; + SourceAddress: Pointer); stdcall; +begin + Dest^ := IntPax(SourceAddress^); + TVarData(Dest^).VType := varPointer; +end; + +procedure _ClearReferences(P: TBaseRunner); stdcall; +begin + P.RootGC.ClearRef; +end; + +procedure _ClassClr(Address: Pointer); stdcall; +begin + if not (PObject(Address)^ is TGC_Object) then + begin + PObject(Address)^ := nil; + Exit; + end; + + GC_Assign(Address, nil); +end; + +function _IsJSType(T: Integer; P: Pointer): Boolean; +var + SymbolTable: TBaseSymbolTable; +begin + result := (T = JS_ObjectClassId) or + (T = JS_DateClassId) or + (T = JS_ArrayClassId) or + (T = JS_FunctionClassId) or + (T = JS_MathClassId) or + (T = JS_NumberClassId) or + (T = JS_StringClassId) or + (T = JS_ErrorClassId) or + (T = JS_RegExpClassId) or + (T = JS_BooleanClassId); + if not result then + if P <> nil then + begin + SymbolTable := TBaseSymbolTable(P); + if SymbolTable[T].FinalTypeId <> typeCLASS then + Exit; + result := SymbolTable.Inherits(T, JS_ObjectClassId); + end; +end; + +const + ByRef = true; + +procedure Register_StdJavaScript(st: TBaseSymbolTable); +var + H, G, H_Sub: Integer; +begin + IsJSType := _IsJSType; + + with st do + begin +{$IFNDEF PAXARM} + RegisterRoutine(0, '', typeVARIANT, ccSTDCALL, @_GetGenericProperty); + JS_GetGenericPropertyId := LastSubId; +{$ENDIF} + H_Sub := RegisterRoutine(0, '', typeVARIANT, ccSTDCALL, @_AssignProg); + JS_AssignProgId := LastSubId; + RegisterParameter(H_Sub, typeCLASS, Unassigned); + RegisterParameter(H_Sub, typeCLASS, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_VariantFromClass); + Id_VariantFromClass := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_VariantFromPointer); + Id_VariantFromPointer := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_ClassFromVariant); + Id_ClassFromVariant := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_ClassAssign); + Id_ClassAssign := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned, ByRef); + RegisterParameter(H_Sub, typePOINTER, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_ClearReferences); + JS_ClearReferencesId := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_ClassClr); + Id_ClassClr := LastSubId; + RegisterParameter(H_Sub, typeCLASS, Unassigned, ByRef); + + // overriden routines - begin + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_VariantClr); + Id_VariantClr := LastSubId; + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + +{$IFNDEF PAXARM} + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_VariantFromPAnsiChar); + Id_VariantFromPAnsiChar := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_VariantFromAnsiString); + Id_VariantFromAnsiString := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_VariantFromWideString); + Id_VariantFromWideString := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_VariantFromAnsiChar); + Id_VariantFromAnsiChar := LastSubId; + RegisterParameter(H_Sub, typeANSICHAR, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); +{$ENDIF} + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_VariantFromPWideChar); + Id_VariantFromPWideChar := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_VariantFromInterface); + Id_VariantFromInterface := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_VariantFromShortString); + Id_VariantFromShortString := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_VariantFromUnicString); + Id_VariantFromUnicString := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_VariantFromWideChar); + Id_VariantFromWideChar := LastSubId; + RegisterParameter(H_Sub, typeWIDECHAR, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_VariantFromInt); + Id_VariantFromInt := LastSubId; + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_VariantFromInt64); + Id_VariantFromInt64 := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_VariantFromByte); + Id_VariantFromByte := LastSubId; + RegisterParameter(H_Sub, typeBYTE, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_VariantFromBool); + Id_VariantFromBool := LastSubId; + RegisterParameter(H_Sub, typeBOOLEAN, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_VariantFromWord); + Id_VariantFromWord := LastSubId; + RegisterParameter(H_Sub, typeWORD, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_VariantFromCardinal); + Id_VariantFromCardinal := LastSubId; + RegisterParameter(H_Sub, typeCARDINAL, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_VariantFromSmallInt); + Id_VariantFromSmallInt := LastSubId; + RegisterParameter(H_Sub, typeSMALLINT, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_VariantFromShortInt); + Id_VariantFromShortInt := LastSubId; + RegisterParameter(H_Sub, typeSHORTINT, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_VariantFromDouble); + Id_VariantFromDouble := LastSubId; + RegisterParameter(H_Sub, typeDOUBLE, Unassigned, ByRef); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_VariantFromCurrency); + Id_VariantFromCurrency := LastSubId; + RegisterParameter(H_Sub, typeCURRENCY, Unassigned, ByRef); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_VariantFromSingle); + Id_VariantFromSingle := LastSubId; + RegisterParameter(H_Sub, typeSINGLE, Unassigned, ByRef); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_VariantFromExtended); + Id_VariantFromExtended := LastSubId; + RegisterParameter(H_Sub, typeEXTENDED, Unassigned, ByRef); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_VariantAssign); + Id_VariantAssign := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); +{$IFNDEF PAXARM} + RegisterRoutine(0, '', typeVARIANT, ccSTDCALL, @_PutGenericProperty); + JS_PutGenericPropertyId := LastSubId; +{$ENDIF} + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @ _VarArrayGet1); + Id_VarArrayGet1 := LastSubId; + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @ _VarArrayPut1); + Id_VarArrayPut1 := LastSubId; + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @ _VarArrayGet2); + Id_VarArrayGet2 := LastSubId; + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @ _VarArrayPut2); + Id_VarArrayPut2 := LastSubId; + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @ _VarArrayGet3); + Id_VarArrayGet3 := LastSubId; + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @ _VarArrayPut3); + Id_VarArrayPut3 := LastSubId; + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + + // overriden routines - end + + H_Sub := RegisterRoutine(0, '', typeVOID, ccREGISTER, @_WriteObject); + Id_WriteObject := LastSubId; + RegisterParameter(H_Sub, typeCLASS, Unassigned); + H_WriteObject := H_Sub; + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @ _FuncObjFromVariant); + Id_FuncObjFromVariant := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @ _JS_ToObject); + JS_ToObjectId := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @ _JS_GetNextProp); + JS_GetNextPropId := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @ _JS_TypeOf); + JS_TypeOfId := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @ _JS_Void); + JS_VoidId := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + RegisterRoutine(0, '', typeVOID, ccSTDCALL, @ _JS_Delete); + JS_Delete := LastSubId; + + JS_TempNamespaceId := RegisterNamespace(0, StrJavaScriptTempNamespace); + + H := RegisterNamespace(0, StrJavaScriptNamespace); + JS_JavaScriptNamespace := H; + + RegisterConstant(H, 'Undefined', Undefined); + RegisterHeader(H, + 'procedure alert(const P1: Variant; const P2, P3, P4, P5: Variant = Undefined); stdcall;', + @ _alert); + Records[LastSubId].PushProgRequired := true; + JS_AlertId := LastSubId; + + H_Sub := RegisterRoutine(0, '', typeVARIANT, ccSTDCALL, @_PushContext); + Id_PushContext := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVARIANT, ccSTDCALL, @_PopContext); + Id_PopContext := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVARIANT, ccSTDCALL, @_FindContext); + Id_FindContext := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVARIANT, ccSTDCALL, @_FindFunc); + JS_FindFuncId := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + RegisterConstant(H, 'null', typeVARIANT, Undefined); + +// Object ---------------------------------------------------------------------- + + G := RegisterClassType(H, TJS_Object); + JS_ObjectClassId := G; + Records[G].Name := 'Object'; + Records[G].IsJavaScriptClass := true; + RegisterHeader(G, 'constructor Create;, @TJS_Object.Create);', + @TJS_Object.Create); + + RegisterHeader(G, + 'procedure PutProperty(PropName: PChar; const Value: Variant);', + @TJS_Object.PutProperty); + JS_PutPropertyId := LastSubId; + + RegisterHeader(G, + 'function GetProperty(PropName: PChar): Variant;', + @TJS_Object.GetProperty); + JS_GetPropertyId := LastSubId; + + RegisterHeader(G, 'property ___prop[PropertyName: PChar]: Variant read GetProperty write PutProperty; default;', nil); + + RegisterHeader(G, + 'function GetPropertyAsObject(PropName: PChar): TObject;', + @ TJS_Object.GetPropertyAsObject); + JS_GetPropertyAsObjectId := LastSubId; + + RegisterHeader(G, + 'procedure PutArrProperty(PropName: Integer; const Value: Variant);', + @TJS_Object.PutArrProperty); + JS_PutArrPropertyId := LastSubId; + + RegisterHeader(G, + 'function GetArrProperty(PropName: Integer): Variant;', + @TJS_Object.GetArrProperty); + JS_GetArrPropertyId := LastSubId; + + RegisterTypeField(G, 'prototype', JS_ObjectClassId, Integer(@TJS_Object(nil).prototype)); + RegisterTypeField(G, strInternalConstructor, JS_ObjectClassId, Integer(@TJS_Object(nil).aconstructor)); + RegisterTypeField(G, strProgram, typePOINTER, Integer(@TJS_Object(nil).prog)); + + RegisterHeader(G, + 'function GetConstructor: Object;', + @TJS_Object.GetConstructor); + RegisterHeader(G, + 'property constructor: Object read GetConstructor write ' + strInternalConstructor + ';', nil); + +//-- Date ---------------------------------------------------------------------- + + G := RegisterClassType(H, TJS_Date); + JS_DateClassId := G; + Records[G].Name := 'Date'; + Records[G].IsJavaScriptClass := true; + RegisterHeader(G, + 'constructor Create(const Year, Month, Date, Hours, Minutes, Seconds, Ms: Variant = Undefined);', + @TJS_Date.Create); + +// Array ----------------------------------------------------------------------- + + G := RegisterClassType(H, TJS_Array); + JS_ArrayClassId := G; + + Records[G].Name := 'Array'; + Records[G].IsJavaScriptClass := true; + RegisterHeader(G, + 'constructor Create(const V: array of Variant);', + @TJS_Array.Create); + + RegisterHeader(G, 'function GetLength: Integer;', @TJS_Array.GetLength); + RegisterHeader(G, 'procedure SetLength(value: Integer);', @TJS_Array.SetLength); + RegisterHeader(G, 'property length: Integer read GetLength write SetLength;', nil); + +// Boolean --------------------------------------------------------------------- + + G := RegisterClassType(H, TJS_Boolean); + JS_BooleanClassId := G; + Records[G].Name := 'Boolean'; + Records[G].IsJavaScriptClass := true; + RegisterHeader(G, + 'constructor Create(const P: Variant = Undefined);', + @TJS_Boolean.Create); + +// Number ---------------------------------------------------------------------- + + G := RegisterClassType(H, TJS_Number); + JS_NumberClassId := G; + + Records[G].Name := 'Number'; + Records[G].IsJavaScriptClass := true; + RegisterHeader(G, + 'constructor Create(const P: Variant = Undefined);', + @TJS_Number.Create); + +// String ---------------------------------------------------------------------- + + G := RegisterClassType(H, TJS_String); + JS_StringClassId := G; + + Records[G].Name := 'String'; + Records[G].IsJavaScriptClass := true; + RegisterHeader(G, + 'constructor Create(const P: Variant = Undefined);', + @TJS_String.Create); + +// Function -------------------------------------------------------------------- + + G := RegisterClassType(H, TJS_Function); + JS_FunctionClassId := G; + + Records[G].Name := 'Function'; + Records[G].IsJavaScriptClass := true; + RegisterHeader(G, + 'constructor ' + strInternalCreate + '(i_InternalFuncAddr: Pointer; i_NP: Integer; i_ProgPtr: Pointer);', + @TJS_Function.InternalCreate); + + RegisterHeader(G, + 'function ' + strInternalCall + '(NP: Integer): Variant; stdcall;', + @TJS_Function.InternalCall); + + JS_FunctionCallId := LastSubId; + + RegisterTypeField(G, 'arguments', JS_ArrayClassId, Integer(@TJS_Function(nil).arguments)); + RegisterTypeField(G, 'length', typeINTEGER, Integer(@TJS_Function(nil).InternalLength)); + RegisterTypeField(G, strInternalLength, typeINTEGER, Integer(@TJS_Function(nil).InternalLength)); + RegisterTypeField(G, strInternalFuncAddr, typePOINTER, Integer(@TJS_Function(nil).InternalFuncAddr)); + RegisterTypeField(G, str__this, typePOINTER, Integer(@TJS_Function(nil).__this)); + +{$IFDEF PAX64} + ParArr_OFFSET := IntPax(@TJS_Function(nil).ParArr); + RetAdr_OFFSET := IntPax(@TJS_Function(nil).RetAdr); +{$ENDIF} + +//-- Math ---------------------------------------------------------------------- + + G := RegisterClassType(H, TJS_Math); + JS_MathClassId := G; + Records[G].Name := 'Math'; + Records[G].IsJavaScriptClass := true; + +//-- RegExp -------------------------------------------------------------------- + + G := RegisterClassType(H, TJS_RegExp); + JS_RegExpClassId := G; + Records[G].Name := 'RegExp'; + Records[G].IsJavaScriptClass := true; + + RegisterHeader(G, 'constructor Create(const Source: Variant = Undefined; const Modifiers: Variant = Undefined);', + @TJS_RegExp.Create); + RegisterHeader(G, 'destructor Destroy; override;', + @TJS_RegExp.Destroy); + RegisterHeader(G, 'function test(const InputString: Variant): Boolean;', + @TJS_RegExp.Test); + RegisterHeader(G, 'procedure compile;', + @TJS_RegExp.Compile); + RegisterHeader(G, 'function matchCount: Integer;', + @TJS_RegExp.MatchCount); + RegisterHeader(G, 'function exec(const InputString: Variant): Array;', + @TJS_RegExp.Exec); + RegisterHeader(G, 'function execute(const InputString: Variant): Array;', + @TJS_RegExp.Execute); + RegisterHeader(G, 'function replace(const Expression, ReplaceStr: Variant): String;', + @TJS_RegExp.Replace); + RegisterHeader(G, 'function __GetMatch(I: Integer): String;', + @TJS_RegExp.GetMatch); + RegisterHeader(G, 'function __GetMatchLen(I: Integer): Integer;', + @TJS_RegExp.GetMatchLen); + RegisterHeader(G, 'function __GetMatchPos(I: Integer): Integer;', + @TJS_RegExp.GetMatchPos); + RegisterHeader(G, 'property match[I: Integer]: Integer read __GetMatch;', nil); + RegisterHeader(G, 'property matchPos[I: Integer]: Integer read __GetMatchPos;', nil); + RegisterHeader(G, 'property matchLen[I: Integer]: Integer read __GetMatchLen;', nil); + +// Error --------------------------------------------------------------------- + + G := RegisterClassType(H, TJS_Error); + JS_ErrorClassId := G; + Records[G].Name := 'Error'; + Records[G].IsJavaScriptClass := true; + RegisterHeader(G, + 'constructor Create(const P: Variant = Undefined);', + @TJS_Error.Create); + end; +end; + +initialization + VarIntTypes := [varSmallint, varInteger, + varShortInt, varByte, varWord, + varLongWord]; + + Randomize; + MaxArgs := IntMaxArgs; + CrtJSObjects := Create_JSObjects; + EmptyFunction := TJS_Function.InternalCreate(nil, 0, nil); +finalization + EmptyFunction.Free; +end. diff --git a/Sources/PAXCOMP_KERNEL.pas b/Sources/PAXCOMP_KERNEL.pas new file mode 100644 index 0000000..4cadafb --- /dev/null +++ b/Sources/PAXCOMP_KERNEL.pas @@ -0,0 +1,2115 @@ +//////////////////////////////////////////////////////////////////////////// +// PaxCompiler +// Site: http://www.paxcompiler.com +// Author: Alexander Baranovsky (paxscript@gmail.com) +// ======================================================================== +// Copyright (c) Alexander Baranovsky, 2006-2014. All rights reserved. +// Code Version: 4.2 +// ======================================================================== +// Unit: PAXCOMP_KERNEL.pas +// ======================================================================== +//////////////////////////////////////////////////////////////////////////// + +{$I PaxCompiler.def} +unit PAXCOMP_KERNEL; +interface +uses {$I uses.def} + Classes, + SysUtils, + TypInfo, + PAXCOMP_CONSTANTS, + PAXCOMP_TYPES, + PAXCOMP_SYS, + PAXCOMP_MODULE, + PAXCOMP_SCANNER, + PAXCOMP_PARSER, + PAXCOMP_SYMBOL_REC, + PAXCOMP_BASESYMBOL_TABLE, + PAXCOMP_SYMBOL_TABLE, + PAXCOMP_BYTECODE, + PAXCOMP_ERROR, + PAXCOMP_OFFSET, + PAXCOMP_VAROBJECT, + PAXCOMP_STDLIB, + PAXCOMP_TYPEINFO, + PAXCOMP_MAP, + PAXCOMP_CLASSFACT, + PAXCOMP_BASERUNNER, + PAXCOMP_RTI, +{$ifdef DRTTI} + RTTI, + PAXCOMP_2010, + PAXCOMP_2010REG, +{$endif} + PAXCOMP_GENERIC; +type + TWhatParse = (wpProgram, wpExpression, wpEvalExpression); + + TUsedUnitEvent = function (Sender: TObject; const AUnitName: String; + var SourceCode: String): Boolean of object; + + TImportMemberEvent = procedure (Sender: TObject; + MemberId: Integer; + const AMemberName: String) of object; + + TIncludeEvent = procedure (Sender: TObject; const FileName: String; + var Text: String) of object; + + TCompilerDirectiveEvent = procedure (Sender: TObject; + const Directive: String; + var ok: Boolean) + of object; + + TUndeclaredIdentifierEvent = function (Sender: TObject; + const IdentName: String; + var Scope: String; + var FullTypeName: String): boolean + of object; + + TCommentEvent = procedure (Sender: TObject; + const Comment: String; + const Context: String; + CommentedTokens: TStrings) of object; + + TUnitAliasEvent = procedure (Sender: TObject; + var UnitName: String) of object; + + TKernel = class + private + fPAX64: Boolean; + fTargetPlatform: TTargetPlatform; + fSearchPathList: TStringList; + function GetPAX64: Boolean; + procedure SetPAX64(value: Boolean); + procedure SetFieldOffsets; + procedure RemoveTypes; + function GetRootKernel: TKernel; + function GetRootSearchPathList: TStringList; + procedure SetupDefaultSettings; + function GetRunnerKind: TRunnerKind; + function GetTargetPlatform: TTargetPlatform; + procedure SetTargetPlatform(value: TTargetPlatform); + function GetSupportedSEH: Boolean; + public + IsUNIC: Boolean; + ParserList: TParserList; + SymbolTable: TSymbolTable; + Code: TCode; + Errors: TErrorList; + Warnings: TErrorList; + UndeclaredTypes: TUndeclaredTypeList; + UndeclaredIdents: TUndeclaredIdentList; + Modules: TModuleList; + OffsetList: TOffsetList; + ExportList: TExportList; + HostClassListIds: TIntegerList; + CondDirectiveList, ExternalSymList: TStringList; + DefList: TDefList; + ClassFactory: TPaxClassFactory; + TypeInfoList: TPaxTypeInfoList; + MessageList: TMessageList; + UsedUnitList: TStringList; + TypeDefList: TTypeDefList; + EvalList: TStringList; + + Owner: TObject; + + TryCount: Integer; + + OnCompilerProgress: TNotifyEvent; + OnUsedUnit: TUsedUnitEvent; + OnImportUnit: TImportMemberEvent; + OnImportType: TImportMemberEvent; + OnImportGlobalMembers: TNotifyEvent; + OnSavePCU: TSavePCUEvent; + OnLoadPCU: TLoadPCUEvent; + OnInclude: TIncludeEvent; + OnSavePCUFinished: TSavePCUFinishedEvent; // jason + OnLoadPCUFinished: TLoadPCUFinishedEvent; // jason + + OnDefineDirective: TCompilerDirectiveEvent; + OnUndefineDirective: TCompilerDirectiveEvent; + OnUnknownDirective: TCompilerDirectiveEvent; + OnUndeclaredIdentifier: TUndeclaredIdentifierEvent; + OnComment: TCommentEvent; + OnUnitAlias: TUnitAliasEvent; + + DEBUG_MODE: Boolean; + + CurrParser: TBaseParser; + + IsConsoleApp: Boolean; + Alignment: Integer; + + SignCompression: Boolean; + + Canceled: Boolean; + CancelChar: Char; + CompletionPrefix: String; + + SignCodeCompletion: Boolean; + CompletionTarget: String; + CompletionHasParsed: Boolean; + + InterfaceOnly: Boolean; + ImportOnly: Boolean; + + UndeclaredIdentifiers: TStringList; + TypeMap: TTypeMap; + + BuildAll: Boolean; + BuildWithRuntimePackages: Boolean; + BuildedUnits: TStringList; + PCUStreamList: TStreamList; + PCUOwner: Pointer; + + DefaultParser: TBaseParser; + CurrLanguage: String; + + ModeSEH: Boolean; + GT: TBaseSymbolTable; + IsFramework: Boolean; + + FindDeclId: Integer; + + prog: TBaseRunner; + + AnonymousClassCount: Integer; + +{$ifdef DRTTI} + ImportUnitList: TUnitList; +{$endif} + + ExAlphaList: TAssocIntegers; + + constructor Create(i_Owner: TObject); + destructor Destroy; override; + function GetRunnerClass: TBaseRunnerClass; + function AddModule(const Name, LanguageName: String; + IsPCU: Boolean = false): TModule; + procedure AddCode(const ModuleName, Text: String); + procedure AddCodeFromFile(const ModuleName, FileName: String); + procedure RegisterParser(P: TBaseParser); + function GetHandle(LevelId: Integer; const Name: String; Upcase: Boolean): Integer; + procedure ParseModule(M: TModule; ModuleNumber: Integer; + What: TWhatParse = wpProgram; + eval: Pointer = nil); + procedure Parse(CodeCompletion: Boolean = false; + const CancelModuleName: String = ''; + X: Integer = -1; + Y: Integer = -1); + procedure ParseCompletion(const CancelModuleName: String; + X: Integer; + Y: Integer); + procedure ParseExpression(const Expression: String; + const LangName: String = ''); + procedure Link; + function HasError: Boolean; + procedure RaiseError(const Message: string; params: array of Const); + procedure CreateError(const Message: string; params: array of Const); + procedure CreateWarning(const Message: string; params: array of Const); + function SourceLineToByteCodeLine(const ModuleName: String; + SourceLine: Integer): Integer; + function IsExecutableLine(const ModuleName: String; + SourceLine: Integer): Boolean; + function FindFullPath(const FileName: String): String; + function GetOffset(S: TSymbolRec): Integer; + function ExistsOffset(S: TSymbolRec): Boolean; + procedure Reset; + procedure ResetCompilation; + function GetTypeMapRec(Id: Integer): TTypeMapRec; + procedure CopyRootEvents; + procedure AssignImportTable(ImportTable: Pointer); + procedure SetProg(AProg: TBaseRunner); + procedure UpdateTypeInfos; + procedure CompressHostClassList(HostMapTable: TMapTable); + procedure CreateRTI(aprogram: TBaseRunner); + procedure AllocateConstants(const PData: Pointer); + function GetDestructorAddress: Pointer; +{$ifdef DRTTI} + procedure RegisterImportUnit(Level: Integer; const AUnitName: String); +{$endif} + property RootKernel: TKernel read GetRootKernel; + property PAX64: Boolean read GetPAX64 write SetPAX64; + property RootSearchPathList: TStringList read GetRootSearchPathList; + property RunnerKind: TRunnerKind read GetRunnerKind; + property TargetPlatform: TTargetPlatform read GetTargetPlatform write SetTargetPlatform; + property SupportedSEH: Boolean read GetSupportedSEH; + end; + +function CheckProc(const TypeName: String; Data: Pointer; + errKind: TExternRecKind): Boolean; +var + VarCheckProc: TCheckProc = CheckProc; + +var + CurrKernel: TKernel; + +implementation + +uses + PAXCOMP_EVAL, + PAXCOMP_PASCAL_PARSER; + +constructor TKernel.Create(i_Owner: TObject); +begin + FindAvailTypes; + + GT := GlobalSymbolTable; + + SetupDefaultSettings; + + Owner := i_Owner; + OnCompilerProgress := nil; + + Errors := TErrorList.Create(Self); + Warnings := TErrorList.Create(Self); + + UndeclaredTypes := TUndeclaredTypeList.Create; + UndeclaredIdents := TUndeclaredIdentList.Create; + + SymbolTable := TSymbolTable.Create(Self); + SymbolTable.Reset; + + Code := TCode.Create(Self); + Code.Reset; + + Modules := TModuleList.Create(Self); + Modules.Clear; + + ParserList := TParserList.Create(Self); + DEBUG_MODE := false; + + CondDirectiveList := TStringList.Create; + DefList := TDefList.Create; + ExternalSymList := TStringList.Create; + UsedUnitList := TStringList.Create; + TypeDefList := TTypeDefList.Create; + EvalList := TStringList.Create; + + OffsetList := nil; + ExportList := nil; + HostClassListIds := TIntegerList.Create; + + Alignment := GlobalAlignment; + + SignCompression := true; + Canceled := false; + SignCodeCompletion := false; + InterfaceOnly := false; + UndeclaredIdentifiers := TStringList.Create; + BuildedUnits := TStringList.Create; + PCUStreamList := TStreamList.Create; + TypeMap := TTypeMap.Create; + DefaultParser := TPascalParser.Create; + +{$ifdef DRTTI} + ImportUnitList := TUnitList.Create; +{$endif} + fSearchPathList := TStringList.Create; + + ExAlphaList := TAssocIntegers.Create; +end; + +destructor TKernel.Destroy; +begin + FreeAndNil(SymbolTable); + FreeAndNil(Code); + FreeAndNil(Modules); + + FreeAndNil(Errors); + FreeAndNil(Warnings); + + UndeclaredTypes.Reset; + FreeAndNil(UndeclaredTypes); + + UndeclaredIdents.Reset; + FreeAndNil(UndeclaredIdents); + + FreeAndNil(HostClassListIds); + + FreeAndNil(ParserList); + + FreeAndNil(DefList); + FreeAndNil(CondDirectiveList); + FreeAndNil(ExternalSymList); + FreeAndNil(UsedUnitList); + FreeAndNil(TypeDefList); + FreeAndNil(EvalList); + + FreeAndNil(UndeclaredIdentifiers); + FreeAndNil(BuildedUnits); + FreeAndNil(PCUStreamList); + + FreeAndNil(TypeMap); + FreeAndNil(DefaultParser); + +{$ifdef DRTTI} + FreeAndNil(ImportUnitList); +{$endif} + FreeAndNil(fSearchPathList); + + FreeAndNil(ExAlphaList); + + inherited; +end; + +procedure TKernel.Reset; +begin + CompletionTarget := ''; + + SetupDefaultSettings; + + SymbolTable.Reset; + Code.Reset; + Errors.Reset; + Warnings.Reset; + UndeclaredTypes.Reset; + UndeclaredIdents.Reset; + HostClassListIds.Clear; + Modules.Clear; + ParserList.Clear; + DefList.Clear; + UsedUnitList.Clear; + TypeDefList.Clear; + EvalList.Clear; + + TryCount := 0; + Canceled := false; + SignCodeCompletion := false; + InterfaceOnly := false; + UndeclaredIdentifiers.Clear; + BuildedUnits.Clear; + PCUStreamList.Clear; + ExternalSymList.Clear; + TypeMap.Clear; + PCUOwner := nil; + + AnonymousClassCount := 0; + +{$ifdef DRTTI} + ImportUnitList.Clear; +{$endif} + fSearchPathList.Clear; + + ExAlphaList.Clear; +end; + +procedure TKernel.ResetCompilation; +begin + CompletionTarget := ''; + + if Code.Card = 0 then + SymbolTable.CompileCard := SymbolTable.Card + else + SymbolTable.ResetCompilation; + Code.Reset; + Errors.Reset; + Warnings.Reset; + UndeclaredTypes.Reset; + UndeclaredIdents.Reset; + HostClassListIds.Clear; + Modules.Clear; + DefList.Clear; + UsedUnitList.Clear; + TypeDefList.Clear; + EvalList.Clear; + TryCount := 0; + Canceled := false; + InterfaceOnly := false; + UndeclaredIdentifiers.Clear; + ExternalSymList.Clear; + TypeMap.Clear; + PCUOwner := nil; + + AnonymousClassCount := 0; + +{$ifdef DRTTI} + ImportUnitList.Clear; +{$endif} +end; + +function TKernel.AddModule(const Name, LanguageName: String; + IsPCU: Boolean = false): TModule; +var + I: Integer; + Found: Boolean; +begin + if Modules.Count = 0 then + begin + SymbolTable.CompileCard := SymbolTable.Card; + CurrLanguage := LanguageName; + end; + + Found := false; + for I := 0 to ParserList.Count - 1 do + if StrEql(LanguageName, ParserList[I].LanguageName) then + Found := true; + + if not Found then + begin + if StrEql(LanguageName, 'Pascal') then + begin + RegisterParser(DefaultParser); + end + else + RaiseError(errUnregisteredLanguage, [LanguageName]); + end; + + result := Modules.AddModule(Name, LanguageName); + result.IsPCU := IsPCU; +end; + +procedure TKernel.AddCode(const ModuleName, Text: String); +var + I: Integer; +begin + I := Modules.IndexOf(ModuleName); + if I = -1 then + RaiseError(errModuleNotFound, [ModuleName]); + Modules[I].Lines.Text := Modules[I].Lines.Text + Text; +end; + +procedure TKernel.AddCodeFromFile(const ModuleName, FileName: String); +var + L: TStringList; + S, FullPath: String; + I: Integer; +{$IFDEF MACOS} + J: Integer; +{$ENDIF} +begin + I := Modules.IndexOf(ModuleName); + if I = -1 then + RaiseError(errModuleNotFound, [ModuleName]); + + FullPath := FindFullPath(FileName); + if not FileExists(FullPath) then + RaiseError(errFileNotFound, [FileName]); + L := TStringList.Create; + try + L.LoadFromFile(FullPath); + + S := L.Text; +{$IFDEF MACOS} + for J := SLow(S) to SHigh(S) do + if (Ord(S[J]) = 8220) or (Ord(S[J]) = 8221) then + S[J] := '"'; +{$ENDIF} + + Modules[I].Lines.Text := Modules[I].Lines.Text + S; + Modules[I].FileName := FullPath; + finally + FreeAndNil(L); + end; +end; + +procedure TKernel.RegisterParser(P: TBaseParser); +begin + ParserList.AddParser(P); +end; + +function TKernel.GetHandle(LevelId: Integer; const Name: String; Upcase: Boolean): Integer; +var + id, I, P: Integer; + Ok: Boolean; + S: String; +begin + P := 0; + for I:= Length(Name) downto 1 do + if Name[I] = '.' then + begin + P := I; + break; + end; + + if P > 0 then + begin + S := Copy(Name, 1, P - 1); + LevelId := GetHandle(LevelId, S, Upcase); + if LevelId = 0 then + begin + result := 0; + Exit; + end; + S := Copy(Name, P + 1, Length(Name) - P); + end + else + S := Name; + + id := 0; + + with SymbolTable do + for I := Card downto 1 do + begin + if (Records[I].Level = LevelId) and + (Records[I].OwnerId = 0) and + (Records[I].Kind <> KindNONE) then + begin + if UpCase then + ok := StrEql(Records[I].Name, S) + else + ok := Records[I].Name = S; + if ok then + begin + id := I; + break; + end; + end; + end; + + if id > 0 then + begin + if SymbolTable[id].Kind in KindSUBs then + result := - SymbolTable[id].Value + else if SymbolTable[id].Kind in [KindNAMESPACE, KindTYPE] then + result := id + else + result := SymbolTable[id].Shift; + end + else + result := 0; +end; + +procedure TKernel.ParseModule(M: TModule; ModuleNumber: Integer; + What: TWhatParse = wpProgram; + eval: Pointer = nil); +var + LanguageNamespaceId: Integer; + L, I, J, Id, ExitLabelId, CurrSelfId, CurrN: Integer; + parser: TBaseParser; + R: TSymbolRec; + ExtraNamespaceList: TStringList; +begin + UsedUnitList.Clear; + + if eval = nil then + ExtraNamespaceList := nil + else + ExtraNamespaceList := TEval(eval).NamespaceList; + + Canceled := false; +// DefList.Clear; + for I := 0 to CondDirectiveList.Count - 1 do + DefList.Add(CondDirectiveList[I]); + + parser := ParserList.FindParser(M.LanguageName); + + if parser = nil then + RaiseError(errLanguageNotRegistered, [M.LanguageName]); + + CurrParser := parser; + + M.ModuleNumber := ModuleNumber; + + CurrLanguage := M.LanguageName; + + parser.Init(Self, M); + + ExitLabelId := 0; + L := 0; + LanguageNamespaceId := 0; + + try + parser.ParsesModule := true; + + try + parser.Gen(OP_BEGIN_MODULE, ModuleNumber, parser.LanguageId, Integer(parser.UpCase)); + parser.Gen(OP_SEPARATOR, ModuleNumber, 0, 0); + + LanguageNamespaceId := SymbolTable.LookUp(M.LanguageName + 'Namespace', 0, true); + if LanguageNamespaceId = 0 then + LanguageNamespaceId := H_PascalNamespace; + // LanguageNamespaceId := SymbolTable.RegisterNamespace(0, M.LanguageName + 'Namespace'); + + IsFramework := false; + +{$IFDEF EXPLICIT_OFF} + parser.EXPLICIT_OFF := true; + parser.Gen(OP_OPTION_EXPLICIT, 0, 0, 0); +{$ENDIF} + + parser.Gen(OP_WARNINGS_ON, 0, 0, 0); + parser.Gen(OP_BEGIN_USING, LanguageNamespaceId, 0, 0); + parser.Gen(OP_BEGIN_USING, 0, 0, 0); + + if ExtraNamespaceList <> nil then + begin + for I := 0 to ExtraNamespaceList.Count - 1 do + begin + Id := SymbolTable.LookupFullName(ExtraNamespaceList[I], parser.UpCase); + if Id > 0 then + parser.Gen(OP_BEGIN_USING, Id, 0, 0); + end; + end; + + L := parser.NewLabel; + parser.SkipLabelStack.Push(L); + + ExitLabelId := parser.NewLabel; + parser.ExitLabelStack.Push(L); + + case What of + wpProgram: + begin + parser.ParseProgram; + end; + wpExpression: + begin + parser.Gen(OP_END_INTERFACE_SECTION, 0, 0, 0); + parser.DECLARE_SWITCH := false; + parser.Call_SCANNER; + parser.Gen(OP_ASSIGN, SymbolTable.ResultId, parser.Parse_Expression, SymbolTable.ResultId); + end; + wpEvalExpression: + begin + R := SymbolTable.AddRecord; + R.Kind := KindVAR; + R.Name := StrExprResult; + R.Level := 0; + + if eval <> nil then + TEval(eval).ResultId := SymbolTable.Card; + + CurrN := TBaseRunner(TEval(eval).SProg).CurrN; + if CurrN > 0 then + CurrSelfId := TKernel(TEval(eval).SKernel).Code.GetCurrSelfId(CurrN) + else + CurrSelfId := 0; + + parser.Gen(OP_END_INTERFACE_SECTION, 0, 0, 0); + if CurrSelfId > 0 then + begin + Parser.Gen(OP_BEGIN_WITH, CurrSelfId, 0, 0); + Parser.WithStack.Push(CurrSelfId); + end; + + parser.DECLARE_SWITCH := false; + parser.Call_SCANNER; + parser.Gen(OP_ASSIGN, R.Id, parser.Parse_Expression, R.Id); + + if CurrSelfId > 0 then + begin + Parser.Gen(OP_END_WITH, CurrSelfId, 0, 0); + Parser.WithStack.Pop; + end; + end; + else + parser.ParseProgram; + end; + except + on E: Exception do + begin + if E is PaxCompilerException then + begin + // already has been processed + end + else if E is PaxCancelException then + begin + if CompletionHasParsed then + begin + Errors.Reset; + Warnings.Reset; + end; + Canceled := true; + end + else + begin + CreateError(E.Message, []); + end; + end; + end; + + finally + CurrParser := nil; + + parser.SkipLabelStack.Pop; + parser.SetLabelHere(L); + + parser.ExitLabelStack.Pop; + parser.SetLabelHere(ExitLabelId); + + parser.Gen(OP_END_USING, LanguageNamespaceId, 0, 0); + parser.Gen(OP_END_USING, 0, 0, 0); +// parser.Gen(OP_RET, 0, 0, 0); + parser.Gen(OP_END_MODULE, ModuleNumber, 0, 0); + + IsConsoleApp := parser.IsConsoleApp; + if Assigned(prog) then + prog.Console := IsConsoleApp; + + parser.ParsesModule := false; + end; + + if parser.InterfaceOnly then + Exit; + + if Canceled then + begin + Parser.Gen(OP_NOP, 0, 0, 0); + Parser.Gen(OP_NOP, 0, 0, 0); + Parser.Gen(OP_NOP, 0, 0, 0); + Parser.Gen(OP_NOP, 0, 0, 0); + Exit; + end; + + if What = wpExpression then + Exit; + if What = wpEvalExpression then + Exit; + if SignCodeCompletion then + Exit; + + if not StrEql(M.LanguageName, 'C') then + for I:=FirstLocalId + 1 to SymbolTable.Card do + begin + if SymbolTable[I].IsForward then + begin + for J := 1 to Code.Card do + if Code[J].Op = OP_BEGIN_SUB then + if Code[J].Arg1 = I then + begin + Code.N := J; + break; + end; + + CreateError(errUnsatisfiedForwardOrExternalDeclaration, [SymbolTable[I].Name]); + end; + end; + + if parser.scanner.DefStack.Count > 0 then + CreateError(errMissingENDIFdirective, ['']); +end; + +procedure TKernel.Parse(CodeCompletion: Boolean = false; + const CancelModuleName: String = ''; + X: Integer = -1; + Y: Integer = -1); +var + I, J, CancelPos: Integer; + Temp: Boolean; + ExtraModuleName, ExtraCode: String; +begin + CompletionHasParsed := false; + SignCodeCompletion := CodeCompletion; + Temp := false; + + code.Reset; + SymbolTable.CompileCard := SymbolTable.Card; + I := 0; + while (I < Modules.Count) do + begin + + if CodeCompletion and StrEql(CancelModuleName, Modules[I].Name) then + begin + CancelPos := Modules.GetPos(CancelModuleName, X, Y); + if CancelPos = -1 then + Exit; + Modules[I].CancelPos := CancelPos; + end; + + Modules[I].State := msCompiling; + if not Modules[I].SkipParsing then + begin + ParseModule(Modules[I], I); + end; + + Modules[I].State := msCompiled; + + Inc(I); + + if Canceled then + begin + Temp := True; + if I >= Modules.Count then + break; + end; + end; + + Canceled := Temp; + + for I := Modules.Count - 1 downto 0 do + if Modules[I].SkipParsing then + Modules.Delete(Modules[I]); + + if ImportOnly then + Exit; + + RemoveTypes; + + TypeDefList.GenPascalUnits; + for J := 0 to TypeDefList.TypeModuleList.Count - 1 do + if TypeDefList.TypeModuleList[J].LangId = PASCAL_LANGUAGE then + if TypeDefList.TypeModuleList[J].Success then + begin + ExtraModuleName := strExtraPascalUnit + TypeDefList.TypeModuleList[J].ModuleName; + ExtraCode := TypeDefList.TypeModuleList[J].Source; + AddModule(ExtraModuleName, 'Pascal'); + AddCode(ExtraModuleName, ExtraCode); + I := Modules.Count - 1; + Modules[I].IsExtra := true; + Modules[I].State := msCompiling; + ParseModule(Modules[I], I); + Modules[I].State := msCompiled; + end; + + TypeDefList.GenBasicUnits; + for J := 0 to TypeDefList.TypeModuleList.Count - 1 do + if TypeDefList.TypeModuleList[J].LangId = BASIC_LANGUAGE then + if TypeDefList.TypeModuleList[J].Success then + begin + ExtraModuleName := strExtraBasicUnit + TypeDefList.TypeModuleList[J].ModuleName; + ExtraCode := TypeDefList.TypeModuleList[J].Source; + AddModule(ExtraModuleName, 'Basic'); + AddCode(ExtraModuleName, ExtraCode); + I := Modules.Count - 1; + Modules[I].IsExtra := true; + Modules[I].State := msCompiling; + ParseModule(Modules[I], I); + Modules[I].State := msCompiled; + end; + + TypeDefList.GenJavaUnits; + for J := 0 to TypeDefList.TypeModuleList.Count - 1 do + if TypeDefList.TypeModuleList[J].LangId = JAVA_LANGUAGE then + if TypeDefList.TypeModuleList[J].Success then + begin + ExtraModuleName := strExtraJavaUnit + TypeDefList.TypeModuleList[J].ModuleName; + ExtraCode := TypeDefList.TypeModuleList[J].Source; + AddModule(ExtraModuleName, 'Java'); + AddCode(ExtraModuleName, ExtraCode); + I := Modules.Count - 1; + Modules[I].IsExtra := true; + Modules[I].State := msCompiling; + ParseModule(Modules[I], I); + Modules[I].State := msCompiled; + end; +end; + +procedure TKernel.ParseCompletion(const CancelModuleName: String; + X: Integer; + Y: Integer); +var + I, J, J1, CancelPos, Card1, Op: Integer; + S: String; + ActiveUnitList: TStringList; +begin + CompletionHasParsed := false; + SignCodeCompletion := true; + + code.Reset; + SymbolTable.CompileCard := SymbolTable.Card; + I := Modules.IndexOf(CancelModuleName); + if I = -1 then + Exit; + CancelPos := Modules.GetPos(CancelModuleName, X, Y); + if CancelPos = -1 then + Exit; + Modules[I].CancelPos := CancelPos; + Modules[I].State := msCompiling; + ParseModule(Modules[I], I); + Modules[I].State := msCompiled; + Canceled := false; + + Card1 := Code.Card; + InterfaceOnly := true; + + ActiveUnitList := TStringList.Create; + try + for J1 := 0 to UsedUnitList.Count - 1 do + begin + S := UpperCase(UsedUnitList[J1]); + ActiveUnitList.Add(S); + end; + + J := 0; + while J < ActiveUnitList.Count do + begin + S := ActiveUnitList[J]; + I := Modules.IndexOf(S); + if I >= 0 then + begin + Modules[I].State := msCompiling; + ParseModule(Modules[I], I); + Modules[I].State := msCompiled; + + for J1 := 0 to UsedUnitList.Count - 1 do + begin + S := UpperCase(UsedUnitList[J1]); + if ActiveUnitList.IndexOf(S) = -1 then + ActiveUnitList.Add(S); + end; + end; + + Inc(J); + end; + + finally + FreeAndNil(ActiveUnitList); + InterfaceOnly := false; + end; + + for I := Code.Card downto Card1 do + begin + Op := Code[I].Op; + if (Op <> OP_EVAL) and + (Op <> OP_BEGIN_MODULE) and + (Op <> OP_END_MODULE) and + (Op <> OP_BEGIN_USING) and + (Op <> OP_ASSIGN_CONST) and + (Op <> OP_ADD_ANCESTOR) and + (Op <> OP_ASSIGN_TYPE) then + begin + Code.DeleteRecord(I); + end; + end; +end; + +procedure TKernel.ParseExpression(const Expression: String; + const LangName: String = ''); +var + M: TModule; +begin + if LangName = '' then + M := AddModule('$', 'Pascal') + else + M := AddModule('$', LangName); + AddCode('$', Expression); + ParseModule(M, 0, wpExpression); +end; + +procedure TKernel.RaiseError(const Message: string; params: array of Const); +begin + CreateError(Message, params); + if SignCodeCompletion then + raise PaxCancelException.Create(Format(Message, params)) + else + raise PaxCompilerException.Create(Format(Message, params)); +end; + +procedure TKernel.CreateError(const Message: string; params: array of Const); +var + E: TError; + S: String; +begin + dmp; + S := Format(Message, params); + E := TError.Create(Self, S); + Errors.Add(E); +end; + +procedure TKernel.CreateWarning(const Message: string; params: array of Const); +var + E: TError; +begin + dmp; + E := TError.Create(Self, Format(Message, params)); + Warnings.Add(E); +end; + +function TKernel.HasError: Boolean; +begin + result := Errors.Count > 0; +end; + +function CheckProc(const TypeName: String; Data: Pointer; errKind: TExternRecKind): Boolean; +var + Code: TCode; + CodeRec: TCodeRec; + SymbolTable: TSymbolTable; + I, Id, K: Integer; + S: String; +begin + S := ExtractName(TypeName); + result := false; + Code := TKernel(Data).Code; + SymbolTable := TKernel(Data).SymbolTable; + K := SymbolTable.Card; + for I := 1 to Code.Card do + begin + CodeRec := Code[I]; + Id := CodeRec.Arg1; + if (Id > StdCard) and (Id <= K) then + if StrEql(S, SymbolTable[Id].Name) then + begin + Code.N := I; + result := true; + Exit; + end; + Id := CodeRec.Arg2; + if (Id > StdCard) and (Id <= K) then + if StrEql(S, SymbolTable[Id].Name) then + begin + Code.N := I; + result := true; + Exit; + end; + Id := CodeRec.Res; + if (Id > StdCard) and (Id <= K) then + if StrEql(S, SymbolTable[Id].Name) then + begin + Code.N := I; + result := true; + Exit; + end; + end; +end; + +procedure TKernel.Link; +{$ifdef DRTTI} +var + Q: TStringList; + I, Id: Integer; + AUnitName: String; +{$endif} +begin + CurrProg := Prog; + SymbolTable.LinkCard := SymbolTable.CompileCard; + + try +{$ifdef DRTTI} + + if ImportUnitList.Count > 0 then + begin + dmp; + + Q := TStringList.Create; + try + Code.CreateEvalList(EvalList); + if EvalList.Count > 0 then + begin + for I := 0 to ImportUnitList.Count - 1 do + Q.Add(ImportUnitList[I].Name); + ImportUnitList.FindMembers(EvalList); + + ImportUnitList.Sort; + + if IsDump then + ImportUnitList.Dump('simp_units.txt'); + + for I := 0 to ImportUnitList.Count - 1 do + begin + Id := RegisterUnit(ImportUnitList[I], SymbolTable, EvalList, Self); + if Assigned(OnImportUnit) then + begin + AUnitName := ImportUnitList[I].Name; + if Q.IndexOf(AUnitName) >= 0 then + begin + try + SymbolTable.HeaderParser.kernel := Self; + SymbolTable.HeaderParser.CurrImportUnit := AUnitName; + OnImportUnit(Owner, Id, AUnitName); + finally + SymbolTable.HeaderParser.CurrImportUnit := ''; + SymbolTable.HeaderParser.kernel := nil; + end; + end; + end; + end; + + if Assigned(OnImportGlobalMembers) then + OnImportGlobalMembers(Owner); + + SymbolTable.LinkCard := SymbolTable.Card; + end; + + finally + FreeAndNil(Q); + end; + end; + +{$endif} + dmp; + + SymbolTable.Update; + try + SymbolTable.ResolveExternList(VarCheckProc, Self); + except + on E: Exception do + begin + CreateError(E.Message, []); + end; + end; + + if HasError then Exit; + code.RemoveEvalOpForTypes; + + if HasError then Exit; + code.ProcessImplements; + + if HasError then Exit; + code.RemoveEvalOp; + + if HasError then Exit; + + if HasError then Exit; + if not Canceled then + code.GenHostStructConst; + + if HasError then Exit; + if not Canceled then + code.UpdateDefaultConstructors; + + if HasError then Exit; + modules.CreateLoadOrder; + + if HasError then Exit; + code.CheckOverride; + + if HasError then Exit; + code.CheckTypes; + + if Canceled then + begin + Exit; + end; + + if InterfaceOnly then + begin + Exit; + end; + + if SignCodeCompletion then + begin + Exit; + end; + + code.CheckExpansions; + + if HasError then Exit; + code.AddWarnings; + + if HasError then Exit; + code.InsertDynamicTypeDestructors; + + if HasError then Exit; + code.InsertFinalizators; + + if HasError then Exit; + code.InsertTryFinally; + + if HasError then Exit; + + try + SymbolTable.SetShifts(prog); + except + on E: Exception do + CreateError(E.Message, []); + end; + UpdateTypeInfos; + + if HasError then Exit; + SetFieldOffsets; + + if HasError then Exit; + code.ProcessSizeOf; + + if HasError then Exit; + code.ChangeOrderOfActualParams; + + if HasError then Exit; + code.AssignShifts; + + if HasError then Exit; + code.RemoveLoadProc; + + if HasError then Exit; + code.InsertHostMonitoring; + + if HasError then Exit; + code.Optimization; + + if HasError then Exit; + code.AdjustTryList; + + if HasError then Exit; + if DEBUG_MODE then + Code.InsertCallHostEvents; + + Code.SetLastCondRaise; + + dmp; + + except + end; +end; + +function TKernel.SourceLineToByteCodeLine(const ModuleName: String; + SourceLine: Integer): Integer; +var + I: Integer; + M: TModule; +begin + result := 0; + I := Modules.IndexOf(ModuleName); + if I = -1 then + Exit; + M := Modules[I]; + for I:=M.P1 to M.P3 do + if Code[I].OP = OP_SEPARATOR then + if Code[I].Arg2 = SourceLine then + begin + result := I; + Exit; + end; +end; + +function TKernel.IsExecutableLine(const ModuleName: String; + SourceLine: Integer): Boolean; +var + I, J: Integer; + M: TModule; +begin + result := false; + I := Modules.IndexOf(ModuleName); + if I = -1 then + Exit; + M := Modules[I]; + for I:=M.P1 to M.P3 do + if Code[I].OP = OP_SEPARATOR then + if Code[I].Arg2 = SourceLine then + begin + J := I; + repeat + Inc(J); + + if J > Code.Card then + Exit; + if Code[J].Op = OP_SEPARATOR then + Exit; + + if Code[J].Op = OP_SET_CODE_LINE then + begin + result := true; + Exit; + end; + until false; + + Exit; + end; +end; + +function TKernel.GetOffset(S: TSymbolRec): Integer; +var + Shift: Integer; +begin + if SignCompression then + begin + Shift := S.Shift; + + if (Shift <= 0) or (S.Kind = kindTYPE_FIELD) then + begin + result := Shift; + Exit; + end + else if PAX64 then + begin + if S.Param or S.Local then + begin + result := Shift; + Exit; + end; + end; + + result := OffsetList.GetOffset(Shift); + + if result = -1 then + RaiseError(errInternalError, []); + end + else + result := S.Shift; +end; + +function TKernel.ExistsOffset(S: TSymbolRec): Boolean; //18.09.2009 +var + Shift: Integer; +begin + if SignCompression then + begin + Shift := S.Shift; + + if (Shift <= 0) or (S.Kind = kindTYPE_FIELD) then + begin + result := true; + Exit; + end; + + result := OffsetList.GetOffset(Shift) <> - 1; + end + else + result := true; +end; + +function TKernel.GetTypeMapRec(Id: Integer): TTypeMapRec; +var + T: Integer; +begin + result := nil; + + T := SymbolTable[Id].FinalTypeId; + if not (T in [typeRECORD, typeCLASS]) then + Exit; + + T := SymbolTable[Id].TerminalTypeId; + result := TypeMap.Lookup(T); + if result = nil then + result := TypeMap.Add(T); + if not result.Completed then + begin + result.Fields.Clear; + SymbolTable.GetFieldCount(Id, result); + result.Completed := true; + end; +end; + +function TKernel.GetRootKernel: TKernel; +begin + result := Self; + while result.PCUOwner <> nil do + result := result.PCUOwner; +end; + +procedure TKernel.CopyRootEvents; +var + RK: TKernel; +begin + RK := RootKernel; + if Self <> RK then + begin + Owner := RK.Owner; + + OnCompilerProgress := RK.OnCompilerProgress; + OnUsedUnit := RK.OnUsedUnit; + OnSavePCU := RK.OnSavePCU; + OnLoadPCU := RK.OnLoadPCU; + OnInclude := RK.OnInclude; + OnDefineDirective := RK.OnDefineDirective; + OnUndefineDirective := RK.OnUndefineDirective; + OnUnknownDirective := RK.OnUnknownDirective; + OnSavePCUFinished := RK.OnSavePCUFinished; // jason + OnLoadPCUFinished := RK.OnLoadPCUFinished; // jason + + end; +end; + +procedure TKernel.AssignImportTable(ImportTable: Pointer); +begin + GT := ImportTable; + SymbolTable.SetImportTable(GT); +end; + +procedure TKernel.SetProg(AProg: TBaseRunner); +begin + prog := AProg; + + if prog = nil then + Exit; + + ClassFactory := prog.ProgClassFactory; + TypeInfoList := prog.ProgTypeInfoList; + OffsetList := prog.OffsetList; + ExportList := prog.ExportList; + MessageList := prog.MessageList; + + prog.ModeSEH := ModeSEH; + prog.PAX64 := PAX64; + prog.UseMapping := true; + + prog.SetGlobalSym(GT); +end; + +procedure TKernel.UpdateTypeInfos; +var + I, J: Integer; + RI: TTypeInfoContainer; + ClassTypeDataContainer: TClassTypeDataContainer; + SR: TSymbolRec; +begin + for I := 0 to TypeInfoList.Count - 1 do + begin + RI := TypeInfoList[I]; + if RI.TypeInfo.Kind = tkClass then + begin + ClassTypeDataContainer := + RI.TypeDataContainer as + TClassTypeDataContainer; + with ClassTypeDataContainer.AnotherFieldListContainer do + for J := 0 to Count - 1 do + begin + SR := SymbolTable[Records[J].Id]; + Records[J].Offset := SR.Shift; + Records[J].FinalFieldTypeId := SR.FinalTypeId; + end; + end; + end; +end; + +function TKernel.GetPAX64: Boolean; +begin + result := fPAX64; +end; + +procedure TKernel.SetPAX64(value: Boolean); +begin + fPAX64 := value; + if fPAX64 then + begin + ModeSEH := false; + SymbolTable.SetPAX64(true); + end; +end; + +procedure TKernel.CompressHostClassList(HostMapTable: TMapTable); +begin + SymbolTable.CompressHostClassList(HostMapTable, HostClassListIds); +end; + +procedure TKernel.SetFieldOffsets; +var + I, J, Id: Integer; + ClassTypeDataContainer: TClassTypeDataContainer; + FieldListContainer: TFieldListContainer; +begin + for I:=0 to TypeInfoList.Count - 1 do + if TypeInfoList[I].TypeInfo.Kind = tkClass then + begin + ClassTypeDataContainer := TypeInfoList[I].TypeDataContainer as + TClassTypeDataContainer; + FieldListContainer := ClassTypeDataContainer.FieldListContainer; + for J := 0 to FieldListContainer.Count - 1 do + begin + Id := FieldListContainer[J].Id; + FieldListContainer[J].Offset := SymbolTable[Id].Shift; + end; + end; +end; + +procedure TKernel.RemoveTypes; +var + I, TypeId: Integer; + S, OldFullName, NewFullName: String; +begin + for I := 0 to TypeDefList.RemTypeIds.Count - 1 do + begin + TypeId := TypeDefList.RemTypeIds[I]; + S := SymbolTable[TypeId].Name; + OldFullName := SymbolTable[TypeId].FullName; + S := S + '#'; + SymbolTable[TypeId].Name := S; + NewFullName := SymbolTable[TypeId].FullName; + if SymbolTable[TypeId].FinalTypeId = typeCLASS then + if not ClassFactory.RenameClass(OldFullName, NewFullName) then + RaiseError(errInternalError, []); + end; +end; + +procedure TKernel.CreateRTI(aprogram: TBaseRunner); +var + RuntimeModuleList: TRuntimeModuleList; + I, J, K, Index, Id: Integer; + UsedName: String; + MR: TModuleRec; +begin + RuntimeModuleList := aprogram.RunTimeModuleList; + RuntimeModuleList.Clear; + + SetLength(RuntimeModuleList.SourceLines, Code.Card + 1); + SetLength(RuntimeModuleList.ModuleIndexes, Code.Card + 1); + + for I:=1 to Code.Card do + begin + RuntimeModuleList.SourceLines[I] := Code.GetSourceLineNumber(I); + RuntimeModuleList.ModuleIndexes[I] := Code.GetModuleNumber(I); + end; + + for I:=0 to Modules.Count - 1 do + begin + MR := RuntimeModuleList.Modules.AddRecord; + with MR do + begin + ModuleName := Modules[I].Name; + P1 := Modules[I].P1; + P2 := Modules[I].P2; + P3 := Modules[I].P3; + + Code.CreateExecLines(MR); + + UsedModules.Clear; + for J:=P1 to P2 do + begin + if Code[J].Op = OP_BEGIN_USING then + begin + Id := Code[J].Arg1; + if Id > 0 then + begin + UsedName := Code.GetSymbolRec(Id).Name; + if StrEql(ExtractName(UsedName), ExtractName(ModuleName)) then + continue; + if StrEql(UsedName, strPascalNamespace) then + continue; + if StrEql(UsedName, strBasicNamespace) then + continue; + + Index := -1; + for K := 0 to UsedModules.Count - 1 do + if StrEql(UsedModules[K], UsedName) then + begin + Index := K; + break; + end; + if Index = -1 then + UsedModules.Add(UsedName); + end; + end; + end; + end; + end; +end; + +procedure TKernel.AllocateConstants(const PData: Pointer); +var + I, J, Shift: Integer; + RI: TSymbolRec; + P: Pointer; + I64: Int64; + UI64: UInt64; + VCardinal: Cardinal; + ByteSet: TByteSet; + SetSize, VT, TypeID: Integer; + SS: String; + GUID: TGUID; +{$IFDEF PAXARM} + WS: String; +{$ELSE} + S: AnsiString; + WS: WideString; +{$ENDIF} +begin + I := 0; + + while I < SymbolTable.Card do + begin + Inc(I); + + if not SymbolTable.InCode[I] then + continue; + + RI := SymbolTable[I]; + + if RI = SymbolTable.SR0 then + continue; + + if RI.Shift = 0 then + continue; + + case RI.Kind of + KindCONST: + case RI.FinalTypeID of + typeDOUBLE: + begin + Shift := GetOffset(RI); + P := ShiftPointer(PData, Shift); + Double(P^) := Double(RI.Value); + end; + typeSINGLE: + begin + Shift := GetOffset(RI); + P := ShiftPointer(PData, Shift); + Single(P^) := Single(RI.Value); + end; + typeEXTENDED: + begin + Shift := GetOffset(RI); + P := ShiftPointer(PData, Shift); + Extended(P^) := Extended(RI.Value); + end; + typeCURRENCY: + begin + Shift := GetOffset(RI); + P := ShiftPointer(PData, Shift); + Currency(P^) := Currency(RI.Value); + end; + +{$IFDEF VARIANTS} + typeINT64: + begin + Shift := GetOffset(RI); + P := ShiftPointer(PData, Shift); + I64 := RI.Value; + Int64(P^) := I64; + end; + typeUINT64: + begin + Shift := GetOffset(RI); + P := ShiftPointer(PData, Shift); + UI64 := RI.Value; + UInt64(P^) := UI64; + end; +{$ELSE} + typeINT64, typeUINT64: + begin + Shift := GetOffset(RI); + P := ShiftPointer(PData, Shift); + I64 := Integer(RI.Value); + Int64(P^) := I64; + end; +{$ENDIF} + typeINTEGER, typeCLASS: + if RI.MustBeAllocated then + begin + Shift := GetOffset(RI); + P := ShiftPointer(PData, Shift); + Integer(P^) := Integer(RI.Value); + end; + typeSHORTINT: + if RI.MustBeAllocated then + begin + Shift := GetOffset(RI); + P := ShiftPointer(PData, Shift); + ShortInt(P^) := Integer(RI.Value); + end; + typeSMALLINT: + if RI.MustBeAllocated then + begin + Shift := GetOffset(RI); + P := ShiftPointer(PData, Shift); + SmallInt(P^) := Integer(RI.Value); + end; + typeWORD: + if RI.MustBeAllocated then + begin + Shift := GetOffset(RI); + P := ShiftPointer(PData, Shift); + VCardinal := RI.Value; + Word(P^) := VCardinal; + end; + typeWIDECHAR: + if RI.MustBeAllocated then + begin + Shift := GetOffset(RI); + P := ShiftPointer(PData, Shift); + VCardinal := RI.Value; + Word(P^) := VCardinal; + end; + typeBOOLEAN: + if RI.MustBeAllocated then + begin + Shift := GetOffset(RI); + P := ShiftPointer(PData, Shift); + Boolean(P^) := RI.Value; + end; + typeBYTEBOOL: + if RI.MustBeAllocated then + begin + Shift := GetOffset(RI); + P := ShiftPointer(PData, Shift); +{$IFDEF FPC} + if RI.Value <> 0 then + ByteBool(P^) := true + else + ByteBool(P^) := false; +{$ELSE} + ByteBool(P^) := RI.Value; +{$ENDIF} + end; + typeWORDBOOL: + if RI.MustBeAllocated then + begin + Shift := GetOffset(RI); + P := ShiftPointer(PData, Shift); + WordBool(P^) := RI.Value; + end; + typeLONGBOOL: + if RI.MustBeAllocated then + begin + Shift := GetOffset(RI); + P := ShiftPointer(PData, Shift); + LongBool(P^) := RI.Value; + end; + typeBYTE, typeENUM: + if RI.MustBeAllocated then + begin + Shift := GetOffset(RI); + P := ShiftPointer(PData, Shift); + VCardinal := RI.Value; + Byte(P^) := VCardinal; + end; +{$IFNDEF PAXARM} + typeANSICHAR: + if RI.MustBeAllocated then + begin + Shift := GetOffset(RI); + P := ShiftPointer(PData, Shift); + VCardinal := RI.Value; + Byte(P^) := VCardinal; + end; +{$ENDIF} + typeCARDINAL: + if RI.MustBeAllocated then + begin + Shift := GetOffset(RI); + P := ShiftPointer(PData, Shift); + VCardinal := RI.Value; + Cardinal(P^) := VCardinal; + end; + typeVARIANT: + begin + Shift := GetOffset(RI); + P := ShiftPointer(PData, Shift); + Variant(P^) := RI.Value; + end; + typeOLEVARIANT: + begin + Shift := GetOffset(RI); + P := ShiftPointer(PData, Shift); + OleVariant(P^) := RI.Value; + end; + typeSET: + begin + Shift := GetOffset(RI); + P := ShiftPointer(PData, Shift); + ByteSet := RI.ValueAsByteSet; + SetSize := SymbolTable.GetSizeOfSetType(RI.TerminalTypeId); + Move(ByteSet, P^, SetSize); + end; + typeCLASSREF: + begin + Shift := GetOffset(RI); + P := ShiftPointer(PData, Shift); + IntPax(P^) := IntPax(RI.Value); + end; + typeRECORD: + if RI.TerminalTypeId = H_TGUID then + begin + VT := VarType(RI.Value); + if (VT = varString) or (VT = varUString) then + begin + Shift := GetOffset(RI); + P := ShiftPointer(PData, Shift); + SS := RI.Value; + GUID := StringToGuid(SS); + Move(GUID, P^, SizeOf(TGUID)); + end; + end; + typePOINTER: + begin + TypeID := RI.TypeId; + if SymbolTable[TypeId].PatternId = typeWIDECHAR then + begin + WS := RI.Value; + + Shift := GetOffset(RI); + P := ShiftPointer(PData, Shift); + + P := ShiftPointer(P, 4); + Integer(P^) := Length(WS); + + P := ShiftPointer(P, 4); + + if WS = '' then + Word(P^) := 0 + else + begin + for J := SLow(WS) to SHigh(WS) do + begin + Move(WS[J], P^, SizeOf(WideChar)); + Inc(IntPax(P), 2); + end; + Word(P^) := 0; + end; + end +{$IFNDEF PAXARM} + else if SymbolTable[TypeId].PatternId = typeANSICHAR then + begin + S := AnsiString(RI.Value); + + Shift := GetOffset(RI); + P := ShiftPointer(PData, Shift + 4); + Integer(P^) := -1; + + P := ShiftPointer(P, 4); + Integer(P^) := Length(S); + + P := ShiftPointer(P, 4); + + if S = '' then + Byte(P^) := 0 + else + Move(Pointer(S)^, P^, Length(S) + 1); + end +{$ENDIF} + else + if RI.MustBeAllocated then + begin + Shift := GetOffset(RI); + P := ShiftPointer(PData, Shift); + VCardinal := RI.Value; + Cardinal(P^) := VCardinal; + end; + end; + end; + KindVAR: + if (RI.IsStatic) and (not IsEmpty(RI.Value)) then + case RI.FinalTypeID of + typeBOOLEAN, typeBYTE: + begin + Shift := GetOffset(RI); + P := ShiftPointer(PData, Shift); + Byte(P^) := Integer(RI.Value); + end; +{$IFNDEF PAXARM} + typeANSICHAR: + begin + Shift := GetOffset(RI); + P := ShiftPointer(PData, Shift); + Byte(P^) := Integer(RI.Value); + end; +{$ENDIF} + typeINTEGER: + begin + Shift := GetOffset(RI); + P := ShiftPointer(PData, Shift); + Integer(P^) := Integer(RI.Value); + end; + typeDOUBLE: + begin + Shift := GetOffset(RI); + P := ShiftPointer(PData, Shift); + Double(P^) := Double(RI.Value); + end; + typeSINGLE: + begin + Shift := GetOffset(RI); + P := ShiftPointer(PData, Shift); + Single(P^) := Single(RI.Value); + end; + typeEXTENDED: + begin + Shift := GetOffset(RI); + P := ShiftPointer(PData, Shift); + Extended(P^) := Extended(RI.Value); + end; + typeCURRENCY: + begin + Shift := GetOffset(RI); + P := ShiftPointer(PData, Shift); + Currency(P^) := Currency(RI.Value); + end; +{$IFDEF VARIANTS} + typeINT64: + begin + Shift := GetOffset(RI); + P := ShiftPointer(PData, Shift); + I64 := RI.Value; + Int64(P^) := I64; + end; + typeUINT64: + begin + Shift := GetOffset(RI); + P := ShiftPointer(PData, Shift); + UI64 := RI.Value; + UInt64(P^) := UI64; + end; +{$ELSE} + typeINT64, typeUINT64: + begin + Shift := GetOffset(RI); + P := ShiftPointer(PData, Shift); + I64 := Integer(RI.Value); + Int64(P^) := I64; + end; +{$ENDIF} + typeSET: + begin + Shift := GetOffset(RI); + P := ShiftPointer(PData, Shift); + ByteSet := RI.ValueAsByteSet; + SetSize := SymbolTable.GetSizeOfSetType(RI.TerminalTypeId); + Move(ByteSet, P^, SetSize); + end; + + typeCLASSREF: + begin + Shift := GetOffset(RI); + P := ShiftPointer(PData, Shift); + IntPax(P^) := IntPax(RI.Value); + end; + + typeVARIANT: + begin + Shift := GetOffset(RI); + P := ShiftPointer(PData, Shift); + Variant(P^) := Variant(RI.Value); + end; + + typeOLEVARIANT: + begin + Shift := GetOffset(RI); + P := ShiftPointer(PData, Shift); + OleVariant(P^) := Variant(RI.Value); + end; + + typeRECORD: + if RI.TerminalTypeId = H_TGUID then + begin + VT := VarType(RI.Value); + if (VT = varString) or (VT = varUString) then + begin + Shift := GetOffset(RI); + P := ShiftPointer(PData, Shift); + SS := RI.Value; + GUID := StringToGuid(SS); + Move(GUID, P^, SizeOf(TGUID)); + end; + end; + end; + KindSUB: + if not RI.Host then + begin + Shift := GetOffset(RI); + P := ShiftPointer(PData, Shift); + Integer(P^) := RI.Value; + end; + end; // case + end; +end; + +function TKernel.GetRunnerClass: TBaseRunnerClass; +begin + if prog = nil then + result := DefaultRunnerClass + else + result := TBaseRunnerClass(prog.ClassType) +end; + +function TKernel.GetDestructorAddress: Pointer; +begin + if prog = nil then + result := nil + else + result := prog.GetDestructorAddress; +end; + +{$ifdef DRTTI} +procedure TKernel.RegisterImportUnit(Level: Integer; const AUnitName: String); + +var + u: TUnit; + + procedure P(t: TRTTIType); + var + S: String; + begin + S := ExtractUnitName(t); + if StrEql(S, AUnitName) then + if u.UsedTypes.IndexOf(t) = -1 then + begin + if not CheckType(t) then + Exit; + u.UsedTypes.Add(t); + end; + end; + +var + t: TRTTIType; +begin + u := ImportUnitList.AddUnit(AUnitName, Level); + for t in PaxContext.GetTypes do + P(t); +end; +{$endif} + +function TKernel.GetRootSearchPathList: TStringList; +begin + result := RootKernel.fSearchPathList; +end; + +function TKernel.FindFullPath(const FileName: String): String; +var + I: Integer; + S: String; +begin + result := FileName; + if SysUtils.FileExists(result) then + Exit; + for I := 0 to RootSearchPathList.Count - 1 do + begin + S := RootSearchPathList[I]; + if S[Length(S)] <> '\' then + S := S + '\'; + S := S + FileName; + if SysUtils.FileExists(S) then + begin + result := S; + Exit; + end; + end; +end; + +procedure TKernel.SetupDefaultSettings; +begin + fTargetPlatform := tpNONE; +{$IFDEF MACOS} + fTargetPlatform := tpOSX32; +{$ENDIF} +{$IFDEF LINUX} + fTargetPlatform := tpLINUX32; +{$ENDIF} +{$IFDEF IOS} + fTargetPlatform := tpiOSSim; +{$ENDIF} + +{$IFDEF CPUARM} + {$IFDEF ANDROID} + fTargetPlatform := tpANDROID; + {$ELSE} + fTargetPlatform := tpiOSDev; + {$ENDIF} +{$ENDIF} + +{$IFDEF MSWINDOWS} + {$IFDEF PAX64} + fPAX64 := true; + fTargetPlatform := tpWIN64; + {$ELSE} + fTargetPlatform := tpWIN32; + {$ENDIF} +{$ENDIF} + + {$IFDEF UNIC} + IsUNIC := true; + {$ELSE} + IsUNIC := false; + {$ENDIF} + + ModeSEH := fTargetPlatform = tpWIN32; +end; + +function TKernel.GetRunnerKind: TRunnerKind; +begin + if prog = nil then + result := rkNONE + else if StrEql(prog.ClassName, 'TProgram') then + result := rkPROGRAM + else + result := rkINTERPRETER; +end; + +function TKernel.GetTargetPlatform: TTargetPlatform; +begin + result := fTargetPlatform; +end; + +procedure TKernel.SetTargetPlatform(value: TTargetPlatform); +begin + fTargetPlatform := value; + PAX64 := (value = tpWin64); +end; + +function TKernel.GetSupportedSEH: Boolean; +begin + result := (TargetPlatform = tpWIN32) or (RunnerKind = rkINTERPRETER); +end; + + +end. diff --git a/Sources/PAXCOMP_LABEL_STACK.pas b/Sources/PAXCOMP_LABEL_STACK.pas new file mode 100644 index 0000000..91476c5 --- /dev/null +++ b/Sources/PAXCOMP_LABEL_STACK.pas @@ -0,0 +1,133 @@ +//////////////////////////////////////////////////////////////////////////// +// PaxCompiler +// Site: http://www.paxcompiler.com +// Author: Alexander Baranovsky (paxscript@gmail.com) +// ======================================================================== +// Copyright (c) Alexander Baranovsky, 2006-2014. All rights reserved. +// Code Version: 4.2 +// ======================================================================== +// Unit: PAXCOMP_LABEL_STACK.pas +// ======================================================================== +//////////////////////////////////////////////////////////////////////////// + +{$I PaxCompiler.def} +unit PAXCOMP_LABEL_STACK; +interface +uses {$I uses.def} + SysUtils, + Classes, + PAXCOMP_CONSTANTS, + PAXCOMP_TYPES, + PAXCOMP_SYS; +type + + TEntryRec = class + public + IntLabel: Integer; + StringLabel: String; + CodeN: Integer; + loopLabel: Integer; + end; + + TEntryStack = class(TTypedList) + private + kernel: Pointer; + function GetRecord(I: Integer): TEntryRec; + function GetTop: TEntryRec; + public + procedure SetKernel(AKernel: Pointer); + procedure Push(AIntLabel, ALoopLabel: Integer); overload; + procedure Push(AIntLabel: Integer; + var AStringLabel: String; + ALoopLabel: Integer); overload; + procedure Pop; + function TopLabel(const AStringLabel: String = ''): Integer; + property Top: TEntryRec read GetTop; + property Records[I: Integer]: TEntryRec read GetRecord; default; + end; + +implementation + +uses + PAXCOMP_BYTECODE, + PAXCOMP_KERNEL; + +procedure TEntryStack.SetKernel(AKernel: Pointer); +begin + kernel := AKernel; +end; + +function TEntryStack.GetRecord(I: Integer): TEntryRec; +begin + result := TEntryRec(L[I]); +end; + +procedure TEntryStack.Push(AIntLabel, ALoopLabel: Integer); +var + R: TEntryRec; +begin + R := TEntryRec.Create; + R.IntLabel := AIntLabel; + R.StringLabel := ''; + R.loopLabel := ALoopLabel; + if kernel <> nil then + R.CodeN := TKernel(kernel).Code.Card; + L.Add(R); +end; + +procedure TEntryStack.Push(AIntLabel: Integer; var AStringLabel: String; ALoopLabel: Integer); +var + R: TEntryRec; +begin + R := TEntryRec.Create; + R.IntLabel := AIntLabel; + R.StringLabel := AStringLabel; + R.loopLabel := ALoopLabel; + if kernel <> nil then + R.CodeN := TKernel(kernel).Code.Card; + L.Add(R); + AStringLabel := ''; +end; + +procedure TEntryStack.Pop; +begin +{$IFDEF ARC} + L[Count - 1] := nil; +{$ELSE} + Records[Count - 1].Free; +{$ENDIF} + L.Delete(Count - 1); +end; + +function TEntryStack.TopLabel(const AStringLabel: String = ''): Integer; +var + I: Integer; + R: TEntryRec; +begin + if AStringLabel <> '' then + begin + for I:=Count - 1 downto 0 do + begin + R := Records[I]; + with R do + if StringLabel = AStringLabel then + begin + result := IntLabel; + Exit; + end; + end; + raise Exception.Create(errLabelNotFound); + end + else + result := Records[Count - 1].IntLabel; +end; + +function TEntryStack.GetTop: TEntryRec; +begin + if Count = 0 then + result := nil + else + result := Records[Count - 1]; +end; + +end. diff --git a/Sources/PAXCOMP_LOCALSYMBOL_TABLE.pas b/Sources/PAXCOMP_LOCALSYMBOL_TABLE.pas new file mode 100644 index 0000000..761e027 --- /dev/null +++ b/Sources/PAXCOMP_LOCALSYMBOL_TABLE.pas @@ -0,0 +1,313 @@ +//////////////////////////////////////////////////////////////////////////// +// PaxCompiler +// Site: http://www.paxcompiler.com +// Author: Alexander Baranovsky (paxscript@gmail.com) +// ======================================================================== +// Copyright (c) Alexander Baranovsky, 2006-2014. All rights reserved. +// Code Version: 4.2 +// ======================================================================== +// Unit: PAXCOMP_LOCALSYMBOL_TABLE.pas +// ======================================================================== +//////////////////////////////////////////////////////////////////////////// + +{$I PaxCompiler.def} +{$O-} +unit PAXCOMP_LOCALSYMBOL_TABLE; +interface +uses {$I uses.def} + TypInfo, + SysUtils, + Classes, + PAXCOMP_CONSTANTS, + PAXCOMP_TYPES, + PAXCOMP_SYS, + PAXCOMP_BASESYMBOL_TABLE, + PAXCOMP_SYMBOL_REC, + PAXCOMP_MAP, + PAXCOMP_STDLIB; +type + TLocalSymbolTable = class(TBaseSymbolTable) + private + SaveClassList: TAssocIntegers; + protected + function GetRecord(I: Integer): TSymbolRec; override; + public + GlobalST: TBaseSymbolTable; + GlobalST_LastShiftValue: Integer; + constructor Create(AGlobalST: TBaseSymbolTable; NeedHash: Boolean = True); + destructor Destroy; override; + procedure Reset; override; + procedure Update; virtual; + procedure CompressHostClassList(MapTable: TMapTable; + ClassListIds: TIntegerList = nil); + procedure RestoreClassIndexes; + procedure SetImportTable(ImportTable: TBaseSymbolTable); + property Records[I: Integer]: TSymbolRec read GetRecord; default; + end; + + TProgSymbolTable = class(TLocalSymbolTable) + public + constructor Create(AGlobalST: TBaseSymbolTable); + end; + +implementation + +//-- TLocalSymbolTable --------------------------------------------------------- + +constructor TLocalSymbolTable.Create(AGlobalST: TBaseSymbolTable; NeedHash: Boolean = true); +begin + inherited Create(NeedHash); + st_tag := 1; + GlobalST := AGlobalST; + SaveClassList := TAssocIntegers.Create; + + SR0 := GlobalST[0]; +end; + +destructor TLocalSymbolTable.Destroy; +begin + FreeAndNil(SaveClassList); + inherited; +end; + +procedure TLocalSymbolTable.RestoreClassIndexes; +var + I, Id, ClassIndex: Integer; +begin + for I := 0 to SaveClassList.Count - 1 do + begin + Id := SaveClassList.Keys[I]; + ClassIndex := SaveClassList.Values[I]; + Records[Id].ClassIndex := ClassIndex; + end; +end; + +procedure TLocalSymbolTable.Reset; +var + I: Integer; +begin + SaveClassList.Clear; + for I:=A.Count - 1 downto 0 do +{$IFDEF ARC} + A[I] := nil; +{$ELSE} + TSymbolRec(A[I]).Free; +{$ENDIF} + A.Clear; + + Card := FirstLocalId; + SetImportTable(GlobalST); +end; + +{$O+} +function TLocalSymbolTable.GetRecord(I: Integer): TSymbolRec; +begin + if I <= GlobalST.Card then + result := TSymbolRec(GlobalST.A[I]) + else if I <= FirstLocalId then + result := SR0 + else + result := TSymbolRec(A[I - FirstLocalId - 1]); +end; +{$O-} + +procedure TLocalSymbolTable.Update; +var + I, D: Integer; + R: TSymbolRec; + S: String; +begin + D := GlobalST.LastShiftValue - GlobalST_LastShiftValue; + if D > 0 then + begin + for I := FirstLocalId + 1 to Card do + begin + R := Records[I]; + if R.Shift >= GlobalST_LastShiftValue then + if R.Kind in (KindSubs + [KindVAR]) then + R.Shift := R.Shift + D; + end; + GlobalST_LastShiftValue := GlobalST.LastShiftValue; + end; + + FreeAndNil(HashArray); + HashArray := GlobalST.HashArray.Clone; + + for I := FirstLocalId + 1 to Card do + begin + R := Records[I]; + S := R.Name; + R.Name := S; + end; + + LastClassIndex := -1; + for I := 1 to Card do + begin + R := Records[I]; + if R = SR0 then + continue; + + if R.Kind = kindTYPE then + if R.TypeId = typeCLASS then + begin + Inc(LastClassIndex); + R.ClassIndex := LastClassIndex; + + if not R.Host then + continue; + + if I <= Card then + if R.AncestorId = H_TObject then + SetAncestorEx(I); + end; + end; +end; + +procedure TLocalSymbolTable.CompressHostClassList(MapTable: TMapTable; + ClassListIds: TIntegerList = nil); +var + I, KK, K1, K2: Integer; + R: TSymbolRec; + S: String; + MapRec: TMapRec; + L: TStringList; + UpName: String; +begin + LastClassIndex := -1; + + L := TStringList.Create; + try + + for KK := 1 to 2 do + begin + if KK = 1 then + begin + K1 := 1; + K2 := GlobalST.Card; + end + else + begin + K1 := FirstLocalId + 1; + K2 := Card; + end; + + for I := K1 to K2 do + begin + R := Records[I]; + + if R.Kind = kindTYPE then + if R.TypeId = typeCLASS then + if R.ClassIndex <> -1 then + begin + SaveClassList.Add(I, R.ClassIndex); + + if R.Host then + begin + if I <= StdCard then + begin + Inc(LastClassIndex); + if ClassListIds <> nil then + ClassListIds.Add(I); + R.ClassIndex := LastClassIndex; + continue; + end; + + UpName := UpperCase(R.Name); + if L.IndexOf(UpName) >= 0 then + continue; + + S := R.FullName; + + MapRec := MapTable.Lookup(S); + if MapRec <> nil then + begin + L.Add(UpName); + + Inc(LastClassIndex); + if ClassListIds <> nil then + ClassListIds.Add(I); + + R.ClassIndex := LastClassIndex; + MapRec.ClassIndex := LastClassIndex; + continue; + end; + + MapRec := MapTable.Lookup(ExtractName(S)); + if MapRec <> nil then + begin + L.Add(UpName); + + Inc(LastClassIndex); + if ClassListIds <> nil then + ClassListIds.Add(I); + + R.ClassIndex := LastClassIndex; + MapRec.ClassIndex := LastClassIndex; + end + else + R.ClassIndex := -1; + end + else + begin + Inc(LastClassIndex); + R.ClassIndex := LastClassIndex; + end; + end; + end; + end; + finally + FreeAndNil(L); + end; +end; + +procedure TLocalSymbolTable.SetImportTable(ImportTable: TBaseSymbolTable); +begin + GlobalST := ImportTable; + + SR0 := GlobalST[0]; + + ResultId := GlobalST.ResultId; + TrueId := GlobalST.TrueId; + FalseId := GlobalST.FalseId; + NilId := GlobalST.NilId; + EventNilId := GlobalST.EventNilId; + CurrExceptionObjectId := GlobalST.CurrExceptionObjectId; + EmptySetId := GlobalST.EmptySetId; + EmptyStringId := GlobalST.EmptyStringId; + LastShiftValue := GlobalST.LastShiftValue; + LastClassIndex := GlobalST.LastClassIndex; + + GlobalST_LastShiftValue := GlobalST.LastShiftValue; + + if HashArray <> nil then + begin + FreeAndNil(HashArray); + HashArray := GlobalST.HashArray.Clone; + end; + + if TypeHelpers <> nil then + begin + FreeAndNil(TypeHelpers); + TypeHelpers := GlobalST.TypeHelpers.Clone; + end; + + FreeAndNil(GuidList); + GuidList := GlobalST.GuidList.Clone; + + FreeAndNil(SomeTypeList); + SomeTypeList := GlobalST.SomeTypeList.Clone; + +// ExternList.Free; +// ExternList := GlobalST.ExternList.Clone; + +// CompileCard := Card; +end; + +//-- TProgSymbolTable ---------------------------------------------------------- + +constructor TProgSymbolTable.Create(AGlobalST: TBaseSymbolTable); +begin + inherited Create(AGlobalST, false); +end; + +end. diff --git a/Sources/PAXCOMP_MAP.pas b/Sources/PAXCOMP_MAP.pas new file mode 100644 index 0000000..bf53d64 --- /dev/null +++ b/Sources/PAXCOMP_MAP.pas @@ -0,0 +1,889 @@ +//////////////////////////////////////////////////////////////////////////// +// PaxCompiler +// Site: http://www.paxcompiler.com +// Author: Alexander Baranovsky (paxscript@gmail.com) +// ======================================================================== +// Copyright (c) Alexander Baranovsky, 2006-2014. All rights reserved. +// Code Version: 4.2 +// ======================================================================== +// Unit: PAXCOMP_MAP.pas +// ======================================================================== +//////////////////////////////////////////////////////////////////////////// + +{$I PaxCompiler.def} +unit PAXCOMP_MAP; +interface +uses {$I uses.def} + SysUtils, + Classes, + PAXCOMP_CONSTANTS, + PAXCOMP_TYPES, + PAXCOMP_SYS, + PAXCOMP_OFFSET; +type + TMapFieldRec = class + public + FieldName: String; + FieldOffset: Integer; +{$IFDEF PCU_EX} + FieldTypeName: String; +{$ENDIF} + procedure SaveToStream(S: TStream); + procedure LoadFromStream(S: TStream); + end; + + TMapFieldList = class(TTypedList) + private + function GetRecord(I: Integer): TMapFieldRec; + public + function Add(const FieldName: String; + FieldOffset: Integer; + const FieldTypeName: String): TMapFieldRec; + procedure SaveToStream(S: TStream); + procedure LoadFromStream(S: TStream); + function Lookup(const FieldName: String): TMapFieldRec; + property Records[I: Integer]: TMapFieldRec read GetRecord; default; + end; + + TSubParamRec = class + public + FinTypeId: Byte; + ParamMod: Byte; + ParamSize: Integer; + // pcu only + ParamName: String; + ParamTypeName: String; + OptValue: String; + ParamOffset: Integer; + end; + + TSubParamList = class(TTypedList) + private + function GetRecord(I: Integer): TSubParamRec; + public + function IndexOf(const AName: String): Integer; + function AddRecord: TSubParamRec; + procedure SaveToStream(S: TStream); + procedure LoadFromStream(S: TStream); + property Records[I: Integer]: TSubParamRec read GetRecord; default; + end; + + TSubLocalVarRec = class + public + LocalVarName: String; + LocalVarTypeName: String; + LocalVarOffset: Integer; + IsByRef: Boolean; + end; + + TSubLocalVarList = class(TTypedList) + private + function GetRecord(I: Integer): TSubLocalVarRec; + public + function IndexOf(const AName: String): Integer; + function AddRecord: TSubLocalVarRec; + procedure SaveToStream(S: TStream); + procedure LoadFromStream(S: TStream); + property Records[I: Integer]: TSubLocalVarRec + read GetRecord; default; + end; + + TSubDesc = class + public + OverCount: Byte; + CallConv: Byte; + CallMode: Byte; + ResTypeId: Byte; + MethodIndex: Integer; + RetSize: Integer; + ParamList: TSubParamList; + + // pcu only + LocalVarList: TSubLocalVarList; + ResTypeName: String; + IsMethod: Boolean; + IsShared: Boolean; + SubName: String; + DllName: String; + AliasName: String; + + SId: Integer; + N1: Integer; + N2: Integer; + SelfOffset: Integer; + SubSize: Integer; // not save to stream + + constructor Create; + destructor Destroy; override; + procedure SaveToStream(S: TStream); + procedure LoadFromStream(S: TStream); + end; + + TSubDescList = class(TTypedList) + private + function GetRecord(I: Integer): TSubDesc; + public + function AddRecord: TSubDesc; + procedure SaveToStream(S: TStream); + procedure LoadFromStream(S: TStream); + property Records[I: Integer]: TSubDesc read GetRecord; default; + end; + + TMapRec = class + private + function GetIsMethod: Boolean; + public + FullName: String; + Shift: Integer; + Offset: Integer; + ClassIndex: Integer; + Kind: Byte; + Global: Boolean; + Vis: TClassVisibility; + TypedConst: Boolean; + FullTypeName: String; + IsExternal: Boolean; + SubDesc: TSubDesc; + FieldList: TMapFieldList; + constructor Create; + destructor Destroy; override; + procedure SaveToStream(S: TStream); + procedure LoadFromStream(S: TStream); + property IsMethod: Boolean read GetIsMethod; + end; + + TMapTable = class(TTypedList) + private + function GetRecord(I: Integer): TMapRec; + function Add: TMapRec; + public + function AddRec(const FullName: String; + Shift: Integer; + ClassIndex: Integer; + Kind: Byte; + Global: Boolean; + OverCount: Byte; + CallMode: Byte): TMapRec; + function LookupByOffset(Offset: Integer): TMapRec; + function Lookup(const FullName: String): TMapRec; + function LookupEx(const FullName: String; OverCount: Integer): TMapRec; + function LookupType(const FullName: String): TMapRec; + function LookupConstructor(const AClassName: String; NP: Integer): TMapRec; + function LookupSub(SubId: Integer): TMapRec; + function GetSub(N: Integer): TMapRec; + procedure SaveToStream(S: TStream); + procedure LoadFromStream(S: TStream); + procedure CreateOffsets(OffsetList: TOffsetList; Host: Boolean); + property Records[I: Integer]: TMapRec read GetRecord; default; + end; + + TTypeMapRec = class + public + TypeId: Integer; + Fields: TIntegerList; + Completed: Boolean; + constructor Create; + destructor Destroy; override; + end; + + TTypeMap = class(TTypedList) + private + function GetRecord(I: Integer): TTypeMapRec; + public + function Add(TypeId: Integer): TTypeMapRec; + function Lookup(TypeId: Integer): TTypeMapRec; + property Records[I: Integer]: TTypeMapRec read GetRecord; default; + end; + +implementation + +// TSubLocalVarList ------------------------------------------------------------ + +function TSubLocalVarList.GetRecord(I: Integer): TSubLocalVarRec; +begin + result := TSubLocalVarRec(L[I]); +end; + +function TSubLocalVarList.IndexOf(const AName: String): Integer; +var + I: Integer; +begin + result := -1; + for I := 0 to Count - 1 do + if StrEql(Records[I].LocalVarName, AName) then + begin + result := I; + Exit; + end; +end; + +function TSubLocalVarList.AddRecord: TSubLocalVarRec; +begin + result := TSubLocalVarRec.Create; + L.Add(result); +end; + +procedure TSubLocalVarList.SaveToStream(S: TStream); +var + I, K: Integer; +begin + K := Count; + S.Write(K, SizeOf(Integer)); + + for I := 0 to K - 1 do + with Records[I] do + begin + SaveStringToStream(LocalVarName, S); + SaveStringToStream(LocalVarTypeName, S); + S.Write(LocalVarOffset, SizeOf(LocalVarOffset)); + S.Write(IsByRef, SizeOf(IsByRef)); + end; +end; + +procedure TSubLocalVarList.LoadFromStream(S: TStream); +var + I, K: Integer; + R: TSubLocalVarRec; +begin + S.Read(K, SizeOf(Integer)); + + for I := 0 to K - 1 do + begin + R := AddRecord; + with R do + begin + LocalVarName := LoadStringFromStream(S); + LocalVarTypeName := LoadStringFromStream(S); + S.Read(LocalVarOffset, SizeOf(LocalVarOffset)); + S.Read(IsByRef, SizeOf(IsByRef)); + end; + end; +end; + +// TSubParamList --------------------------------------------------------------- + +function TSubParamList.GetRecord(I: Integer): TSubParamRec; +begin + result := TSubParamRec(L[I]); +end; + +function TSubParamList.IndexOf(const AName: String): Integer; +var + I: Integer; +begin + result := -1; + for I := 0 to Count - 1 do + if StrEql(Records[I].ParamName, AName) then + begin + result := I; + Exit; + end; +end; + +function TSubParamList.AddRecord: TSubParamRec; +begin + result := TSubParamRec.Create; + L.Add(result); +end; + +procedure TSubParamList.SaveToStream(S: TStream); +var + I, K: Integer; +begin + K := Count; + S.Write(K, SizeOf(Integer)); + + for I := 0 to K - 1 do + with Records[I] do + begin + S.Write(FinTypeId, SizeOf(FinTypeId)); + S.Write(ParamMod, SizeOf(ParamMod)); + S.Write(ParamSize, SizeOf(ParamSize)); + SaveStringToStream(ParamName, S); + SaveStringToStream(ParamTypeName, S); + SaveStringToStream(OptValue, S); +{$IFDEF PCU_EX} + S.Write(ParamOffset, SizeOf(ParamOffset)); +{$ENDIF} + end; +end; + +procedure TSubParamList.LoadFromStream(S: TStream); +var + I, K: Integer; + R: TSubParamRec; +begin + S.Read(K, SizeOf(Integer)); + + for I := 0 to K - 1 do + begin + R := AddRecord; + with R do + begin + S.Read(FinTypeId, SizeOf(FinTypeId)); + S.Read(ParamMod, SizeOf(ParamMod)); + S.Read(ParamSize, SizeOf(ParamSize)); + ParamName := LoadStringFromStream(S); + ParamTypeName := LoadStringFromStream(S); + OptValue := LoadStringFromStream(S); +{$IFDEF PCU_EX} + S.Read(ParamOffset, SizeOf(ParamOffset)); +{$ENDIF} + end; + end; +end; + +// TSubDesc -------------------------------------------------------------------- + +constructor TSubDesc.Create; +begin + inherited; + ParamList := TSubParamList.Create; + LocalVarList := TSubLocalVarList.Create; +end; + +destructor TSubDesc.Destroy; +begin + FreeAndNil(ParamList); + FreeAndNil(LocalVarList); + inherited; +end; + +procedure TSubDesc.SaveToStream(S: TStream); +begin + S.Write(OverCount, SizeOf(OverCount)); + S.Write(CallConv, SizeOf(CallConv)); + S.Write(CallMode, SizeOf(CallMode)); + S.Write(ResTypeId, SizeOf(ResTypeId)); + S.Write(MethodIndex, SizeOf(MethodIndex)); + S.Write(RetSize, SizeOf(RetSize)); + S.Write(IsMethod, SizeOf(IsMethod)); + S.Write(IsShared, SizeOf(IsShared)); + SaveStringToStream(ResTypeName, S); + ParamList.SaveToStream(S); + SaveStringToStream(SubName, S); + SaveStringToStream(DllName, S); + SaveStringToStream(AliasName, S); +{$IFDEF PCU_EX} + LocalVarList.SaveToStream(S); + S.Write(SId, SizeOf(SId)); + S.Write(N1, SizeOf(N1)); + S.Write(N2, SizeOf(N2)); + S.Write(SelfOffset, SizeOf(SelfOffset)); +{$ENDIF} +end; + +procedure TSubDesc.LoadFromStream(S: TStream); +begin + S.Read(OverCount, SizeOf(OverCount)); + S.Read(CallConv, SizeOf(CallConv)); + S.Read(CallMode, SizeOf(CallMode)); + S.Read(ResTypeId, SizeOf(ResTypeId)); + S.Read(MethodIndex, SizeOf(MethodIndex)); + S.Read(RetSize, SizeOf(RetSize)); + S.Read(IsMethod, SizeOf(IsMethod)); + S.Read(IsShared, SizeOf(IsShared)); + ResTypeName := LoadStringFromStream(S); + ParamList.Clear; + ParamList.LoadFromStream(S); + SubName := LoadStringFromStream(S); + DllName := LoadStringFromStream(S); + AliasName := LoadStringFromStream(S); +{$IFDEF PCU_EX} + LocalVarList.Clear; + LocalVarList.LoadFromStream(S); + S.Read(SId, SizeOf(SId)); + S.Read(N1, SizeOf(N1)); + S.Read(N2, SizeOf(N2)); + S.Read(SelfOffset, SizeOf(SelfOffset)); +{$ENDIF} +end; + +// TSubDescList ---------------------------------------------------------------- + +function TSubDescList.GetRecord(I: Integer): TSubDesc; +begin + result := TSubDesc(L[I]); +end; + +function TSubDescList.AddRecord: TSubDesc; +begin + result := TSubDesc.Create; + L.Add(result); +end; + +procedure TSubDescList.SaveToStream(S: TStream); +var + I, K: Integer; +begin + K := Count; + S.Write(K, SizeOf(Integer)); + for I := 0 to K - 1 do + Records[I].SaveToStream(S); +end; + +procedure TSubDescList.LoadFromStream(S: TStream); +var + I, K: Integer; +begin + S.Read(K, SizeOf(Integer)); + for I := 0 to K - 1 do + AddRecord.LoadFromStream(S); +end; + +// TTypeMapRec ----------------------------------------------------------------- + +constructor TTypeMapRec.Create; +begin + inherited; + Fields := TIntegerList.Create; +end; + +destructor TTypeMapRec.Destroy; +begin + FreeAndNil(Fields); + inherited; +end; + +// TTypeMap -------------------------------------------------------------------- + +function TTypeMap.Lookup(TypeId: Integer): TTypeMapRec; +var + I: Integer; +begin + result := nil; + for I := 0 to Count - 1 do + if Records[I].TypeId = TypeId then + begin + result := Records[I]; + Exit; + end; +end; + +function TTypeMap.GetRecord(I: Integer): TTypeMapRec; +begin + result := TTypeMapRec(L[I]); +end; + +function TTypeMap.Add(TypeId: Integer): TTypeMapRec; +begin + result := Lookup(TypeId); + if result <> nil then + Exit; + result := TTypeMapRec.Create; + result.TypeId := TypeId; + L.Add(result); +end; + +// TMapFieldRec ---------------------------------------------------------------- + +procedure TMapFieldRec.SaveToStream(S: TStream); +begin + SaveStringToStream(FieldName, S); + S.Write(FieldOffset, SizeOf(FieldOffset)); +{$IFDEF PCU_EX} + SaveStringToStream(FieldTypeName, S); +{$ENDIF} +end; + +procedure TMapFieldRec.LoadFromStream(S: TStream); +begin + FieldName := LoadStringFromStream(S); + S.Read(FieldOffset, SizeOf(FieldOffset)); +{$IFDEF PCU_EX} + FieldTypeName := LoadStringFromStream(S); +{$ENDIF} +end; + +// TMapFieldList --------------------------------------------------------------- + +function TMapFieldList.GetRecord(I: Integer): TMapFieldRec; +begin + result := TMapFieldRec(L[I]); +end; + +function TMapFieldList.Lookup(const FieldName: String): TMapFieldRec; +var + I: Integer; +begin + result := nil; + for I := 0 to Count - 1 do + if StrEql(Records[I].FieldName, FieldName) then + begin + result := Records[I]; + Exit; + end; +end; + +procedure TMapFieldList.SaveToStream(S: TStream); +var + I, K: Integer; +begin + K := Count; + S.Write(K, SizeOf(K)); + for I := 0 to Count - 1 do + Records[I].SaveToStream(S); +end; + +procedure TMapFieldList.LoadFromStream(S: TStream); +var + I, K: Integer; + R: TMapFieldRec; +begin + S.Read(K, SizeOf(K)); + for I := 0 to K - 1 do + begin + R := TMapFieldRec.Create; + R.LoadFromStream(S); + L.Add(R); + end; +end; + +function TMapFieldList.Add(const FieldName: String; + FieldOffset: Integer; + const FieldTypeName: String): TMapFieldRec; +begin + result := TMapFieldRec.Create; + result.FieldName := FieldName; + result.FieldOffset := FieldOffset; +{$IFDEF PCU_EX} + result.FieldTypeName := FieldTypeName; +{$ENDIF} + L.Add(result); +end; + +// TMapRec --------------------------------------------------------------------- + +constructor TMapRec.Create; +begin + inherited; + FieldList := nil; + SubDesc := TSubDesc.Create; +end; + +destructor TMapRec.Destroy; +begin + if Assigned(FieldList) then + FreeAndNil(FieldList); + + FreeAndNil(SubDesc); + + inherited; +end; + +function TMapRec.GetIsMethod: Boolean; +begin + result := SubDesc.IsMethod; +end; + +procedure TMapRec.SaveToStream(S: TStream); +begin + SaveStringToStream(FullName, S); + S.Write(Offset, SizeOf(Offset)); + S.Write(ClassIndex, SizeOf(ClassIndex)); + S.Write(Kind, SizeOf(Kind)); + S.Write(Global, SizeOf(Global)); + S.Write(Vis, SizeOf(Vis)); + S.Write(TypedConst, SizeOf(TypedConst)); + S.Write(IsExternal, SizeOf(IsExternal)); + SaveStringToStream(FullTypeName, S); + + SubDesc.SaveToStream(S); + + if ClassIndex > 0 then + FieldList.SaveToStream(S); +end; + +procedure TMapRec.LoadFromStream(S: TStream); +begin + FullName := LoadStringFromStream(S); + S.Read(Offset, SizeOf(Offset)); + S.Read(ClassIndex, SizeOf(ClassIndex)); + S.Read(Kind, SizeOf(Kind)); + S.Read(Global, SizeOf(Global)); + S.Read(Vis, SizeOf(Vis)); + S.Read(TypedConst, SizeOf(TypedConst)); + S.Read(IsExternal, SizeOf(IsExternal)); + FullTypeName := LoadStringFromStream(S); + + SubDesc.LoadFromStream(S); + + if ClassIndex > 0 then + begin + if Assigned(FieldList) then + FreeAndNil(FieldList); + + FieldList := TMapFieldList.Create; + FieldList.LoadFromStream(S); + end; +end; + +// TMapTable ------------------------------------------------------------------------ + +function TMapTable.GetRecord(I: Integer): TMapRec; +begin + result := TMapRec(L[I]); +end; + +function TMapTable.Add: TMapRec; +begin + result := TMapRec.Create; + L.Add(result); +end; + +function TMapTable.AddRec(const FullName: String; + Shift: Integer; ClassIndex: Integer; + Kind: Byte; + Global: Boolean; + OverCount: Byte; + CallMode: Byte): TMapRec; +begin + result := Add; + result.FullName := FullName; + result.Shift := Shift; + result.ClassIndex := ClassIndex; + result.Kind := Kind; + result.Global := Global; + + result.SubDesc.OverCount := OverCount; + result.SubDesc.CallMode := CallMode; + + if ClassIndex > 0 then + result.FieldList := TMapFieldList.Create; +end; + +procedure TMapTable.SaveToStream(S: TStream); +var + I, K: Integer; +begin + K := Count; + S.Write(K, SizeOf(Integer)); + for I:=0 to K - 1 do + Records[I].SaveToStream(S); +end; + +procedure TMapTable.LoadFromStream(S: TStream); +var + I, K: Integer; + R: TMapRec; +begin + Clear; + + S.Read(K, SizeOf(Integer)); + for I:=0 to K - 1 do + begin + R := Add; + R.LoadFromStream(S); + end; +end; + +function TMapTable.Lookup(const FullName: String): TMapRec; +var + I: Integer; + S: String; +begin + result := nil; + for I:=0 to Count - 1 do + if StrEql(Records[I].FullName, FullName) then + begin + result := Records[I]; + Exit; + end; + + if ChCount(FullName, '.') <> 1 then + Exit; + + for I:=0 to Count - 1 do + begin + S := Records[I].FullName; + if ChCount(S, '.') = 2 then + if StrEql(FullName, ExtractFullName(S)) then + begin + result := Records[I]; + Exit; + end; + end; +end; + +function TMapTable.LookupEx(const FullName: String; OverCount: Integer): TMapRec; +var + I: Integer; + S: String; +begin + result := nil; + for I:=0 to Count - 1 do + begin + if Records[I].Kind in KindSUBS then + begin + if Records[I].SubDesc.OverCount = OverCount then + if StrEql(Records[I].FullName, FullName) then + begin + result := Records[I]; + Exit; + end; + end + else + begin + if StrEql(Records[I].FullName, FullName) then + begin + result := Records[I]; + Exit; + end; + end; + end; + + if ChCount(FullName, '.') <> 1 then + Exit; + for I:=0 to Count - 1 do + if Records[I].Kind in KindSUBS then + begin + if Records[I].SubDesc.OverCount = OverCount then + begin + S := Records[I].FullName; + if ChCount(S, '.') = 2 then + if StrEql(FullName, ExtractFullName(S)) then + begin + result := Records[I]; + Exit; + end; + end; + end + else + begin + S := Records[I].FullName; + if ChCount(S, '.') = 2 then + if StrEql(FullName, ExtractFullName(S)) then + begin + result := Records[I]; + Exit; + end; + end; +end; + +function TMapTable.LookupByOffset(Offset: Integer): TMapRec; +var + I: Integer; +begin + result := nil; + for I:=0 to Count - 1 do + if Records[I].Offset = Offset then + begin + result := Records[I]; + Exit; + end; +end; + +function TMapTable.LookupConstructor(const AClassName: String; NP: Integer): TMapRec; +var + I: Integer; + S: String; + MR: TMapRec; +begin + result := nil; + for I:=0 to Count - 1 do + begin + MR := Records[I]; + if MR.Kind = kindCONSTRUCTOR then + if MR.SubDesc.ParamList.Count = NP then + begin + S := ExtractClassName(MR.FullName); + if StrEql(S, AClassName) then + begin + result := MR; + Exit; + end; + end; + end; +end; + +function TMapTable.LookupType(const FullName: String): TMapRec; +var + I: Integer; + S1, S2: String; +begin + result := nil; + + S1 := ExtractName(FullName); + for I:=0 to Count - 1 do + if Records[I].Kind = kindTYPE then + begin + S2 := ExtractName(Records[I].FullName); + if StrEql(S1, S2) then + begin + result := Records[I]; + Exit; + end; + end; +end; + +function TMapTable.LookupSub(SubId: Integer): TMapRec; +var + I: Integer; + MR: TMapRec; +begin + result := nil; + for I:=0 to Count - 1 do + begin + MR := Records[I]; + if MR.Kind in kindSUBS then + if MR.SubDesc.SId = SubId then + begin + result := MR; + Exit; + end; + end; +end; + +procedure TMapTable.CreateOffsets(OffsetList: TOffsetList; Host: Boolean); +var + I, S, Q: Integer; + MapRec: TMapRec; +begin + if OffsetList.Count > 0 then + for I := 0 to Count - 1 do + begin + MapRec := Records[I]; + + if (not Host) and (MapRec.Kind in KindSUBS) then + begin + MapRec.Offset := MapRec.Shift; + continue; + end; + + S := MapRec.Shift; + if S > 0 then + begin + Q := OffsetList.GetOffset(S); + if Q = -1 then + raise Exception.Create(errInternalError); + MapRec.Offset := Q; + end; + end + else + for I := 0 to Count - 1 do + begin + MapRec := Records[I]; + MapRec.Offset := MapRec.Shift; + end; +end; + +function TMapTable.GetSub(N: Integer): TMapRec; +var + I: Integer; + MR: TMapRec; +begin + result := nil; + for I := 0 to Count - 1 do + begin + MR := Records[I]; + if MR.Kind in KindSUBS then + if (N >= MR.SubDesc.N1) and (N <= MR.SubDesc.N2) then + begin + result := MR; + Exit; + end; + end; +end; + +end. + diff --git a/Sources/PAXCOMP_MASKS.pas b/Sources/PAXCOMP_MASKS.pas new file mode 100644 index 0000000..412bde5 --- /dev/null +++ b/Sources/PAXCOMP_MASKS.pas @@ -0,0 +1,351 @@ +unit PAXCOMP_MASKS; + +{$I PaxCompiler.def} +{$IFDEF FPC} +{$MODE DELPHI} {$H+} +{$ENDIF} + +interface + +{$IFNDEF VARIANTS} + +implementation + +end. +{$ENDIF} + uses SysUtils; + +type + EMaskException = class(Exception); + + TMask = class + private + FMask: Pointer; + FSize: Integer; + public + constructor Create(const MaskValue: string); + destructor Destroy; override; + function Matches(const FileName: string): Boolean; + end; + +function MatchesMask(const FileName, Mask: string): Boolean; + +implementation + +uses PAXCOMP_SYS, RTLConsts; + +const + MaxCards = 30; + +type + PMaskSet = ^TMaskSet; + TMaskSet = set of AnsiChar; + TMaskStates = (msLiteral, msAny, msSet, msMBCSLiteral); + + TMaskState = record + SkipTo: Boolean; + case State: TMaskStates of + msLiteral: + (Literal: Char); + msAny: + (); + msSet: + (Negate: Boolean; + CharSet: PMaskSet); + msMBCSLiteral: + (LeadByte, TrailByte: Char); + end; + + PMaskStateArray = ^TMaskStateArray; + TMaskStateArray = array [0 .. 128] of TMaskState; + +function InitMaskStates(const Mask: string; var MaskStates: array of TMaskState; + bDontAllocate: Boolean = False): Integer; +var + I: Integer; + SkipTo: Boolean; + Literal: Char; + LeadByte, TrailByte: Char; + P: PChar; + Negate: Boolean; + CharSet: TMaskSet; + Cards: Integer; + + procedure InvalidMask; + begin + raise EMaskException.CreateResFmt(@SInvalidMask, + [Mask, P - PChar(Mask) + 1]); + end; + + procedure Reset; + begin + SkipTo := False; + Negate := False; + CharSet := []; + end; + + procedure WriteScan(MaskState: TMaskStates); + begin + if I <= High(MaskStates) then + begin + if SkipTo then + begin + Inc(Cards); + if Cards > MaxCards then + InvalidMask; + end; + MaskStates[I].SkipTo := SkipTo; + MaskStates[I].State := MaskState; + case MaskState of + msLiteral: + MaskStates[I].Literal := UpCase(Literal); + msSet: + begin + MaskStates[I].Negate := Negate; + if not bDontAllocate then + begin + New(MaskStates[I].CharSet); + MaskStates[I].CharSet^ := CharSet; + end + else + MaskStates[I].CharSet := nil; + end; + msMBCSLiteral: + begin + MaskStates[I].LeadByte := LeadByte; + MaskStates[I].TrailByte := TrailByte; + end; + end; + end; + Inc(I); + Reset; + end; + + procedure ScanSet; + var + LastChar: Char; + C: Char; + begin + Inc(P); + if P^ = '!' then + begin + Negate := True; + Inc(P); + end; + LastChar := #0; + while not((P^ = #0) or (P^ = ']')) do + begin + // MBCS characters not supported in msSet! + if P^ in LeadBytes then + Inc(P) + else + case P^ of + '-': + if LastChar = #0 then + InvalidMask + else + begin + Inc(P); + for C := LastChar to UpCase(P^) do + CharSet := CharSet + [C]; + end; + else + LastChar := UpCase(P^); + CharSet := CharSet + [LastChar]; + end; + Inc(P); + end; + if (P^ <> ']') or (CharSet = []) then + InvalidMask; + WriteScan(msSet); + end; + +begin + P := PChar(Mask); + I := 0; + Cards := 0; + Reset; + while P^ <> #0 do + begin + case P^ of + '*': + SkipTo := True; + '?': + if not SkipTo then + WriteScan(msAny); + '[': + ScanSet; + else + if P^ in LeadBytes then + begin + LeadByte := P^; + Inc(P); + TrailByte := P^; + WriteScan(msMBCSLiteral); + end + else + begin + Literal := P^; + WriteScan(msLiteral); + end; + end; + Inc(P); + end; + Literal := #0; + WriteScan(msLiteral); + Result := I; +end; + +function MatchesMaskStates(const FileName: string; + const MaskStates: array of TMaskState): Boolean; +type + TStackRec = record + sP: PChar; + sI: Integer; + end; +var + T: Integer; + S: array [0 .. MaxCards - 1] of TStackRec; + I: Integer; + P: PChar; + + procedure Push(P: PChar; I: Integer); + begin + with S[T] do + begin + sP := P; + sI := I; + end; + Inc(T); + end; + + function Pop(var P: PChar; var I: Integer): Boolean; + begin + if T = 0 then + Result := False + else + begin + Dec(T); + with S[T] do + begin + P := sP; + I := sI; + end; + Result := True; + end; + end; + + function Matches(P: PChar; Start: Integer): Boolean; + var + I: Integer; + begin + Result := False; + for I := Start to High(MaskStates) do + with MaskStates[I] do + begin + if SkipTo then + begin + case State of + msLiteral: + while (P^ <> #0) and (UpperCase(P^) <> Literal) do + Inc(P); + msSet: + while (P^ <> #0) and not(Negate xor (UpCase(P^) in CharSet^)) do + Inc(P); + msMBCSLiteral: + while (P^ <> #0) do + begin + if (P^ <> LeadByte) then + Inc(P, 2) + else + begin + Inc(P); + if (P^ = TrailByte) then + Break; + Inc(P); + end; + end; + end; + if P^ <> #0 then + Push(@P[1], I); + end; + case State of + msLiteral: + if UpperCase(P^) <> Literal then + Exit; + msSet: + if not(Negate xor (UpCase(P^) in CharSet^)) then + Exit; + msMBCSLiteral: + begin + if P^ <> LeadByte then + Exit; + Inc(P); + if P^ <> TrailByte then + Exit; + end; + end; + Inc(P); + end; + Result := True; + end; + +begin + Result := True; + T := 0; + P := PChar(FileName); + I := Low(MaskStates); + repeat + if Matches(P, I) then + Exit; + until not Pop(P, I); + Result := False; +end; + +procedure DoneMaskStates(var MaskStates: array of TMaskState); +var + I: Integer; +begin + for I := Low(MaskStates) to High(MaskStates) do + if MaskStates[I].State = msSet then + Dispose(MaskStates[I].CharSet); +end; + +{ TMask } + +constructor TMask.Create(const MaskValue: string); +var + A: array [0 .. 0] of TMaskState; +begin + FSize := InitMaskStates(MaskValue, A, True); + FMask := AllocMem(FSize * SizeOf(TMaskState)); + InitMaskStates(MaskValue, Slice(PMaskStateArray(FMask)^, FSize)); +end; + +destructor TMask.Destroy; +begin + if FMask <> nil then + begin + DoneMaskStates(Slice(PMaskStateArray(FMask)^, FSize)); + FreeMem(FMask, FSize * SizeOf(TMaskState)); + end; +end; + +function TMask.Matches(const FileName: string): Boolean; +begin + Result := MatchesMaskStates(FileName, Slice(PMaskStateArray(FMask)^, FSize)); +end; + +function MatchesMask(const FileName, Mask: string): Boolean; +var + CMask: TMask; +begin + CMask := TMask.Create(Mask); + try + Result := CMask.Matches(FileName); + finally + FreeAndNil(CMask); + end; +end; + +end. diff --git a/Sources/PAXCOMP_MODULE.pas b/Sources/PAXCOMP_MODULE.pas new file mode 100644 index 0000000..b8be685 --- /dev/null +++ b/Sources/PAXCOMP_MODULE.pas @@ -0,0 +1,450 @@ +//////////////////////////////////////////////////////////////////////////// +// PaxCompiler +// Site: http://www.paxcompiler.com +// Author: Alexander Baranovsky (paxscript@gmail.com) +// ======================================================================== +// Copyright (c) Alexander Baranovsky, 2006-2014. All rights reserved. +// Code Version: 4.2 +// ======================================================================== +// Unit: PAXCOMP_MODULE.pas +// ======================================================================== +//////////////////////////////////////////////////////////////////////////// + +{$I PaxCompiler.def} +unit PAXCOMP_MODULE; +interface +uses {$I uses.def} + SysUtils, + Classes, + PAXCOMP_CONSTANTS, + PAXCOMP_TYPES, + PAXCOMP_SYS; + +type + TModuleState = (msNone, msCompiling, msCompiled); + + TModule = class + private + kernel: Pointer; + UsedModules: TIntegerList; + TempUsedModules: TIntegerList; + public + Name: String; + LanguageName: String; + FileName: String; + Lines: TStringList; + S1, S2, S3: Integer; + P1, P2, P3: Integer; + PInitBegin, PInitEnd: Integer; + PFinBegin, PFinEnd: Integer; + ModuleNumber: Integer; + CancelPos: Integer; + SkipParsing: Boolean; + State: TModuleState; + IsExtra: Boolean; + IsPCU: Boolean; + IncludedFiles: TStringList; + constructor Create(i_kernel: Pointer); + destructor Destroy; override; + procedure Recalc; + end; + + TModuleList = class(TTypedList) + private + kernel: Pointer; + function GetModule(I: Integer): TModule; + public + LoadOrder: TIntegerList; + constructor Create(i_kernel: Pointer); + destructor Destroy; override; + function AddModule(const ModuleName, LanguageName: String): TModule; + function IndexOf(const ModuleName: String): Integer; + function IndexOfModuleById(Id: Integer): Integer; + function IsDefinedInPCU(Id: Integer): Boolean; + function GetPos(const ModuleName: String; X, Y: Integer): Integer; + procedure Recalc; + procedure CreateLoadOrder; + procedure SaveScript(const FileName: String); + procedure CreateError(const Message: string; params: array of Const); + procedure RaiseError(const Message: string; params: array of Const); + procedure Delete(M: TModule); + property Modules[I: Integer]: TModule read GetModule; default; + end; + +implementation + +uses + PAXCOMP_BYTECODE, + PAXCOMP_SYMBOL_TABLE, + PAXCOMP_KERNEL; + +constructor TModule.Create(i_kernel: Pointer); +begin + inherited Create; + Self.kernel := i_kernel; + Lines := TStringList.Create; + UsedModules := TIntegerList.Create; + TempUsedModules := TIntegerList.Create; + IncludedFiles := TStringList.Create; + + S1 := 0; + S2 := 0; + S3 := 0; + P1 := 0; + P2 := 0; + P3 := 0; + PInitBegin := 0; + PInitEnd := 0; + PFinBegin := 0; + PFinEnd := 0; + + CancelPos := -1; +end; + +destructor TModule.Destroy; +begin + FreeAndNil(Lines); + FreeAndNil(UsedModules); + FreeAndNil(TempUsedModules); + FreeAndNil(IncludedFiles); + + inherited; +end; + +procedure TModule.Recalc; +var + I: Integer; +begin + for I:=1 to TKernel(kernel).Code.Card do + with TKernel(kernel).Code[I] do + if (Op = OP_BEGIN_MODULE) and (Arg1 = ModuleNumber) then + P1 := I + else if (Op = OP_END_INTERFACE_SECTION) and (Arg1 = ModuleNumber) then + P2 := I + else if (Op = OP_END_MODULE) and (Arg1 = ModuleNumber) then + P3 := I + else if (Op = OP_BEGIN_INITIALIZATION) and (Arg1 = ModuleNumber) then + PInitBegin := I + else if (Op = OP_END_INITIALIZATION) and (Arg1 = ModuleNumber) then + PInitEnd := I + else if (Op = OP_BEGIN_FINALIZATION) and (Arg1 = ModuleNumber) then + PFinBegin := I + else if (Op = OP_END_FINALIZATION) and (Arg1 = ModuleNumber) then + PFinEnd := I; +end; + +constructor TModuleList.Create(i_kernel: Pointer); +begin + inherited Create; + Self.kernel := i_kernel; + LoadOrder := TIntegerList.Create; +end; + +destructor TModuleList.Destroy; +begin + FreeAndNil(LoadOrder); + inherited; +end; + +function TModuleList.AddModule(const ModuleName, LanguageName: String): TModule; +begin + result := TModule.Create(kernel); + result.Name := ModuleName; + result.LanguageName := LanguageName; + L.Add(result); +end; + +procedure TModuleList.Delete(M: TModule); +var + I: Integer; +begin + for I:=Count - 1 downto 0 do + if Modules[I] = M then + begin + L.Delete(I); + FreeAndNil(M); + end; +end; + +function TModuleList.GetPos(const ModuleName: String; X, Y: Integer): Integer; +var + S: String; + I, L, CurrX, CurrY: Integer; + ch: Char; +begin + TKernel(kernel).CompletionPrefix := ''; + result := -1; + I := IndexOf(ModuleName); + if I = -1 then + Exit; + S := Modules[I].Lines.Text + #255; + CurrX := -1; + CurrY := 0; + + I := SLow(S) - 1; + L := SHigh(S); + while I < L do + begin + Inc(I); + Inc(CurrX); + + if (CurrX = X) and (CurrY = Y) then + begin + if TKernel(kernel).FindDeclId < 0 then + begin + result := I; + Exit; + end; + + if ByteInSet(S[I], IdsSet + WhiteSpaces + [Ord('!'), Ord('.'), + Ord('('), Ord(')'), Ord(';'), Ord(',')]) then + begin + if ByteInSet(S[I], WhiteSpaces + [Ord(';'), Ord(')'), Ord(',')]) and + (ByteInSet(S[I - 1], IdsSet + [Ord('.')])) then + begin + Dec(i); + end; + if IsAlpha(S[I]) then + begin + while ByteInSet(S[I], IdsSet) do + begin + TKernel(kernel).CompletionPrefix := S[I] + TKernel(kernel).CompletionPrefix; + + Dec(I); + if I = 0 then + Exit; + end; + end; + + result := I; + Exit; + end; + end; + + ch := S[I]; + if ByteInSet(ch, [10, 13]) then + begin + Inc(CurrY); + if S[I + 1] = #10 then + Inc(I); + CurrX := -1; + end; + + if (CurrX = X) and (CurrY = Y) then + begin + if ByteInSet(S[I], IdsSet + WhiteSpaces + [Ord('.'), Ord('('), Ord(')'), + Ord(';'), Ord(',')]) then + begin + if ByteInSet(S[I], WhiteSpaces + [Ord(';'), Ord(')'), Ord(',')]) and + (ByteInSet(S[I - 1], IdsSet + [Ord('.')])) then + begin + Dec(i); + end; + if IsAlpha(S[I]) then + begin + while ByteInSet(S[I], IdsSet) do + begin + TKernel(kernel).CompletionPrefix := S[I] + TKernel(kernel).CompletionPrefix; + + Dec(I); + if I = 0 then + Exit; + end; + end; + + result := I; + Exit; + end; + end; + end; +end; + +function TModuleList.IndexOf(const ModuleName: String): Integer; +var + I: Integer; +begin + result := -1; + for I := 0 to Count - 1 do + if StrEql(Modules[I].Name, ModuleName) then + begin + result := I; + Exit; + end; +end; + +function TModuleList.GetModule(I: Integer): TModule; +begin + result := TModule(L[I]); +end; + +function TModuleList.IndexOfModuleById(Id: Integer): Integer; +var + I: Integer; + M: TModule; +begin + for I:=0 to Count - 1 do + begin + M := Modules[I]; + if (Id >= M.S1) and (Id <= M.S3) then + begin + result := I; + Exit; + end; + end; + result := -1; +end; + +function TModuleList.IsDefinedInPCU(Id: Integer): Boolean; +var + I: Integer; +begin + result := false; + I := IndexOfModuleById(Id); + if I = -1 then + Exit; + result := Modules[I].IsPCU; +end; + +procedure TModuleList.Recalc; +var + I: Integer; +begin + for I:=0 to Count - 1 do + Modules[I].Recalc; +end; + +procedure TModuleList.CreateLoadOrder; +var + I, J: Integer; + M: TModule; + Code: TCode; + SymbolTable: TSymbolTable; + Id: Integer; + ModuleIndex: Integer; + ok: Boolean; + CurrModuleName: String; +begin + if TKernel(kernel).SignCodeCompletion then + begin + LoadOrder.Clear; + LoadOrder.Add(0); + Exit; + end; + + Code := TKernel(kernel).Code; + SymbolTable := TKernel(kernel).SymbolTable; + + Recalc; + + for I:=0 to Count - 1 do + begin + M := Modules[I]; + M.UsedModules.Clear; + M.TempUsedModules.Clear; + + CurrModuleName := M.Name; + + for J := M.P1 to M.P2 do + begin + if Code[J].Op = OP_END_IMPORT then + break; + + if Code[J].Op = OP_BEGIN_USING then + begin + Id := Code[J].Arg1; + if SymbolTable[Id].Host then + continue; + if Id = 0 then + continue; + if StrEql(ExtractName(SymbolTable[Id].Name), ExtractName(CurrModuleName)) then + continue; + ModuleIndex := IndexOfModuleById(Id); + if ModuleIndex = -1 then + RaiseError(errInternalError, []); + M.UsedModules.Add(ModuleIndex); + M.TempUsedModules.Add(ModuleIndex); + end; + end; + end; + + LoadOrder.Clear; + + if Count = 0 then + Exit; + + if Count = 1 then + begin + LoadOrder.Add(0); + Exit; + end; + + if TKernel(kernel).InterfaceOnly then + begin + for I:=0 to Count - 1 do + LoadOrder.Add(I); + Exit; + end; + + repeat + ok := false; + + for I:=0 to Count - 1 do + begin + if LoadOrder.IndexOf(I) >= 0 then + continue; + + M := Modules[I]; + if M.TempUsedModules.Count = 0 then + begin + ok := true; + LoadOrder.Add(I); + if LoadOrder.Count = Count then + Exit; + for J:=0 to Count - 1 do + Modules[J].TempUsedModules.DeleteValue(I); + break; + end; + end; + + if not ok then + for I:=0 to Count - 1 do + if LoadOrder.IndexOf(I) = -1 then + begin + CreateError(errCircularUnitReference, [Modules[I].Name]); + Exit; + end; + + until false; +end; + +procedure TModuleList.CreateError(const Message: string; params: array of Const); +begin + TKernel(kernel).CreateError(Message, params); +end; + +procedure TModuleList.RaiseError(const Message: string; params: array of Const); +begin + TKernel(kernel).RaiseError(Message, params); +end; + +procedure TModuleList.SaveScript(const FileName: String); +var + I: Integer; + S: String; + Lst: TStringList; +begin + if not IsDump then + Exit; + S := ''; + for I:=0 to Count - 1 do + S := S + Modules[I].Lines.Text; + Lst := TStringList.Create; + try + Lst.Text := S; + Lst.SaveToFile(FileName); + finally + FreeAndNil(Lst); + end; +end; + +end. diff --git a/Sources/PAXCOMP_OFFSET.pas b/Sources/PAXCOMP_OFFSET.pas new file mode 100644 index 0000000..627763c --- /dev/null +++ b/Sources/PAXCOMP_OFFSET.pas @@ -0,0 +1,298 @@ +//////////////////////////////////////////////////////////////////////////// +// PaxCompiler +// Site: http://www.paxcompiler.com +// Author: Alexander Baranovsky (paxscript@gmail.com) +// ======================================================================== +// Copyright (c) Alexander Baranovsky, 2006-2014. All rights reserved. +// Code Version: 4.2 +// ======================================================================== +// Unit: PAXCOMP_SYMBOL_OFFSET.pas +// ======================================================================== +//////////////////////////////////////////////////////////////////////////// + +{$I PaxCompiler.def} +{$O+} +unit PAXCOMP_OFFSET; +interface +uses {$I uses.def} + TypInfo, + SysUtils, + Classes, + PAXCOMP_CONSTANTS, + PAXCOMP_TYPES, + PAXCOMP_SYS; + +type + TOffsetRec = class + public + Id: Integer; + Shift: Integer; + Offset: Integer; + Size: Integer; + function Clone: TOffsetRec; + procedure SaveToStream(S: TStream); + procedure LoadFromStream(S: TStream); + end; + + TOffsetList = class(TTypedList) + private + Sorted: Boolean; + function GetRecord(I: Integer): TOffsetRec; + procedure SetRecord(I: Integer; value: TOffsetRec); + public + InitSize: Integer; + constructor Create; + function Add(Id, Shift, Offset, Size: Integer): TOffsetRec; + procedure Clear; override; + function Clone: TOffsetList; + function GetSize: Integer; + function GetOffset(Shift: Integer): Integer; + function HasId(Id: Integer): Boolean; + procedure SaveToStream(S: TStream); + procedure LoadFromStream(S: TStream); + function GetOffsetById(Id: Integer): Integer; + property Records[I: Integer]: TOffsetRec read GetRecord write SetRecord; default; + end; + +procedure TOffsetList_Sort(Self: TOffsetList); + +implementation + +// TOffsetRec ------------------------------------------------------------------ + +function TOffsetRec.Clone: TOffsetRec; +begin + result := TOffsetRec.Create; + result.Id := Id; + result.Shift := Shift; + result.Offset := Offset; + result.Size := Size; +end; + +procedure TOffsetRec.SaveToStream(S: TStream); +begin + S.Write(Shift, SizeOf(Shift)); + S.Write(Offset, SizeOf(Offset)); +end; + +procedure TOffsetRec.LoadFromStream(S: TStream); +begin + S.Read(Shift, SizeOf(Shift)); + S.Read(Offset, SizeOf(Offset)); +end; + +// TOffsetList ----------------------------------------------------------------- + +constructor TOffsetList.Create; +begin + inherited; + InitSize := 0; + Sorted := false; +end; + +function TOffsetList.Add(Id, Shift, Offset, Size: Integer): TOffsetRec; +begin + result := TOffsetRec.Create; + result.Id := Id; + result.Shift := Shift; + result.Offset := Offset; + result.Size := Size; + L.Add(result); +end; + +function TOffsetList.GetSize: Integer; +var + I, SZ: Integer; +begin + result := InitSize; + for I := 0 to Count - 1 do + begin + SZ := Records[I].Size; + Inc(result, SZ); + end; +end; + +function BinSearch(List: TOffsetList; const Key: Integer): Integer; +var + First: Integer; + Last: Integer; + Pivot: Integer; + Found: Boolean; +begin + First := 0; + Last := List.Count - 1; + Found := False; + Result := -1; + + while (First <= Last) and (not Found) do + begin + Pivot := (First + Last) div 2; + if TOffsetRec(List.L[Pivot]).Shift = Key then + begin + Found := True; + Result := Pivot; + end + else if TOffsetRec(List.L[Pivot]).Shift > Key then + Last := Pivot - 1 + else + First := Pivot + 1; + end; +end; + +function TOffsetList.GetOffset(Shift: Integer): Integer; +var + I: Integer; + R: TOffsetRec; +begin + result := -1; + + if Shift < StdSize then + begin + result := Shift; + Exit; + end; + + if Sorted then + begin + I := BinSearch(Self, Shift); + if I = -1 then + Exit; + result := Records[I].Offset; + Exit; + end; + + for I := 0 to Count - 1 do + begin + R := Records[I]; + if R.Shift = Shift then + begin + result := R.Offset; + Exit; + end; + end; +end; + +function TOffsetList.HasId(Id: Integer): Boolean; +var + I: Integer; + R: TOffsetRec; +begin + for I := 0 to Count - 1 do + begin + R := Records[I]; + if R.Id = Id then + begin + result := true; + Exit; + end; + end; + result := false; +end; + +function TOffsetList.GetRecord(I: Integer): TOffsetRec; +begin + result := TOffsetRec(L[I]); +end; + +procedure TOffsetList.SetRecord(I: Integer; value: TOffsetRec); +begin + L[I] := value; +end; + +function TOffsetList.GetOffsetById(Id: Integer): Integer; +var + I: Integer; +begin + for I:=0 to Count - 1 do + if Records[I].Id = Id then + begin + result := Records[I].Offset; + Exit; + end; + raise Exception.Create(errInternalError); +end; + +procedure TOffsetList.Clear; +begin + inherited; + InitSize := 0; + Sorted := false; +end; + +function TOffsetList.Clone: TOffsetList; +var + I: Integer; + R: TOffsetRec; +begin + result := TOffsetList.Create; + for I := 0 to Count - 1 do + begin + R := Records[I].Clone; + result.L.Add(R); + end; +end; + +procedure TOffsetList.SaveToStream(S: TStream); +var + I, K: Integer; +begin + K := Count; + S.Write(K, SizeOf(Integer)); + for I := 0 to K - 1 do + Records[I].SaveToStream(S); +end; + +procedure TOffsetList.LoadFromStream(S: TStream); +var + I, K: Integer; + R: TOffsetRec; +begin + S.Read(K, SizeOf(Integer)); + for I := 0 to K - 1 do + begin + R := TOffsetRec.Create; + R.LoadFromStream(S); + L.Add(R); + end; +end; + +procedure QuickSort(var List: TOffsetList; Start, Stop: Integer); +var + Left: Integer; + Right: Integer; + Mid: Integer; + Pivot: TOffsetRec; + Temp: TOffsetRec; +begin + Left := Start; + Right := Stop; + Mid := (Start + Stop) div 2; + + Pivot := List[mid]; + repeat + while List[Left].Shift < Pivot.Shift do Inc(Left); + while Pivot.Shift < List[Right].Shift do Dec(Right); + if Left <= Right then + begin + Temp := List[Left]; + List[Left] := List[Right]; // Swops the two Strings + List[Right] := Temp; + Inc(Left); + Dec(Right); + end; + until Left > Right; + + if Start < Right then QuickSort(List, Start, Right); // Uses + if Left < Stop then QuickSort(List, Left, Stop); // Recursion +end; + +procedure TOffsetList_Sort(Self: TOffsetList); +begin + if Self.Count > 0 then + begin + QuickSort(Self, 0, Self.Count - 1); + Self.Sorted := true; + end; +end; + +end. diff --git a/Sources/PAXCOMP_OLE.pas b/Sources/PAXCOMP_OLE.pas new file mode 100644 index 0000000..f6a40be --- /dev/null +++ b/Sources/PAXCOMP_OLE.pas @@ -0,0 +1,938 @@ +//////////////////////////////////////////////////////////////////////////// +// PaxCompiler +// Site: http://www.paxcompiler.com +// Author: Alexander Baranovsky (paxscript@gmail.com) +// ======================================================================== +// Copyright (c) Alexander Baranovsky, 2006-2014. All rights reserved. +// Code Version: 4.2 +// ======================================================================== +// Unit: PAXCOMP_OLE.pas +// ======================================================================== +//////////////////////////////////////////////////////////////////////////// + +{$I PaxCompiler.def} +unit PAXCOMP_OLE; +interface + +{$IFDEF PAXARM} +implementation +end. +{$ENDIF} + +{$IFDEF FPC} +implementation +end. +{$ENDIF} + +{$IFDEF MACOS} +implementation +end. +{$ENDIF} + +uses +{$IFDEF VARIANTS} + Variants, +{$ENDIF} + SysUtils, + {$IFDEF DPULSAR} + {$IFDEF MACOS32} + {$ELSE} + Winapi.Windows, + System.Win.ComObj, + System.Win.ComConst, + Winapi.ActiveX, + {$ENDIF} + {$ELSE} + Windows, + ComConst, + ComObj, + ActiveX, + {$ENDIF} + PAXCOMP_TYPES, + PAXCOMP_SYS; + +procedure _GetOLEProperty(const D: Variant; PropName: PChar; + var Result: Variant; + ParamsCount: Integer); stdcall; +procedure _SetOLEProperty(const D: Variant; PropName: PChar; + const Value: Variant; + ParamsCount: Integer); stdcall; +const + atVarMask = $3F; + atTypeMask = $7F; + atByRef = $80; + +var + Unassigned: Variant; + +implementation + +uses + PAXCOMP_CONSTANTS, + PaxCompiler, + AnsiStrings; + +type + TOleHelperRec = class + public + DispId: Integer; + Index: Integer; + end; + + TOleHelperList = class(TTypedList) + private + function GetRecord(I: Integer): TOleHelperRec; + public + function Add(DispId: Integer; Index: Integer): TOleHelperRec; + function FindIndex(DispId: Integer): Integer; + property Records[I: Integer]: TOleHelperRec read GetRecord; default; + end; + +function TOleHelperList.GetRecord(I: Integer): TOleHelperRec; +begin + result := TOleHelperRec(L[I]); +end; +function TOleHelperList.Add(DispId: Integer; Index: Integer): TOleHelperRec; +begin + result := TOleHelperRec.Create; + result.DispId := DispId; + result.Index := Index; + L.Add(result); +end; +function TOleHelperList.FindIndex(DispId: Integer): Integer; +var + I: Integer; + R: TOleHelperRec; +begin + result := -1; + for I := 0 to Count - 1 do + begin + R := Records[I]; + if R.DispId = DispId then + begin + result := R.Index; + Exit; + end; + end; +end; + +var FOleHelperList: TOleHelperList; + +function OLEHelperList : TOleHelperList; +begin + if not assigned(FOleHelperList) then + FOleHelperList := TOleHelperList.create; + result := FOleHelperList; +end; + +const + MaxDispArgs = 64; +type + TIntArr = array[0..100] of LongInt; + PIntArr = ^TIntArr; + TBoolArr = array[0..30] of Boolean; + PBoolArr = ^TBoolArr; + TStringArr = array[0..30] of String; + PStringArr = ^TStringArr; + TDoubleArr = array[0..30] of Double; + PDoubleArr = ^TDoubleArr; + TCurrencyArr = array[0..30] of Currency; + PCurrencyArr = ^TCurrencyArr; + TVariantArr = array[0..30] of Variant; + PVariantArr = ^TVariantArr; + +{$IFDEF PAX64} +procedure GetIDsOfNames(const Dispatch: IDispatch; Names: PAnsiChar; + NameCount: Integer; DispIDs: PDispIDList); +type + PNamesArray = ^TNamesArray; + TNamesArray = array[0..100] of PWideChar; + + TArrayOfNamesArray = array[0..20] of TNamesArray; + + procedure RaiseNameException; + begin + raise EOleError.CreateFmt(SNoMethod, [Names]); + end; + +var + N, SrcLen, DestLen: Integer; + Src: PAnsiChar; + Dest: PWideChar; + NameRefs: TNamesArray; + StackTop: Pointer; + Temp: Integer; + + buff: array[0..20] of TNamesArray; + +begin + Src := Names; + N := 0; + + repeat + SrcLen := SysUtils.StrLen(Src); + DestLen := MultiByteToWideChar(0, 0, Src, SrcLen, nil, 0) + 1; + + Dest := @ buff[N]; + + if N = 0 then + NameRefs[0] := Dest + else + NameRefs[NameCount - N] := Dest; + + MultiByteToWideChar(0, 0, Src, SrcLen, Dest, DestLen); + Dest[DestLen-1] := #0; + Inc(Src, SrcLen+1); + Inc(N); + until N = NameCount; + Temp := Dispatch.GetIDsOfNames(GUID_NULL, @NameRefs, NameCount, + GetThreadLocale, DispIDs); + if Temp = Integer(DISP_E_UNKNOWNNAME) then RaiseNameException else OleCheck(Temp); +end; +{$ELSE} + +procedure GetIDsOfNames(const Dispatch: IDispatch; Names: PAnsiChar; + NameCount: Integer; DispIDs: PDispIDList); + + procedure RaiseNameException; + begin + raise EOleError.CreateFmt(SNoMethod, [Names]); + end; + +type + PNamesArray = ^TNamesArray; + TNamesArray = array[0..0] of PWideChar; +var + N, SrcLen, DestLen: Integer; + Src: PAnsiChar; + Dest: PWideChar; + NameRefs: PNamesArray; + StackTop: Pointer; + Temp: Integer; +begin + Src := Names; + N := 0; + asm + MOV StackTop, ESP + MOV EAX, NameCount + INC EAX + SHL EAX, 2 // sizeof pointer = 4 + SUB ESP, EAX + LEA EAX, NameRefs + MOV [EAX], ESP + end; + repeat + SrcLen := AnsiStrings.StrLen(Src); + DestLen := MultiByteToWideChar(0, 0, Src, SrcLen, nil, 0) + 1; + asm + MOV EAX, DestLen + ADD EAX, EAX + ADD EAX, 3 // round up to 4 byte boundary + AND EAX, not 3 + SUB ESP, EAX + LEA EAX, Dest + MOV [EAX], ESP + end; + if N = 0 then NameRefs[0] := Dest else NameRefs[NameCount - N] := Dest; + MultiByteToWideChar(0, 0, Src, SrcLen, Dest, DestLen); + Dest[DestLen-1] := #0; + Inc(Src, SrcLen+1); + Inc(N); + until N = NameCount; + Temp := Dispatch.GetIDsOfNames(GUID_NULL, NameRefs, NameCount, + GetThreadLocale, DispIDs); + if Temp = Integer(DISP_E_UNKNOWNNAME) then RaiseNameException else OleCheck(Temp); + asm + MOV ESP, StackTop + end; +end; +{$ENDIF} + +procedure MyDispatchInvoke(const Dispatch: IDispatch; + CallDesc: PCallDesc; + DispIDs: PDispIDList; + Params: Pointer; + Result: PVariant; + var ByRefs: TBoolArr; + ParamsCount: Integer; + const P: Variant; + var SS: TStringArr; + var II: TIntArr; + var DD: TDoubleArr; + var CC: TCurrencyArr; + var VV: TVariantArr); +type + PVarArg = ^TVarArg; +{$IFDEF PAX64} + TVarArg = array[0..5] of DWORD; +{$ELSE} + TVarArg = array[0..3] of DWORD; +{$ENDIF} + TStringDesc = record + BStr: PWideChar; + PStr: PString; + end; +var + I, J, K, ArgType, ArgCount, StrCount, DispID, InvKind, Status: Integer; + VarFlag: Byte; + ParamPtr: ^Integer; + ArgPtr, VarPtr: PVarArg; + DispParams: TDispParams; + ExcepInfo: TExcepInfo; + Strings: array[0..MaxDispArgs - 1] of TStringDesc; + Args: array[0..MaxDispArgs - 1] of TVarArg; + + TypeInfoCount: Integer; + TypeInfo: ITypeInfo2; + pfdesc: PFuncDesc; + FuncIndex: Cardinal; + W: Word; + VT: Integer; + VCount: Integer; + + VTypes: array[0..30] of Integer; + Processed: Boolean; + B1, B2: Integer; +begin + FillChar(ByRefs, SizeOf(ByRefs), 0); + FillChar(VTypes, SizeOf(VTypes), 0); + + if ParamsCount > 0 then + begin + Dispatch.GetTypeInfoCount(TypeInfoCount); + if TypeInfoCount = 1 then + begin + if Dispatch.GetTypeInfo(0, GetThreadLocale, TypeInfo) = S_OK then + begin + DispID := DispIDs[0]; + Processed := false; + + B1 := OleHelperList.FindIndex(DispId); + if B1 >= 0 then + B2 := B1 + else + begin + B1 := 0; + B2 := 1000; + end; + + for FuncIndex := B1 to B2 do + begin + if Processed then + break; + + if TypeInfo.GetFuncDesc(FuncIndex, pfdesc) <> S_OK then + begin + TypeInfo.ReleaseFuncDesc(pfdesc); + break; + end; + + if pfdesc^.cparams < ParamsCount then + continue; + + if pfdesc^.memid = DispId then + try + OleHelperList.Add(DispId, FuncIndex); + + for I:=0 to ParamsCount - 1 do + begin + W := pfdesc^.lprgelemdescParam[I].paramdesc.wParamFlags; + VTypes[I] := pfdesc^.lprgelemdescParam[I].tdesc.vt; +// if (W = PARAMFLAG_FOUT) or (W = PARAMFLAG_FRETVAL) then + if ((W and PARAMFLAG_FOUT) = PARAMFLAG_FOUT) or ((W and PARAMFLAG_FRETVAL) = PARAMFLAG_FRETVAL) then + begin + ByRefs[I] := true; + CallDesc.ArgTypes[I] := CallDesc.ArgTypes[I] or atByRef; + end; + end; + finally + Processed := true; + TypeInfo.ReleaseFuncDesc(pfdesc); + end; + end; // for-loop + end; + end; + end; + + K := -1; + for I := 1 to ParamsCount do + begin + VT := TVarData(P[I]).VType; + VCount := VarArrayDimCount(P[I]); + + if VT = 0 then + begin + VT := VTypes[I-1]; + if VT = 26 then + VT := varOleStr; + end; + if VT = varUnknown then + VT := varDispatch; + + if (VT in [VarInteger,VarSmallInt,VarByte]) and (VCount=0) then + begin + II[I] := P[I]; + Inc(K); + if ByRefs[I-1] then + PIntArr(Params)^[K] := IntPax(@II[I]) + else + PIntArr(Params)^[K] := II[I]; + end + else if VT = VarError then + begin + Inc(K); + end + else if VT = VarOleStr then + begin + SS[I] := P[I]; + Inc(K); + if ByRefs[I-1] then + PIntArr(Params)^[K] := IntPax(@SS[I]) + else + PIntArr(Params)^[K] := IntPax(SS[I]); // byval only + end + else if (VT = VarVariant) or (VT = VarDispatch) or (VCount > 0) then + begin + VV[I] := P[I]; + Inc(K); + + if ByRefs[I-1] then + PIntArr(Params)^[K] := IntPax(@VV[I]) + else + begin + Move(VV[I], PIntArr(Params)^[K], SizeOf(Variant)); + Inc(K); + Inc(K); + Inc(K); + end; + end + else if VT = VarDouble then + begin + DD[I] := P[I]; + Inc(K); + + if ByRefs[I-1] then + PIntArr(Params)^[K] := Integer(@DD[I]) + else + begin + Move(DD[I], PIntArr(Params)^[K], SizeOf(Double)); + Inc(K); + end; + end + else if VT = VarCurrency then + begin + CC[I] := P[I]; + Inc(K); + + if ByRefs[I-1] then + PIntArr(Params)^[K] := Integer(@CC[I]) + else + begin + Move(CC[I], PIntArr(Params)^[K], SizeOf(Currency)); + Inc(K); + end; + end; + end; + + StrCount := 0; + try + ArgCount := CallDesc^.ArgCount; + if ArgCount > MaxDispArgs then raise EOleException.CreateRes(@STooManyParams); + if ArgCount <> 0 then + begin + ParamPtr := Params; + ArgPtr := @Args[ArgCount]; + I := 0; + repeat + Dec(IntPax(ArgPtr), SizeOf(TVarData)); + ArgType := CallDesc^.ArgTypes[I] and atTypeMask; + VarFlag := CallDesc^.ArgTypes[I] and atByRef; + if ArgType = varError then + begin + ArgPtr^[0] := varError; + ArgPtr^[2] := DWORD(DISP_E_PARAMNOTFOUND); + end + else + begin + if ArgType = varStrArg then + begin + with Strings[StrCount] do + if VarFlag <> 0 then + begin + BStr := StringToOleStr(PString(ParamPtr^)^); + PStr := PString(ParamPtr^); + PVarData(ArgPtr).VType := varOleStr or VarByRef; + PVarData(ArgPtr).VString := @BStr; + end + else + begin + BStr := StringToOleStr(PString(ParamPtr)^); + PStr := nil; + PVarData(ArgPtr).VType := varOleStr; + PVarData(ArgPtr).VString := BStr; + end; + Inc(StrCount); + end + + else if VarFlag <> 0 then + begin + if (ArgType = varVariant) and + (PVarData(ParamPtr^)^.VType = varString) then + VarCast(PVariant(ParamPtr^)^, PVariant(ParamPtr^)^, varOleStr); + + ArgPtr^[0] := ArgType or varByRef; + ArgPtr^[2] := ParamPtr^; + end + + else if ArgType = varVariant then + begin + if PVarData(ParamPtr)^.VType = varString then + begin + with Strings[StrCount] do + begin + BStr := StringToOleStr(string(PVarData(ParamPtr)^.VString)); + PStr := nil; + PVarData(ArgPtr).VType := varOleStr; + PVarData(ArgPtr).VString := BStr; + end; + Inc(StrCount); + end + else + begin + VarPtr := PVarArg(ParamPtr); + ArgPtr^[0] := VarPtr^[0]; + ArgPtr^[1] := VarPtr^[1]; + ArgPtr^[2] := VarPtr^[2]; + ArgPtr^[3] := VarPtr^[3]; + Inc(IntPax(ParamPtr), 12); + end; + end + + else + begin + ArgPtr^[0] := ArgType; + ArgPtr^[2] := ParamPtr^; + if (ArgType >= varDouble) and (ArgType <= varDate) then + begin + Inc(IntPax(ParamPtr), 4); + ArgPtr^[3] := ParamPtr^; + end; + end; + Inc(IntPax(ParamPtr), 4); + end; + Inc(I); + until I = ArgCount; + end; + DispParams.rgvarg := @Args; + DispParams.rgdispidNamedArgs := @DispIDs[1]; + DispParams.cArgs := ArgCount; + DispParams.cNamedArgs := CallDesc^.NamedArgCount; + DispID := DispIDs[0]; + InvKind := CallDesc^.CallType; + if InvKind = DISPATCH_PROPERTYPUT then + begin + if Args[0][0] and varTypeMask = varDispatch then + InvKind := DISPATCH_PROPERTYPUTREF; + DispIDs[0] := DISPID_PROPERTYPUT; + Dec(IntPax(DispParams.rgdispidNamedArgs), SizeOf(Integer)); + Inc(DispParams.cNamedArgs); + end else + if (InvKind = DISPATCH_METHOD) and (ArgCount = 0) and (Result <> nil) then + InvKind := DISPATCH_METHOD or DISPATCH_PROPERTYGET; + Status := Dispatch.Invoke(DispID, GUID_NULL, 0, InvKind, DispParams, + Result, @ExcepInfo, nil); + if Status <> 0 then DispatchInvokeError(Status, ExcepInfo); + J := StrCount; + while J <> 0 do + begin + Dec(J); + with Strings[J] do + if PStr <> nil then OleStrToStrVar(BStr, PStr^); + end; + finally + K := StrCount; + while K <> 0 do + begin + Dec(K); + SysFreeString(Strings[K].BStr); + end; + end; +end; + +{ Call GetIDsOfNames method on the given IDispatch interface } + +{ Central call dispatcher } + +procedure MyVarDispInvoke(Result: PVariant; const Instance: Variant; + CallDesc : PCallDesc; Params: Pointer; var ByRefs: TBoolArr; + ParamsCount: Integer; + const InitParam: Variant; + var SS: TStringArr; + var II: TIntArr; + var DD: TDoubleArr; + var CC: TCurrencyArr; + var VV: TVariantArr); + + procedure RaiseException; + begin + raise EOleError.Create(SVarNotObject); + end; + +var + Dispatch: Pointer; + DispIDs: array[0..MaxDispArgs - 1] of Integer; +begin + + if TVarData(Instance).VType = varDispatch then + Dispatch := TVarData(Instance).VDispatch + else if TVarData(Instance).VType = (varDispatch or varByRef) then + Dispatch := Pointer(TVarData(Instance).VPointer^) + else + RaiseException; + + GetIDsOfNames(IDispatch(Dispatch), @CallDesc^.ArgTypes[CallDesc^.ArgCount], + CallDesc^.NamedArgCount + 1, @DispIDs); + + if Result <> nil then VarClear(Result^); + + MyDispatchInvoke(IDispatch(Dispatch), CallDesc, @DispIDs, Params, Result, ByRefs, ParamsCount, InitParam, SS, II, DD, CC, VV); +end; + +function DispatchProcedure(ModeCall: Byte; const Instance: Variant; const Name: String; + var P: Variant; ParamsCount: Integer; + var ByRefs: TBoolArr): Variant; +var + CallDesc: TCallDesc; + Params: TIntArr; + S: ShortString; + I, VCount: Integer; + VT: Byte; + SS: TStringArr; + II: TIntArr; + DD: TDoubleArr; + CC: TCurrencyArr; + VV: TVariantArr; +begin + FillChar(CallDesc, SizeOf(TCallDesc ), 0); + FillChar(Params, SizeOf(Params), 0); + + S := ShortString(Name); + + with CallDesc do + begin + CallType := ModeCall; + NamedArgCount := 0; + ArgCount := 0; + for I := 1 to ParamsCount do + begin + VT := TVarData(P[I]).VType; + VCount := VarArrayDimCount(P[I]); + if VT = varUnknown then + VT := varVariant; + ArgTypes[ArgCount] := VT; + if (VT = VarOleStr) and (VCount = 0) then + ArgTypes[ArgCount] := VarStrArg + else if (VT = VarVariant) or (VT = VarDispatch) or (VCount > 0) then + ArgTypes[ArgCount] := VarVariant; + ArgTypes[ ArgCount ] := ArgTypes[ ArgCount ];// or atTypeMask; + Inc(ArgCount); + end; + Move(S[1], ArgTypes[ArgCount], Length(S)); + end; + + MyVarDispInvoke(@Result, Instance, @CallDesc, @Params, ByRefs, ParamsCount, P, SS, II, DD, CC, VV); + + for I:=1 to ParamsCount do + begin + VT := TVarData(P[I]).VType; + VCount := VarArrayDimCount(P[I]); + + if not ByRefs[I - 1] then + continue; + + if (VT in [VarInteger,VarSmallInt,VarByte]) and (VCount=0) then + P[I] := II[I] + else if VT = VarOleStr then + P[I] := SS[I] + else if (VT = VarVariant) or (VT = VarDispatch) or (VCount > 0) then + P[I] := VV[I] + else if VT = VarDouble then + P[I] := DD[I] + else if VT = VarCurrency then + P[I] := CC[I]; + end; +end; + + +{$IFDEF PAX64} + +function GetParams: TPtrList; assembler; +asm + mov rax, r15 +end; + +procedure _GetOLEProperty(const D: Variant; PropName: PChar; + var Result: Variant; + ParamsCount: Integer); stdcall; +var + L: TPtrList; + I: Integer; + Params: Variant; + ModeCall: Byte; + V: PVariant; + ByRefs: TBoolArr; + ATempPropName: String; +begin + L := GetParams; + + Params := VarArrayCreate([1, ParamsCount], varVariant); + for I:=1 to ParamsCount do + begin + V := L[I - 1]; + if VarType(V^) = varBoolean then + begin + if V^ then + Params[I] := Integer(1) + else + Params[I] := Integer(0); + end + else + Params[I] := V^; + end; + + ModeCall := DISPATCH_METHOD + DISPATCH_PROPERTYGET; + ATempPropName := PropName; + result := DispatchProcedure(ModeCall, D, ATempPropName, Params, ParamsCount, ByRefs); + ATempPropName := ''; + + for I:=1 to ParamsCount do + begin + if not ByRefs[I-1] then + continue; + V := L[I - 1]; + V^ := Params[I]; + end; +end; + +procedure _SetOLEProperty(const D: Variant; PropName: PChar; + const Value: Variant; + ParamsCount: Integer); stdcall; +var + L: TPtrList; + I: Integer; + Params: Variant; + V: PVariant; + ModeCall: Byte; + ByRefs: TBoolArr; + A: array of PVariant; + ATempPropName: String; +begin + L := GetParams; + + Params := VarArrayCreate([1, ParamsCount + 1], varVariant); + for I:=1 to ParamsCount do + begin + V := A[I - 1]; + if VarType(V^) = varBoolean then + begin + if V^ then + Params[I] := Integer(1) + else + Params[I] := Integer(0); + end + else + Params[I] := V^; + end; + + if VarType(Value) = varBoolean then + begin + if Value then + Params[ParamsCount + 1] := Integer(1) + else + Params[ParamsCount + 1] := Integer(0); + end + else + Params[ParamsCount + 1] := Value; + + ModeCall := DISPATCH_PROPERTYPUT; + ATempPropName := PropName; + DispatchProcedure(ModeCall, D, ATempPropName, Params, ParamsCount + 1, ByRefs); + ATempPropName := ''; +end; + +{$ELSE} +procedure _GetOLEProperty(const D: Variant; PropName: PChar; + var Result: Variant; + ParamsCount: Integer); stdcall; + +var + P: Pointer; +procedure Nested; +var + I: Integer; + Params: Variant; + ModeCall: Byte; + V: PVariant; + ByRefs: TBoolArr; + A: array of PVariant; + ATempPropName: String; +begin + SetLength(A, ParamsCount); + + for I:=0 to ParamsCount - 1 do + begin + A[I] := Pointer(P^); + Inc(IntPax(P), 4); + end; + + Params := VarArrayCreate([1, ParamsCount], varVariant); + for I:=1 to ParamsCount do + begin + V := A[I - 1]; + if VarType(V^) = varBoolean then + begin + if V^ then + Params[I] := Integer(1) + else + Params[I] := Integer(0); + end + else + Params[I] := V^; + end; + + ModeCall := DISPATCH_METHOD + DISPATCH_PROPERTYGET; + ATempPropName := PropName; + result := DispatchProcedure(ModeCall, D, ATempPropName, Params, ParamsCount, ByRefs); + ATempPropName := ''; + + for I:=1 to ParamsCount do + begin + if not ByRefs[I-1] then + continue; + A[I - 1]^ := Params[I]; + end; +end; // nested + +var + RetSize: Integer; +begin + asm + mov P, ebp + end; + Inc(Integer(P), 24); + Nested; + + RetSize := 16 + ParamsCount * 4; + + asm + // emulate ret RetSize + mov ecx, RetSize + + mov esp, ebp + pop ebp + mov ebx, [esp] + + @@loop: + pop edx + sub ecx, 4 + jnz @@loop + pop edx + jmp ebx + end; + +end; + +procedure _SetOLEProperty(const D: Variant; PropName: PChar; + const Value: Variant; + ParamsCount: Integer); stdcall; + +var + P: Pointer; +procedure Nested; +var + I: Integer; + Params: Variant; + V: PVariant; + ModeCall: Byte; + ByRefs: TBoolArr; + A: array of PVariant; + ATempPropName: String; +begin + SetLength(A, ParamsCount); + + for I:=0 to ParamsCount - 1 do + begin + A[I] := Pointer(P^); + Inc(Integer(P), 4); + end; + + Params := VarArrayCreate([1, ParamsCount + 1], varVariant); + for I:=1 to ParamsCount do + begin + V := A[I - 1]; + if VarType(V^) = varBoolean then + begin + if V^ then + Params[I] := Integer(1) + else + Params[I] := Integer(0); + end + else + Params[I] := V^; + end; + + if VarType(Value) = varBoolean then + begin + if Value then + Params[ParamsCount + 1] := Integer(1) + else + Params[ParamsCount + 1] := Integer(0); + end + else + Params[ParamsCount + 1] := Value; + + ModeCall := DISPATCH_PROPERTYPUT; + ATempPropName := PropName; + DispatchProcedure(ModeCall, D, ATempPropName, Params, ParamsCount + 1, ByRefs); + ATempPropName := ''; + +end; // nested + +var + RetSize: Integer; +begin + asm + mov P, ebp + end; + Inc(Integer(P), 24); + Nested; + + RetSize := 16 + ParamsCount * 4; + + asm + // emulate ret RetSize + mov ecx, RetSize + + mov esp, ebp + pop ebp + mov ebx, [esp] + + @@loop: + pop edx + sub ecx, 4 + jnz @@loop + pop edx + jmp ebx + end; +end; + +{$ENDIF} + +initialization + FOleHelperList := nil; +// OleHelperList:= TOleHelperList.Create; +finalization + if assigned(FOleHelperList) then + FOleHelperList.Free; + +end. diff --git a/Sources/PAXCOMP_PARSER.pas b/Sources/PAXCOMP_PARSER.pas new file mode 100644 index 0000000..c657c17 --- /dev/null +++ b/Sources/PAXCOMP_PARSER.pas @@ -0,0 +1,5661 @@ +//////////////////////////////////////////////////////////////////////////// +// PaxCompiler +// Site: http://www.paxcompiler.com +// Author: Alexander Baranovsky (paxscript@gmail.com) +// ======================================================================== +// Copyright (c) Alexander Baranovsky, 2006-2014. All rights reserved. +// Code Version: 4.2 +// ======================================================================== +// Unit: PAXCOMP_PARSER.pas +// ======================================================================== +//////////////////////////////////////////////////////////////////////////// + +{$I PaxCompiler.def} +unit PAXCOMP_PARSER; +interface +uses {$I uses.def} + SysUtils, + Classes, + TypInfo, + PAXCOMP_CONSTANTS, + PAXCOMP_TYPES, + PAXCOMP_SYS, + PAXCOMP_MODULE, + PAXCOMP_SCANNER, + PAXCOMP_LABEL_STACK, + PAXCOMP_BASESYMBOL_TABLE, + PAXCOMP_SYMBOL_REC, + PAXCOMP_BYTECODE, + PAXCOMP_TYPEINFO, + PAXCOMP_BASERUNNER, + PAXCOMP_MAP, + PAXCOMP_SYMBOL_TABLE, + PAXCOMP_GENERIC; +type + TBaseParser = class; + TBaseParserClass = class of TBaseParser; + TBaseParser = class + private + keywords: TFastStringList; + hidden_keywords: TIntegerList; + LValueIndex: Integer; + SkipWhenNotFound: Boolean; + BeginSubList: TAssocIntegers; + LoopCounter: Integer; + LoopCounterStack: TIntegerStack; + function GetFinSubLabel: Integer; + function GetCurrLevel: Integer; + function GetCurrSubId: Integer; + function GetCurrResultId: Integer; + function GetOuterClassId: Integer; + function GetNilId: Integer; + function GetEmptySetId: Integer; + function GetCurrExceptionObjectId: Integer; + function GetTryCount: Integer; + procedure SetTryCount(Value: Integer); + function GetDebugMode: Boolean; + function GetRaiseMode: Integer; + function GetStCard: Integer; + function GetCodeCard: Integer; + function GetTrueId: Integer; + function GetFalseId: Integer; + function CreateParser(const FileName: String): TBaseParser; + function GetUsedUnitList: TStringList; + function GetInterfaceOnly: Boolean; + function GetImportOnly: Boolean; + function GetTargetPlatform: TTargetPlatform; + function GetRunnerKind: TRunnerKind; + function GetSupportedSEH: Boolean; + protected + function CreateScanner: TBaseScanner; virtual; abstract; + function GetLanguageName: String; virtual; abstract; + function GetFileExt: String; virtual; abstract; + function GetLanguageId: Integer; virtual; abstract; + function GetUpcase: Boolean; virtual; abstract; + function ReplaceForwardDeclaration(var ID: Integer; IsExternalUnit: Boolean = false): Boolean; virtual; + function GetCurrSelfId: Integer; virtual; + function ConvString(const S: String): String; virtual; + procedure SetPrevToken; + function GetIsUNIC: Boolean; + function Parse_Factor: Integer; virtual; abstract; + + function IsCurrText(const S: String): Boolean; virtual; + function IsCurrTextIn(L: TStrings): Boolean; virtual; + function IsNextText(const S: String): Boolean; virtual; + function IsNext2Text(const S: String): Boolean; virtual; + function GetNextText: String; virtual; + function GetNext2Text: String; virtual; + function GetNextTokenClass: TTokenClass; virtual; + function GetNext2TokenClass: TTokenClass; virtual; + + public + kernel: Pointer; + scanner: TBaseScanner; + PrintKeyword: String; + PrintlnKeyword: String; + UpCase: Boolean; + LanguageId: Integer; + CurrToken: TToken; + FIND_DECL_SWITCH: Boolean; + DECLARE_SWITCH: Boolean; + EXECUTABLE_SWITCH: Integer; + FIELD_OWNER_ID: Integer; + SKIP_STATEMENT_TERMINATOR: Boolean; + CurrModule: TModule; + BreakStack: TEntryStack; + ContinueStack: TEntryStack; + WithStack: TIntegerStack; + SkipLabelStack: TIntegerStack; + ExitLabelStack: TIntegerStack; + try_stack: TIntegerStack; + CallConv: Integer; + DeclareCallConv: Integer; + LevelStack: TIntegerStack; + AnonymStack: TAnonymContextStack; + UsingList: TIntegerList; + TypeParams: TTypeParams; + TypeParamsHistory: TTypeParamsHistory; + CompleteBooleanEval: Boolean; + UnitLookup: Boolean; + IsConsoleApp: Boolean; + Alignment: Integer; + LinePos: Integer; + BRP: Boolean; + IMPLEMENTATION_SECTION: Boolean; + FIND_DECL_IMPLEMENTATION_SECTION: Boolean; + EXPLICIT_OFF: Boolean; + EXTRA_SWITCH: Boolean; + ParsesModule: Boolean; + UseFWArrays: Boolean; + InitFuncResult: Boolean; + Tag: Integer; + CollectSig: Boolean; + Sig: String; + operators: TAssocStrings; + Owner: TObject; + PrevPosition: Integer; + PrevLength: Integer; + constructor Create; virtual; + destructor Destroy; override; + procedure ParseProgram; virtual; abstract; + function Parse_Expression: Integer; virtual; abstract; + procedure Parse_Unit(IsExternalUnit: Boolean = false); virtual; + procedure Init(i_kernel: Pointer; M: TModule); virtual; + procedure InitScanner(const S: String); + function Lookup(const S: String; Level: Integer): Integer; + function Lookups(const S: String; Levels: TIntegerStack): Integer; + function LookupInUsingList(const S: String): Integer; + function LookupInWithStack(const S: String; + var PatternId: Integer; + var StackIsOK: Boolean): Integer; + + function FindConstructorId(ClassId: Integer): Integer; + function FindDestructorId(ClassId: Integer): Integer; + function FindPrevEvaluation(const S: String): Integer; + + function AddKeyword(const S: String): Integer; + procedure AddKeywords(L: TStrings); + function IsKeyword(const S: String): Boolean; + procedure HideKeyword(KeywordIndex: Integer); + procedure RestoreKeywords; + + procedure AddOperator(const S1, S2: String); + function OperatorIndex(const S: String): Integer; + + // generics + function Parse_TypeParams: String; + procedure AddTypeParameters(LevelId: Integer; + E: TTypeExtRec = nil); virtual; + procedure BeginTypeDef(TypeId: Integer); virtual; + procedure EndTypeDef(TypeId: Integer); virtual; + procedure BeginTypeExt(TypeId: Integer); virtual; + procedure InitTypeExt(TypeId: Integer; + const MemberName: String; + IsMethodImpl: Boolean); + procedure EndTypeExt(TypeId: Integer); virtual; + procedure BeginMethodDef; virtual; + procedure InitMethodDef(SubId: Integer); + procedure EndMethodDef(SubId: Integer); virtual; + procedure SaveExtraNamespace(Id: Integer); + function ParametrizedTypeExpected: Boolean; virtual; + function ReadType: Integer; + function IsGeneric(TypeId: Integer): Boolean; + procedure Parse_TypeRestriction(LocalTypeParams: TStringObjectList); virtual; + function AltTypeId(const S: String): Integer; virtual; + procedure RemoveType(TypeId: Integer); + procedure BeginLoop; + procedure EndLoop; + function ExtractText(P1, P2: Integer): String; + function Parse_Ident: Integer; virtual; + function Parse_QualId: Integer; virtual; + function Parse_EnumIdent: Integer; + function Parse_FormalParameter: Integer; virtual; + function Parse_BooleanLiteral: Integer; virtual; + function Parse_CharLiteral: Integer; virtual; + function Parse_PCharLiteral: Integer; virtual; + function Parse_IntegerLiteral: Integer; virtual; + function Parse_DoubleLiteral: Integer; virtual; + function BinOp(Op, Arg1, Arg2: Integer): Integer; + function UnaryOp(Op, Arg1: Integer): Integer; + function NewConst(ATypeID: Integer): Integer; overload; + function NewConst(ATypeID: Integer; const Value: Variant): Integer; overload; + function NewVar(const VarName: String): Integer; + function NewTempVar: Integer; overload; + function NewTempVar(TypeId: Integer): Integer; overload; + function NewTypeAlias: Integer; + function NewLabel: Integer; + function NewField(const FieldName: String; OwnerId: Integer): Integer; + function Gen(Op, Arg1, Arg2, Res: Integer): TCodeRec; virtual; + procedure ReadToken; virtual; + procedure ReadTokenEx; virtual; + procedure Call_SCANNER; virtual; + + procedure Match(const S: String); virtual; + procedure MatchFinal(const S: String); + procedure SafeMatch(const S: String); + function NotMatch(const S: String): Boolean; virtual; + function IsEOF: Boolean; + function IsNewLine: Boolean; + function GetFullName(Id: Integer): String; + function GetName(Id: Integer): String; + procedure SetName(Id: Integer; const S: String); + procedure SetValue(Id: Integer; const Value: Variant); + function GetCount(Id: Integer): Integer; + procedure SetParam(Id: Integer; value: boolean); + procedure SetCount(Id: Integer; value: Integer); + function GetResultId(SubId: Integer): Integer; + function GetParamId(SubId, J: Integer): Integer; + procedure SetPatternId(Id: Integer; PatternId: Integer); + procedure SetAncestorId(Id: Integer; AncestorId: Integer); + procedure SetOwnerId(Id: Integer; OwnerId: Integer); + procedure SetByRef(Id: Integer); + procedure SetIsConst(Id: Integer); + procedure SetOptional(Id: Integer); + procedure SetPacked(Id: Integer); + procedure SetCallConvention(Id: Integer; value: Integer); + procedure SetOverloaded(SubId: Integer); + procedure SetCallMode(Id: Integer; value: Integer); + procedure SetKind(Id: Integer; Kind: Integer); + function GetLevel(Id: Integer): Integer; + procedure SetLevel(Id: Integer; Level: Integer); + function GetType(Id: Integer): Integer; + procedure SetType(Id: Integer; TypeID: Integer); + function GetKind(Id: Integer): Integer; + function GetPosition(Id: Integer): Integer; + procedure SetPosition(Id, Position: Integer); + procedure SetFinal(Id: Integer; value: Boolean); + procedure SetAbstract(Id: Integer; value: Boolean); + procedure SetVarCount(Id, value: Integer); + procedure SetLabelHere(Id: Integer; + Arg2: Integer = 0; + Res: Integer = 0); + procedure SetVisibility(Id: Integer; vis: TClassVisibility); + procedure SetReadId(PropId, ReadId: Integer); + procedure SetWriteId(PropId, WriteId: Integer); + procedure SetDefault(Id: Integer; value: Boolean); + procedure SetTypedConst(Id: Integer); + procedure SetOpenArray(ID: Integer; value: Boolean); + procedure SetExternal(Id: Integer; value: Boolean); + + procedure SetHost(Id: Integer; value: Boolean); + function GetHost(Id: Integer): Boolean; + procedure SetAlignment(TypeId, Value: Integer); + + procedure BeginSub(SubId: Integer); virtual; + procedure RemoveSub; overload; + procedure RemoveSub(SubId: Integer); overload; + procedure BeginClassConstructor(SubId, ClassTypeId: Integer); virtual; + procedure BeginClassDestructor(SubId, ClassTypeId: Integer); virtual; + procedure BeginClassMethod(SubId, ClassTypeId: Integer; + HasResult: Boolean; + IsSharedMethod: Boolean; + IsMethodImpl: Boolean); virtual; + procedure BeginStructureConstructor(SubId, StructTypeId: Integer); + procedure BeginStructureDestructor(SubId, StructTypeId: Integer); + procedure BeginStructureMethod(SubId, StructTypeId: Integer; + HasResult: Boolean; + IsSharedMethod: Boolean); virtual; + procedure BeginStructureOperator(SubId, StructTypeId: Integer); virtual; + + procedure BeginInterfaceMethod(SubId, IntfTypeId: Integer; + HasResult: Boolean); virtual; + procedure CheckAbstract(SubId: Integer); + procedure InitSub(var SubId: Integer); virtual; + procedure EndSub(SubId: Integer); virtual; + function GetIncludedFileExt: String; virtual; abstract; + + procedure BeginProperty(PropId, ClassTypeId: Integer); + procedure EndProperty(PropId: Integer); + + procedure BeginNamespace(Id: Integer; Jump: Boolean = true); + procedure EndNamespace(Id: Integer; Jump: Boolean = true); + + procedure BeginArrayType(TypeId: Integer); + procedure EndArrayType(TypeId: Integer); + + procedure BeginRecordType(TypeId: Integer); + procedure EndRecordType(TypeId: Integer); + + procedure BeginClassType(TypeId: Integer); + procedure EndClassType(TypeId: Integer; IsForward: Boolean = false); + + procedure BeginInterfaceType(TypeId: Integer); + procedure SetGuid(IntfTypeId: Integer; const S: String); + procedure SetNewGuid(IntfTypeId: Integer); + procedure EndInterfaceType(TypeId: Integer; IsForward: Boolean = false); + + procedure BeginMethodRefType(TypeId: Integer); + procedure EndMethodRefType(TypeId: Integer); + + procedure BeginEnumType(TypeId, TypeBaseId: Integer); + procedure EndEnumType(TypeId, ACount: Integer); + + procedure BeginSubrangeType(TypeId, TypeBaseId: Integer); + procedure EndSubrangeType(TypeId: Integer); + + procedure BeginPointerType(TypeId: Integer); + procedure EndPointerType(TypeId: Integer); + + procedure BeginHelperType(TypeId, TrueTypeId: Integer); + procedure EndHelperType(TypeId: Integer); + + procedure BeginClassReferenceType(TypeId: Integer); + procedure EndClassReferenceType(TypeId: Integer); + + procedure BeginDynamicArrayType(TypeId: Integer); + procedure EndDynamicArrayType(TypeId: Integer); + + procedure BeginOpenArrayType(TypeId: Integer); + procedure EndOpenArrayType(TypeId: Integer; const ElemName: String); +{$IFNDEF PAXARM} + procedure BeginShortStringType(TypeId: Integer); + procedure EndShortStringType(TypeId: Integer); +{$ENDIF} + procedure BeginProceduralType(TypeId, SubID: Integer); + procedure EndProceduralType(TypeId: Integer); + + procedure BeginSetType(TypeId, TypeBaseId: Integer); + procedure EndSetType(TypeId: Integer); + + procedure BeginInitialization; + procedure EndInitialization; + procedure BeginFinalization; + procedure EndFinalization; + + function GenBeginTry: Integer; // returns label + procedure GenEndTry; + procedure GenFinally; + procedure GenExcept; + procedure GenExceptOn(type_id: Integer); + + procedure GenNOPS(K: Integer); + procedure GenAssignOuterInstance(Id, ClassId: Integer); + procedure GenComment(const S: String); + + procedure BeginInitConst(Id: Integer); + procedure EndInitConst(Id: Integer); + + procedure GenDestroyGlobalDynamicVariables(B1, B2: Integer); + + procedure SetForward(SubId: Integer; value: Boolean); + function IsForward(SubId: Integer): Boolean; + + procedure BeginCollectSig(SubId: Integer); virtual; + procedure EndCollectSig(SubId: Integer); virtual; + + procedure AddModuleFromFile(FileName: String; + UsedUnitId: Integer; + IsImplementationSection: Boolean; + ErrMessage: String = ''; + NoRaise: Boolean = false); + + function GetValue(id: Integer): Variant; + + procedure RemoveInstruction(Op, Arg1, Arg2, Res: Integer); + function RemoveLastEvalInstruction(const S: String; Upcase: Boolean = true): Integer; + function RemoveLastEvalInstructionAndName(const S: String; Upcase: Boolean = true): Boolean; + procedure RemoveLastIdent(Id: Integer); + function LastCodeRec(var I: Integer): TCodeRec; overload; + function LastCodeRec: TCodeRec; overload; + function LastCodeRec2: TCodeRec; + function LastEvalRec(Id: Integer): TCodeRec; overload; + function LastEvalRec(Id: Integer; var I: Integer): TCodeRec; overload; + + function LookupForwardDeclarations(Id: Integer): TIntegerList; + procedure DiscardLastSTRecord; + function ScanRegExpLiteral: String; + function LA(I: Integer): Char; + function CreatePointerType(type_id, pcount: Integer): Integer; + function CreateProceduralType(SubId: Integer): Integer; + function CreateSubrangeType(B1, B2: Integer): Integer; + function CreateArrayType(RangeTypeId, ElemTypeId: Integer): Integer; + + procedure RaiseError(const Message: string; params: array of Const); + procedure CreateError(const Message: string; params: array of Const); + procedure RaiseNotImpl; + + procedure Push_SCANNER; + procedure Pop_SCANNER; + + function CountAtLevel(const S: String; Level: Integer): Integer; overload; + function CountAtLevel(const S: String; + Level, Kind: Integer; IsSharedMethod: Boolean): Integer; overload; + + function IsStringConst(Id: Integer): Boolean; + procedure SetCompletionTarget(const S: String); + function GetCodeRec(I: Integer): TCodeRec; + function GetSymbolRec(Id: Integer): TSymbolRec; + function CurrNamespaceId: Integer; + function BuildingAll: Boolean; + procedure SetTempName(Id: Integer); + function Parse_UnitName(var S: String): Integer; + function ExpandUnitName(const S: String): String; + function ExpandTypeName(const S: String): String; + procedure CheckRedeclaredSub(SubId: Integer); + procedure SetDeprecated(SubId: Integer; value: Boolean); + function HasBeenDeclared(Id: Integer): Boolean; + function HasModule(const ModuleName: String): Boolean; + procedure GenHtml; + procedure GenCondRaise; + + function GetOpenArrayHighId(Id: Integer): Integer; + procedure GenPause; + + function IsTryContext(R: TEntryRec): Boolean; + procedure NewAnonymousNames(var ClsName: String; + var ObjName: String); + function IsOuterLocalVar(Id: Integer): Boolean; + procedure RelocateCode(K1, K2: Integer); overload; + procedure RelocateCode(Ip, K1, K2: Integer); overload; + + property CurrLevel: Integer read GetCurrLevel; + property CurrResultId: Integer read GetCurrResultId; + property CurrSelfId: Integer read GetCurrSelfId; + property CurrSubId: Integer read GetCurrSubId; + property NilId: Integer read GetNilId; + property EmptySetId: Integer read GetEmptySetId; + property CurrExceptionObjectId: Integer read GetCurrExceptionObjectId; + property LanguageName: String read GetLanguageName; + property TryCount: Integer read GetTryCount write SetTryCount; + property DEBUG_MODE: Boolean read GetDebugMode; + property RaiseMode: Integer read GetRaiseMode; + property STCard: Integer read GetStCard; + property FinSubLabel: Integer read GetFinSubLabel; + property TrueId: Integer read GetTrueId; + property FalseId: Integer read GetFalseId; + property CodeCard: Integer read GetCodeCard; + property UsedUnitList: TStringList read GetUsedUnitList; + property InterfaceOnly: Boolean read GetInterfaceOnly; + property ImportOnly: Boolean read GetImportOnly; + property OuterClassId: Integer read GetOuterClassId; + property IsUNIC: Boolean read GetIsUNIC; + property TargetPlatform: TTargetPlatform read GetTargetPlatform; + property RunnerKind: TRunnerKind read GetRunnerKind; + property SupportedSEH: Boolean read GetSupportedSEH; + end; + + TParserList = class + private + L: TPtrList; + kernel: Pointer; + function GetParser(I: Integer): TBaseParser; + public + constructor Create(i_kernel: Pointer); + destructor Destroy; override; + procedure AddParser(P: TBaseParser); + procedure Clear; + function Count: Integer; + function FindParser(const LanguageName: String): TBaseParser; + function FindParserByFileExtension(const FileExtension: String): TBaseParser; + property Items[I: Integer]: TBaseParser read GetParser; default; + end; + +implementation + +uses +{$IFDEF DRTTI} + PAXCOMP_2010, +{$ENDIF} + PAXCOMP_KERNEL, PAXCOMP_STDLIB, PAXCOMP_PCU, PAXCOMP_RTI; + +constructor TBaseParser.Create; +begin + kernel := nil; + + scanner := CreateScanner; + UpCase := true; + DECLARE_SWITCH := false; + FIND_DECL_SWITCH := false; + EXECUTABLE_SWITCH := 0; + FIELD_OWNER_ID := 0; + EXTRA_SWITCH := false; + keywords := TFastStringList.Create; + hidden_keywords := TIntegerList.Create; + operators := TAssocStrings.Create; + BeginSubList := TAssocIntegers.Create; + levelStack := TIntegerStack.Create; + levelStack.Push(0); + AnonymStack := TAnonymContextStack.Create; + try_stack := TIntegerStack.Create; + SkipLabelStack := TIntegerStack.Create; + ExitLabelStack := TIntegerStack.Create; + BreakStack := TEntryStack.Create; + ContinueStack := TEntryStack.Create; + WithStack := TIntegerStack.Create; + SKIP_STATEMENT_TERMINATOR := false; + CompleteBooleanEval := false; + UnitLookup := true; + IsConsoleApp := false; + Alignment := GlobalAlignment; + PrintKeyword := 'print'; + PrintlnKeyword := 'println'; + BRP := false; + CallConv := ccREGISTER; + DeclareCallConv := ccSTDCALL; + UseFWArrays := true; + UsingList := TIntegerList.Create; + TypeParams := TTypeParams.Create; + TypeParamsHistory := TTypeParamsHistory.Create; + LoopCounterStack := TIntegerStack.Create; +end; + +destructor TBaseParser.Destroy; +begin + FreeAndNil(scanner); + FreeAndNil(keywords); + FreeAndNil(hidden_keywords); + FreeAndNil(operators); + FreeAndNil(BeginSubList); + FreeAndNil(levelStack); + FreeAndNil(AnonymStack); + FreeAndNil(SkipLabelStack); + FreeAndNil(ExitLabelStack); + FreeAndNil(BreakStack); + FreeAndNil(ContinueStack); + FreeAndNil(WithStack); + FreeAndNil(try_stack); + FreeAndNil(UsingList); + FreeAndNil(TypeParams); + FreeAndNil(TypeParamsHistory); + FreeAndNil(LoopCounterStack); + + inherited; +end; + +procedure TBaseParser.Init(i_kernel: Pointer; M: TModule); +begin + Self.kernel := i_kernel; + if scanner <> nil then + scanner.Init(kernel, M.Lines.Text, M.CancelPos); + levelStack.Clear; + levelStack.Push(0); + AnonymStack.Clear; + SkipLabelStack.Clear; + ExitLabelStack.Clear; + BreakStack.Clear; + BreakStack.SetKernel(i_kernel); + ContinueStack.Clear; + ContinueStack.SetKernel(i_kernel); + WithStack.Clear; + try_stack.Clear; + BeginSubList.Clear; + hidden_keywords.Clear; + + CurrModule := M; + LValueIndex := 0; + + SKIP_STATEMENT_TERMINATOR := false; + FIELD_OWNER_ID := 0; + + IsConsoleApp := false; + Alignment := TKernel(kernel).Alignment; + + LinePos := 0; + + LanguageId := GetLanguageId; + + Upcase := GetUpcase; + + Gen(OP_PRINT_KWD, NewConst(typeSTRING, PrintKeyword), 0, 0); + Gen(OP_PRINTLN_KWD, NewConst(typeSTRING, PrintlnKeyword), 0, 0); + + DECLARE_SWITCH := false; + EXECUTABLE_SWITCH := 0; + IMPLEMENTATION_SECTION := false; + FIND_DECL_IMPLEMENTATION_SECTION := false; + FIND_DECL_SWITCH := false; + CollectSig := false; + UsingList.Clear; + TypeParams.Clear; + TypeParamsHistory.Clear; + + LoopCounter := 0; + LoopCounterStack.Clear; +end; + +procedure TBaseParser.ReadToken; +begin + scanner.ReadToken; + CurrToken := scanner.Token; +end; + +procedure TBaseParser.ReadTokenEx; +var + S: String; + c: Byte; +begin + scanner.ReadToken; + S := scanner.Token.Text; + c := Ord(S[1]); + while (c = 13) or (c = 10) do + begin + scanner.ReadToken; + S := scanner.Token.Text; + c := Ord(S[1]); + end; +end; + + +function TBaseParser.NewField(const FieldName: String; OwnerId: Integer): Integer; +begin + result := NewTempVar; + with TKernel(kernel) do + begin + SymbolTable[result].Name := FieldName; + SymbolTable[result].OwnerId := OwnerId; + end; +end; + +procedure TBaseParser.Call_SCANNER; +var + IntVal: Integer; + Int64Val: Int64; + ExtendedVal: Extended; + StringVal: String; + SymbolTable: TSymbolTable; + I, id, lev: Integer; + R: TSymbolRec; + S: String; + WordVal: Word; + CurrToken_Text: String; + cc: Boolean; + FieldId, PatternId: Integer; + StackIsOK: Boolean; +label + LabelEval; +begin + SymbolTable := TKernel(kernel).SymbolTable; + + LinePos := scanner.LinePos; + + scanner.ReadToken; + + CurrToken := scanner.Token; + + CurrToken_Text := scanner.UpdateToken; + + if CurrModule.IsExtra then + begin + if Upcase then + begin + if StrEql(EXTRA_KEYWORD, CurrToken_Text) then + begin + EXTRA_SWITCH := true; + Call_SCANNER; + end; + end + else + begin + if EXTRA_KEYWORD = CurrToken_Text then + begin + EXTRA_SWITCH := true; + Call_SCANNER; + end; + end; + end; + + if CurrToken.TokenClass = tcHtmlStringConst then + begin + GenHtml; + DECLARE_SWITCH := false; + Tag := 1; + Call_SCANNER; + Exit; + end; + + if Assigned(TKernel(kernel).OnCompilerProgress) then + TKernel(kernel).OnCompilerProgress(TKernel(kernel).Owner); + + if CurrToken.TokenClass = tcIntegerConst then + begin + if CurrToken_Text[1] = '&' then + begin + CurrToken_Text := '$' + Copy(CurrToken_Text, 3, Length(CurrToken_Text) - 2); + end; + + if CurrToken.Tag = 2 then + begin + Int64Val := Scanner.CustomInt64Val; + CurrToken.Tag := 0; + end + else + begin +// Int64Val := StrToInt64(CurrToken_Text); + Val(CurrToken_Text, Int64Val, I); + end; + if Abs(Int64Val) > MaxInt then + CurrToken.Id := SymbolTable.AddInt64Const(Int64Val).Id + else + begin + if Int64Val < - MaxInt then + CurrToken.Id := SymbolTable.AddInt64Const(Int64Val).Id + else + CurrToken.Id := SymbolTable.AddIntegerConst(Int64Val).Id; + end; + end + else if CurrToken.TokenClass = tcCharConst then + begin + if CurrToken.Tag = 1 then + begin + StringVal := Copy(CurrToken_Text, 2, Length(CurrToken_Text) - 1); + + IntVal := StrToInt(StringVal); + if IntVal <= 255 then + begin + StringVal := Chr(IntVal); + + repeat + + if scanner[1] = '#' then + begin + ReadToken; + S := Copy(CurrToken.Text, 2, Length(CurrToken.Text) - 1); + WordVal := StrToInt(S); + if WordVal <= 255 then + StringVal := StringVal + Chr(WordVal) + else + RaiseError(errSyntaxError, []); + end; + + if scanner[1] = '''' then + begin + ReadToken; + S := CurrToken.Text; + S := Copy(S, 2, Length(S) - 2); + + I := PosCh(CHAR_REMOVE, S); + while I > 0 do + begin + Delete(S, I, 1); + I := PosCh(CHAR_REMOVE, S); + end; + StringVal := StringVal + S; + end; + + until not ByteInSet(scanner[1], [Ord('#'), Ord('''')]); + + if IsUNIC then + begin + if Length(StringVal) > 1 then + CurrToken.Id := SymbolTable.AddPWideCharConst(StringVal).Id + else + CurrToken.Id := SymbolTable.AddWideCharConst(IntVal).Id; + end + else + begin +{$IFNDEF PAXARM} + if Length(StringVal) > 1 then + CurrToken.Id := SymbolTable.AddPAnsiCharConst(AnsiString(StringVal)).Id + else + CurrToken.Id := SymbolTable.AddAnsiCharConst(AnsiChar(Chr(IntVal))).Id; +{$ENDIF} + end; + end + else + CurrToken.Id := SymbolTable.AddWideCharConst(IntVal).Id; + CurrToken.Tag := 0; + end + else + begin + if CurrToken.Tag = 2 then + begin +{$IFDEF PAXARM} + CurrToken.Id := SymbolTable.AddWideCharConst(Scanner.CustomInt64Val).Id; +{$ELSE} + if IsUNIC then + CurrToken.Id := SymbolTable.AddWideCharConst(Scanner.CustomInt64Val).Id + else + CurrToken.Id := SymbolTable.AddAnsiCharConst(AnsiChar(Scanner.CustomInt64Val)).Id; +{$ENDIF} + CurrToken.Tag := 0; + Exit; + end; + + StringVal := CurrToken_Text; // length = 3 + +{$IFDEF PAXARM} + CurrToken.Id := SymbolTable.AddWideCharConst(Ord(StringVal[1+SLow(StringVal)])).Id; +{$ELSE} + if IsUNIC then + CurrToken.Id := SymbolTable.AddWideCharConst(Ord(StringVal[1+SLow(StringVal)])).Id + else + CurrToken.Id := SymbolTable.AddAnsiCharConst(AnsiChar(StringVal[2])).Id; +{$ENDIF} + end; + end + else if CurrToken.TokenClass = tcPCharConst then + begin + if CurrToken.Tag = 2 then + begin +{$IFDEF PAXARM} + CurrToken.Id := SymbolTable.AddPWideCharConst(Scanner.CustomStringVal).Id; +{$ELSE} + if IsUNIC then + CurrToken.Id := SymbolTable.AddPWideCharConst(Scanner.CustomStringVal).Id + else + CurrToken.Id := SymbolTable.AddPAnsiCharConst(AnsiString(Scanner.CustomStringVal)).Id; +{$ENDIF} + CurrToken.Tag := 0; + Exit; + end; + + StringVal := CurrToken_Text; + StringVal := Copy(StringVal, 2, Length(StringVal) - 2); + + I := PosCh(CHAR_REMOVE, StringVal); + while I > 0 do + begin + Delete(StringVal, I, 1); + I := PosCh(CHAR_REMOVE, StringVal); + end; + + repeat + + if scanner[1] = '#' then + begin + ReadToken; + S := Copy(CurrToken.Text, 2, Length(CurrToken.Text) - 1); + WordVal := StrToInt(S); + if WordVal <= 255 then + StringVal := StringVal + Chr(WordVal) + else + RaiseError(errSyntaxError, []); + end; + + if scanner[1] = '''' then + begin + ReadToken; + S := CurrToken.Text; + S := Copy(S, 2, Length(S) - 2); + + I := PosCh(CHAR_REMOVE, S); + while I > 0 do + begin + Delete(S, I, 1); + I := PosCh(CHAR_REMOVE, S); + end; + StringVal := StringVal + S; + end; + + until not ByteInSet(scanner[1], [Ord('#'), Ord('''')]); + + StringVal := ConvString(StringVal); + + if StringVal = '' then + CurrToken.Id := SymbolTable.EmptyStringId + else + begin +{$IFDEF PAXARM} + CurrToken.Id := SymbolTable.AddPWideCharConst(StringVal).Id; +{$ELSE} + if IsUNIC then + CurrToken.Id := SymbolTable.AddPWideCharConst(StringVal).Id + else + CurrToken.Id := SymbolTable.AddPAnsiCharConst(AnsiString(StringVal)).Id; +{$ENDIF} + end; + CurrToken.Tag := 0; + end + else if CurrToken.TokenClass = tcDoubleConst then + begin + StringVal := CurrToken_Text; + Val(StringVal, ExtendedVal, Id); + if ExtendedVal >= MaxDouble then + CurrToken.Id := SymbolTable.AddDoubleConst(MaxDouble).Id + else if (ExtendedVal > 0) and (ExtendedVal <= MinDouble) then + CurrToken.Id := SymbolTable.AddDoubleConst(MinDouble).Id + else + CurrToken.Id := SymbolTable.AddDoubleConst(ExtendedVal).Id; + end + else if CurrToken.TokenClass = tcIdentifier then + begin + if not DECLARE_SWITCH then + begin + if IsCurrText('true') then + begin + CurrToken.TokenClass := tcBooleanConst; + CurrToken.Id := SymbolTable.TrueId; + Exit; + end + else if IsCurrText('false') then + begin + CurrToken.TokenClass := tcBooleanConst; + CurrToken.Id := SymbolTable.FalseId; + Exit; + end; + end; + + if IsKeyword(CurrToken_Text) then + begin + CurrToken.Id := 0; + CurrToken.TokenClass := tcKeyword; + if FIELD_OWNER_ID = 0 then + Exit + else + CurrToken.TokenClass := tcIdentifier; + end; + + if ParametrizedTypeExpected then + CurrToken_Text := CurrToken_Text + Parse_TypeParams; + + if FIELD_OWNER_ID > 0 then + begin + with SymbolTable.AddRecord do + begin + CurrToken.Id := Id; + Name := CurrToken_Text; + Kind := KindVAR; + Level := CurrLevel; + OwnerId := FIELD_OWNER_ID; + end; + + FIELD_OWNER_ID := 0; + Exit; + end; + + if DECLARE_SWITCH then + begin + id := LookUp(CurrToken_Text, CurrLevel); + if id <> 0 then + begin + if SymbolTable[id].Kind in [kindNAMESPACE] then + begin + CurrToken.Id := Id; + Exit; + end + else + begin + if SymbolTable[Id].IsForward then + begin + + if (SymbolTable[Id].Kind = KindTYPE) and + (SymbolTable[Id].FinalTypeId = typeCLASS) then + begin + CurrToken.Id := id; + SetForward(Id, false); + SymbolTable[Id].Position := CurrToken.Position - 1; + Exit; + end; + + if LanguageId = PASCAL_LANGUAGE then + if GetKind(id) = KindSUB then + if GetSymbolRec(id).OverCount = 0 then + begin + if not ImportOnly then + RaiseError(errRedeclaredIdentifier, [CurrToken_Text]); + end; + + CurrToken.Id := NewTempVar; + SetName(CurrToken.Id, GetName(Id)); + SymbolTable[Id].Position := CurrToken.Position - 1; + Exit; + end + else if LanguageId = JS_LANGUAGE then + begin + // no problem + end + else + begin + if not (GetKind(id) in KindSUBS) then + if not TKernel(kernel).SymbolTable[id].Host then + if Id > TKernel(kernel).GT.Card then + begin + cc := StrEql(CurrToken_Text, 'register') or + StrEql(CurrToken_Text, 'pascal') or + StrEql(CurrToken_Text, 'stdcall') or + StrEql(CurrToken_Text, 'cdecl') or + StrEql(CurrToken_Text, 'msfastcall') or + StrEql(CurrToken_Text, 'safecall'); + if cc then + SymbolTable[id].Kind := KindNONE; + + if not (InterfaceOnly or cc) then + RaiseError(errRedeclaredIdentifier, [CurrToken_Text]); + end; + end; + end; + end; + + with SymbolTable.AddRecord do + begin + CurrToken.Id := Id; + Name := CurrToken_Text; + Kind := KindVAR; + Level := CurrLevel; + + InImplementation := IMPLEMENTATION_SECTION; + + Position := CurrToken.Position - 1; + end; + end + else + begin + CurrToken.Id := 0; + + if WithStack.Count = 0 then + begin + CurrToken.Id := LookUps(CurrToken_Text, levelStack); + if CurrToken.Id = 0 then + CurrToken.Id := LookupInUsingList(CurrToken_Text); + end + else + begin + if WithStack.Count = 1 then + if WithStack[0] = CurrSelfId then + begin + Id := LookUps(CurrToken_Text, levelStack); + if Id > 0 then + begin + lev := GetSymbolRec(Id).Level; + if lev > 0 then + if GetSymbolRec(lev).Kind in KindSUBS then + begin + CurrToken.Id := Id; + goto LabelEval; + end; + end; + end; + + Id := LookupInWithStack(CurrToken_Text, PatternId, StackIsOK); + if Id > 0 then + begin + if PatternId <> CurrSubId then + if GetKind(PatternId) <> KindPROP then + begin + FieldId := NewField(CurrToken_Text, Id); + SetType(FieldId, GetType(PatternId)); + Gen(OP_FIELD, Id, FieldId, FieldId); + LastCodeRec.CodeRecTag := TAG_DISCARD_STMT; + LastCodeRec.PatternFieldId := PatternId; + + CurrToken.Id := FieldId; + goto LabelEval; + end; + end; + + if (Id = 0) and StackIsOK then + begin + CurrToken.Id := LookUps(CurrToken_Text, levelStack); + if CurrToken.Id = 0 then + CurrToken.Id := LookupInUsingList(CurrToken_Text); + end; + end; + + LabelEval: + + if CurrToken.Id > 0 then + begin + if TKernel(kernel).TypeDefList.RemTypeIds.IndexOf(CurrToken.Id) >= 0 then + CurrToken.Id := 0; + end; + + if CurrToken.Id = 0 then + begin +{ + if LanguageId = BASIC_LANGUAGE then + if IsNextText('.') then + if LookUps(CurrToken_Text, levelStack) = 0 then + if not HasModule(CurrToken_Text) then + begin + SkipWhenNotFound := true; + try + AddModuleFromFile(CurrToken_Text, CurrToken.Id, false, + Format(errUndeclaredIdentifier, [CurrToken_Text]), true); + finally + SkipWhenNotFound := false; + end; + + end; +} + R := SymbolTable.AddRecord; + R.Name := CurrToken_Text; + R.Kind := KindNONE; + R.Level := CurrLevel; + CurrToken.Id := R.Id; + Gen(OP_EVAL, 0, 0, R.Id); + R.Position := CurrToken.Position - 1; + end; + end; + end; +end; + +function TBaseParser.GetPosition(Id: Integer): Integer; +begin + result := TKernel(kernel).SymbolTable[Id].Position; +end; + +procedure TBaseParser.SetPosition(Id, Position: Integer); +begin + TKernel(kernel).SymbolTable[Id].Position := Position; +end; + +procedure TBaseParser.SetVarCount(Id, value: Integer); +begin + TKernel(kernel).SymbolTable[Id].VarCount := value; +end; + +function TBaseParser.Parse_Ident: Integer; +begin + if CurrToken.TokenClass <> tcIdentifier then + RaiseError(errIdentifierExpected, [CurrToken.Text]); + result := CurrToken.Id; + if FIND_DECL_SWITCH then + begin + FIND_DECL_IMPLEMENTATION_SECTION := IMPLEMENTATION_SECTION; + TKernel(kernel).FindDeclId := result; + FIND_DECL_SWITCH := false; + end; + Call_SCANNER; +end; + +function TBaseParser.Parse_EnumIdent: Integer; +var + TypeID: Integer; +begin + TypeID := LevelStack.Top; + + result := Parse_Ident; + SetKind(result, KindCONST); + SetType(result, TypeID); + SetOwnerId(result, TypeID); +end; + +function TBaseParser.Parse_FormalParameter: Integer; +begin + if CurrToken.TokenClass <> tcIdentifier then + RaiseError(errIdentifierExpected, [CurrToken.Text]); + result := CurrToken.Id; + + TKernel(kernel).SymbolTable[result].Param := true; + + Call_SCANNER; +end; + +function TBaseParser.Parse_CharLiteral: Integer; +begin + result := CurrToken.Id; + Call_SCANNER; +end; + +function TBaseParser.Parse_PCharLiteral: Integer; +begin + result := CurrToken.Id; + if CurrToken.TokenClass <> tcPCharConst then + RaiseError(errPCharLiteralExpected, []); + Call_SCANNER; +end; + +function TBaseParser.Parse_BooleanLiteral: Integer; +begin + result := CurrToken.Id; + Call_SCANNER; +end; + +function TBaseParser.Parse_IntegerLiteral: Integer; +begin + result := CurrToken.Id; + Call_SCANNER; +end; + +function TBaseParser.Parse_DoubleLiteral: Integer; +begin + result := CurrToken.Id; + Call_SCANNER; +end; + +function TBaseParser.BinOp(Op, Arg1, Arg2: Integer): Integer; +begin + result := NewTempVar; + Gen(Op, Arg1, Arg2, result); +end; + +function TBaseParser.UnaryOp(Op, Arg1: Integer): Integer; +begin + result := NewTempVar(); + Gen(Op, Arg1, 0, result); +end; + +function TBaseParser.NewVar(const VarName: String): Integer; +var + R: TSymbolRec; +begin + R := TKernel(kernel).SymbolTable.AddRecord; + R.Kind := KindVAR; + R.Level := CurrLevel; + R.Name := VarName; + result := R.Id; +end; + +function TBaseParser.NewTempVar: Integer; +var + R: TSymbolRec; +begin + R := TKernel(kernel).SymbolTable.AddRecord; + R.Kind := KindVAR; + R.Level := CurrLevel; + result := R.Id; +end; + +function TBaseParser.NewTempVar(TypeId: Integer): Integer; +begin + result := NewTempVar; + SetType(result, typeID); +end; + +function TBaseParser.NewConst(ATypeID: Integer; const Value: Variant): Integer; +var + R: TSymbolRec; +begin + case ATypeID of + typeBOOLEAN: result := TKernel(kernel).SymbolTable.AddBooleanConst(Value).Id; + typeINTEGER: result := TKernel(kernel).SymbolTable.AddIntegerConst(Value).Id; + typeDOUBLE: result := TKernel(kernel).SymbolTable.AddDoubleConst(Value).Id; +{$IFNDEF PAXARM} + typeANSISTRING: result := TKernel(kernel).SymbolTable.AddPAnsiCharConst(AnsiString(Value)).Id; +{$ENDIF} + typeUNICSTRING: result := TKernel(kernel).SymbolTable.AddPWideCharConst(Value).Id; + else + begin + R := TKernel(kernel).SymbolTable.AddRecord; + R.Kind := KindCONST; + R.TypeID := ATypeID; + R.Level := CurrLevel; + R.Value := Value; + result := R.Id; + end; + end; +end; + +function TBaseParser.NewConst(ATypeID: Integer): Integer; +begin + with TKernel(kernel).SymbolTable do + begin + result := AddRecord.Id; + with Records[result] do + begin + Kind := kindCONST; + Level := CurrLevel; + TypeID := ATypeID; + end; + end; +end; + +function TBaseParser.NewTypeAlias: Integer; +var + R: TSymbolRec; +begin + R := TKernel(kernel).SymbolTable.AddRecord; + R.Kind := KindTYPE; + R.Level := CurrLevel; + R.TypeID := typeALIAS; + result := R.Id; +end; + +function TBaseParser.NewLabel: Integer; +begin + result := TKernel(kernel).SymbolTable.AddLabel.Id; +end; + +function TBaseParser.Gen(Op, Arg1, Arg2, Res: Integer): TCodeRec; +var + L, I: Integer; + B: Boolean; + Code: TCode; + SymbolTable: TSymbolTable; + TypeId, MemberId: Integer; + S: String; +begin + Code := TKernel(kernel).Code; + SymbolTable := TKernel(kernel).SymbolTable; + + Code.N := Code.Card; + + if Op = OP_STMT then + begin + I := Code.Card; + if Code[I].Op = OP_EVAL then + begin + result := Code[I]; + Exit; + end; + if Code[I].Op = OP_LABEL then + Dec(I); + if Code[I].Op = OP_FIELD then + if Code[I].CodeRecTag = TAG_DISCARD_STMT then + begin + result := Code[Code.Card]; + Exit; + end; + Arg1 := CurrLevel; + end; + + if OP = OP_COND_RAISE then + begin + Arg1 := FinSubLabel; + if Res = 0 then + Res := NewTempVar(typeBOOLEAN); + end + else if OP = OP_ADD_TYPEINFO then + begin + RemoveInstruction(OP, Arg1, -1, -1); + end + else if OP = OP_ASSIGN_TYPE then + if GetSymbolRec(Arg2).Kind = KindTYPE then + begin + SetType(Arg1, Arg2); + result := LastCodeRec; + Exit; + end; + + result := Code.Add(Op, Arg1, Arg2, Res, CurrLevel, Upcase, + LanguageId, CurrModule.ModuleNumber, + LinePos); + if Op = OP_CALL_INHERITED then + begin + result.Op := OP_CALL; + result.IsInherited := true; + end; + + if Op = OP_FIELD then + begin + if GetSymbolRec(Arg1).FinalTypeId = typeCLASS then + begin + S := GetSymbolRec(Res).Name; + if S <> '' then + begin + + MemberId := TKernel(kernel).SymbolTable. + Lookup(S, GetSymbolRec(Arg1).TerminalTypeId, UpCase, MaxInt, false); + if MemberId <> 0 then + if GetKind(MemberId) in [KindVAR, KindPROP] then + begin + TypeId := GetSymbolRec(MemberId).TypeId; + SetType(Res, TypeId); + result.PatternFieldId := MemberId; + end; + end; + end; + end + else if Op = OP_ELEM then + begin + SymbolTable[Res].Kind := KindVAR; + SymbolTable[Res].OwnerId := Arg1; + end + else if Op = OP_BEGIN_MODULE then + begin + CurrModule.S1 := SymbolTable.Card + 1; + CurrModule.P1 := Code.Card; + end + else if Op = OP_BEGIN_SUB then + begin + BeginSubList.Add(Arg1, Code.Card); + end + else if Op = OP_END_INTERFACE_SECTION then + begin + CurrModule.S2 := SymbolTable.Card; + CurrModule.P2 := Code.Card; + end + else if Op = OP_END_MODULE then + begin + CurrModule.S3 := SymbolTable.Card; + CurrModule.P3 := Code.Card; + end + else if Op = OP_BEGIN_USING then + begin + UsingList.Add(Arg1); + end + else if Op = OP_END_USING then + begin + UsingList.DeleteValue(Arg1); + end + else if OP = OP_EVAL_INHERITED then + Gen(OP_NOP, SkipLabelStack.Top, 0, 0) + else if Op = OP_ASSIGN_CONST then + begin + GetSymbolRec(Arg1).Value := GetSymbolRec(Arg2).Value; + end + else if OP = OP_GET_ENUMERATOR then + begin + Gen(OP_NOP, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + end + else if OP = OP_CURRENT then + begin + Gen(OP_NOP, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + end + else if OP = OP_MOVE_NEXT then + begin + Gen(OP_NOP, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + end + else if Op = OP_SEPARATOR then + begin + if (not DECLARE_SWITCH) and (EXECUTABLE_SWITCH > 0) then + begin + b := false; + for I:=Code.Card downto 1 do + begin + Op := Code[I].Op; + if Op = OP_SET_CODE_LINE then + break + else if Op = OP_CALL then + break + else if Op = OP_PUSH then + begin + b := true; + break; + end; + end; + + Gen(OP_SET_CODE_LINE, 0, 0, 0); + if DEBUG_MODE then if not b then + begin + L := NewLabel; + Gen(OP_CHECK_PAUSE, L, 0, 0); + SetLabelHere(L); + end; + end; + end; +end; + +procedure TBaseParser.RaiseError(const Message: string; params: array of Const); +begin + TKernel(kernel).Code.N := TKernel(kernel).Code.Card; + TKernel(kernel).RaiseError(Message, params); +end; + +procedure TBaseParser.CreateError(const Message: string; params: array of Const); +begin + TKernel(kernel).CreateError(Message, params); +end; + +function TBaseParser.AddKeyword(const S: String): Integer; +begin + result := keywords.Add(S); +end; + +procedure TBaseParser.AddKeywords(L: TStrings); +var + I: Integer; +begin + for I := 0 to L.Count - 1 do + AddKeyword(L[I]); +end; + +function TBaseParser.IsKeyword(const S: String): Boolean; +var + I: Integer; +begin + I := keywords.IndexOfEx(S, UpCase); + result := I >= 0; + if result then + result := hidden_keywords.IndexOf(I) = - 1; +end; + +procedure TBaseParser.AddOperator(const S1, S2: String); +begin + operators.Add(S1, S2); +end; + +function TBaseParser.OperatorIndex(const S: String): Integer; +begin + result := operators.Keys.IndexOf(S); +end; + +function TBaseParser.IsCurrText(const S: String): Boolean; +begin + if UpCase then + result := StrEql(CurrToken.Text, S) + else + result := CurrToken.Text = S; +end; + +function TBaseParser.IsCurrTextIn(L: TStrings): Boolean; +var + I: Integer; +begin + result := false; + for I := 0 to L.Count - 1 do + if IsCurrText(L[I]) then + begin + result := true; + Exit; + end; +end; + +function TBaseParser.IsNextText(const S: String): Boolean; +begin + scanner.LookForward := true; + + Push_SCANNER; + ReadTokenEx; + result := IsCurrText(S); + Pop_SCANNER; + + scanner.VarNameList.Clear; + + scanner.LookForward := false; +end; + +function TBaseParser.IsNext2Text(const S: String): Boolean; +begin + scanner.LookForward := true; + + Push_SCANNER; + ReadTokenEx; + ReadTokenEx; + result := IsCurrText(S); + Pop_SCANNER; + + scanner.LookForward := false; +end; + +function TBaseParser.GetNextText: String; +begin + scanner.LookForward := true; + + Push_SCANNER; + ReadTokenEx; + result := CurrToken.Text; + Pop_SCANNER; + + scanner.LookForward := false; +end; + +function TBaseParser.GetNext2Text: String; +begin + scanner.LookForward := true; + + Push_SCANNER; + ReadTokenEx; + ReadTokenEx; + result := CurrToken.Text; + Pop_SCANNER; + + scanner.LookForward := false; +end; + +function TBaseParser.GetNextTokenClass: TTokenClass; +begin + scanner.LookForward := true; + + Push_SCANNER; + ReadTokenEx; + result := CurrToken.TokenClass; + Pop_SCANNER; + + scanner.LookForward := false; +end; + +function TBaseParser.GetNext2TokenClass: TTokenClass; +begin + scanner.LookForward := true; + + Push_SCANNER; + ReadTokenEx; + ReadTokenEx; + result := CurrToken.TokenClass; + Pop_SCANNER; + + scanner.LookForward := false; +end; + +procedure TBaseParser.Match(const S: String); +begin + if IsCurrText(S) then + Call_SCANNER + else + begin + LinePos := scanner.LinePos; + Gen(OP_NOP, 0, 0, 0); + RaiseError(errTokenExpected, [S, CurrToken.Text]); + end; +end; + +procedure TBaseParser.MatchFinal(const S: String); +begin + if IsCurrText(S) then + begin + // ok + end + else + begin + LinePos := scanner.LinePos; + Gen(OP_NOP, 0, 0, 0); + RaiseError(errTokenExpected, [S, CurrToken.Text]); + end; +end; + + +procedure TBaseParser.SafeMatch(const S: String); +begin + if IsCurrText(S) then + ReadToken + else + begin + LinePos := scanner.LinePos; + Gen(OP_NOP, 0, 0, 0); + RaiseError(errTokenExpected, [S, CurrToken.Text]); + end; +end; + +function TBaseParser.NotMatch(const S: String): Boolean; +begin + if not IsCurrText(S) then + result := true + else + begin + result := false; + Call_SCANNER; + end; +end; + +function TBaseParser.IsEOF: Boolean; +begin + result := scanner.IsEOF; +end; + +function TBaseParser.IsNewLine: Boolean; +begin + result := scanner.IsNewLine; +end; + +function TBaseParser.GetType(Id: Integer): Integer; +begin + result := TKernel(kernel).SymbolTable[Id].TypeID; +end; + +procedure TBaseParser.SetType(Id: Integer; TypeID: Integer); +begin + TKernel(kernel).SymbolTable[Id].TypeID := TypeID; +end; + +procedure TBaseParser.SetValue(Id: Integer; const Value: Variant); +begin + TKernel(kernel).SymbolTable[Id].Value := Value; +end; + +function TBaseParser.GetLevel(Id: Integer): Integer; +begin + result := TKernel(kernel).SymbolTable[Id].Level; +end; + +procedure TBaseParser.SetLevel(Id: Integer; Level: Integer); +begin + TKernel(kernel).SymbolTable[Id].Level := Level; +end; + +procedure TBaseParser.SetTypedConst(Id: Integer); +begin + TKernel(kernel).SymbolTable[Id].TypedConst := true; + SetKind(Id, KindVAR); +end; + +procedure TBaseParser.SetKind(Id: Integer; Kind: Integer); +var + S: TSymbolRec; +begin + S := TKernel(kernel).SymbolTable[Id]; + S.Kind := Kind; + if Kind = KindNONE then + begin + S.Param := false; + S.Register := 0; + S.TypeId := 0; + end; + +end; + +function TBaseParser.GetKind(Id: Integer): Integer; +begin + result := TKernel(kernel).SymbolTable[Id].Kind; +end; + +procedure TBaseParser.SetFinal(Id: Integer; value: Boolean); +begin + TKernel(kernel).SymbolTable[Id].IsFinal := value; +end; + +procedure TBaseParser.SetAbstract(Id: Integer; value: Boolean); +begin + TKernel(kernel).SymbolTable[Id].IsAbstract := value; +end; + +function TBaseParser.GetFullName(Id: Integer): String; +begin + result := TKernel(kernel).SymbolTable[Id].FullName; +end; + +function TBaseParser.GetName(Id: Integer): String; +begin + result := TKernel(kernel).SymbolTable[Id].Name; +end; + +procedure TBaseParser.SetName(Id: Integer; const S: String); +begin + TKernel(kernel).SymbolTable[Id].Name := S; +end; + +function TBaseParser.GetCount(Id: Integer): Integer; +begin + result := TKernel(kernel).SymbolTable[Id].Count; +end; + +procedure TBaseParser.SetCount(Id: Integer; value: Integer); +begin + TKernel(kernel).SymbolTable[Id].Count := value; +end; + +function TBaseParser.GetResultId(SubId: Integer): Integer; +begin + result := TKernel(kernel).SymbolTable.GetResultId(SubId); +end; + +function TBaseParser.GetParamId(SubId, J: Integer): Integer; +begin + result := TKernel(kernel).SymbolTable.GetParamId(SubId, J); +end; + +procedure TBaseParser.SetPatternId(Id: Integer; PatternId: Integer); +begin + TKernel(kernel).SymbolTable[Id].PatternId := PatternId; +end; + +procedure TBaseParser.SetAncestorId(Id: Integer; AncestorId: Integer); +begin + TKernel(kernel).SymbolTable[Id].AncestorId := AncestorId; +end; + +procedure TBaseParser.SetParam(Id: Integer; value: boolean); +begin + TKernel(kernel).SymbolTable[Id].Param := value; +end; + +procedure TBaseParser.SetOwnerId(Id: Integer; OwnerId: Integer); +begin + TKernel(kernel).SymbolTable[Id].OwnerId := OwnerId; +end; + +procedure TBaseParser.SetByRef(Id: Integer); +begin + TKernel(kernel).SymbolTable[Id].ByRef := true; +end; + +procedure TBaseParser.SetIsConst(Id: Integer); +begin + TKernel(kernel).SymbolTable[Id].IsConst := true; +end; + +procedure TBaseParser.SetOptional(Id: Integer); +begin + TKernel(kernel).SymbolTable[Id].Optional := true; +end; + +procedure TBaseParser.SetPacked(Id: Integer); +begin + SetAlignment(Id, 1); +end; + +procedure TBaseParser.SetCallConvention(Id: Integer; value: Integer); +begin + if TargetPlatform = tpWIN64 then + TKernel(kernel).SymbolTable[Id].CallConv := cc64 + else + TKernel(kernel).SymbolTable[Id].CallConv := value; +end; + +procedure TBaseParser.SetOverloaded(SubId: Integer); +var + Lst: TIntegerList; + SymbolTable: TSymbolTable; + I, K: Integer; +begin + SymbolTable := TKernel(kernel).SymbolTable; + lst := SymbolTable.LookupAll(SymbolTable[SubId].Name, SymbolTable[SubId].Level, Upcase); + try + K := Lst.Count; + for I := 0 to Lst.Count - 1 do + if Lst[I] < FirstLocalId then + Dec(K); + TKernel(kernel).SymbolTable[SubId].OverCount := K; + finally + FreeAndNil(Lst); + end; +end; + +procedure TBaseParser.SetCallMode(Id: Integer; value: Integer); +var + S: String; +begin + S := TKernel(kernel).SymbolTable[Id].Name; + if StrEql(S, 'AfterConstruction') or + StrEql(S, 'BeforeDestruction') or + StrEql(S, 'SafeCallexception') or + StrEql(S, 'Dispatch') or + StrEql(S, 'DefaultHandler') or + StrEql(S, 'NewInstance') or + StrEql(S, 'FreeInstance') then + value := cmNONE; + TKernel(kernel).SymbolTable[Id].CallMode := value; +end; + +procedure TBaseParser.SetLabelHere(Id: Integer; + Arg2: Integer = 0; + Res: Integer = 0); +begin + Gen(OP_LABEL, Id, Arg2, Res); +end; + +function TBaseParser.GetFinSubLabel: Integer; +begin + if ExitLabelStack.Count = 0 then + result := 0 + else + result := ExitLabelStack.Top; +end; + +function TBaseParser.GetCurrLevel: Integer; +begin + if levelStack.Count = 0 then + result := 0 + else + result := levelStack.Top; +end; + +function TBaseParser.GetCurrSubId: Integer; +begin + result := GetCurrLevel; +end; + +function TBaseParser.GetOuterClassId: Integer; +var + I, temp, K: Integer; +begin + result := typePOINTER; + K := 0; + + for I := levelStack.Count - 1 downto 0 do + begin + temp := levelStack[I]; + + if temp > 0 then + if GetSymbolRec(temp).Kind = KindTYPE then + if GetSymbolRec(temp).FinalTypeId = typeCLASS then + begin + Inc(K); + if K = 2 then + begin + result := temp; + Exit; + end; + end; + end; +end; + + +function TBaseParser.GetCurrResultId: Integer; +var + I: Integer; +begin + I := levelStack.Count - 1; + result := levelStack[I]; + while not (GetKind(result) in KindSUBS) do + begin + Dec(I); + result := levelStack[I]; + end; + result := TKernel(kernel).SymbolTable.GetResultId(result); +end; + +function TBaseParser.GetCurrSelfId: Integer; +var + I, SubId, L: Integer; +begin + result := 0; + SubId := 0; + + for I := levelStack.Count - 1 downto 0 do + begin + SubId := levelStack[I]; + if not GetSymbolRec(SubId).Kind in KindSUBS then + Exit; + L := GetLevel(SubId); + if L = 0 then + Exit; + if GetSymbolRec(L).Kind = KindTYPE then + break; + end; + + result := TKernel(kernel).SymbolTable.GetSelfId(SubId); +end; + +function TBaseParser.GetNilId: Integer; +begin + result := TKernel(kernel).SymbolTable.NilId; +end; + +function TBaseParser.GetCurrExceptionObjectId: Integer; +begin + result := TKernel(kernel).SymbolTable.CurrExceptionObjectId; +end; + +function TBaseParser.GetEmptySetId: Integer; +begin + result := TKernel(kernel).SymbolTable.EmptySetId; +end; + +procedure TBaseParser.BeginSub(SubId: Integer); +var + SelfId, L: Integer; +begin + SetKind(SubID, KindSUB); + SetCallConvention(SubID, CallConv); + + levelStack.Push(SubId); + + NewVar('result'); + SelfId := NewVar(''); + SetKind(SelfId, KindNONE); + + L := NewLabel; + Gen(OP_GO, L, 0, 0); + SkipLabelStack.Push(L); + + Gen(OP_BEGIN_SUB, SubId, 0, 0); + L := NewLabel; + SkipLabelStack.Push(L); + + if TKernel(kernel).SymbolTable[SubId].IsNestedSub then + begin + L := NewVar('%RBP'); + SetType(L, typePOINTER); + if TargetPlatform <> tpWIN64 then + SetCallConvention(SubID, ccSTDCALL); + end; + if TargetPlatform in [tpOSX32, tpIOSSim] then + begin + L := NewVar('%RBX'); + SetType(L, typePOINTER); + L := NewVar('%RDI'); + SetType(L, typePOINTER); + end; + + L := NewLabel; + ExitLabelStack.Push(L); +end; + +procedure TBaseParser.RemoveSub; +var + Code: TCode; + I: Integer; +begin + Code := TKernel(kernel).Code; + + I := Code.Card; + repeat + if Code[I].Op = OP_EVAL then + begin + Dec(I); + continue; + end; + + if Code[I].Op = OP_ASSIGN_TYPE then + Dec(I) + else if Code[I].Op = OP_ASSIGN_CONST then + Dec(I) + else if Code[I].Op = OP_CREATE_DYNAMIC_ARRAY_TYPE then + Dec(I) + else if Code[I].Op = OP_ADD_MESSAGE then + Dec(I) + else if Code[I].Op = OP_GO then + begin + Code[I].Op := OP_NOP; + Exit; + end + else + begin + Code[I].Op := OP_NOP; + Dec(I); + end; + + until false; +end; + +procedure TBaseParser.RemoveSub(SubId: Integer); +var + Code: TCode; + I: Integer; + R: TCodeRec; + Inside: Boolean; + id: Integer; +begin + Code := TKernel(kernel).Code; + Inside := false; + + for I := 1 to Code.Card do + begin + R := Code[I]; + if (R.Op = OP_BEGIN_SUB) and (R.Arg1 = SubId) then + begin + R.Op := OP_NOP; + Inside := true; + end + else if (R.Op = OP_FIN_SUB) and (R.Arg1 = SubId) then + begin + R.Op := OP_NOP; + Exit; + end + else if Inside then + R.Op := OP_NOP; + end; + + Id := TKernel(kernel).SymbolTable.GetResultId(SubId); + SetName(Id, ''); + SetKind(Id, KindNONE); + SetName(SubId, ''); + SetKind(SubId, KindNONE); +end; + +procedure TBaseParser.BeginClassConstructor(SubId, ClassTypeId: Integer); +var + L: Integer; + ResId, SelfId: Integer; + Id: Integer; +begin + SetKind(SubID, KindCONSTRUCTOR); + SetCallConvention(SubID, ccREGISTER); + + levelStack.Push(SubId); + + ResId := NewVar(''); // result + SelfId := NewVar('Self'); + + SetKind(ResId, KindNONE); + SetLevel(SubId, ClassTypeId); + TKernel(kernel).SymbolTable[SelfId].Param := true; + + Gen(OP_ASSIGN_TYPE, SubId, ClassTypeId, 0); + Gen(OP_ASSIGN_TYPE, SelfId, ClassTypeId, 0); + + L := NewLabel; + Gen(OP_GO, L, 0, 0); + SkipLabelStack.Push(L); + + Gen(OP_BEGIN_SUB, SubId, 0, 0); + L := NewLabel; + SkipLabelStack.Push(L); + + L := NewLabel; + ExitLabelStack.Push(L); + + AddTypeParameters(SubId); + + if TargetPlatform <> tpWIN32 then + begin + Id := NewVar('%DL'); + SetType(Id, typePOINTER); + end; + if TargetPlatform in [tpOSX32, tpIOSSim] then + begin + L := NewVar('%RBX'); + SetType(L, typePOINTER); + L := NewVar('%RDI'); + SetType(L, typePOINTER); + end; +end; + +procedure TBaseParser.BeginClassDestructor(SubId, ClassTypeId: Integer); +var + L: Integer; + ResId, SelfId: Integer; +begin + SetKind(SubID, KindDESTRUCTOR); + SetCallConvention(SubID, CallConv); + + levelStack.Push(SubId); + + ResId := NewVar(''); // result + SelfId := NewVar('Self'); + + SetKind(ResId, KindNONE); + SetLevel(SubId, ClassTypeId); + TKernel(kernel).SymbolTable[SelfId].Param := true; + + Gen(OP_ASSIGN_TYPE, SubId, ClassTypeId, 0); + Gen(OP_ASSIGN_TYPE, SelfId, ClassTypeId, 0); + + L := NewLabel; + Gen(OP_GO, L, 0, 0); + SkipLabelStack.Push(L); + + Gen(OP_BEGIN_SUB, SubId, 0, 0); + L := NewLabel; + SkipLabelStack.Push(L); + + L := NewLabel; + ExitLabelStack.Push(L); + + AddTypeParameters(SubId); + + if TargetPlatform in [tpOSX32, tpIOSSim] then + begin + L := NewVar('%RBX'); + SetType(L, typePOINTER); + L := NewVar('%RDI'); + SetType(L, typePOINTER); + end; +end; + +procedure TBaseParser.BeginClassMethod(SubId, ClassTypeId: Integer; + HasResult: Boolean; + IsSharedMethod: Boolean; + IsMethodImpl: Boolean); // pascal only +var + L: Integer; + ResId, SelfId: Integer; +begin + InitTypeExt(ClassTypeId, GetName(SubId), IsMethodImpl); + + SetKind(SubID, KindSUB); + SetCallConvention(SubID, CallConv); + + levelStack.Push(SubId); + + if HasResult then + NewVar('result') + else + begin + ResId := NewVar(''); + SetKind(ResId, KindNONE); + end; + + SelfId := NewVar('Self'); + + SetLevel(SubId, ClassTypeId); + + TKernel(kernel).SymbolTable[SelfId].Param := true; + TKernel(kernel).SymbolTable[SubId].IsSharedMethod := IsSharedMethod; + + SetType(SubId, typeVOID); + Gen(OP_ASSIGN_TYPE, SelfId, ClassTypeId, 0); + + L := NewLabel; + Gen(OP_GO, L, 0, 0); + SkipLabelStack.Push(L); + + Gen(OP_BEGIN_SUB, SubId, 0, 0); + L := NewLabel; + SkipLabelStack.Push(L); + + L := NewLabel; + ExitLabelStack.Push(L); + + AddTypeParameters(SubId); + + if TargetPlatform in [tpOSX32, tpIOSSim] then + begin + L := NewVar('%RBX'); + SetType(L, typePOINTER); + L := NewVar('%RDI'); + SetType(L, typePOINTER); + end; +end; + +procedure TBaseParser.BeginStructureConstructor(SubId, StructTypeId: Integer); +begin + BeginStructureMethod(SubId, StructTypeId, false, false); + SetKind(SubId, kindCONSTRUCTOR); + SetType(SubId, StructTypeId); + SetCallConvention(SubID, ccREGISTER); +end; + +procedure TBaseParser.BeginStructureDestructor(SubId, StructTypeId: Integer); +begin + BeginStructureMethod(SubId, StructTypeId, false, false); + SetKind(SubId, kindDESTRUCTOR); + SetCallConvention(SubID, ccREGISTER); +end; + +procedure TBaseParser.BeginStructureMethod(SubId, StructTypeId: Integer; + HasResult: Boolean; + IsSharedMethod: Boolean); +var + L: Integer; + ResId, SelfId: Integer; +begin + SetKind(SubID, KindSUB); + SetCallConvention(SubID, CallConv); + + levelStack.Push(SubId); + + if HasResult then + NewVar('result') + else + begin + ResId := NewVar(''); + SetKind(ResId, KindNONE); + end; + + SelfId := NewVar('Self'); + + SetLevel(SubId, StructTypeId); + + TKernel(kernel).SymbolTable[SelfId].Param := true; + TKernel(kernel).SymbolTable[SubId].IsSharedMethod := IsSharedMethod; + + TKernel(kernel).SymbolTable[SelfId].ByRef := true; + + SetType(SubId, typeVOID); + Gen(OP_ASSIGN_TYPE, SelfId, StructTypeId, 0); + + L := NewLabel; + Gen(OP_GO, L, 0, 0); + SkipLabelStack.Push(L); + + Gen(OP_BEGIN_SUB, SubId, 0, 0); + L := NewLabel; + SkipLabelStack.Push(L); + + L := NewLabel; + ExitLabelStack.Push(L); + + AddTypeParameters(SubId); + + if TargetPlatform in [tpOSX32, tpIOSSim] then + begin + L := NewVar('%RBX'); + SetType(L, typePOINTER); + L := NewVar('%RDI'); + SetType(L, typePOINTER); + end; +end; + +procedure TBaseParser.BeginStructureOperator(SubId, StructTypeId: Integer); +var + L: Integer; + SelfId: Integer; +begin + SetKind(SubID, KindSUB); + SetCallConvention(SubID, CallConv); + + levelStack.Push(SubId); + + NewVar('result'); + SelfId := NewVar(''); + GetSymbolRec(SelfId).Kind := KindNONE; + + SetLevel(SubId, StructTypeId); + + TKernel(kernel).SymbolTable[SelfId].Param := true; + TKernel(kernel).SymbolTable[SubId].IsSharedMethod := true; + TKernel(kernel).SymbolTable[SubId].CallMode := cmSTATIC; + + L := NewLabel; + Gen(OP_GO, L, 0, 0); + SkipLabelStack.Push(L); + + Gen(OP_BEGIN_SUB, SubId, 0, 0); + L := NewLabel; + SkipLabelStack.Push(L); + + L := NewLabel; + ExitLabelStack.Push(L); + + if TargetPlatform in [tpOSX32, tpIOSSim] then + begin + L := NewVar('%RBX'); + SetType(L, typePOINTER); + L := NewVar('%RDI'); + SetType(L, typePOINTER); + end; +end; + +procedure TBaseParser.BeginInterfaceMethod(SubId, IntfTypeId: Integer; + HasResult: Boolean); +begin + BeginClassMethod(SubId, IntfTypeId, HasResult, false, false); + SetVisibility(SubId, cvPublic); +end; + +procedure TBaseParser.CheckAbstract(SubId: Integer); +var + I, Op: Integer; + Code: TCode; + S, Q: String; + R: TCodeRec; +begin + Code := TKernel(kernel).Code; + S := GetFullName(SubId); + for I:=Code.Card downto 1 do + begin + R := Code[I]; + Op := R.Op; + if Op = OP_ERR_ABSTRACT then + begin + if StrEql(GetFullName(R.Res), S) then + begin + S := GetSymbolRec(R.Res).Sig; + Q := GetSymbolRec(SubId).Sig; + if StrEql(S, Q) then + begin + CreateError(errNoDefinitionForAbstractMethodAllowed, [S]); + break; + end; + end; + end + else if Op = OP_BEGIN_MODULE then + break; + end; +end; + +procedure TBaseParser.BeginLoop; +begin + Inc(LoopCounter); + LoopCounterStack.Push(LoopCounter); + Gen(OP_BEGIN_LOOP, LoopCounterStack.Top, 0, 0); + Gen(OP_NOP, 0, 0, 0); +end; + +procedure TBaseParser.EndLoop; +var + b: Boolean; + Code: TCode; + I: Integer; +begin + // reserved for epilogue + Gen(OP_EPILOGUE_LOOP, LoopCounterStack.Top, 0, 0); + + Code := TKernel(kernel).Code; + + b := false; + + I := Code.Card; + repeat + Dec(I); + + if Code[I].Op = OP_END_LOOP then + break; + if Code[I].Op = OP_BEGIN_LOOP then + break; + if Code[I].Op = OP_TRY_ON then + begin + b := true; + break; + end; + + until false; + + if b then + begin + if BreakStack.Count > 0 then + begin + LastCodeRec.BreakLabel := BreakStack.TopLabel(); + LastCodeRec.LoopLabel := BreakStack.Top.loopLabel; + end; + if ContinueStack.Count > 0 then + LastCodeRec.ContinueLabel := ContinueStack.TopLabel(); + + Gen(OP_NOP, 0, 0, 0); // OP_EXCEPT_SEH + Gen(OP_NOP, 0, 0, 0); // LABEL + Gen(OP_NOP, 0, 0, 0); // FINALLY + + Gen(OP_NOP, 0, 0, 0); //OP_COND_RAISE + Gen(OP_NOP, 0, 0, 0); //OP_LABEL + Gen(OP_NOP, 0, 0, 0); //OP_TRY_OFF + Gen(OP_NOP, 0, 0, 0); //OP_LABEL + end; + + Gen(OP_END_LOOP, LoopCounterStack.Top, 0, 0); + LoopCounterStack.Pop; +end; + +procedure TBaseParser.InitSub(var SubId: Integer); +begin + SetLabelHere(SubId); + Gen(OP_INIT_SUB, SubId, 0, 0); + // reserved for prologue + Gen(OP_NOP, 0, 0, 0); +end; + +procedure TBaseParser.EndSub(SubId: Integer); +var + L: Integer; + I: Integer; + Code: TCode; + R: TCodeRec; +begin + Code := TKernel(kernel).Code; + + L := SkipLabelStack.Top; + SetLabelHere(L); + SkipLabelStack.Pop; + + Gen(OP_EPILOGUE_SUB, SubId, 0, 0); + + // reserved for epilogue + Gen(OP_NOP, 0, 0, 0); // OP_EXCEPT_SEH + Gen(OP_NOP, 0, 0, 0); // LABEL + Gen(OP_NOP, 0, 0, 0); // FINALLY + + for I:=Code.Card downto 1 do + begin + R := Code[I]; + if (R.Op = OP_BEGIN_SUB) and (R.Arg1 = SubId) then + break; + if (R.Op = OP_DECLARE_LOCAL_VAR) and (R.Arg1 = SubId) then + begin + if GetKind(R.Arg2) = KindVAR then + begin + if GetSymbolRec(R.Arg2).IsConst then + continue; + if GetSymbolRec(R.Arg2).TypedConst then + continue; + if GetSymbolRec(R.Arg2).ByRef then + continue; + + if not TKernel(kernel).SymbolTable[R.Arg2].Param then + Gen(OP_DESTROY_LOCAL_VAR, R.Arg2, 0, 0); + end; + end; + end; + + // reserved for epilogue + Gen(OP_NOP, 0, 0, 0); //OP_COND_RAISE + Gen(OP_NOP, 0, 0, 0); //OP_LABEL + Gen(OP_NOP, 0, 0, 0); //OP_TRY_OFF + Gen(OP_NOP, 0, 0, 0); //OP_LABEL + + levelStack.Pop; + Gen(OP_END_SUB, SubId, 0, 0); + + L := ExitLabelStack.Top; + SetLabelHere(L); + ExitLabelStack.Pop; + Gen(OP_FIN_SUB, SubId, 0, 0); + + L := SkipLabelStack.Top; + SetLabelHere(L); + SkipLabelStack.Pop; +end; + +procedure TBaseParser.BeginProperty(PropId, ClassTypeId: Integer); +begin + SetKind(PropID, KindPROP); + levelStack.Push(PropId); + SetLevel(PropId, ClassTypeId); +end; + +procedure TBaseParser.EndProperty(PropId: Integer); +begin + levelStack.Pop; +end; + +procedure TBaseParser.BeginNamespace(Id: Integer; Jump: Boolean = true); +var + L: Integer; + DeclaredInSub: Boolean; +begin + DeclaredInSub := GetKind(levelStack.Top) = KindSUB; + + SetKind(Id, KindNAMESPACE); + levelStack.Push(Id); + + if Jump then if not DeclaredInSub then + begin + L := NewLabel; + Gen(OP_GO, L, 0, 0); + SkipLabelStack.Push(L); + end; + + Gen(OP_BEGIN_NAMESPACE, Id, 0, 0); + Gen(OP_BEGIN_USING, Id, 0, 0); +end; + +procedure TBaseParser.EndNamespace(Id: Integer; Jump: Boolean = true); +var + L: Integer; + DeclaredInSub: Boolean; +begin + Gen(OP_END_NAMESPACE, Id, 0, 0); + + levelStack.Pop; + + DeclaredInSub := GetKind(levelStack.Top) = KindSUB; + + if Jump then if not DeclaredInSub then + begin + L := SkipLabelStack.Top; + SetLabelHere(L); + SkipLabelStack.Pop; + end; + + Gen(OP_END_USING, Id, 0, 0); +end; + +procedure TBaseParser.BeginRecordType(TypeId: Integer); +var + L: Integer; + DeclaredInSub: Boolean; +begin + DeclaredInSub := GetKind(levelStack.Top) = KindSUB; + + SetKind(TypeId, KindTYPE); + SetType(TypeId, typeRECORD); + levelStack.Push(TypeId); + + SetAlignment(TypeId, Alignment); + + if not DeclaredInSub then + begin + L := NewLabel; + Gen(OP_GO, L, 0, 0); + SkipLabelStack.Push(L); + end; + + Gen(OP_BEGIN_RECORD_TYPE, TypeId, 0, 0); + if GetName(TypeId) = '' then + begin + SetName(TypeId, 'RecordType_' + IntToStr(TypeId)); + Gen(OP_ADD_TYPEINFO, TypeId, 0, 0); + end; + + AddTypeParameters(TypeId); +end; + +procedure TBaseParser.EndRecordType(TypeId: Integer); +var + L: Integer; + DeclaredInSub: Boolean; +begin + TypeParams.Clear; + + Gen(OP_END_RECORD_TYPE, TypeId, 0, 0); + + levelStack.Pop; + + DeclaredInSub := GetKind(levelStack.Top) = KindSUB; + + if not DeclaredInSub then + begin + L := SkipLabelStack.Top; + SetLabelHere(L); + SkipLabelStack.Pop; + end; +end; + +procedure TBaseParser.BeginClassType(TypeId: Integer); +var + L, SZ: Integer; + DeclaredInSub: Boolean; + R: TSymbolRec; + ClassRefTypeId: Integer; + S, FullName: String; + C: TClass; +begin + SZ := TObject.InstanceSize; + S := GetName(TypeId); + FullName := GetSymbolRec(TypeId).FullName; + + DeclaredInSub := GetKind(levelStack.Top) = KindSUB; + + SetAlignment(TypeId, 1); + + SetKind(TypeId, KindTYPE); + SetType(TypeId, typeCLASS); + + TKernel(kernel).SymbolTable[TypeId].AncestorId := H_TObject; + + R := TKernel(kernel).SymbolTable.AddClassRefVar(0); + + if TKernel(kernel).ClassFactory.LookupFullName(FullName) = nil then + begin + C := TKernel(kernel).ClassFactory.CreatePaxClass(FullName, SZ, TObject, + TKernel(kernel).GetDestructorAddress); + R.Value := Integer(C); + TKernel(kernel).SymbolTable[TypeId].PClass := C; + end; + + ClassRefTypeId := TKernel(kernel).SymbolTable.RegisterClassReferenceType(0, '', TypeId); + TKernel(kernel).SymbolTable[ClassRefTypeId].Host := false; + R.TypeID := ClassRefTypeId; + + levelStack.Push(TypeId); + + if not DeclaredInSub then + begin + L := NewLabel; + Gen(OP_GO, L, 0, 0); + SkipLabelStack.Push(L); + end; + + Gen(OP_BEGIN_CLASS_TYPE, TypeId, 0, R.Id); + + AddTypeParameters(TypeId); +end; + +procedure TBaseParser.EndClassType(TypeId: Integer; IsForward: Boolean = false); +var + I, L, P: Integer; + DeclaredInSub: Boolean; + Code: TCode; + R: TCodeRec; + S: String; +begin + Code := TKernel(kernel).Code; + + if IsGeneric(TypeId) then + if not CurrModule.IsExtra then + begin + for I := Code.Card downto 1 do + begin + R := Code[I]; + if R.Op = OP_BEGIN_CLASS_TYPE then + if R.Arg1 = TypeId then + break; + if R.Op = OP_ADD_ANCESTOR then + if R.Arg1 = TypeId then + begin + S := GetName(R.Arg2); + P := PosCh('<', S); + if P > 0 then + begin + S := Copy(S, 1, P - 1); + TKernel(kernel).TypeDefList.FindTypeDef(TypeId).AncestorName := S; + end; + end; + end; + end; + + TypeParams.Clear; + + if IsForward then + begin + L := Code.Card; + while Code[L].Op <> OP_BEGIN_CLASS_TYPE do Dec(L); + Code[L].Op := OP_NOP; + end + else + Gen(OP_END_CLASS_TYPE, TypeId, 0, 0); + + levelStack.Pop; + + DeclaredInSub := GetKind(levelStack.Top) = KindSUB; + + if not DeclaredInSub then + begin + L := SkipLabelStack.Top; + SetLabelHere(L); + SkipLabelStack.Pop; + end; +end; + +procedure TBaseParser.BeginMethodRefType(TypeId: Integer); +begin + BeginInterfaceType(TypeId); + SetNewGuid(TypeId); + SetPacked(TypeID); + Gen(OP_ADD_INTERFACE, TypeId, H_IUnknown, 0); +end; + +procedure TBaseParser.EndMethodRefType(TypeId: Integer); +begin + EndInterfaceType(TypeId, false); +end; + +procedure TBaseParser.BeginInterfaceType(TypeId: Integer); +var + L: Integer; + DeclaredInSub: Boolean; +begin + DeclaredInSub := GetKind(levelStack.Top) = KindSUB; + + SetAlignment(TypeId, 1); + + SetKind(TypeId, KindTYPE); + SetType(TypeId, typeINTERFACE); + + TKernel(kernel).SymbolTable.AddDoubleConst(0); + TKernel(kernel).SymbolTable.AddDoubleConst(0); + + levelStack.Push(TypeId); + + if not DeclaredInSub then + begin + L := NewLabel; + Gen(OP_GO, L, 0, 0); + SkipLabelStack.Push(L); + end; + + Gen(OP_BEGIN_INTERFACE_TYPE, TypeId, 0, 0); + if GetName(TypeId) = '' then + begin + SetName(TypeId, 'InterfaceType_' + IntToStr(TypeId)); + Gen(OP_ADD_TYPEINFO, TypeId, 0, 0); + end; + + AddTypeParameters(TypeId); +end; + +procedure TBaseParser.SetGuid(IntfTypeId: Integer; const S: String); +var + D: packed record + D1, D2: Double; + end; + G: TGUID; +begin +{$IFDEF VARIANTS} + if S[1] = '(' then + G := SysUtils.StringToGUID(Copy(S, 2, Length(S) - 2)) + else + G := SysUtils.StringToGUID(S); +{$ELSE} + if S[1] = '(' then + G := StringToGUID(Copy(S, 2, Length(S) - 2)) + else + G := StringToGUID(S); +{$ENDIF} + Move(G, D, SizeOf(G)); + TKernel(kernel).SymbolTable[IntfTypeId + 1].Value := D.D1; + TKernel(kernel).SymbolTable[IntfTypeId + 2].Value := D.D2; +end; + +{$IFDEF PAXARM} +function CoCreateGuid(out guid: TGUID): HResult; +begin +end; +{$ELSE} +{$IFDEF LINUX} + // will use uuid.pas in hash folder: +function CoCreateGuid(out guid: TGUID): HResult; +begin + if uuid.uuid_create(GUID) then result:=1 + else result:=0; +end; +{$ELSE} +function CoCreateGuid(out guid: TGUID): HResult; stdcall; + external 'ole32.dll' name 'CoCreateGuid'; +{$ENDIF} +{$ENDIF} + +function CreateGUID(out Guid: TGUID): HResult; +begin + Result := CoCreateGuid(Guid); +end; + +procedure TBaseParser.SetNewGuid(IntfTypeId: Integer); +var + D: packed record + D1, D2: Double; + end; + G: TGUID; +begin +{$IFDEF VARIANTS} + SysUtils.CreateGUID(G); +{$ELSE} + CreateGUID(G); +{$ENDIF} + Move(G, D, SizeOf(G)); + TKernel(kernel).SymbolTable[IntfTypeId + 1].Value := D.D1; + TKernel(kernel).SymbolTable[IntfTypeId + 2].Value := D.D2; +end; + +procedure TBaseParser.EndInterfaceType(TypeId: Integer; IsForward: Boolean); +var + L: Integer; + DeclaredInSub: Boolean; + Code: TCode; +begin + TypeParams.Clear; + + if IsForward then + begin + Code := TKernel(kernel).Code; + L := Code.Card; + while Code[L].Op <> OP_BEGIN_INTERFACE_TYPE do Dec(L); + Code[L].Op := OP_NOP; + end + else + Gen(OP_END_INTERFACE_TYPE, TypeId, 0, 0); + + levelStack.Pop; + + DeclaredInSub := GetKind(levelStack.Top) = KindSUB; + + if not DeclaredInSub then + begin + L := SkipLabelStack.Top; + SetLabelHere(L); + SkipLabelStack.Pop; + end; +end; + +procedure TBaseParser.BeginArrayType(TypeId: Integer); +var + L: Integer; + DeclaredInSub: Boolean; +begin + DeclaredInSub := GetKind(levelStack.Top) = KindSUB; + + SetKind(TypeId, KindTYPE); + SetType(TypeId, typeARRAY); + + SetAlignment(TypeId, 1); + + levelStack.Push(TypeId); + + if not DeclaredInSub then + begin + L := NewLabel; + Gen(OP_GO, L, 0, 0); + SkipLabelStack.Push(L); + end; + + Gen(OP_BEGIN_ARRAY_TYPE, TypeId, 0, 0); + if GetName(TypeId) = '' then + begin + SetName(TypeId, 'ArrayType_' + IntToStr(TypeId)); + Gen(OP_ADD_TYPEINFO, TypeId, 0, 0); + end; + + AddTypeParameters(GetSymbolRec(TypeId).Level); +end; + +procedure TBaseParser.EndArrayType(TypeId: Integer); +var + L: Integer; + DeclaredInSub: Boolean; +begin + Gen(OP_END_ARRAY_TYPE, TypeId, 0, 0); + + levelStack.Pop; + + DeclaredInSub := GetKind(levelStack.Top) = KindSUB; + + if not DeclaredInSub then + begin + L := SkipLabelStack.Top; + SetLabelHere(L); + SkipLabelStack.Pop; + end; +end; + +procedure TBaseParser.BeginSetType(TypeId, TypeBaseId: Integer); +begin + SetKind(TypeId, KindTYPE); + SetType(TypeId, typeSET); + SetPatternId(TypeId, TypeBaseId); + + Gen(OP_BEGIN_SET_TYPE, TypeId, 0, 0); + if GetName(TypeId) = '' then + begin + SetName(TypeId, 'SetType_' + IntToStr(TypeId)); + Gen(OP_ADD_TYPEINFO, TypeId, 0, 0); + end; + if GetName(TypeBaseId) = '' then + begin + SetName(TypeBaseId, 'OriginSetType_' + IntToStr(TypeBaseId)); + Gen(OP_ADD_TYPEINFO, TypeBaseId, 0, 0); + end; +end; + +procedure TBaseParser.EndSetType(TypeId: Integer); +begin + Gen(OP_END_SET_TYPE, TypeId, 0, 0); +end; + +procedure TBaseParser.BeginEnumType(TypeId, TypeBaseId: Integer); +begin + SetKind(TypeId, KindTYPE); + SetType(TypeId, typeENUM); + SetPatternId(TypeId, TypeBaseId); + + levelStack.Push(TypeId); + + Gen(OP_BEGIN_ENUM_TYPE, TypeId, 0, 0); + if GetName(TypeId) = '' then + begin + SetName(TypeId, 'EnumType_' + IntToStr(TypeId)); + Gen(OP_ADD_TYPEINFO, TypeId, 0, 0); + end; +end; + +procedure TBaseParser.EndEnumType(TypeId, ACount: Integer); +begin + Gen(OP_END_ENUM_TYPE, TypeId, 0, 0); + + SetCount(TypeId, ACount); + + levelStack.Pop; +end; + +procedure TBaseParser.BeginSubrangeType(TypeId, TypeBaseId: Integer); +begin + SetKind(TypeId, KindTYPE); + SetType(TypeId, TypeBaseId); + levelStack.Push(TypeId); + + Gen(OP_BEGIN_SUBRANGE_TYPE, TypeId, 0, 0); + if GetName(TypeId) = '' then + begin + SetName(TypeId, 'SubType_' + IntToStr(TypeId)); + Gen(OP_ADD_TYPEINFO, TypeId, 0, 0); + end; +end; + +procedure TBaseParser.EndSubrangeType(TypeId: Integer); +begin + Gen(OP_END_SUBRANGE_TYPE, TypeId, 0, 0); + + levelStack.Pop; +end; + +procedure TBaseParser.BeginPointerType(TypeId: Integer); +begin + SetKind(TypeId, KindTYPE); + SetType(TypeId, typePOINTER); + + Gen(OP_BEGIN_POINTER_TYPE, TypeId, 0, 0); + if GetName(TypeId) = '' then + begin + SetName(TypeId, 'PointerType_' + IntToStr(TypeId)); + Gen(OP_ADD_TYPEINFO, TypeId, 0, 0); + end; +end; + +procedure TBaseParser.EndPointerType(TypeId: Integer); +begin + Gen(OP_END_POINTER_TYPE, TypeId, 0, 0); +end; + +procedure TBaseParser.BeginHelperType(TypeId, TrueTypeId: Integer); +begin + SetKind(TypeId, KindTYPE); + SetType(TypeId, typeHELPER); + Gen(OP_BEGIN_HELPER_TYPE, TypeId, TrueTypeId, 0); + levelStack.Push(TypeId); +end; + +procedure TBaseParser.EndHelperType(TypeId: Integer); +begin + Gen(OP_END_HELPER_TYPE, TypeId, 0, 0); + levelStack.Pop; +end; + +procedure TBaseParser.BeginClassReferenceType(TypeId: Integer); +begin + SetKind(TypeId, KindTYPE); + SetType(TypeId, typeCLASSREF); + Gen(OP_BEGIN_CLASSREF_TYPE, TypeId, 0, 0); + if GetName(TypeId) = '' then + begin + SetName(TypeId, 'ClassRefType_' + IntToStr(TypeId)); + Gen(OP_ADD_TYPEINFO, TypeId, 0, 0); + end; +end; + +procedure TBaseParser.EndClassReferenceType(TypeId: Integer); +begin + Gen(OP_END_CLASSREF_TYPE, TypeId, 0, 0); +end; + +procedure TBaseParser.BeginDynamicArrayType(TypeId: Integer); +var + L: Integer; +begin + SetKind(TypeId, KindTYPE); + SetType(TypeId, typeDYNARRAY); + + Gen(OP_BEGIN_DYNARRAY_TYPE, TypeId, 0, 0); + if GetName(TypeId) = '' then + begin + SetName(TypeId, 'DynarrayType_' + IntToStr(TypeId)); + Gen(OP_ADD_TYPEINFO, TypeId, 0, 0); + end; + L := GetLevel(TypeId); + AddTypeParameters(L); + if L = 0 then + Exit; + while GetKind(L) in kindSUBS do + L := GetLevel(L); + SetLevel(TypeId, L); +end; + +procedure TBaseParser.EndDynamicArrayType(TypeId: Integer); +begin + Gen(OP_END_DYNARRAY_TYPE, TypeId, 0, 0); +end; + +procedure TBaseParser.BeginOpenArrayType(TypeId: Integer); +var + L: Integer; +begin + SetKind(TypeId, KindTYPE); + SetType(TypeId, typeOPENARRAY); + + L := GetLevel(TypeId); + if L = 0 then + Exit; + while GetKind(L) in kindSUBS do + L := GetLevel(L); + SetLevel(TypeId, L); +end; + +procedure TBaseParser.EndOpenArrayType(TypeId: Integer; const ElemName: String); +var + HighId: Integer; +begin + HighId := NewTempVar; + SetLevel(HighId, CurrLevel); + SetType(HighId, typeINTEGER); +// GetSymbolRec(HighId).Param := true; + + if GetName(TypeId) = '' then + begin + SetName(TypeId, 'OA_' + IntToStr(TypeId) + '_' + ElemName); + end; +end; + +{$IFNDEF PAXARM} +procedure TBaseParser.BeginShortStringType(TypeId: Integer); +begin + SetKind(TypeId, KindTYPE); + SetType(TypeId, typeSHORTSTRING); + Gen(OP_BEGIN_SHORTSTRING_TYPE, TypeId, 0, 0); + if GetName(TypeId) = '' then + begin + SetName(TypeId, 'ShortStringType_' + IntToStr(TypeId)); + Gen(OP_ADD_TYPEINFO, TypeId, 0, 0); + end; +end; + +procedure TBaseParser.EndShortStringType(TypeId: Integer); +begin + Gen(OP_END_SHORTSTRING_TYPE, TypeId, 0, 0); +end; +{$ENDIF} + +procedure TBaseParser.BeginProceduralType(TypeId, SubId: Integer); +var + DummySubId: Integer; +begin + SetKind(TypeId, KindTYPE); + SetType(TypeId, typePROC); + + SetKind(SubID, KindSUB); + SetCallConvention(SubID, CallConv); + + SetPatternId(TypeId, SubId); + + levelStack.Push(SubId); + NewVar('result'); + NewVar(''); + + if InterfaceOnly then + begin +// DummySubId := TypeId + 1; +// SetName(DummySubId, DUMMYPROC_PREFIX + IntToStr(DummySubId)); + DummySubId := SubId; + + Gen(OP_BEGIN_PROC_TYPE, TypeId, 0, 0); + Gen(OP_BEGIN_SUB, DummySubId, 0, 0); + + if GetName(TypeId) = '' then + SetName(TypeId, 'ProcType_' + IntToStr(TypeId)); + + SetName(DummySubId, DUMMYPROC_PREFIX + GetName(TypeId)); + SetLevel(DummySubId, TypeId); + end; + + AddTypeParameters(GetLevel(TypeId)); +end; + +procedure TBaseParser.EndProceduralType(TypeId: Integer); +begin + if InterfaceOnly then + begin + Gen(OP_END_SUB, TypeId + 1, 0, 0); + Gen(OP_END_PROC_TYPE, TypeId, 0, 0); + end; + + levelStack.Pop; +end; + + +function TBaseParser.GetTryCount: Integer; +begin + result := TKernel(kernel).TryCount; +end; + +procedure TBaseParser.SetTryCount(Value: Integer); +begin + TKernel(kernel).TryCount := Value; +end; + +function TBaseParser.GetDebugMode: Boolean; +begin + result := TKernel(kernel).DEBUG_MODE; +end; + +function TBaseParser.GenBeginTry: Integer; // returns label +begin + SetTryCount(TryCount + 1); + try_stack.Push(TryCount); + + result := NewLabel; + Gen(OP_TRY_ON, try_stack.Top, 0, CurrLevel); +end; + +procedure TBaseParser.GenFinally; +var + L: Integer; +begin + L := NewLabel; + SetLabelHere(L); + Gen(OP_FINALLY, try_stack.Top, L, CurrLevel); + + if BreakStack.Count > 0 then + begin + LastCodeRec.BreakLabel := BreakStack.TopLabel(); + LastCodeRec.LoopLabel := BreakStack.Top.loopLabel; + end; + if ContinueStack.Count > 0 then + LastCodeRec.ContinueLabel := ContinueStack.TopLabel(); +end; + +procedure TBaseParser.GenExcept; +var + L: Integer; +begin + L := NewLabel; + SetLabelHere(L); + Gen(OP_EXCEPT, try_stack.Top, L, CurrLevel); + + if BreakStack.Count > 0 then + begin + LastCodeRec.BreakLabel := BreakStack.TopLabel(); + LastCodeRec.LoopLabel := BreakStack.Top.loopLabel; + end; + if ContinueStack.Count > 0 then + LastCodeRec.ContinueLabel := ContinueStack.TopLabel(); +end; + +procedure TBaseParser.GenExceptOn(type_id: Integer); +var + L: Integer; + BlockNumber: Integer; +begin + L := NewLabel; + SetLabelHere(L); + BlockNumber := try_stack.Top; + Gen(OP_EXCEPT_ON, BlockNumber, L, type_id); +end; + +procedure TBaseParser.GenEndTry; +begin + Gen(OP_TRY_OFF, try_stack.Top, 0, CurrLevel); + try_stack.Pop; +end; + +procedure TBaseParser.GenDestroyGlobalDynamicVariables(B1, B2: Integer); +var + I: Integer; + R: TCodeRec; + Code: TCode; +begin + Code := TKernel(kernel).Code; + + for I:=B2 downto B1 do + begin + R := Code[I]; + if R.Op = OP_DECLARE_LOCAL_VAR then + if GetKind(R.Arg2) = KindVAR then + begin + if (R.Arg1 = 0) or (TKernel(kernel).SymbolTable[R.Arg1].Kind = kindNAMESPACE) then + begin + if not TKernel(kernel).SymbolTable[R.Arg2].Param then + Gen(OP_DESTROY_LOCAL_VAR, R.Arg2, 0, 0); + end + else if GetSymbolRec(R.Arg2).TypedConst then + begin + Gen(OP_DESTROY_LOCAL_VAR, R.Arg2, 0, 0); + end; + end; + end; +end; + +function TBaseParser.IsForward(SubId: Integer): Boolean; +begin + result := TKernel(kernel).SymbolTable[SubId].IsForward; +end; + +procedure TBaseParser.SetForward(SubId: Integer; value: Boolean); +begin + TKernel(kernel).SymbolTable[SubId].IsForward := value; +end; + +function TBaseParser.ReplaceForwardDeclaration(var ID: Integer; IsExternalUnit: Boolean = false): Boolean; +var + I, J, ParamId: Integer; + Code: TCode; + SymbolTable: TSymbolTable; + ForwardID: Integer; + L, TypeParams: TIntegerList; + BestId: Integer; +label + ok; +begin + BestId := 0; + Code := TKernel(kernel).Code; + SymbolTable := TKernel(kernel).SymbolTable; + + ForwardId := SymbolTable.LookupForwardDeclaration(Id, Upcase, BestId); + + if ForwardId = Id then + begin + result := true; + Exit; + end; + + if ForwardId = 0 then + begin + if IsExternalUnit then + begin + result := true; + Exit; + end; + + if BestId > 0 then + begin + ForwardId := BestId; + + if SymbolTable[id].Count > 0 then + begin + CreateError(errDeclarationDiffersFromPreviousDeclaration, + [SymbolTable[Id].FullName]); + end; + + goto ok; + end; + + if SymbolTable[Id].Count > 0 then + begin + result := false; + Exit; + end; + + L := LookupForwardDeclarations(Id); + + if L = nil then + begin + I := SymbolTable[Id].Level; + if (I > 0) then if SymbolTable[I].Kind = kindTYPE then + begin + if SymbolTable.LookupAnotherDeclaration(Id, Upcase, BestId) = 0 then + begin + CreateError(errUndeclaredIdentifier, [SymbolTable[Id].FullName]); + end + else + begin + CreateError(errRedeclaredIdentifier, [SymbolTable[Id].FullName]); + end; + end; + + result := false; + Exit; + end + else if L.Count = 1 then + begin + // ok + ForwardId := L[0]; + FreeAndNil(L); + end + else + begin + FreeAndNil(L); + result := false; + Exit; + end; + + end; + + ok: + + if GetSymbolRec(Id).IsSharedMethod <> GetSymbolRec(ForwardId).IsSharedMethod then + CreateError(errDeclarationDiffersFromPreviousDeclaration, + [GetName(ForwardId)]); + + result := true; + + // remove forward definition from Code + +{ + I := 1; + repeat + if (Code[I].Op = OP_BEGIN_SUB) and (Code[I].Arg1 = ForwardId) then + begin + Code[I].Op := OP_NOP; + break; + end; + Inc(I); + if I = Code.Card then + RaiseError(errInternalError, []); + until false; +} +// + + I := BinSearch(BeginSubList.Keys, ForwardId); + if I = -1 then + RaiseError(errInternalError, []); + I := BeginSubList.Values[I]; + if (Code[I].Op <> OP_BEGIN_SUB) or (Code[I].Arg1 <> ForwardId) then + RaiseError(errInternalError, []); + Code[I].Op := OP_DECL_SUB; +// + + Code[I-1].Op := OP_NOP; //OP_GO + + Inc(I); // 15 july 2007 + repeat +// new + if Code[I].Op = OP_HIGH then + begin + // ok. 30 match 2009 + end + else if Code[I].Op = OP_LOW then + begin + // ok. 30 match 2009 + end + else if Code[I].Op = OP_SIZEOF then + begin + // ok. 30 match 2009 + end + else if Code[I].Op = OP_PRED then + begin + // ok. 30 match 2009 + end + else if Code[I].Op = OP_SUCC then + begin + // ok. 30 match 2009 + end + else if Code[I].Op = OP_ABS then + begin + // ok. 30 match 2009 + end + else if Code[I].Op = OP_ORD then + begin + // ok. 30 match 2009 + end + else if Code[I].Op = OP_CHR then + begin + // ok. 30 match 2009 + end + else if Code[I].Op = OP_EVAL then + begin + // ok. 2 october 2007 + end + else if Code[I].Op = OP_ASSIGN_CONST then + begin + // ok. 18 november 2007 + end + else if (Code[I].Op = OP_PUSH) or (Code[I].Op = OP_CALL) then + begin + // ok. 3 december 2007 + end + else if (Code[I].Op = OP_CHECK_OVERRIDE) then + begin + // ok. 23 July 2008 + end + else if (Code[I].Op = OP_CREATE_DYNAMIC_ARRAY_TYPE) then + begin + // ok. 6 October 2008 + end + else if Code[I].Op = OP_SEPARATOR then + begin + // ok. 3 August 2009 + end + else if Code[I].Op = OP_ADD_MESSAGE then + begin + // ok. 9 June 2010 + end + else if Code[I].Op = OP_FIELD then + begin + // ok. 18 november 2007 + end + else + if Code[I].Op = OP_ASSIGN_TYPE then + begin + if (Code[I].Arg1 = ForwardId) or + (SymbolTable[Code[I].Arg1].Level = ForwardId) then + begin + // ok + end + else + Code[I].Op := OP_NOP; + end + else +// new + Code[I].Op := OP_NOP; + Inc(I); + if I = Code.Card then + RaiseError(errInternalError, []); + until (Code[I].Op = OP_FIN_SUB) and (Code[I].Arg1 = ForwardId); + Code[I].Op := OP_NOP; + Code[I+1].Op := OP_NOP; //OP_LABEL + + // update OP_ASSIGN_TYPE instructions for parameters and result + { + I := 1; + repeat + if (Code[I].Op = OP_BEGIN_SUB) and (Code[I].Arg1 = Id) then + break; + Inc(I); + if I > Code.Card then // 15 july 2007 + RaiseError(errInternalError, []); + until false; + } +// + I := BinSearch(BeginSubList.Keys, Id); + if I = -1 then + RaiseError(errInternalError, []); + I := BeginSubList.Values[I]; + if I > Code.Card then + RaiseError(errInternalError, []); +// + + if I < Code.Card then // 15 july 2007 + repeat + Inc(I); + if Code[I].Op = OP_ASSIGN_TYPE then + begin + if SymbolTable[Code[I].Arg2].FinalTypeId = typeOPENARRAY then + continue; + + if SymbolTable[Code[I].Arg1].Level = Id then + begin + for J:=0 to SymbolTable[Id].Count - 1 do + begin + ParamId := SymbolTable.GetParamId(Id, J); + if ParamId = Code[I].Arg1 then + begin + ParamId := SymbolTable.GetParamId(ForwardId, J); + Code[I].Arg1 := ParamId; + break; + end; + end; + if Code[I].Arg1 = SymbolTable.GetResultId(Id) then + Code[I].Arg1 := SymbolTable.GetResultId(ForwardId); + end; + end; + if I >= Code.Card then + break; + until false; + + Code.ReplaceId(Id, ForwardId); + + TypeParams := SymbolTable.GetTypeParameters(Id); + for I := 0 to TypeParams.Count - 1 do + GetSymbolRec(TypeParams[I]).Level := ForwardId; + FreeAndNil(TypeParams); + + if FIND_DECL_IMPLEMENTATION_SECTION then + begin + if LanguageId = PASCAL_LANGUAGE then + if TKernel(kernel).FindDeclId = - 1 then + if SymbolTable[ForwardId].Count > 0 then + begin + for I := 0 to SymbolTable[ForwardId].Count - 1 do + begin + ParamId := SymbolTable.GetParamId(ForwardId, I); + J := SymbolTable.GetParamId(Id, I); + SymbolTable[ParamId].Position := SymbolTable[J].Position; + end; + end; + end + else + begin + if TKernel(kernel).FindDeclId = ForwardId then + TKernel(kernel).FindDeclId := Id; + end; + + SetKind(Id, KindNONE); + SetName(Id, ''); + + SetKind(SymbolTable.GetResultId(Id), KindNONE); + SetKind(SymbolTable.GetSelfId(Id), KindNONE); + + SetKind(ForwardId + 3, KindNONE); // label + SetKind(ForwardId + 4, KindNONE); // label + + for I:=ID to SymbolTable.Card do + if (SymbolTable[I].Level = Id) and (SymbolTable[I].Kind <> KindTYPE) then + begin + SetKind(I, KindNONE); +// SetName(I, ''); // 25 march 2011 / 6 April 2011 + end; + + SetForward(ForwardId, false); + + Id := ForwardId; + LevelStack.Pop; + LevelStack.Push(id); +end; + +constructor TParserList.Create(i_kernel: Pointer); +begin + inherited Create; + L := TPtrList.Create; + kernel := i_kernel; +end; + +destructor TParserList.Destroy; +begin + Clear; + FreeAndNil(L); + inherited; +end; + +function TParserList.GetParser(I: Integer): TBaseParser; +begin + result := TBaseParser(L[I]); +end; + +function TParserList.Count: Integer; +begin + result := L.Count; +end; + +procedure TParserList.Clear; +begin + L.Clear; +end; + +procedure TParserList.AddParser(P: TBaseParser); +begin + if FindParser(P.LanguageName) = nil then + L.Add(P); +end; + +function TParserList.FindParser(const LanguageName: String): TBaseParser; +var + I: Integer; +begin + for I:=0 to Count - 1 do + if StrEql(Items[I].LanguageName, LanguageName) then + begin + result := Items[I]; + Exit; + end; + result := nil; +end; + +function TParserList.FindParserByFileExtension(const FileExtension: String): TBaseParser; +var + I: Integer; +begin + if FindParser(TKernel(kernel).DefaultParser.LanguageName) = nil then + AddParser(TKernel(kernel).DefaultParser); + + for I:=0 to Count - 1 do + if StrEql(Items[I].GetFileExt, FileExtension) then + begin + result := Items[I]; + Exit; + end; + result := nil; +end; + +{$IFDEF VARIANTS} +{$WARN SYMBOL_DEPRECATED OFF} +{$ENDIF} +procedure TBaseParser.AddModuleFromFile(FileName: String; + UsedUnitId: Integer; + IsImplementationSection: Boolean; + ErrMessage: String = ''; + NoRaise: Boolean = false); +var + CodeLines: String; + UnitName, ALanguageName, Ext: String; + P, I: Integer; + Parser, UnitParser: TBaseParser; + Prog: TBaseRunner; + SourceAge, PCUAge: TDateTime; + PCUFileName: String; + M: TModule; + RootKernel: TKernel; + InputStream, OutputStream: TStream; + OutputStream_Position, Temp_Position, PosStream: Integer; + CompilePCU: Boolean; + RunnerClass: TBaseRunnerClass; +begin + RunnerClass := TKernel(kernel).GetRunnerClass; + + if TKernel(kernel).Modules.IndexOf(FileName) >= 0 then + Exit; + + RootKernel := TKernel(Kernel).RootKernel; + + CodeLines := ''; + + P := LastPosCh('.', FileName); + if P > 0 then + begin + UnitName := SCopy(FileName, SLow(FileName), P - SLow(FileName)); + Ext := SCopy(FileName, P + 1, 10); + Parser := TKernel(kernel).ParserList.FindParserByFileExtension(Ext); + if Parser = nil then + RaiseError(errUnregisteredLanguage, [FileName]); + + ALanguageName := Parser.LanguageName; + end + else + begin + ALanguageName := LanguageName; + UnitName := FileName; + Parser := Self; + end; + + PCUFileName := UnitName + '.' + PCU_FILE_EXT; + OutputStream := nil; + OutputStream_Position := 0; + InputStream := nil; + + I := RootKernel.Modules.IndexOf(UnitName); + if I >= 0 then + begin + if IsImplementationSection then + begin + if RootKernel.Modules[I].State <> msCompiling then + IsImplementationSection := false; + end + else + begin + if RootKernel.Modules[I].State = msCompiling then + IsImplementationSection := true + else if RootKernel.BuildedUnits.IndexOf(UpperCase(PCUFileName)) = -1 then + if RootKernel.Modules[I].State <> msNone then + if RootKernel.BuildAll then + RaiseError(errCircularUnitReference, [UnitName]); + end; + end; + + if Assigned(RootKernel.OnLoadPCU) then + begin + RootKernel.OnLoadPCU(RootKernel.Owner, UnitName, InputStream); + end; + + try // jason + +// if RootKernel.BuildAll then + + if RootKernel.BuildAll or + ((InputStream = nil) and + Assigned(RootKernel.OnSavePCU) and + (RootKernel.BuildedUnits.IndexOf(UpperCase(PCUFileName)) = - 1)) then + begin + if Assigned(RootKernel.OnSavePCU) and (InputStream = nil) then + if RootKernel.BuildedUnits.IndexOf(UpperCase(PCUFileName)) = - 1 then + if not IsImplementationSection then + begin + RootKernel.OnSavePCU(RootKernel.Owner, UnitName, OutputStream); + if OutputStream <> nil then + OutputStream_Position := OutputStream.Position; + end; + + if IsImplementationSection then + begin + RemoveInstruction(OP_EVAL, -1, -1, UsedUnitId); + + I := TKernel(Kernel).Modules.IndexOf(UnitName); + if I = -1 then + begin + if Assigned(RootKernel.OnUsedUnit) then + begin + RootKernel.CurrLanguage := ALanguageName; + if (RootKernel.OnUsedUnit(RootKernel, UnitName, CodeLines)) and + (CodeLines <> '') then + begin + ALanguageName := RootKernel.CurrLanguage; + M := TKernel(kernel).AddModule(UnitName, ALanguageName); + M.SkipParsing := true; + TKernel(kernel).AddCode(UnitName, CodeLines); + end + else + begin + M := TKernel(kernel).AddModule(UnitName, ALanguageName); + M.SkipParsing := true; + end; + end + else + begin + I := RootKernel.Modules.IndexOf(UnitName); + M := TKernel(kernel).AddModule(UnitName, ALanguageName); + M.SkipParsing := true; + if I = - 1 then + TKernel(kernel).AddCodeFromFile(UnitName, FileName) + else + TKernel(kernel).AddCode(UnitName, + RootKernel.Modules[I].Lines.Text); + end; + + UnitParser := CreateParser(FileName); + try + UnitParser.Init(kernel, M); + UnitParser.BRP := true; + UnitParser.Call_SCANNER; + UnitParser.Parse_Unit(true); + finally + FreeAndNil(UnitParser); + end; + end; + Exit; + end + else + begin + try // jason + if RootKernel.BuildedUnits.IndexOf(UpperCase(PCUFileName)) = - 1 then + if not CompileUnit(kernel, UnitName, FileName, PCUFileName, Parser, true, OutputStream) then + Exit; + finally // jason + if (OutputStream <> nil) and + Assigned(RootKernel.OnSavePCU) and + Assigned(RootKernel.OnSavePCUFinished) then // jason + begin // jason + RootKernel.OnSavePCUFinished(RootKernel.Owner, UnitName, OutputStream); // jason + end; // jason + end; // jason + end; + end; + + if not RootKernel.BuildAll then + if Assigned(RootKernel.OnUsedUnit) then + if TKernel(Kernel).Modules.IndexOf(UnitName) = -1 then + begin + RootKernel.CurrLanguage := LanguageName; + if RootKernel.OnUsedUnit(RootKernel.Owner, UnitName, CodeLines) then + begin + if CodeLines <> '' then + begin + TKernel(kernel).AddModule(UnitName, TKernel(kernel).CurrLanguage); + TKernel(kernel).AddCode(UnitName, CodeLines); + end; + Exit; + end; + end; + + if (InputStream = nil) or (OutputStream = nil) then + begin + if not FileExists(FileName) then + begin + if FileExists('System.' + FileName) then + begin + FileName := 'System.' + FileName; + UnitName := 'System.' + UnitName; + end; + end; + + if not FileExists(FileName) then + SourceAge := 0 + else + SourceAge := FileDateToDateTime(FileAge(FileName)); + + if not FileExists(PCUFileName) then + PCUAge := 0 + else + PCUAge := FileDateToDateTime(FileAge(PCUFileName)); + + CompilePCU := ((PCUAge > SourceAge) and FileExists(PCUFileName)) or + ((SourceAge = 0) and (PCUAge = 0)); + end + else + CompilePCU := true; + + if CompilePCU then + begin + FileName := PCUFileName; + + if TKernel(kernel).Modules.IndexOf(UnitName) = -1 then + begin + Prog := RunnerClass.Create; + try + PosStream := 0; + if InputStream <> nil then + begin + PosStream := InputStream.Position; + Prog.LoadFromStream(InputStream); + end + else if OutputStream <> nil then + begin + Temp_Position := OutputStream.Position; + OutputStream.Position := OutputStream_Position; + Prog.LoadFromStream(OutputStream); + OutputStream.Position := Temp_Position; + end + else + begin + + if not FileExists(FileName) then + begin + if NoRaise then + Exit; + +{$IFDEF DRTTI} + if Assigned(TKernel(kernel).prog) then + if TKernel(kernel).prog.HasAvailUnit(UnitName) then + TKernel(kernel).RegisterImportUnit(0, UnitName); + Exit; +{$ENDIF} + if ErrMessage = '' then + RaiseError(errFileNotFound, [FileName]) + else + RaiseError(errMessage, []); + end; + + Prog.LoadFromFile(FileName); + end; + + if not RootKernel.BuildWithRuntimePackages then + begin + if InputStream <> nil then + begin + InputStream.Position := PosStream; + RootKernel.PCUStreamList.AddFromStream(InputStream, FileName); + end + else + RootKernel.PCUStreamList.AddFromFile(FileName); + end; + + CodeLines := PCUToString(Prog, UnitName, FileName); + case Prog.PCULang of + PASCAL_LANGUAGE: TKernel(kernel).AddModule(UnitName, 'Pascal', true); + BASIC_LANGUAGE: TKernel(kernel).AddModule(UnitName, 'Basic', true); + else + TKernel(kernel).AddModule(UnitName, 'Pascal', true); + end; + TKernel(kernel).AddCode(UnitName, CodeLines); + finally + FreeAndNil(Prog); + end; + end; + + Exit; + end; + + if not + UnitLookup then + Exit; + + if SkipWhenNotFound then + begin + SkipWhenNotFound := false; + Exit; + end; + + if TKernel(kernel).Modules.IndexOf(UnitName) = -1 then + begin + if not FileExists(FileName) then + begin +{$IFDEF DRTTI} + TKernel(kernel).RegisterImportUnit(0, UnitName); + Exit; +{$ENDIF} + if ErrMessage = '' then + RaiseError(errFileNotFound, [FileName]) + else + raise Exception.Create(errMessage); + end; + + TKernel(kernel).AddModule(UnitName, ALanguageName); + TKernel(kernel).AddCodeFromFile(UnitName, FileName); + end; + + finally // jason + if Assigned(RootKernel.OnLoadPCU) and + Assigned(RootKernel.OnLoadPCUFinished) and + (InputStream <> nil) then // jason + RootKernel.OnLoadPCUFinished(RootKernel.Owner, UnitName, InputStream); // jason + end; // jason +end; + +function TBaseParser.GetValue(id: Integer): Variant; +begin + result := TKernel(kernel).SymbolTable[id].Value; +end; + +procedure TBaseParser.BeginInitialization; +begin + Gen(OP_STMT, 0, 0, 0); + Gen(OP_BEGIN_INITIALIZATION, CurrModule.ModuleNumber, 0, 0); +end; + +procedure TBaseParser.EndInitialization; +begin + Gen(OP_STMT, 0, 0, 0); + Gen(OP_END_INITIALIZATION, CurrModule.ModuleNumber, 0, 0); +end; + +procedure TBaseParser.BeginFinalization; +begin + Gen(OP_STMT, 0, 0, 0); + Gen(OP_BEGIN_FINALIZATION, CurrModule.ModuleNumber, 0, 0); +end; + +procedure TBaseParser.EndFinalization; +begin + Gen(OP_STMT, 0, 0, 0); + Gen(OP_END_FINALIZATION, CurrModule.ModuleNumber, 0, 0); +end; + +function TBaseParser.GetRaiseMode: Integer; +var + Code: TCode; + I: Integer; +begin + Code := TKernel(kernel).Code; + result := 0; + for I:=Code.Card downto 1 do + if Code[I].Op = OP_EXCEPT then + begin + result := 1; + Exit; + end + else if Code[I].Op = OP_FINALLY then + begin + result := 1; + Exit; + end + else if Code[I].Op = OP_TRY_ON then + break + else if Code[I].Op = OP_TRY_OFF then + break; +end; + +function TBaseParser.Lookup(const S: String; Level: Integer): Integer; +begin + result := TKernel(kernel).SymbolTable.LookUp(S, Level, UpCase, MaxInt, false); +end; + +function TBaseParser.Lookups(const S: String; Levels: TIntegerStack): Integer; +begin + result := TKernel(kernel).SymbolTable.LookUps(S, Levels, UpCase, MaxInt, false); + if result = 0 then + if ImportOnly then + result := Lookup(S, H_PascalNamespace); +end; + +procedure TBaseParser.SetVisibility(Id: Integer; vis: TClassVisibility); +begin + TKernel(kernel).SymbolTable[id].Vis := vis; +end; + +procedure TBaseParser.SetReadId(PropId, ReadId: Integer); +begin + TKernel(kernel).SymbolTable[PropId].ReadId := ReadId; +end; + +procedure TBaseParser.SetWriteId(PropId, WriteId: Integer); +begin + TKernel(kernel).SymbolTable[PropId].WriteId := WriteId; +end; + +procedure TBaseParser.SetDefault(Id: Integer; value: Boolean); +begin + TKernel(kernel).SymbolTable[Id].IsDefault := value; +end; + +procedure TBaseParser.RemoveInstruction(Op, Arg1, Arg2, Res: Integer); +begin + TKernel(kernel).Code.RemoveInstruction(Op, Arg1, Arg2, Res); +end; + +function TBaseParser.RemoveLastEvalInstruction(const S: String; Upcase: Boolean = true): Integer; +begin + result := TKernel(kernel).Code.RemoveLastEvalInstruction(S); +end; + +function TBaseParser.RemoveLastEvalInstructionAndName(const S: String; Upcase: Boolean = true): Boolean; +var + Id: Integer; +begin + dmp; + Id := TKernel(kernel).Code.RemoveLastEvalInstruction(S); + result := Id > 0; + if result then + RemoveLastIdent(Id); +end; + +procedure TBaseParser.RemoveLastIdent(Id: Integer); +var + R: TCodeRec; +begin + if Id = TKernel(kernel).SymbolTable.Card then + begin + R := LastEvalRec(Id); + if R <> nil then + begin + R.Op := OP_NOP; + R.GenOp := OP_NOP; + R.Res := 0; + end; + TKernel(kernel).SymbolTable.RemoveLastRecord; + end; +end; + +function TBaseParser.LastCodeRec(var I: Integer): TCodeRec; +var + Code: TCode; +begin + Code := TKernel(kernel).Code; + I := Code.Card; + while Code[I].Op = OP_SEPARATOR do + Dec(I); + result := Code[I]; +end; + +function TBaseParser.LastCodeRec: TCodeRec; +var + Code: TCode; + I: Integer; +begin + Code := TKernel(kernel).Code; + I := Code.Card; + while Code[I].Op = OP_SEPARATOR do + Dec(I); + result := Code[I]; +end; + +function TBaseParser.LastCodeRec2: TCodeRec; +var + Code: TCode; + I: Integer; +begin + Code := TKernel(kernel).Code; + I := Code.Card; + while Code[I].Op = OP_SEPARATOR do + Dec(I); + Dec(I); + while Code[I].Op = OP_SEPARATOR do + Dec(I); + result := Code[I]; +end; + +function TBaseParser.LastEvalRec(Id: Integer; var I: Integer): TCodeRec; +var + Code: TCode; +begin + Code := TKernel(kernel).Code; + + result := LastCodeRec(I); + if result.Op = OP_EVAL then + if result.Res = Id then + Exit; + I := Code.Card; + result := nil; + repeat + Dec(I); + if I <= 1 then + Exit; + if Code[I].Op = OP_BEGIN_MODULE then + Exit; + if Code[I].Op = OP_EVAL then + if Code[I].Res = Id then + begin + result := Code[I]; + Exit; + end; + until false; +end; + +function TBaseParser.LastEvalRec(Id: Integer): TCodeRec; +var + Code: TCode; + I: Integer; +begin + Code := TKernel(kernel).Code; + + result := LastCodeRec(I); + if result.Op = OP_EVAL then + if result.Res = Id then + Exit; + I := Code.Card; + result := nil; + repeat + Dec(I); + if I <= 1 then + Exit; + if Code[I].Op = OP_BEGIN_MODULE then + Exit; + if Code[I].Op = OP_EVAL then + if Code[I].Res = Id then + begin + result := Code[I]; + Exit; + end; + until false; +end; + +function TBaseParser.LookupForwardDeclarations(Id: Integer): TIntegerList; +begin + result := TKernel(kernel).SymbolTable.LookupForwardDeclarations(Id, Upcase); +end; + +procedure TBaseParser.Push_SCANNER; +begin + scanner.Push; +end; + +procedure TBaseParser.Pop_SCANNER; +begin + scanner.Pop; +end; + +function TBaseParser.FindConstructorId(ClassId: Integer): Integer; +begin + result := TKernel(kernel).SymbolTable.FindConstructorId(ClassId); +end; + +function TBaseParser.FindDestructorId(ClassId: Integer): Integer; +begin + result := TKernel(kernel).SymbolTable.FindDestructorId(ClassId); +end; + +function TBaseParser.IsStringConst(Id: Integer): Boolean; +var + Code: TCode; + I: Integer; +begin + result := (GetKind(Id) = KindCONST) and + ( +{$IFNDEF PAXARM} + TKernel(kernel).SymbolTable[Id].HasPAnsiCharType or +{$ENDIF} + TKernel(kernel).SymbolTable[Id].HasPWideCharType); + + if not result then + begin + Code := TKernel(kernel).Code; + for I:=1 to Code.Card do + if Code[I].Op = OP_ASSIGN_CONST then + if Code[I].Arg1 = Id then + begin + result := IsStringConst(Code[I].Arg2); + break; + end; + end; +end; + +procedure TBaseParser.SetHost(Id: Integer; value: Boolean); +begin + TKernel(kernel).SymbolTable[Id].Host := value; +end; + +function TBaseParser.GetHost(Id: Integer): Boolean; +begin + result := TKernel(kernel).SymbolTable[Id].Host; +end; + +procedure TBaseParser.SetAlignment(TypeId, Value: Integer); +begin + TKernel(kernel).SymbolTable[TypeId].DefaultAlignment := Value; +end; + +procedure TBaseParser.SetCompletionTarget(const S: String); +begin + TKernel(kernel).CompletionTarget := S; +end; + +function TBaseParser.GetStCard: Integer; +begin + result := TKernel(kernel).SymbolTable.Card; +end; + +function TBaseParser.GetCodeCard: Integer; +begin + result := TKernel(kernel).Code.Card; +end; + +procedure TBaseParser.SetOpenArray(ID: Integer; value: Boolean); +begin + TKernel(kernel).SymbolTable[ID].IsOpenArray := value; +end; + +procedure TBaseParser.DiscardLastSTRecord; +begin + if CurrToken.Id = StCard then + with TKernel(kernel).SymbolTable[TKernel(kernel).SymbolTable.Card] do + begin + Kind := kindNONE; + Name := ''; + end; +end; + +function TBaseParser.GetSymbolRec(Id: Integer): TSymbolRec; +begin + result := TKernel(kernel).SymbolTable[Id]; +end; + +procedure TBaseParser.InitScanner(const S: String); +begin + scanner.Init(kernel, S, -1); +end; + +function TBaseParser.GetTrueId: Integer; +begin + result := TKernel(kernel).SymbolTable.TrueId; +end; + +function TBaseParser.GetFalseId: Integer; +begin + result := TKernel(kernel).SymbolTable.FalseId; +end; + +function TBaseParser.GetCodeRec(I: Integer): TCodeRec; +begin + result := TKernel(kernel).Code[I]; +end; + +function TBaseParser.CurrNamespaceId: Integer; +begin + result := CurrLevel; + if result = 0 then + Exit; + while GetSymbolRec(result).Kind <> kindNAMESPACE do + begin + result := GetSymbolRec(result).Level; + if result = 0 then + break; + end; +end; + +function TBaseParser.CreateParser(const FileName: String): TBaseParser; +var + Parser: TBaseParser; + Ext: String; + P: Integer; + C: TBaseParserClass; +begin + Parser := nil; + P := LastPosCh('.', FileName); + if P > 0 then + begin + Ext := Copy(FileName, P + 1, 10); + Parser := TKernel(kernel).ParserList.FindParserByFileExtension(Ext); + end; + if Parser = nil then + RaiseError(errUnregisteredLanguage, [FileName]); + C := TBaseParserClass(Parser.ClassType); + result := C.Create; +end; + +procedure TBaseParser.Parse_Unit(IsExternalUnit: Boolean = false); +begin +end; + +function TBaseParser.BuildingAll: Boolean; +begin + result := TKernel(kernel).RootKernel.BuildAll; +end; + +procedure TBaseParser.SetExternal(Id: Integer; value: Boolean); +begin + GetSymbolRec(Id).IsExternal := value; +end; + +procedure TBaseParser.SetTempName(Id: Integer); +begin + SetName(Id, '_temp_' + IntToStr(id)); +end; + +function TBaseParser.ScanRegExpLiteral: String; +begin + result := scanner.ScanRegExpLiteral; +end; + +function TBaseParser.LA(I: Integer): Char; +begin + result := scanner.LA(I); +end; + +function TBaseParser.Parse_QualId: Integer; +var + id: Integer; +begin + result := Parse_Ident; + + while IsCurrText('.') do + begin + FIELD_OWNER_ID := result; + id := FIELD_OWNER_ID; + + Match('.'); + if CurrToken.TokenClass = tcBooleanConst then + result := Parse_BooleanLiteral + else if CurrToken.TokenClass = tcPCharConst then + result := Parse_PCharLiteral + else if CurrToken.TokenClass = tcIntegerConst then + result := Parse_IntegerLiteral + else if CurrToken.TokenClass = tcDoubleConst then + result := Parse_DoubleLiteral + else + result := Parse_Ident; + Gen(OP_FIELD, id, result, result); + end; +end; + +function TBaseParser.Parse_UnitName(var S: String): Integer; +var + Id, FieldId, J: Integer; + Q: TStringList; + S1: String; +begin + if DECLARE_SWITCH then + begin + result := Parse_Ident; + S := GetName(result); + if not StrEql('System', S) then + BeginNamespace(result); + while IsCurrText('.') do + begin + Match('.'); + result := Parse_Ident; + BeginNamespace(result); + S := S + '.' + GetName(result); + end; + + Exit; + end; + + S := CurrToken.Text; + ReadToken; + while IsCurrText('.') do + begin + ReadToken; + S := S + '.' + CurrToken.Text; + ReadToken; + end; + + TKernel(kernel).EvalList.Add(S); + + try + + result := Lookup(S, 0); + if result > 0 then + Exit; + + if LastCodeRec.Op = OP_EVAL then + LastCodeRec.Op := OP_NOP; + + S1 := S; + if not ImportOnly then + S := ExpandUnitName(S1); + if S <> S1 then + TKernel(kernel).EvalList.Add(S); + + if Assigned(TKernel(kernel).OnUnitAlias) then + TKernel(kernel).OnUnitAlias(TKernel(kernel).Owner, S); + + Q := ExtractNames(S); + + try + if StrEql(Q[0], 'System') then + begin + Q.Delete(0); + if Q.Count = 0 then + RaiseError(errUndeclaredIdentifier, ['System']); + end; + + Id := 0; + for J := 0 to Q.Count - 1 do + begin + Id := Lookup(Q[J], Id); + if Id = 0 then + break; + end; + if Id > 0 then + begin + result := Id; + Exit; + end; + + Id := NewVar(Q[0]); + SetKind(Id, KindNONE); + Gen(OP_EVAL, 0, 0, Id); + + for J := 1 to Q.Count - 1 do + begin + FieldId := NewField(Q[J], Id); + Gen(OP_FIELD, Id, FieldId, FieldId); + Id := FieldId; + end; + + finally + FreeAndNil(Q); + end; + + result := Id; + + finally + if UsedUnitList.IndexOf(Uppercase(S)) >= 0 then + CreateError(errRedeclaredIdentifier, [S]); + UsedUnitList.Add(Uppercase(S)); + end; +end; + +function TBaseParser.ExpandUnitName(const S: String): String; +var + I: Integer; + Q: String; +begin + result := S; + + if AvailUnitList1.Count = 0 then + Exit; + + I := AvailUnitList.IndexOf(S); + if I >= 0 then + Exit; + + for I := 0 to AvailUnitList1.Count - 1 do + begin + Q := AvailUnitList1[I] + '.' + S; + if AvailUnitList.IndexOf(Q) >= 0 then + begin + result := Q; + Exit; + end; + end; +end; + +function TBaseParser.ExpandTypeName(const S: String): String; +var + I: Integer; + Q: String; +begin + result := S; + + if AvailTypeList.Count = 0 then + Exit; + + I := AvailTypeList.IndexOf(S); + if I >= 0 then + Exit; + + Q := 'System.' + S; + I := AvailTypeList.IndexOf(Q); + if I >= 0 then + begin + result := Q; + Exit; + end; + + for I := 0 to UsedUnitList.Count - 1 do + begin + Q := UsedUnitList[I] + '.' + S; + if AvailTypeList.IndexOf(Q) >= 0 then + begin + result := Q; + Exit; + end; + Q := 'System.' + Q; + if AvailTypeList.IndexOf(Q) >= 0 then + begin + result := Q; + Exit; + end; + end; +end; + +procedure TBaseParser.CheckRedeclaredSub(SubId: Integer); + +function GetSignature(Id: Integer): String; +var + I, J, T, ParamId: Integer; + S: String; + SymbolTable: TSymbolTable; + Code: TCode; +begin + SymbolTable := TKernel(kernel).SymbolTable; + Code := TKernel(kernel).Code; + + result := ''; + for I:=0 to GetCount(Id) - 1 do + begin + ParamId := SymbolTable.GetParamId(Id, I); + S := ''; + + T := GetSymbolRec(ParamId).TypeID; + if GetSymbolRec(ParamId).TypeID > 0 then + begin + S := GetSymbolRec(T).Name; + end + else + for J := 1 to Code.Card do + if Code[J].Op = OP_ASSIGN_TYPE then + if Code[J].Arg1 = ParamId then + begin + S := GetSymbolRec(Code[J].Arg2).Name; + break; + end; + + result := result + ' ' + S; + end; + +end; + +var + I, Level, Kind: Integer; + S: String; + L: TIntegerList; + ok: Boolean; + Signature: String; +begin + if ImportOnly then + Exit; + + S := GetSymbolRec(SubId).Name; + Level := GetSymbolRec(SubId).Level; + Kind := GetSymbolRec(SubId).Kind; + L := TKernel(kernel).SymbolTable.LookupAll(S, Level, Upcase); + + try + if L.Count <= 1 then + Exit; + + Signature := GetSignature(SubId); + + for I := 0 to L.Count - 1 do + begin + if L[I] = SubId then + continue; + + S := GetSignature(L[I]); + + if UpCase then + ok := StrEql(S, Signature) + else + ok := S = Signature; + + if ok then + begin + if Kind in [kindCONSTRUCTOR, KindDESTRUCTOR] then + if GetKind(L[I]) = Kind then + if GetSymbolRec(L[I]).IsSharedMethod <> GetSymbolRec(SubId).IsSharedMethod then + continue; + + CreateError(errRedeclaredIdentifier, [GetSymbolRec(SubId).Name]); + break; + end; + end; + finally + FreeAndNil(L); + end; +end; + +function TBaseParser.CountAtLevel(const S: String; Level: Integer): Integer; +var + L: TIntegerList; +begin + L := TKernel(kernel).SymbolTable.LookupAll(S, Level, Upcase); + try + result := L.Count; + finally + FreeAndNil(L); + end; +end; + +function TBaseParser.CountAtLevel(const S: String; Level, Kind: Integer; IsSharedMethod: Boolean): Integer; +var + L: TIntegerList; + I: Integer; +begin + L := TKernel(kernel).SymbolTable.LookupAll(S, Level, Upcase); + try + if Kind in [KindCONSTRUCTOR, KindDESTRUCTOR] then + begin + result := 0; + for I := 0 to L.Count - 1 do + if GetSymbolRec(L[I]).IsSharedMethod = IsSharedMethod then + Inc(result); + end + else + result := L.Count; + finally + FreeAndNil(L); + end; +end; + +procedure TBaseParser.SetDeprecated(SubId: Integer; value: Boolean); +begin + TKernel(kernel).SymbolTable[SubId].IsDeprecated := value; +end; + +function TBaseParser.HasBeenDeclared(Id: Integer): Boolean; +var + I: Integer; + R: TCodeRec; +begin + result := false; + I := TKernel(kernel).Code.N; + repeat + Dec(I); + if I = 0 then + Exit; + R := TKernel(kernel).Code[I]; + if R.Op = OP_BEGIN_MODULE then + Exit; + if R.Op = OP_DECLARE_LOCAL_VAR then + if R.Arg2 = Id then + begin + result := true; + Exit; + end; + until false; +end; + +function TBaseParser.HasModule(const ModuleName: String): Boolean; +begin + result := TKernel(kernel).Modules.IndexOf(ModuleName) >= 0; +end; + +procedure TBaseParser.GenHtml; +var + Id: Integer; + S: String; +begin + S := CurrToken.Text; + S := RemoveLeftChars(WhiteSpaces, S); + Id := NewConst(typeSTRING, S); + Gen(OP_PRINT_EX, Id, 0, 0); +end; + +procedure TBaseParser.GenCondRaise; +var + cond_id: Integer; +begin + Gen(OP_COND_RAISE, 0, 0, 0); + cond_id := LastCodeRec.Res; + + if BreakStack.Count > 0 then + LastCodeRec.BreakLabel := BreakStack.TopLabel; + if ContinueStack.Count > 0 then + LastCodeRec.ContinueLabel := ContinueStack.TopLabel; + + Gen(OP_GO_TRUE, SkipLabelStack.Top, cond_id, 0); +end; + +function TBaseParser.GetUsedUnitList: TStringList; +begin + result := TKernel(kernel).UsedUnitList; +end; + +function TBaseParser.GetInterfaceOnly: Boolean; +begin + result := TKernel(kernel).InterfaceOnly; +end; + +function TBaseParser.GetImportOnly: Boolean; +begin + result := TKernel(kernel).ImportOnly; +end; + +function TBaseParser.ConvString(const S: String): String; +begin + result := S; +end; + +procedure TBaseParser.BeginInitConst(Id: Integer); +begin + if GetKind(Id) = KindCONST then + SetTypedConst(ID); + Gen(OP_BEGIN_INIT_CONST, ID, 0, 0); + if GetSymbolRec(ID).Name = '' then + GetSymbolRec(ID).Name := '@'; +end; + +procedure TBaseParser.EndInitConst(Id: Integer); +var + I: Integer; +begin + Gen(OP_END_INIT_CONST, ID, 0, 0); + if GetSymbolRec(ID).Name <> '' then + begin + for I := Id + 1 to TKernel(kernel).SymbolTable.Card do + GetSymbolRec(I).NoRelocate := true; + end; +end; + +function TBaseParser.FindPrevEvaluation(const S: String): Integer; +var + L, I, Op, Id: Integer; + SymbolTable: TSymbolTable; + Code: TCode; + R: TCodeRec; + b: Boolean; +begin + result := 0; + L := CurrLevel; + SymbolTable := TKernel(kernel).SymbolTable; + Code := TKernel(kernel).Code; + I := Code.Card; + repeat + Dec(I); + if I < 1 then + break; + R := Code[I]; + Op := R.Op; + + if Op = OP_BEGIN_WITH then + break; + if Op = OP_BEGIN_MODULE then + break; + if Op = OP_BEGIN_SUB then + break; + if Op <> OP_EVAL then + continue; + + Id := R.Res; + if SymbolTable[Id].Level <> L then + break; + + if Upcase then + b := StrEql(SymbolTable[Id].Name, S) + else + b := SymbolTable[I].Name = S; + + if b then + begin + result := R.Res; + break; + end; + until false; + + if result = 0 then + Exit; + + repeat + Inc(I); + if I > Code.Card then + begin + Exit; + end; + if Code[I].Op = OP_STMT then + begin + result := 0; + Exit; + end; + if Code[I].Op = OP_CALL then + if Code[I].Arg1 = result then + begin + Exit; + end; + until false; +end; + +procedure TBaseParser.GenNOPS(K: Integer); +var + I: Integer; +begin + for I := 0 to K - 1 do + Gen(OP_NOP, 0, 0, 0); +end; + +procedure TBaseParser.GenAssignOuterInstance(Id, ClassId: Integer); +var + RefId, OuterInstanceId: Integer; +begin + OuterInstanceId := NewTempVar; + Gen(OP_EVAL_OUTER, ClassId, 0, OuterInstanceId); + + RefId := NewField(StrOuterThis, Id); + Gen(OP_FIELD, Id, RefId, RefId); + Gen(OP_ASSIGN, RefId, OuterInstanceId, RefId); +end; + +procedure TBaseParser.BeginCollectSig(SubId: Integer); +begin + CollectSig := true; + Sig := ''; +end; + +procedure TBaseParser.EndCollectSig(SubId: Integer); +begin + CollectSig := false; + Sig := RemoveChars(WhiteSpaces, Sig); + GetSymbolRec(SubId).Sig := Sig; +end; + +function TBaseParser.LookupInUsingList(const S: String): Integer; +var + I, Id, temp: Integer; +begin + result := 0; + for I := UsingList.Count - 1 downto 0 do + begin + Id := UsingList[I]; + if Id = 0 then + break; + if GetSymbolRec(Id).Kind = KindNAMESPACE then + begin + temp := Lookup(S, Id); + if temp > 0 then + begin + result := temp; + Exit; + end; + end + else + continue; + end; +end; + +function TBaseParser.LookupInWithStack(const S: String; + var PatternId: Integer; + var StackIsOK: Boolean): Integer; +var + I, Id, TypeId, temp: Integer; +begin + result := 0; + StackIsOK := true; + for I := WithStack.Count - 1 downto 0 do + begin + Id := WithStack[I]; + + TypeId := GetSymbolRec(Id).TypeId; + if TypeId = 0 then + begin + StackIsOK := false; + break; + end; + if GetSymbolRec(TypeId).Kind = KindTYPE then + begin + temp := TKernel(kernel).SymbolTable. + Lookup(S, TypeId, UpCase, MaxInt, false); + if temp > 0 then + begin + result := Id; + PatternId := temp; + Exit; + end; + end + else + begin + StackIsOK := false; + break; + end; + end; +end; + +function TBaseParser.GetOpenArrayHighId(Id: Integer): Integer; +begin + result := TKernel(kernel).SymbolTable.GetOpenArrayHighId(Id); +end; + +function TBaseParser.Parse_TypeParams: String; + + function Parse_Internal(KK: Integer): String; + var + OldPosition: Integer; + S, TypeName: String; + R: TTypeExpRec; + I, J, Id, FieldId: Integer; + ParamList: TStringList; + TR: TTypeRestrictionRec; + LocalTypeParams: TTypeParams; + Q: TStringList; + label + Next; + begin + LocalTypeParams := TTypeParams.Create; + try + TypeName := CurrToken.Text; + + OldPosition := CurrToken.Position; + + result := '<'; + + ReadToken; + ReadToken; // "<" + repeat + S := CurrToken.Text; + + while IsNextText('.') do + begin + ReadToken; + ReadToken; + S := S + '.' + CurrToken.Text; + end; + + if IsNextText('<') then + S := S + Parse_Internal(KK + 1); + + S := ExpandTypeName(S); + + LocalTypeParams.Add(S); + + if AvailTypeList.Count = 0 then + result := result + CurrToken.Text + else + result := result + S; + + ReadToken; + + Next: + if IsCurrText(',') then + begin + ReadToken; + result := result + ','; + end + else if IsCurrText(';') then + begin + ReadToken; + result := result + ','; + end + else + begin + if IsCurrText('>') then + break; + + if DECLARE_SWITCH then + begin + Parse_TypeRestriction(LocalTypeParams); + goto Next; + end; + + end; + until false; + result := result + '>'; + CurrToken.TokenClass := tcIdentifier; + CurrToken.Length := CurrToken.Position - OldPosition + 1; + CurrToken.Position := OldPosition; + + result := RemoveChars(WhiteSpaces, result); + + if (not DECLARE_SWITCH) and (not CurrModule.IsExtra) then + begin + if TKernel(kernel).TypeDefList.IndexOf(TypeName, LocalTypeParams, Upcase) >= 0 then + Exit; + + if TKernel(kernel).TypeDefList.TypeExpList.IndexOf(TypeName, LocalTypeParams, Upcase) >= 0 then + Exit; + + R := TKernel(kernel).TypeDefList.TypeExpList.Add; + R.Name := TypeName; + + for I := 0 to LocalTypeParams.Count - 1 do + begin + ParamList := TKernel(kernel).TypeDefList.TypeExpList.Top.ParamList; + + S := LocalTypeParams[I]; + if PosCh('.', S) > 0 then + begin + Q := ExtractNames(S); + + if AvailTypeList.Count = 0 then + LocalTypeParams[I] := Q[Q.Count - 1]; + + Id := NewVar(Q[0]); + SetKind(Id, KindNONE); + Gen(OP_EVAL, 0, 0, Id); + + for J := 1 to Q.Count - 1 do + begin + FieldId := NewField(Q[J], Id); + Gen(OP_FIELD, Id, FieldId, FieldId); + Id := FieldId; + end; + + if AvailTypeList.Count = 0 then + S := LocalTypeParams[I]; + + TR := TTypeRestrictionRec.Create; + TR.Id := Id; + TR.N := TKernel(kernel).Code.Card; + + ParamList.AddObject(S, TR); + + Q.Free; + end + else + begin + Id := AltTypeId(S); + + if Id = 0 then + begin + Id := NewVar(S); + SetKind(Id, KindNONE); + Gen(OP_EVAL, 0, 0, Id); + end; + + TR := TTypeRestrictionRec.Create; + TR.Id := Id; + TR.N := TKernel(kernel).Code.Card; + + ParamList.AddObject(S, TR); + end; + end; + end; + finally + if KK = 0 then + begin + LocalTypeParams.AssTo(TypeParams); + TypeParamsHistory.Add(TypeParams); + end; + + FreeAndNil(LocalTypeParams); + end; + end; + +begin + TypeParams.Clear; + result := Parse_Internal(0); +end; + +procedure TBaseParser.AddTypeParameters(LevelId: Integer; + E: TTypeExtRec = nil); +var + I, Id: Integer; + S: String; + ParamList: TStringList; + TR: TTypeRestrictionRec; +begin + if TypeParams.Count = 0 then + Exit; + + try +// if CurrModule.IsExtra then +// Exit; + + for I := 0 to TypeParams.Count - 1 do + begin + if CurrModule.IsExtra then + if E = nil then + continue; + + if EXTRA_SWITCH then + continue; + + S := TypeParams[I]; + TR := TTypeRestrictionRec(TypeParams.Objects[I]); + + if TR <> nil then + begin + Id := NewTempVar(typeALIAS); + GetSymbolRec(Id).PatternId := TR.Id; + end + else + begin + Id := NewTempVar(typeTYPEPARAM); + end; + + SetKind(Id, KindTYPE); + SetName(Id, S); + SetLevel(Id, LevelId); + + if CurrModule.IsExtra then + continue; + + if E <> nil then + ParamList := E.ParamList + else + ParamList := TKernel(kernel).TypeDefList.Top.ParamList; + + if TR = nil then + ParamList.Add(S) + else + ParamList.AddObject(S, TR.Clone); + end; + + if CurrModule.IsExtra then + Exit; + + for I := 0 to TKernel(kernel).UsedUnitList.Count - 1 do + begin + S := TKernel(kernel).UsedUnitList[I]; + if TKernel(kernel).TypeDefList.CurrTypeModuleRec.UsingList.IndexOf(S) = -1 then + TKernel(kernel).TypeDefList.CurrTypeModuleRec.UsingList.Add(S); + end; + + finally + TypeParams.Clear; + EXTRA_SWITCH := false; + end; +end; + +procedure TBaseParser.BeginTypeDef(TypeId: Integer); +var + S: String; + P: Integer; + R: TTypeDefRec; +begin +// if CurrModule.IsExtra then +// Exit; + + S := GetName(TypeId); + + P := PosCh('<', S); + if P > 0 then + S := SCopy(S, SLow(S), P - SLow(S)); + + R := TKernel(kernel).TypeDefList.Add(CurrModule.Name, LanguageId); + R.IsGeneric := IsGeneric(TypeId); + R.IsExtra := CurrModule.IsExtra; + R.TypeId := TypeId; + R.LangId := LanguageId; + R.P1 := Scanner.Position - CurrToken.Length; + R.Name := S; +end; + +procedure TBaseParser.EndTypeDef(TypeId: Integer); +var + S: String; + R: TTypeDefRec; +begin + TypeParams.Clear; + +// if CurrModule.IsExtra then +// Exit; +// if not IsGeneric(TypeId) then +// Exit; + + R := TKernel(kernel).TypeDefList.FindTypeDef(TypeID); + with R do + begin + P2 := Scanner.Position; + S := SCopy(Scanner.Buff, P1, P2 - P1 + CurrToken.Length); + Definition := S; + end; +end; + +procedure TBaseParser.BeginTypeExt(TypeId: Integer); +var + R: TTypeDefRec; + E: TTypeExtRec; +begin + TypeParams.Clear; + +// if CurrModule.IsExtra then +// Exit; + + R := TKernel(kernel).TypeDefList.FindTypeDef(TypeID); + if R <> nil then + begin + E := R.TypeExtList.Add; + E.P1 := CurrToken.Position; + E.IsExtra := CurrModule.IsExtra; + end; +end; + +procedure TBaseParser.InitTypeExt(TypeId: Integer; + const MemberName: String; + IsMethodImpl: Boolean); +var + R: TTypeDefRec; + E: TTypeExtRec; + P: Integer; +begin +// if CurrModule.IsExtra then +// Exit; + + if IsMethodImpl then + R := TKernel(kernel).TypeDefList.Top + else + R := TKernel(kernel).TypeDefList.FindTypeDef(TypeID); + + if R <> nil then + begin + if R.TypeExtList.Count = 0 then + Exit; + + E := R.TypeExtList.Top; + P := PosCh('<', MemberName); + if P > 0 then + begin + E.Valid := true; + E.Name := SCopy(MemberName, SLow(MemberName), P - SLow(MemberName)); + AddTypeParameters(TypeId, E); + + if IsMethodImpl then + begin + if IsGeneric(TypeId) then + TypeParamsHistory[TypeParamsHistory.Count - 2].AssTo(TypeParams) + else + begin + RemoveType(TypeId); + end; + end; + end + else + E.Name := MemberName; + end; +end; + +procedure TBaseParser.EndTypeExt(TypeId: Integer); +var + S: String; + R: TTypeDefRec; + E: TTypeExtRec; +begin + TypeParams.Clear; + +// if CurrModule.IsExtra then +// Exit; + + R := TKernel(kernel).TypeDefList.FindTypeDef(TypeID); + if R <> nil then + begin + E := R.TypeExtList.Top; + + if not E.Valid then + begin + R.TypeExtList.RemoveTop; + Exit; + end; + + E.P2 := CurrToken.Position; + S := SCopy(Scanner.Buff, E.P1, E.P2 - E.P1 + CurrToken.Length); + E.Extension := S; + + R.IsGeneric := true; + + if not IsGeneric(TypeId) then + RemoveType(TypeId); + end; +end; + +procedure TBaseParser.BeginMethodDef; +var + E: TTypeExtRec; + R: TTypeDefRec; +begin +// if CurrModule.IsExtra then +// Exit; + R := TKernel(kernel).TypeDefList.Add(CurrModule.Name, LanguageId); + + with R do + begin + IsExtra := CurrModule.IsExtra; + LangId := LanguageId; + P1 := Scanner.Position - CurrToken.Length; + + E := TypeExtList.Add; + E.P1 := P1; + E.IsExtra := CurrModule.IsExtra; + end; +end; + +procedure TBaseParser.InitMethodDef(SubId: Integer); +var + TypeId: Integer; + R: TTypeDefRec; +begin +// if CurrModule.IsExtra then +// Exit; + + TypeId := GetLevel(SubId); + if TypeId = 0 then + Exit; + if GetKind(TypeId) <> KindTYPE then + Exit; +// if not IsGeneric(TypeId) then +// begin +// Exit; +// end; + + R := TKernel(kernel).TypeDefList.Top; + R.SubId := SubId; + R.IsGeneric := IsGeneric(TypeId); + R.TypeId := TypeId; +end; + +procedure TBaseParser.EndMethodDef(SubId: Integer); +var + S: String; + P, TypeId: Integer; + R: TTypeDefRec; + E: TTypeExtRec; +begin + TypeParams.Clear; + + TypeId := GetLevel(SubId); + +// if CurrModule.IsExtra then +// Exit; + if TypeId = 0 then + Exit; + if GetKind(TypeId) <> KindTYPE then + Exit; + + S := GetName(TypeId); + P := PosCh('<', S); + if P > 0 then + S := SCopy(S, SLow(S), P - SLow(S)); + + R := TKernel(kernel).TypeDefList.FindMethodDef(SubId); + with R do + begin + IsGeneric := P > 0; + Name := S; + P2 := Scanner.Position; + S := SCopy(Scanner.Buff, P1, P2 - P1 + CurrToken.Length); + Definition := S; + IsMethodImplementation := true; + end; + + E := R.TypeExtList.Top; + + if not E.Valid then + begin + R.TypeExtList.RemoveTop; + Exit; + end; + + E.P2 := R.P2; + E.Extension := R.Definition; + + R.IsGeneric := true; +end; + +procedure TBaseParser.SaveExtraNamespace(Id: Integer); +begin + TKernel(kernel).Code.Extra_using_list.Add(Id); +end; + +function TBaseParser.ParametrizedTypeExpected: Boolean; +begin + if not GENERICS_ALLOWED then + result := false + else + result := Scanner.ParametrizedTypeExpected; +end; + +function TBaseParser.ReadType: Integer; +var + S: String; +begin + ReadToken; + S := CurrToken.Text; + if ParametrizedTypeExpected then + S := S + Parse_TypeParams; + result := Lookup(S, CurrLevel); +end; + +function TBaseParser.IsGeneric(TypeId: Integer): Boolean; +begin + result := PosCh('<', GetName(TypeId)) > 0; +end; + +procedure TBaseParser.Parse_TypeRestriction(LocalTypeParams: TStringObjectList); +begin +end; + +function TBaseParser.AltTypeId(const S: String): Integer; +begin + result := 0; +end; + +procedure TBaseParser.RemoveType(TypeId: Integer); +begin + if CurrModule.IsExtra then + Exit; + + if TKernel(kernel).TypeDefList.RemTypeIds.IndexOf(TypeId) = -1 then + TKernel(kernel).TypeDefList.RemTypeIds.Add(TypeId); +end; + +procedure TBaseParser.GenPause; +var + b: Boolean; + I, Op, L: Integer; + Code: TCode; +begin + Code := TKernel(kernel).Code; + if (not DECLARE_SWITCH) and (EXECUTABLE_SWITCH > 0) then + begin + b := false; + for I:=Code.Card downto 1 do + begin + Op := Code[I].Op; + if Op = OP_SET_CODE_LINE then + break + else if Op = OP_CALL then + break + else if Op = OP_PUSH then + begin + b := true; + break; + end; + end; + + Gen(OP_SET_CODE_LINE, 0, 0, 0); + if DEBUG_MODE then if not b then + begin + L := NewLabel; + Gen(OP_CHECK_PAUSE, L, 0, 0); + SetLabelHere(L); + end; + end; +end; + +function TBaseParser.IsTryContext(R: TEntryRec): Boolean; +var + Op, I, K, CodeN: Integer; + Code: TCode; +begin + result := false; + if try_stack.Count = 0 then + Exit; + CodeN := R.CodeN; + Code := TKernel(kernel).Code; + I := Code.Card + 1; + K := 0; + repeat + Dec(I); + if I = CodeN then + break; + Op := Code[I].Op; + if Op = OP_TRY_ON then + Inc(K) + else if Op = OP_TRY_OFF then + Dec(K); + until false; + result := K > 0; +end; + +function TBaseParser.GetIsUNIC: Boolean; +begin + result := TKernel(kernel).IsUNIC; +end; + +procedure TBaseParser.NewAnonymousNames(var ClsName: String; + var ObjName: String); +begin + Inc(TKernel(kernel).AnonymousClassCount); + ClsName := ANONYMOUS_CLASS_PREFIX + + IntToStr(TKernel(kernel).AnonymousClassCount); + ObjName := ANONYMOUS_OBJECT_PREFIX + + IntToStr(TKernel(kernel).AnonymousClassCount); +end; + +function TBaseParser.IsOuterLocalVar(Id: Integer): Boolean; +var + I, L: Integer; +begin + result := false; + if GetKind(Id) <> KindVAR then + Exit; + if AnonymStack.Count = 0 then + Exit; + L := GetLevel(Id); + if L = AnonymStack.Top.SubId then + Exit; + if L = CurrLevel then + Exit; + + for I := 0 to LevelStack.Count - 2 do + begin + if LevelStack[I] > 0 then + if GetKind(LevelStack[I]) in KindSUBS then + if L = LevelStack[I] then + begin + result := true; + Exit; + end; + end; +end; + +procedure TBaseParser.GenComment(const S: String); +begin +{$IFDEF PAXARM} + Gen(OP_ADD_COMMENT, + TKernel(kernel).SymbolTable.AddPWideCharConst('//- ' + S).Id, 0, 0); +{$ELSE} + Gen(OP_ADD_COMMENT, + TKernel(kernel).SymbolTable.AddPAnsiCharConst('//- ' + AnsiString(S)).Id, 0, 0); +{$ENDIF} +end; + +procedure TBaseParser.RelocateCode(K1, K2: Integer); +var + I: Integer; + Code: TCode; + R: TCodeRec; +begin + Code := TKernel(kernel).Code; + + for I := K1 to K2 do + begin + R := Code[I]; + Code.Add(R.Op, R.Arg1, R.Arg2, R.Res, R.SavedLevel, R.Upcase, + R.Language, CurrModule.ModuleNumber, + R.LinePos); + R.Op := OP_NOP; + R.GenOp := OP_NOP; + end; +end; + +procedure TBaseParser.RelocateCode(Ip, K1, K2: Integer); +var + I: Integer; + Code: TCode; + R: TCodeRec; + L: TCodeRecList; +begin + Code := TKernel(kernel).Code; + + L := TCodeRecList.Create; + for I := K1 to K2 do + begin + R := Code[I]; + L.Add(R); + end; + for I := K1 to K2 do + Code.A.Delete(Code.A.Count - 1); + + while Ip > Code.A.Count do + Dec(Ip); + + for I := 0 to L.Count - 1 do + begin + R := L[I]; + Code.A.Insert(Ip, R); + Inc(Ip); + end; + + FreeAndNil(L); +end; + +procedure TBaseParser.RaiseNotImpl; +begin + RaiseError(errNotImplementedYet, []); +end; + +procedure TBaseParser.HideKeyword(KeywordIndex: Integer); +begin + hidden_keywords.Add(KeywordIndex); +end; + +procedure TBaseParser.RestoreKeywords; +begin + hidden_keywords.Clear; +end; + +function TBaseParser.ExtractText(P1, P2: Integer): String; +begin + result := SCopy(scanner.Buff, P1, P2 - P1 + 1); +end; + +procedure TBaseParser.SetPrevToken; +begin + if CurrToken = nil then + begin + PrevPosition := SLow(scanner.Buff); + PrevLength := 0; + end + else + begin + PrevPosition := CurrToken.Position; + PrevLength := CurrToken.Length; + end; +end; + +function TBaseParser.CreatePointerType(type_id, pcount: Integer): Integer; +var + S: String; + T: Integer; +begin + result := type_id; + S := GetName(result); + while pcount > 0 do + begin + T := GetPointerType(result); + if T > 0 then + result := T + else + begin + S := S + '*'; + result := TKernel(kernel).SymbolTable.RegisterPointerType(0, + S, result); + SetHost(result, false); + GetSymbolRec(result).Completed := false; + end; + Dec(pcount); + end; +end; + +function TBaseParser.CreateProceduralType(SubId: Integer): Integer; +var + S: String; +begin + S := GetName(SubId) + '&'; + result := TKernel(kernel).SymbolTable.RegisterProceduralType(0, + S, - SubId); + GetSymbolRec(result).Completed := false; + SetHost(result, false); +end; + +function TBaseParser.CreateSubrangeType(B1, B2: Integer): Integer; +begin + result := TKernel(kernel).SymbolTable.RegisterSubrangeType(0, '', typeINTEGER, + B1, B2); + GetSymbolRec(result).Completed := false; + SetHost(result, false); + SetName(result, 'SubType_' + IntToStr(result)); +end; + +function TBaseParser.CreateArrayType(RangeTypeId, ElemTypeId: Integer): Integer; +begin + result := TKernel(kernel).SymbolTable.RegisterArrayType(0, '', + RangeTypeId, ElemTypeId, 1); + GetSymbolRec(result).Completed := false; + SetHost(result, false); + SetName(result, 'ArrayType_' + IntToStr(result)); +end; + +function TBaseParser.GetTargetPlatform: TTargetPlatform; +begin + if kernel = nil then + result := tpNONE + else + result := TKernel(kernel).TargetPlatform; +end; + +function TBaseParser.GetRunnerKind: TRunnerKind; +begin + if kernel = nil then + result := rkNONE + else + result := TKernel(kernel).RunnerKind; +end; + +function TBaseParser.GetSupportedSEH: Boolean; +begin + if kernel = nil then + result := false + else + result := TKernel(kernel).SupportedSEH; +end; + +end. diff --git a/Sources/PAXCOMP_PASCAL_PARSER.pas b/Sources/PAXCOMP_PASCAL_PARSER.pas new file mode 100644 index 0000000..c6e24b9 --- /dev/null +++ b/Sources/PAXCOMP_PASCAL_PARSER.pas @@ -0,0 +1,9369 @@ +/////////////////////////////////////////////////////////////////////////// +// PaxCompiler +// Site: http://www.paxcompiler.com +// Author: Alexander Baranovsky (paxscript@gmail.com) +// ======================================================================== +// Copyright (c) Alexander Baranovsky, 2006-2014. All rights reserved. +// Code Version: 4.2 +// ======================================================================== +// Unit: PAXCOMP_PASCAL_PARSER.pas +// ======================================================================== +//////////////////////////////////////////////////////////////////////////// + +{$I PaxCompiler.def} +unit PAXCOMP_PASCAL_PARSER; +interface +uses {$I uses.def} + SysUtils, + Classes, + PAXCOMP_CONSTANTS, + PAXCOMP_TYPES, + PAXCOMP_SYS, + PAXCOMP_BASESYMBOL_TABLE, + PAXCOMP_SCANNER, + PAXCOMP_BYTECODE, + PAXCOMP_MODULE, + + PAXCOMP_STDLIB, + PAXCOMP_PARSER, + PAXCOMP_KERNEL, + PAXCOMP_BASERUNNER, + PAXCOMP_CLASSFACT, + PAXCOMP_GENERIC, + PAXCOMP_PASCAL_SCANNER; + +const + dirNONE = 0; + dirFORWARD = 1; + dirOVERLOAD = 2; + dirABSTRACT = 3; + dirVIRTUAL = 4; + dirOVERRIDE = 5; + dirREINTRODUCE = 6; + dirDYNAMIC = 7; + dirSTATIC = 8; + dirFINAL = 9; + +type + TPascalParser = class(TBaseParser) + private + I_STRICT: Integer; + I_PRIVATE: Integer; + I_PROTECTED: Integer; + I_PUBLIC: Integer; + I_PUBLISHED: Integer; + WasInherited: Boolean; + ForInCounter: Integer; + CONST_ONLY: Boolean; + OuterList: TAssocStringInt; + procedure GenExternalSub(SubId: Integer); + function MatchEx(const S: String): Boolean; + function InScope(const S: String): Boolean; + function Parse_AnonymousRoutine(IsFunc: Boolean): Integer; + procedure RemoveKeywords; + procedure RestoreKeywords; + protected + function CreateScanner: TBaseScanner; override; + function GetLanguageName: String; override; + function GetFileExt: String; override; + function GetLanguageId: Integer; override; + function GetUpcase: Boolean; override; + public + OnParseUnitName: TParserIdentEvent; + OnParseImplementationSection: TParserNotifyEvent; + OnParseBeginUsedUnitList: TParserNotifyEvent; + OnParseEndUsedUnitList: TParserNotifyEvent; + OnParseUsedUnitName: TParserIdentEvent; + OnParseTypeDeclaration: TParserIdentEvent; + OnParseForwardTypeDeclaration: TParserIdentEvent; + OnParseBeginClassTypeDeclaration: TParserIdentEventEx; + OnParseEndClassTypeDeclaration: TParserIdentEvent; + OnParseAncestorTypeDeclaration: TParserIdentEvent; + OnParseUsedInterface: TParserIdentEvent; + OnParseClassReferenceTypeDeclaration: TParserTypedIdentEvent; + OnParseAliasTypeDeclaration: TParserTypedIdentEvent; + OnParseProceduralTypeDeclaration: TParserIdentEventEx; + OnParseEventTypeDeclaration: TParserIdentEventEx; + OnParseMethodReferenceTypeDeclaration: TParserIdentEventEx; + OnParseSetTypeDeclaration: TParserTypedIdentEvent; + OnParsePointerTypeDeclaration: TParserTypedIdentEvent; + OnParseArrayTypeDeclaration: TParserArrayTypeEvent; + OnParseDynArrayTypeDeclaration: TParserTypedIdentEvent; + OnParseShortStringTypeDeclaration: TParserNamedValueEvent; + OnParseSubrangeTypeDeclaration: TParserDeclarationEvent; + OnParseBeginRecordTypeDeclaration: TParserIdentEventEx; + OnParseEndRecordTypeDeclaration: TParserIdentEvent; + OnParseBeginClassHelperTypeDeclaration: TParserTypedIdentEvent; + OnParseEndClassHelperTypeDeclaration: TParserIdentEvent; + OnParseBeginRecordHelperTypeDeclaration: TParserTypedIdentEvent; + OnParseEndRecordHelperTypeDeclaration: TParserIdentEvent; + OnParseBeginInterfaceTypeDeclaration: TParserIdentEvent; + OnParseEndInterfaceTypeDeclaration: TParserIdentEvent; + OnParseBeginEnumTypeDeclaration: TParserIdentEvent; + OnParseEndEnumTypeDeclaration: TParserIdentEvent; + OnParseEnumName: TParserNamedValueEvent; + OnParseFieldDeclaration: TParserTypedIdentEvent; + OnParseVariantRecordFieldDeclaration: TParserVariantRecordFieldEvent; + OnParsePropertyDeclaration: TParserTypedIdentEvent; + OnParseConstantDeclaration: TParserNamedValueEvent; + OnParseResourceStringDeclaration: TParserNamedValueEvent; + OnParseTypedConstantDeclaration: TParserNamedTypedValueEvent; + OnParseVariableDeclaration: TParserTypedIdentEvent; + OnParseBeginSubDeclaration: TParserIdentEvent; + OnParseEndSubDeclaration: TParserDeclarationEvent; + OnParseBeginFormalParameterList: TParserNotifyEvent; + OnParseEndFormalParameterList: TParserNotifyEvent; + OnParseFormalParameterDeclaration: TParserNamedTypedValueEvent; + OnParseResultType: TParserIdentEvent; + OnParseSubDirective: TParserIdentEvent; + + constructor Create; override; + destructor Destroy; override; + procedure ParseProgram; override; + procedure Call_SCANNER; override; + procedure Match(const S: String); override; + procedure ReadToken; override; + procedure InitSub(var SubId: Integer); override; + function GetIncludedFileExt: String; override; + procedure Init(i_kernel: Pointer; M: TModule); override; + function Parse_DirectiveList(SubId: Integer): TIntegerList; + function Parse_PortabilityDirective: TPortDir; + + procedure GenDefaultConstructor(ClassId: Integer); + procedure GenDefaultDestructor(ClassId: Integer); + + procedure Parse_Attribute; + procedure Parse_Message(SubId: Integer); + procedure Parse_Library; + procedure Parse_ProgramBlock(namespace_id: Integer); + procedure Parse_Unit(IsExternalUnit: Boolean = false); override; + procedure Parse_Block; + + procedure Parse_NamespaceDeclaration; + procedure Parse_UsesClause(IsImplementationSection: Boolean); + procedure Parse_NamespaceMemberDeclaration; + + procedure Parse_DeclarationPart(IsImplementation: Boolean = false); + procedure Parse_VariableDeclaration(vis: TClassVisibility = cvNone); + procedure Parse_ConstantDeclaration(vis: TClassVisibility = cvNone); + procedure Parse_ResourcestringDeclaration; + procedure Parse_LabelDeclaration; + function Parse_FormalParameterList(SubId: Integer; + bracket: Char = '('): Integer; + procedure Parse_ProcedureDeclaration(IsSharedMethod: Boolean = false); + procedure Parse_FunctionDeclaration(IsSharedMethod: Boolean = false); + procedure Parse_OperatorDeclaration; + procedure Parse_ConstructorDeclaration; + procedure Parse_DestructorDeclaration; + procedure Parse_SubBlock; + procedure Parse_ConstantInitialization(ID: Integer); + function Parse_VariableInitialization: Integer; + + // types + procedure Parse_TypeDeclaration(IsExternalUnit: Boolean = false; + vis: TClassVisibility = cvPublic); + procedure Parse_ProceduralTypeDeclaration(TypeID: Integer; + var SubId: Integer); + procedure Parse_ArrayTypeDeclaration(ArrayTypeID: Integer; IsPacked: Boolean); + function Parse_RecordConstructorHeading(IsSharedMethod: Boolean; + RecordTypeId: Integer; + Vis: TClassVisibility; + IsExternalUnit: Boolean): Integer; + function Parse_RecordDestructorHeading(IsSharedMethod: Boolean; + RecordTypeId: Integer; + Vis: TClassVisibility; + IsExternalUnit: Boolean): Integer; + function Parse_RecordProcedureHeading(IsSharedMethod: Boolean; + RecordTypeId: Integer; + Vis: TClassVisibility; + IsExternalUnit: Boolean): Integer; + function Parse_RecordFunctionHeading(IsSharedMethod: Boolean; + RecordTypeId: Integer; + Vis: TClassVisibility; + IsExternalUnit: Boolean): Integer; + function Parse_RecordOperatorHeading(RecordTypeId: Integer; + Vis: TClassVisibility; + IsExternalUnit: Boolean): Integer; + function Parse_RecordProperty(RecordTypeId: Integer; + Vis: TClassVisibility; + IsExternalUnit: Boolean): Integer; + procedure Parse_RecordVariantPart(VarLevel: Integer; + CurrVarCnt: Int64; + vis: TClassVisibility); + procedure Parse_RecordHelperItem; + procedure Parse_RecordTypeDeclaration(RecordTypeID: Integer; IsPacked: Boolean; + IsExternalUnit: Boolean = false); + function Parse_ClassConstructorHeading(IsSharedMethod: Boolean; + ClassTypeId: Integer; + vis: TClassVisibility; + IsExternalUnit: Boolean): Integer; + function Parse_ClassDestructorHeading(IsSharedMethod: Boolean; + ClassTypeId: Integer; + vis: TClassVisibility; + IsExternalUnit: Boolean): Integer; + function Parse_ClassProcedureHeading(IsSharedMethod: Boolean; + ClassTypeId: Integer; + vis: TClassVisibility; + IsExternalUnit: Boolean): Integer; + function Parse_ClassFunctionHeading(IsSharedMethod: Boolean; + ClassTypeId: Integer; + vis: TClassVisibility; + IsExternalUnit: Boolean): Integer; + function Parse_ClassProperty(IsShared: Boolean; + ClassTypeId: Integer; + vis: TClassVisibility; + IsExternalUnit: Boolean): Integer; + procedure Parse_ClassTypeDeclaration(ClassTypeID: Integer; IsPacked: Boolean; + IsExternalUnit: Boolean = false); + procedure Parse_InterfaceTypeDeclaration(IntfTypeID: Integer); + procedure Parse_MethodRefTypeDeclaration(TypeID: Integer); + procedure Parse_EnumTypeDeclaration(TypeID: Integer); + procedure Parse_PointerTypeDeclaration(TypeID: Integer); +{$IFNDEF PAXARM} + procedure Parse_ShortStringTypeDeclaration(TypeID: Integer); +{$ENDIF} + procedure Parse_SetTypeDeclaration(TypeID: Integer); + procedure Parse_SubrangeTypeDeclaration(TypeID, TypeBaseId: Integer; + var Declaration: String; + Expr1ID: Integer = 0); + function Parse_OrdinalType(var Declaration: String): Integer; + function Parse_Type: Integer; + function Parse_OpenArrayType(var ElemTypeName: String): Integer; + + procedure ParseExternalSub(SubId: Integer); + + //statements + function Parse_Statement: Boolean; + procedure Parse_CompoundStmt; + procedure Parse_StmtList; + procedure Parse_Write; + procedure Parse_Writeln; + procedure Parse_Print; + procedure Parse_Println; + procedure Parse_AssignmentStmt; + procedure Parse_CaseStmt; + procedure Parse_IfStmt; + procedure Parse_GotoStmt; + procedure Parse_BreakStmt; + procedure Parse_ContinueStmt; + procedure Parse_ExitStmt; + procedure Parse_WhileStmt; + procedure Parse_RepeatStmt; + procedure Parse_ForStmt; + procedure Parse_WithStmt; + procedure Parse_TryStmt; + procedure Parse_RaiseStmt; + + function Parse_LoopStmt(l_break, l_continue, l_loop: Integer): Boolean; + + //expressions + function Parse_LambdaParameters(SubId: Integer) : Integer; + function Parse_LambdaExpression: Integer; + function Parse_AnonymousFunction: Integer; + function Parse_AnonymousProcedure: Integer; + function Parse_ArgumentList(SubId: Integer): Integer; + function Parse_ConstantExpression: Integer; + function Parse_Expression: Integer; override; + function Parse_SimpleExpression: Integer; + function Parse_Term: Integer; + function Parse_Factor: Integer; override; + function Parse_SetConstructor: Integer; + function Parse_Designator(init_id: Integer = 0): Integer; + function Parse_Label: Integer; + function Parse_Ident: Integer; override; + // generic + procedure EndMethodDef(SubId: Integer); override; + procedure Parse_TypeRestriction(LocalTypeParams: TStringObjectList); override; + end; + + TPascalExprParser = class + private + kernel: Pointer; + scanner: TPascalScanner; + function GetCurrToken: String; + function GetTokenClass: TTokenClass; + function Parse_SetConstructor: Variant; + function IsCurrText(const S: String): Boolean; + procedure Match(const S: String); + function NotMatch(const S: String): Boolean; + procedure Cancel; + procedure Call_SCANNER; + function Parse_Expression: Variant; + function Parse_SimpleExpression: Variant; + function Parse_Term: Variant; + function Parse_Factor: Variant; + public + LevelList: TIntegerList; + IsSet: Boolean; + ResExpr: String; + constructor Create(akernel: Pointer; const Expr: String); + destructor Destroy; override; + function ParseExpression: Variant; + function Lookup(const S: String): Variant; + function LegalValue(const V: Variant): Boolean; + property CurrToken: String read GetCurrToken; + property TokenClass: TTokenClass read GetTokenClass; + end; + +implementation + +uses + PAXCOMP_VAROBJECT; + +constructor TPascalExprParser.Create(akernel: Pointer; const Expr: String); +begin + inherited Create; + LevelList := TIntegerList.Create(true); + kernel := akernel; + scanner := TPascalScanner.Create; + scanner.Init(kernel, Expr, 0); + ResExpr := ''; +end; + +destructor TPascalExprParser.Destroy; +begin + scanner.Free; + LevelList.Free; + inherited; +end; + +function TPascalExprParser.GetCurrToken: String; +begin + result := scanner.Token.Text; +end; + +function TPascalExprParser.GetTokenClass: TTokenClass; +begin + result := scanner.Token.TokenClass; +end; + +function TPascalExprParser.IsCurrText(const S: String): Boolean; +begin + result := StrEql(S, CurrToken); +end; + +function TPascalExprParser.LegalValue(const V: Variant): Boolean; +begin + result := VarType(V) <> varEmpty; +end; + +procedure TPascalExprParser.Match(const S: String); +begin + if IsCurrText(S) then + Call_SCANNER + else + Cancel; +end; + +procedure TPascalExprParser.Cancel; +begin + raise PaxCancelException.Create(''); +end; + +procedure TPascalExprParser.Call_SCANNER; +begin + scanner.ReadToken; + ResExpr := ResExpr + CurrToken; +end; + +function TPascalExprParser.NotMatch(const S: String): Boolean; +begin + if not IsCurrText(S) then + result := true + else + begin + result := false; + Call_SCANNER; + end; +end; + +function TPascalExprParser.Lookup(const S: String): Variant; +var + I, L, Id: Integer; +begin + for I := 0 to LevelList.Count - 1 do + begin + L := LevelList[I]; + Id := TKernel(kernel).SymbolTable.LookUp(S, L, true); + if Id > 0 then + begin + result := TKernel(kernel).SymbolTable[Id].Value; + Exit; + end; + end; +end; + +function TPascalExprParser.ParseExpression: Variant; +begin + Call_SCANNER; + Call_SCANNER; + Call_SCANNER; + try + result := Parse_Expression; + except + // canceled + end; +end; + +function TPascalExprParser.Parse_Expression: Variant; +var + Op: Integer; + V: Variant; +begin + result := Parse_SimpleExpression; + if not LegalValue(result) then + Cancel; + + if CurrToken = '=' then + Op := OP_EQ + else if CurrToken = '<>' then + Op := OP_NE + else if CurrToken = '>' then + Op := OP_GT + else if CurrToken = '>=' then + Op := OP_GE + else if CurrToken = '<' then + Op := OP_LT + else if CurrToken = '<=' then + Op := OP_LT + else + Op := 0; + + while Op <> 0 do + begin + Call_SCANNER; + V := Parse_SimpleExpression; + if not LegalValue(V) then + Cancel; + + if Op = OP_EQ then + result := result = V + else if Op = OP_NE then + result := result <> V + else if Op = OP_GT then + result := result > V + else if Op = OP_GE then + result := result >= V + else if Op = OP_LT then + result := result < V + else if Op = OP_LE then + result := result <= V; + + if CurrToken = '=' then + Op := OP_EQ + else if CurrToken = '<>' then + Op := OP_NE + else if CurrToken = '>' then + Op := OP_GT + else if CurrToken = '>=' then + Op := OP_GE + else if CurrToken = '<' then + Op := OP_LT + else if CurrToken = '<=' then + Op := OP_LT + else + Op := 0; + end; +end; + +function TPascalExprParser.Parse_SimpleExpression: Variant; +var + Op: Integer; + V: Variant; +begin + result := Parse_Term; + if not LegalValue(result) then + Cancel; + + if CurrToken = '+' then + Op := OP_PLUS + else if CurrToken = '-' then + Op := OP_MINUS + else if StrEql(CurrToken, 'or') then + Op := OP_OR + else if StrEql(CurrToken, 'xor') then + Op := OP_XOR + else + Op := 0; + + while Op <> 0 do + begin + Call_SCANNER; + V := Parse_Term; + if not LegalValue(V) then + Cancel; + + if Op = OP_PLUS then + result := result + V + else if Op = OP_MINUS then + result := result - V + else if Op = OP_OR then + result := result or V + else if Op = OP_XOR then + result := result xor V; + + if CurrToken = '+' then + Op := OP_PLUS + else if CurrToken = '-' then + Op := OP_MINUS + else if StrEql(CurrToken, 'or') then + Op := OP_OR + else if StrEql(CurrToken, 'xor') then + Op := OP_XOR + else + Op := 0; + end; +end; + +function TPascalExprParser.Parse_Term: Variant; +var + Op: Integer; + V: Variant; +begin + result := Parse_Factor; + if not LegalValue(result) then + Cancel; + + if CurrToken = '*' then + Op := OP_MULT + else if CurrToken = '/' then + Op := OP_DIV + else if StrEql(CurrToken, 'div') then + Op := OP_IDIV + else if StrEql(CurrToken, 'mod') then + Op := OP_MOD + else if StrEql(CurrToken, 'shl') then + Op := OP_SHL + else if StrEql(CurrToken, 'shr') then + Op := OP_SHL + else if StrEql(CurrToken, 'and') then + Op := OP_AND + else + Op := 0; + + while Op <> 0 do + begin + Call_SCANNER; + V := Parse_Factor; + if not LegalValue(V) then + Cancel; + + if Op = OP_MULT then + result := result * V + else if Op = OP_DIV then + begin + if V = 0.0 then + begin + if result = 0.0 then + result := NaN + else if result = 1.0 then + result := Infinity + else if result = - 1.0 then + result := NegInfinity + end + else + result := result / V; + end + else if Op = OP_IDIV then + result := result div V + else if Op = OP_MOD then + result := result mod V + else if Op = OP_SHL then + result := result shl V + else if Op = OP_SHR then + result := result shr V + else if Op = OP_AND then + result := result and V; + + if CurrToken = '*' then + Op := OP_MULT + else if CurrToken = '/' then + Op := OP_DIV + else if StrEql(CurrToken, 'div') then + Op := OP_IDIV + else if StrEql(CurrToken, 'mod') then + Op := OP_MOD + else if StrEql(CurrToken, 'shl') then + Op := OP_SHL + else if StrEql(CurrToken, 'shr') then + Op := OP_SHL + else if StrEql(CurrToken, 'and') then + Op := OP_AND + else + Op := 0; + end; +end; + +function TPascalExprParser.Parse_Factor: Variant; +var + I, J: Integer; + D: Double; +begin +{$IFDEF PAXARM} + if TokenClass = tcCharConst then + begin + result := Ord(CurrToken[1]); + Call_SCANNER; + end + else if TokenClass = tcNumCharConst then + begin + result := StrToInt(CurrToken); + Call_SCANNER; + end + else if TokenClass = tcPCharConst then + begin + result := CurrToken; + Call_SCANNER; + end +{$ELSE} + if TokenClass = tcCharConst then + begin + result := Ord(CurrToken[1]); + Call_SCANNER; + end + else if TokenClass = tcNumCharConst then + begin + result := StrToInt(CurrToken); + Call_SCANNER; + end + else if TokenClass = tcPCharConst then + begin + result := CurrToken; + Call_SCANNER; + end +{$ENDIF} + else if TokenClass = tcIntegerConst then + begin + val(CurrToken, i, j); + if j = 0 then begin + if Pos('$', CurrToken) > 0 then + begin +{$IFDEF VARIANTS} + result := Cardinal(i); +{$ELSE} + result := Integer(i); +{$ENDIF} + end + else + begin + result := i; + end; + end; + Call_SCANNER; + end + else if TokenClass = tcVariantConst then + begin + Call_SCANNER; + end + else if TokenClass = tcDoubleConst then + begin + Val(CurrToken, D, I); + result := D; + Call_SCANNER; + end + else if IsCurrText('nil') then + begin + result := 0; + Call_SCANNER; + end + else if IsCurrText('true') then + begin + result := true; + Call_SCANNER; + end + else if IsCurrText('false') then + begin + result := false; + Call_SCANNER; + end + else if IsCurrText('+') then + begin + Call_SCANNER; + result := Parse_Factor; + end + else if IsCurrText('-') then + begin + Call_SCANNER; + result := - Parse_Factor; + end + else if IsCurrText('not') then + begin + Call_SCANNER; + result := not Parse_Factor; + end + else if IsCurrText('low') then + begin + Call_SCANNER; + Match('('); + result := Lookup(CurrToken); + Call_SCANNER; + Match(')'); + end + else if IsCurrText('high') then + begin + Call_SCANNER; + Match('('); + I := Lookup(CurrToken); + Call_SCANNER; + Match(')'); + end + else if IsCurrText('SizeOf') then + begin + Call_SCANNER; + Match('('); + I := Lookup(CurrToken); + Call_SCANNER; + Match(')'); + end + else if IsCurrText('pred') then + begin + Call_SCANNER; + Match('('); + result := Parse_Expression - 1; + Match(')'); + end + else if IsCurrText('succ') then + begin + Call_SCANNER; + Match('('); + result := Parse_Expression + 1; + Match(')'); + end + else if IsCurrText('ord') then + begin + Call_SCANNER; + Match('('); + result := Parse_Expression; + Match(')'); + end + else if IsCurrText('chr') then + begin + Call_SCANNER; + Match('('); + result := Parse_Expression; + Match(')'); + end + else if IsCurrText('(') then + begin + Match('('); + result := Parse_Expression; + Match(')'); + end + else if IsCurrText('@') then + begin + Cancel; + end + else if IsCurrText('[') then + begin + result := Parse_SetConstructor; + end + else if IsCurrText('procedure') then + begin + Cancel; + end + else if IsCurrText('function') then + begin + Cancel; + end + else if IsCurrText('array') then + begin + Cancel; + end + else if IsCurrText('deprecated') then + begin + Cancel; + end + else if IsCurrText('pchar') then + begin + Cancel; + end + else if IsCurrText('[') then + begin + result := Parse_SetConstructor; + end + else + begin + result := LookUp(CurrToken); + Call_SCANNER; + while IsCurrText('.') do + begin + Match('.'); + result := LookUp(CurrToken); + Call_SCANNER; + end; + if IsCurrText('(') then + begin + Match('('); + result := Parse_Expression; + Match(')'); + end; + end; +end; + +function TPascalExprParser.Parse_SetConstructor: Variant; +begin + Match('['); + if not IsCurrText(']') then + begin + repeat + Parse_Expression; + if IsCurrText('..') then + begin + Match('..'); + Parse_Expression; + end; + If NotMatch(',') then + break; + until false; + end; + Match(']'); + IsSet := true; + result := ResExpr; +end; + +constructor TPascalParser.Create; +begin + inherited; + + OuterList := TAssocStringInt.Create; + + AddKeyword('and'); + AddKeyword('array'); + AddKeyword('as'); + AddKeyword('asm'); + AddKeyword('begin'); + AddKeyword('case'); + AddKeyword('class'); + AddKeyword('const'); + AddKeyword('constructor'); + AddKeyword('destructor'); + AddKeyword('dispinterface'); + AddKeyword('div'); + AddKeyword('do'); + AddKeyword('downto'); + AddKeyword('else'); + + AddKeyword('end'); + AddKeyword('except'); + AddKeyword('exports'); + + AddKeyword('external'); + + AddKeyword('file'); + AddKeyword('finalization'); + AddKeyword('finally'); + AddKeyword('for'); + AddKeyword('function'); + AddKeyword('goto'); + AddKeyword('if'); + AddKeyword('implementation'); + AddKeyword('in'); + AddKeyword('inherited'); + AddKeyword('initialization'); + AddKeyword('inline'); + AddKeyword('interface'); + AddKeyword('is'); + AddKeyword('label'); + AddKeyword('library'); + AddKeyword('mod'); + AddKeyword('nil'); + AddKeyword('not'); + AddKeyword('object'); + AddKeyword('of'); + AddKeyword('on'); + AddKeyword('or'); + AddKeyword('out'); + AddKeyword('packed'); + I_STRICT := AddKeyword('strict'); + I_PRIVATE := AddKeyword('private'); + AddKeyword('procedure'); + AddKeyword('program'); + AddKeyword('property'); + I_PROTECTED := AddKeyword('protected'); + I_PUBLIC := AddKeyword('public'); + I_PUBLISHED := AddKeyword('published'); + AddKeyword('raise'); + AddKeyword('record'); + AddKeyword('repeat'); + AddKeyword('resourcestring'); + AddKeyword('set'); + AddKeyword('shl'); + AddKeyword('shr'); + AddKeyword('string'); + AddKeyword('then'); + AddKeyword('threadvar'); + AddKeyword('to'); + AddKeyword('try'); + AddKeyword('type'); + AddKeyword('unit'); + AddKeyword('until'); + AddKeyword('uses'); + AddKeyword('var'); + AddKeyword('while'); + AddKeyword('with'); + AddKeyword('xor'); + AddKeyword(EXTRA_KEYWORD); + + AddOperator(pascal_Implicit, gen_Implicit); + AddOperator(pascal_Explicit, gen_Explicit); + AddOperator(pascal_Add, gen_Add); + AddOperator(pascal_Divide, gen_Divide); + AddOperator(pascal_IntDivide, gen_IntDivide); + AddOperator(pascal_Modulus, gen_Modulus); + AddOperator(pascal_Multiply, gen_Multiply); + AddOperator(pascal_Subtract, gen_Subtract); + AddOperator(pascal_Negative, gen_Negative); + AddOperator(pascal_Positive, gen_Positive); + AddOperator(pascal_LogicalNot, gen_LogicalNot); + AddOperator(pascal_LeftShift, gen_LeftShift); + AddOperator(pascal_RightShift, gen_RightShift); + AddOperator(pascal_LogicalAnd, gen_LogicalAnd); + AddOperator(pascal_LogicalOr, gen_LogicalOr); + AddOperator(pascal_LogicalXor, gen_LogicalXor); + AddOperator(pascal_LessThan, gen_LessThan); + AddOperator(pascal_LessThanOrEqual, gen_LessThanOrEqual); + AddOperator(pascal_GreaterThan, gen_GreaterThan); + AddOperator(pascal_GreaterThanOrEqual, gen_GreaterThanOrEqual); + AddOperator(pascal_Equal, gen_Equal); + AddOperator(pascal_NotEqual, gen_NotEqual); + AddOperator(pascal_Inc, gen_Inc); + AddOperator(pascal_Dec, gen_Dec); +end; + +destructor TPascalParser.Destroy; +begin + FreeAndNil(OuterList); + inherited; +end; + +function TPascalParser.CreateScanner: TBaseScanner; +begin + result := TPascalScanner.Create; +end; + +function TPascalParser.GetLanguageName: String; +begin + result := 'Pascal'; +end; + +function TPascalParser.GetFileExt: String; +begin + result := 'pas'; +end; + +function TPascalParser.GetIncludedFileExt: String; +begin + result := 'pas'; +end; + +function TPascalParser.GetLanguageId: Integer; +begin + result := PASCAL_LANGUAGE; +end; + +function TPascalParser.GetUpcase: Boolean; +begin + result := true; +end; + +procedure TPascalParser.Init(i_kernel: Pointer; M: TModule); +begin + Inherited Init(i_kernel, M); + WasInherited := true; + ForInCounter := 0; + IMPLEMENTATION_SECTION := false; + OuterList.Clear; +end; + +procedure TPascalParser.GenDefaultConstructor(ClassId: Integer); +var + SubId, ResId, L: Integer; +begin + GenComment('BEGIN OF DEFAULT CONSTRUCTOR OF ' + GetName(ClassId)); + + LevelStack.Push(ClassId); + SubId := NewTempVar; + SetName(SubId, 'Create'); + + BeginClassConstructor(SubId, ClassId); + SetVisibility(SubId, cvPublic); + inherited InitSub(SubId); + + SetCallMode(SubId, cmOVERRIDE); + Gen(OP_ADD_MESSAGE, SubId, NewConst(typeINTEGER, -1000), 0); + Gen(OP_CHECK_OVERRIDE, SubId, 0, 0); + + Gen(OP_SAVE_EDX, 0, 0, 0); + + L := NewLabel; + Gen(OP_GO_DL, L, 0, 0); + Gen(OP_CREATE_OBJECT, ClassId, 0, CurrSelfId); + + if GetSymbolRec(ClassId).IsAbstract then + Gen(OP_ERR_ABSTRACT, NewConst(typeSTRING, + GetFullName(ClassId)), 0, SubId); + + SetLabelHere(L); + + Gen(OP_BEGIN_WITH, CurrSelfId, 0, 0); + WithStack.Push(CurrSelfId); + + NewTempVar; + ResId := NewTempVar; + + Gen(OP_PUSH_CLASSREF, CurrSelfId, 0, ResId); + Gen(OP_EVAL_INHERITED, SubId, 0, ResId); + + SetDefault(SubId, true); + Gen(OP_UPDATE_DEFAULT_CONSTRUCTOR, SubId, 0, ResId); +// will insertion here + + Gen(OP_CALL_INHERITED, ResId, 0, 0); + + Gen(OP_END_WITH, WithStack.Top, 0, 0); + WithStack.Pop; + + Gen(OP_RESTORE_EDX, 0, 0, 0); + L := NewLabel; + Gen(OP_GO_DL, L, 0, 0); + Gen(OP_ONCREATE_OBJECT, CurrSelfId, 0, 0); + Gen(OP_ON_AFTER_OBJECT_CREATION, CurrSelfId, 0, 0); + SetLabelHere(L); + + EndSub(SubId); + LevelStack.Pop; + + GenComment('END OF DEFAULT CONSTRUCTOR OF ' + GetName(ClassId)); +end; + +procedure TPascalParser.GenDefaultDestructor(ClassId: Integer); +var + SubId, Id, ResId: Integer; +begin + GenComment('BEGIN OF DEFAULT DESTRUCTOR OF ' + GetName(ClassId)); + + LevelStack.Push(ClassId); + SubId := NewTempVar; + SetName(SubId, 'Destroy'); + BeginClassDestructor(SubId, ClassId); + SetVisibility(SubId, cvPublic); + SetCallMode(SubId, cmOVERRIDE); + inherited InitSub(SubId); + + Gen(OP_BEGIN_WITH, CurrSelfId, 0, 0); + WithStack.Push(CurrSelfId); + + Id := NewTempVar; + ResId := NewTempVar; + SetName(Id, 'Destroy'); + Gen(OP_EVAL, 0, 0, Id); + Gen(OP_EVAL_INHERITED, Id, 0, ResId); + + Gen(OP_CALL, ResId, 0, 0); + + Gen(OP_END_WITH, WithStack.Top, 0, 0); + WithStack.Pop; + + EndSub(SubId); + LevelStack.Pop; + + GenComment('END OF DEFAULT DESTRUCTOR OF ' + GetName(ClassId)); +end; + +procedure TPascalParser.Parse_DeclarationPart(IsImplementation: Boolean = false); +var + ok: Boolean; +begin + repeat + ok := false; + if IsCurrText('label') then + begin + Parse_LabelDeclaration; + ok := true; + end + else if IsCurrText('var') then + begin + Parse_VariableDeclaration; + ok := true; + end + else if IsCurrText('threadvar') then + begin + Parse_VariableDeclaration; + ok := true; + end + else if IsCurrText('const') then + begin + Parse_ConstantDeclaration; + ok := true; + end + else if IsCurrText('resourcestring') then + begin + Parse_ResourcestringDeclaration; + ok := true; + end + else if IsCurrText('procedure') then + begin + Parse_ProcedureDeclaration; + ok := true; + end + else if IsCurrText('function') then + begin + Parse_FunctionDeclaration; + ok := true; + end + else if IsCurrText('class') then + begin + Call_SCANNER; + if IsCurrText('procedure') then + Parse_ProcedureDeclaration(true) + else if IsCurrText('function') then + Parse_FunctionDeclaration(true) + else if IsCurrText('operator') then + Parse_OperatorDeclaration + else + Match('procedure'); + ok := true; + end + else if IsCurrText('constructor') then + begin + Parse_ConstructorDeclaration; + ok := true; + end + else if IsCurrText('destructor') then + begin + Parse_DestructorDeclaration; + ok := true; + end + else if IsCurrText('type') then + begin + Parse_TypeDeclaration; + ok := true; + end + until not ok; + + if GetKind(LevelStack.Top) in KindSUBS then + Exit; +end; + +procedure TPascalParser.ParseProgram; +var + namespace_id: Integer; +begin + EXECUTABLE_SWITCH := 0; + Call_SCANNER; + + if IsEOF then + Exit; + + namespace_id := 0; + + if IsCurrText('program') then + begin + DECLARE_SWITCH := true; + Call_SCANNER; +// SetKind(CurrToken.Id, KindNONE); +// Call_SCANNER; + namespace_id := Parse_Ident; + DECLARE_SWITCH := false; + Match(';'); + end; + + if IsCurrText('unit') then + Parse_Unit + else if IsCurrText('library') then + Parse_Library + else + Parse_ProgramBlock(namespace_id); +end; + +procedure TPascalParser.Parse_Library; +var + id, I: Integer; + L: TAssocStringInt; + S: String; +begin + DECLARE_SWITCH := true; + Match('library'); + + Gen(OP_BEGIN_LIBRARY, Parse_Ident, 0, 0); + Match(';'); + + while IsCurrText('uses') do + begin + Parse_UsesClause(false); + end; + + Gen(OP_END_IMPORT, 0, 0, 0); + + repeat + if IsEOF then + Match('exports'); + if IsCurrText('exports') then + break; + Parse_NamespaceMemberDeclaration; + until false; + + DECLARE_SWITCH := false; + + Gen(OP_BEGIN_EXPORT, 0, 0, 0); + Match('exports'); + + L := TAssocStringInt.Create; + try + repeat + S := CurrToken.Text; + id := Parse_Ident; + L.AddValue(S, id); + if IsCurrText(',') then + Call_SCANNER + else + break; + until false; +// L.Sort; + for I := 0 to L.Count - 1 do + begin + Id := L.Values[I]; + Gen(OP_EXPORTS, id, 0, 0); + end; + finally + FreeAndNil(L); + end; + Match(';'); + + Parse_CompoundStmt; + MatchFinal('.'); +end; + +procedure TPascalParser.Parse_NamespaceDeclaration; +var + l: TIntegerList; + i, namespace_id: Integer; +begin + DECLARE_SWITCH := true; + RemoveLastIdent(CurrToken.Id); + Match('namespace'); + + l := TIntegerList.Create; + + try + repeat // ParseQualifiedIdentifier + namespace_id := Parse_Ident; + l.Add(namespace_id); + BeginNamespace(namespace_id); + if NotMatch('.') then + break; + until false; + + // Parse namespace body + + repeat + if IsEOF then + Match('end'); + if IsCurrText('end') then + break; + Parse_NamespaceMemberDeclaration; + until false; + + for i := l.Count - 1 downto 0 do + begin + EndNamespace(l[i]); + Gen(OP_BEGIN_USING, l[i], 0, 0); + end; + + finally + FreeAndNil(L); + end; + + Match('end'); + Match(';'); +end; + +procedure TPascalParser.Parse_UsesClause(IsImplementationSection: Boolean); +var + unit_id, id: Integer; + S: String; + AlreadyExists: Boolean; + RootKernel: TKernel; +begin + RootKernel := TKernel(Kernel).RootKernel; + + UsedUnitList.Clear; + + DECLARE_SWITCH := false; + Match('uses'); + if Assigned(OnParseBeginUsedUnitList) then + OnParseBeginUsedUnitList(Owner); + + repeat + unit_id := Parse_UnitName(S); + if Assigned(OnParseUsedUnitName) then + OnParseUsedUnitName(Owner, S, unit_id); + + AlreadyExists := GetKind(unit_id) = kindNAMESPACE; + + Gen(OP_BEGIN_USING, unit_id, 0, 0); + + if IsCurrText('in') then + begin + Call_SCANNER; + id := Parse_PCharLiteral; + S := GetValue(id); + if (PosCh('\', S) > 0) or (PosCh('/', S) > 0) then + if not Assigned(RootKernel.OnUsedUnit) then + begin + if (Pos('.\', S) > 0) or (Pos('./', S) > 0) then + S := ExpandFileName(S) + else + S := GetCurrentDir + S; + end; + + AlreadyExists := false; + end + else + S := S + '.' + GetFileExt; + + if not AlreadyExists then + if not ImportOnly then + AddModuleFromFile(S, unit_id, IsImplementationSection); + + if NotMatch(',') then + Break; + until false; + + Match(';'); +end; + +procedure TPascalParser.Parse_NamespaceMemberDeclaration; +begin + if IsCurrText('type') then + Parse_TypeDeclaration + else if IsCurrText('procedure') then + Parse_ProcedureDeclaration + else if IsCurrText('function') then + Parse_FunctionDeclaration + else if IsCurrText('class') then + begin + Call_SCANNER; + if IsCurrText('procedure') then + Parse_ProcedureDeclaration(true) + else if IsCurrText('function') then + Parse_FunctionDeclaration(true) + else if IsCurrText('operator') then + Parse_OperatorDeclaration + else + Match('procedure'); + end + else if IsCurrText('var') then + Parse_VariableDeclaration + else if IsCurrText('const') then + Parse_ConstantDeclaration + else if IsCurrText('resourcestring') then + Parse_ResourcestringDeclaration + else + Match('end'); +end; + +function TPascalParser.Parse_Statement: Boolean; +begin + result := false; + + if CurrToken.TokenClass = tcIdentifier then + if GetKind(CurrToken.Id) = KindLABEL then + if GetName(CurrToken.Id) <> '' then + begin + SetLabelHere(CurrToken.Id); + Call_SCANNER; + Match(':'); + end; + + Gen(OP_STMT, 0, 0, 0); + + if IsCurrText('begin') then + begin + Parse_CompoundStmt; + result := true; + end + else if IsCurrText('case') then + Parse_CaseStmt + else if IsCurrText('if') then + Parse_IfStmt + else if IsCurrText('goto') then + Parse_GotoStmt + else if IsCurrText('while') then + Parse_WhileStmt + else if IsCurrText('repeat') then + Parse_RepeatStmt + else if IsCurrText('for') then + Parse_ForStmt + else if IsCurrText('break') then + begin + if (BreakStack.Count = 0) or (Lookups('break', LevelStack) > 0) then + Parse_AssignmentStmt + else + begin + RemoveLastEvalInstructionAndName('break'); + Parse_BreakStmt; + end; + end + else if IsCurrText('continue') then + begin + if (ContinueStack.Count = 0) or (Lookups('continue', LevelStack) > 0) then + Parse_AssignmentStmt + else + begin + RemoveLastEvalInstructionAndName('continue'); + Parse_ContinueStmt; + end; + end + else if IsCurrText('exit') then + begin + if Lookups('exit', LevelStack) > 0 then + Parse_AssignmentStmt + else + begin + RemoveLastEvalInstructionAndName('exit'); + Parse_ExitStmt; + end; + end + else if IsCurrText('with') then + Parse_WithStmt + else if IsCurrText('try') then + Parse_TryStmt + else if IsCurrText('raise') then + Parse_RaiseStmt + else + begin + if IsCurrText(PrintKeyword) then + begin + if (CurrToken.Id > StdCard) and (GetKind(CurrToken.Id) = kindSUB) then + Parse_AssignmentStmt + else + begin + Call_SCANNER; + Parse_Print; + end; + end + else if IsCurrText(PrintlnKeyword) then + begin + if (CurrToken.Id > StdCard) and (GetKind(CurrToken.Id) = kindSUB) then + Parse_AssignmentStmt + else + begin + Call_SCANNER; + Parse_Println; + end; + end + else if IsCurrText('write') then + begin + Call_SCANNER; + Parse_Write; + end + else if IsCurrText('writeln') then + begin + Call_SCANNER; + Parse_Writeln; + end + else + Parse_AssignmentStmt; + end; + Gen(OP_STMT, 0, 0, 0); +end; + +procedure TPascalParser.Parse_Write; +var + ID, ID_L1, ID_L2: Integer; +begin + IsConsoleApp := true; + + Match('('); + repeat + ID := Parse_Expression; + ID_L1 := 0; + ID_L2 := 0; + if IsCurrText(':') then + begin + Call_SCANNER; + ID_L1 := Parse_Expression; + end; + if IsCurrText(':') then + begin + Call_SCANNER; + ID_L2 := Parse_Expression; + end; + + Gen(OP_PRINT, ID, ID_L1, ID_L2); + if NotMatch(',') then + Break; + until false; + Match(')'); +end; + +procedure TPascalParser.Parse_Writeln; +begin + IsConsoleApp := true; + + if IsCurrText('(') then + Parse_Write; + Gen(OP_PRINT, 0, 0, 0); +end; + +procedure TPascalParser.Parse_Print; +var + ID, ID_L1, ID_L2: Integer; +begin + if IsCurrText(';') then + begin + Exit; + end; + + repeat + ID := Parse_Expression; + ID_L1 := 0; + ID_L2 := 0; + if IsCurrText(':') then + begin + Call_SCANNER; + ID_L1 := Parse_Expression; + end; + if IsCurrText(':') then + begin + Call_SCANNER; + ID_L2 := Parse_Expression; + end; + + Gen(OP_PRINT_EX, ID, ID_L1, ID_L2); + if NotMatch(',') then + Break; + until false; +end; + +procedure TPascalParser.Parse_Println; +begin + if not IsCurrText(';') then + Parse_Print; +{$IFDEF PAXARM} + Gen(OP_PRINT_EX, NewConst(typeUNICSTRING, #13#10), 0, 0); +{$ELSE} + Gen(OP_PRINT_EX, NewConst(typeANSISTRING, #13#10), 0, 0); +{$ENDIF} +end; + +procedure TPascalParser.Parse_Block; +begin + DECLARE_SWITCH := true; + Parse_DeclarationPart; + Parse_CompoundStmt; +end; + +procedure TPascalParser.Parse_ProgramBlock(namespace_id: Integer); +var + B1, B2: Integer; +begin + {$IFDEF ZERO_NS} + namespace_id := 0; + {$ENDIF} + while IsCurrText('uses') do + Parse_UsesClause(false); + + Gen(OP_END_IMPORT, 0, 0, 0); + B1 := CodeCard; + + if namespace_id > 0 then + begin + BeginNamespace(namespace_id, false); + end; + + while IsCurrText('namespace') do + Parse_NamespaceDeclaration; + +// parse block + + DECLARE_SWITCH := true; + Parse_DeclarationPart; + + Gen(OP_END_INTERFACE_SECTION, CurrModule.ModuleNumber, 0, 0); + + Gen(OP_BEGIN_GLOBAL_BLOCK, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + +{$IFDEF HTML} + Inc(EXECUTABLE_SWITCH); + DECLARE_SWITCH := false; + Parse_StmtList; + Dec(EXECUTABLE_SWITCH); +{$ELSE} + Parse_CompoundStmt; +{$ENDIF} + + B2 := CodeCard; + + Gen(OP_EPILOGUE_GLOBAL_BLOCK, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + Gen(OP_EPILOGUE_GLOBAL_BLOCK2, 0, 0, 0); + + GenDestroyGlobalDynamicVariables(B1, B2); + + Gen(OP_NOP, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + Gen(OP_END_GLOBAL_BLOCK, 0, 0, 0); + + if IsCurrText('.') then + begin + // ok + end + else + begin +{$IFDEF HTML} + // ok + CALL_SCANNER; +{$ELSE} + MatchFinal('.'); +{$ENDIF} + end; + + if namespace_id > 0 then + EndNamespace(namespace_id, false); +end; + + +procedure TPascalParser.ParseExternalSub(SubId: Integer); +var + SubNameId, LibId, L, I: Integer; + S: String; + b: Boolean; +label + LabName; +begin + ReplaceForwardDeclaration(SubId); + + SetExternal(SubId, true); + + S := GetName(SubId); + L := GetLevel(SubId); + if L > 0 then + if GetKind(L) = KindTYPE then + begin + b := false; + for I := 0 to OuterList.Count - 1 do + if OuterList.Values[I] = L then + begin + S := ExtractFullName(OuterList.Keys[I]) + '.' + GetName(L) + '.' + S; + b := true; + break; + end; + + if not b then + S := GetName(L) + '.' + S; + end; + + SubNameId := NewConst(typeSTRING, S); + + ReadToken; // skip external + + EndSub(SubId); + + if ImportOnly then + begin + if IsCurrText(';') then + begin + Call_SCANNER; + Exit; + end; + end; + + if CurrToken.TokenClass = tcPCharConst then + begin + S := RemoveCh('''', CurrToken.Text); + LibId := NewConst(typeSTRING, S); + end + else + begin + LibId := Lookup(CurrToken.Text, CurrLevel); + if (LibId = 0) or (not IsStringConst(LibId)) then + LibId := Lookup(S, CurrLevel); + if not ImportOnly then + begin + if LibId = 0 then + RaiseError(errUndeclaredIdentifier, [S]); + if not IsStringConst(LibId) then + RaiseError(errIncompatibleTypesNoArgs, []); + end; + end; + + if ImportOnly then + if IsCurrText('name') then + goto LabName; + + + ReadToken; + RemoveSub; + + if IsCurrText(';') then + begin + Gen(OP_LOAD_PROC, SubId, SubNameId, LibId); + Match(';'); + end + else + begin + if IsCurrText('delayed') then + begin + RemoveLastIdent(CurrToken.Id); + Call_SCANNER; + Match(';'); + Exit; + end; + +LabName: + + Match('name'); + SubNameId := CurrToken.Id; + Gen(OP_LOAD_PROC, SubId, SubNameId, LibId); + if ImportOnly then + Parse_ConstantExpression + else + Call_SCANNER; + + if IsCurrText('delayed') then + begin + RemoveLastIdent(CurrToken.Id); + Call_SCANNER; + end; + + Match(';'); + end; +end; + +procedure TPascalParser.GenExternalSub(SubId: Integer); +var + SubNameId, LibId, namespace_id: Integer; + S, TypeName: String; +begin + namespace_id := GetLevel(SubId); + if GetKind(namespace_id) = kindTYPE then + TypeName := GetName(namespace_id) + else + TypeName := ''; + + while GetKind(namespace_id) <> kindNAMESPACE do + namespace_id := GetLevel(namespace_id); + + SetForward(SubId, false); + + SetExternal(SubId, true); + + ReplaceForwardDeclaration(SubId, true); + S := GetName(SubId); + if TypeName <> '' then + S := TypeName + '.' + S; + SubNameId := NewConst(typeSTRING, S); + EndSub(SubId); + RemoveSub; + + LibId := NewConst(typeSTRING, + GetName(namespace_id) + '.' + PCU_FILE_EXT); + + Gen(OP_LOAD_PROC, SubId, SubNameId, LibId); +end; + +procedure TPascalParser.Parse_Unit(IsExternalUnit: Boolean = false); +var + B1, B2: Integer; + + procedure Parse_InterfaceSection; + + procedure Parse_ProcedureHeading; + var + SubId: Integer; + DirectiveList: TIntegerList; + Declaration: String; + SavedPosition: Integer; + begin + SavedPosition := CurrToken.Position; + DECLARE_SWITCH := true; + Match('procedure'); + SubId := Parse_Ident; + BeginSub(SubId); + if Assigned(OnParseBeginSubDeclaration) then + OnParseBeginSubDeclaration(Owner, GetName(SubId), SubId); + try + Parse_FormalParameterList(SubId); + SetName(CurrResultId, ''); + SetKind(CurrResultId, KindNONE); + SetType(SubId, TypeVOID); + SetType(CurrResultId, TypeVOID); + + if InterfaceOnly then + begin + if IsCurrText(';') then + Match(';'); + end + else + Match(';'); + + DirectiveList := Parse_DirectiveList(SubId); + FreeAndNil(DirectiveList); + + if IsCurrText('external') then + begin + ParseExternalSub(SubId); + Exit; + end; + + if IsExternalUnit then + begin + GenExternalSub(SubId); + Exit; + end; + + SetForward(SubId, true); + EndSub(SubId); + finally + if Assigned(OnParseEndSubDeclaration) then + begin + Declaration := ExtractText(SavedPosition, PrevPosition + PrevLength - 1); + OnParseEndSubDeclaration(Owner, GetName(SubId), SubId, Declaration); + end; + end; + end; + + procedure Parse_FunctionHeading; + var + SubId, TypeId: Integer; + DirectiveList: TIntegerList; + Declaration, StrType: String; + SavedPosition: Integer; + begin + SavedPosition := CurrToken.Position; + DECLARE_SWITCH := true; + Match('function'); + SubId := Parse_Ident; + BeginSub(SubId); + if Assigned(OnParseBeginSubDeclaration) then + OnParseBeginSubDeclaration(Owner, GetName(SubId), SubId); + try + Parse_FormalParameterList(SubId); + DECLARE_SWITCH := false; + + StrType := ''; + + TypeId := 0; + if ImportOnly then + begin + if IsCurrText(':') then + begin + Match(':'); + Parse_Attribute; + DECLARE_SWITCH := true; + TypeID := Parse_Type; + StrType := GetName(TypeId); + Gen(OP_ASSIGN_TYPE, SubId, TypeID, 0); + Gen(OP_ASSIGN_TYPE, CurrResultId, TypeID, 0); + end; + end + else + begin + Match(':'); + Parse_Attribute; + DECLARE_SWITCH := true; + TypeID := Parse_Type; + StrType := GetName(TypeId); + Gen(OP_ASSIGN_TYPE, SubId, TypeID, 0); + Gen(OP_ASSIGN_TYPE, CurrResultId, TypeID, 0); + end; + + if Assigned(OnParseResultType) then + OnParseResultType(Owner, StrType, TypeId); + + DECLARE_SWITCH := true; + + if InterfaceOnly then + begin + if IsCurrText(';') then + Match(';'); + end + else + Match(';'); + + DirectiveList := Parse_DirectiveList(SubId); + FreeAndNil(DirectiveList); + + if IsCurrText('external') then + begin + ParseExternalSub(SubId); + Exit; + end; + + if IsExternalUnit then + begin + GenExternalSub(SubId); + Exit; + end; + + SetForward(SubId, true); + EndSub(SubId); + finally + Declaration := ExtractText(SavedPosition, PrevPosition + PrevLength - 1); + if Assigned(OnParseEndSubDeclaration) then + OnParseEndSubDeclaration(Owner, GetName(SubId), SubId, Declaration); + end; + end; + + var + ok: Boolean; + begin + Match('interface'); + while IsCurrText('uses') do + Parse_UsesClause(false); + if Assigned(OnParseEndUsedUnitList) then + OnParseEndUsedUnitList(Owner); + + Gen(OP_END_IMPORT, 0, 0, 0); + + B1 := CodeCard; + + repeat + ok := false; + if IsCurrText('var') then + begin + Parse_VariableDeclaration; + ok := true; + end + else if IsCurrText('threadvar') then + begin + Parse_VariableDeclaration; + ok := true; + end + else if IsCurrText('const') then + begin + Parse_ConstantDeclaration; + ok := true; + end + else if IsCurrText('resourcestring') then + begin + Parse_ResourcestringDeclaration; + ok := true; + end + else if IsCurrText('procedure') then + begin + Parse_ProcedureHeading; + ok := true; + end + else if IsCurrText('function') then + begin + Parse_FunctionHeading; + ok := true; + end + else if IsCurrText('type') then + begin + Parse_TypeDeclaration(IsExternalUnit); + ok := true; + end + until not ok; + end; // interface section + + procedure Parse_ImplementationSection; + var + I, InnerTypeId, OuterTypeId: Integer; + S, OldFullName: String; + R: TPaxClassFactoryRec; + begin + for I := 0 to OuterList.Count - 1 do + begin + S := OuterList.Keys[I]; + InnerTypeId := OuterList.Values[I]; + OuterTypeId := TKernel(kernel).SymbolTable.LookupFullName(S, true); + if OuterTypeId = 0 then + RaiseError(errUndeclaredIdentifier, [S]); + OldFullName := GetFullName(InnerTypeId); + R := TKernel(kernel).ClassFactory.FindRecordByFullName(OldFullName); + if R = nil then + RaiseError(errInternalError, [S]); + R.FullClassName := S + '.' + GetName(InnerTypeId); + + SetLevel(InnerTypeId, OuterTypeId); + end; + + IMPLEMENTATION_SECTION := true; + Match('implementation'); + while IsCurrText('uses') do + Parse_UsesClause(true); + Parse_DeclarationPart(true); + end; + + procedure Parse_InitSection; + begin + DECLARE_SWITCH := false; + if IsCurrText('initialization') then + begin + BeginInitialization; + + Gen(OP_BEGIN_GLOBAL_BLOCK, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + + Call_SCANNER; + Parse_StmtList; + + Gen(OP_EPILOGUE_GLOBAL_BLOCK, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + + Gen(OP_EPILOGUE_GLOBAL_BLOCK2, 0, 0, 0); + + Gen(OP_NOP, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + Gen(OP_END_GLOBAL_BLOCK, 0, 0, 0); + + EndInitialization; + if IsCurrText('finalization') then + begin + BeginFinalization; + + Gen(OP_BEGIN_GLOBAL_BLOCK, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + + Call_SCANNER; + Parse_StmtList; + + B2 := CodeCard; + + Gen(OP_EPILOGUE_GLOBAL_BLOCK, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + Gen(OP_EPILOGUE_GLOBAL_BLOCK2, 0, 0, 0); + + GenDestroyGlobalDynamicVariables(B1, B2); + + Gen(OP_NOP, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + Gen(OP_END_GLOBAL_BLOCK, 0, 0, 0); + + EndFinalization; + end + else + begin + BeginFinalization; + + Gen(OP_BEGIN_GLOBAL_BLOCK, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + + B2 := CodeCard; + + Gen(OP_EPILOGUE_GLOBAL_BLOCK, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + Gen(OP_EPILOGUE_GLOBAL_BLOCK2, 0, 0, 0); + + GenDestroyGlobalDynamicVariables(B1, B2); + + Gen(OP_NOP, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + Gen(OP_END_GLOBAL_BLOCK, 0, 0, 0); + + EndFinalization; + end; + + Match('end'); + end + else if IsCurrText('begin') then + begin + BeginInitialization; + + Gen(OP_BEGIN_GLOBAL_BLOCK, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + + Call_SCANNER; + Parse_StmtList; + + Gen(OP_EPILOGUE_GLOBAL_BLOCK, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + Gen(OP_EPILOGUE_GLOBAL_BLOCK2, 0, 0, 0); + + Gen(OP_NOP, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + Gen(OP_END_GLOBAL_BLOCK, 0, 0, 0); + + EndInitialization; + Match('end'); + + BeginFinalization; + + Gen(OP_BEGIN_GLOBAL_BLOCK, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + + B2 := CodeCard; + + Gen(OP_EPILOGUE_GLOBAL_BLOCK, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + Gen(OP_EPILOGUE_GLOBAL_BLOCK2, 0, 0, 0); + + GenDestroyGlobalDynamicVariables(B1, B2); + + Gen(OP_NOP, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + Gen(OP_END_GLOBAL_BLOCK, 0, 0, 0); + + EndFinalization; + + end + else if IsCurrText('finalization') then + begin + BeginFinalization; + + Gen(OP_BEGIN_GLOBAL_BLOCK, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + + Call_SCANNER; + Parse_StmtList; + + B2 := CodeCard; + + Gen(OP_EPILOGUE_GLOBAL_BLOCK, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + Gen(OP_EPILOGUE_GLOBAL_BLOCK2, 0, 0, 0); + + GenDestroyGlobalDynamicVariables(B1, B2); + + Gen(OP_NOP, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + Gen(OP_END_GLOBAL_BLOCK, 0, 0, 0); + + EndFinalization; + Match('end'); + end + else if IsCurrText('end') then + begin + BeginFinalization; + + Gen(OP_BEGIN_GLOBAL_BLOCK, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + + Call_SCANNER; + + B2 := CodeCard; + + Gen(OP_EPILOGUE_GLOBAL_BLOCK, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + Gen(OP_EPILOGUE_GLOBAL_BLOCK2, 0, 0, 0); + + GenDestroyGlobalDynamicVariables(B1, B2); + + Gen(OP_NOP, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + Gen(OP_NOP, 0, 0, 0); + Gen(OP_END_GLOBAL_BLOCK, 0, 0, 0); + + EndFinalization; + end + else + Match('end'); + end; + +var + namespace_name: String; + namespace_id: Integer; +begin + DECLARE_SWITCH := true; + Match('unit'); + namespace_id := Parse_UnitName(namespace_name); + if Assigned(OnParseUnitName) then + OnParseUnitName(Owner, namespace_name, namespace_id); + + if CurrModule.IsExtra then + SaveExtraNamespace(namespace_id); + + Parse_PortabilityDirective; + Match(';'); + Parse_InterfaceSection; + + if IsExternalUnit then + begin + Match('implementation'); + Exit; + end; + + Gen(OP_END_INTERFACE_SECTION, CurrModule.ModuleNumber, 0, 0); + + if InterfaceOnly then + begin + if Assigned(OnParseImplementationSection) then + OnParseImplementationSection(Owner); + if ImportOnly then + Exit; + Match('implementation'); + while not scanner.IsEOF do + ReadToken; + EndNamespace(namespace_id); + end + else + begin + Parse_ImplementationSection; + Inc(EXECUTABLE_SWITCH); + Parse_InitSection; + Dec(EXECUTABLE_SWITCH); + EndNamespace(namespace_id); + MatchFinal('.'); + end; +end; + +procedure TPascalParser.Parse_VariableDeclaration(vis: TClassVisibility = cvNone); +var + L: TIntegerList; + I, ID, TypeID, ExprID: Integer; + S, Declaration: String; + VarNameId, LibId: Integer; +begin + L := TIntegerList.Create; + try + if InterfaceOnly then + Gen(OP_BEGIN_VAR, 0, 0, 0); + + DECLARE_SWITCH := true; + if IsCurrText('threadvar') then + Call_SCANNER + else + Match('var'); + + repeat + Parse_Attribute; + + L.Clear; + repeat + ID := Parse_Ident; + SetVisibility(ID, vis); + Gen(OP_DECLARE_LOCAL_VAR, CurrLevel, ID, 0); + L.Add(ID); + if NotMatch(',') then break; + until false; + DECLARE_SWITCH := false; + + if EXPLICIT_OFF then + begin + TypeId := 0; + if IsCurrText(';') then + begin + //ok + end + else + begin + Match(':'); + TypeID := Parse_Type; + end; + end + else + begin + Match(':'); + TypeID := Parse_Type; + end; + + for I:=0 to L.Count - 1 do + Gen(OP_ASSIGN_TYPE, L[I], TypeID, 0); + + S := ''; + if IsCurrText('absolute') then + begin + RemoveLastIdent(CurrToken.Id); + + DECLARE_SWITCH := false; + + Call_SCANNER; + ExprId := Parse_Ident; + for I:=0 to L.Count - 1 do + Gen(OP_ABSOLUTE, L[I], ExprID, 0); + end + else if IsCurrText('=') then + begin + if GetKind(CurrLevel) = KindSUB then + CreateError(errCannotInitializeLocalVariables, []); + DECLARE_SWITCH := false; + + Match('='); + + Id := L[0]; + BeginInitConst(Id); + + ExprID := Parse_VariableInitialization; + S := ExtractText(PrevPosition, PrevPosition + PrevLength - 1); + for I:=0 to L.Count - 1 do + Gen(OP_ASSIGN, L[I], ExprID, L[I]); + + EndInitConst(Id); + end; + + Parse_PortabilityDirective; + + if Assigned(OnParseVariableDeclaration) then + for I:=0 to L.Count - 1 do + begin + if S = '' then + Declaration := GetName(L[I]) + ':' + GetName(TypeID) + ';' + else + Declaration := GetName(L[I]) + ':' + GetName(TypeID) + '=' + ';'; + + OnParseVariableDeclaration(Owner, GetName(L[I]), L[I], GetName(TypeID), + Declaration); + end; + + DECLARE_SWITCH := true; + if not MatchEx(';') then + break; + + if IsCurrText('external') then + begin + SetExternal(Id, true); + + S := GetName(Id); + VarNameId := NewConst(typeSTRING, S); + ReadToken; // skip external + if CurrToken.TokenClass = tcPCharConst then + begin + S := RemoveCh('''', CurrToken.Text); + LibId := NewConst(typeSTRING, S); + end + else + begin + LibId := Lookup(S, CurrLevel); + + if LibId = 0 then + RaiseError(errUndeclaredIdentifier, [S]); + + if not IsStringConst(LibId) then + RaiseError(errIncompatibleTypesNoArgs, []); + end; + + ReadToken; + Gen(OP_LOAD_PROC, Id, VarNameId, LibId); + Match(';'); + Exit; + end; + + + until CurrToken.TokenClass <> tcIdentifier; + + finally + if InterfaceOnly then + Gen(OP_END_VAR, 0, 0, 0); + + FreeAndNil(L); + end; +end; + +procedure TPascalParser.Parse_ConstantDeclaration(vis: TClassVisibility = cvNone); +var + ID: Integer; + S: String; + VarNameId, LibId, ConstId, TypeId: Integer; + Declaration: String; + SavedPosition: Integer; + IsBuildingPCU: Boolean; +begin + IsBuildingPCU := BuildingAll; + + Gen(OP_EMIT_OFF, 0, 0, 0); + try + + DECLARE_SWITCH := true; + Match('const'); + + repeat + Parse_Attribute; + + SavedPosition := CurrToken.Position; + ID := Parse_Ident; + + SetVisibility(Id, vis); + + if InterfaceOnly then + Gen(OP_BEGIN_CONST, Id, 0, 0); + + Gen(OP_DECLARE_LOCAL_VAR, CurrLevel, ID, 0); + + SetKind(ID, kindCONST); + DECLARE_SWITCH := false; + if IsCurrText(':') then + begin + Match(':'); + TypeId := Parse_Type; + Gen(OP_ASSIGN_TYPE, ID, TypeId, 0); + + if not ImportOnly then + levelStack.Push(CurrNamespaceId); + Match('='); + Parse_ConstantInitialization(ID); + if Assigned(OnParseTypedConstantDeclaration) then + begin + Declaration := ExtractText(SavedPosition, + CurrToken.Position + CurrToken.Length - 1); + OnParseTypedConstantDeclaration(Owner, + GetName(ID), ID, GetName(TypeId), GetValue(ID), Declaration); + end; + if not ImportOnly then + levelStack.Pop; + end + else + begin + if not ImportOnly then + levelStack.Push(CurrNamespaceId); + Match('='); + if IsBuildingPCU or IsCurrText('[') then + begin + Parse_ConstantInitialization(ID); + ConstId := Id; + end + else + begin + ConstId := Parse_ConstantExpression; + if TKernel(kernel).SignCodeCompletion then + SetType(ID, GetSymbolRec(ConstId).TypeID); + + Gen(OP_ASSIGN_CONST, ID, ConstId, ID); + end; + if Assigned(OnParseConstantDeclaration) then + begin + Declaration := ExtractText(SavedPosition, + CurrToken.Position + CurrToken.Length - 1); + OnParseConstantDeclaration(Owner, GetName(ID), ID, GetValue(ConstID), Declaration); + end; + if not ImportOnly then + levelStack.Pop; + end; + + DECLARE_SWITCH := true; + + if InterfaceOnly then + Gen(OP_END_CONST, Id, 0, 0); + + Parse_PortabilityDirective; + + if not MatchEx(';') then + break; + + if IsCurrText('external') then + begin + S := GetName(Id); + VarNameId := NewConst(typeSTRING, S); + ReadToken; // skip external + if CurrToken.TokenClass = tcPCharConst then + begin + S := RemoveCh('''', CurrToken.Text); + LibId := NewConst(typeSTRING, S); + end + else + begin + LibId := Lookup(S, CurrLevel); + + if LibId = 0 then + RaiseError(errUndeclaredIdentifier, [S]); + + if not IsStringConst(LibId) then + RaiseError(errIncompatibleTypesNoArgs, []); + end; + + ReadToken; + Gen(OP_LOAD_PROC, Id, VarNameId, LibId); + Match(';'); + Exit; + end; + + until CurrToken.TokenClass <> tcIdentifier; + + finally + Gen(OP_EMIT_ON, 0, 0, 0); + end; +end; + +procedure TPascalParser.Parse_ResourcestringDeclaration; +var + ID: Integer; + Value: Variant; + Declaration: String; + IsBuildingPCU: Boolean; +begin + IsBuildingPCU := BuildingAll; + + Gen(OP_EMIT_OFF, 0, 0, 0); + try + + DECLARE_SWITCH := true; + Match('resourcestring'); + + repeat + + ID := Parse_Ident; + Gen(OP_DECLARE_LOCAL_VAR, CurrLevel, ID, 0); + + SetKind(ID, kindCONST); + DECLARE_SWITCH := false; + Match('='); + if IsBuildingPCU then + Parse_ConstantInitialization(ID) + else + Gen(OP_ASSIGN_CONST, ID, Parse_ConstantExpression, ID); + + if Assigned(OnParseConstantDeclaration) then + begin + Value := GetValue(Id); + if not VariantIsString(Value) then + Value := String(Chr(Integer(Value))); + Declaration := GetName(Id) + ' = ' + Value; + OnParseResourceStringDeclaration(Owner, GetName(ID), ID, Value, Declaration); + end; + + Parse_PortabilityDirective; + + DECLARE_SWITCH := true; + if not MatchEx(';') then + break; + + until CurrToken.TokenClass <> tcIdentifier; + + finally + Gen(OP_EMIT_ON, 0, 0, 0); + end; +end; + +procedure TPascalParser.Parse_ConstantInitialization(ID: Integer); +var + ExprId, ItemId, NameId, K, ConstId: Integer; +begin + BeginInitConst(Id); + + if IsCurrText('(') then + begin + K := -1; + Call_SCANNER; + repeat + if IsCurrText(')') then + break; + + Inc(K); + if IsCurrText('(') then + begin + ExprId := NewTempVar(); + SetLevel(ExprId, 0); + Parse_ConstantInitialization(ExprId); + Gen(OP_ASSIGN_SHIFT, 0, K, ExprId); + if NotMatch(',') then + break; + end + else + begin + ItemId := NewTempVar(); + SetLevel(ItemId, 0); + + if IsNextText(':') then + begin + SetName(CurrToken.Id, ''); + SetKind(CurrToken.Id, KindNONE); + NameId := NewConst(typeSTRING, CurrToken.Text); + SetKind(NameId, kindNONE); + + Call_SCANNER; + Match(':'); + if IsCurrText('(') then + begin + ExprId := NewTempVar(); + SetLevel(ExprId, 0); + + Parse_ConstantInitialization(ExprId); + Gen(OP_ASSIGN_SHIFT, 0, K, ExprId); + end + else + begin + ExprId := Parse_ConstantExpression; + Gen(OP_RECORD_ITEM, ID, NameId, ItemId); + Gen(OP_ASSIGN, ItemId, ExprId, ItemId); + end; + if NotMatch(';') then + break; + end + else + begin + ExprId := Parse_ConstantExpression; + Gen(OP_ITEM, ID, K, ItemId); + Gen(OP_ASSIGN, ItemId, ExprId, ItemId); + if NotMatch(',') then + break; + end; + end; + until false; + Match(')'); + end + else + begin + ConstId := Parse_ConstantExpression; + Gen(OP_ASSIGN, ID, ConstId, ID); + SetValue(Id, GetValue(ConstId)); + end; + + EndInitConst(Id); +end; + +function TPascalParser.Parse_VariableInitialization: Integer; +var + ExprId, ItemId, NameId, K: Integer; +begin + if IsCurrText('(') then + begin + result := NewTempVar; + K := -1; + Call_SCANNER; + repeat + if IsCurrText(')') then + break; + + Inc(K); + if IsCurrText('(') then + begin + ExprId := NewTempVar(); + SetLevel(ExprId, 0); + Gen(OP_ASSIGN, ExprId, Parse_VariableInitialization, ExprId); + Gen(OP_ASSIGN_SHIFT, 0, K, ExprId); + if NotMatch(',') then + break; + end + else + begin + ItemId := NewTempVar(); + SetLevel(ItemId, 0); + + if IsNextText(':') then + begin + SetName(CurrToken.Id, ''); + SetKind(CurrToken.Id, KindNONE); + NameId := NewConst(typeSTRING, CurrToken.Text); + SetKind(NameId, kindNONE); + + Call_SCANNER; + Match(':'); + if IsCurrText('(') then + begin + ExprId := NewTempVar(); + SetLevel(ExprId, 0); + + Gen(OP_ASSIGN, ExprId, Parse_VariableInitialization, ExprId); + Gen(OP_ASSIGN_SHIFT, 0, K, ExprId); + end + else + begin + ExprId := Parse_Expression; + Gen(OP_RECORD_ITEM, result, NameId, ItemId); + Gen(OP_ASSIGN, ItemId, ExprId, ItemId); + end; + if NotMatch(';') then + break; + end + else + begin + ExprId := Parse_Expression; + Gen(OP_ITEM, result, K, ItemId); + Gen(OP_ASSIGN, ItemId, ExprId, ItemId); + if NotMatch(',') then + break; + end; + end; + until false; + Match(')'); + end + else + result := Parse_Expression; +end; + +procedure TPascalParser.Parse_LabelDeclaration; +begin + DECLARE_SWITCH := true; + Match('label'); + repeat + Parse_Label; + if NotMatch(',') then break; + until false; + Match(';'); +end; + +procedure TPascalParser.Parse_TypeDeclaration(IsExternalUnit: Boolean = false; + vis: TClassVisibility = cvPublic); +var + ok: Boolean; + TypeID, T, SubId, TypeBaseId: Integer; + IsPacked: Boolean; + S, Q: String; +begin + TypeParams.Clear; + DECLARE_SWITCH := true; + Match('type'); + repeat + Parse_Attribute; + + BeginTypeDef(CurrToken.Id); + TypeId := Parse_Ident; + SetVisibility(TypeId, vis); + SetKind(TypeId, KindTYPE); + SetLevel(TypeId, CurrLevel); + + if Assigned(OnParseTypeDeclaration) then + OnParseTypeDeclaration(Owner, GetName(TypeId), TypeId); + + S := GetFullName(TypeId); + while IsCurrText('.') do + begin + SetKind(TypeId, KindNONE); + SetName(TypeId, ''); + + Call_SCANNER; + TypeId := Parse_Ident; + + S := S + '.' + GetName(TypeId); + end; + + if S <> GetFullName(TypeId) then + begin + S := ExtractFullOwner(S); + OuterList.AddValue(S, TypeId); + end; + + SetKind(TypeID, KindTYPE); + if InterfaceOnly then + Gen(OP_BEGIN_TYPE, TypeId, 0, 0); + + DECLARE_SWITCH := false; + Match('='); + ok := false; + + if IsCurrText('packed') then + begin + Match('packed'); + IsPacked := true; + end + else + IsPacked := false; + + if IsCurrText('array') then + begin + IsPacked := true; + Parse_ArrayTypeDeclaration(TypeID, IsPacked); + Parse_PortabilityDirective; + + EndTypeDef(TypeId); + + DECLARE_SWITCH := true; + ok := MatchEx(';'); + end + else if IsCurrText('record') then + begin + DECLARE_SWITCH := true; + Parse_RecordTypeDeclaration(TypeID, IsPacked); + Parse_PortabilityDirective; + + EndTypeDef(TypeId); + + DECLARE_SWITCH := true; + ok := MatchEx(';'); + end + else if IsCurrText('class') then + begin + IsPacked := true; + DECLARE_SWITCH := true; + Parse_ClassTypeDeclaration(TypeID, IsPacked, IsExternalUnit); + Parse_PortabilityDirective; + + EndTypeDef(TypeId); + + DECLARE_SWITCH := true; + ok := MatchEx(';'); + end + else if IsCurrText('interface') then + begin + DECLARE_SWITCH := true; + Parse_InterfaceTypeDeclaration(TypeID); + Parse_PortabilityDirective; + + EndTypeDef(TypeId); + + DECLARE_SWITCH := true; + ok := MatchEx(';'); + end + else if IsCurrText('dispinterface') then + begin + if not ImportOnly then + RaiseNotImpl; + + DECLARE_SWITCH := true; + Parse_InterfaceTypeDeclaration(TypeID); + Parse_PortabilityDirective; + + EndTypeDef(TypeId); + + DECLARE_SWITCH := true; + ok := MatchEx(';'); + end + else if IsCurrText('reference') then + begin + RemoveLastIdent(CurrToken.Id); + DECLARE_SWITCH := true; + Call_SCANNER; + Match('to'); + Parse_MethodRefTypeDeclaration(TypeID); + Parse_PortabilityDirective; + + DECLARE_SWITCH := true; + ok := true; + end + else if IsCurrText('^') then + begin + if IsPacked then + CreateError(errPACKEDNotAllowedHere, []); + if TypeParams.Count > 0 then + RaiseError(errTypeParameterNotAllowed, []); + + Parse_PointerTypeDeclaration(TypeID); + Parse_PortabilityDirective; + + DECLARE_SWITCH := true; + ok := MatchEx(';'); + end + else if IsCurrText('(') then + begin + if IsPacked then + CreateError(errPACKEDNotAllowedHere, []); + if TypeParams.Count > 0 then + RaiseError(errTypeParameterNotAllowed, []); + + DECLARE_SWITCH := true; + Parse_EnumTypeDeclaration(TypeID); + Parse_PortabilityDirective; + + DECLARE_SWITCH := true; + ok := MatchEx(';'); + end + else if IsCurrText('procedure') or IsCurrText('function') then + begin + if IsPacked then + CreateError(errPACKEDNotAllowedHere, []); + + DECLARE_SWITCH := true; + Parse_ProceduralTypeDeclaration(TypeID, SubId); + + EndTypeDef(TypeId); + + DECLARE_SWITCH := true; + if InterfaceOnly then + begin + if IsCurrText(';') then + ok := MatchEx(';'); + end + else + ok := MatchEx(';'); + end + else if IsCurrText('set') then + begin + if IsPacked then + CreateError(errPACKEDNotAllowedHere, []); + if TypeParams.Count > 0 then + RaiseError(errTypeParameterNotAllowed, []); + + DECLARE_SWITCH := true; + Parse_SetTypeDeclaration(TypeID); + Parse_PortabilityDirective; + + DECLARE_SWITCH := true; + ok := MatchEx(';'); + end + else if CurrToken.TokenClass = tcIntegerConst then + begin + if IsPacked then + CreateError(errPACKEDNotAllowedHere, []); + if TypeParams.Count > 0 then + RaiseError(errTypeParameterNotAllowed, []); + + Parse_SubrangeTypeDeclaration(TypeID, typeINTEGER, Q, 0); + Parse_PortabilityDirective; + + DECLARE_SWITCH := true; + ok := MatchEx(';'); + end + else if CurrToken.TokenClass = tcCharConst then + begin + if IsPacked then + CreateError(errPACKEDNotAllowedHere, []); + if TypeParams.Count > 0 then + RaiseError(errTypeParameterNotAllowed, []); + + Parse_SubrangeTypeDeclaration(TypeID, typeCHAR, Q, 0); + Parse_PortabilityDirective; + + DECLARE_SWITCH := true; + ok := MatchEx(';'); + end + else if CurrToken.TokenClass = tcBooleanConst then + begin + if IsPacked then + CreateError(errPACKEDNotAllowedHere, []); + if TypeParams.Count > 0 then + RaiseError(errTypeParameterNotAllowed, []); + + Parse_SubrangeTypeDeclaration(TypeID, typeBOOLEAN, Q, 0); + Parse_PortabilityDirective; + + DECLARE_SWITCH := true; + ok := MatchEx(';'); + end + else + begin + if IsPacked then + CreateError(errPACKEDNotAllowedHere, []); + + if IsCurrText('type') then + begin + Call_SCANNER; + if IsCurrText('of') then + Call_SCANNER; + end; + + if IsCurrText('string') then + begin + Call_SCANNER; + if IsCurrText('[') then + begin +{$IFDEF PAXARM} + Match(';'); +{$ELSE} + Parse_ShortStringTypeDeclaration(TypeID); +{$ENDIF} + end + else + begin + if InterfaceOnly then + Gen(OP_BEGIN_ALIAS_TYPE, TypeId, 0, 0); + SetType(TypeId, typeALIAS); + Gen(OP_ASSIGN_TYPE_ALIAS, TypeId, typeSTRING, 0); + if Assigned(OnParseAliasTypeDeclaration) then + OnParseAliasTypeDeclaration(Owner, GetName(TypeId), TypeId, 'string', + GetName(TypeId) + ' = string;'); + if InterfaceOnly then + Gen(OP_END_ALIAS_TYPE, TypeId, 0, 0); + end; + end + else + begin + case CurrToken.TokenClass of + tcSpecial: typeBaseId := typeINTEGER; + tcIntegerConst: typeBaseId := typeINTEGER; + tcCharConst: typeBaseId := typeCHAR; + tcBooleanConst: typeBaseId := typeBOOLEAN; + tcIdentifier: typeBaseId := GetType(CurrToken.Id); + else + TypeBaseId := typeINTEGER; + end; + + T := Parse_Expression; + + if IsCurrText('..') then + Parse_SubrangeTypeDeclaration(TypeID, TypeBaseId, Q, T) + else + begin + if InterfaceOnly then + Gen(OP_BEGIN_ALIAS_TYPE, TypeId, 0, 0); + SetType(TypeId, typeALIAS); + Gen(OP_ASSIGN_TYPE_ALIAS, TypeId, T, 0); + if Assigned(OnParseAliasTypeDeclaration) then + OnParseAliasTypeDeclaration(Owner, GetName(TypeId), TypeId, GetName(T), + GetName(TypeId) + ' = ' + GetName(T) + ';'); + if InterfaceOnly then + Gen(OP_END_ALIAS_TYPE, TypeId, 0, 0); + end; + end; + + Parse_PortabilityDirective; + + DECLARE_SWITCH := true; + TypeParams.Clear; + ok := MatchEx(';'); + end; + + Gen(OP_ADD_TYPEINFO, TypeId, 0, 0); + + if InterfaceOnly then + Gen(OP_END_TYPE, TypeId, 0, 0); + + if CurrToken.TokenClass = tcKeyword then + Break; + until not ok; +end; + +function TPascalParser.Parse_OrdinalType(var Declaration: String): Integer; +var + T: Integer; +begin + Declaration := ''; + if IsCurrText('(') then + begin + result := NewTempVar; + Parse_EnumTypeDeclaration(result); + end + else if (CurrToken.TokenClass = tcIntegerConst) or IsCurrText('-') then + begin + result := NewTempVar; + Parse_SubrangeTypeDeclaration(result, typeINTEGER, Declaration, 0); + end + else if CurrToken.TokenClass = tcCharConst then + begin + result := NewTempVar; + Parse_SubrangeTypeDeclaration(result, typeCHAR, Declaration, 0); + end + else if CurrToken.TokenClass = tcBooleanConst then + begin + result := NewTempVar; + Parse_SubrangeTypeDeclaration(result, typeBOOLEAN, Declaration, 0); + end + else if IsCurrText('ord') and IsNextText('(') then + begin + result := NewTempVar; + Parse_SubrangeTypeDeclaration(result, typeBYTE, Declaration, 0); + end + else if IsCurrText('chr') and IsNextText('(') then + begin + result := NewTempVar; + Parse_SubrangeTypeDeclaration(result, typeCHAR, Declaration, 0); + end + else if IsCurrText('low') and IsNextText('(') then + begin + result := NewTempVar; + Parse_SubrangeTypeDeclaration(result, typeBYTE, Declaration, 0); + end + else if IsCurrText('high') and IsNextText('(') then + begin + result := NewTempVar; + Parse_SubrangeTypeDeclaration(result, typeBYTE, Declaration, 0); + end + else + begin + T := Parse_QualId; + + if IsCurrText('..') then + begin + result := NewTempVar; + Parse_SubrangeTypeDeclaration(result, typeENUM, Declaration, T); + end + else + begin + result := T; + Declaration := GetName(T); +// AddTypeExpRec(result); + end; + end; +end; + +function TPascalParser.Parse_OpenArrayType(var ElemTypeName: String): Integer; +begin + DECLARE_SWITCH := true; + Match('array'); + DECLARE_SWITCH := false; + Match('of'); + ElemTypeName := CurrToken.Text; + if IsCurrText('const') then + begin + Call_SCANNER; + result := H_Dynarray_TVarRec; + end + else if IsCurrText('Integer') then + begin + Call_SCANNER; + result := H_Dynarray_Integer; + end +{$IFDEF UNIC} + else if IsCurrText('String') then + begin + ElemTypeName := 'UnicodeString'; + Call_SCANNER; + result := H_Dynarray_UnicodeString; + end + else if IsCurrText('Char') then + begin + ElemTypeName := 'WideChar'; + Call_SCANNER; + result := H_Dynarray_AnsiChar; + end +{$ELSE} + else if IsCurrText('String') then + begin + ElemTypeName := 'AnsiString'; + Call_SCANNER; + result := H_Dynarray_AnsiString; + end + else if IsCurrText('Char') then + begin + ElemTypeName := 'AnsiChar'; + Call_SCANNER; + result := H_Dynarray_WideChar; + end +{$ENDIF} + else if IsCurrText('Byte') then + begin + Call_SCANNER; + result := H_Dynarray_Byte; + end + else if IsCurrText('Word') then + begin + Call_SCANNER; + result := H_Dynarray_Word; + end + else if IsCurrText('ShortInt') then + begin + Call_SCANNER; + result := H_Dynarray_ShortInt; + end + else if IsCurrText('SmallInt') then + begin + Call_SCANNER; + result := H_Dynarray_SmallInt; + end + else if IsCurrText('Cardinal') then + begin + Call_SCANNER; + result := H_Dynarray_Cardinal; + end + else if IsCurrText('Int64') then + begin + Call_SCANNER; + result := H_Dynarray_Int64; + end + else if IsCurrText('UInt64') then + begin + Call_SCANNER; + result := H_Dynarray_UInt64; + end + else if IsCurrText('AnsiChar') then + begin + Call_SCANNER; + result := H_Dynarray_AnsiChar; + end + else if IsCurrText('WideChar') then + begin + Call_SCANNER; + result := H_Dynarray_WideChar; + end + else if IsCurrText('AnsiString') then + begin + Call_SCANNER; + result := H_Dynarray_AnsiString; + end + else if IsCurrText('WideString') then + begin + Call_SCANNER; + result := H_Dynarray_WideString; + end + else if IsCurrText('UnicodeString') then + begin + Call_SCANNER; + result := H_Dynarray_UnicodeString; + end + else if IsCurrText('ShortString') then + begin + Call_SCANNER; + result := H_Dynarray_ShortString; + end + else if IsCurrText('Double') then + begin + Call_SCANNER; + result := H_Dynarray_Double; + end + else if IsCurrText('Single') then + begin + Call_SCANNER; + result := H_Dynarray_Single; + end + else if IsCurrText('Extended') then + begin + Call_SCANNER; + result := H_Dynarray_Extended; + end + else if IsCurrText('Currency') then + begin + Call_SCANNER; + result := H_Dynarray_Currency; + end + else if IsCurrText('Boolean') then + begin + Call_SCANNER; + result := H_Dynarray_Boolean; + end + else if IsCurrText('ByteBool') then + begin + Call_SCANNER; + result := H_Dynarray_ByteBool; + end + else if IsCurrText('WordBool') then + begin + Call_SCANNER; + result := H_Dynarray_WordBool; + end + else if IsCurrText('LongBool') then + begin + Call_SCANNER; + result := H_Dynarray_LongBool; + end + else if IsCurrText('Variant') then + begin + Call_SCANNER; + result := H_Dynarray_Variant; + end + else if IsCurrText('OleVariant') then + begin + Call_SCANNER; + result := H_Dynarray_OleVariant; + end + else if IsCurrText('Pointer') then + begin + Call_SCANNER; + result := H_Dynarray_Pointer; + end + else + begin + result := NewTempVar; + BeginOpenArrayType(result); + Gen(OP_CREATE_DYNAMIC_ARRAY_TYPE, result, Parse_Ident, 0); + EndOpenArrayType(result, ElemTypeName); + end; + DECLARE_SWITCH := false; +end; + +function TPascalParser.Parse_Type: Integer; +var + IsPacked: Boolean; + SubId: Integer; + S: String; +begin + IsPacked := false; + + if IsCurrText('packed') then + begin + Match('packed'); + IsPacked := true; + end + else if IsCurrText('System') then + begin + Match('System'); + Match('.'); + end; + + if IsCurrText('array') then + begin + result := NewTempVar; + DECLARE_SWITCH := true; + Parse_ArrayTypeDeclaration(result, IsPacked); + DECLARE_SWITCH := false; + end + else if IsCurrText('record') then + begin + result := NewTempVar; + DECLARE_SWITCH := true; + Parse_RecordTypeDeclaration(result, IsPacked); + DECLARE_SWITCH := false; + end + else if IsCurrText('class') then + begin + result := NewTempVar; + DECLARE_SWITCH := true; + Parse_ClassTypeDeclaration(result, IsPacked); + DECLARE_SWITCH := false; + end + else if IsCurrText('interface') then + begin + result := NewTempVar; + DECLARE_SWITCH := true; + Parse_InterfaceTypeDeclaration(result); + DECLARE_SWITCH := false; + end + else if IsCurrText('dispinterface') then + begin + result := NewTempVar; + DECLARE_SWITCH := true; + Parse_InterfaceTypeDeclaration(result); + DECLARE_SWITCH := false; + end + else if IsCurrText('reference') then + begin + RemoveLastIdent(CurrToken.Id); + result := NewTempVar; + DECLARE_SWITCH := true; + Call_SCANNER; + Match('to'); + Parse_MethodRefTypeDeclaration(result); + DECLARE_SWITCH := false; + end + else if IsCurrText('^') then + begin + result := NewTempVar; + Parse_PointerTypeDeclaration(result); + DECLARE_SWITCH := false; + end + else if IsCurrText('set') then + begin + result := NewTempVar; + Parse_SetTypeDeclaration(result); + DECLARE_SWITCH := false; + end + else if IsCurrText('procedure') or IsCurrText('function') then + begin + result := NewTempVar; + Parse_ProceduralTypeDeclaration(result, SubId); + DECLARE_SWITCH := false; + end + else if IsCurrText('string') then + begin +// result := Parse_Ident; +{$IFDEF PAXARM} + result := typeUNICSTRING; +{$ELSE} + if IsUNIC then + result := typeUNICSTRING + else + result := typeANSISTRING; +{$ENDIF} + + Call_SCANNER; + + if IsCurrText('[') then + begin + result := NewTempVar; +{$IFDEF PAXARM} + Match(';'); +{$ELSE} + Parse_ShortStringTypeDeclaration(result); +{$ENDIF} + DECLARE_SWITCH := false; + end; + end + else if IsCurrText('double') then + begin + result := Parse_Ident; + end + else + begin + result := Parse_OrdinalType(S); + end; + + Gen(OP_ADD_TYPEINFO, result, 0, 0); +end; + +procedure TPascalParser.Parse_ArrayTypeDeclaration(ArrayTypeID: Integer; IsPacked: Boolean); +var + I, T, RangeTypeId, ElemTypeId: Integer; + L: TIntegerList; + RangeList: TStringList; + Declaration, S: String; +begin + L := TIntegerList.Create; + RangeList := TStringList.Create; + + try + Match('array'); + DECLARE_SWITCH := false; + + if IsCurrText('of') then // dynamic array + begin + Match('of'); + BeginDynamicArrayType(ArrayTypeID); + if IsCurrText('const') then + begin + Call_SCANNER; + Gen(OP_CREATE_DYNAMIC_ARRAY_TYPE, ArrayTypeId, H_TVarRec, 0); + ElemTypeId := H_TVarRec; + end + else + begin + ElemTypeId := Parse_Type; + Gen(OP_CREATE_DYNAMIC_ARRAY_TYPE, ArrayTypeId, ElemTypeId, 0); + end; + EndDynamicArrayType(ArrayTypeID); + if Assigned(OnParseDynArrayTypeDeclaration) then + begin + Declaration := 'array of ' + ExtractText(PrevPosition, PrevPosition + PrevLength - 1); + OnParseDynArrayTypeDeclaration(Owner, GetName(ArrayTypeId), ArrayTypeId, + GetName(ElemTypeId), Declaration); + end; + end + else // static array + begin + + BeginArrayType(ArrayTypeID); + if IsPacked then + SetPacked(ArrayTypeID); + L.Add(ArrayTypeId); + + Match('['); + repeat + T := NewTypeAlias; + RangeTypeId := Parse_OrdinalType(S); + Gen(OP_ASSIGN_TYPE_ALIAS, T, RangeTypeId, 0); + RangeList.Add(S); + + if IsCurrText(',') then + begin + Match(','); + + ArrayTypeId := NewTempVar; + BeginArrayType(ArrayTypeID); + if IsPacked then + SetPacked(ArrayTypeID); + L.Add(ArrayTypeId); + end + else + break; + until false; + + Match(']'); + Match('of'); + + T := NewTypeAlias; + ElemTypeId := Parse_Type; + Gen(OP_ASSIGN_TYPE_ALIAS, T, ElemTypeId, 0); + + DECLARE_SWITCH := true; + + for I:=0 to L.Count - 1 do + begin + EndArrayType(L[I]); + end; + + if Assigned(OnParseArrayTypeDeclaration) then + begin + S := GetName(ElemTypeId); + OnParseArrayTypeDeclaration(Owner, GetName(L[0]), L[0], + RangeList, + S); + end; + end; + finally + FreeAndNil(L); + FreeAndNil(RangeList); + end; +end; + +function TPascalParser.Parse_RecordConstructorHeading(IsSharedMethod: Boolean; + RecordTypeId: Integer; + Vis: TClassVisibility; + IsExternalUnit: Boolean): Integer; +var + DirectiveList: TIntegerList; + Declaration: String; + SavedPosition: Integer; +begin + SavedPosition := CurrToken.Position; + DECLARE_SWITCH := true; + Match('constructor'); + result := Parse_Ident; + Gen(OP_DECLARE_MEMBER, CurrLevel, result, 0); + SetVisibility(result, vis); + BeginStructureConstructor(result, RecordTypeId); + if Assigned(OnParseBeginSubDeclaration) then + OnParseBeginSubDeclaration(Owner, GetName(result), result); + Parse_FormalParameterList(result); + Match(';'); + + DirectiveList := Parse_DirectiveList(result); + if (DirectiveList.IndexOf(dirVIRTUAL) >= 0) or + (DirectiveList.IndexOf(dirDYNAMIC) >= 0) or + (DirectiveList.IndexOf(dirOVERRIDE) >= 0) then + begin + CreateError(errE2379, []); + // Virtual methods not allowed in record types. + end; + + FreeAndNil(DirectiveList); + SetForward(result, true); + + if IsCurrText('external') then + begin + ParseExternalSub(result); + SetForward(result, false); + Exit; + end; + + if IsExternalUnit then + begin + GenExternalSub(result); + Exit; + end; + + EndSub(result); + if Assigned(OnParseEndSubDeclaration) then + begin + Declaration := ExtractText(SavedPosition, PrevPosition + PrevLength - 1); + if IsSharedMethod then + Declaration := 'class ' + Declaration; + OnParseEndSubDeclaration(Owner, GetName(result), result, Declaration); + end; +end; + +function TPascalParser.Parse_RecordDestructorHeading(IsSharedMethod: Boolean; + RecordTypeId: Integer; + Vis: TClassVisibility; + IsExternalUnit: Boolean): Integer; +var + NP: Integer; + DirectiveList: TIntegerList; + Declaration: String; + SavedPosition: Integer; +begin + SavedPosition := CurrToken.Position; + DECLARE_SWITCH := true; + Match('destructor'); + result := Parse_Ident; + Gen(OP_DECLARE_MEMBER, CurrLevel, result, 0); + SetVisibility(result, vis); + BeginStructureDestructor(result, RecordTypeId); + if Assigned(OnParseBeginSubDeclaration) then + OnParseBeginSubDeclaration(Owner, GetName(result), result); + NP := 0; + if IsCurrText('(') then + begin + Call_SCANNER; + Match(')'); + end; + SetCount(result, NP); + Match(';'); + + DirectiveList := Parse_DirectiveList(result); + if (DirectiveList.IndexOf(dirVIRTUAL) >= 0) or + (DirectiveList.IndexOf(dirDYNAMIC) >= 0) or + (DirectiveList.IndexOf(dirOVERRIDE) >= 0) then + begin + CreateError(errE2379, []); + // Virtual methods not allowed in record types. + end; + FreeAndNil(DirectiveList); + SetForward(result, true); + + if IsCurrText('external') then + begin + ParseExternalSub(result); + SetForward(result, false); + Exit; + end; + + if IsExternalUnit then + begin + GenExternalSub(result); + Exit; + end; + + EndSub(result); + if Assigned(OnParseEndSubDeclaration) then + begin + Declaration := ExtractText(SavedPosition, PrevPosition + PrevLength - 1); + if IsSharedMethod then + Declaration := 'class ' + Declaration; + OnParseEndSubDeclaration(Owner, GetName(result), result, Declaration); + end; +end; + +function TPascalParser.Parse_RecordProcedureHeading(IsSharedMethod: Boolean; + RecordTypeId: Integer; + Vis: TClassVisibility; + IsExternalUnit: Boolean): Integer; +var + DirectiveList: TIntegerList; + Declaration: String; + SavedPosition: Integer; +begin + SavedPosition := CurrToken.Position; + DECLARE_SWITCH := true; + Match('procedure'); + result := Parse_Ident; + Gen(OP_DECLARE_MEMBER, CurrLevel, result, 0); + + if IsCurrText('.') then + begin + Scanner.CurrComment.AllowedDoComment := false; + Match('.'); + Parse_Ident; + DECLARE_SWITCH := false; + Match('='); + Parse_Ident; + Match(';'); + Exit; + end; + + SetVisibility(result, vis); + BeginStructureMethod(result, RecordTypeId, false, IsSharedMethod); + if Assigned(OnParseBeginSubDeclaration) then + OnParseBeginSubDeclaration(Owner, GetName(result), result); + Parse_FormalParameterList(result); + Match(';'); + + DirectiveList := Parse_DirectiveList(result); + + if DirectiveList.IndexOf(dirABSTRACT) >= 0 then + begin + inherited InitSub(result); + Gen(OP_ERR_ABSTRACT, NewConst(typeSTRING, + GetName(RecordTypeId) + '.' + GetName(result)), 0, result); + end + else if (DirectiveList.IndexOf(dirVIRTUAL) >= 0) or + (DirectiveList.IndexOf(dirDYNAMIC) >= 0) or + (DirectiveList.IndexOf(dirOVERRIDE) >= 0) then + begin + CreateError(errE2379, []); + // Virtual methods not allowed in record types. + end + else if IsSharedMethod and (DirectiveList.IndexOf(dirSTATIC) = -1) then + begin + CreateError(errE2398, []); + // Class methods in record types must be static. + end + else + SetForward(result, true); + FreeAndNil(DirectiveList); + + if IsCurrText('external') then + begin + ParseExternalSub(result); + SetForward(result, false); + Exit; + end; + + if IsExternalUnit then + begin + GenExternalSub(result); + Exit; + end; + + EndSub(result); + if Assigned(OnParseEndSubDeclaration) then + begin + Declaration := ExtractText(SavedPosition, PrevPosition + PrevLength - 1); + if IsSharedMethod then + Declaration := 'class ' + Declaration; + OnParseEndSubDeclaration(Owner, GetName(result), result, Declaration); + end; +end; + +function TPascalParser.Parse_RecordFunctionHeading(IsSharedMethod: Boolean; + RecordTypeId: Integer; + Vis: TClassVisibility; + IsExternalUnit: Boolean): Integer; +var + TypeID: Integer; + DirectiveList: TIntegerList; + Declaration: String; + SavedPosition: Integer; +begin + SavedPosition := CurrToken.Position; + DECLARE_SWITCH := true; + Match('function'); + result := Parse_Ident; + Gen(OP_DECLARE_MEMBER, CurrLevel, result, 0); + + if IsCurrText('.') then + begin + Scanner.CurrComment.AllowedDoComment := false; + Match('.'); + Parse_Ident; + DECLARE_SWITCH := false; + Match('='); + Parse_Ident; + Match(';'); + Exit; + end; + + SetVisibility(result, vis); + BeginStructureMethod(result, RecordTypeId, true, IsSharedMethod); + if Assigned(OnParseBeginSubDeclaration) then + OnParseBeginSubDeclaration(Owner, GetName(result), result); + Parse_FormalParameterList(result); + + DECLARE_SWITCH := false; + Match(':'); + Parse_Attribute; + TypeID := Parse_Type; + Gen(OP_ASSIGN_TYPE, result, TypeID, 0); + Gen(OP_ASSIGN_TYPE, CurrResultId, TypeID, 0); + if Assigned(OnParseResultType) then + OnParseResultType(Owner, GetName(TypeId), TypeId); + + DECLARE_SWITCH := true; + Match(';'); + + DirectiveList := Parse_DirectiveList(result); + if DirectiveList.IndexOf(dirABSTRACT) >= 0 then + begin + inherited InitSub(result); + Gen(OP_ERR_ABSTRACT, NewConst(typeSTRING, + GetName(RecordTypeId) + '.' + GetName(result)), 0, result); + end + else if (DirectiveList.IndexOf(dirVIRTUAL) >= 0) or + (DirectiveList.IndexOf(dirDYNAMIC) >= 0) or + (DirectiveList.IndexOf(dirOVERRIDE) >= 0) then + begin + CreateError(errE2379, []); + // Virtual methods not allowed in record types. + end + else if IsSharedMethod and (DirectiveList.IndexOf(dirSTATIC) = -1) then + begin + CreateError(errE2398, []); + // Class methods in record types must be static. + end + else + SetForward(result, true); + + FreeAndNil(DirectiveList); + + if IsCurrText('external') then + begin + ParseExternalSub(result); + SetForward(result, false); + Exit; + end; + + if IsExternalUnit then + begin + GenExternalSub(result); + Exit; + end; + + EndSub(result); + if Assigned(OnParseEndSubDeclaration) then + begin + Declaration := ExtractText(SavedPosition, PrevPosition + PrevLength - 1); + if IsSharedMethod then + Declaration := 'class ' + Declaration; + OnParseEndSubDeclaration(Owner, GetName(result), result, Declaration); + end; +end; + +function TPascalParser.Parse_RecordOperatorHeading(RecordTypeId: Integer; + Vis: TClassVisibility; + IsExternalUnit: Boolean): Integer; +var + I, TypeID: Integer; + DirectiveList: TIntegerList; + Declaration: String; + SavedPosition: Integer; +begin + SavedPosition := CurrToken.Position; + DECLARE_SWITCH := true; + RemoveLastIdent(CurrToken.Id); + Match('operator'); + I := OperatorIndex(CurrToken.Text); + if I = -1 then + CreateError(errE2393, []); + // errE2393 = 'Invalid operator declaration'; + result := Parse_Ident; + SetName(result, operators.Values[I]); + Gen(OP_DECLARE_MEMBER, CurrLevel, result, 0); + + SetVisibility(result, vis); + BeginStructureOperator(result, RecordTypeId); + if Assigned(OnParseBeginSubDeclaration) then + OnParseBeginSubDeclaration(Owner, GetName(result), result); + Parse_FormalParameterList(result); + + DECLARE_SWITCH := false; + Match(':'); + Parse_Attribute; + TypeID := Parse_Type; + Gen(OP_ASSIGN_TYPE, result, TypeID, 0); + Gen(OP_ASSIGN_TYPE, CurrResultId, TypeID, 0); + if Assigned(OnParseResultType) then + OnParseResultType(Owner, GetName(TypeId), TypeId); + + DECLARE_SWITCH := true; + Match(';'); + DirectiveList := Parse_DirectiveList(result); + FreeAndNil(DirectiveList); + + SetForward(result, true); + SetOverloaded(result); + + if IsCurrText('external') then + begin + ParseExternalSub(result); + SetForward(result, false); + Exit; + end; + + if IsExternalUnit then + begin + GenExternalSub(result); + Exit; + end; + + EndSub(result); + if Assigned(OnParseEndSubDeclaration) then + begin + Declaration := 'class ' + ExtractText(SavedPosition, PrevPosition + PrevLength - 1); + OnParseEndSubDeclaration(Owner, GetName(result), result, Declaration); + end; +end; + +function TPascalParser.Parse_RecordProperty(RecordTypeId: Integer; + Vis: TClassVisibility; + IsExternalUnit: Boolean): Integer; +var + TypeID, ReadId, WriteId, ImplementsId: Integer; + Declaration: String; + SavedPosition: Integer; +begin + DECLARE_SWITCH := true; + SavedPosition := CurrToken.Position; + Match('property'); + result := Parse_Ident; + Gen(OP_DECLARE_MEMBER, CurrLevel, result, 0); + + SetVisibility(result, vis); + BeginProperty(result, RecordTypeId); + ReadId := 0; + WriteId := 0; + TypeId := 0; + + try + + Parse_FormalParameterList(result, '['); + + SetReadId(result, ReadId); + SetWriteId(result, WriteId); + + if IsCurrText(';') then + begin + Match(';'); + Gen(OP_DETERMINE_PROP, result, 0, 0); + EndProperty(result); + Exit; + end; + + if IsCurrText(':') then + begin + DECLARE_SWITCH := false; + Match(':'); + TypeID := Parse_QualId; + Gen(OP_ASSIGN_TYPE, result, TypeID, 0); + end; + + repeat + DECLARE_SWITCH := false; + if IsCurrText('read') and (ReadId = 0) then + begin + RemoveLastIdent(CurrToken.Id); + Call_SCANNER; + ReadId := Parse_QualId; + ReadId := Lookup(GetName(ReadId), RecordTypeId); + if ReadId = 0 then + RaiseError(errUndeclaredIdentifier, [CurrToken.Text]); + SetReadId(result, ReadId); + end + else if IsCurrText('write') and (WriteId = 0) then + begin + RemoveLastIdent(CurrToken.Id); + Call_SCANNER; + WriteId := Parse_QualId; + WriteId := Lookup(GetName(WriteId), RecordTypeId); + if WriteId = 0 then + RaiseError(errUndeclaredIdentifier, [CurrToken.Text]); + SetWriteId(result, WriteId); + end + else if IsCurrText('implements') then + begin + RemoveLastIdent(CurrToken.Id); + DECLARE_SWITCH := false; + Call_SCANNER; + if not StrEql(GetName(result), CurrToken.Text) then + DiscardLastStRecord; + ImplementsId := Parse_Ident; + Gen(OP_IMPLEMENTS, result, ImplementsId, 0); + end + else if IsCurrText('stored') then + begin + DECLARE_SWITCH := false; + if not StrEql(GetName(result), CurrToken.Text) then + DiscardLastStRecord; + Call_SCANNER; + Parse_Expression; + end + else if IsCurrText('index') then + begin + DECLARE_SWITCH := false; + if not StrEql(GetName(result), CurrToken.Text) then + DiscardLastStRecord; + Call_SCANNER; + Parse_Expression; + end + else if IsCurrText('default') then + begin + if not StrEql(GetName(result), CurrToken.Text) then + DiscardLastStRecord; + Call_SCANNER; + if IsCurrText(';') then + SetDefault(result, true) + else + Parse_Expression; + end + else if IsCurrText('nodefault') then + begin + if not StrEql(GetName(result), CurrToken.Text) then + DiscardLastStRecord; + Call_SCANNER; + end + else + break; + until false; + + if IsNextText('default') then + begin + Call_SCANNER; + Match('default'); + SetDefault(result, true); + end; + + if ReadId + WriteId = 0 then + RaiseError(errSyntaxError, []); + + if ReadId > 0 then + TKernel(kernel).Code.used_private_members.Add(ReadId); + if WriteId > 0 then + TKernel(kernel).Code.used_private_members.Add(WriteId); + + Match(';'); + EndProperty(result); + finally + if Assigned(OnParsePropertyDeclaration) then + begin + Declaration := ExtractText(SavedPosition, PrevPosition + PrevLength - 1); + OnParsePropertyDeclaration(Owner, GetName(result), result, + GetName(TypeId), Declaration); + end; + end; +end; + +procedure TPascalParser.Parse_RecordVariantPart(VarLevel: Integer; + CurrVarCnt: Int64; + vis: TClassVisibility); +var + id, I, TypeId: Integer; + V, VarCnt: Int64; + L: TIntegerList; + S, Declaration: String; + SavedPosition: Integer; +begin + + L := TIntegerList.Create; + + try + VarCnt := 0; + + if IsNext2Text(':') then + begin + DECLARE_SWITCH := true; + Match('case'); + DECLARE_SWITCH := false; + id := Parse_Ident; + Match(':'); + TypeId := Parse_Ident; + SetKind(Id, KindTYPE_FIELD); + Gen(OP_ASSIGN_TYPE, id, TypeId, 0); + end + else + begin + DECLARE_SWITCH := false; + Match('case'); + TypeId := Parse_Ident; + Gen(OP_EVAL, 0, 0, TypeId); + end; + + DECLARE_SWITCH := false; + Match('of'); + + repeat + Inc(VarCnt); + + if IsEOF then + Break; + if IsCurrText('end') then + Break; + if IsCurrText(')') then + begin + Break; + end; + + // RecVariant + + // ConstList + repeat + if IsEOF then + Break; + if IsCurrText('end') then + Break; + + Parse_Expression; + + if NotMatch(',') then + break; + until false; + + Match(':'); + + // FieldList + DECLARE_SWITCH := true; + + Match('('); + if not IsCurrText(')') then + begin + if IsCurrText('case') then + begin + case VarLevel of + 1: V := VarCnt; + 2: V := VarCnt * 100 + CurrVarCnt; + 3: V := VarCnt * 10000 + CurrVarCnt; + 4: V := VarCnt * 1000000 + CurrVarCnt; + 5: V := VarCnt * 100000000 + CurrVarCnt; + 6: V := VarCnt * 10000000000 + CurrVarCnt; + 7: V := VarCnt * 1000000000000 + CurrVarCnt; + else + begin + V := 0; + RaiseError(errTooManyNestedCaseBlocks, []); + end; + end; + + Parse_RecordVariantPart(VarLevel + 1, V, vis); + end + else + begin + + repeat + + L.Clear; + repeat // parse ident list + L.Add(Parse_Ident); + if NotMatch(',') then + break; + until false; + + DECLARE_SWITCH := false; + Match(':'); + + SavedPosition := CurrToken.Position; + TypeID := Parse_Type; + S := ExtractText(SavedPosition, PrevPosition + PrevLength - 1); + + case VarLevel of + 1: V := VarCnt; + 2: V := VarCnt * 100 + CurrVarCnt; + 3: V := VarCnt * 10000 + CurrVarCnt; + 4: V := VarCnt * 1000000 + CurrVarCnt; + 5: V := VarCnt * 100000000 + CurrVarCnt; + 6: V := VarCnt * 10000000000 + CurrVarCnt; + 7: V := VarCnt * 1000000000000 + CurrVarCnt; + else + begin + V := 0; + RaiseError(errTooManyNestedCaseBlocks, []); + end; + end; + + for I:=0 to L.Count - 1 do + begin + SetKind(L[I], KindTYPE_FIELD); + SetVarCount(L[I], V); + SetVisibility(L[I], vis); + Gen(OP_ASSIGN_TYPE, L[I], TypeID, 0); + + if Assigned(OnParseVariantRecordFieldDeclaration) then + begin + Declaration := GetName(L[I]) + ' = ' + S + ';'; + OnParseVariantRecordFieldDeclaration(Owner, GetName(L[I]), L[I], + GetName(TypeId), V, Declaration); + end; + end; + + if IsCurrText(';') then + begin + DECLARE_SWITCH := true; + Match(';'); + + if IsCurrText(')') then + break; + + if IsCurrText('case') then + begin + Parse_RecordVariantPart(VarLevel + 1, V, vis); + break; + end; + + end + else + break; + + until false; + end; + + DECLARE_SWITCH := true; + end; + + DECLARE_SWITCH := false; + + Match(')'); + if IsCurrText(';') then + Match(';'); + + until false; + finally + FreeAndNil(L); + end; +end; + +procedure TPascalParser.Parse_RecordHelperItem; +begin + if IsCurrText('const') then + Parse_ConstantDeclaration; +end; + +procedure TPascalParser.Parse_RecordTypeDeclaration(RecordTypeID: Integer; IsPacked: Boolean; + IsExternalUnit: Boolean = false); +var + vis: TClassVisibility; + +var + L: TIntegerList; + I, TypeID, Id, TrueRecordId: Integer; + b: Boolean; + Declaration: String; + SavedPosition: Integer; +begin + SavedPosition := CurrToken.Position; + + TrueRecordId := 0; + vis := cvPublic; + + if IsNextText('helper') then + begin + Match('record'); + DECLARE_SWITCH := false; + RemoveLastIdent(CurrToken.Id); + Match('helper'); + Match('for'); + TrueRecordId := Parse_QualId; + BeginHelperType(RecordTypeId, TrueRecordId); + + if Assigned(OnParseBeginRecordHelperTypeDeclaration) then + begin + Declaration := ExtractText(SavedPosition, PrevPosition + PrevLength - 1); + Declaration := GetName(RecordTypeId) + ' = ' + Declaration; + if Assigned(OnParseBeginClassHelperTypeDeclaration) then + begin + OnParseBeginRecordHelperTypeDeclaration(Owner, GetName(RecordTypeId), RecordTypeId, + GetName(TrueRecordId), + Declaration); + end; + end; + end + else + begin + BeginRecordType(RecordTypeID); + if IsPacked then + SetPacked(RecordTypeID); + Match('record'); + + if Assigned(OnParseBeginRecordTypeDeclaration) then + begin + Declaration := ExtractText(SavedPosition, PrevPosition + PrevLength - 1); + Declaration := GetName(RecordTypeId) + ' = ' + Declaration; + OnParseBeginRecordTypeDeclaration(Owner, GetName(RecordTypeId), RecordTypeId, Declaration); + end; + end; + + b := false; + L := TIntegerList.Create; + try + repeat + if IsEOF then + Break; + + if IsCurrText('end') then + Break; + + if IsCurrText('case') then + + begin + Parse_RecordVariantPart(1, 0, vis); + break; + end + else + begin + repeat + if IsCurrText('strict') then + begin + RemoveLastIdent(CurrToken.Id); + Call_SCANNER; + if IsCurrText('protected') then + begin + Call_SCANNER; + vis := cvStrictProtected; + end + else + begin + Match('private'); + vis := cvStrictPrivate; + end; + b := false; + end + else if IsCurrText('private') then + begin + Call_SCANNER; + vis := cvPrivate; + b := false; + end + else if IsCurrText('protected') then + begin + Call_SCANNER; + vis := cvProtected; + b := false; + end + else if IsCurrText('public') then + begin + Call_SCANNER; + vis := cvPublic; + b := false; + end + else if IsCurrText('published') then + begin + Call_SCANNER; + vis := cvPublished; + b := false; + end + else + break; + until false; + + if IsCurrText('end') then + Break; + Parse_Attribute; + + if IsCurrText('case') then + begin + Parse_RecordVariantPart(1, 0, vis); + break; + end + else if IsCurrText('constructor') then + begin + Parse_RecordConstructorHeading(false, RecordTypeId, vis, IsExternalUnit); + b := true; + end + else if IsCurrText('destructor') then + begin + Parse_RecordDestructorHeading(false, RecordTypeId, vis, IsExternalUnit); + b := true; + end + else if IsCurrText('procedure') then + begin + Parse_RecordProcedureHeading(false, RecordTypeId, vis, IsExternalUnit); + b := true; + end + else if IsCurrText('function') then + begin + Parse_RecordFunctionHeading(false, RecordTypeId, vis, IsExternalUnit); + b := true; + end + else if IsCurrText('var') or IsCurrText('threadvar') then + begin + if IsCurrText('threadvar') then + Call_SCANNER + else + Match('var'); + + repeat + Parse_Attribute; + + L.Clear; + repeat // parse ident list + Id := Parse_Ident; + Gen(OP_DECLARE_MEMBER, CurrLevel, Id, 0); + L.Add(Id); + if NotMatch(',') then + break; + until false; + + DECLARE_SWITCH := false; + Match(':'); + + TypeID := Parse_Type; + + for I:=0 to L.Count - 1 do + begin + SetKind(L[I], KindTYPE_FIELD); + SetVisibility(L[I], vis); + Gen(OP_ASSIGN_TYPE, L[I], TypeID, 0); + end; + + DECLARE_SWITCH := true; + + Parse_PortabilityDirective; + + if IsCurrText(';') then + Match(';'); + + if CurrToken.TokenClass <> tcIdentifier then + if not IsCurrText('[') then + break; + until false; + end + else if IsCurrText('class') then + begin + b := true; + Call_SCANNER; + if IsCurrText('constructor') then + Parse_RecordConstructorHeading(true, RecordTypeId, vis, IsExternalUnit) + else if IsCurrText('destructor') then + Parse_RecordDestructorHeading(true, RecordTypeId, vis, IsExternalUnit) + else if IsCurrText('procedure') then + Parse_RecordProcedureHeading(true, RecordTypeId, vis, IsExternalUnit) + else if IsCurrText('function') then + Parse_RecordFunctionHeading(true, RecordTypeId, vis, IsExternalUnit) + else if IsCurrText('operator') then + Parse_RecordOperatorHeading(RecordTypeId, vis, IsExternalUnit) + else if IsCurrText('property') then + Parse_RecordProperty(RecordTypeId, vis, IsExternalUnit) + else if IsCurrText('var') or IsCurrText('threadvar') then + Parse_VariableDeclaration(vis); + end + else if IsCurrText('property') then + begin + Parse_RecordProperty(RecordTypeId, vis, IsExternalUnit); + b := true; + end + else if IsCurrText('type') then + begin + Parse_TypeDeclaration(false, vis); + b := true; + end + else if IsCurrText('const') then + begin + Parse_ConstantDeclaration(vis); + b := true; + end + else + begin + if IsCurrText('threadvar') then + Call_SCANNER + else if IsCurrText('var') then + Call_SCANNER; + + if b then + CreateError(errFieldDefinitionNotAllowedAfter, []); + + L.Clear; + repeat // parse ident list + Id := Parse_Ident; + SetVisibility(Id, Vis); + Gen(OP_DECLARE_MEMBER, CurrLevel, Id, 0); + L.Add(Id); + if NotMatch(',') then + break; + until false; + + DECLARE_SWITCH := false; + Match(':'); + + SavedPosition := CurrToken.Position; + + TypeID := Parse_Type; + + for I:=0 to L.Count - 1 do + begin + SetKind(L[I], KindTYPE_FIELD); + Gen(OP_ASSIGN_TYPE, L[I], TypeID, 0); + + if Assigned(OnParseFieldDeclaration) then + begin + Declaration := GetName(L[I]) + ':' + + ExtractText(SavedPosition, PrevPosition + PrevLength - 1); + OnParseFieldDeclaration(Owner, GetName(L[I]), L[I], GetName(TypeId), + Declaration); + end; + end; + + DECLARE_SWITCH := true; + + Parse_PortabilityDirective; + + if IsCurrText(';') then + Match(';'); + end; + + if IsCurrText('case') then + begin + Parse_RecordVariantPart(1, 0, vis); + break; + end; + end; + + until false; + finally + FreeAndNil(L); + end; + + if TrueRecordId > 0 then + begin + EndHelperType(RecordTypeId); + if Assigned(OnParseEndRecordHelperTypeDeclaration) then + OnParseEndRecordHelperTypeDeclaration(Owner, GetName(RecordTypeId), RecordTypeId); + end + else + begin + EndRecordType(RecordTypeId); + if Assigned(OnParseEndRecordTypeDeclaration) then + OnParseEndRecordTypeDeclaration(Owner, GetName(RecordTypeId), RecordTypeId); + end; + + Match('end'); +end; + +procedure TPascalParser.Parse_Message(SubId: Integer); +begin + DECLARE_SWITCH := false; + Call_SCANNER; + if CurrToken.TokenClass = tcIntegerConst then + begin + Gen(OP_ADD_MESSAGE, SubId, CurrToken.Id, 0); + end + else if CurrToken.TokenClass = tcIdentifier then + begin + Gen(OP_ADD_MESSAGE, SubId, CurrToken.Id, 0); + end + else + begin + RaiseError(errIncompatibleTypesNoArgs, []); + end; + ReadToken; +end; + +function TPascalParser.Parse_ClassConstructorHeading(IsSharedMethod: Boolean; + ClassTypeId: Integer; + vis: TClassVisibility; + IsExternalUnit: Boolean): Integer; +var + DirectiveList: TIntegerList; + Declaration: String; + SavedPosition: Integer; +begin + SavedPosition := CurrToken.Position; + DECLARE_SWITCH := true; + Match('constructor'); + result := Parse_Ident; + Gen(OP_DECLARE_MEMBER, CurrLevel, result, 0); + SetVisibility(result, vis); + BeginClassConstructor(result, ClassTypeId); + if Assigned(OnParseBeginSubDeclaration) then + OnParseBeginSubDeclaration(Owner, GetName(result), result); + + GetSymbolRec(result).IsSharedMethod := IsSharedMethod; + + Parse_FormalParameterList(result); + Match(';'); + CheckRedeclaredSub(result); + + DirectiveList := Parse_DirectiveList(result); + try + if not ImportOnly then + if CountAtLevel(GetName(result), GetLevel(result), KindCONSTRUCTOR, IsSharedMethod) > 1 then + if DirectiveList.IndexOf(dirOVERLOAD) = -1 then + CreateError(errOverloadExpected, [GetName(result)]); + + if (DirectiveList.IndexOf(dirSTATIC) >= 0) and + ( + (DirectiveList.IndexOf(dirVIRTUAL) >= 0) or + (DirectiveList.IndexOf(dirDYNAMIC) >= 0) or + (DirectiveList.IndexOf(dirOVERRIDE) >= 0) + ) then + begin + CreateError(errE2376, []); + //STATIC can only be used on non-virtual class methods. + end; + + finally + FreeAndNil(DirectiveList); + end; + SetForward(result, true); + + if IsCurrText('external') then + begin + ParseExternalSub(result); + SetForward(result, false); + Exit; + end; + + if IsExternalUnit then + begin + GenExternalSub(result); + Exit; + end; + + EndSub(result); + if Assigned(OnParseEndSubDeclaration) then + begin + Declaration := ExtractText(SavedPosition, PrevPosition + PrevLength - 1); + if IsSharedMethod then + Declaration := 'class ' + Declaration; + OnParseEndSubDeclaration(Owner, GetName(result), result, Declaration); + end; +end; + +function TPascalParser.Parse_ClassDestructorHeading(IsSharedMethod: Boolean; + ClassTypeId: Integer; + vis: TClassVisibility; + IsExternalUnit: Boolean): Integer; +var + NP: Integer; + DirectiveList: TIntegerList; + Declaration: String; + SavedPosition: Integer; +begin + SavedPosition := CurrToken.Position; + DECLARE_SWITCH := true; + Match('destructor'); + result := Parse_Ident; + Gen(OP_DECLARE_MEMBER, CurrLevel, result, 0); + SetVisibility(result, vis); + BeginClassDestructor(result, ClassTypeId); + if Assigned(OnParseBeginSubDeclaration) then + OnParseBeginSubDeclaration(Owner, GetName(result), result); + + GetSymbolRec(result).IsSharedMethod := IsSharedMethod; + + NP := 0; + if IsCurrText('(') then + begin + Call_SCANNER; + Match(')'); + end; + SetCount(result, NP); + Match(';'); + CheckRedeclaredSub(result); + + DirectiveList := Parse_DirectiveList(result); + try + if not ImportOnly then + begin + if not IsSharedMethod then + if DirectiveList.IndexOf(dirOVERRIDE) = -1 then + Match('override'); + if CountAtLevel(GetName(result), GetLevel(result), KindDESTRUCTOR, IsSharedMethod) > 1 then + if DirectiveList.IndexOf(dirOVERLOAD) = -1 then + CreateError(errOverloadExpected, [GetName(result)]); + end; + finally + FreeAndNil(DirectiveList); + end; + + SetForward(result, true); + + if IsCurrText('external') then + begin + ParseExternalSub(result); + SetForward(result, false); + Exit; + end; + + if IsExternalUnit then + begin + GenExternalSub(result); + Exit; + end; + + EndSub(result); + if Assigned(OnParseEndSubDeclaration) then + begin + Declaration := ExtractText(SavedPosition, PrevPosition + PrevLength - 1); + if IsSharedMethod then + Declaration := 'class ' + Declaration; + OnParseEndSubDeclaration(Owner, GetName(result), result, Declaration); + end; +end; + +function TPascalParser.Parse_ClassProcedureHeading(IsSharedMethod: Boolean; + ClassTypeId: Integer; + vis: TClassVisibility; + IsExternalUnit: Boolean): Integer; +var + DirectiveList: TIntegerList; + Declaration: String; + SavedPosition: Integer; +begin + SavedPosition := CurrToken.Position; + DECLARE_SWITCH := true; + BeginTypeExt(ClassTypeId); + Match('procedure'); + result := Parse_Ident; + Gen(OP_DECLARE_MEMBER, CurrLevel, result, 0); + + if IsCurrText('.') then + begin + Scanner.CurrComment.AllowedDoComment := false; + Match('.'); + Parse_Ident; + DECLARE_SWITCH := false; + Match('='); + Parse_Ident; + Match(';'); + Exit; + end; + + SetVisibility(result, vis); + BeginClassMethod(result, ClassTypeId, false, IsSharedMethod, false); + if Assigned(OnParseBeginSubDeclaration) then + OnParseBeginSubDeclaration(Owner, GetName(result), result); + Parse_FormalParameterList(result); + EndTypeExt(ClassTypeId); + Match(';'); + + CheckRedeclaredSub(result); + + if IsCurrText('message') then + Parse_Message(result); + + DirectiveList := Parse_DirectiveList(result); + try + if DirectiveList.IndexOf(dirABSTRACT) >= 0 then + begin + inherited InitSub(result); + Gen(OP_ERR_ABSTRACT, NewConst(typeSTRING, + GetName(ClassTypeId) + '.' + GetName(result)), 0, result); + end + else if (DirectiveList.IndexOf(dirSTATIC) >= 0) and + ( + (IsSharedMethod = false) or + (DirectiveList.IndexOf(dirVIRTUAL) >= 0) or + (DirectiveList.IndexOf(dirDYNAMIC) >= 0) or + (DirectiveList.IndexOf(dirOVERRIDE) >= 0) + ) then + begin + CreateError(errE2376, []); + //STATIC can only be used on non-virtual class methods. + end + else if DirectiveList.IndexOf(dirOVERRIDE) >= 0 then + begin + SetForward(result, true); + end + else + SetForward(result, true); + + if CountAtLevel(GetName(result), GetLevel(result)) > 1 then + if DirectiveList.IndexOf(dirOVERLOAD) = -1 then + if not ImportOnly then + CreateError(errOverloadExpected, [GetName(result)]); + + finally + FreeAndNil(DirectiveList); + end; + + if IsCurrText('external') then + begin + ParseExternalSub(result); + SetForward(result, false); + Exit; + end; + + if IsExternalUnit then + begin + GenExternalSub(result); + Exit; + end; + + EndSub(result); + if Assigned(OnParseEndSubDeclaration) then + begin + Declaration := ExtractText(SavedPosition, PrevPosition + PrevLength - 1); + if IsSharedMethod then + Declaration := 'class ' + Declaration; + OnParseEndSubDeclaration(Owner, GetName(result), result, Declaration); + end; +end; + +function TPascalParser.Parse_ClassFunctionHeading(IsSharedMethod: Boolean; + ClassTypeId: Integer; + vis: TClassVisibility; + IsExternalUnit: Boolean): Integer; +var + TypeID: Integer; + DirectiveList: TIntegerList; + Declaration: String; + SavedPosition: Integer; +begin + SavedPosition := CurrToken.Position; + DECLARE_SWITCH := true; + Match('function'); + result := Parse_Ident; + Gen(OP_DECLARE_MEMBER, CurrLevel, result, 0); + + if IsCurrText('.') then + begin + Scanner.CurrComment.AllowedDoComment := false; + Match('.'); + Parse_Ident; + DECLARE_SWITCH := false; + Match('='); + Parse_Ident; + Match(';'); + Exit; + end; + + SetVisibility(result, vis); + BeginClassMethod(result, ClassTypeId, true, IsSharedMethod, false); + if Assigned(OnParseBeginSubDeclaration) then + OnParseBeginSubDeclaration(Owner, GetName(result), result); + Parse_FormalParameterList(result); + + DECLARE_SWITCH := false; + Match(':'); + Parse_Attribute; + TypeID := Parse_Type; + Gen(OP_ASSIGN_TYPE, result, TypeID, 0); + Gen(OP_ASSIGN_TYPE, CurrResultId, TypeID, 0); + if Assigned(OnParseResultType) then + OnParseResultType(Owner, GetName(TypeId), TypeId); + + DECLARE_SWITCH := true; + Match(';'); + CheckRedeclaredSub(result); + + if IsCurrText('message') then + Parse_Message(result); + + DirectiveList := Parse_DirectiveList(result); + try + + if DirectiveList.IndexOf(dirABSTRACT) >= 0 then + begin + inherited InitSub(result); + Gen(OP_ERR_ABSTRACT, NewConst(typeSTRING, + GetName(ClassTypeId) + '.' + GetName(result)), 0, result); + end + else if (DirectiveList.IndexOf(dirSTATIC) >= 0) and + ( + (IsSharedMethod = false) or + (DirectiveList.IndexOf(dirVIRTUAL) >= 0) or + (DirectiveList.IndexOf(dirDYNAMIC) >= 0) or + (DirectiveList.IndexOf(dirOVERRIDE) >= 0) + ) then + begin + CreateError(errE2376, []); + //STATIC can only be used on non-virtual class methods. + end + else if DirectiveList.IndexOf(dirOVERRIDE) >= 0 then + begin + SetForward(result, true); + end + else + SetForward(result, true); + + if CountAtLevel(GetName(result), GetLevel(result)) > 1 then + if DirectiveList.IndexOf(dirOVERLOAD) = -1 then + if not ImportOnly then + CreateError(errOverloadExpected, [GetName(result)]); + + finally + FreeAndNil(DirectiveList); + end; + + if IsCurrText('external') then + begin + ParseExternalSub(result); + SetForward(result, false); + Exit; + end; + + if IsExternalUnit then + begin + GenExternalSub(result); + Exit; + end; + + EndSub(result); + if Assigned(OnParseEndSubDeclaration) then + begin + Declaration := ExtractText(SavedPosition, PrevPosition + PrevLength - 1); + if IsSharedMethod then + Declaration := 'class ' + Declaration; + OnParseEndSubDeclaration(Owner, GetName(result), result, Declaration); + end; +end; + +function TPascalParser.Parse_ClassProperty(IsShared: Boolean; + ClassTypeId: Integer; + vis: TClassVisibility; + IsExternalUnit: Boolean): Integer; +var + ReadId, WriteId, ImplementsId, TypeID, K: Integer; + StrType, StrDefault, Declaration: String; + SavedPosition: Integer; +begin + RemoveKeywords; + + SavedPosition := CurrToken.Position; + ReadId := 0; + WriteId := 0; + + DECLARE_SWITCH := true; + Match('property'); + result := Parse_Ident; + + StrType := ''; + StrDefault := ''; + + try + Gen(OP_DECLARE_MEMBER, CurrLevel, result, 0); + SetVisibility(result, vis); + BeginProperty(result, ClassTypeId); + + Parse_FormalParameterList(result, '['); + + if IsCurrText(';') then + begin + Gen(OP_DETERMINE_PROP, result, 0, 0); + EndProperty(result); + Exit; + end + else if IsCurrText('default') then + begin + Call_SCANNER; + StrDefault := CurrToken.Text; + if not IsCurrText(';') then + Parse_Expression; + Gen(OP_DETERMINE_PROP, result, 0, 0); + EndProperty(result); + Exit; + end + else if IsCurrText('nodefault') then + begin + Call_SCANNER; + Gen(OP_DETERMINE_PROP, result, 0, 0); + EndProperty(result); + Exit; + end; + + if IsCurrText(':') then + begin + DECLARE_SWITCH := false; + Match(':'); + TypeID := Parse_QualId; + StrType := GetName(TypeId); + Gen(OP_ASSIGN_TYPE, result, TypeID, 0); + end; + + repeat + DECLARE_SWITCH := false; + if IsCurrText('read') and (ReadId = 0) then + begin + RemoveLastIdent(CurrToken.Id); + Call_SCANNER; + ReadId := Parse_QualId; + Gen(OP_SET_READ_ID, result, ReadId, 0); + SetReadId(result, ReadId); + + if IsCurrText(';') then + if IsNextText('default') then + Call_SCANNER; + end + else if IsCurrText('write') and (WriteId = 0) then + begin + RemoveLastIdent(CurrToken.Id); + Call_SCANNER; + WriteId := Parse_QualId; + Gen(OP_SET_WRITE_ID, result, WriteId, 0); + SetWriteId(result, WriteId); + + if IsCurrText(';') then + if IsNextText('default') then + Call_SCANNER; + end + else if IsCurrText('implements') then + begin + RemoveLastIdent(CurrToken.Id); + DECLARE_SWITCH := false; + Call_SCANNER; + if not StrEql(GetName(result), CurrToken.Text) then + DiscardLastStRecord; + repeat + ImplementsId := Parse_QualId; + Gen(OP_IMPLEMENTS, result, ImplementsId, 0); + if NotMatch(',') then + break; + until false; + end + else if IsCurrText('stored') then + begin + DECLARE_SWITCH := false; + if not StrEql(GetName(result), CurrToken.Text) then + DiscardLastStRecord; + Call_SCANNER; + Parse_Expression; + end + else if IsCurrText('index') then + begin + DECLARE_SWITCH := false; + if not StrEql(GetName(result), CurrToken.Text) then + DiscardLastStRecord; + Call_SCANNER; + Parse_Expression; + end + else if IsCurrText('default') then + begin + if not StrEql(GetName(result), CurrToken.Text) then + DiscardLastStRecord; + Call_SCANNER; + if IsCurrText(';') then + SetDefault(result, true) + else + Parse_Expression; + end + else if IsCurrText('nodefault') then + begin + if not StrEql(GetName(result), CurrToken.Text) then + DiscardLastStRecord; + Call_SCANNER; + end + else + break; + until false; + + if IsNextText('default') then + begin + Call_SCANNER; + Match('default'); + StrDefault := CurrToken.Text; + SetDefault(result, true); + end; + + if ReadId > 0 then + TKernel(kernel).Code.used_private_members.Add(ReadId); + if WriteId > 0 then + TKernel(kernel).Code.used_private_members.Add(WriteId); + + EndProperty(result); + finally + RestoreKeywords; + if Assigned(OnParsePropertyDeclaration) then + begin + Declaration := ExtractText(SavedPosition, + CurrToken.Position + CurrToken.Length - 1); + if IsShared then + Declaration := 'class ' + Declaration; + + if StrType = '' then + if GetSymbolRec(result).Vis in [cvPublic, cvProtected] then + begin + if ReadId > 0 then + begin + TypeId := GetSymbolRec(ReadId).TypeID; + StrType := GetName(TypeId); + end; + + if StrType = '' then + if WriteId > 0 then + begin + if GetKind(WriteId) = KindSUB then + begin + K := GetCount(result); + K := GetParamId(WriteId, K); + TypeId := GetSymbolRec(K).TypeID; + StrType := GetName(TypeId); + end + else + begin + TypeId := GetSymbolRec(WriteId).TypeID; + StrType := GetName(TypeId); + end; + end; + + if StrType = '' then + if StrDefault <> '' then + begin + if StrEql(StrDefault, 'true') or StrEql(StrDefault, 'false') then + StrType := 'Boolean'; + end; + end; + OnParsePropertyDeclaration(Owner, GetName(result), result, StrType, + Declaration); + end; + end; +end; + +procedure TPascalParser.Parse_ClassTypeDeclaration(ClassTypeID: Integer; IsPacked: Boolean; + IsExternalUnit: Boolean = false); +var + vis: TClassVisibility; + +var + L: TIntegerList; + I, TypeID, AncestorId, RefTypeId, Id: Integer; + b: Boolean; + Declaration: String; + TrueClassId: Integer; + SavedPosition: Integer; +begin + SavedPosition := CurrToken.Position; + + if IsNextText('of') then + begin + DECLARE_SWITCH := false; + BeginClassReferenceType(ClassTypeID); + Match('class'); + Match('of'); + RefTypeId := Parse_QualId; + Gen(OP_CREATE_CLASSREF_TYPE, ClassTypeId, RefTypeId, 0); + EndClassReferenceType(ClassTypeID); + if Assigned(OnParseClassReferenceTypeDeclaration) then + begin + Declaration := ExtractText(SavedPosition, CurrToken.Position + CurrToken.Length - 1); + OnParseClassReferenceTypeDeclaration(Owner, + GetName(ClassTypeId), ClassTypeId, GetName(RefTypeId), Declaration); + end; + Exit; + end + else if IsNextText('helper') then + begin + Match('class'); + DECLARE_SWITCH := false; + RemoveLastIdent(CurrToken.Id); + Match('helper'); + Match('for'); + TrueClassId := Parse_QualId; + BeginHelperType(ClassTypeId, TrueClassId); + end + else + begin + BeginClassType(ClassTypeID); + TrueClassId := 0; + + if IsPacked then + SetPacked(ClassTypeID); + + Match('class'); + + if IsCurrText(';') then // forward declaration + begin + SetForward(ClassTypeId, true); + EndClassType(ClassTypeId, true); + if Assigned(OnParseForwardTypeDeclaration) then + OnParseForwardTypeDeclaration(Owner, GetName(ClassTypeId), ClassTypeId); + Exit; + end; + + if IsCurrText('abstract') then + begin + RemoveLastEvalInstruction('abstract'); + SetAbstract(ClassTypeId, true); + Call_SCANNER; + end + else if IsCurrText('sealed') then + begin + SetFinal(ClassTypeId, true); + Call_SCANNER; + end; + end; + + if TrueClassId > 0 then + begin + if Assigned(OnParseBeginClassHelperTypeDeclaration) then + begin + OnParseBeginClassHelperTypeDeclaration(Owner, GetName(ClassTypeId), ClassTypeId, + GetName(TrueClassId), + Declaration); + end; + end + else if Assigned(OnParseBeginClassTypeDeclaration) then + begin + Declaration := ExtractText(SavedPosition, PrevPosition + PrevLength - 1); + Declaration := GetName(ClassTypeId) + ' = ' + Declaration; + OnParseBeginClassTypeDeclaration(Owner, GetName(ClassTypeId), ClassTypeId, Declaration); + end; + + if IsCurrText('(') then + begin + DECLARE_SWITCH := false; + Match('('); + AncestorId := Parse_QualId; + Gen(OP_ADD_ANCESTOR, ClassTypeId, AncestorId, 0); + if Assigned(OnParseAncestorTypeDeclaration) then + OnParseAncestorTypeDeclaration(Owner, GetName(AncestorId), AncestorId); + + if StrEql(GetName(ClassTypeId), GetName(AncestorId)) then + RaiseError(errRedeclaredIdentifier, [GetName(AncestorId)]); + + if IsCurrText(',') then + begin + Call_SCANNER; + repeat + AncestorId := Parse_QualId; + Gen(OP_ADD_INTERFACE, ClassTypeId, AncestorId, 0); + if Assigned(OnParseUsedInterface) then + OnParseUsedInterface(Owner, GetName(AncestorId), AncestorId); + if NotMatch(',') then + break; + until false; + end; + + DECLARE_SWITCH := true; + Match(')') + end + else + if Assigned(OnParseAncestorTypeDeclaration) then + OnParseAncestorTypeDeclaration(Owner, GetName(H_TObject), H_TObject); + + + if IsCurrText(';') then + begin + if TrueClassId > 0 then + begin + EndHelperType(ClassTypeId); + + if Assigned(OnParseEndClassHelperTypeDeclaration) then + OnParseEndClassHelperTypeDeclaration(Owner, GetName(ClassTypeId), ClassTypeId); + end + else + begin + EndClassType(ClassTypeId); + + if Assigned(OnParseEndClassTypeDeclaration) then + OnParseEndClassTypeDeclaration(Owner, GetName(ClassTypeId), ClassTypeId); + + if FindConstructorId(ClassTypeId) = 0 then + GenDefaultConstructor(ClassTypeId); + if FindDestructorId(ClassTypeId) = 0 then + GenDefaultDestructor(ClassTypeId); + end; + Exit; + end; + + vis := cvPublished; + + b := false; + + L := TIntegerList.Create; + try + repeat + if IsEOF then + Break; + if IsCurrText('end') then + Break; + + repeat + if IsCurrText('strict') then + begin + RemoveLastIdent(CurrToken.Id); + Call_SCANNER; + if IsCurrText('protected') then + begin + Call_SCANNER; + vis := cvStrictProtected; + end + else + begin + Match('private'); + vis := cvStrictPrivate; + end; + b := false; + end + else if IsCurrText('private') then + begin + Call_SCANNER; + vis := cvPrivate; + b := false; + end + else if IsCurrText('protected') then + begin + Call_SCANNER; + vis := cvProtected; + b := false; + end + else if IsCurrText('public') then + begin + Call_SCANNER; + vis := cvPublic; + b := false; + end + else if IsCurrText('published') then + begin + Call_SCANNER; + vis := cvPublished; + b := false; + end + else + break; + + until false; + + if IsCurrText('end') then + Break; + + Parse_Attribute; + + if IsCurrText('constructor') then + begin + Parse_ClassConstructorHeading(false, ClassTypeId, vis, IsExternalUnit); + b := true; + end + else if IsCurrText('destructor') then + begin + Parse_ClassDestructorHeading(false, ClassTypeId, vis, IsExternalUnit); + b := true; + end + else if IsCurrText('procedure') then + begin + Parse_ClassProcedureHeading(false, ClassTypeId, vis, IsExternalUnit); + b := true; + end + else if IsCurrText('function') then + begin + Parse_ClassFunctionHeading(false, ClassTypeId, vis, IsExternalUnit); + b := true; + end + else if IsCurrText('var') or IsCurrText('threadvar') then + begin + if IsCurrText('threadvar') then + Call_SCANNER + else + Match('var'); + + repeat + Parse_Attribute; + + L.Clear; + repeat // parse ident list + Id := Parse_Ident; + Gen(OP_DECLARE_MEMBER, CurrLevel, Id, 0); + L.Add(Id); + if NotMatch(',') then + break; + until false; + + DECLARE_SWITCH := false; + Match(':'); + + TypeID := Parse_Type; + + for I:=0 to L.Count - 1 do + begin + SetKind(L[I], KindTYPE_FIELD); + SetVisibility(L[I], vis); + Gen(OP_ASSIGN_TYPE, L[I], TypeID, 0); + end; + + DECLARE_SWITCH := true; + + Parse_PortabilityDirective; + + if IsCurrText(';') then + Match(';'); + + if CurrToken.TokenClass <> tcIdentifier then + if not IsCurrText('[') then + break; + until false; + end + else if IsCurrText('class') then + begin + b := true; + Call_SCANNER; + if IsCurrText('constructor') then + Parse_ClassConstructorHeading(true, ClassTypeId, vis, IsExternalUnit) + else if IsCurrText('destructor') then + Parse_ClassDestructorHeading(true, ClassTypeId, vis, IsExternalUnit) + else if IsCurrText('procedure') then + Parse_ClassProcedureHeading(true, ClassTypeId, vis, IsExternalUnit) + else if IsCurrText('function') then + Parse_ClassFunctionHeading(true, ClassTypeId, vis, IsExternalUnit) + else if IsCurrText('property') then + Parse_ClassProperty(true, ClassTypeId, vis, IsExternalUnit) + else if IsCurrText('var') or IsCurrText('threadvar') then + begin + if vis = cvPublished then + Parse_VariableDeclaration(cvPublic) + else + Parse_VariableDeclaration(vis); + end; + end + else if IsCurrText('property') then + begin + Parse_ClassProperty(false, ClassTypeId, vis, IsExternalUnit); + b := true; + end + else if IsCurrText('type') then + begin + Parse_TypeDeclaration(false, vis); + b := true; + end + else if IsCurrText('const') then + begin + if vis = cvPublished then + Parse_ConstantDeclaration(cvPublic) + else + Parse_ConstantDeclaration(vis); + b := true; + end + else + begin + if IsCurrText('var') then + Call_SCANNER + else if IsCurrText('threadvar') then + Call_SCANNER; + + if b then + CreateError(errFieldDefinitionNotAllowedAfter, []); + + Parse_Attribute; + + L.Clear; + repeat // parse ident list + Id := Parse_Ident; + Gen(OP_DECLARE_MEMBER, CurrLevel, Id, 0); + L.Add(Id); + if NotMatch(',') then + break; + until false; + + DECLARE_SWITCH := false; + Match(':'); + + SavedPosition := CurrToken.Position; + + TypeID := Parse_Type; + + for I:=0 to L.Count - 1 do + begin + SetKind(L[I], KindTYPE_FIELD); + SetVisibility(L[I], vis); + Gen(OP_ASSIGN_TYPE, L[I], TypeID, 0); + + if Assigned(OnParseFieldDeclaration) then + begin + Declaration := GetName(L[I]) + ':' + + ExtractText(SavedPosition, CurrToken.Position + CurrToken.Length - 1); + OnParseFieldDeclaration(Owner, GetName(L[I]), L[I], GetName(TypeId), + Declaration); + end; + end; + end; + + DECLARE_SWITCH := true; + + Parse_PortabilityDirective; + + if IsCurrText(';') then + Match(';'); + until false; + finally + FreeAndNil(L); + end; + + if TrueClassId > 0 then + begin + EndHelperType(ClassTypeId); + + if Assigned(OnParseEndClassHelperTypeDeclaration) then + OnParseEndClassHelperTypeDeclaration(Owner, GetName(ClassTypeId), ClassTypeId); + end + else + begin + EndClassType(ClassTypeId); + + if Assigned(OnParseEndClassTypeDeclaration) then + OnParseEndClassTypeDeclaration(Owner, GetName(ClassTypeId), ClassTypeId); + + if FindConstructorId(ClassTypeId) = 0 then + GenDefaultConstructor(ClassTypeId); + if FindDestructorId(ClassTypeId) = 0 then + GenDefaultDestructor(ClassTypeId); + end; + + Match('end'); +end; + +procedure TPascalParser.Parse_MethodRefTypeDeclaration(TypeID: Integer); + +var + NegativeMethodIndex: Integer; + + function Parse_ProcedureHeading: Integer; + var + DirectiveList: TIntegerList; + Declaration: String; + SavedPosition: Integer; + begin + SavedPosition := CurrToken.Position; + + Dec(NegativeMethodIndex); + + DECLARE_SWITCH := true; + Match('procedure'); + result := NewTempVar(); + SetName(result, ANONYMOUS_METHOD_NAME); + BeginInterfaceMethod(result, TypeId, false); + if Assigned(OnParseBeginSubDeclaration) then + OnParseBeginSubDeclaration(Owner, GetName(result), result); + + Parse_FormalParameterList(result); + Gen(OP_ADD_METHOD_INDEX, result, NegativeMethodIndex, 0); + + DECLARE_SWITCH := true; + EndTypeDef(TypeId); + Match(';'); + + DirectiveList := Parse_DirectiveList(result); + if DirectiveList.IndexOf(dirABSTRACT) >= 0 then + CreateError(errUnknownDirective, ['abstract']); + EndSub(result); + FreeAndNil(DirectiveList); + + if Assigned(OnParseEndSubDeclaration) then + begin + Declaration := ExtractText(SavedPosition, PrevPosition + PrevLength - 1); + OnParseEndSubDeclaration(Owner, GetName(result), result, Declaration); + end; + end; + + function Parse_FunctionHeading: Integer; + var + ResTypeID: Integer; + DirectiveList: TIntegerList; + Declaration: String; + SavedPosition: Integer; + begin + SavedPosition := CurrToken.Position; + + Dec(NegativeMethodIndex); + + DECLARE_SWITCH := true; + Match('function'); + result := NewTempVar(); + SetName(result, ANONYMOUS_METHOD_NAME); + BeginInterfaceMethod(result, TypeId, true); + if Assigned(OnParseBeginSubDeclaration) then + OnParseBeginSubDeclaration(Owner, GetName(result), result); + Parse_FormalParameterList(result); + + DECLARE_SWITCH := false; + Match(':'); + Parse_Attribute; + ResTypeID := Parse_Type; + Gen(OP_ASSIGN_TYPE, result, ResTypeID, 0); + Gen(OP_ASSIGN_TYPE, CurrResultId, ResTypeID, 0); + Gen(OP_ADD_METHOD_INDEX, result, NegativeMethodIndex, 0); + if Assigned(OnParseResultType) then + OnParseResultType(Owner, GetName(ResTypeId), TypeId); + + DECLARE_SWITCH := true; + EndTypeDef(TypeId); + Match(';'); + + DirectiveList := Parse_DirectiveList(result); + if DirectiveList.IndexOf(dirABSTRACT) >= 0 then + CreateError(errUnknownDirective, ['abstract']); + EndSub(result); + FreeAndNil(DirectiveList); + + if Assigned(OnParseEndSubDeclaration) then + begin + Declaration := ExtractText(SavedPosition, PrevPosition + PrevLength - 1); + OnParseEndSubDeclaration(Owner, GetName(result), result, Declaration); + end; + end; + +var + SavedPosition: Integer; + Declaration: String; +begin + SavedPosition := CurrToken.Position; + + NegativeMethodIndex := 0; + + BeginMethodRefType(TypeID); + + if IsCurrText('procedure') then + begin + Parse_ProcedureHeading; + end + else if IsCurrText('function') then + begin + Parse_FunctionHeading; + end + else + Match('procedure'); + + EndMethodRefType(TypeId); + + if Assigned(OnParseMethodReferenceTypeDeclaration) then + begin + Declaration := ExtractText(SavedPosition, PrevPosition + + PrevLength - 1); + OnParseMethodReferenceTypeDeclaration(Owner, GetName(TypeId), TypeId, + Declaration); + end; +end; + +procedure TPascalParser.Parse_InterfaceTypeDeclaration(IntfTypeID: Integer); + +const + IsPacked = true; + +var + NegativeMethodIndex: Integer; + + function Parse_ProcedureHeading: Integer; + var + DirectiveList: TIntegerList; + Declaration: String; + SavedPosition: Integer; + begin + SavedPosition := CurrToken.Position; + + Dec(NegativeMethodIndex); + + DECLARE_SWITCH := true; + Match('procedure'); + result := Parse_Ident; + BeginInterfaceMethod(result, IntfTypeId, false); + if Assigned(OnParseBeginSubDeclaration) then + OnParseBeginSubDeclaration(Owner, GetName(result), result); + + Parse_FormalParameterList(result); + Gen(OP_ADD_METHOD_INDEX, result, NegativeMethodIndex, 0); + + DECLARE_SWITCH := true; + Match(';'); + + if IsCurrText('dispid') then + begin + Call_SCANNER; + Parse_Expression; + end; + + DirectiveList := Parse_DirectiveList(result); + if DirectiveList.IndexOf(dirABSTRACT) >= 0 then + CreateError(errUnknownDirective, ['abstract']); + EndSub(result); + if Assigned(OnParseEndSubDeclaration) then + begin + Declaration := ExtractText(SavedPosition, PrevPosition + PrevLength - 1); + OnParseEndSubDeclaration(Owner, GetName(result), result, Declaration); + end; + + FreeAndNil(DirectiveList); + end; + + function Parse_FunctionHeading: Integer; + var + TypeID: Integer; + DirectiveList: TIntegerList; + Declaration: String; + SavedPosition: Integer; + begin + SavedPosition := CurrToken.Position; + Dec(NegativeMethodIndex); + + DECLARE_SWITCH := true; + Match('function'); + result := Parse_Ident; + BeginInterfaceMethod(result, IntfTypeId, true); + if Assigned(OnParseBeginSubDeclaration) then + OnParseBeginSubDeclaration(Owner, GetName(result), result); + Parse_FormalParameterList(result); + + DECLARE_SWITCH := false; + Match(':'); + Parse_Attribute; + TypeID := Parse_Type; + Gen(OP_ASSIGN_TYPE, result, TypeID, 0); + Gen(OP_ASSIGN_TYPE, CurrResultId, TypeID, 0); + Gen(OP_ADD_METHOD_INDEX, result, NegativeMethodIndex, 0); + if Assigned(OnParseResultType) then + OnParseResultType(Owner, GetName(TypeId), TypeId); + + DECLARE_SWITCH := true; + Match(';'); + + if IsCurrText('dispid') then + begin + Call_SCANNER; + Parse_Expression; + end; + + DirectiveList := Parse_DirectiveList(result); + if DirectiveList.IndexOf(dirABSTRACT) >= 0 then + CreateError(errUnknownDirective, ['abstract']); + EndSub(result); + if Assigned(OnParseEndSubDeclaration) then + begin + Declaration := ExtractText(SavedPosition, PrevPosition + PrevLength - 1); + OnParseEndSubDeclaration(Owner, GetName(result), result, Declaration); + end; + FreeAndNil(DirectiveList); + end; + + function Parse_Property: Integer; + var + TypeID, ReadId, WriteId: Integer; + Declaration: String; + SavedPosition: Integer; + begin + DECLARE_SWITCH := true; + SavedPosition := CurrToken.Position; + Match('property'); + result := Parse_Ident; + BeginProperty(result, IntfTypeId); + + ReadId := 0; + WriteId := 0; + TypeId := 0; + + try + SetVisibility(result, cvPublic); + Parse_FormalParameterList(result, '['); + + DECLARE_SWITCH := false; + Match(':'); + TypeID := Parse_QualId; + Gen(OP_ASSIGN_TYPE, result, TypeID, 0); + + if IsCurrText('readonly') then + begin + Call_SCANNER; + end + else if IsCurrText('writeonly') then + begin + Call_SCANNER; + end; + + if IsCurrText('dispid') then + begin + Call_SCANNER; + Parse_Expression; + if IsNextText('default') then + begin + Match(';'); + Call_SCANNER; + SetDefault(result, true); + end; + EndProperty(result); + Exit; + end; + + repeat + if IsCurrText('read') and (ReadId = 0) then + begin + RemoveLastIdent(CurrToken.Id); + Call_SCANNER; + ReadId := Parse_QualId; + ReadId := Lookup(GetName(ReadId), IntfTypeId); + if ReadId = 0 then + RaiseError(errUndeclaredIdentifier, [CurrToken.Text]); + SetReadId(result, ReadId); + end + else if IsCurrText('write') and (WriteId = 0) then + begin + RemoveLastIdent(CurrToken.Id); + Call_SCANNER; + WriteId := Parse_QualId; + WriteId := Lookup(GetName(WriteId), IntfTypeId); + if WriteId = 0 then + RaiseError(errUndeclaredIdentifier, [CurrToken.Text]); + SetWriteId(result, WriteId); + end + else + break; + until false; + + if IsCurrText(';') then + Call_SCANNER + else + RaiseError(errTokenExpected, [';', CurrToken.Text]); + + if IsCurrText('default') then + begin + Call_SCANNER; + SetDefault(result, true); + end; + + if ReadId + WriteId = 0 then + RaiseError(errSyntaxError, []); + + EndProperty(result); + finally + if Assigned(OnParsePropertyDeclaration) then + begin + Declaration := ExtractText(SavedPosition, PrevPosition + + PrevLength - 1); + OnParsePropertyDeclaration(Owner, GetName(result), result, GetName(TypeId), + Declaration); + end; + end; + end; + +var + L: TIntegerList; + I, AncestorId: Integer; + S: String; + IntfList: TIntegerList; +begin + IntfList := TIntegerList.Create; + try + NegativeMethodIndex := 0; + + BeginInterfaceType(IntfTypeID); + SetPacked(IntfTypeID); + + if IsCurrText('dispinterface') then + Call_SCANNER + else + Match('interface'); + + if IsCurrText(';') then // forward declaration + begin + SetForward(IntfTypeId, true); + EndInterfaceType(IntfTypeId, true); + if Assigned(OnParseForwardTypeDeclaration) then + OnParseForwardTypeDeclaration(Owner, GetName(IntfTypeId), IntfTypeId); + Exit; + end; + + if IsCurrText('(') then + begin + DECLARE_SWITCH := false; + Match('('); + + repeat + AncestorId := Parse_Ident; + IntfList.Add(AncestorId); + Gen(OP_ADD_INTERFACE, IntfTypeId, AncestorId, 0); + if NotMatch(',') then + break; + until false; + + DECLARE_SWITCH := true; + Match(')'); + end + else + begin + Gen(OP_ADD_INTERFACE, IntfTypeId, H_IUnknown, 0); + IntfList.Add(H_IUnknown); + end; + + if IsCurrText('[') then + begin + Match('['); + if CurrToken.TokenClass = tcPCharConst then + begin + I := Parse_PCharLiteral; + S := GetValue(I); + SetGuid(IntfTypeId, S); + end + else + begin + I := Parse_Ident; + S := GetValue(I); + // SetGuid(IntfTypeId, S); + if ImportOnly then + GetSymbolRec(IntfTypeId).NoGUID := true; + end; + Match(']'); + end + else + begin + if ImportOnly then + GetSymbolRec(IntfTypeId).NoGUID := true; + SetNewGuid(IntfTypeId); + end; + + if Assigned(OnParseBeginInterfaceTypeDeclaration) then + OnParseBeginInterfaceTypeDeclaration(Owner, GetName(IntfTypeId), IntfTypeId); + if Assigned(OnParseAncestorTypeDeclaration) then + begin + AncestorId := IntfList[0]; + OnParseAncestorTypeDeclaration(Owner, GetName(AncestorId), AncestorId); + end; + if Assigned(OnParseUsedInterface) then + for I := 1 to IntfList.Count - 1 do + begin + AncestorId := IntfList[I]; + OnParseUsedInterface(Owner, GetName(AncestorId), AncestorId); + end; + + L := TIntegerList.Create; + try + repeat + if IsEOF then + Break; + if IsCurrText('end') then + Break; + + repeat + if IsCurrText('private') then + begin + CreateError(errKeywordNotAllowedInInterfaceDeclaration, [CurrToken.Text]); + Call_SCANNER; + end + else if IsCurrText('protected') then + begin + CreateError(errKeywordNotAllowedInInterfaceDeclaration, [CurrToken.Text]); + Call_SCANNER; + end + else if IsCurrText('public') then + begin + CreateError(errKeywordNotAllowedInInterfaceDeclaration, [CurrToken.Text]); + Call_SCANNER; + end + else if IsCurrText('published') then + begin + CreateError(errKeywordNotAllowedInInterfaceDeclaration, [CurrToken.Text]); + Call_SCANNER; + end + else + break; + + until false; + + if IsCurrText('end') then + Break; + + if IsCurrText('procedure') then + begin + Parse_ProcedureHeading; + end + else if IsCurrText('function') then + begin + Parse_FunctionHeading; + end + else if IsCurrText('property') then + begin + Parse_Property; + end + else if IsCurrText('[') then + Parse_Attribute + else + Match('end'); + + DECLARE_SWITCH := true; + + if IsCurrText(';') then + Match(';'); + until false; + finally + FreeAndNil(L); + end; + + EndInterfaceType(IntfTypeId); + if Assigned(OnParseEndInterfaceTypeDeclaration) then + OnParseEndInterfaceTypeDeclaration(Owner, GetName(IntfTypeId), IntfTypeId); + + Match('end'); + finally + FreeAndNil(IntfList); + end; +end; + +procedure TPascalParser.Parse_PointerTypeDeclaration(TypeID: Integer); +var + RefTypeId: Integer; + Declaration: String; + SavedPosition: Integer; +begin + SavedPosition := CurrToken.Position; + DECLARE_SWITCH := false; + Match('^'); + BeginPointerType(TypeID); + RefTypeId := Parse_QualId; + Gen(OP_CREATE_POINTER_TYPE, TypeId, RefTypeId, 0); + EndPointerType(TypeID); + if Assigned(OnParsePointerTypeDeclaration) then + begin + Declaration := GetName(TypeId) + '=' + + ExtractText(SavedPosition, CurrToken.Position + CurrToken.Length - 1); + OnParsePointerTypeDeclaration(Owner, + GetName(TypeId), TypeId, GetName(RefTypeId), Declaration); + end; +end; + +{$IFNDEF PAXARM} +procedure TPascalParser.Parse_ShortStringTypeDeclaration(TypeID: Integer); +var + ExprId: Integer; + Declaration: String; + SavedPosition: Integer; +begin + SavedPosition := CurrToken.Position; + DECLARE_SWITCH := false; + Match('['); + BeginShortStringType(TypeID); + ExprId := Parse_ConstantExpression; + Gen(OP_CREATE_SHORTSTRING_TYPE, TypeId, ExprId, 0); + EndShortStringType(TypeID); + Match(']'); + if Assigned(OnParseShortStringTypeDeclaration) then + begin + Declaration := 'String' + ExtractText(SavedPosition, PrevPosition + PrevLength - 1); + OnParseShortStringTypeDeclaration(Owner, GetName(TypeId), TypeId, GetValue(ExprId), + Declaration); + end; +end; +{$ENDIF} + +procedure TPascalParser.Parse_ProceduralTypeDeclaration(TypeID: Integer; + var SubId: Integer); +var + IsFunc: Boolean; + SubTypeId: Integer; + Declaration: String; + SavedPosition: Integer; +begin + SavedPosition := CurrToken.Position; + if IsCurrText('function') then + begin + Match('function'); + IsFunc := true; + end + else + begin + Match('procedure'); + IsFunc := false; + end; + SubTypeId := typeVOID; + SubId := NewTempVar; + BeginProceduralType(TypeID, SubId); + if Assigned(OnParseBeginSubDeclaration) then + OnParseBeginSubDeclaration(Owner, GetName(SubId), SubId); + Parse_FormalParameterList(SubId); + DECLARE_SWITCH := false; + if IsFunc then + begin + Match(':'); + DECLARE_SWITCH := true; + SubTypeID := Parse_Type; + if Assigned(OnParseResultType) then + OnParseResultType(Owner, GetName(SubTypeID), SubTypeID); + end; + Gen(OP_ASSIGN_TYPE, SubId, SubTypeID, 0); + Gen(OP_ASSIGN_TYPE, CurrResultId, SubTypeID, 0); + EndProceduralType(TypeID); + + if Assigned(OnParseEndSubDeclaration) then + begin + Declaration := ExtractText(SavedPosition, PrevPosition + PrevLength - 1); + end; + + if IsCurrText('of') then + begin + Match('of'); + Match('object'); + SetType(TypeId, typeEVENT); + end; + + DECLARE_SWITCH := true; + + if IsCurrText('stdcall') then + begin + RemoveLastIdent(CurrToken.Id); + Call_SCANNER; + SetCallConvention(SubId, ccSTDCALL); + end + else if IsCurrText('safecall') then + begin + RemoveLastIdent(CurrToken.Id); + Call_SCANNER; + SetCallConvention(SubId, ccSTDCALL); + end + else if IsCurrText('register') then + begin + RemoveLastIdent(CurrToken.Id); + Call_SCANNER; + SetCallConvention(SubId, ccSTDCALL); + end + else if IsCurrText('cdecl') then + begin + RemoveLastIdent(CurrToken.Id); + Call_SCANNER; + SetCallConvention(SubId, ccSTDCALL); + end + else if IsCurrText('msfastcall') then + begin + RemoveLastIdent(CurrToken.Id); + Call_SCANNER; + SetCallConvention(SubId, ccSTDCALL); + end + else if IsCurrText('pascal') then + begin + RemoveLastIdent(CurrToken.Id); + Call_SCANNER; + SetCallConvention(SubId, ccSTDCALL); + end + //-------------- + else if IsNextText('stdcall') then + begin + Call_SCANNER; + RemoveLastIdent(CurrToken.Id); + SetCallConvention(SubId, ccSTDCALL); + Call_SCANNER; + end + else if IsNextText('safecall') then + begin + Call_SCANNER; + RemoveLastIdent(CurrToken.Id); + SetCallConvention(SubId, ccSAFECALL); + Call_SCANNER; + end + else if IsNextText('register') then + begin + Call_SCANNER; + RemoveLastIdent(CurrToken.Id); + SetCallConvention(SubId, ccREGISTER); + Call_SCANNER; + end + else if IsNextText('cdecl') then + begin + Call_SCANNER; + RemoveLastIdent(CurrToken.Id); + SetCallConvention(SubId, ccCDECL); + Call_SCANNER; + end + else if IsNextText('msfastcall') then + begin + Call_SCANNER; + RemoveLastIdent(CurrToken.Id); + SetCallConvention(SubId, ccMSFASTCALL); + Call_SCANNER; + end + else if IsNextText('pascal') then + begin + Call_SCANNER; + RemoveLastIdent(CurrToken.Id); + SetCallConvention(SubId, ccPASCAL); + Call_SCANNER; + end; + + if Assigned(OnParseEndSubDeclaration) then + begin + OnParseEndSubDeclaration(Owner, GetName(SubId), SubId, Declaration); + end; + + if GetType(TypeId) = typePROC then + begin + if Assigned(OnParseProceduralTypeDeclaration) then + begin + Declaration := ExtractText(SavedPosition, CurrToken.Position + + CurrToken.Length - 1); + OnParseProceduralTypeDeclaration(Owner, GetName(TypeId), TypeId, + Declaration); + end; + end + else + begin + if Assigned(OnParseEventTypeDeclaration) then + begin + Declaration := ExtractText(SavedPosition, CurrToken.Position + + CurrToken.Length - 1); + OnParseEventTypeDeclaration(Owner, GetName(TypeId), TypeId, + Declaration); + end; + end; +end; + +procedure TPascalParser.Parse_SetTypeDeclaration(TypeID: Integer); +var + TypeBaseId: Integer; + Declaration: String; + SavedPosition: Integer; +begin + SavedPosition := CurrToken.Position; + DECLARE_SWITCH := false; + Match('set'); + Match('of'); + TypeBaseId := Parse_OrdinalType(Declaration); + BeginSetType(TypeID, TypeBaseId); + EndSetType(TypeID); + if Assigned(OnParseSetTypeDeclaration) then + begin + Declaration := GetName(TypeId) + '=' + + ExtractText(SavedPosition, CurrToken.Position + CurrToken.Length - 1); + OnParseSetTypeDeclaration(Owner, GetName(TypeId), TypeId, GetName(TypeBaseId), + Declaration); + end; +end; + +procedure TPascalParser.Parse_EnumTypeDeclaration(TypeID: Integer); +var + ID, TempID, L, K: Integer; + Declaration: String; + SavedPosition: Integer; +begin + L := CurrLevel; + + BeginEnumType(TypeID, TypeINTEGER); + if Assigned(OnParseBeginEnumTypeDeclaration) then + OnParseBeginEnumTypeDeclaration(Owner, GetName(TypeId), TypeId); + + DECLARE_SWITCH := true; + Match('('); + + TempID := NewConst(TypeID, 0); + + K := 0; + + repeat + SavedPosition := CurrToken.Position; + + ID := Parse_EnumIdent; + + Inc(K); + + SetLevel(ID, L); + + if IsCurrText('=') then + begin + DECLARE_SWITCH := false; + Match('='); + Gen(OP_ASSIGN_ENUM, ID, Parse_ConstantExpression, ID); + Gen(OP_ASSIGN_ENUM, TempID, ID, TempID); + Gen(OP_INC, TempID, NewConst(typeINTEGER, 1), tempID); + DECLARE_SWITCH := true; + end + else + begin + Gen(OP_ASSIGN_ENUM, ID, TempID, ID); + Gen(OP_INC, TempID, NewConst(typeINTEGER, 1), tempID); + end; + + if Assigned(OnParseEnumName) then + begin + Declaration := ExtractText(SavedPosition, PrevPosition + PrevLength - 1); + OnParseEnumName(Owner, GetName(ID), ID, K - 1, Declaration); + end; + + if NotMatch(',') then + Break; + until false; + Match(')'); + EndEnumType(TypeID, K); + if Assigned(OnParseEndEnumTypeDeclaration) then + OnParseEndEnumTypeDeclaration(Owner, GetName(TypeId), TypeId); +end; + +procedure TPascalParser.Parse_SubrangeTypeDeclaration(TypeID, TypeBaseId: Integer; + var Declaration: String; + Expr1ID: Integer = 0); +var + ID1, ID2, ExprId1, ExprId2: Integer; + SavedPosition: Integer; +begin + SavedPosition := Scanner.FindPosition([Ord('='), Ord('['), Ord(':'), Ord(',')]) + 1; + + BeginSubrangeType(TypeID, TypeBaseID); + + ID1 := NewConst(TypeBaseId); + ID2 := NewConst(TypeBaseId); + + if Expr1ID = 0 then + begin + ExprId1 := Parse_ConstantExpression; + Gen(OP_ASSIGN_CONST, ID1, ExprId1, ID1); + end + else + begin + Gen(OP_ASSIGN_CONST, ID1, Expr1ID, ID1); + end; + + Match('..'); + ExprId2 := Parse_ConstantExpression; + Gen(OP_ASSIGN_CONST, ID2, ExprId2, ID2); + + Gen(OP_CHECK_SUBRANGE_TYPE, ID1, ID2, 0); + + EndSubrangeType(TypeID); + + Declaration := GetName(TypeId) + ' = ' + ExtractText(SavedPosition, PrevPosition + PrevLength - 1); + if Assigned(OnParseSubrangeTypeDeclaration) then + OnParseSubrangeTypeDeclaration(Owner, GetName(TypeId), TypeId, Declaration); +end; + +function TPascalParser.Parse_FormalParameterList(SubId: Integer; + bracket: Char = '('): Integer; +var + L: TIntegerList; + I, ID, TypeId, ExprId: Integer; + ByRef, IsConst, HasDefaultParameters, IsOpenArray, IsOut: Boolean; + Declaration, DefaultValue, ParamMod, StrType: String; + SavedPosition: Integer; +begin + result := 0; + if Assigned(OnParseBeginFormalParameterList) then + OnParseBeginFormalParameterList(Owner); + + BeginCollectSig(SubId); + try + DECLARE_SWITCH := true; + if IsCurrText('(') then + Call_SCANNER + else if IsCurrText('[') then + Call_SCANNER + else + begin + if IsCurrText(':') then + Sig := '( ) : ' + GetNextText + else + Sig := '( ) ;'; + Exit; + end; + + HasDefaultParameters := false; + + if not IsCurrText(')') then + begin + L := TIntegerList.Create; + + StrType := ''; + + try + + repeat + ByRef := false; + IsConst := false; + IsOut := false; + + Parse_Attribute; + + ParamMod := ''; + if IsCurrText('var') then + begin + ParamMod := 'var'; + Match('var'); + ByRef := true; + end + else if IsCurrText('out') then + begin + ParamMod := 'out'; + Match('out'); + ByRef := true; + IsOut := true; + end + else if IsCurrText('const') then + begin + ParamMod := 'const'; + Match('const'); + IsConst := true; + end; + + Parse_Attribute; + + L.Clear; + repeat + Inc(result); + ID := Parse_FormalParameter; + Gen(OP_DECLARE_LOCAL_VAR, SubId, ID, 0); + L.Add(ID); + if NotMatch(',') then + break; + until false; + DECLARE_SWITCH := false; + + IsOpenArray := false; + if ByRef or IsConst then + begin + if IsCurrText(':') then + begin + Match(':'); + IsOpenArray := IsCurrText('array'); + if IsOpenArray then + TypeId := Parse_OpenArrayType(StrType) + else + begin + TypeId := Parse_Type; + StrType := GetName(TypeId); + end; + end + else + TypeId := typePVOID; + end + else + begin + Match(':'); + IsOpenArray := IsCurrText('array'); + if IsOpenArray then + TypeId := Parse_OpenArrayType(StrType) + else + begin + TypeId := Parse_Type; + StrType := GetName(TypeId); + end; + end; + + DECLARE_SWITCH := true; + + for I:=0 to L.Count - 1 do + begin + if ByRef then if not IsOpenArray then + SetByRef(L[I]); + + if IsOut then + GetSymbolRec(L[I]).IsOut := true; + + if IsConst then + SetIsConst(L[I]); + + if IsOpenArray then + begin + SetOpenArray(L[I], true); + end; + + Gen(OP_ASSIGN_TYPE, L[I], TypeID, 0); + end; + + DefaultValue := ''; + + if IsCurrText('=') then + begin + // if L.Count > 1 then + // CreateError(errParameterNotAllowedHere, [GetName(L[1])]); + DECLARE_SWITCH := false; + CollectSig := false; + Sig := RemoveCh('=', Sig); + + Match('='); + + SavedPosition := CurrToken.Position; + if ImportOnly then + ExprId := Parse_Expression + else + ExprId := Parse_ConstantExpression; + DefaultValue := ExtractText(SavedPosition, PrevPosition + PrevLength - 1); + + for I := 0 to L.Count - 1 do + begin + Gen(OP_ASSIGN_CONST, L[I], ExprId, L[I]); + SetOptional(L[I]); + end; + CollectSig := true; + Sig := Sig + CurrToken.Text; + + DECLARE_SWITCH := true; + HasDefaultParameters := true; + end + else + begin + if HasDefaultParameters then + CreateError(errDefaultValueRequired, [GetName(L[0])]); + end; + + if Assigned(OnParseFormalParameterDeclaration) then + begin + if IsOpenArray then + StrType := 'ARRAY OF ' + StrType; + + for I := 0 to L.Count - 1 do + begin + if DefaultValue = '' then + Declaration := GetName(L[I]) + ' : ' + StrType + ';' + else + Declaration := GetName(L[I]) + ' : ' + + StrType + '=' + DefaultValue + ';'; + + if ParamMod <> '' then + Declaration := ParamMod + ' ' + Declaration; + + OnParseFormalParameterDeclaration(Owner, + GetName(L[I]), L[I], StrType, DefaultValue, Declaration); + end; + end; + + if NotMatch(';') then + Break; + until false; + + finally + FreeAndNil(L); + end; + end; + + if bracket = '(' then + Match(')') + else if bracket = '[' then + Match(']'); + + if IsCurrText(':') then + Sig := Sig + ' ' + GetNextText; + finally + SetCount(SubId, result); + EndCollectSig(SubId); + + if Assigned(OnParseEndFormalParameterList) then + OnParseEndFormalParameterList(Owner); + end; +end; + +procedure TPascalParser.Parse_SubBlock; +begin + if GetName(CurrSelfId) = '' then + begin + Gen(OP_STMT, 0, 0, 0); + Parse_Block; + end + else + begin + Gen(OP_STMT, 0, 0, 0); + DECLARE_SWITCH := true; + Parse_DeclarationPart; + + Gen(OP_BEGIN_WITH, CurrSelfId, 0, 0); + WithStack.Push(CurrSelfId); + Parse_CompoundStmt; + Gen(OP_END_WITH, WithStack.Top, 0, 0); + WithStack.Pop; + end; +end; + +procedure TPascalParser.Parse_ProcedureDeclaration(IsSharedMethod: Boolean = false); +var + SubId, ForwardId: Integer; + DirectiveList: TIntegerList; + NotDeclared, WaitOverload: Boolean; + K: Integer; +begin + DECLARE_SWITCH := true; + K := 0; + BeginMethodDef; + try + + NotDeclared := false; + WaitOverload := false; + + if IsSharedMethod then + begin + ForwardId := ReadType; + + if ForwardId = 0 then + CreateError(errUndeclaredIdentifier, [CurrToken.Text]); + + Call_SCANNER; + DECLARE_SWITCH := true; + Scanner.CurrComment.AllowedDoComment := false; + Match('.'); + SubId := Parse_Ident; + BeginClassMethod(SubId, ForwardId, false, true, true); + end + else + begin + ForwardId := ReadType; + + if (ForwardId > 0) and (GetKind(ForwardId) = KindTYPE) then + begin + Call_SCANNER; + + while GetNext2Text = '.' do + begin + Inc(K); + levelStack.Push(ForwardId); + ReadToken; + ForwardId := Lookup(CurrToken.Text, CurrLevel); + if ForwardId = 0 then + RaiseError(errUndeclaredIdentifier, [CurrToken.Text]); + ReadToken; + end; + + DECLARE_SWITCH := true; + Scanner.CurrComment.AllowedDoComment := false; + Match('.'); + SubId := Parse_Ident; + if Lookup(GetName(SubId), ForwardId) = 0 then + NotDeclared := true; + BeginClassMethod(SubId, ForwardId, false, false, true); + end + else + begin + if ForwardId > 0 then + if GetKind(ForwardId) in KindSUBS then + if not GetSymbolRec(ForwardId).IsForward then + if GetSymbolRec(ForwardId).Host = false then + if GetSymbolRec(ForwardId).OverCount = 0 then + RaiseError(errRedeclaredIdentifier, [CurrToken.Text]) + else + WaitOverload := true; + + SubId := NewVar(CurrToken.Text); + SetPosition(SubId, CurrToken.Position - 1); + CurrToken.Id := SubId; + Parse_Ident; + BeginSub(SubId); + end; + end; + + Parse_FormalParameterList(SubId); + SetName(CurrResultId, ''); + SetKind(CurrResultId, KindNONE); + SetType(SubId, TypeVOID); + SetType(CurrResultId, TypeVOID); + + Match(';'); + + if NotDeclared then + CreateError(errUndeclaredIdentifier, [GetName(SubId)]); + + DirectiveList := Parse_DirectiveList(SubId); + try + if DirectiveList.IndexOf(dirFORWARD) >= 0 then + begin + SetForward(SubId, true); + EndSub(SubId); + Exit; + end; + if WaitOverload then + begin + if DirectiveList.IndexOf(dirOVERLOAD) = -1 then + CreateError(errOverloadExpected, [GetName(SubId)]); + end; + finally + FreeAndNil(DirectiveList); + end; + + if IsCurrText('external') then + begin + ParseExternalSub(SubId); + Exit; + end; + + InitSub(SubId); + + if ForwardId > 0 then + if not GetSymbolRec(ForwardId).IsForward then + CheckRedeclaredSub(SubId); + + Parse_SubBlock; + EndSub(SubId); + + EndMethodDef(SubId); + + Match(';'); + + finally + while K > 0 do + begin + Dec(K); + levelStack.Pop; + end; + end; +end; + +function TPascalParser.Parse_AnonymousFunction: Integer; +begin + result := Parse_AnonymousRoutine(true); +end; + +function TPascalParser.Parse_AnonymousProcedure: Integer; +begin + result := Parse_AnonymousRoutine(false); +end; + +function TPascalParser.Parse_AnonymousRoutine(IsFunc: Boolean): Integer; +var + I, Id, RefId, ClassId, SubId, ResTypeId: Integer; + ClsName, ObjName: String; +begin + NewAnonymousNames(ClsName, ObjName); + GenComment('BEGIN OF ANONYMOUS CLASS ' + ClsName); + + TypeParams.Clear; + + ClassId := NewTempVar; + SetName(ClassId, ClsName); + BeginClassType(ClassId); + SetPacked(ClassId); + SetAncestorId(ClassId, H_TInterfacedObject); +// Gen(OP_ADD_INTERFACE, ClassId, 0, 0); // 0 - anonymous + + GenDefaultConstructor(ClassId); + GenDefaultDestructor(ClassId); + + DECLARE_SWITCH := true; + if IsFunc then + Match('function') + else + Match('procedure'); + + DECLARE_SWITCH := false; + + SubId := NewTempVar; + SetName(SubId, ANONYMOUS_METHOD_NAME); + BeginClassMethod(SubId, + ClassId, + IsFunc, // has result + false, // is shared + true); // is implementation + + Parse_FormalParameterList(SubId); + DECLARE_SWITCH := false; + if IsFunc then + begin + Match(':'); + Parse_Attribute; + ResTypeId := Parse_Type; + Gen(OP_ASSIGN_TYPE, SubId, ResTypeId, 0); + Gen(OP_ASSIGN_TYPE, CurrResultId, ResTypeId, 0); + end; + + DECLARE_SWITCH := true; + + AnonymStack.Push(SubId); + try + InitSub(SubId); + Parse_SubBlock; + + EndSub(SubId); + + for I := 0 to AnonymStack.Top.BindList.Count - 1 do + begin + Id := NewTempVar; + SetName(Id, GetName(AnonymStack.Top.BindList[I])); + SetLevel(Id, ClassId); + SetKind(Id, KindTYPE_FIELD); + SetVisibility(Id, cvPublic); + Gen(OP_ASSIGN_THE_SAME_TYPE, Id, AnonymStack.Top.BindList[I], 0); + end; + + EndClassType(ClassId); + GenComment('END OF ANONYMOUS CLASS ' + ClsName); + Gen(OP_ADD_TYPEINFO, ClassId, 0, 0); + + result := NewTempVar; + Gen(OP_DECLARE_LOCAL_VAR, CurrSubId, result, 0); + SetName(result, ObjName); + SetType(result, ClassId); + + RefId := NewField('Create', result); + Gen(OP_FIELD, ClassId, RefId, RefId); + Gen(OP_ASSIGN, result, RefId, result); + + for I := 0 to AnonymStack.Top.BindList.Count - 1 do + begin + RefId := NewField(GetName(AnonymStack.Top.BindList[I]), result); + Gen(OP_FIELD, result, RefId, RefId); + Gen(OP_ASSIGN, RefId, AnonymStack.Top.BindList[I], RefId); + end; + finally + AnonymStack.Pop; + end; + Gen(OP_ADD_INTERFACE, ClassId, 0, 0); // 0 - anonymous +end; + +function TPascalParser.Parse_LambdaExpression: Integer; +var + I, Id, RefId, ClassId, SubId: Integer; + ClsName, ObjName: String; +begin + NewAnonymousNames(ClsName, ObjName); + GenComment('BEGIN OF ANONYMOUS CLASS ' + ClsName); + + TypeParams.Clear; + + ClassId := NewTempVar; + SetName(ClassId, ClsName); + BeginClassType(ClassId); + SetPacked(ClassId); + SetAncestorId(ClassId, H_TInterfacedObject); + + GenDefaultConstructor(ClassId); + GenDefaultDestructor(ClassId); + + SubId := NewTempVar; + Gen(OP_ASSIGN_LAMBDA_TYPES, SubId, 0, 0); + + SetName(SubId, ANONYMOUS_METHOD_NAME); + BeginClassMethod(SubId, + ClassId, + true, // has result + false, // is shared + true); // is implementation + + DECLARE_SWITCH := true; + Match('lambda'); + + Parse_LambdaParameters(SubId); + DECLARE_SWITCH := false; + + Match('=>'); + + AnonymStack.Push(SubId); + try + InitSub(SubId); + Gen(OP_BEGIN_WITH, CurrSelfId, 0, 0); + WithStack.Push(CurrSelfId); + Id := CurrResultId; + Gen(OP_ASSIGN, Id, Parse_Expression, Id); + Gen(OP_END_WITH, WithStack.Top, 0, 0); + WithStack.Pop; + EndSub(SubId); + + for I := 0 to AnonymStack.Top.BindList.Count - 1 do + begin + Id := NewTempVar; + SetName(Id, GetName(AnonymStack.Top.BindList[I])); + SetLevel(Id, ClassId); + SetKind(Id, KindTYPE_FIELD); + SetVisibility(Id, cvPublic); + Gen(OP_ASSIGN_THE_SAME_TYPE, Id, AnonymStack.Top.BindList[I], 0); + end; + + EndClassType(ClassId); + GenComment('END OF ANONYMOUS CLASS ' + ClsName); + Gen(OP_ADD_TYPEINFO, ClassId, 0, 0); + + result := NewTempVar; + Gen(OP_DECLARE_LOCAL_VAR, CurrSubId, result, 0); + SetName(result, ObjName); + SetType(result, ClassId); + + RefId := NewField('Create', result); + Gen(OP_FIELD, ClassId, RefId, RefId); + Gen(OP_ASSIGN, result, RefId, result); + + for I := 0 to AnonymStack.Top.BindList.Count - 1 do + begin + RefId := NewField(GetName(AnonymStack.Top.BindList[I]), result); + Gen(OP_FIELD, result, RefId, RefId); + Gen(OP_ASSIGN, RefId, AnonymStack.Top.BindList[I], RefId); + end; + finally + AnonymStack.Pop; + end; + + Gen(OP_ASSIGN_LAMBDA_TYPES, SubId, ClassId, result); +end; + +function TPascalParser.Parse_LambdaParameters(SubId: Integer) : Integer; +var + ID: Integer; +begin + result := 0; + + if not IsCurrText('(') then + repeat + Inc(result); + ID := Parse_FormalParameter; + Gen(OP_DECLARE_LOCAL_VAR, SubId, ID, 0); + SetCount(SubId, result); + if NotMatch(',') then + Exit; + until false; + + Match('('); + if IsCurrText(')') then + begin + Match(')'); + SetCount(SubId, result); + Exit; + end; + + repeat + Inc(result); + ID := Parse_FormalParameter; + Gen(OP_DECLARE_LOCAL_VAR, SubId, ID, 0); + if NotMatch(',') then + break; + until false; + + Match(')'); + SetCount(SubId, result); +end; + +procedure TPascalParser.Parse_FunctionDeclaration(IsSharedMethod: Boolean = false); +var + SubId, TypeId, ForwardId: Integer; + DirectiveList: TIntegerList; + L: TIntegerList; + NotDeclared, WaitOverload: Boolean; + K: Integer; +begin + DECLARE_SWITCH := true; + K := 0; + BeginMethodDef; + try + + NotDeclared := false; + WaitOverload := false; + + if IsSharedMethod then + begin + ForwardId := ReadType; + + if ForwardId = 0 then + CreateError(errUndeclaredIdentifier, [CurrToken.Text]); + + Call_SCANNER; + DECLARE_SWITCH := true; + Scanner.CurrComment.AllowedDoComment := false; + Match('.'); + SubId := Parse_Ident; + BeginClassMethod(SubId, ForwardId, true, true, true); + end + else + begin + ForwardId := ReadType; + + if (ForwardId > 0) and (GetKind(ForwardId) = KindTYPE) then + begin + Call_SCANNER; + + while GetNext2Text = '.' do + begin + Inc(K); + levelStack.Push(ForwardId); + ReadToken; + ForwardId := Lookup(CurrToken.Text, CurrLevel); + if ForwardId = 0 then + RaiseError(errUndeclaredIdentifier, [CurrToken.Text]); + ReadToken; + end; + + DECLARE_SWITCH := true; + Scanner.CurrComment.AllowedDoComment := false; + Match('.'); + SubId := Parse_Ident; + if Lookup(GetName(SubId), ForwardId) = 0 then + NotDeclared := true; + BeginClassMethod(SubId, ForwardId, true, false, true); + end + else + begin + if ForwardId > 0 then + if GetKind(ForwardId) in KindSUBS then + if not GetSymbolRec(ForwardId).IsForward then + if GetSymbolRec(ForwardId).OverCount = 0 then + RaiseError(errRedeclaredIdentifier, [CurrToken.Text]) + else + WaitOverload := true; + + SubId := NewVar(CurrToken.Text); + SetPosition(SubId, CurrToken.Position - 1); + Parse_Ident; + BeginSub(SubId); + end; + end; + + Parse_FormalParameterList(SubId); + DECLARE_SWITCH := false; + + if IsCurrText(';') then + begin + L := LookupForwardDeclarations(SubId); + if L = nil then + RaiseError(errUnsatisfiedForwardOrExternalDeclaration, [GetName(SubId)]) + else + FreeAndNil(L); + end + else + begin + Match(':'); + Parse_Attribute; + TypeID := Parse_Type; + Gen(OP_ASSIGN_TYPE, SubId, TypeID, 0); + Gen(OP_ASSIGN_TYPE, CurrResultId, TypeID, 0); + end; + + DECLARE_SWITCH := true; + + if IsCurrText(';') then + Match(';'); + + if NotDeclared then + CreateError(errUndeclaredIdentifier, [GetName(SubId)]); + + DirectiveList := Parse_DirectiveList(SubId); + try + if DirectiveList.IndexOf(dirFORWARD) >= 0 then + begin + SetForward(SubId, true); + EndSub(SubId); + Exit; + end; + if WaitOverload then + if DirectiveList.IndexOf(dirOVERLOAD) = -1 then + CreateError(errOverloadExpected, [GetName(SubId)]); + finally + FreeAndNil(DirectiveList); + end; + + if IsCurrText('external') then + begin + ParseExternalSub(SubId); + Exit; + end; + + InitSub(SubId); + + if ForwardId > 0 then + if not GetSymbolRec(ForwardId).IsForward then + CheckRedeclaredSub(SubId); + + if InitFuncResult then + Gen(OP_CALL_DEFAULT_CONSTRUCTOR, CurrResultId, 0, 0); + + Parse_SubBlock; + EndSub(SubId); + + EndMethodDef(SubId); + Match(';'); + + finally + + while K > 0 do + begin + Dec(K); + levelStack.Pop; + end; + + end; +end; + +procedure TPascalParser.Parse_OperatorDeclaration; +var + I, SubId, TypeId, ForwardId: Integer; + L: TIntegerList; + NotDeclared: Boolean; +begin + NotDeclared := false; + + ReadToken; + ForwardId := Lookup(CurrToken.Text, CurrLevel); + if ForwardId = 0 then + CreateError(errUndeclaredIdentifier, [CurrToken.Text]); + + Call_SCANNER; + DECLARE_SWITCH := true; + Match('.'); + I := OperatorIndex(CurrToken.Text); + if I = -1 then + CreateError(errE2393, []); + // errE2393 = 'Invalid operator declaration'; + SubId := Parse_Ident; + SetName(SubId, operators.Values[I]); + BeginStructureOperator(SubId, ForwardId); + + Parse_FormalParameterList(SubId); + DECLARE_SWITCH := false; + + if IsCurrText(';') then + begin + L := LookupForwardDeclarations(SubId); + if L = nil then + RaiseError(errUnsatisfiedForwardOrExternalDeclaration, [GetName(SubId)]) + else + FreeAndNil(L); + end + else + begin + Match(':'); + Parse_Attribute; + TypeID := Parse_Type; + Gen(OP_ASSIGN_TYPE, SubId, TypeID, 0); + Gen(OP_ASSIGN_TYPE, CurrResultId, TypeID, 0); + end; + + DECLARE_SWITCH := true; + Match(';'); + + if NotDeclared then + CreateError(errUndeclaredIdentifier, [GetName(SubId)]); + + if IsCurrText('external') then + begin + ParseExternalSub(SubId); + Exit; + end; + + InitSub(SubId); + + if ForwardId > 0 then + if not GetSymbolRec(ForwardId).IsForward then + if not StrEql(GetName(SubId), pascal_Implicit) then + if not StrEql(GetName(SubId), pascal_Explicit) then + CheckRedeclaredSub(SubId); + + Parse_SubBlock; + EndSub(SubId); + Match(';'); +end; + +procedure TPascalParser.Parse_ConstructorDeclaration; +var + ClassTypeId, SubId, L: Integer; + DirectiveList: TIntegerList; + OldSubId: Integer; + K, ForwardId: Integer; +begin + DECLARE_SWITCH := true; + K := 0; + ClassTypeId := 0; + BeginMethodDef; + try + ForwardId := ReadType; + + if (ForwardId > 0) and (GetKind(ForwardId) = KindTYPE) then + begin + Call_SCANNER; + + while GetNext2Text = '.' do + begin + Inc(K); + levelStack.Push(ForwardId); + ReadToken; + ForwardId := Lookup(CurrToken.Text, CurrLevel); + if ForwardId = 0 then + RaiseError(errUndeclaredIdentifier, [CurrToken.Text]); + ReadToken; + end; + + ClassTypeId := ForwardId; + DECLARE_SWITCH := true; + Match('.'); + SubId := Parse_Ident; + if GetSymbolRec(ClassTypeId).FinalTypeId = typeRECORD then + BeginStructureConstructor(SubId, ClassTypeId) + else + BeginClassConstructor(SubId, ClassTypeId); + end + else + RaiseError(errUndeclaredIdentifier, [CurrToken.Text]); + + Parse_FormalParameterList(SubId); + + Inc(EXECUTABLE_SWITCH); + Match(';'); + + DirectiveList := Parse_DirectiveList(SubId); + if DirectiveList.IndexOf(dirFORWARD) >= 0 then + begin + SetForward(SubId, true); + EndSub(SubId); + FreeAndNil(DirectiveList); + + Dec(EXECUTABLE_SWITCH); + Exit; + end; + FreeAndNil(DirectiveList); + + OldSubId := SubId; + InitSub(SubId); + + if OldSubId = SubId then + RaiseError(errUndeclaredIdentifier, [GetName(OldSubId)]); + + if GetSymbolRec(ClassTypeId).FinalTypeId = typeRECORD then + begin + Parse_SubBlock; + end + else + begin + + WasInherited := false; + + Gen(OP_SAVE_EDX, 0, 0, 0); + L := NewLabel; + Gen(OP_GO_DL, L, 0, 0); + Gen(OP_CREATE_OBJECT, ClassTypeId, 0, CurrSelfId); + SetLabelHere(L); + + Parse_SubBlock; + +// if not WasInherited then +// CreateError(errTheCallOfInheritedConstructorIsMandatory, []); + + Gen(OP_RESTORE_EDX, 0, 0, 0); + L := NewLabel; + Gen(OP_GO_DL, L, 0, 0); + Gen(OP_ON_AFTER_OBJECT_CREATION, CurrSelfId, 0, 0); + SetLabelHere(L); + end; + + EndSub(SubId); + + Dec(EXECUTABLE_SWITCH); + + EndMethodDef(SubId); + Match(';'); + + finally + + while K > 0 do + begin + Dec(K); + levelStack.Pop; + end; + + end; +end; + +procedure TPascalParser.Parse_DestructorDeclaration; +var + ClassTypeId, SubId, NP: Integer; + DirectiveList: TIntegerList; + OldSubId: Integer; + K: Integer; +begin + DECLARE_SWITCH := true; + K := 0; + BeginMethodDef; + try + + ClassTypeId := ReadType; + + if (ClassTypeId > 0) and (GetKind(ClassTypeId) = KindTYPE) then + begin + Call_SCANNER; + + while GetNext2Text = '.' do + begin + Inc(K); + levelStack.Push(ClassTypeId); + ReadToken; + ClassTypeId := Lookup(CurrToken.Text, CurrLevel); + if ClassTypeId = 0 then + RaiseError(errUndeclaredIdentifier, [CurrToken.Text]); + ReadToken; + end; + + DECLARE_SWITCH := true; + Match('.'); + SubId := Parse_Ident; + BeginClassDestructor(SubId, ClassTypeId); + end + else + RaiseError(errUndeclaredIdentifier, [CurrToken.Text]); + + NP := 0; + if IsCurrText('(') then + begin + Call_SCANNER; + Match(')'); + end; + + SetCount(SubId, NP); + + Inc(EXECUTABLE_SWITCH); + Match(';'); + + DirectiveList := Parse_DirectiveList(SubId); + if DirectiveList.IndexOf(dirFORWARD) >= 0 then + begin + SetForward(SubId, true); + EndSub(SubId); + FreeAndNil(DirectiveList); + + Dec(EXECUTABLE_SWITCH); + Exit; + end; + FreeAndNil(DirectiveList); + + OldSubId := SubId; + InitSub(SubId); + + if OldSubId = SubId then + RaiseError(errUndeclaredIdentifier, [GetName(OldSubId)]); + + Parse_SubBlock; + EndSub(SubId); + + Dec(EXECUTABLE_SWITCH); + EndMethodDef(SubId); + Match(';'); + + finally + + while K > 0 do + begin + Dec(K); + levelStack.Pop; + end; + + end; +end; + +// STATEMENTS + +procedure TPascalParser.Parse_CompoundStmt; +begin + Inc(EXECUTABLE_SWITCH); + DECLARE_SWITCH := false; + Match('begin'); + Parse_StmtList; + Match('end'); + Dec(EXECUTABLE_SWITCH); +end; + +procedure TPascalParser.Parse_StmtList; +begin + DECLARE_SWITCH := false; + repeat + if IsEOF then + break; + if IsCurrText('end') then + break; + if IsCurrText('finalization') then + break; + Parse_Statement; + if NotMatch(';') then break; + until false; +end; + +procedure TPascalParser.Parse_AssignmentStmt; +var + I, LeftID, RightId, SizeId, SubId, L, ID1, ID2: Integer; + R: TCodeRec; + Lst: TIntegerList; +// SignProp: Boolean; + K1: Integer; +begin + if IsCurrText('inherited') then + begin + Call_SCANNER; + LeftId := NewTempVar; + if IsCurrText(';') or IsCurrText('else') then + begin + SubId := CurrLevel; + L := NewTempVar; + SetName(L, GetName(SubId)); + Gen(OP_EVAL, 0, 0, L); + Gen(OP_EVAL_INHERITED, L, 0, LeftId); + for I:=0 to GetCount(SubId) - 1 do + Gen(OP_PUSH, GetParamId(SubId, I), I, LeftId); + Gen(OP_CALL_INHERITED, LeftID, 0, 0); + end + else + begin + L := Parse_Ident; + + if IsCurrText('[') then + begin +// SignProp := true; + RemoveInstruction(OP_EVAL, -1, -1, L); + end + else + begin + RemoveInstruction(OP_EVAL, -1, -1, L); +// SignProp := false; + end; + + Gen(OP_EVAL_INHERITED, L, 0, LeftId); + if IsCurrText('(') or IsCurrText('[') then + Gen(OP_CALL_INHERITED, LeftID, Parse_ArgumentList(LeftId), 0) + else + Gen(OP_CALL_INHERITED, LeftID, 0, 0); + +// if SignProp then + if IsCurrText(':=') then + begin + K1 := CodeCard; + Call_SCANNER; + Gen(OP_PUSH, Parse_Expression, GetCodeRec(K1).Arg2, LeftId); + GetCodeRec(K1).Arg2 := GetCodeRec(K1).Arg2 + 1; + Gen(OP_CALL, LeftId, GetCodeRec(K1).Arg2, 0); + GetCodeRec(K1).Op := OP_NOP; + Exit; + end; + + end; + if GetKind(CurrSubId) = kindCONSTRUCTOR then + begin + Gen(OP_RESTORE_EDX, 0, 0, 0); + + L := NewLabel; + Gen(OP_GO_DL, L, 0, 0); + Gen(OP_ONCREATE_OBJECT, CurrSelfId, 0, 0); + SetLabelHere(L); + + Gen(OP_SAVE_EDX, 0, 0, 0); + + WasInherited := true; + end; + Exit; + end + else if IsCurrText('Include') and (not InScope('Include')) then + begin + RemoveInstruction(OP_EVAL, -1, -1, -1); + Call_SCANNER; + Match('('); + ID1 := Parse_Expression; + Match(','); + ID2 := Parse_Expression; + Match(')'); + Gen(OP_SET_INCLUDE, ID1, ID2, 0); + Exit; + end + else if IsCurrText('Exclude') and (not InScope('Exclude')) then + begin + RemoveInstruction(OP_EVAL, -1, -1, -1); + Call_SCANNER; + Match('('); + ID1 := Parse_Expression; + Match(','); + ID2 := Parse_Expression; + Match(')'); + Gen(OP_SET_EXCLUDE, ID1, ID2, 0); + Exit; + end + else if IsCurrText('inc') and (not InScope('inc')) then + begin + Call_SCANNER; + if not IsCurrText('(') then + RaiseError(errTokenExpected, ['(', CurrToken.Text]); + Push_SCANNER; + Call_SCANNER; + ID1 := Parse_Designator; + Pop_SCANNER; + Call_SCANNER; + ID2 := Parse_Designator; + if IsCurrText(',') then + begin + Call_SCANNER; + Gen(OP_INC, ID2, Parse_Expression, ID1); + end + else + Gen(OP_INC, ID2, NewConst(typeINTEGER, 1), ID1); + Match(')'); + + Exit; + end + else if IsCurrText('dec') and (not InScope('dec')) then + begin + Call_SCANNER; + if not IsCurrText('(') then + RaiseError(errTokenExpected, ['(', CurrToken.Text]); + Push_SCANNER; + Call_SCANNER; + ID1 := Parse_Designator; + Pop_SCANNER; + Call_SCANNER; + ID2 := Parse_Designator; + if IsCurrText(',') then + begin + Call_SCANNER; + Gen(OP_DEC, ID2, Parse_Expression, ID1); + end + else + Gen(OP_DEC, ID2, NewConst(typeINTEGER, 1), ID1); + Match(')'); + + Exit; + end + else if IsCurrText('SetLength') and (not InScope('SetLength')) then + begin + Lst := TIntegerList.Create; + try + Call_SCANNER; + Match('('); + LeftID := Parse_Designator; + + Call_SCANNER; + repeat + Lst.Add(Parse_Expression); + if NotMatch(',') then + break; + until false; + + if Lst.Count = 1 then + Gen(OP_SET_LENGTH, LeftID, Lst[0], 0) + else + begin + for I := 0 to Lst.Count - 1 do + Gen(OP_PUSH_LENGTH, Lst[I], 0, 0); + Gen(OP_SET_LENGTH_EX, LeftID, Lst.Count, 0); + end; + + Match(')'); + finally + FreeAndNil(Lst); + end; + Exit; + end + else if IsCurrText('str') and (not InScope('str')) then + begin + LeftID := NewTempVar; + + Call_SCANNER; + Match('('); + + try + + Gen(OP_PUSH, Parse_Expression, 3, LeftID); + + if IsCurrText(':') then + begin + Call_SCANNER; + Gen(OP_PUSH, Parse_Expression, 2, LeftID); + end + else + Gen(OP_PUSH, NewConst(typeINTEGER, 0), 2, LeftID); + + if IsCurrText(':') then + begin + Call_SCANNER; + Gen(OP_PUSH, Parse_Expression, 1, LeftID); + end + else + Gen(OP_PUSH, NewConst(typeINTEGER, 0), 1, LeftID); + + Match(','); + Gen(OP_PUSH, Parse_Expression, 0, LeftID); + + finally + Gen(OP_STR, LeftID, 0, 0); + end; + + Match(')'); + Exit; + end + else if IsCurrText('new') and (not InScope('new')) then + begin + SetCompletionTarget('new'); + + Call_SCANNER; + + Match('('); + LeftId := Parse_Designator; + SizeId := NewTempVar; + SubId := NewTempVar; + SetName(SubId, 'GetMem'); + SetKind(SubId, kindNONE); + Gen(OP_EVAL, 0, 0, SubId); + Gen(OP_SIZEOF, LeftId, 0, SizeId); + Gen(OP_PUSH, LeftId, 0, SubId); + Gen(OP_PUSH, SizeId, 1, SubId); + Gen(OP_CALL, SubId, 0, 0); + Match(')'); + Exit; + end + else if IsCurrText('dispose') and (not InScope('dispose')) then + begin + SetCompletionTarget('Dispose'); + + Call_SCANNER; + Match('('); + LeftId := Parse_Designator; + SizeId := NewTempVar; + SubId := NewTempVar; + SetName(SubId, 'FreeMem'); + SetKind(SubId, kindNONE); + Gen(OP_EVAL, 0, 0, SubId); + Gen(OP_SIZEOF, LeftId, 0, SizeId); + Gen(OP_PUSH, LeftId, 0, SubId); + Gen(OP_PUSH, SizeId, 1, SubId); + Gen(OP_CALL, SubId, 0, 0); + Match(')'); + Exit; + end + else if IsCurrText('pause') and (not InScope('pause')) then + begin + Call_SCANNER; + if IsCurrText('(') then + begin + Match('('); + Match(')'); + end; + L := NewLabel; + Gen(OP_PAUSE, L, 0, 0); + SetLabelHere(L); + Exit; + end + else if IsCurrText('halt') or IsCurrText('abort') then + begin + Call_SCANNER; + if IsCurrText('(') then + begin + Match('('); + if not IsCurrText(')') then + begin + Gen(OP_HALT, Parse_ConstantExpression, 0, 0); + end + else + Gen(OP_HALT, NewConst(typeINTEGER, 0), 0, 0); + Match(')'); + end + else + Gen(OP_HALT, NewConst(typeINTEGER, 0), 0, 0); + Exit; + end; + + if IsCurrText('(') then + LeftID := Parse_Factor + else + LeftID := Parse_SimpleExpression; + + if IsEOF then + Exit; + + if IsCurrText(';') or (CurrToken.TokenClass = tcKeyword) then + begin + R := LastCodeRec; + if R.Op = OP_CALL then + begin + SetKind(R.Res, KindNONE); + R.Res := 0; + end + else if GetKind(LeftId) = kindCONST then + RaiseError(errIdentifierExpectedNoArgs, []) + else + begin + {$IFDEF CPP_SYN} + if (R.Arg1 = LeftId) and (R.Op = OP_ASSIGN) then + begin + if (LastCodeRec2.Op = OP_PLUS) or (LastCodeRec2.Op = OP_MINUS) then + Exit; + end + else if R.Op = OP_POSTFIX_EXPRESSION then + Exit; + {$ENDIF} + Gen(OP_CALL, LeftID, 0, 0); + end; + Exit; + end; + + Gen(OP_LVALUE, LeftId, 0, 0); + + if IsCurrText(':=') then + begin + Call_SCANNER; + RightId := Parse_Expression; + Gen(OP_ASSIGN, LeftID, RightId, LeftID); + end +{$IFDEF CPP_SYN} + else if IsCurrText('+=') then + begin + Call_SCANNER; + ID1 := NewTempVar; + Gen(OP_PLUS, LeftId, Parse_Expression, ID1); + Gen(OP_ASSIGN, LeftId, ID1, LeftId); + end + else if IsCurrText('-=') then + begin + Call_SCANNER; + ID1 := NewTempVar; + Gen(OP_MINUS, LeftId, Parse_Expression, ID1); + Gen(OP_ASSIGN, LeftId, ID1, LeftId); + end + else if IsCurrText('*=') then + begin + Call_SCANNER; + ID1 := NewTempVar; + Gen(OP_MULT, LeftId, Parse_Expression, ID1); + Gen(OP_ASSIGN, LeftId, ID1, LeftId); + end + else if IsCurrText('/=') then + begin + Call_SCANNER; + ID1 := NewTempVar; + Gen(OP_DIV, LeftId, Parse_Expression, ID1); + Gen(OP_ASSIGN, LeftId, ID1, LeftId); + end + else if IsCurrText('~=') then + begin + Call_SCANNER; + ID1 := NewTempVar; + Gen(OP_IDIV, LeftId, Parse_Expression, ID1); + Gen(OP_ASSIGN, LeftId, ID1, LeftId); + end + else if IsCurrText('%=') then + begin + Call_SCANNER; + ID1 := NewTempVar; + Gen(OP_MOD, LeftId, Parse_Expression, ID1); + Gen(OP_ASSIGN, LeftId, ID1, LeftId); + end + else if IsCurrText('^=') then + begin + Call_SCANNER; + ID1 := NewTempVar; + Gen(OP_XOR, LeftId, Parse_Expression, ID1); + Gen(OP_ASSIGN, LeftId, ID1, LeftId); + end + else if IsCurrText('|=') then + begin + Call_SCANNER; + ID1 := NewTempVar; + Gen(OP_OR, LeftId, Parse_Expression, ID1); + Gen(OP_ASSIGN, LeftId, ID1, LeftId); + end + else if IsCurrText('&=') then + begin + Call_SCANNER; + ID1 := NewTempVar; + Gen(OP_AND, LeftId, Parse_Expression, ID1); + Gen(OP_ASSIGN, LeftId, ID1, LeftId); + end +{$ENDIF} + else if IsCurrText('(') then + begin + R := Gen(OP_CALL, LeftID, Parse_ArgumentList(LeftId), 0); + + if IsCurrText(':=') then + begin + R.Res := NewTempVar; + Call_SCANNER; + Gen(OP_ASSIGN, R.Res, Parse_Expression, R.Res); + end + else if IsCurrText('(') then + begin + R.Res := NewTempVar; + Gen(OP_CALL, R.Res, Parse_ArgumentList(R.Res), 0); + end; + end + else + begin + Gen(OP_CALL, LeftID, 0, 0); + end; +end; + +procedure TPascalParser.Parse_CaseStmt; +var + lg, lf, lt, lc, id, expr1_id, cond_id: Integer; +begin + Match('case'); + lg := NewLabel; + cond_id := NewTempVar; + id := NewTempVar; + Gen(OP_ASSIGN, Id, Parse_Expression, id); + Match('of'); + repeat + // Parse case selector + lt := NewLabel; + lf := NewLabel; + repeat + lc := NewLabel; + expr1_id := Parse_ConstantExpression; + + if IsCurrText('..') then + begin + Gen(OP_GE, id, expr1_id, cond_id); + Gen(OP_GO_FALSE, lc, cond_id, 0); + Match('..'); + Gen(OP_LE, id, Parse_ConstantExpression, cond_id); + Gen(OP_GO_FALSE, lc, cond_id, 0); + end + else + Gen(OP_EQ, id, expr1_id, cond_id); + Gen(OP_GO_TRUE, lt, cond_id, 0); + SetLabelHere(lc); + + if NotMatch(',') then + break; + until false; + Gen(OP_GO, lf, 0, 0); + SetLabelHere(lt); + Match(':'); + if IsCurrText(';') then + begin + end + else + Parse_Statement; + Gen(OP_GO, lg, 0, 0); + SetLabelHere(lf); + // end of case selector + if NotMatch(';') then + Break; + if IsCurrText('else') then + break; + if IsCurrText('end') then + break; + until false; + if IsCurrText('else') then + begin + Match('else'); + Parse_StmtList; + end; + if IsCurrText(';') then + Match(';'); + Match('end'); + SetLabelHere(lg); +end; + +procedure TPascalParser.Parse_IfStmt; +var + lf, lg: Integer; +begin + Match('if'); + lf := NewLabel; + Gen(OP_GO_FALSE, lf, Parse_Expression, 0); + Match('then'); + if not IsCurrText('else') then + Parse_Statement; + if IsCurrText('else') then + begin + Gen(OP_NOP, 0, 0, 0); + lg := NewLabel(); + Gen(OP_GO, lg, 0, 0); + SetLabelHere(lf); + Match('else'); + Parse_Statement; + SetLabelHere(lg); + end + else + SetLabelHere(lf); +end; + +procedure TPascalParser.Parse_GotoStmt; +begin + Match('goto'); + Gen(OP_GO, Parse_Label, 0, 0); +end; + +procedure TPascalParser.Parse_BreakStmt; +begin + if BreakStack.Count = 0 then + RaiseError(errBreakOrContinueOutsideOfLoop, []); + Match('break'); + if IsCurrText('(') then + begin + Match('('); + Match(')'); + end; + if not SupportedSEH then + Gen(OP_GO, BreakStack.TopLabel, 0, 0) + else + begin + if IsTryContext(BreakStack.Top) then + Gen(OP_EXIT, BreakStack.TopLabel, Integer(emBreak), CurrLevel) + else + Gen(OP_GO, BreakStack.TopLabel, 0, 0); + end; +end; + +procedure TPascalParser.Parse_ContinueStmt; +begin + if ContinueStack.Count = 0 then + RaiseError(errBreakOrContinueOutsideOfLoop, []); + Match('continue'); + if IsCurrText('(') then + begin + Match('('); + Match(')'); + end; + if not SupportedSEH then + Gen(OP_GO, ContinueStack.TopLabel, 0, 0) + else + begin + if IsTryContext(ContinueStack.Top) then + Gen(OP_EXIT, ContinueStack.TopLabel, Integer(emContinue), CurrLevel) + else + Gen(OP_GO, ContinueStack.TopLabel, 0, 0); + end; +end; + +procedure TPascalParser.Parse_ExitStmt; +begin + Match('exit'); + if IsCurrText('(') then + begin + Match('('); + Match(')'); + end; + if not SupportedSEH then + Gen(OP_GO, SkipLabelStack.Top, 0, CurrLevel) + else + Gen(OP_EXIT, SkipLabelStack.Top, 0, CurrLevel); +end; + +procedure TPascalParser.Parse_WhileStmt; +var + lf, lg, l_loop: Integer; +begin + Match('while'); + lf := NewLabel; + lg := NewLabel; + SetLabelHere(lg); + l_loop := lg; + Gen(OP_GO_FALSE, lf, Parse_Expression, 0); + Match('do'); + + Parse_LoopStmt(lf, lg, l_loop); + + Gen(OP_GO, lg, 0, 0); + SetLabelHere(lf); +end; + +procedure TPascalParser.Parse_RepeatStmt; +var + lf, lg, l_loop: Integer; +begin + Match('repeat'); + lf := NewLabel; + lg := NewLabel; + SetLabelHere(lf); + l_loop := lf; + repeat + if IsCurrText('until') then + Break; + if IsEOF then + Break; + + Parse_LoopStmt(lg, lf, l_loop); + + if NotMatch(';') then + Break; + + until false; + Match('until'); + Gen(OP_GO_FALSE, lf, Parse_Expression, 0); + SetLabelHere(lg); +end; + +procedure TPascalParser.Parse_ForStmt; +var + id, expr1_id, expr2_id, limit_cond_id1, limit_cond_id2: Integer; + i, compound: Boolean; + lf, lg, lc, l_loop: Integer; + + element_id, collection_id, enumerator_id, bool_id: Integer; +begin + l_loop := NewLabel; + SetLabelHere(l_loop); + Match('for'); + if IsNextText('in') then + begin + Inc(ForInCounter); + lf := NewLabel; + lg := NewLabel; + lc := NewLabel; + enumerator_id := NewTempVar; + bool_id := NewTempVar; + element_id := Parse_Ident; + Match('in'); + collection_id := Parse_Expression; + Match('do'); + Gen(OP_LOCK_VARRAY, collection_id, ForInCounter, 0); + Gen(OP_GET_ENUMERATOR, collection_id, ForInCounter, enumerator_id); + SetLabelHere(lg); + Gen(OP_CURRENT, enumerator_id, ForInCounter, element_id); + + compound := Parse_LoopStmt(lf, lc, l_loop); + + SetLabelHere(lc, ForInCounter); + if not compound then + GenPause; + Gen(OP_MOVE_NEXT, element_id, ForInCounter, bool_id); + Gen(OP_GO_FALSE, lf, bool_id, 0); + Gen(OP_GO, lg, 0, 0); + SetLabelHere(lf, 0, ForInCounter); + Gen(OP_UNLOCK_VARRAY, collection_id, ForInCounter, 0); + Exit; + end; + + lf := NewLabel; + lg := NewLabel; + lc := NewLabel; + limit_cond_id1 := NewTempVar; + limit_cond_id2 := NewTempVar; + expr1_id := NewTempVar; + expr2_id := NewTempVar; + id := Parse_Ident; + Match(':='); + Gen(OP_ASSIGN, expr1_id, Parse_Expression, expr1_id); + Gen(OP_ASSIGN, id, expr1_id, id); + if IsCurrText('downto') then + begin + Match('downto'); + Gen(OP_ASSIGN, expr2_id, Parse_Expression, expr2_id); + Gen(OP_LT, id, expr2_id, limit_cond_id1); + i := false; + end + else + begin + Match('to'); + Gen(OP_ASSIGN, expr2_id, Parse_Expression, expr2_id); + Gen(OP_GT, id, expr2_id, limit_cond_id1); + i := true; + end; + Gen(OP_GO_TRUE, lg, limit_cond_id1, 0); + Match('do'); + SetLabelHere(lf); + + compound := Parse_LoopStmt(lg, lc, l_loop); + + SetLabelHere(lc); + if i then + begin + Gen(OP_INC, id, NewConst(typeINTEGER, 1), id); + Gen(OP_GT, id, expr2_id, limit_cond_id2); + end + else + begin + Gen(OP_DEC, id, NewConst(typeINTEGER, 1), id); + Gen(OP_LT, id, expr2_id, limit_cond_id2); + end; + if not compound then + GenPause; + Gen(OP_GO_FALSE, lf, limit_cond_id2, 0); + SetLabelHere(lg); +end; + +procedure TPascalParser.Parse_WithStmt; +var + id, K: Integer; +begin + K := WithStack.Count; + Match('with'); + repeat + id := Parse_Expression; + Gen(OP_BEGIN_WITH, id, 0, 0); + WithStack.Push(id); + if NotMatch(',') then + Break; + until false; + Match('do'); + Parse_Statement; + + while WithStack.Count > K do + begin + id := WithStack.Top; + Gen(OP_END_WITH, id, 0, 0); + WithStack.Pop; + end; +end; + +procedure TPascalParser.Parse_TryStmt; +var + id, type_id, l_try, BlockId: Integer; +begin + if not SupportedSEH then + RaiseError(errTryExceptNotImplemented, []); + + l_try := GenBeginTry; + + Match('try'); + + repeat + if IsCurrText('except') then + Break; + if IsCurrText('finally') then + Break; + if IsEOF then + Break; + Parse_Statement; + if NotMatch(';') then + Break; + until false; + + Gen(OP_EXCEPT_SEH, 0, 0, 0); + + if IsCurrText('except') then + begin + Gen(OP_GO, l_try, 0, 0); + GenExcept; + + Call_SCANNER; + //ExceptionBlock + + if IsCurrText('on') then + begin + while IsCurrText('on') do + begin + BlockId := NewTempVar; + LevelStack.push(BlockId); + Gen(OP_BEGIN_BLOCK, BlockId, 0, 0); + + if IsNext2Text(':') then + begin + DECLARE_SWITCH := true; + Match('on'); + id := Parse_Ident; + DECLARE_SWITCH := false; + Match(':'); + type_id := Parse_Ident; + end + else + begin + DECLARE_SWITCH := false; + Match('on'); + type_id := Parse_Ident; + id := NewTempVar; + end; + + Gen(OP_ASSIGN_TYPE, id, type_id, 0); + + GenExceptOn(type_id); + Gen(OP_ASSIGN, id, CurrExceptionObjectId, id); + + Gen(OP_BEGIN_EXCEPT_BLOCK, 0, 0, 0); + Match('do'); + Parse_Statement; + Gen(OP_END_EXCEPT_BLOCK, 0, 0, 0); + + Gen(OP_GO, l_try, 0, 0); + + Gen(OP_END_BLOCK, BlockId, 0, 0); + LevelStack.Pop; + if IsCurrText(';') then + Match(';'); + end; + + GenExceptOn(0); + + if IsCurrText('else') then + begin + Gen(OP_BEGIN_EXCEPT_BLOCK, 0, 0, 0); + Call_SCANNER; + Parse_Statement; + + if IsCurrText(';') then + Match(';'); + Gen(OP_END_EXCEPT_BLOCK, 0, 0, 0); + end; + end + else + begin + Gen(OP_BEGIN_EXCEPT_BLOCK, 0, 0, 0); + repeat + if IsCurrText('end') then + Break; + if IsEOF then + Break; + Parse_Statement; + if NotMatch(';') then + Break; + until false; + Gen(OP_END_EXCEPT_BLOCK, 0, 0, 0); + end; + end // except + else if IsCurrText('finally') then + begin + GenFinally; + Call_SCANNER; + repeat + if IsCurrText('end') then + Break; + if IsEOF then + Break; + Parse_Statement; + if NotMatch(';') then + Break; + until false; + GenCondRaise; + end // finally + else + Match('finally'); + SetLabelHere(l_try); + GenEndTry; + Match('end'); +end; + +procedure TPascalParser.Parse_RaiseStmt; +begin + if not SupportedSEH then + RaiseError(errRaiseNotImplemented, []); + + Match('raise'); + if IsCurrText(';') then + Gen(OP_RAISE, 0, RaiseMode, 0) + else + begin + Gen(OP_RAISE, Parse_Expression, RaiseMode, 0); + end; +end; + +// EXPRESSIONS + +function TPascalParser.Parse_ArgumentList(SubId: Integer): Integer; +var + I: Integer; + L: TIntegerList; + bracket: String; +begin + try + bracket := ')'; + L := TIntegerList.Create; + try + if IsCurrText('(') then + begin + Match('('); + bracket := ')'; + end + else if IsCurrText('[') then + begin + Match('['); + bracket := ']'; + end + else + Match('('); + result := 0; + if (not IsCurrText(')')) then + begin + repeat + Inc(result); + L.Add(Parse_Expression); + if NotMatch(',') then + Break; + until false; + end; + + for I:=0 to L.Count - 1 do + Gen(OP_PUSH, L[I], I, SubID); + + Match(bracket); + finally + FreeAndNil(L); + end; + except + Gen(OP_CALL, SubId, 0, 0); + raise; + end; +end; + +function TPascalParser.Parse_ConstantExpression: Integer; +begin + try + CONST_ONLY := true; + result := Parse_Expression; + finally + CONST_ONLY := false; + end; +end; + +function TPascalParser.Parse_Expression: Integer; +var + Op: Integer; +begin + if IsCurrText('procedure') then + begin + result := Parse_AnonymousProcedure; + Exit; + end + else if IsCurrText('function') then + begin + result := Parse_AnonymousFunction; + Exit; + end + else if IsCurrText('lambda') then + begin + RemoveLastIdent(CurrToken.Id); + result := Parse_LambdaExpression; + Exit; + end; + + result := Parse_SimpleExpression; + while (CurrToken.Id = OP_LT) or + (CurrToken.Id = OP_LE) or + (CurrToken.Id = OP_GT) or + (CurrToken.Id = OP_GE) or + (CurrToken.Id = OP_EQ) or + (CurrToken.Id = OP_NE) or + (CurrToken.Id = OP_IS) or + (CurrToken.Id = OP_AS) or + (CurrToken.Id = OP_SET_MEMBERSHIP) do + begin + Op := CurrToken.Id; + Call_SCANNER; + result := BinOp(Op, result, Parse_SimpleExpression); + end; +end; + +function TPascalParser.Parse_SimpleExpression: Integer; +var + Op, L, I: Integer; + Lst: TCodeRecList; + R: TCodeRec; +begin + if CompleteBooleanEval then + begin + result := Parse_Term; + while IsCurrText('+') or + IsCurrText('-') or + IsCurrText('or') or + IsCurrText('xor') do + begin + Op := CurrToken.Id; + Call_SCANNER; + result := BinOp(Op, result, Parse_Term); + end; + Exit; + end; + + L := 0; + Lst := TCodeRecList.Create; + try + result := Parse_Term; + while (CurrToken.Id = OP_PLUS) or + (CurrToken.Id = OP_MINUS) or + (CurrToken.Id = OP_OR) or + (CurrToken.Id = OP_XOR) do + begin + if (CurrToken.Id = OP_OR) and (Lst.Count = 0) then + L := NewLabel; + + if CurrToken.Id = OP_OR then + begin + R := Gen(OP_ASSIGN, 0, result, 0); + Lst.Add(R); + Gen(OP_GO_TRUE_BOOL, L, result, 0); + end; + + Op := CurrToken.Id; + Call_SCANNER; + result := BinOp(Op, result, Parse_Term); + end; + + if Lst.Count > 0 then + begin + for I:=0 to Lst.Count - 1 do + begin + R := TCodeRec(Lst[I]); + R.Arg1 := result; + R.Res := result; + end; + SetLabelHere(L); + end; + finally + FreeAndNil(Lst); + end; +end; + +function TPascalParser.Parse_Term: Integer; +var + Op, L, I: Integer; + Lst: TCodeRecList; + R: TCodeRec; +begin + if CompleteBooleanEval then + begin + result := Parse_Factor; + while (CurrToken.Id = OP_MULT) or + (CurrToken.Id = OP_DIV) or + (CurrToken.Id = OP_IDIV) or + (CurrToken.Id = OP_MOD) or + (CurrToken.Id = OP_SHL) or + (CurrToken.Id = OP_SHR) or + (CurrToken.Id = OP_AND) do + begin + Op := CurrToken.Id; + Call_SCANNER; + result := BinOp(Op, result, Parse_Factor); + end; + Exit; + end; + + L := 0; + Lst := TCodeRecList.Create; + try + result := Parse_Factor; + while (CurrToken.Id = OP_MULT) or + (CurrToken.Id = OP_DIV) or + (CurrToken.Id = OP_IDIV) or + (CurrToken.Id = OP_MOD) or + (CurrToken.Id = OP_SHL) or + (CurrToken.Id = OP_SHR) or + (CurrToken.Id = OP_AND) do + begin + if (CurrToken.Id = OP_AND) and (Lst.Count = 0) then + L := NewLabel; + + if CurrToken.Id = OP_AND then + begin + R := Gen(OP_ASSIGN, 0, result, 0); + Lst.Add(R); + Gen(OP_GO_FALSE_BOOL, L, result, 0); + end; + + Op := CurrToken.Id; + Call_SCANNER; + result := BinOp(Op, result, Parse_Factor); + end; + + if Lst.Count > 0 then + begin + for I:=0 to Lst.Count - 1 do + begin + R := TCodeRec(Lst[I]); + R.Arg1 := result; + R.Res := result; + end; + SetLabelHere(L); + end; + + finally + FreeAndNil(Lst); + end; +end; + +function TPascalParser.Parse_Factor: Integer; +var + SubId, K, Id: Integer; + ValidConst: Boolean; + {$IFDEF CPP_SYN} + temp, r: Integer; + {$ENDIF} + S: String; + v: Variant; +label + LabelDesignator; +begin + + if CurrToken.TokenClass = tcBooleanConst then + begin + result := Parse_BooleanLiteral; + if IsCurrText('.') then + begin + if CONST_ONLY then + CreateError(errConstantExpressionExpected, []); + result := Parse_Designator(result); + end; + end + else if CurrToken.TokenClass = tcCharConst then + begin + result := Parse_CharLiteral; + if IsCurrText('.') then + begin + if CONST_ONLY then + CreateError(errConstantExpressionExpected, []); + result := Parse_Designator(result); + end; + end + else if CurrToken.TokenClass = tcPCharConst then + begin + result := Parse_PCharLiteral; + if IsCurrText('.') then + begin + if CONST_ONLY then + CreateError(errConstantExpressionExpected, []); + result := Parse_Designator(result); + end; + end + else if CurrToken.TokenClass = tcIntegerConst then + begin + result := Parse_IntegerLiteral; + if IsCurrText('.') then + begin + if CONST_ONLY then + CreateError(errConstantExpressionExpected, []); + result := Parse_Designator(result); + end; + end + else if CurrToken.TokenClass = tcDoubleConst then + begin + result := Parse_DoubleLiteral; + if IsCurrText('.') then + begin + if CONST_ONLY then + CreateError(errConstantExpressionExpected, []); + result := Parse_Designator(result); + end; + end + else if IsCurrText('+') then + begin + Call_SCANNER; + result := UnaryOp(OP_POSITIVE, Parse_Factor); + end + else if IsCurrText('-') then + begin + Call_SCANNER; + ValidConst := CurrToken.TokenClass in [tcIntegerConst, tcDoubleConst]; + Id := Parse_Factor; + if ValidConst then + begin + result := Id; + v := GetValue(id); + if v > 0 then + SetValue(Id, - v); + end + else + result := UnaryOp(OP_NEG, Id); + end + {$IFDEF CPP_SYN} + else if IsCurrText('++') then + begin + if CONST_ONLY then + CreateError(errConstantExpressionExpected, []); + + Call_SCANNER; + result := Parse_Expression; + Id := NewTempVar; + Gen(OP_PLUS, result, NewConst(typeINTEGER, 1), Id); + Gen(OP_ASSIGN, result, Id, result); + end + else if IsCurrText('--') then + begin + if CONST_ONLY then + CreateError(errConstantExpressionExpected, []); + + Call_SCANNER; + result := Parse_Expression; + Id := NewTempVar; + Gen(OP_MINUS, result, NewConst(typeINTEGER, 1), Id); + Gen(OP_ASSIGN, result, Id, result); + end + {$ENDIF} + else if IsCurrText('*') then + begin + Call_SCANNER; + result := UnaryOp(OP_POSITIVE, Parse_Factor); + end + else if IsCurrText('not') then + begin + Call_SCANNER; + result := UnaryOp(OP_NOT, Parse_Factor); + end + else if IsCurrText('(') then + begin + Match('('); + result := Parse_Expression; + Match(')'); + if IsCurrText('.') or IsCurrText('[') then + result := Parse_Designator(result); + end + else if IsCurrText('[') then + begin + result := Parse_SetConstructor; + end + else if IsCurrText('@') then + begin + Match('@'); + result := NewTempVar; + Gen(OP_ADDRESS, Parse_Designator, 0, result); + end + else if IsCurrText('assigned') and (not InScope('assigned')) then + begin + if CONST_ONLY then + CreateError(errConstantExpressionExpected, []); + + Call_SCANNER; + Match('('); + result := NewTempVar; + Gen(OP_ASSIGNED, Parse_Expression, 0, result); + Match(')'); + Exit; + end + else if IsCurrText('sizeof') and (not InScope('sizeof')) then + begin + Match('sizeof'); + Match('('); + result := NewTempVar; + Gen(OP_SIZEOF, Parse_Expression, 0, result); + Match(')'); + end + else if IsCurrText('typeinfo') and (not InScope('typeinfo')) then + begin + if CONST_ONLY then + CreateError(errConstantExpressionExpected, []); + + Match('typeinfo'); + Match('('); + result := NewTempVar; + SetType(result, typePOINTER); + Gen(OP_TYPEINFO, Parse_Expression, 0, result); + Match(')'); + end + else if IsCurrText('pred') and (not InScope('pred')) then + begin + Match('pred'); + Match('('); + result := NewTempVar; + Gen(OP_PRED, Parse_Expression, 0, result); + Match(')'); + end + else if IsCurrText('succ') and (not InScope('succ')) then + begin + Match('succ'); + Match('('); + result := NewTempVar; + Gen(OP_SUCC, Parse_Expression, 0, result); + Match(')'); + end + else if IsCurrText('ord') and (not InScope('ord')) then + begin + Match('ord'); + Match('('); + result := NewTempVar; + Gen(OP_ORD, Parse_Expression, 0, result); + Match(')'); + end + else if IsCurrText('chr') and (not InScope('chr')) then + begin + Match('chr'); + Match('('); + result := NewTempVar; + Gen(OP_CHR, Parse_Expression, 0, result); + Match(')'); + end + else if IsCurrText('high') and (not InScope('high')) then + begin + Match('high'); + Match('('); + result := NewTempVar; + Gen(OP_HIGH, Parse_Expression, 0, result); + Match(')'); + end + else if IsCurrText('low') and (not InScope('low')) then + begin + Match('low'); + Match('('); + result := NewTempVar; + Gen(OP_LOW, Parse_Expression, 0, result); + Match(')'); + end + else if IsCurrText('abs') and (not InScope('abs')) then + begin + Match('abs'); + Match('('); + result := NewTempVar; + Gen(OP_ABS, Parse_Expression, 0, result); + Match(')'); + end + else if IsCurrText('length') and (not InScope('length')) then + begin + S := GetNext2Text; + Id := Lookup(S, CurrLevel); + if Id = 0 then + goto LabelDesignator; + if GetSymbolRec(Id).FinalTypeId <> typeOPENARRAY then + goto LabelDesignator; + Id := GetOpenArrayHighId(Id); + result := NewTempVar; + Gen(OP_PLUS, Id, NewConst(typeINTEGER, 1), result); + Match('length'); + Match('('); + Parse_Expression; + Match(')'); + end + else if IsCurrText('inherited') then + begin + if CONST_ONLY then + CreateError(errConstantExpressionExpected, []); + + Call_SCANNER; + SubId := NewTempVar; + result := NewTempVar; + K := Parse_Ident; + RemoveInstruction(OP_EVAL, -1, -1, K); + Gen(OP_EVAL_INHERITED, K, 0, SubId); + if IsCurrText('(') or IsCurrText('[') then + Gen(OP_CALL_INHERITED, SubID, Parse_ArgumentList(SubId), result) + else + Gen(OP_CALL_INHERITED, SubID, 0, result); + end + else + begin +LabelDesignator: + result := Parse_Designator; + if IsCurrText(':=') then + if GetSymbolRec(result).OwnerId = 0 then + if CurrLevel > 0 then + if GetKind(CurrLevel) in KindSUBS then + if (GetName(result) <> '') and StrEql(GetName(result), GetName(CurrSubId)) then + result := CurrResultId; + + if IsCurrText('(') then + begin + if CONST_ONLY then + CreateError(errConstantExpressionExpected, []); + + SubId := result; + result := NewTempVar; + K := Parse_ArgumentList(SubId); + Gen(OP_CALL, SubID, K, result); + + if IsCurrText('.') or IsCurrText('[') then + result := Parse_Designator(result); + end + else if GetKind(result) = KindSUB then + begin + if CONST_ONLY then + CreateError(errConstantExpressionExpected, []); + + SubId := result; + result := NewTempVar; + SetName(result, GetName(SubId)); + SetKind(result, KindNONE); + Gen(OP_EVAL, 0, 0, result); + + if IsCurrText('.') or IsCurrText('[') then + result := Parse_Designator(result); + end; + + {$IFDEF CPP_SYN} + if IsCurrText('++') then // post increment expression + begin + if CONST_ONLY then + CreateError(errConstantExpressionExpected, []); + + Match('++'); + temp := NewTempVar; + Gen(OP_ASSIGN, temp, result, temp); + r := NewTempVar; + Gen(OP_PLUS, result, NewConst(typeINTEGER, 1), r); + Gen(OP_ASSIGN, result, r, result); + Gen(OP_POSTFIX_EXPRESSION, 0, 0, 0); + result := temp; + end + else if IsCurrText('--') then // post decrement expression + begin + if CONST_ONLY then + CreateError(errConstantExpressionExpected, []); + + Match('--'); + temp := NewTempVar; + Gen(OP_ASSIGN, temp, result, temp); + r := NewTempVar; + Gen(OP_MINUS, result, NewConst(typeINTEGER, 1), r); + Gen(OP_ASSIGN, result, r, result); + Gen(OP_POSTFIX_EXPRESSION, 0, 0, 0); + result := temp; + end; + {$ENDIF} + end; +end; + +function TPascalParser.Parse_SetConstructor: Integer; +var + id1, id2, k: Integer; +begin + Match('['); + if not IsCurrText(']') then + begin + k := 0; + result := NewTempVar; + + repeat + if IsEOF then + break; + // parse member group + + id1 := Parse_Expression; + if IsCurrText('..') then + begin + Match('..'); + id2 := Parse_Expression; + Gen(OP_CHECK_SUBRANGE_TYPE, id1, id2, 0); + Gen(OP_SET_INCLUDE_INTERVAL, result, id1, id2); + end + else + Gen(OP_SET_INCLUDE, result, id1, 0); + + Inc(k); + + If NotMatch(',') then + break; + until false; + + SetCount(result, k); + + end + else + result := EmptySetId; + + Match(']'); +end; + +function TPascalParser.Parse_Designator(init_id: Integer = 0): Integer; +var + ok: Boolean; + id: Integer; + S: String; +begin + if init_id = 0 then + result := Parse_QualId + else + result := init_id; + + if IsOuterLocalVar(result) then + begin + AnonymStack.Top.BindList.Add(result); + S := GetName(result); + result := NewTempVar; + SetName(result, S); + Gen(OP_EVAL, 0, 0, result); + end; + + repeat + if IsCurrText('.') then + begin + FIELD_OWNER_ID := result; + id := FIELD_OWNER_ID; + + Match('.'); + result := Parse_Ident; + Gen(OP_FIELD, id, result, result); + ok := true; + end + else if IsCurrText('[') then // index + begin + Match('['); + repeat + id := result; + result := NewTempVar; + Gen(OP_ELEM, id, Parse_Expression, result); + if NotMatch(',') then + Break; + until false; + Match(']'); + ok := true; + end + else if IsCurrText('(') then + begin + Id := result; + result := NewTempVar; + Gen(OP_CALL, Id, Parse_ArgumentList(Id), result); + ok := true; + end + else if IsCurrText('^') then + begin + Match('^'); + id := result; + result := NewTempVar; + Gen(OP_TERMINAL, id, 0, result); + ok := true; + end + else + ok := false; + until not ok; +end; + +function TPascalParser.Parse_Label: Integer; +begin + if not (CurrToken.TokenClass in [tcIntegerConst, tcIdentifier]) then + RaiseError(errIdentifierExpected, [CurrToken.Text]); + result := CurrToken.Id; + if DECLARE_SWITCH then + SetKind(result, KindLABEL) + else if GetKind(result) <> KindLABEL then + RaiseError(errLabelExpected, []); + Call_SCANNER; +end; + +function TPascalParser.Parse_Ident: Integer; +begin + if CurrToken.TokenClass = tcKeyword then + begin + if IsCurrText('nil') then + begin + result := NilId; + Call_SCANNER; + Exit; + end; + end; + result := inherited Parse_Ident; +end; + +procedure TPascalParser.Call_SCANNER; +var + S: String; +begin + SetPrevToken; + + inherited; + + while CurrToken.TokenClass = tcSeparator do + begin + Gen(OP_SEPARATOR, CurrModule.ModuleNumber, CurrToken.Id, 0); + inherited Call_SCANNER; + end; + + if CollectSig then + Sig := Sig + ' ' + CurrToken.Text; + + if DECLARE_SWITCH then + Exit; + + if CurrToken.TokenClass = tcKeyword then + begin + if StrEql(CurrToken.Text, 'String') then + begin +{$IFDEF PAXARM} + CurrToken.Id := typeUNICSTRING; +{$ELSE} + if IsUNIC then + CurrToken.Id := typeUNICSTRING + else + CurrToken.Id := typeANSISTRING; +{$ENDIF} + CurrToken.TokenClass := tcIdentifier; + Exit; + end + else if StrEql(CurrToken.Text, 'File') then + begin + CurrToken.Id := H_TFileRec; + CurrToken.TokenClass := tcIdentifier; + Exit; + end; + end; + + if CurrToken.TokenClass = tcIdentifier then + begin + S := CurrToken.Text; + if StrEql(S, 'Char') then + begin +{$IFDEF PAXARM} + CurrToken.Id := typeWIDECHAR; +{$ELSE} + if IsUNIC then + CurrToken.Id := typeWIDECHAR + else + CurrToken.Id := typeANSICHAR; +{$ENDIF} + end + else if StrEql(S, 'PChar') then + begin +{$IFDEF PAXARM} + CurrToken.Id := typePWIDECHAR; +{$ELSE} + if IsUNIC then + CurrToken.Id := typePWIDECHAR + else + CurrToken.Id := typePANSICHAR; +{$ENDIF} + end + else if StrEql(S, 'NativeInt') then + begin + CurrToken.Id := typeNATIVEINT; + end; + end; +end; + +procedure TPascalParser.ReadToken; +begin + inherited; + + while CurrToken.TokenClass = tcSeparator do + begin + Gen(OP_SEPARATOR, CurrModule.ModuleNumber, CurrToken.Id, 0); + inherited ReadToken; + end; +end; + +function TPascalParser.Parse_DirectiveList(SubId: Integer): TIntegerList; +var + S: String; +begin + result := TIntegerList.Create; + + repeat + if Parse_PortabilityDirective <> portNone then + if IsCurrText(';') then + Match(';'); + S := CurrToken.Text; + + if StrEql(S, 'overload') then + begin + if Assigned(OnParseSubDirective) then + OnParseSubDirective(Owner, S, dirOVERLOAD); + + RemoveLastIdent(CurrToken.Id); + + Call_SCANNER; + result.Add(dirOVERLOAD); + SetOverloaded(SubId); + + if Parse_PortabilityDirective <> portNone then + Match(';') + else if IsCurrText(';') then + Match(';'); + end + else if StrEql(S, 'forward') then + begin + if Assigned(OnParseSubDirective) then + OnParseSubDirective(Owner, S, dirFORWARD); + + RemoveLastIdent(CurrToken.Id); + + Call_SCANNER; + result.Add(dirFORWARD); + + if Parse_PortabilityDirective <> portNone then + Match(';') + else if IsCurrText(';') then + Match(';'); + end + else if StrEql(S, 'message') then + begin + if Assigned(OnParseSubDirective) then + OnParseSubDirective(Owner, S, 0); + + RemoveLastIdent(CurrToken.Id); + + if DECLARE_SWITCH then + if CurrToken.Id = StCard then + DiscardLastSTRecord; + + Call_SCANNER; + Parse_Expression; + + if Parse_PortabilityDirective <> portNone then + Match(';') + else if IsCurrText(';') then + Match(';'); + end + else if StrEql(S, 'inline') then + begin + if Assigned(OnParseSubDirective) then + OnParseSubDirective(Owner, S, 0); + Call_SCANNER; + + if Parse_PortabilityDirective <> portNone then + Match(';') + else if IsCurrText(';') then + Match(';'); + end + else if StrEql(S, 'stdcall') then + begin + if Assigned(OnParseSubDirective) then + OnParseSubDirective(Owner, S, ccSTDCALL); + + RemoveLastIdent(CurrToken.Id); + Call_SCANNER; + SetCallConvention(SubId, ccSTDCALL); + + if Parse_PortabilityDirective <> portNone then + Match(';') + else if IsCurrText(';') then + Match(';'); + end + else if StrEql(S, 'safecall') then + begin + if Assigned(OnParseSubDirective) then + OnParseSubDirective(Owner, S, ccSAFECALL); + + RemoveLastIdent(CurrToken.Id); + Call_SCANNER; + SetCallConvention(SubId, ccSAFECALL); + + if Parse_PortabilityDirective <> portNone then + Match(';') + else if IsCurrText(';') then + Match(';'); + end + else if StrEql(S, 'register') then + begin + if Assigned(OnParseSubDirective) then + OnParseSubDirective(Owner, S, ccREGISTER); + + RemoveLastIdent(CurrToken.Id); + + Call_SCANNER; + SetCallConvention(SubId, ccREGISTER); + + if Parse_PortabilityDirective <> portNone then + Match(';') + else if IsCurrText(';') then + Match(';'); + end + else if StrEql(S, 'cdecl') then + begin + if Assigned(OnParseSubDirective) then + OnParseSubDirective(Owner, S, ccCDECL); + + RemoveLastIdent(CurrToken.Id); + + Call_SCANNER; + SetCallConvention(SubId, ccCDECL); + + if Parse_PortabilityDirective <> portNone then + Match(';') + else if IsCurrText(';') then + Match(';'); + end + else if StrEql(S, 'msfastcall') then + begin + if Assigned(OnParseSubDirective) then + OnParseSubDirective(Owner, S, ccMSFASTCALL); + + RemoveLastIdent(CurrToken.Id); + + Call_SCANNER; + SetCallConvention(SubId, ccMSFASTCALL); + + if Parse_PortabilityDirective <> portNone then + Match(';') + else if IsCurrText(';') then + Match(';'); + end + else if StrEql(S, 'pascal') then + begin + if Assigned(OnParseSubDirective) then + OnParseSubDirective(Owner, S, ccPASCAL); + + RemoveLastIdent(CurrToken.Id); + + Call_SCANNER; + SetCallConvention(SubId, ccPASCAL); + + if Parse_PortabilityDirective <> portNone then + Match(';') + else if IsCurrText(';') then + Match(';'); + end + else if StrEql(S, 'virtual') then + begin + if Assigned(OnParseSubDirective) then + OnParseSubDirective(Owner, S, cmVIRTUAL); + + RemoveLastIdent(CurrToken.Id); + + Call_SCANNER; + result.Add(dirVIRTUAL); + SetCallMode(SubId, cmVIRTUAL); + + if Parse_PortabilityDirective <> portNone then + Match(';') + else if IsCurrText(';') then + Match(';'); + end + else if StrEql(S, 'static') then + begin + if Assigned(OnParseSubDirective) then + OnParseSubDirective(Owner, S, cmSTATIC); + + RemoveLastIdent(CurrToken.Id); + + Call_SCANNER; + result.Add(dirSTATIC); + SetCallMode(SubId, cmSTATIC); + + if Parse_PortabilityDirective <> portNone then + Match(';') + else if IsCurrText(';') then + Match(';'); + end + else if StrEql(S, 'dynamic') then + begin + if Assigned(OnParseSubDirective) then + OnParseSubDirective(Owner, S, cmDYNAMIC); + + RemoveLastIdent(CurrToken.Id); + + Call_SCANNER; + result.Add(dirDYNAMIC); + SetCallMode(SubId, cmDYNAMIC); + Gen(OP_ADD_MESSAGE, SubId, NewConst(typeINTEGER, -1000), 0); + + if Parse_PortabilityDirective <> portNone then + Match(';') + else if IsCurrText(';') then + Match(';'); + end + else if StrEql(S, 'assembler') then + begin + if Assigned(OnParseSubDirective) then + OnParseSubDirective(Owner, S, 0); + + RemoveLastIdent(CurrToken.Id); + Call_SCANNER; + + if Parse_PortabilityDirective <> portNone then + Match(';') + else if IsCurrText(';') then + Match(';'); + end + else if StrEql(S, 'override') then + begin + if Assigned(OnParseSubDirective) then + OnParseSubDirective(Owner, S, cmOVERRIDE); + + RemoveLastIdent(CurrToken.Id); + + Call_SCANNER; + result.Add(dirOVERRIDE); + SetCallMode(SubId, cmOVERRIDE); + Gen(OP_ADD_MESSAGE, SubId, NewConst(typeINTEGER, -1000), 0); + Gen(OP_CHECK_OVERRIDE, SubId, 0, 0); + + if Parse_PortabilityDirective <> portNone then + Match(';') + else if IsCurrText(';') then + Match(';'); + end + else if StrEql(S, 'abstract') then + begin + if Assigned(OnParseSubDirective) then + OnParseSubDirective(Owner, S, dirABSTRACT); + + RemoveLastIdent(CurrToken.Id); + + Call_SCANNER; + result.Add(dirABSTRACT); + + if Parse_PortabilityDirective <> portNone then + Match(';') + else if IsCurrText(';') then + Match(';'); + end + else if StrEql(S, 'final') then + begin + if Assigned(OnParseSubDirective) then + OnParseSubDirective(Owner, S, dirFINAL); + + RemoveLastIdent(CurrToken.Id); + + SetFinal(SubId, true); + Call_SCANNER; + result.Add(dirFINAL); + + if Parse_PortabilityDirective <> portNone then + Match(';') + else if IsCurrText(';') then + Match(';'); + end + else if StrEql(S, 'reintroduce') then + begin + if Assigned(OnParseSubDirective) then + OnParseSubDirective(Owner, S, dirREINTRODUCE); + + RemoveLastIdent(CurrToken.Id); + + Call_SCANNER; + result.Add(dirREINTRODUCE); + + if Parse_PortabilityDirective <> portNone then + Match(';') + else if IsCurrText(';') then + Match(';'); + end + else + break; + until false; + + if result.IndexOf(dirVIRTUAL) >= 0 then + if result.IndexOf(dirVIRTUAL) = -1 then + CreateError(errAbstractMethodsMustBeVirtual, []); + + Parse_PortabilityDirective; + + if IsCurrText(';') then + Match(';'); +end; + +function TPascalParser.Parse_PortabilityDirective: TPortDir; +var + ok: Boolean; + S: String; +begin + result := portNone; + repeat + ok := false; + S := CurrToken.Text; + if StrEql(S, 'platform') then + begin + RemoveLastIdent(CurrToken.Id); + Call_SCANNER; + if IsCurrText('=') then + begin + Call_SCANNER; + Parse_Expression; + end; + result := portPlatform; + ok := true; + end; + if StrEql(S, 'deprecated') then + begin + RemoveLastIdent(CurrToken.Id); + + Call_SCANNER; + if not IsCurrText(';') then + Call_SCANNER; + result := portDeprecated; + ok := true; + end; + if StrEql(S, 'library') then + begin + Call_SCANNER; + result := portLibrary; + ok := true; + end; + until not ok; +end; + +procedure TPascalParser.InitSub(var SubId: Integer); +begin + if AnonymStack.Count = 0 then + begin + CheckAbstract(SubId); + ReplaceForwardDeclaration(SubId); + end; + + inherited InitSub(SubId); + + Scanner.AttachId(SubId, true); + Scanner.DoComment; + + if GetSymbolRec(SubId).CallMode = cmSTATIC then + GetSymbolRec(CurrSelfId).Name := ''; + + InitMethodDef(SubId); +end; + +procedure TPascalParser.Match(const S: String); +begin + inherited; +end; + +function TPascalParser.MatchEx(const S: String): Boolean; +begin + result := true; + Tag := 0; + Match(S); + if Tag = 1 then + result := false; +end; + +function TPascalParser.InScope(const S: String): Boolean; +var + id: Integer; +begin + id := Lookups(S, LevelStack); + if id = 0 then + result := false + else + result := not GetSymbolRec(id).Host; +end; + +procedure TPascalParser.EndMethodDef(SubId: Integer); +var + TypeId: Integer; +begin + inherited; + + TypeId := GetLevel(SubId); + +// if CurrModule.IsExtra then +// Exit; + + if TypeId = 0 then + Exit; + if GetKind(TypeId) <> KindTYPE then + Exit; + +// if not IsGeneric(TypeId) then +// Exit; + + if GetSymbolRec(SubId).IsSharedMethod then + with TKernel(kernel).TypeDefList.FindMethodDef(SubId) do + Definition := 'class ' + Definition; +end; + +procedure TPascalParser.Parse_TypeRestriction(LocalTypeParams: TStringObjectList); +var + temp: Boolean; + I: Integer; + TR: TTypeRestrictionRec; +begin + temp := DECLARE_SWITCH; + try + DECLARE_SWITCH := false; + if not IsCurrText(':') then + Exit; + Call_SCANNER; + TR := TTypeRestrictionRec.Create; + TR.N := TKernel(kernel).Code.Card; + if IsCurrText('class') then + begin + Call_SCANNER; + if IsCurrText(',') then + begin + Match(','); + Match('constructor'); + end; + TR.Id := H_TObject; + end + else if IsCurrText('constructor') then + begin + Call_SCANNER; + if IsCurrText(',') then + begin + Match(','); + Match('class'); + end; + TR.Id := H_TObject; + end + else if IsCurrText('record') then + begin + Call_SCANNER; + TR.Id := typeRECORD; + end + else + begin + TR.Id := Parse_QualId; + if IsCurrText(',') then + begin + Match(','); + Match('constructor'); + end; + end; + finally + DECLARE_SWITCH := temp; + end; + if TR = nil then + Exit; + for I := LocalTypeParams.Count - 1 downto 0 do + begin + if LocalTypeParams.Objects[I] <> nil then + break; + LocalTypeParams.Objects[I] := TR.Clone; + end; + FreeAndNil(TR); +end; + +procedure TPascalParser.Parse_Attribute; +begin + while IsCurrText('[') do + begin + Call_SCANNER; + repeat + Parse_Expression; + if NotMatch(',') then + break; + until false; + Match(']'); + end; +end; + +procedure TPascalParser.RemoveKeywords; +begin + HideKeyword(I_STRICT); + HideKeyword(I_PRIVATE); + HideKeyword(I_PROTECTED); + HideKeyword(I_PUBLIC); + HideKeyword(I_PUBLISHED); +end; + +procedure TPascalParser.RestoreKeywords; +begin + inherited; +end; + +function TPascalParser.Parse_LoopStmt(l_break, l_continue, l_loop: Integer): Boolean; +begin + BreakStack.Push(l_break, l_loop); + ContinueStack.Push(l_continue, l_loop); + BeginLoop; + result := Parse_Statement; + EndLoop; + BreakStack.Pop; + ContinueStack.Pop; +end; + +end. diff --git a/Sources/PAXCOMP_PASCAL_SCANNER.pas b/Sources/PAXCOMP_PASCAL_SCANNER.pas new file mode 100644 index 0000000..02b09b9 --- /dev/null +++ b/Sources/PAXCOMP_PASCAL_SCANNER.pas @@ -0,0 +1,813 @@ +//////////////////////////////////////////////////////////////////////////// +// PaxCompiler +// Site: http://www.paxcompiler.com +// Author: Alexander Baranovsky (paxscript@gmail.com) +// ======================================================================== +// Copyright (c) Alexander Baranovsky, 2006-2014. All rights reserved. +// Code Version: 4.2 +// ======================================================================== +// Unit: PAXCOMP_PASCAL_SCANNER.pas +// ======================================================================== +//////////////////////////////////////////////////////////////////////////// + +{$I PaxCompiler.def} +unit PAXCOMP_PASCAL_SCANNER; +interface +uses {$I uses.def} + SysUtils, + PAXCOMP_CONSTANTS, + PAXCOMP_TYPES, + PAXCOMP_SYS, + PAXCOMP_SCANNER; + +type + TPascalScanner = class(TBaseScanner) + procedure ScanCharLiteral; + procedure ScanStringLiteral(ch: Char); override; + procedure ReadCustomToken; override; + + function Scan_Expression: Variant; override; + function Scan_SimpleExpression: Variant; + function Scan_Term: Variant; + function Scan_Ident: Variant; override; + end; + +implementation + +uses + PAXCOMP_KERNEL; + +procedure TPascalScanner.ScanCharLiteral; +var + s: String; + I, P1, P2: Integer; +begin + GetNextChar; // # + ScanHexDigits; + Token.TokenClass := tcCharConst; + Token.Tag := 1; + if LA(1) <> '#' then + Exit; + CustomStringVal := ''; + Token.TokenClass := tcPCharConst; + Token.Tag := 2; + + s := SCopy(Buff, Token.Position + 1, Position - Token.Position); + I := StrToInt(s); + CustomStringVal := CustomStringVal + Chr(I); + + while LA(1) = '#' do + begin + GetNextChar; // # + P1 := Position; + if LA(1) = '$' then + GetNextChar; + ScanHexDigits; + P2 := Position; + s := SCopy(Buff, P1 + 1, P2 - P1); + I := StrToInt(s); + CustomStringVal := CustomStringVal + Chr(I); + end; + + while ByteInSet(LA(1), [Ord('#'), Ord(CHAR_AP)]) do + begin + GetNextChar; // # + if LA(0) = CHAR_AP then + begin + I := Position + 1; + inherited ScanStringLiteral(CHAR_AP); + s := SCopy(Buff, I, Position - I); + I := PosCh(CHAR_REMOVE, s); + while I > 0 do + begin + Delete(s, I, 1); + I := PosCh(CHAR_REMOVE, s); + end; + CustomStringVal := CustomStringVal + s; + end + else if LA(1) = '$' then + begin + GetNextChar; + I := Position + 1; + ScanHexDigits; + s := SCopy(Buff, I, Position - I + 1); + I := StrToInt('$' + s); + CustomStringVal := CustomStringVal + chr(I); + end + else + begin + I := Position + 1; + ScanDigits; + s := SCopy(Buff, I, Position - I + 1); + I := StrToInt(s); + CustomStringVal := CustomStringVal + chr(I); + end; + end; +end; + +procedure TPascalScanner.ScanStringLiteral(ch: Char); +var + s: String; + I: Integer; +begin + inherited; + + if LA(1) <> '#' then + Exit; + + s := SCopy(Buff, Token.Position + 1, Position - Token.Position - 1); + I := PosCh(CHAR_REMOVE, s); + while I > 0 do + begin + Delete(s, I, 1); + I := PosCh(CHAR_REMOVE, s); + end; + CustomStringVal := s; + + while ByteInSet(LA(1), [Ord('#'), Ord(ch)]) do + begin + GetNextChar; // # + if LA(1) = '$' then + begin + GetNextChar; + I := Position + 1; + ScanHexDigits; + s := SCopy(Buff, I, Position - I + 1); + I := StrToInt('$' + s); + CustomStringVal := CustomStringVal + chr(I); + end + else if LA(0) = ch then + begin + I := Position + 1; + inherited ScanStringLiteral(ch); + s := SCopy(Buff, I, Position - I); + CustomStringVal := CustomStringVal + s; + end + else + begin + I := Position + 1; + ScanDigits; + s := SCopy(Buff, I, Position - I + 1); + I := StrToInt(s); + CustomStringVal := CustomStringVal + chr(I); + end; + end; + + Token.TokenClass := tcPCharConst; + Token.Tag := 2; +end; + +procedure TPascalScanner.ReadCustomToken; +var + c: Char; + S: String; +begin + repeat + GetNextChar; + c := LA(0); + Token.Position := Position; + if IsWhiteSpace(c) then + begin + continue; + end +{$IFDEF LINUX} + else if c = #10 then + ScanSeparator +{$ELSE} +{$IFDEF MACOS} + else if c = #10 then + ScanSeparator +{$ELSE} + else if c = #13 then + ScanSeparator +{$ENDIF} +{$ENDIF} + +{$IFDEF ANDROID} + else if c = #10 then + ScanSeparator +{$ENDIF} + else if IsEOF(c) then + ScanEOF + else if IsEOF then + ScanEOF + +{$IFDEF HTML} + else if (c = '?') or (c = '%') then + begin + case ScannerState of + ScanText: + RaiseError(errSyntaxError, []); + ScanProg: + if LA(1) = '>' then + begin + ScannerState := scanText; + GetNextChar; + + if (LA(1) = '<') and (LA(2) in ['?','%']) then + begin + ScannerState := scanText; + continue; + end; + +// GetNextChar; + Token.Position := Position + 1; + + ScanHtmlString(''); + end + else + begin + {$IFDEF CPP_SYN} + if LA(1) = '=' then + begin + GetNextChar; + ScanSpecial; + Token.Id := OP_ASSIGN; + Exit; + end; + {$ENDIF} + end; + end; + end + else if c = '<' then + begin + case ScannerState of + scanText: + begin + if LA(1) = '?' then + begin + GetNextChar; + GetNextChar; + ScanChars([Ord('a')..Ord('z')] + [Ord('A')..Ord('Z')]); + + if not StrEql('pax', Trim(Token.Text)) then + RaiseError(errSyntaxError, []); + + ScannerState := scanProg; + Token.TokenClass := tcNone; + Continue; + end + else if LA(1) = '%' then + begin + GetNextChar; + ScannerState := scanProg; + + if LA(1) = '=' then + begin + GetNextChar; + InsertText('print'); + end; + + Continue; + end + else if ByteInSet(LA(1), [Ord('a')..Ord('z'),Ord('A')..Ord('Z'), Ord('!')]) then + ScanHtmlString(c) + else + RaiseError(errSyntaxError, []); + end; + scanProg: + begin + ScanSpecial; + if LA(1) = '=' then + begin + GetNextChar; + ScanSpecial; + Token.Id := OP_LE; + end + else if LA(1) = '>' then + begin + GetNextChar; + ScanSpecial; + Token.Id := OP_NE; + end + else + Token.Id := OP_LT; + end; + end; + end + +{$ENDIF} + + else if IsAlpha(c) then + begin + ScanIdentifier; + + token.Length := Position - token.Position + 1; + + S := Token.Text; + + if StrEql(S, 'in') then + begin + ScanSpecial; + Token.Id := OP_SET_MEMBERSHIP; + end + else if StrEql(S, 'div') then + begin + ScanSpecial; + Token.Id := OP_IDIV; + end + else if StrEql(S, 'mod') then + begin + ScanSpecial; + Token.Id := OP_MOD; + end + else if StrEql(S, 'shl') then + begin + ScanSpecial; + Token.Id := OP_SHL; + end + else if StrEql(S, 'shr') then + begin + ScanSpecial; + Token.Id := OP_SHR; + end + else if StrEql(S, 'and') then + begin + ScanSpecial; + Token.Id := OP_AND; + end + else if StrEql(S, 'or') then + begin + ScanSpecial; + Token.Id := OP_OR; + end + else if StrEql(S, 'xor') then + begin + ScanSpecial; + Token.Id := OP_XOR; + end + else if StrEql(S, 'not') then + begin + ScanSpecial; + Token.Id := OP_NOT; + end + else if StrEql(S, 'is') then + begin + ScanSpecial; + Token.Id := OP_IS; + end + else if StrEql(S, 'as') then + begin + ScanSpecial; + Token.Id := OP_AS; + end; + + end + else if IsDigit(c) then + ScanNumberLiteral + else if c = '$' then + ScanHexLiteral + else if c = CHAR_AP then + ScanStringLiteral(CHAR_AP) + else if c = '+' then + begin + ScanSpecial; + Token.Id := OP_PLUS; + {$IFDEF CPP_SYN} + if LA(1) = '=' then + begin + GetNextChar; + ScanSpecial; + Token.Id := OP_ASSIGN; + end + else if LA(1) = '+' then + begin + GetNextChar; + ScanSpecial; + end; + {$ENDIF} + end + else if c = '-' then + begin + ScanSpecial; + Token.Id := OP_MINUS; + {$IFDEF CPP_SYN} + if LA(1) = '=' then + begin + GetNextChar; + ScanSpecial; + Token.Id := OP_ASSIGN; + end + else if LA(1) = '-' then + begin + GetNextChar; + ScanSpecial; + end; + {$ENDIF} + end + else if c = '*' then + begin + ScanSpecial; + Token.Id := OP_MULT; + {$IFDEF CPP_SYN} + if LA(1) = '=' then + begin + GetNextChar; + ScanSpecial; + Token.Id := OP_ASSIGN; + end; + {$ENDIF} + end + else if c = '/' then + begin + {$IFDEF CPP_SYN} + if LA(1) = '=' then + begin + GetNextChar; + ScanSpecial; + Token.Id := OP_ASSIGN; + end + else + {$ENDIF} + if LA(1) = '/' then + begin + ScanSingleLineComment(); + continue; + end + else + begin + ScanSpecial; + Token.Id := OP_DIV; + end; + end + else if ByteInSet(c, [Ord('~'), Ord('%'), Ord('^'), Ord('&'), Ord('|')]) then + begin + {$IFDEF CPP_SYN} + if LA(1) = '=' then + begin + GetNextChar; + ScanSpecial; + Token.Id := OP_ASSIGN; + end + else + if c = '^' then + begin + ScanSpecial; + Exit; + end + else + RaiseError(errSyntaxError, []); + {$ELSE} + if c = '^' then + ScanSpecial + else if c = '&' then + begin + GetNextChar; + continue; + end + else + RaiseError(errSyntaxError, []); + {$ENDIF} + end + else if c = '=' then + begin + ScanSpecial; + Token.Id := OP_EQ; + if LA(1) = '>' then + begin + GetNextChar; + ScanSpecial; + end + end + else if c = '<' then + begin + ScanSpecial; + if LA(1) = '=' then + begin + GetNextChar; + ScanSpecial; + Token.Id := OP_LE; + end + else if LA(1) = '>' then + begin + GetNextChar; + ScanSpecial; + Token.Id := OP_NE; + end + else + Token.Id := OP_LT; + end + else if c = '>' then + begin + ScanSpecial; + if LA(1) = '=' then + begin + GetNextChar; + ScanSpecial; + Token.Id := OP_GE; + end + else + Token.Id := OP_GT; + end + else if c = ':' then + begin + ScanSpecial; + if LA(1) = '=' then + begin + GetNextChar; + ScanSpecial; + Token.Id := OP_ASSIGN; + end; + end + else if c = ',' then + ScanSpecial + else if c = '.' then + begin + if LA(1) = '.' then + GetNextChar; + ScanSpecial; + end + else if c = '#' then + ScanCharLiteral + else if c = '(' then + begin + if LA(1) = '*' then + begin + BeginComment(2); + repeat + GetNextChar; + c := LA(0); + if ByteInSet(c, [10,13]) then + begin + Inc(LineCount); + GenSeparator; + if c = #13 then + GetNextChar; + end; + until ByteInSet(LA(1), [Ord('*'), Ord(CHAR_EOF)]) and + ByteInSet(LA(2), [Ord(')'), Ord(CHAR_EOF)]); + GetNextChar; + GetNextChar; + + EndComment(2); + end + else + ScanSpecial; + end + else if c = ')' then + ScanSpecial + else if c = '[' then + ScanSpecial + else if c = ']' then + ScanSpecial + else if c = '^' then + ScanSpecial + else if c = '@' then + ScanSpecial + else if c = ':' then + ScanSpecial + else if c = ';' then + ScanSpecial + else if c = '{' then + begin + if LA(1) = '$' then + begin + + if (not LookForward) then + begin + ScanCondDir('{', [Ord('$')]); + Token.TokenClass := tcNone; + continue; + end; + + GetNextChar; + if ByteInSet(LA(1), [Ord('b'), Ord('B')]) then + begin + GetNextChar; + if LA(1) = '+' then + begin + GetNextChar; + SetCompleteBooleanEval(true); + end + else if LA(1) = '-' then + begin + GetNextChar; + SetCompleteBooleanEval(false); + end; + end + else if ByteInSet(LA(1), [Ord('a'), Ord('A')]) then + begin + GetNextChar; + if LA(1) = '1' then + begin + GetNextChar; + SetAlignment(1); + end + else if LA(1) = '2' then + begin + GetNextChar; + SetAlignment(2); + end + else if LA(1) = '4' then + begin + GetNextChar; + SetAlignment(4); + end + else if LA(1) = '8' then + begin + GetNextChar; + SetAlignment(8); + end + else if LA(1) = '-' then + begin + GetNextChar; + SetAlignment(1); + end + else + RaiseError(errInvalidCompilerDirective, []); + end; + + end; + + if LA(1) = '}' then + begin + GetNextChar; + continue; + end; + + BeginComment(1); + repeat + GetNextChar; + + if IsEOF then + break; + + c := LA(0); + if ByteInSet(c, [10,13]) then + begin + Inc(LineCount); + GenSeparator; + if c = #13 then + GetNextChar; + end; + until LA(1) = '}'; + GetNextChar; + EndComment(1); + end + else if c = #254 then + begin + raise PaxCancelException.Create(TKernel(kernel).CancelChar); + end + else + begin + if SCAN_EXPR and (c = '}') then + begin + ScanSpecial; + Exit; + end; + + RaiseError(errSyntaxError, []); + end; + until Token.TokenClass <> tcNone; +end; + +function TPascalScanner.Scan_Expression: Variant; +var + Op: Integer; +begin + result := Scan_SimpleExpression; + while IsCurrText('>') or + IsCurrText('>=') or + IsCurrText('<') or + IsCurrText('<=') or + IsCurrText('=') or + IsCurrText('<>') do + begin + Op := 0; + if IsCurrText('>') then + Op := OP_GT + else if IsCurrText('>=') then + Op := OP_GE + else if IsCurrText('<') then + Op := OP_LT + else if IsCurrText('<=') then + Op := OP_LE + else if IsCurrText('=') then + Op := OP_EQ + else if IsCurrText('<>') then + Op := OP_NE; + ReadToken; + if Op = OP_GT then + result := result > Scan_SimpleExpression + else if Op = OP_GE then + result := result >= Scan_SimpleExpression + else if Op = OP_LT then + result := result < Scan_SimpleExpression + else if Op = OP_LE then + result := result <= Scan_SimpleExpression + else if Op = OP_EQ then + result := result = Scan_SimpleExpression + else if Op = OP_NE then + result := result <> Scan_SimpleExpression; + end; +end; + +function TPascalScanner.Scan_SimpleExpression: Variant; +var + Op: Integer; +begin + result := Scan_Term; + while IsCurrText('+') or + IsCurrText('-') or + IsCurrText('or') or + IsCurrText('xor') do + begin + Op := 0; + if IsCurrText('+') then + Op := OP_PLUS + else if IsCurrText('-') then + Op := OP_MINUS + else if IsCurrText('or') then + Op := OP_OR + else if IsCurrText('xor') then + Op := OP_XOR; + ReadToken; + if Op = OP_PLUS then + result := result + Scan_Term + else if Op = OP_MINUS then + result := result - Scan_Term + else if Op = OP_OR then + result := result or Scan_Term + else if Op = OP_XOR then + result := result xor Scan_Term; + end; +end; + +function TPascalScanner.Scan_Term: Variant; +var + Op: Integer; +begin + result := Scan_Factor; + while IsCurrText('*') or + IsCurrText('/') or + IsCurrText('div') or + IsCurrText('mod') or + IsCurrText('shl') or + IsCurrText('shr') or + IsCurrText('and') do + begin + Op := 0; + if IsCurrText('*') then + Op := OP_MULT + else if IsCurrText('/') then + Op := OP_DIV + else if IsCurrText('div') then + Op := OP_IDIV + else if IsCurrText('mod') then + Op := OP_MOD + else if IsCurrText('shl') then + Op := OP_SHL + else if IsCurrText('shr') then + Op := OP_SHR + else if IsCurrText('and') then + Op := OP_AND; + ReadToken; + if Op = OP_MULT then + result := result * Scan_Factor + else if Op = OP_DIV then + result := result / Scan_Factor + else if Op = OP_IDIV then + result := result div Scan_Factor + else if Op = OP_MOD then + result := result mod Scan_Factor + else if Op = OP_SHL then + result := result shl Scan_Factor + else if Op = OP_SHR then + result := result shr Scan_Factor + else if Op = OP_AND then + result := result and Scan_Factor; + end; +end; + +function TPascalScanner.Scan_Ident: Variant; +var + I, Id: Integer; + DefList: TDefList; + S: String; +begin + DefList := TKernel(kernel).DefList; + S := Token.Text; + I := DefList.IndexOf(S); + if I >= 0 then + begin + result := DefList[I].value; + end + else + begin + with TKernel(kernel).CurrParser do + begin + Id := LookUps(S, levelStack); + if Id = 0 then + Id := LookupInUsingList(S); + if Id = 0 then + RaiseError(errConstantExpressionExpected, []); + if GetSymbolRec(Id).Kind <> KindCONST then + RaiseError(errConstantExpressionExpected, []); + result := GetSymbolRec(Id).Value; + end; + end; + ReadToken; +end; + + +end. diff --git a/Sources/PAXCOMP_PAUSE.pas b/Sources/PAXCOMP_PAUSE.pas new file mode 100644 index 0000000..d3bc3e1 --- /dev/null +++ b/Sources/PAXCOMP_PAUSE.pas @@ -0,0 +1,169 @@ +//////////////////////////////////////////////////////////////////////////// +// PaxCompiler +// Site: http://www.paxcompiler.com +// Author: Alexander Baranovsky (paxscript@gmail.com) +// ======================================================================== +// Copyright (c) Alexander Baranovsky, 2006-2014. All rights reserved. +// Code Version: 4.2 +// ======================================================================== +// Unit: PAXCOMP_PAUSE.pas +// ======================================================================== +//////////////////////////////////////////////////////////////////////////// + +{$I PaxCompiler.def} +unit PAXCOMP_PAUSE; +interface +uses {$I uses.def} + SysUtils, + PAXCOMP_CONSTANTS, + PAXCOMP_SYS; + +type + TPauseRec = class + public + _EBP: IntPax; + _ESP: IntPax; + ESP0: IntPax; + ProgOffset: Integer; + StackFrame: Pointer; + StackFrameSize: Integer; + + PaxExcFrame1: PPaxExcFrame; + constructor Create; + destructor Destroy; override; + procedure Clear; + procedure SaveStackFrame; + function GetPtr(EBP_Value, Shift: Integer): Pointer; + end; + +implementation + +//-- TPauseRec ----------------------------------------------------------------- + +constructor TPauseRec.Create; +begin + inherited; + StackFrame := nil; + Clear; +end; + +destructor TPauseRec.Destroy; +begin + Clear; + inherited; +end; + +procedure TPauseRec.Clear; +begin + if StackFrame <> nil then + FreeMem(StackFrame, StackFrameSize); + _ESP := 0; + ESP0 := 0; + ProgOffset := 0; + StackFrame := nil; + StackFrameSize := 0; + PaxExcFrame1 := nil; +end; + +{$IFDEF PAX64} + +procedure _Save(I: Int64; P: Pointer; K: Int64); assembler; +asm + mov rax, I + mov rbx, P + mov rcx, K + + @@loop: + + mov rdx, [rax] + mov [rbx], rdx + + sub rax, 8 + sub rbx, 8 + + sub rcx, 1 + cmp rcx, 0 + + jnz @@loop +end; + +procedure TPauseRec.SaveStackFrame; +var + P: Pointer; + I, K: Integer; +begin + if ESP0 = _ESP then + Exit; + + if StackFrame <> nil then + FreeMem(StackFrame, StackFrameSize); + + StackFrameSize := ESP0 - _ESP; + + if StackFrameSize < 0 then + Exit; + + StackFrame := AllocMem(StackFrameSize); + + I := ESP0 - SizeOf(Pointer); + + P := ShiftPointer(StackFrame, StackFrameSize - SizeOf(Pointer)); + + K := StackFrameSize div SizeOf(Pointer); + + _Save(I, P, K); +end; +{$ELSE} +procedure TPauseRec.SaveStackFrame; +var + P: Pointer; + I, K: Integer; +begin + if ESP0 = _ESP then + Exit; + + if StackFrame <> nil then + FreeMem(StackFrame, StackFrameSize); + + StackFrameSize := ESP0 - _ESP; + + if StackFrameSize < 0 then + Exit; + + StackFrame := AllocMem(StackFrameSize); + + I := ESP0 - 4; + + P := ShiftPointer(StackFrame, StackFrameSize - 4); + + K := StackFrameSize div 4; + asm + mov eax, I + mov ebx, P + mov ecx, K + + @@loop: + + mov edx, [eax] + mov [ebx], edx + + sub eax, 4 + + sub ebx, 4 + + sub ecx, 1 + cmp ecx, 0 + jnz @@loop + end; +end; +{$ENDIF} + +function TPauseRec.GetPtr(EBP_Value, Shift: Integer): Pointer; +var + K: Integer; +begin + K := EBP_Value + Shift - _ESP; + result := ShiftPointer(StackFrame, K); +end; + +end. diff --git a/Sources/PAXCOMP_PCU.pas b/Sources/PAXCOMP_PCU.pas new file mode 100644 index 0000000..207b743 --- /dev/null +++ b/Sources/PAXCOMP_PCU.pas @@ -0,0 +1,1988 @@ +/////////////////////////////////////////////////////////////////////////// +// PaxCompiler +// Site: http://www.paxcompiler.com +// Author: Alexander Baranovsky (paxscript@gmail.com) +// ======================================================================== +// Copyright (c) Alexander Baranovsky, 2006-2014. All rights reserved. +// Code Version: 4.2 +// ======================================================================== +// Unit: PAXCOMP_PCU.pas +// ======================================================================== +//////////////////////////////////////////////////////////////////////////// + +{$I PaxCompiler.def} +unit PAXCOMP_PCU; +interface +uses {$I uses.def} + SysUtils, + Classes, + TypInfo, + PAXCOMP_CONSTANTS, + PAXCOMP_SYS, + PAXCOMP_MODULE, + PAXCOMP_PARSER, + PAXCOMP_KERNEL; + +function CompileUnit(Owner: Pointer; + const UnitName, FileName, PCUName: String; + Parser: TBaseParser; + BuildAll: Boolean; + OutputStream: TStream): Boolean; + +function PCUToString(Prg: Pointer; const UnitName, + FileName: String): String; overload; +function PCUToString(Prg: Pointer; const UnitName: String): String; overload; +function PCUToMainScript(Prg: Pointer; const Expression: String): String; +function PCUToScript(Prg: Pointer; Expression: String): TStringList; + +implementation + +uses + PAXCOMP_BASESYMBOL_TABLE, + PAXCOMP_SYMBOL_TABLE, + PAXCOMP_SYMBOL_REC, + PAXCOMP_BASERUNNER, + PAXCOMP_RTI, + PAXCOMP_MAP, + PAXCOMP_TYPEINFO, + PaxCompiler, + PaxRunner; + +procedure AddScopeVars(Prog: TBaseRunner; var CodeLines: String); forward; + +procedure CopyLocalImport(RootST, ST: TSymbolTable); +var + I: Integer; + R1, R2: TSymbolRec; + S: TMemoryStream; + Writer: TWriter; + Reader: TReader; +begin + for I := FirstLocalId + 1 to RootST.CompileCard do + begin + S := TMemoryStream.Create; + try + Writer := TWriter.Create(S, 1024); + try + R1 := RootST[I]; + R1.SaveToStream(Writer); + finally + FreeAndNil(Writer); + end; + + S.Seek(0, soFromBeginning); + Reader := TReader.Create(S, 1024); + + try + R2 := ST.AddRecord; + R2.LoadFromStream(Reader); + finally + FreeAndNil(Reader); + end; + + R2.Address := R1.Address; + R2.PClass := R1.PClass; + + finally + FreeAndNil(S); + end; + end; +end; + +function CompileUnit(Owner: Pointer; + const UnitName, FileName, PCUName: String; + Parser: TBaseParser; + BuildAll: Boolean; + OutputStream: TStream): Boolean; + +var + PaxCompiler1: TPaxCompiler; + PaxRunner1: TPaxRunner; + UnitParser: TBaseParser; + C: TBaseParserClass; + RootKernel: TKernel; + CodeLines: String; + I: Integer; + PaxRunnerClass: TPaxRunnerClass; + TempProg: Pointer; +begin + RootKernel := TKernel(Owner).RootKernel; + CodeLines := ''; + PaxRunnerClass := TPaxRunnerClass(RootKernel.Prog.Owner.ClassType); + + if Assigned(RootKernel.OnUsedUnit) then + if RootKernel.Modules.IndexOf(UnitName) = -1 then + if not RootKernel.OnUsedUnit(RootKernel.Owner, UnitName, CodeLines) then + CodeLines := ''; + + if CodeLines = '' then + if not FileExists(FileName) then + begin + I := RootKernel.Modules.IndexOf(UnitName); + if I >= 0 then + begin + CodeLines := RootKernel.Modules[I].Lines.Text; + end + else + begin + result := FileExists(PCUName); + Exit; + end; + end; + + PaxCompiler1 := TPaxCompiler.Create(nil); + CopyLocalImport(RootKernel.SymbolTable, + TKernel(PaxCompiler1.GetKernelPtr).SymbolTable); + + PaxRunner1 := PaxRunnerClass.Create(nil); + + C := TBaseParserClass(Parser.ClassType); + UnitParser := C.Create; + + TKernel(PaxCompiler1.GetKernelPtr).PCUOwner := Owner; + + TKernel(PaxCompiler1.GetKernelPtr).CopyRootEvents; + PaxCompiler1.DebugMode := RootKernel.DEBUG_MODE; + + TempProg := CurrProg; + try + CurrProg := PaxRunner1.GetProgPtr; + + TKernel(PaxCompiler1.GetKernelPtr).RegisterParser(UnitParser); + PaxCompiler1.AddModule(UnitName, UnitParser.LanguageName); + + if CodeLines = '' then + PaxCompiler1.AddCodeFromFile(UnitName, FileName) + else + PaxCompiler1.AddCode(UnitName, CodeLines); + + if PaxCompiler1.Compile(PaxRunner1, BuildAll) then + begin + if RootKernel.BuildWithRuntimePackages then + PaxRunner1.GetProgPtr.ProgList.Clear; + + PaxRunner1.GetProgPtr.PCULang := UnitParser.LanguageId; + + if Assigned(OutputStream) then + PaxRunner1.SaveToStream(OutputStream) + else + PaxRunner1.SaveToFile(PCUName); + result := true; + + RootKernel.BuildedUnits.Add(UpperCase(PCUName)); + end + else + begin + result := false; + RootKernel.Errors.Add(TKernel(PaxCompiler1.GetKernelPtr).Errors[0].Clone(RootKernel)); + end; + finally + CurrProg := TempProg; + + FreeAndNil(UnitParser); + FreeAndNil(PaxCompiler1); + FreeAndNil(PaxRunner1); + end; +end; + +function PCUToString(Prg: Pointer; const UnitName: String): String; +begin + result := PCUToString(Prg, UnitName, UnitName + '.PCU'); +end; + +function PCUToString(Prg: Pointer; const UnitName, + FileName: String): String; +var + Prog: TBaseRunner; + ModuleRec: TModuleRec; + CodeLines: String; + I, J, J1: Integer; + MapTable: TMapTable; + TypeInfoList: TPaxTypeInfoList; + EnumTypeDataContainer: TEnumTypeDataContainer; + ArrayTypeDataContainer: TArrayTypeDataContainer; + RecordTypeDataContainer: TRecordTypeDataContainer; + SetTypeDataContainer: TSetTypeDataContainer; + AliasTypeDataContainer: TAliasTypeDataContainer; + PointerTypeDataContainer: TPointerTypeDataContainer; + ClassRefTypeDataContainer: TClassRefTypeDataContainer; + DynArrayTypeDataContainer: TDynArrayTypeDataContainer; + ProceduralTypeDataContainer: TProceduralTypeDataContainer; + ClassTypeDataContainer: TClassTypeDataContainer; + MethodTypeDataContainer: TMethodTypeDataContainer; + InterfaceTypeDataContainer: TInterfaceTypeDataContainer; + S, S1, S2: String; + AFullTypeName: String; + MapRec: TMapRec; + SubDesc: TSubDesc; + K: Integer; + L: TStringList; + LangId: Integer; + AClassName: String; +begin + Prog := TBaseRunner(Prg); + + LangId := Prog.PCULang; + if LangId <> BASIC_LANGUAGE then + LangId := PASCAL_LANGUAGE; + + case LangId of + PASCAL_LANGUAGE: + begin + CodeLines := '{$WARNINGS OFF}' + #13#10 + + 'unit ' + ExtractName(UnitName) + ';' + #13#10 + + 'interface' + #13#10; + end; + BASIC_LANGUAGE: + begin + CodeLines := + 'Module ' + ExtractName(UnitName) + #13#10; + end; + end; + + ModuleRec := Prog.RunTimeModuleList.Modules.GetModuleRec(UnitName); + if ModuleRec <> nil then + if ModuleRec.UsedModules.Count > 0 then + begin + case LangId of + PASCAL_LANGUAGE: + begin + CodeLines := CodeLines + 'uses '; + for I := 0 to ModuleRec.UsedModules.Count - 1 do + begin + CodeLines := CodeLines + ModuleRec.UsedModules[I]; + if I < ModuleRec.UsedModules.Count - 1 then + CodeLines := CodeLines + ',' + else + CodeLines := CodeLines + ';' + #13#10; + end; + end; + BASIC_LANGUAGE: + begin + CodeLines := CodeLines + 'Imports '; + for I := 0 to ModuleRec.UsedModules.Count - 1 do + begin + CodeLines := CodeLines + ModuleRec.UsedModules[I]; + if I < ModuleRec.UsedModules.Count - 1 then + CodeLines := CodeLines + ',' + else + CodeLines := CodeLines + #13#10; + end; + end; + end; + end; + + MapTable := Prog.ScriptMapTable; + TypeInfoList := Prog.ProgTypeInfoList; + + for I := 0 to TypeInfoList.Count - 1 do + begin + S := String(TypeInfoList[I].FullName); + if Pos(UpperCase(UnitName) + '.', UpperCase(S)) = 0 then + continue; + case TypeInfoList[I].TypeInfo.Kind of + tkUnknown: + begin + case TypeInfoList[I].FinTypeId of + typeALIAS: + begin + AliasTypeDataContainer := + TypeInfoList[I].TypeDataContainer as TAliasTypeDataContainer; + case LangId of + PASCAL_LANGUAGE: + begin + CodeLines := CodeLines + 'type ' + PTIName(@TypeInfoList[I].TypeInfo) + + ' = '; + CodeLines := CodeLines + + ExtractName(AliasTypeDataContainer.FullSourceTypeName) + ';' + + #13#10; + end; + BASIC_LANGUAGE: + begin + CodeLines := CodeLines + 'TypeDef ' + PTIName(@TypeInfoList[I].TypeInfo) + + ' As '; + CodeLines := CodeLines + + ExtractName(AliasTypeDataContainer.FullSourceTypeName) + + #13#10; + end; + end; + end; + typePOINTER: + begin + PointerTypeDataContainer := + TypeInfoList[I].TypeDataContainer as TPointerTypeDataContainer; + case LangId of + PASCAL_LANGUAGE: + begin + CodeLines := CodeLines + 'type ' + PTIName(@TypeInfoList[I].TypeInfo) + + ' = '; + CodeLines := CodeLines + '^' + + ExtractName(PointerTypeDataContainer.FullOriginTypeName) + ';' + + #13#10; + end; + BASIC_LANGUAGE: + begin + CodeLines := CodeLines + 'TypeDef ' + PTIName(@TypeInfoList[I].TypeInfo) + + ' As '; + CodeLines := CodeLines + + ExtractName(PointerTypeDataContainer.FullOriginTypeName) + ' *' + + #13#10; + end; + end; + end; + typeCLASSREF: + begin + ClassRefTypeDataContainer := + TypeInfoList[I].TypeDataContainer as TClassRefTypeDataContainer; + case LangId of + PASCAL_LANGUAGE: + begin + CodeLines := CodeLines + 'type ' + PTIName(@TypeInfoList[I].TypeInfo) + + ' = '; + CodeLines := CodeLines + ' class of ' + + ExtractName(ClassRefTypeDataContainer.FullOriginTypeName) + ';' + + #13#10; + end; + BASIC_LANGUAGE: + begin + CodeLines := CodeLines + 'TypeDef ' + PTIName(@TypeInfoList[I].TypeInfo) + + ' As '; + CodeLines := CodeLines + ' Class Of ' + + ExtractName(ClassRefTypeDataContainer.FullOriginTypeName) + + #13#10; + end; + end; + end; + typePROC: + begin + ProceduralTypeDataContainer := + TypeInfoList[I].TypeDataContainer as TProceduralTypeDataContainer; + + case LangId of + PASCAL_LANGUAGE: + begin + CodeLines := CodeLines + 'type ' + PTIName(@TypeInfoList[I].TypeInfo) + + ' = '; + with ProceduralTypeDataContainer.SubDesc do + begin + if ResTypeId = typeVOID then + CodeLines := CodeLines + 'procedure (' + else + CodeLines := CodeLines + 'function ('; + if ParamList.Count = 0 then + CodeLines := CodeLines + ')' + else + for J := 0 to ParamList.Count - 1 do + begin + if ParamList[J].ParamMod = PM_BYREF then + CodeLines := CodeLines + 'var ' + else if ParamList[J].ParamMod = PM_CONST then + CodeLines := CodeLines + 'const '; + + CodeLines := CodeLines + ParamList[J].ParamName + ':' + + ParamList[J].ParamTypeName; + + if ParamList[J].OptValue <> '' then + CodeLines := CodeLines + '=' + ParamList[J].OptValue; + + if J < ParamList.Count - 1 then + CodeLines := CodeLines + ';' + else + CodeLines := CodeLines + ')'; + end; + + if ResTypeId = typeVOID then + CodeLines := CodeLines + ';' + else + CodeLines := CodeLines + ':' + ResTypeName + ';'; + + case CallMode of + ccREGISTER: CodeLines := CodeLines + 'register;'; + ccSTDCALL: CodeLines := CodeLines + 'stdcall;'; + ccCDECL: CodeLines := CodeLines + 'cdecl;'; + ccPASCAL: CodeLines := CodeLines + 'pascal;'; + ccSAFECALL: CodeLines := CodeLines + 'safecall;'; + ccMSFASTCALL: CodeLines := CodeLines + 'msfastcall;'; + end; + end; + end; + BASIC_LANGUAGE: + begin + Prog.RaiseError(errInternalError, []); + end; + end; + CodeLines := CodeLines + #13#10; + end; + end; + end; + tkRecord: + begin + RecordTypeDataContainer := + TypeInfoList[I].TypeDataContainer as TRecordTypeDataContainer; + + case LangId of + PASCAL_LANGUAGE: + begin + if TypeInfoList[I].IsGeneric then + begin + S := TypeInfoList[I].GenericTypeContainer.Definition; + CodeLines := CodeLines + 'type ' + S + #13#10; + continue; + end; + + if RecordTypeDataContainer.IsPacked then + CodeLines := CodeLines + 'type ' + PTIName(@TypeInfoList[I].TypeInfo) + + ' = packed record' + #13#10 + else + CodeLines := CodeLines + 'type ' + PTIName(@TypeInfoList[I].TypeInfo) + + ' = record' + #13#10; + + with RecordTypeDataContainer do + for J := 0 to FieldListContainer.Count - 1 do + begin + CodeLines := CodeLines + + StringFromPShortString(@FieldListContainer[J].Name) + ':' + + ExtractName(FieldListContainer[J].FullFieldTypeName) + + ';'#13#10; + end; + + AFullTypeName := TypeInfoList[I].FullName; + + // methods + for J := 0 to MapTable.Count - 1 do + begin + MapRec := MapTable[J]; + if Pos(UpperCase(UnitName), UpperCase(MapRec.FullName)) = 1 then + begin + if MapRec.Kind in KindSUBS then + begin + SubDesc := MapRec.SubDesc; + if not SubDesc.IsMethod then + continue; + + S := ExtractFullOwner(MapRec.FullName); + if not StrEql(AFullTypeName, S) then + continue; + + S := ExtractName(MapRec.FullName); + + case MapRec.Kind of + KindCONSTRUCTOR: + S := 'constructor ' + S + '('; + KindDESTRUCTOR: + S := 'destructor ' + S + '('; + KindSUB: + begin + if SubDesc.ResTypeId = typeVOID then + S := 'procedure ' + S + '(' + else + S := 'function ' + S + '('; + end; + end; + + if SubDesc.IsShared then + S := 'class ' + S; + + case MapRec.Vis of + cvNone: continue; + cvPrivate: S := 'private ' + S; + cvPublic: S := 'public ' + S; + cvProtected: S := 'protected ' + S; + cvPublished: + begin + if MapRec.Kind = KindSUB then + S := 'published ' + S; + end; + end; + + for K:=0 to SubDesc.ParamList.Count - 1 do + begin + case SubDesc.ParamList[K].ParamMod of + PM_BYVAL: begin end; + PM_BYREF: S := S + 'var '; + PM_CONST: S := S + 'const '; + end; + S := S + SubDesc.ParamList[K].ParamName; + S := S + ':'; + S := S + SubDesc.ParamList[K].ParamTypeName; + + if SubDesc.ParamList[K].OptValue <> '' then + S := S + '=' + SubDesc.ParamList[K].OptValue; + + if K < SubDesc.ParamList.Count - 1 then + S := S + ';'; + end; + + S := S + ')'; + + if MapRec.Kind = KindSUB then + if SubDesc.ResTypeId <> typeVOID then + S := S + ':' + SubDesc.ResTypeName; + S := S + ';'; +{ + case SubDesc.CallMode of + cmNONE: + if MapRec.Kind = KindDESTRUCTOR then + S := S + 'override;'; + cmVIRTUAL: + begin + S := S + 'virtual;'; + end; + cmDYNAMIC: + begin + S := S + 'dynamic;'; + end; + cmOVERRIDE: + S := S + 'override;'; + end; +} + if not Prog.PAX64 then + begin + case SubDesc.CallConv of + ccREGISTER: S := S + 'register'; + ccSTDCALL: S := S + 'stdcall'; + ccCDECL: S := S + 'cdecl'; + ccPASCAL: S := S + 'pascal'; + ccSAFECALL: S := S + 'safecall'; + ccMSFASTCALL: S := S + 'msfastcall'; + end; + S := S + ';'; + end; + + S := S + 'external ' + '''' + FileName + '''' + ';'; + CodeLines := CodeLines + S + #13#10; + end; // kindSUB + end; + end; // methods + CodeLines := CodeLines + 'end;'#13#10; + end; // PASCAL_LANGUAGE + BASIC_LANGUAGE: + begin + if TypeInfoList[I].IsGeneric then + begin + S := TypeInfoList[I].GenericTypeContainer.Definition; + CodeLines := CodeLines + S + #13#10; + continue; + end; + + CodeLines := CodeLines + 'Structure ' + PTIName(@TypeInfoList[I].TypeInfo) + + #13#10; + with RecordTypeDataContainer do + for J := 0 to FieldListContainer.Count - 1 do + begin + CodeLines := CodeLines + + StringFromPShortString(@FieldListContainer[J].Name) + ' As ' + + ExtractName(FieldListContainer[J].FullFieldTypeName) + + #13#10; + end; + + AFullTypeName := TypeInfoList[I].FullName; + + // methods + for J := 0 to MapTable.Count - 1 do + begin + MapRec := MapTable[J]; + if Pos(UpperCase(UnitName), UpperCase(MapRec.FullName)) = 1 then + begin + if MapRec.Kind in KindSUBS then + begin + SubDesc := MapRec.SubDesc; + if not SubDesc.IsMethod then + continue; + + S := ExtractFullOwner(MapRec.FullName); + if not StrEql(AFullTypeName, S) then + continue; + + AClassName := ExtractName(S); + + if SubDesc.IsShared then + S := 'Shared ' + else + S := ''; + + case MapRec.Vis of + cvNone: continue; + cvPrivate: S := S + ' Private '; + cvPublic: S := S + ' Public '; + cvProtected: S := S + ' Protected '; + cvPublished: + begin + if MapRec.Kind = KindSUB then + S := S + ' Published '; + end; + end; +{ + case SubDesc.CallMode of + cmNONE: + if MapRec.Kind = KindDESTRUCTOR then + S := S + ' Overriden '; + cmVIRTUAL: + begin + S := S + ' Overriadable '; + end; + cmDYNAMIC: + begin + S := S + ' Dynamic '; + end; + cmOVERRIDE: + S := S + ' Overriden '; + end; +} + case MapRec.Kind of + KindCONSTRUCTOR: + S := S + ' Sub New '; + KindDESTRUCTOR: + S := S + ' Sub Finalize '; + KindSUB: + begin + if SubDesc.ResTypeId = typeVOID then + S := S + ' Sub ' + ExtractName(MapRec.FullName) + else + S := S + ' Function ' + ExtractName(MapRec.FullName); + end; + end; +{ + case SubDesc.CallConv of + ccREGISTER: S := S + ' Register '; + ccSTDCALL: S := S + ' StdCall '; + ccCDECL: S := S + ' Cdecl '; + ccPASCAL: S := S + ' Pascal '; + ccSAFECALL: S := S + ' Safecall '; + ccMSFASTCALL: S := S + ' msfastcall '; + end; +} + S := S + ' Lib ' + '"' + FileName + '"'; + case MapRec.Kind of + KindCONSTRUCTOR: + S := S + ' Alias ' + '"' + AClassName + '.Create' + '"'; + KindDESTRUCTOR: + S := S + ' Alias ' + '"' + AClassName + '.Destroy' + '"'; + else + S := S + ' Alias ' + '"' + AClassName + '.' + ExtractName(MapRec.FullName) + '"'; + end; + + S := S + ' ('; + + for K:=0 to SubDesc.ParamList.Count - 1 do + begin + case SubDesc.ParamList[K].ParamMod of + PM_BYVAL: begin end; + PM_BYREF: S := S + 'ByRef '; + PM_CONST: S := S + 'Const '; + end; + S := S + SubDesc.ParamList[K].ParamName; + S := S + ' As '; + S := S + SubDesc.ParamList[K].ParamTypeName; + + if SubDesc.ParamList[K].OptValue <> '' then + S := S + '=' + SubDesc.ParamList[K].OptValue; + + if K < SubDesc.ParamList.Count - 1 then + S := S + ','; + end; + + S := S + ')'; + + if MapRec.Kind = KindSUB then + if SubDesc.ResTypeId <> typeVOID then + S := S + ' As ' + SubDesc.ResTypeName; + + CodeLines := CodeLines + S + #13#10; + end; // kindSUB + end; + end; // methods + + CodeLines := CodeLines + 'End Structure ' + #13#10 + #13#10; + + end; // BASIC_LANGUAGE + end; + end; // tkRecord + tkArray: + begin + case LangId of + PASCAL_LANGUAGE: + begin + ArrayTypeDataContainer := + TypeInfoList[I].TypeDataContainer as TArrayTypeDataContainer; + CodeLines := CodeLines + 'type ' + PTIName(@TypeInfoList[I].TypeInfo) + + ' = array['; + case ArrayTypeDataContainer.FinRangeTypeId of +{$IFNDEF PAXARM} + typeANSICHAR, +{$ENDIF} + typeWIDECHAR: + CodeLines := CodeLines + + '''' + Chr(ArrayTypeDataContainer.B1) + '''' + '..' + + '''' + Chr(ArrayTypeDataContainer.B2) + '''' + ']'; + typeENUM, typeBOOLEAN, typeBYTEBOOL, typeWORDBOOL, typeLONGBOOL: + CodeLines := CodeLines + + ExtractName(ArrayTypeDataContainer.FullRangeTypeName) + ']'; + else + begin + CodeLines := CodeLines + + IntToStr(ArrayTypeDataContainer.B1) + '..' + + IntToStr(ArrayTypeDataContainer.B2) + ']'; + end; + end; // case + CodeLines := CodeLines + ' of ' + + ExtractName(ArrayTypeDataContainer.FullElemTypeName) + ';' + + #13#10; + end; + BASIC_LANGUAGE: + begin + Prog.RaiseError(errInternalError, []); + end; + end; + end; //tkArray + tkDynArray: + begin + DynArrayTypeDataContainer := + TypeInfoList[I].TypeDataContainer as TDynArrayTypeDataContainer; + case LangId of + PASCAL_LANGUAGE: + begin + CodeLines := CodeLines + 'type ' + PTIName(@TypeInfoList[I].TypeInfo) + + ' = '; + CodeLines := CodeLines + ' array of ' + + ExtractName(DynArrayTypeDataContainer.FullElementTypeName) + ';' + + #13#10; + end; + BASIC_LANGUAGE: + begin + Prog.RaiseError(errInternalError, []); + end; + end; + end; + tkSet: + begin + SetTypeDataContainer := + TypeInfoList[I].TypeDataContainer as TSetTypeDataContainer; + case LangId of + PASCAL_LANGUAGE: + begin + CodeLines := CodeLines + 'type ' + PTIName(@TypeInfoList[I].TypeInfo) + + ' = set of '; + CodeLines := CodeLines + + ExtractName(SetTypeDataContainer.FullCompName) + ';' + + #13#10; + end; + BASIC_LANGUAGE: + begin + Prog.RaiseError(errInternalError, []); + end; + end; + end; // tkSet + tkMethod: + begin + MethodTypeDataContainer := + TypeInfoList[I].TypeDataContainer as TMethodTypeDataContainer; + if MethodTypeDataContainer.ResultTypeId = 0 then + continue; + + case LangId of + PASCAL_LANGUAGE: + begin + CodeLines := CodeLines + 'type ' + PTIName(@TypeInfoList[I].TypeInfo) + + ' = '; + with MethodTypeDataContainer do + begin + if ResultTypeId = typeVOID then + CodeLines := CodeLines + 'procedure (' + else + CodeLines := CodeLines + 'function ('; + if ParamCount = 0 then + CodeLines := CodeLines + ')' + else + for J := 0 to ParamCount - 1 do + with ParamListContainer do + begin + if ParamList[J].Flags = [pfVar] then + CodeLines := CodeLines + 'var ' + else if ParamList[J].Flags = [pfConst] then + CodeLines := CodeLines + 'const '; + + CodeLines := CodeLines + StringFromPShortString(@ParamList[J].ParamName) + ':' + + StringFromPShortString(@ParamList[J].TypeName); + if J < ParamCount - 1 then + CodeLines := CodeLines + ';' + else + CodeLines := CodeLines + ')'; + end; + + if ResultTypeId = typeVOID then + CodeLines := CodeLines + ' of object;' + else + CodeLines := CodeLines + ':' + StringFromPShortString(@ResultType) + ' of object;'; + + case CallConv of + ccREGISTER: CodeLines := CodeLines + 'register;'; + ccSTDCALL: CodeLines := CodeLines + 'stdcall;'; + ccCDECL: CodeLines := CodeLines + 'cdecl;'; + ccPASCAL: CodeLines := CodeLines + 'pascal;'; + ccSAFECALL: CodeLines := CodeLines + 'safecall;'; + ccMSFASTCALL: CodeLines := CodeLines + 'msfastcall;'; + end; + + CodeLines := CodeLines + #13#10; + end; + end; + BASIC_LANGUAGE: + begin + Prog.RaiseError(errInternalError, []); + end; + end; + end; // tkMethod + tkClass: + begin + ClassTypeDataContainer := + TypeInfoList[I].TypeDataContainer as TClassTypeDataContainer; + + if Pos(UpperCase(UnitName), UpperCase(String(TypeInfoList[I].FullName))) <> 1 then + continue; + + case LangId of + PASCAL_LANGUAGE: + begin + if TypeInfoList[I].IsGeneric then + begin + S := TypeInfoList[I].GenericTypeContainer.Definition; + CodeLines := CodeLines + 'type ' + S + #13#10; + continue; + end; + + S := ExtractFullName(String(TypeInfoList[I].FullName)); + S := RemoveCh('#', S); + CodeLines := CodeLines + 'type ' + S; + + S := ExtractName(String(ClassTypeDataContainer.FullParentName)); + S := RemoveCh('#', S); + CodeLines := CodeLines + ' = class (' + S; + + for J := 0 to ClassTypeDataContainer.SupportedInterfaces.Count - 1 do + begin + CodeLines := CodeLines + ',' + + ClassTypeDataContainer.SupportedInterfaces[J]; + end; + + CodeLines := CodeLines + ')' + #13#10; + AFullTypeName := String(TypeInfoList[I].FullName); + + // public fields + for J := 0 to ClassTypeDataContainer.AnotherFieldListContainer.Count - 1 do + begin + case ClassTypeDataContainer.AnotherFieldListContainer[J].Vis of + cvPrivate: CodeLines := CodeLines + 'private '; + cvProtected: CodeLines := CodeLines + 'protected '; + cvPublic: CodeLines := CodeLines + 'public '; + end; + + CodeLines := CodeLines + + StringFromPShortString(@ClassTypeDataContainer.AnotherFieldListContainer[J].Name) + + ':' + + ClassTypeDataContainer.AnotherFieldListContainer[J].FullFieldTypeName + + ';'#13#10; + end; + + // published fields + for J := 0 to ClassTypeDataContainer.FieldListContainer.Count - 1 do + begin + CodeLines := CodeLines + 'published ' + + StringFromPShortString(@ClassTypeDataContainer.FieldListContainer[J].Name) + ':' + + ExtractName(ClassTypeDataContainer.FieldListContainer[J].FullFieldTypeName) + + ';'#13#10; + end; + + // methods + for J := 0 to MapTable.Count - 1 do + begin + MapRec := MapTable[J]; + if Pos(UpperCase(UnitName), UpperCase(MapRec.FullName)) = 1 then + begin + if MapRec.Kind in KindSUBS then + begin + SubDesc := MapRec.SubDesc; + if not SubDesc.IsMethod then + continue; + + S := ExtractFullOwner(MapRec.FullName); + if not StrEql(AFullTypeName, S) then + continue; + + S := ExtractName(MapRec.FullName); + + case MapRec.Kind of + KindCONSTRUCTOR: + S := 'constructor ' + S + '('; + KindDESTRUCTOR: + S := 'destructor ' + S + '('; + KindSUB: + begin + if SubDesc.ResTypeId = typeVOID then + S := 'procedure ' + S + '(' + else + S := 'function ' + S + '('; + end; + end; + + if SubDesc.IsShared then + S := 'class ' + S; + + case MapRec.Vis of + cvNone: continue; + cvPrivate: S := 'private ' + S; + cvPublic: S := 'public ' + S; + cvProtected: S := 'protected ' + S; + cvPublished: + begin + if MapRec.Kind = KindSUB then + S := 'published ' + S; + end; + end; + + for K:=0 to SubDesc.ParamList.Count - 1 do + begin + case SubDesc.ParamList[K].ParamMod of + PM_BYVAL: begin end; + PM_BYREF: S := S + 'var '; + PM_CONST: S := S + 'const '; + end; + S := S + SubDesc.ParamList[K].ParamName; + S := S + ':'; + S := S + SubDesc.ParamList[K].ParamTypeName; + + if SubDesc.ParamList[K].OptValue <> '' then + S := S + '=' + SubDesc.ParamList[K].OptValue; + + if K < SubDesc.ParamList.Count - 1 then + S := S + ';'; + end; + + S := S + ')'; + + if MapRec.Kind = KindSUB then + if SubDesc.ResTypeId <> typeVOID then + S := S + ':' + SubDesc.ResTypeName; + S := S + ';'; + + case SubDesc.CallMode of + cmNONE: + if MapRec.Kind = KindDESTRUCTOR then + S := S + 'override;'; + cmVIRTUAL: + begin + S := S + 'virtual;'; + end; + cmDYNAMIC: + begin + S := S + 'dynamic;'; + end; + cmOVERRIDE: + S := S + 'override;'; + end; + + if not Prog.PAX64 then + begin + case SubDesc.CallConv of + ccREGISTER: S := S + 'register'; + ccSTDCALL: S := S + 'stdcall'; + ccCDECL: S := S + 'cdecl'; + ccPASCAL: S := S + 'pascal'; + ccSAFECALL: S := S + 'safecall'; + ccMSFASTCALL: S := S + 'msfastcall'; + end; + S := S + ';'; + end; + + if MapRec.SubDesc.OverCount > 0 then + S := S + 'overload;'; + + if (MapRec.SubDesc.DllName = '') and (MapRec.SubDesc.AliasName = '') then + S := S + 'external ' + '''' + FileName + '''' + ';' + else + S := S + ' external ' + '''' + MapRec.SubDesc.DllName + '''' + + ' name ' + '''' + MapRec.SubDesc.AliasName + '''' + + ';'; + + CodeLines := CodeLines + S + #13#10; + end; // kindSUB + end; + end; // methods + + // public properties + with ClassTypeDataContainer do + for J := 0 to AnotherPropList.Count - 1 do + with AnotherPropList[J] do + begin + case Vis of + cvPrivate: CodeLines := CodeLines + 'private '; + cvProtected: CodeLines := CodeLines + 'protected '; + cvPublic: CodeLines := CodeLines + 'public '; + end; + CodeLines := CodeLines + 'property ' + PropName; + if ParamNames.Count > 0 then + begin + CodeLines := CodeLines + '['; + for K := 0 to ParamNames.Count - 1 do + begin + CodeLines := CodeLines + ParamNames[K] + ':' + + ParamTypes[K]; + if K < ParamNames.Count - 1 then + CodeLines := CodeLines + ',' + else + CodeLines := CodeLines + ']'; + end; + end; + CodeLines := CodeLines + ':' + PropType; + if Length(ReadName) > 0 then + CodeLines := CodeLines + ' read ' + ReadName; + if Length(WriteName) > 0 then + CodeLines := CodeLines + ' write ' + WriteName; + CodeLines := CodeLines + ';'; + if IsDefault then + CodeLines := CodeLines + 'default;'; + CodeLines := CodeLines + #13#10; + end; + + // published properties + for J := 0 to ClassTypeDataContainer.PropDataContainer.PropTypeNames.Count - 1 do + begin + S1 := ExtractName(ClassTypeDataContainer.PropDataContainer.ReadNames[J]); + if Pos(READ_PREFIX, S1) = 1 then + S1 := Copy(S1, Length(READ_PREFIX) + 1, Length(S1) - Length(READ_PREFIX)); + S2 := ExtractName(ClassTypeDataContainer.PropDataContainer.WriteNames[J]); + if Pos(WRITE_PREFIX, S2) = 1 then + S2 := Copy(S2, Length(WRITE_PREFIX) + 1, Length(S2) - Length(WRITE_PREFIX)); + + CodeLines := CodeLines + 'published property '; + + S := StringFromPShortString(@ClassTypeDataContainer.PropDataContainer.PropList[J].Name); + CodeLines := CodeLines + S; + + for J1 := 0 to MapTable.Count - 1 do + begin + MapRec := MapTable[J1]; + if MapRec.Kind <> KindSUB then + continue; + + if Pos(UpperCase(UnitName), UpperCase(MapRec.FullName)) = 1 then + begin + SubDesc := MapRec.SubDesc; + if not SubDesc.IsMethod then + continue; + if SubDesc.ParamList.Count = 0 then + continue; + + S := ExtractFullOwner(MapRec.FullName); + if not StrEql(AFullTypeName, S) then + continue; + S := ExtractName(MapRec.FullName); + if not StrEql(S, S1) then + continue; + + S := '['; + for K:=0 to SubDesc.ParamList.Count - 1 do + begin + case SubDesc.ParamList[K].ParamMod of + PM_BYVAL: begin end; + PM_BYREF: S := S + 'var '; + PM_CONST: S := S + 'const '; + end; + S := S + SubDesc.ParamList[K].ParamName; + S := S + ':'; + S := S + SubDesc.ParamList[K].ParamTypeName; + + if SubDesc.ParamList[K].OptValue <> '' then + S := S + '=' + SubDesc.ParamList[K].OptValue; + + if K < SubDesc.ParamList.Count - 1 then + S := S + ';'; + end; + S := S + ']'; + CodeLines := CodeLines + S; + break; + end; + end; + + if CodeLines[Length(CodeLines)] <> ']' then + for J1 := 0 to MapTable.Count - 1 do + begin + MapRec := MapTable[J1]; + if MapRec.Kind <> KindSUB then + continue; + + if Pos(UpperCase(UnitName), UpperCase(MapRec.FullName)) = 1 then + begin + SubDesc := MapRec.SubDesc; + if not SubDesc.IsMethod then + continue; + if SubDesc.ParamList.Count <= 1 then + continue; + + S := ExtractFullOwner(MapRec.FullName); + if not StrEql(AFullTypeName, S) then + continue; + S := ExtractName(MapRec.FullName); + if not StrEql(S, S2) then + continue; + + S := '['; + for K:=0 to SubDesc.ParamList.Count - 2 do + begin + case SubDesc.ParamList[K].ParamMod of + PM_BYVAL: begin end; + PM_BYREF: S := S + 'var '; + PM_CONST: S := S + 'const '; + end; + S := S + SubDesc.ParamList[K].ParamName; + S := S + ':'; + S := S + SubDesc.ParamList[K].ParamTypeName; + + if SubDesc.ParamList[K].OptValue <> '' then + S := S + '=' + SubDesc.ParamList[K].OptValue; + + if K < SubDesc.ParamList.Count - 2 then + S := S + ';'; + end; + S := S + ']'; + CodeLines := CodeLines + S; + break; + end; + end; + + CodeLines := CodeLines + + ':' + + ExtractName(ClassTypeDataContainer.PropDataContainer.PropTypeNames[J]); + + if Length(S1) > 0 then + CodeLines := CodeLines + ' read ' + S1; + if Length(S2) > 0 then + CodeLines := CodeLines + ' write ' + S2; + CodeLines := CodeLines + ';'#13#10; + end; + + CodeLines := CodeLines + 'end;' + #13#10; + end; + BASIC_LANGUAGE: + begin + if TypeInfoList[I].IsGeneric then + begin + S := TypeInfoList[I].GenericTypeContainer.Definition; + CodeLines := CodeLines + S + #13#10; + continue; + end; + + if TypeInfoList[I].IsGeneric then + begin + S := TypeInfoList[I].GenericTypeContainer.Definition; + CodeLines := CodeLines + S + #13#10; + continue; + end; + + CodeLines := CodeLines + 'Class ' + PTIName(@TypeInfoList[I].TypeInfo) + + #13#10; + + S := ExtractName(ClassTypeDataContainer.FullParentName); + S := RemoveCh('#', S); + CodeLines := CodeLines + 'Inherits ' + S; + + for J := 0 to ClassTypeDataContainer.SupportedInterfaces.Count - 1 do + begin + CodeLines := CodeLines + ',' + + ClassTypeDataContainer.SupportedInterfaces[J]; + end; + + CodeLines := CodeLines + #13#10; + + with ClassTypeDataContainer do + for J := 0 to FieldListContainer.Count - 1 do + begin + CodeLines := CodeLines + + StringFromPShortString(@FieldListContainer[J].Name) + ' As ' + + ExtractName(FieldListContainer[J].FullFieldTypeName) + + #13#10; + end; + + AFullTypeName := TypeInfoList[I].FullName; + + // methods + for J := 0 to MapTable.Count - 1 do + begin + MapRec := MapTable[J]; + if Pos(UpperCase(UnitName), UpperCase(MapRec.FullName)) = 1 then + begin + if MapRec.Kind in KindSUBS then + begin + SubDesc := MapRec.SubDesc; + if not SubDesc.IsMethod then + continue; + + S := ExtractFullOwner(MapRec.FullName); + if not StrEql(AFullTypeName, S) then + continue; + + AClassName := ExtractName(S); + + if SubDesc.IsShared then + S := 'Shared ' + else + S := ''; + + case MapRec.Vis of + cvNone: continue; + cvPrivate: S := S + ' Private '; + cvPublic: S := S + ' Public '; + cvProtected: S := S + ' Protected '; + cvPublished: + begin + if MapRec.Kind = KindSUB then + S := S + ' Published '; + end; + end; +{ + case SubDesc.CallMode of + cmNONE: + if MapRec.Kind = KindDESTRUCTOR then + S := S + ' Overriden '; + cmVIRTUAL: + begin + S := S + ' Overriadable '; + end; + cmDYNAMIC: + begin + S := S + ' Dynamic '; + end; + cmOVERRIDE: + S := S + ' Overriden '; + end; +} + case MapRec.Kind of + KindCONSTRUCTOR: + S := S + ' Sub New '; + KindDESTRUCTOR: + S := S + ' Sub Finalize '; + KindSUB: + begin + S1 := ExtractName(MapRec.FullName); + if Pos('__get', S1) = 1 then + S1 := '__' + S1 + else if Pos('__set', S1) = 1 then + S1 := '__' + S1; + if SubDesc.ResTypeId = typeVOID then + S := S + ' Sub ' + S1 + else + S := S + ' Function ' + S1; + end; + end; +{ + case SubDesc.CallConv of + ccREGISTER: S := S + ' Register '; + ccSTDCALL: S := S + ' StdCall '; + ccCDECL: S := S + ' Cdecl '; + ccPASCAL: S := S + ' Pascal '; + ccSAFECALL: S := S + ' Safecall '; + ccMSFASTCALL: S := S + ' msfastcall '; + end; +} + S := S + ' Lib ' + '"' + FileName + '"'; + case MapRec.Kind of + KindCONSTRUCTOR: + S := S + ' Alias ' + '"' + AClassName + '.Create' + '"'; + KindDESTRUCTOR: + S := S + ' Alias ' + '"' + AClassName + '.Destroy' + '"'; + else + S := S + ' Alias ' + '"' + AClassName + '.' + ExtractName(MapRec.FullName) + '"'; + end; + + S := S + ' ('; + + for K:=0 to SubDesc.ParamList.Count - 1 do + begin + case SubDesc.ParamList[K].ParamMod of + PM_BYVAL: begin end; + PM_BYREF: S := S + 'ByRef '; + PM_CONST: S := S + 'Const '; + end; + S := S + SubDesc.ParamList[K].ParamName; + S := S + ' As '; + S := S + SubDesc.ParamList[K].ParamTypeName; + + if SubDesc.ParamList[K].OptValue <> '' then + S := S + '=' + SubDesc.ParamList[K].OptValue; + + if K < SubDesc.ParamList.Count - 1 then + S := S + ','; + end; + + S := S + ')'; + + if MapRec.Kind = KindSUB then + if SubDesc.ResTypeId <> typeVOID then + S := S + ' As ' + SubDesc.ResTypeName; + + CodeLines := CodeLines + S + #13#10; + end; // kindSUB + end; + end; // methods + + // public properties + with ClassTypeDataContainer do + for J := 0 to AnotherPropList.Count - 1 do + with AnotherPropList[J] do + begin + case Vis of + cvPrivate: CodeLines := CodeLines + 'Private '; + cvProtected: CodeLines := CodeLines + 'Protected '; + cvPublic: CodeLines := CodeLines + 'Public '; + end; + CodeLines := CodeLines + 'Property ' + PropName; + if ParamNames.Count > 0 then + begin + CodeLines := CodeLines + '('; + for K := 0 to ParamNames.Count - 1 do + begin + CodeLines := CodeLines + ParamNames[K] + ' As ' + + ParamTypes[K]; + if K < ParamNames.Count - 1 then + CodeLines := CodeLines + ',' + else + CodeLines := CodeLines + ')'; + end; + end; + CodeLines := CodeLines + ' As ' + + PropType + #13#10; + if Length(ReadName) > 0 then + begin + CodeLines := CodeLines + 'Get' + #13#10; + CodeLines := CodeLines + ' Return ' + '__' + ReadName; + CodeLines := CodeLines + '('; + for K := 0 to ParamNames.Count - 1 do + begin + CodeLines := CodeLines + ParamNames[K]; + if K < ParamNames.Count - 1 then + CodeLines := CodeLines + ','; + end; + CodeLines := CodeLines + ')'; + CodeLines := CodeLines + #13#10; + CodeLines := CodeLines + 'End Get' + #13#10; + end; + if Length(WriteName) > 0 then + begin + CodeLines := CodeLines + 'Set' + #13#10; + CodeLines := CodeLines + '__' + WriteName; + CodeLines := CodeLines + '('; + for K := 0 to ParamNames.Count - 1 do + begin + CodeLines := CodeLines + ParamNames[K]; + CodeLines := CodeLines + ','; + end; + CodeLines := CodeLines + 'value)'; + CodeLines := CodeLines + #13#10; + CodeLines := CodeLines + 'End Set' + #13#10; + end; + CodeLines := CodeLines + 'End Property' + #13#10; + CodeLines := CodeLines + #13#10; + end; + + // published properties + for J := 0 to ClassTypeDataContainer.PropDataContainer.PropTypeNames.Count - 1 do + begin + S1 := ExtractName(ClassTypeDataContainer.PropDataContainer.ReadNames[J]); + if Pos(READ_PREFIX, S1) = 1 then + S1 := Copy(S1, Length(READ_PREFIX) + 1, Length(S1) - Length(READ_PREFIX)); + S2 := ExtractName(ClassTypeDataContainer.PropDataContainer.WriteNames[J]); + if Pos(WRITE_PREFIX, S2) = 1 then + S2 := Copy(S2, Length(WRITE_PREFIX) + 1, Length(S2) - Length(WRITE_PREFIX)); + + CodeLines := CodeLines + 'Published Property '; + + S := StringFromPShortString(@ClassTypeDataContainer.PropDataContainer.PropList[J].Name); + CodeLines := CodeLines + S; + + for J1 := 0 to MapTable.Count - 1 do + begin + MapRec := MapTable[J1]; + if MapRec.Kind <> KindSUB then + continue; + + if Pos(UpperCase(UnitName), UpperCase(MapRec.FullName)) = 1 then + begin + SubDesc := MapRec.SubDesc; + if not SubDesc.IsMethod then + continue; + if SubDesc.ParamList.Count = 0 then + continue; + + S := ExtractFullOwner(MapRec.FullName); + if not StrEql(AFullTypeName, S) then + continue; + S := ExtractName(MapRec.FullName); + if not StrEql(S, S1) then + continue; + + S := '('; + for K:=0 to SubDesc.ParamList.Count - 1 do + begin + case SubDesc.ParamList[K].ParamMod of + PM_BYVAL: begin end; + PM_BYREF: S := S + 'var '; + PM_CONST: S := S + 'const '; + end; + S := S + SubDesc.ParamList[K].ParamName; + S := S + ':'; + S := S + SubDesc.ParamList[K].ParamTypeName; + + if SubDesc.ParamList[K].OptValue <> '' then + S := S + '=' + SubDesc.ParamList[K].OptValue; + + if K < SubDesc.ParamList.Count - 1 then + S := S + ';'; + end; + S := S + ')'; + CodeLines := CodeLines + S; + break; + end; + end; + + if CodeLines[Length(CodeLines)] <> ')' then + for J1 := 0 to MapTable.Count - 1 do + begin + MapRec := MapTable[J1]; + if MapRec.Kind <> KindSUB then + continue; + + if Pos(UpperCase(UnitName), UpperCase(MapRec.FullName)) = 1 then + begin + SubDesc := MapRec.SubDesc; + if not SubDesc.IsMethod then + continue; + if SubDesc.ParamList.Count <= 1 then + continue; + + S := ExtractFullOwner(MapRec.FullName); + if not StrEql(AFullTypeName, S) then + continue; + S := ExtractName(MapRec.FullName); + if not StrEql(S, S2) then + continue; + + S := '('; + for K:=0 to SubDesc.ParamList.Count - 2 do + begin + case SubDesc.ParamList[K].ParamMod of + PM_BYVAL: begin end; + PM_BYREF: S := S + 'ByRef '; + PM_CONST: S := S + 'Const '; + end; + S := S + SubDesc.ParamList[K].ParamName; + S := S + ' As '; + S := S + SubDesc.ParamList[K].ParamTypeName; + + if SubDesc.ParamList[K].OptValue <> '' then + S := S + '=' + SubDesc.ParamList[K].OptValue; + + if K < SubDesc.ParamList.Count - 2 then + S := S + ','; + end; + S := S + ')'; + CodeLines := CodeLines + S; + break; + end; + end; + + CodeLines := CodeLines + + ' As ' + + ExtractName(ClassTypeDataContainer.PropDataContainer.PropTypeNames[J]); + + CodeLines := CodeLines + #13#10; + if Length(S1) > 0 then + begin + CodeLines := CodeLines + 'Get' + #13#10; + CodeLines := CodeLines + ' Return ' + '__' + String(S1); + CodeLines := CodeLines + '('; + CodeLines := CodeLines + ')'; + CodeLines := CodeLines + #13#10; + CodeLines := CodeLines + 'End Get' + #13#10; + end; + if Length(S2) > 0 then + begin + CodeLines := CodeLines + 'Set' + #13#10; + CodeLines := CodeLines + '__' + String(S2); + CodeLines := CodeLines + '('; + CodeLines := CodeLines + 'value)'; + CodeLines := CodeLines + #13#10; + CodeLines := CodeLines + 'End Set' + #13#10; + end; + CodeLines := CodeLines + 'End Property' + #13#10; + end; + + CodeLines := CodeLines + 'End Class' + #13#10 + #13#10; + + end; // Basic + end; + end; + tkString: + begin + case LangId of + PASCAL_LANGUAGE: + begin +{$IFDEF PAXARM} + Prog.RaiseError(errInternalError, []); +{$ELSE} + CodeLines := CodeLines + 'type ' + PTIName(@TypeInfoList[I].TypeInfo) + + ' = String[' + + IntToStr(TypeInfoList[I].TypeDataContainer.TypeData.MaxLength) + + '];'#13#10; +{$ENDIF} + end; + BASIC_LANGUAGE: + begin + Prog.RaiseError(errInternalError, []); + end; + end; + end; + tkInterface: + begin + InterfaceTypeDataContainer := + TypeInfoList[I].TypeDataContainer as TInterfaceTypeDataContainer; + + case LangId of + PASCAL_LANGUAGE: + begin + if TypeInfoList[I].IsGeneric then + begin + S := TypeInfoList[I].GenericTypeContainer.Definition; + CodeLines := CodeLines + ' type ' + S + #13#10; + continue; + end; + + CodeLines := CodeLines + 'type ' + PTIName(@TypeInfoList[I].TypeInfo) + + ' = interface(' + + ExtractName(InterfaceTypeDataContainer.FullParentName) + + ')' + #13#10; + CodeLines := CodeLines + + '[''' + + GuidToString(InterfaceTypeDataContainer.Guid) + + ''']' + + #13#10; + + for K := 0 to InterfaceTypeDataContainer.SubDescList.Count - 1 do + with InterfaceTypeDataContainer.SubDescList[K] do + begin + if ResTypeId = typeVOID then + CodeLines := CodeLines + 'procedure ' + else + CodeLines := CodeLines + 'function '; + + CodeLines := CodeLines + SubName + '('; + + if ParamList.Count = 0 then + CodeLines := CodeLines + ')' + else + for J := 0 to ParamList.Count - 1 do + begin + if ParamList[J].ParamMod = PM_BYREF then + CodeLines := CodeLines + 'var ' + else if ParamList[J].ParamMod = PM_CONST then + CodeLines := CodeLines + 'const '; + + CodeLines := CodeLines + ParamList[J].ParamName + ':' + + ParamList[J].ParamTypeName; + + if ParamList[J].OptValue <> '' then + CodeLines := CodeLines + '=' + ParamList[J].OptValue; + + if J < ParamList.Count - 1 then + CodeLines := CodeLines + ';' + else + CodeLines := CodeLines + ')'; + end; // for-loop + + if ResTypeId = typeVOID then + CodeLines := CodeLines + ';' + else + CodeLines := CodeLines + ':' + ResTypeName + ';'; + + if OverCount > 0 then + CodeLines := CodeLines + 'overload;'; + + case CallConv of + ccREGISTER: CodeLines := CodeLines + 'register;'; + ccSTDCALL: CodeLines := CodeLines + 'stdcall;'; + ccCDECL: CodeLines := CodeLines + 'cdecl;'; + ccPASCAL: CodeLines := CodeLines + 'pascal;'; + ccSAFECALL: CodeLines := CodeLines + 'safecall;'; + ccMSFASTCALL: CodeLines := CodeLines + 'msfastcall;'; + end; + + CodeLines := CodeLines + #13#10; + end; // for-looop SubDescList + + for J := 0 to InterfaceTypeDataContainer.PropDataContainer.Count - 1 do + with InterfaceTypeDataContainer do + begin + S1 := ExtractName(PropDataContainer.ReadNames[J]); + S2 := ExtractName(PropDataContainer.WriteNames[J]); + + CodeLines := CodeLines + 'property ' + + StringFromPShortString(@PropDataContainer.PropList[J].Name) + ':' + + PropDataContainer.PropTypeNames[J]; + if S1 <> '' then + CodeLines := CodeLines + ' read ' + S1; + if S2 <> '' then + CodeLines := CodeLines + ' write ' + S2; + CodeLines := CodeLines + ';'#13#10; + end; + + CodeLines := CodeLines + 'end;' + #13#10; + end; // pascal + BASIC_LANGUAGE: + begin + if TypeInfoList[I].IsGeneric then + begin + S := TypeInfoList[I].GenericTypeContainer.Definition; + CodeLines := CodeLines + S + #13#10; + continue; + end; + + CodeLines := CodeLines + 'Interface ' + PTIName(@TypeInfoList[I].TypeInfo) + + #13#10; + CodeLines := CodeLines + 'Inherits ' + + ExtractName(InterfaceTypeDataContainer.FullParentName) + + #13#10; + + for K := 0 to InterfaceTypeDataContainer.SubDescList.Count - 1 do + with InterfaceTypeDataContainer.SubDescList[K] do + begin + if ResTypeId = typeVOID then + CodeLines := CodeLines + 'Sub ' + else + CodeLines := CodeLines + 'Function '; + + CodeLines := CodeLines + SubName + '('; + + if ParamList.Count = 0 then + CodeLines := CodeLines + ')' + else + for J := 0 to ParamList.Count - 1 do + begin + if ParamList[J].ParamMod = PM_BYREF then + CodeLines := CodeLines + 'ByRef ' + else if ParamList[J].ParamMod = PM_CONST then + CodeLines := CodeLines + 'Const '; + + CodeLines := CodeLines + ParamList[J].ParamName + ' As ' + + ParamList[J].ParamTypeName; + + if ParamList[J].OptValue <> '' then + CodeLines := CodeLines + '=' + ParamList[J].OptValue; + + if J < ParamList.Count - 1 then + CodeLines := CodeLines + ',' + else + CodeLines := CodeLines + ')'; + end; // for-loop + + if ResTypeId <> typeVOID then + CodeLines := CodeLines + ' As ' + ResTypeName; + + CodeLines := CodeLines + #13#10; + end; // for-looop SubDescList + + CodeLines := CodeLines + 'End Interface' + #13#10; + end; + end; + end; // tkInterface + tkEnumeration: + begin + EnumTypeDataContainer := + TypeInfoList[I].TypeDataContainer as TEnumTypeDataContainer; + + case LangId of + PASCAL_LANGUAGE: + begin + CodeLines := CodeLines + 'type ' + PTIName(@TypeInfoList[I].TypeInfo) + + ' = ('; + K := System.Length(EnumTypeDataContainer.NameList); + for J := 0 to K - 1 do + begin + CodeLines := CodeLines + + StringFromPShortString(@EnumTypeDataContainer.NameList[J]) + '=' + + IntToStr(EnumTypeDataContainer.ValueList[J]); + + if J < K - 1 then + CodeLines := CodeLines + ',' + else + CodeLines := CodeLines + ');' + #13#10; + end; + end; + BASIC_LANGUAGE: + begin + CodeLines := CodeLines + 'Enum ' + PTIName(@TypeInfoList[I].TypeInfo) + + #13#10; + K := System.Length(EnumTypeDataContainer.NameList); + for J := 0 to K - 1 do + begin + CodeLines := CodeLines + + StringFromPShortString(@EnumTypeDataContainer.NameList[J]) + '=' + + IntToStr(EnumTypeDataContainer.ValueList[J]) + #13#10; + end; + CodeLines := CodeLines + 'End Enum' + #13#10; + end; + end; + end; //tkEnumeration + end; // case + end; // for-loop + + for I := 0 to MapTable.Count - 1 do + begin + MapRec := MapTable[I]; + if Pos(UpperCase(ExtractName(UnitName)), UpperCase(MapRec.FullName)) = 1 then + begin + S := ExtractName(MapRec.FullName); + if MapRec.Kind = KindSUB then + begin + SubDesc := MapRec.SubDesc; + if SubDesc.IsMethod then + continue; + + if S = '' then + continue; + + if SubDesc.ResTypeId = typeVOID then + S := 'procedure ' + S + '(' + else + S := 'function ' + S + '('; + + for J:=0 to SubDesc.ParamList.Count - 1 do + begin + case SubDesc.ParamList[J].ParamMod of + PM_BYVAL: begin end; + PM_BYREF: S := S + 'var '; + PM_CONST: S := S + 'const '; + end; + S := S + SubDesc.ParamList[J].ParamName; + S := S + ':'; + S := S + SubDesc.ParamList[J].ParamTypeName; + + if SubDesc.ParamList[J].OptValue <> '' then + S := S + '=' + SubDesc.ParamList[J].OptValue; + + if J < SubDesc.ParamList.Count - 1 then + S := S + ';'; + end; + + S := S + ')'; + if SubDesc.ResTypeId <> typeVOID then + S := S + ':' + SubDesc.ResTypeName; + S := S + ';'; + + if not Prog.PAX64 then + begin + case SubDesc.CallConv of + ccREGISTER: S := S + 'register'; + ccSTDCALL: S := S + 'stdcall'; + ccCDECL: S := S + 'cdecl'; + ccPASCAL: S := S + 'pascal'; + ccSAFECALL: S := S + 'safecall'; + ccMSFASTCALL: S := S + 'msfastcall'; + end; + S := S + ';'; + end; + + if SubDesc.OverCount > 0 then + S := S + 'overload;'; + + if (MapRec.SubDesc.DllName = '') and (MapRec.SubDesc.AliasName = '') then + S := S + 'external ' + '''' + FileName + '''' + ';' + else + S := S + ' external ' + '''' + MapRec.SubDesc.DllName + '''' + + ' name ' + '''' + MapRec.SubDesc.AliasName + '''' + + ';'; + + CodeLines := CodeLines + S + #13#10; + end // kindSUB + else if MapRec.Kind = KindVAR then + begin + S := 'var ' + S + ':' + + ExtractName(MapRec.FullTypeName) + + ';'; + S := S + 'external ' + '''' + FileName + '''' + ';'; + CodeLines := CodeLines + S + #13#10; + end // kindVAR + else if MapRec.Kind = KindCONST then + begin + S := 'const ' + S + ':' + + ExtractName(MapRec.FullTypeName) + + ';'; + S := S + 'external ' + '''' + FileName + '''' + ';'; + CodeLines := CodeLines + S + #13#10; + end; // kindCONST + CodeLines := CodeLines + #13#10; + end; + end; + + if Prog.CurrExpr <> '' then + AddScopeVars(Prog, CodeLines); + + case LangId of + PASCAL_LANGUAGE: + begin + CodeLines := CodeLines + + 'implementation' + #13#10; + + for I := 0 to TypeInfoList.Count - 1 do + begin + if Pos(UpperCase(ExtractName(UnitName)), UpperCase(String(TypeInfoList[I].FullName))) <> 1 then + continue; + if TypeInfoList[I].IsGeneric then + for J := 0 to TypeInfoList[I].GenericTypeContainer.MethodList.Count - 1 do + begin + S := TypeInfoList[I].GenericTypeContainer.MethodList[J]; + CodeLines := CodeLines + S + #13#10; + continue; + end; + end; + + if Prog.CurrExpr <> '' then + begin + CodeLines := CodeLines + + 'begin ' + #13#10; + CodeLines := CodeLines + + 'print ' + Prog.CurrExpr + ';' + #13#10; + end; + + CodeLines := CodeLines + + 'end.' + #13#10; + end; + BASIC_LANGUAGE: + CodeLines := CodeLines + + 'End Module' + #13#10; + end; + + if IsDump then + begin + L := TStringList.Create; + try + L.Text := CodeLines; + L.SaveToFile(DUMP_PATH + ExtractName(UnitName) + '.dmp'); + finally + FreeAndNil(L); + end; + end; + + result := CodeLines; +end; + +procedure AddScopeVars(Prog: TBaseRunner; var CodeLines: String); +var + MR, MRT: TMapRec; + I: Integer; + S: String; + MapTable: TMapTable; +begin + MR := Prog.GetCurrentSub; + if MR <> nil then + begin + for I := 0 to MR.SubDesc.ParamList.Count - 1 do + with MR.SubDesc.ParamList[I] do + begin + if ParamMod = PM_BYREF then + S := PRR_FILE_EXT + else + S := PRM_FILE_EXT; + + CodeLines := CodeLines + + 'var ' + ParamName + ':' + ParamTypeName + '; external ' + + '''' + MR.FullName + '.' + S + '''' + ';' + + #13#10; + end; + for I := 0 to MR.SubDesc.LocalVarList.Count - 1 do + with MR.SubDesc.LocalVarList[I] do + begin + if IsByRef then + S := LOR_FILE_EXT + else + S := LOC_FILE_EXT; + + CodeLines := CodeLines + + 'var ' + LocalVarName + ':' + LocalVarTypeName + '; external ' + + '''' + MR.FullName + '.' + S + '''' + ';' + + #13#10; + end; + + if MR.SubDesc.IsMethod then + begin + if MR.SubDesc.ParamList.IndexOf('Self') = -1 then + if MR.SubDesc.LocalVarList.IndexOf('Self') = -1 then + begin + S := ExtractClassName(MR.FullName); + CodeLines := CodeLines + + 'var Self: ' + S + '; external ' + + '''' + MR.FullName + '.' + SLF_FILE_EXT + '''' + ';' + + #13#10; + end; + S := ExtractFullOwner(MR.FullName); + MapTable := Prog.ScriptMapTable; + MRT := MapTable.LookupType(S); + if MRT <> nil then + begin + for I := 0 to MRT.FieldList.Count - 1 do + begin + CodeLines := CodeLines + + 'var ' + MRT.FieldList[I].FieldName + ':' + + MRT.FieldList[I].FieldTypeName + + '; external ' + + '''' + MR.FullName + '.' + + FLD_FILE_EXT + '''' + ';' + + #13#10; + end; + end; + end; + end; +end; + +function PCUToMainScript(Prg: Pointer; const Expression: String): String; +var + Prog: TBaseRunner; + UnitName: String; +begin + Prog := TBaseRunner(Prg); + Prog.CurrExpr := Expression; + try + UnitName := Prog.GetModuleName; + result := PCUToString(Prg, UnitName); + finally + Prog.CurrExpr := ''; + end; +end; + +function PCUToScript(Prg: Pointer; Expression: String): TStringList; +var + Prog: TBaseRunner; + UnitName: String; + I: Integer; + S: String; +begin + Prog := TBaseRunner(Prg); + UnitName := Prog.GetModuleName; + + S := PCUToMainScript(Prg, Expression); + + result := TStringList.Create; + result.Add(S); + + for I := 0 to Prog.ProgList.Count - 1 do + begin + S := PCUToString(Prog.ProgList[I].Prog, + ExtractName(Prog.ProgList[I].FullPath)); + result.Add(S); + end; + + if not IsDump then + Exit; +end; + +end. + + diff --git a/Sources/PAXCOMP_PE.pas b/Sources/PAXCOMP_PE.pas new file mode 100644 index 0000000..dd5da2d --- /dev/null +++ b/Sources/PAXCOMP_PE.pas @@ -0,0 +1,1335 @@ +//////////////////////////////////////////////////////////////////////////// +// PaxCompiler +// Site: http://www.paxcompiler.com +// Author: Alexander Baranovsky (paxscript@gmail.com) +// ======================================================================== +// Copyright (c) Alexander Baranovsky, 2006-2014. All rights reserved. +// Code Version: 4.2 +// ======================================================================== +// Unit: PAXCOMP_PE.pas +// ======================================================================== +//////////////////////////////////////////////////////////////////////////// +{$I PaxCompiler.def} +unit PAXCOMP_PE; +interface +uses {$I uses.def} + PAXCOMP_TYPES, + PAXCOMP_SYS, + SysUtils, + Classes, + PAXCOMP_CONSTANTS, + PAXCOMP_SYMBOL_PROGRAM, + PAXCOMP_MAP, + PAXCOMP_PROG, + PaxRunner; +type + TDosHeader = array[1..128] of Byte; + TSecName = packed array[0..7] of AnsiChar; +const + + FileAlignment = $200; + SectionAlignment = $1000; + AddressOfEntryPoint = SectionAlignment; + BaseOfCode = AddressOfEntryPoint; + ImageBase = $400000; + + DllJumpsOffset = 55; + DllJumpStep = 7; +// DllInitSize = 76; + DllInitSize = 2048; + + NAME_CODE_SEC: TSecName = ('.', 'c', 'o', 'd', 'e', #0, #0, #0); + NAME_IDATA_SEC: TSecName = ('.', 'i', 'd', 'a', 't', 'a', #0, #0); + NAME_DATA_SEC: TSecName = ('.', 'd', 'a', 't', 'a', #0, #0, #0); + NAME_EDATA_SEC: TSecName = ('.', 'e', 'd', 'a', 't', 'a', #0, #0); + NAME_RELOC_SEC: TSecName = ('.', 'r', 'e', 'l', 'o', 'c', #0, #0); + + msdos_header: TDosHeader = ( + $4D, $5A, $90, $00, $03, $00, $00, $00, //0 + $04, $00, $00, $00, $FF, $FF, $00, $00, //1 + $B8, $00, $00, $00, $00, $00, $00, $00, //2 + $40, $00, $00, $00, $00, $00, $00, $00, //3 + $00, $00, $00, $00, $00, $00, $00, $00, //4 + $00, $00, $00, $00, $00, $00, $00, $00, //5 + $00, $00, $00, $00, $00, $00, $00, $00, //6 + $00, $00, $00, $00, $80, $00, $00, $00, //7 + $0E, $1F, $BA, $0E, $00, $B4, $09, $CD, //8 + $21, $B8, $01, $4C, $CD, $21, $54, $68, //9 + $69, $73, $20, $70, $72, $6F, $67, $72, //10 + $61, $6D, $20, $63, $61, $6E, $6E, $6F, //11 + $74, $20, $62, $65, $20, $72, $75, $6E, //12 + $20, $69, $6E, $20, $44, $4F, $53, $20, //13 + $6D, $6F, $64, $65, $2E, $0D, $0D, $0A, //14 + $24, $00, $00, $00, $00, $00, $00, $00);//15 + + IMAGE_FILE_RELOCS_STRIPPED = $0001; + {$EXTERNALSYM IMAGE_FILE_RELOCS_STRIPPED} { Relocation info stripped from file. } + IMAGE_FILE_EXECUTABLE_IMAGE = $0002; + {$EXTERNALSYM IMAGE_FILE_EXECUTABLE_IMAGE} { File is executable (i.e. no unresolved externel references). } + IMAGE_FILE_LINE_NUMS_STRIPPED = $0004; + {$EXTERNALSYM IMAGE_FILE_LINE_NUMS_STRIPPED} { Line nunbers stripped from file. } + IMAGE_FILE_LOCAL_SYMS_STRIPPED = $0008; + {$EXTERNALSYM IMAGE_FILE_LOCAL_SYMS_STRIPPED} { Local symbols stripped from file. } + IMAGE_FILE_AGGRESIVE_WS_TRIM = $0010; + {$EXTERNALSYM IMAGE_FILE_AGGRESIVE_WS_TRIM} { Agressively trim working set } + IMAGE_FILE_LARGE_ADDRESS_AWARE = $0020; + {$EXTERNALSYM IMAGE_FILE_LARGE_ADDRESS_AWARE} { App can handle >2gb addresses } + IMAGE_FILE_BYTES_REVERSED_LO = $0080; + {$EXTERNALSYM IMAGE_FILE_BYTES_REVERSED_LO| { Bytes of machine word are reversed. } + IMAGE_FILE_32BIT_MACHINE = $0100; + {$EXTERNALSYM IMAGE_FILE_32BIT_MACHINE} { 32 bit word machine. } + IMAGE_FILE_DEBUG_STRIPPED = $0200; + {$EXTERNALSYM IMAGE_FILE_DEBUG_STRIPPED} { Debugging info stripped from file in .DBG file } + IMAGE_FILE_REMOVABLE_RUN_FROM_SWAP = $0400; + {$EXTERNALSYM IMAGE_FILE_REMOVABLE_RUN_FROM_SWAP} { If Image is on removable media, copy and run from the swap file. } + IMAGE_FILE_NET_RUN_FROM_SWAP = $0800; + {$EXTERNALSYM IMAGE_FILE_NET_RUN_FROM_SWAP| { If Image is on Net, copy and run from the swap file. } + IMAGE_FILE_SYSTEM = $1000; + {$EXTERNALSYM IMAGE_FILE_SYSTEM} { System File. } + IMAGE_FILE_DLL = $2000; + {$EXTERNALSYM IMAGE_FILE_DLL} { File is a DLL. } + IMAGE_FILE_UP_SYSTEM_ONLY = $4000; + {$EXTERNALSYM IMAGE_FILE_UP_SYSTEM_ONLY} { File should only be run on a UP machine } + IMAGE_FILE_BYTES_REVERSED_HI = $8000; + {$EXTERNALSYM IMAGE_FILE_BYTES_REVERSED_HI} { Bytes of machine word are reversed. } + IMAGE_FILE_MACHINE_UNKNOWN = 0; + {$EXTERNALSYM IMAGE_FILE_MACHINE_UNKNOWN} + IMAGE_FILE_MACHINE_I386 = $14c; + {$EXTERNALSYM IMAGE_FILE_MACHINE_I386} { Intel 386. } + IMAGE_FILE_MACHINE_R3000 = $162; + {$EXTERNALSYM IMAGE_FILE_MACHINE_R3000} { MIPS little-endian, 0x160 big-endian } + IMAGE_FILE_MACHINE_R4000 = $166; + {$EXTERNALSYM IMAGE_FILE_MACHINE_R4000} { MIPS little-endian } + IMAGE_FILE_MACHINE_R10000 = $168; + {$EXTERNALSYM IMAGE_FILE_MACHINE_R10000} { MIPS little-endian } + IMAGE_FILE_MACHINE_ALPHA = $184; + {$EXTERNALSYM IMAGE_FILE_MACHINE_ALPHA} { Alpha_AXP } + IMAGE_FILE_MACHINE_POWERPC = $1F0; + {$EXTERNALSYM IMAGE_FILE_MACHINE_POWERPC} { IBM PowerPC Little-Endian } + + + IMAGE_DOS_SIGNATURE = $5A4D; + {$EXTERNALSYM IMAGE_DOS_SIGNATURE} { MZ } + IMAGE_NT_SIGNATURE = $00004550; + {$EXTERNALSYM IMAGE_NT_SIGNATURE} { PE00 } + IMAGE_NUMBEROF_DIRECTORY_ENTRIES = 16; + {$EXTERNALSYM IMAGE_NUMBEROF_DIRECTORY_ENTRIES} + +{ Directory Entries } + + IMAGE_DIRECTORY_ENTRY_EXPORT = 0; { Export Directory } + {$EXTERNALSYM IMAGE_DIRECTORY_ENTRY_EXPORT} + IMAGE_DIRECTORY_ENTRY_IMPORT = 1; { Import Directory } + {$EXTERNALSYM IMAGE_DIRECTORY_ENTRY_IMPORT} + IMAGE_DIRECTORY_ENTRY_RESOURCE = 2; { Resource Directory } + {$EXTERNALSYM IMAGE_DIRECTORY_ENTRY_RESOURCE} + IMAGE_DIRECTORY_ENTRY_EXCEPTION = 3; { Exception Directory } + {$EXTERNALSYM IMAGE_DIRECTORY_ENTRY_EXCEPTION} + IMAGE_DIRECTORY_ENTRY_SECURITY = 4; { Security Directory } + {$EXTERNALSYM IMAGE_DIRECTORY_ENTRY_SECURITY} + IMAGE_DIRECTORY_ENTRY_BASERELOC = 5; { Base Relocation Table } + {$EXTERNALSYM IMAGE_DIRECTORY_ENTRY_BASERELOC} + IMAGE_DIRECTORY_ENTRY_DEBUG = 6; { Debug Directory } + {$EXTERNALSYM IMAGE_DIRECTORY_ENTRY_DEBUG} + IMAGE_DIRECTORY_ENTRY_COPYRIGHT = 7; { Description String } + {$EXTERNALSYM IMAGE_DIRECTORY_ENTRY_COPYRIGHT} + IMAGE_DIRECTORY_ENTRY_GLOBALPTR = 8; { Machine Value (MIPS GP) } + {$EXTERNALSYM IMAGE_DIRECTORY_ENTRY_GLOBALPTR} + IMAGE_DIRECTORY_ENTRY_TLS = 9; { TLS Directory } + {$EXTERNALSYM IMAGE_DIRECTORY_ENTRY_TLS} + IMAGE_DIRECTORY_ENTRY_LOAD_CONFIG = 10; { Load Configuration Directory } + {$EXTERNALSYM IMAGE_DIRECTORY_ENTRY_LOAD_CONFIG} + IMAGE_DIRECTORY_ENTRY_BOUND_IMPORT = 11; { Bound Import Directory in headers } + {$EXTERNALSYM IMAGE_DIRECTORY_ENTRY_BOUND_IMPORT} + IMAGE_DIRECTORY_ENTRY_IAT = 12; { Import Address Table } + {$EXTERNALSYM IMAGE_DIRECTORY_ENTRY_IAT} + IMAGE_DIRECTORY_ENTRY_DELAY_IMPORT = 13; { Delay Load Import Descriptors } + {$EXTERNALSYM IMAGE_DIRECTORY_ENTRY_DELAY_IMPORT} + IMAGE_DIRECTORY_ENTRY_COM_DESCRIPTOR = 14; { COM Runtime descriptor } + {$EXTERNALSYM IMAGE_DIRECTORY_ENTRY_COM_DESCRIPTOR} + +{ Section header format. } +{ + IMAGE_SIZEOF_SHORT_NAME = 8; + + DLL_PROCESS_ATTACH = 1; + DLL_THREAD_ATTACH = 2; + DLL_THREAD_DETACH = 3; + DLL_PROCESS_DETACH = 0; +} + +type + TIMAGE_DATA_DIRECTORY = record + VirtualAddress: Cardinal; + Size: Cardinal; + end; + + TIMAGE_DOS_HEADER = packed record { DOS .EXE header } + e_magic: Word; { Magic number } + e_cblp: Word; { Bytes on last page of file } + e_cp: Word; { Pages in file } + e_crlc: Word; { Relocations } + e_cparhdr: Word; { Size of header in paragraphs } + e_minalloc: Word; { Minimum extra paragraphs needed } + e_maxalloc: Word; { Maximum extra paragraphs needed } + e_ss: Word; { Initial (relative) SS value } + e_sp: Word; { Initial SP value } + e_csum: Word; { Checksum } + e_ip: Word; { Initial IP value } + e_cs: Word; { Initial (relative) CS value } + e_lfarlc: Word; { File address of relocation table } + e_ovno: Word; { Overlay number } + e_res: array [0..3] of Word; { Reserved words } + e_oemid: Word; { OEM identifier (for e_oeminfo) } + e_oeminfo: Word; { OEM information; e_oemid specific} + e_res2: array [0..9] of Word; { Reserved words } + _lfanew: LongInt; { File address of new exe header } + end; // size of = 64 (dec) + + TIMAGE_FILE_HEADER = packed record + Machine: Word; + NumberOfSections: Word; + TimeDateStamp: Cardinal; + PointerToSymbolTable: Cardinal; + NumberOfSymbols: Cardinal; + SizeOfOptionalHeader: Word; + Characteristics: Word; + end; // size of = 20 + + TIMAGE_OPTIONAL_HEADER = packed record + { Standard fields. } + Magic: Word; + MajorLinkerVersion: Byte; + MinorLinkerVersion: Byte; + SizeOfCode: Cardinal; + SizeOfInitializedData: Cardinal; + SizeOfUninitializedData: Cardinal; + AddressOfEntryPoint: Cardinal; + BaseOfCode: Cardinal; + BaseOfData: Cardinal; + { NT additional fields. } + ImageBase: Cardinal; + SectionAlignment: Cardinal; + FileAlignment: Cardinal; + MajorOperatingSystemVersion: Word; + MinorOperatingSystemVersion: Word; + MajorImageVersion: Word; + MinorImageVersion: Word; + MajorSubsystemVersion: Word; + MinorSubsystemVersion: Word; + Win32VersionValue: Cardinal; + SizeOfImage: Cardinal; + SizeOfHeaders: Cardinal; + CheckSum: Cardinal; + Subsystem: Word; + DllCharacteristics: Word; + SizeOfStackReserve: Cardinal; + SizeOfStackCommit: Cardinal; + SizeOfHeapReserve: Cardinal; + SizeOfHeapCommit: Cardinal; + LoaderFlags: Cardinal; + NumberOfRvaAndSizes: Cardinal; + DataDirectory: packed array[0..IMAGE_NUMBEROF_DIRECTORY_ENTRIES-1] of TIMAGE_DATA_DIRECTORY; + end; // size of = 224 + + TIMAGE_NT_HEADER = packed record + Signature: Cardinal; + FileHeader: TIMAGE_FILE_HEADER; + OptionalHeader: TIMAGE_OPTIONAL_HEADER; + end; // size of 248 + + TISHMisc = packed record + case Integer of + 0: (PhysicalAddress: Cardinal); + 1: (VirtualSize: Cardinal); + end; // size of = 4 + + PIMAGE_SECTION_HEADER = ^TIMAGE_SECTION_HEADER; + TIMAGE_SECTION_HEADER = packed record + Name: TSecName; + Misc: TISHMisc; + VirtualAddress: Cardinal; + SizeOfRawData: Cardinal; + PointerToRawData: Cardinal; + PointerToRelocations: Cardinal; + PointerToLinenumbers: Cardinal; + NumberOfRelocations: Word; + NumberOfLinenumbers: Word; + Characteristics: Cardinal; + end; // size of = 40 + + TIMAGE_SECTION_HEADER_ARR = array[0..50] of TIMAGE_SECTION_HEADER; + + PIMAGE_IMPORT_DESCRIPTOR = ^TIMAGE_IMPORT_DESCRIPTOR; + TIMAGE_IMPORT_DESCRIPTOR = packed record + OriginalFirstThunk: Cardinal; + TimeDateStamp: Cardinal; + ForwarderChain: Cardinal; + Name: Cardinal; + FirstThunk: Cardinal; + end; + + TImportProc = class + public + ProcName: AnsiString; + RVA: Cardinal; + end; + + TImportDll = class + private + L: TList; + function GetRecord(I: Integer): TImportProc; + function GetCount: Integer; + public + DllName: AnsiString; + RVA: Cardinal; + constructor Create; + destructor Destroy; override; + procedure Clear; + function Add: TImportProc; + property Count: Integer read GetCount; + property Records[I: Integer]: TImportProc read GetRecord; default; + end; + + TImportDllList = class + private + L: TList; + function GetRecord(I: Integer): TImportDll; + function GetCount: Integer; + function GetProcCount: Integer; + public + constructor Create; + destructor Destroy; override; + procedure Clear; + function Add: TImportDll; + function FindDll(const DllName: String): TImportDll; + property Count: Integer read GetCount; + property ProcCount: Integer read GetProcCount; + property Records[I: Integer]: TImportDll read GetRecord; default; + end; + + TImportTable = class + public + ImportDllList: TImportDllList; + + IAT_RVA1, IAT_RVA2: Cardinal; + IAT_SIZE: Cardinal; + IMAGE_IMPORT_DESCRIPTOR_RVA: Cardinal; + IMAGE_IMPORT_DESCRIPTOR_SIZE: Cardinal; + RVA_STRINGS: Cardinal; + IAT: array of Cardinal; + IMAGE_IMPORT_DESCRIPTOR_ARR: array of TIMAGE_IMPORT_DESCRIPTOR; + + constructor Create; + destructor Destroy; override; + function AddDll(const DllName: String): TImportDll; + procedure AddProc(const DllName, ProcName: String); + procedure Calc(IAT_RVA: Integer); + procedure SaveToStream(F: TStream); + function GetImageSize: Integer; + end; + + TIMAGE_EXPORT_DIRECTORY = packed record + Characteristics: Cardinal; // = 0 + TimeDateStamp: Cardinal; // = 0 + MajorVersion: Word; // = 0 + MinorVersion: Word; // = 0 + Name: Cardinal; + Base: Cardinal; // 1 + NumberOfFunctions: Cardinal; + NumberOfNames: Cardinal; // + AddressOfFunctions: Cardinal; // address table RVA + AddressOfNames: Cardinal; // name pointers RVA + AddressOfNameOrdinals: Cardinal; // name table RVA + end; + + TExportTable = class + public + ModuleName: String; + IMAGE_EXPORT_DIRECTORY: TIMAGE_EXPORT_DIRECTORY; + ExportList: TExportList; + constructor Create(AExportList: TExportList; const AModuleName: String); + procedure Calc(INIT_RVA, CODE_RVA: Integer); + procedure SaveToStream(F: TStream); + function GetImageSize: Integer; + end; + + TPE = (peEXE, peDLL); + + TFixUpBlock = class + private + function GetBlockSize: Cardinal; + public + PageRVA: Cardinal; + TypeOffsets: TIntegerList; + constructor Create; + destructor Destroy; override; + procedure AddOffset(value: Word); + procedure Adjust; + procedure SaveToStream(S: TStream); + property BlockSize: Cardinal read GetBlockSize; + end; + + TFixUpBlockList = class(TTypedList) + private + function GetBlock(I: Integer): TFixUpBlock; + function GetSize: Cardinal; + public + function AddBlock(PageRVA: Cardinal): TFixUpBlock; + procedure Adjust; + procedure SaveToStream(S: TStream); + property Size: Cardinal read GetSize; + property Blocks[I: Integer]: TFixUpBlock read GetBlock; default; + end; + +procedure CreatePE(const FileName: String; + const ImportDllName: String; + const ProcName: String; + PaxProgram: TPaxRunner; + What: TPE); +const + MAX_STRING = $20; +function IsPEFile(const FileName: String): Boolean; +function GetRawOffset(vsm: Cardinal; // virtual address + P: PIMAGE_SECTION_HEADER; // P is pointer to first section + N: Cardinal // NumberOfSections + ): Cardinal; + +function GePaxRunner(DllInstance: Cardinal): TPaxRunner; + +implementation + +function GePaxRunner(DllInstance: Cardinal): TPaxRunner; +var + P: Pointer; +begin + P := Pointer(DllInstance + BaseOfCode + DllInitSize); + result := Pointer(P^); +end; + +function Align(L, Size: Integer): Integer; +begin + if L <= Size then + result := Size + else + begin + if L mod Size = 0 then + result := (L div Size) * Size + else + result := (L div Size + 1) * Size; + end; +end; + +constructor TFixUpBlock.Create; +begin + inherited; + TypeOffsets := TIntegerList.Create; +end; + +destructor TFixUpBlock.Destroy; +begin + inherited; + FreeAndNil(TypeOffsets); +end; + +function TFixUpBlock.GetBlockSize: Cardinal; +begin + result := TypeOffsets.Count * SizeOf(Word) + SizeOf(Cardinal) * 2; +end; + +procedure TFixUpBlock.AddOffset(value: Word); +var + W: Word; +begin + W := value or $3000; + TypeOffsets.Add(W); +end; + +procedure TFixUpBlock.Adjust; +begin + if TypeOffsets.Count mod 2 = 0 then + Exit; + TypeOffsets.Add(0); +end; + +procedure TFixUpBlock.SaveToStream(S: TStream); +var + I: Integer; + K: Cardinal; + W: Word; +begin + K := BlockSize; + S.Write(PageRVA, SizeOf(Cardinal)); + S.Write(K, SizeOf(Cardinal)); + for I := 0 to TypeOffsets.Count - 1 do + begin + W := TypeOffsets[I]; + S.Write(W, SizeOf(Word)); + end; +end; + +function TFixUpBlockList.GetBlock(I: Integer): TFixUpBlock; +begin + result := TFixUpBlock(L[I]); +end; + +function TFixUpBlockList.GetSize: Cardinal; +var + I: Integer; +begin + result := 0; + for I := 0 to Count - 1 do + Inc(result, Blocks[I].BlockSize); +end; + +function TFixUpBlockList.AddBlock(PageRVA: Cardinal): TFixUpBlock; +begin + result := TFixUpBlock.Create; + result.PageRVA := PageRVA; + L.Add(result); +end; + +procedure TFixUpBlockList.Adjust; +var + I: Integer; +begin + for I := 0 to Count - 1 do + Blocks[I].Adjust; +end; + +procedure TFixUpBlockList.SaveToStream(S: TStream); +var + I: Integer; +begin + for I := 0 to Count - 1 do + Blocks[I].SaveToStream(S); +end; + +constructor TExportTable.Create(AExportList: TExportList; const AModuleName: String); +begin + inherited Create; + ModuleName := AModuleName; + FillChar(IMAGE_EXPORT_DIRECTORY, SizeOf(IMAGE_EXPORT_DIRECTORY), 0); + ExportList := AExportList; +end; + +procedure TExportTable.Calc(INIT_RVA, CODE_RVA: Integer); +var + I, K: Integer; +begin + if ExportList.Count = 0 then + Exit; + + K := ExportList.Count; + + FillChar(IMAGE_EXPORT_DIRECTORY, SizeOf(IMAGE_EXPORT_DIRECTORY), 0); + + IMAGE_EXPORT_DIRECTORY.Name := INIT_RVA + + SizeOf(IMAGE_EXPORT_DIRECTORY) + + SizeOf(Cardinal) * K + + SizeOf(Cardinal) * K + + SizeOf(Word) * K; + IMAGE_EXPORT_DIRECTORY.Base := 1; + IMAGE_EXPORT_DIRECTORY.NumberOfFunctions := K; + IMAGE_EXPORT_DIRECTORY.NumberOfNames := K; + + IMAGE_EXPORT_DIRECTORY.AddressOfFunctions := INIT_RVA + + SizeOf(IMAGE_EXPORT_DIRECTORY); + IMAGE_EXPORT_DIRECTORY.AddressOfNames := INIT_RVA + + SizeOf(IMAGE_EXPORT_DIRECTORY) + + SizeOf(Cardinal) * K; + IMAGE_EXPORT_DIRECTORY.AddressOfNameOrdinals := INIT_RVA + + SizeOf(IMAGE_EXPORT_DIRECTORY) + + SizeOf(Cardinal) * K + + SizeOf(Cardinal) * K; + + for I := 0 to K - 1 do + begin + ExportList[I].Address := CODE_RVA + + DllJumpStep * I; + ExportList[I].NameAddress := + Integer(IMAGE_EXPORT_DIRECTORY.Name) + + MAX_STRING + + MAX_STRING * I; + end; +end; + +procedure TExportTable.SaveToStream(F: TStream); +var + I, K: Integer; + STR_BUFF: array[1..MAX_STRING] of AnsiChar; + S: AnsiString; +begin + if ExportList.Count = 0 then + Exit; + + K := ExportList.Count; + + F.Write(IMAGE_EXPORT_DIRECTORY, SizeOf(IMAGE_EXPORT_DIRECTORY)); + + // save address table rva-s + for I := 0 to K - 1 do + F.Write(ExportList[I].Address, SizeOf(Cardinal)); + + // save name table rva-s + for I := 0 to K - 1 do + F.Write(ExportList[I].NameAddress, SizeOf(Cardinal)); + + // save table of ordinal value + for I := 0 to K - 1 do + F.Write(ExportList[I].Ordinal, SizeOf(Word)); + + FillChar(STR_BUFF, MAX_STRING, 0); + S := AnsiString(ModuleName); + Move(S[1], STR_BUFF[1], Length(S)); + F.Write(STR_BUFF, MAX_STRING); + + for I := 0 to K - 1 do + begin + FillChar(STR_BUFF, MAX_STRING, 0); + S := AnsiString(ExportList[I].Name); + Move(S[1], STR_BUFF[1], Length(S)); + F.Write(STR_BUFF, MAX_STRING); + end; +end; + +function TExportTable.GetImageSize: Integer; +var + K: Integer; +begin + result := 0; + if ExportList.Count = 0 then + Exit; + + K := ExportList.Count; + result := SizeOf(IMAGE_EXPORT_DIRECTORY) + + SizeOf(Cardinal) * K + + SizeOf(Cardinal) * K + + SizeOf(Word) * K + + MAX_STRING + + MAX_STRING * K; +end; + +constructor TImportDll.Create; +begin + inherited; + L := TList.Create; +end; + +destructor TImportDll.Destroy; +begin + Clear; + FreeAndNil(L); + inherited; +end; + +function TImportDll.Add: TImportProc; +begin + result := TImportProc.Create; + L.Add(result); +end; + +function TImportDll.GetRecord(I: Integer): TImportProc; +begin + result := TImportProc(L[I]); +end; + +function TImportDll.GetCount: Integer; +begin + result := L.Count; +end; + +procedure TImportDll.Clear; +var + I: Integer; +begin + for I:=0 to Count - 1 do + Records[I].Free; + L.Clear; +end; + +constructor TImportDllList.Create; +begin + L := TList.Create; +end; + +destructor TImportDllList.Destroy; +begin + Clear; + FreeAndNil(L); +end; + +function TImportDllList.Add: TImportDll; +begin + result := TImportDll.Create; + L.Add(result); +end; + +procedure TImportDllList.Clear; +var + I: Integer; +begin + for I:=0 to Count - 1 do + Records[I].Free; + L.Clear; +end; + +function TImportDllList.GetRecord(I: Integer): TImportDll; +begin + result := TImportDll(L[I]); +end; + +function TImportDllList.FindDll(const DllName: String): TImportDll; +var + I: Integer; +begin + result := nil; + for I:=0 to Count - 1 do + if StrEql(String(Records[I].DllName), DllName) then + begin + result := Records[I]; + Exit; + end; +end; + +function TImportDllList.GetCount: Integer; +begin + result := L.Count; +end; + +function TImportDllList.GetProcCount: Integer; +var + I: Integer; +begin + result := 0; + for I:=0 to Count - 1 do + Inc(result, Records[I].Count); +end; + +constructor TImportTable.Create; +begin + inherited; + ImportDllList := TImportDllList.Create; +end; + +destructor TImportTable.Destroy; +begin + FreeAndNil(ImportDllList); + inherited; +end; + +function TImportTable.AddDll(const DllName: String): TImportDll; +begin + result := ImportDllList.FindDll(DllName); + if result = nil then + begin + result := ImportDllList.Add; + result.DllName := AnsiString(DllName); + end; +end; + +procedure TImportTable.AddProc(const DllName, ProcName: String); +var + Dll: TImportDll; + Proc: TImportProc; +begin + Dll := ImportDllList.FindDll(DllName); + if Dll = nil then + Dll := AddDll(DllName); + Proc := Dll.Add; + Proc.ProcName := AnsiString(ProcName); +end; + +procedure TImportTable.Calc(IAT_RVA: Integer); +var + I, J, ProcCount, RVA_STR: Cardinal; + K: Integer; +begin + // first IAT + // second IAT + // IMAGE_IMPORT_DESCRIPTOR_ARR + // strings + + IAT_RVA1 := IAT_RVA; + SetLength(IAT, ImportDllList.ProcCount + ImportDllList.Count); + SetLength(IMAGE_IMPORT_DESCRIPTOR_ARR, ImportDllList.Count + 1); + + K := -1; + + IAT_SIZE := Length(IAT) * SizeOf(Cardinal); + IAT_RVA2 := IAT_RVA1 + IAT_SIZE; + IMAGE_IMPORT_DESCRIPTOR_RVA := IAT_RVA2 + IAT_SIZE; + IMAGE_IMPORT_DESCRIPTOR_SIZE := SizeOf(TIMAGE_IMPORT_DESCRIPTOR) * (ImportDllList.Count + 1); + RVA_STRINGS := IMAGE_IMPORT_DESCRIPTOR_RVA + IMAGE_IMPORT_DESCRIPTOR_SIZE; + + RVA_STR := RVA_STRINGS; + + for I := 0 to ImportDllList.Count - 1 do + begin + ProcCount := ImportDllList[I].Count; + + ImportDllList[I].RVA := RVA_STR; // rva of dll name + + IMAGE_IMPORT_DESCRIPTOR_ARR[I].Name := RVA_STR; + IMAGE_IMPORT_DESCRIPTOR_ARR[I].TimeDateStamp := 0; + IMAGE_IMPORT_DESCRIPTOR_ARR[I].ForwarderChain := 0; + IMAGE_IMPORT_DESCRIPTOR_ARR[I].FirstThunk := + IAT_RVA1 + I * (ProcCount + 1) * SizeOf(Cardinal); + + IMAGE_IMPORT_DESCRIPTOR_ARR[I].OriginalFirstThunk := + IAT_RVA2 + I * (ProcCount + 1) * SizeOf(Cardinal); + + Inc(RVA_STR, MAX_STRING); // max AnsiString length is 32 + for J := 0 to ProcCount - 1 do + begin + ImportDllList[I][J].RVA := RVA_STR; + Inc(K); + IAT[K] := RVA_STR; + + Inc(RVA_STR, MAX_STRING); + end; + + Inc(K); + IAT[K] := 0; + end; +end; + +procedure TImportTable.SaveToStream(F: TStream); +var + I, J: Cardinal; + STR_BUFF: array[1..32] of AnsiChar; +begin + for I:= 0 to Length(IAT) - 1 do + F.Write(IAT[I], SizeOf(Cardinal)); + + for I:= 0 to Length(IAT) - 1 do + F.Write(IAT[I], SizeOf(Cardinal)); + + for I := 0 to ImportDllList.Count do + F.Write(IMAGE_IMPORT_DESCRIPTOR_ARR[I], SizeOf(TIMAGE_IMPORT_DESCRIPTOR)); + + for I := 0 to ImportDllList.Count - 1 do + begin + FillChar(STR_BUFF, SizeOf(STR_BUFF), 0); + Move(ImportDllList[I].DllName[1], STR_BUFF[1], Length(ImportDllList[I].DllName)); + F.Write(STR_BUFF, SizeOf(STR_BUFF)); + + for J := 0 to ImportDllList[I].Count - 1 do + begin + FillChar(STR_BUFF, SizeOf(STR_BUFF), 0); + Move(ImportDllList[I][J].ProcName[1], STR_BUFF[3], Length(ImportDllList[I][J].ProcName)); + F.Write(STR_BUFF, SizeOf(STR_BUFF)); + end; + end; +end; + +function TImportTable.GetImageSize: Integer; +var + S: TMemoryStream; +begin + S := TMemoryStream.Create; + try + SaveToStream(S); + result := S.Size; + finally + FreeAndNil(S); + end; +end; + +function _Floor(X: Extended): Int64; +begin + result := Trunc(X); + if Frac(X) < 0 then + Dec(result); +end; + +function DelphiDateTimeToEcmaTime(const AValue: TDateTime): Int64; +var + T: TTimeStamp; + D1970: TDateTime; +begin + D1970 := EncodeDate(1970,1,1); + + T := DateTimeToTimeStamp(AValue); + Result := (_Floor(AValue) - _Floor(D1970)) * MSecsPerDay + T.Time; +end; + +function FileDate: Integer; +begin + result := DelphiDateTimeToEcmaTime(Now); +end; + + +function GetRawOffset(vsm: Cardinal; // virtual address + P: PIMAGE_SECTION_HEADER; // P is pointer to first section + N: Cardinal // NumberOfSections + ): Cardinal; +var + I: Integer; + PrevP: PIMAGE_SECTION_HEADER; +begin + if vsm < P^.VirtualAddress then + begin + result := 0; + Exit; + end; + + PrevP := P; + Inc(P); + + for I:=1 to N - 1 do + begin + if vsm < P.VirtualAddress then + begin + result := vsm - PrevP.VirtualAddress + PrevP.PointerToRawData; + + Exit; + end; + + PrevP := P; + Inc(P); + end; + + result := vsm - PrevP.VirtualAddress + PrevP.PointerToRawData; +end; + +function IsPEFile(const FileName: String): Boolean; +var + F: TFileStream; + DOS: TIMAGE_DOS_HEADER; + NT: TIMAGE_NT_HEADER; +begin + if not FileExists(FileName) then + begin + result := false; + Exit; + end; + + F := TFileStream.Create(FileName, fmOpenRead); + try + F.Read(DOS, SizeOf(TIMAGE_DOS_HEADER)); + + if DOS.e_magic <> IMAGE_DOS_SIGNATURE then + begin + result := false; + Exit; + end; + + if F.Size < DOS._lfanew + SizeOf(TIMAGE_NT_HEADER) then + begin + result := false; + Exit; + end; + + F.Position := DOS._lfanew; + F.Read(NT, SizeOf(TIMAGE_NT_HEADER)); + if NT.Signature = IMAGE_NT_SIGNATURE then + result := true + else + result := false; + + finally + FreeAndNil(F); + end; +end; + +procedure CreatePE(const FileName: String; + const ImportDllName: String; + const ProcName: String; + PaxProgram: TPaxRunner; + What: TPE); +var + F: TFileStream; + DOS: TDosHeader; + NT: TIMAGE_NT_HEADER; + + SEC_CODE, + SEC_IDATA, + SEC_EDATA, + SEC_DATA, + SEC_RELOC: TIMAGE_SECTION_HEADER; + + B: Byte; + + section_code_size: Cardinal; + section_idata_size: Cardinal; + section_data_size: Cardinal; + section_edata_size: Cardinal; + section_reloc_size: Cardinal; + + psection_code: Pointer; + psection_data: Pointer; + + BaseOfData: Integer; + + ExportTable: TExportTable; + ImportTable: TImportTable; + RelocTable: TFixUpBlockList; + + prg: TSymbolProg; + P: TProgram; + I: Integer; +begin + B := 0; + ExportTable := TExportTable.Create(PaxProgram.GetProgPtr.ExportList, + FileName); + prg := TSymbolProg.Create(nil); + P := TProgram.Create; + + ImportTable := TImportTable.Create; + ImportTable.AddDll(ImportDllName); + ImportTable.AddProc(ImportDllName, ProcName); + + RelocTable := TFixUpBlockList.Create; + with RelocTable.AddBlock(BaseOfCode) do + if What = peDLL then + begin + AddOffset(36); + AddOffset(41); + end + else + begin + AddOffset(1); + AddOffset(6); + end; + RelocTable.Adjust; + + try + // .code + + section_code_size := FileAlignment; + psection_code := AllocMem(section_code_size); + + BaseOfData := SectionAlignment + + SectionAlignment; + + // .idata + + section_idata_size := FileAlignment; + + // .edata + + section_edata_size := Align(ExportTable.GetImageSize, FileAlignment); + + // .reloc + + section_reloc_size := Align(RelocTable.Size, FileAlignment); + + // .data + + if PaxProgram <> nil then + begin + section_data_size := Align(PaxProgram.GetImageSize, FileAlignment); + psection_data := AllocMem(section_data_size); + PaxProgram.SaveToBuff(psection_data^); + end + else + begin + section_data_size := FileAlignment; + psection_data := AllocMem(section_data_size); + end; + + F := TFileStream.Create(FileName, fmCreate); + try + DOS := msdos_header; + + FillChar(NT, SizeOf(NT), 0); + NT.Signature := IMAGE_NT_SIGNATURE; + NT.FileHeader.Machine := $014C; + NT.FileHeader.NumberOfSections := 5; + NT.FileHeader.TimeDateStamp := 0; + NT.FileHeader.PointerToSymbolTable := 0; + NT.FileHeader.NumberOfSymbols := 0; + NT.FileHeader.SizeOfOptionalHeader := SizeOf(TIMAGE_OPTIONAL_HEADER); + if What = peDLL then + NT.FileHeader.Characteristics := +// IMAGE_FILE_RELOCS_STRIPPED or + IMAGE_FILE_EXECUTABLE_IMAGE or + IMAGE_FILE_LINE_NUMS_STRIPPED or + IMAGE_FILE_LOCAL_SYMS_STRIPPED or + IMAGE_FILE_32BIT_MACHINE or + IMAGE_FILE_DLL + else + NT.FileHeader.Characteristics := +// IMAGE_FILE_RELOCS_STRIPPED or + IMAGE_FILE_EXECUTABLE_IMAGE or + IMAGE_FILE_LINE_NUMS_STRIPPED or + IMAGE_FILE_LOCAL_SYMS_STRIPPED or + IMAGE_FILE_32BIT_MACHINE; + + NT.OptionalHeader.Magic := $010B; + NT.OptionalHeader.MajorLinkerVersion := 4; + NT.OptionalHeader.MinorLinkerVersion := 0; + NT.OptionalHeader.SizeOfCode := section_code_size; + NT.OptionalHeader.SizeOfInitializedData := 0; // later below + NT.OptionalHeader.SizeOfUninitializedData := 0; + NT.OptionalHeader.AddressOfEntryPoint := AddressOfEntryPoint; + NT.OptionalHeader.BaseOfCode := BaseOfCode; // $1000 (RVA) + NT.OptionalHeader.BaseOfData := BaseOfData; // $2000 (RVA) + NT.OptionalHeader.ImageBase := ImageBase; + NT.OptionalHeader.SectionAlignment := SectionAlignment; //$1000 + NT.OptionalHeader.FileAlignment := FileAlignment; //$200 + NT.OptionalHeader.MajorOperatingSystemVersion := 4; + NT.OptionalHeader.MinorOperatingSystemVersion := 0; + NT.OptionalHeader.MajorImageVersion := 0; + NT.OptionalHeader.MinorImageVersion := 0; + NT.OptionalHeader.MajorSubsystemVersion := 4; + NT.OptionalHeader.MinorSubsystemVersion := 0; + NT.OptionalHeader.Win32VersionValue := 0; + NT.OptionalHeader.SizeOfImage := 0; // later below + NT.OptionalHeader.SizeOfHeaders := $600; // ?????? + NT.OptionalHeader.CheckSum := 0; + + if What = peDLL then + NT.OptionalHeader.Subsystem := 2 // gui app + else if PaxProgram.Console then + NT.OptionalHeader.Subsystem := 3 // console app + else + NT.OptionalHeader.Subsystem := 2; // gui app + + if What = peDLL then + NT.OptionalHeader.DllCharacteristics := $1 + else + NT.OptionalHeader.DllCharacteristics := 0; // is not used + + NT.OptionalHeader.SizeOfStackReserve := $100000; + NT.OptionalHeader.SizeOfStackCommit := $1000; + NT.OptionalHeader.SizeOfHeapReserve := $100000; + NT.OptionalHeader.SizeOfHeapCommit := $1000; + NT.OptionalHeader.LoaderFlags := 0; // is not used + NT.OptionalHeader.NumberOfRvaAndSizes := $10; + + FillChar(SEC_CODE, SizeOf(SEC_CODE), 0); + SEC_CODE.Name := NAME_CODE_SEC; + SEC_CODE.Misc.VirtualSize := Align(section_code_size, SectionAlignment); + SEC_CODE.VirtualAddress := SectionAlignment; //$1000 + SEC_CODE.SizeOfRawData := section_code_size; + SEC_CODE.PointerToRawData := FileAlignment + FileAlignment; //$400 + SEC_CODE.PointerToRelocations := 0; + SEC_CODE.PointerToLinenumbers := 0; + SEC_CODE.NumberOfRelocations := 0; + SEC_CODE.NumberOfLinenumbers := 0; + SEC_CODE.Characteristics := $60000020; + //Section contains executable code, Section can be executed as code, Section can be read + + FillChar(SEC_IDATA, SizeOf(SEC_IDATA), 0); + SEC_IDATA.Name := NAME_IDATA_SEC; + SEC_IDATA.Misc.VirtualSize := Align(section_idata_size, SectionAlignment); + SEC_IDATA.VirtualAddress := SEC_CODE.VirtualAddress + + SEC_CODE.Misc.VirtualSize; //$2000 + SEC_IDATA.SizeOfRawData := section_idata_size; + SEC_IDATA.PointerToRawData := SEC_CODE.PointerToRawData + + section_code_size; + SEC_IDATA.PointerToRelocations := 0; + SEC_IDATA.PointerToLinenumbers := 0; + SEC_IDATA.NumberOfRelocations := 0; + SEC_IDATA.NumberOfLinenumbers := 0; + SEC_IDATA.Characteristics := $C0000048; + // Section contains initialized data, Section can be read, Section can be written to + + FillChar(SEC_DATA, SizeOf(SEC_DATA), 0); + SEC_DATA.Name := NAME_DATA_SEC; + SEC_DATA.Misc.VirtualSize := Align(section_data_size, SectionAlignment); + SEC_DATA.VirtualAddress := SEC_IDATA.VirtualAddress + + SEC_IDATA.Misc.VirtualSize; //$3000 + SEC_DATA.SizeOfRawData := section_data_size; + SEC_DATA.PointerToRawData := SEC_IDATA.PointerToRawData + + section_idata_size; + SEC_DATA.PointerToRelocations := 0; + SEC_DATA.PointerToLinenumbers := 0; + SEC_DATA.NumberOfRelocations := 0; + SEC_DATA.NumberOfLinenumbers := 0; + SEC_DATA.Characteristics := $C0000048; + // Section contains initialized data, Section can be read, Section can be written to + + FillChar(SEC_EDATA, SizeOf(SEC_EDATA), 0); + SEC_EDATA.Name := NAME_EDATA_SEC; + SEC_EDATA.Misc.VirtualSize := Align(section_edata_size, SectionAlignment); + SEC_EDATA.VirtualAddress := SEC_DATA.VirtualAddress + + SEC_DATA.Misc.VirtualSize; + SEC_EDATA.SizeOfRawData := section_edata_size; + SEC_EDATA.PointerToRawData := SEC_DATA.PointerToRawData + + section_data_size; + SEC_EDATA.PointerToRelocations := 0; + SEC_EDATA.PointerToLinenumbers := 0; + SEC_EDATA.NumberOfRelocations := 0; + SEC_EDATA.NumberOfLinenumbers := 0; + SEC_EDATA.Characteristics := $C0000048; + // Section contains initialized data, Section can be read, Section can be written to + + FillChar(SEC_RELOC, SizeOf(SEC_RELOC), 0); + SEC_RELOC.Name := NAME_RELOC_SEC; + SEC_RELOC.Misc.VirtualSize := Align(section_reloc_size, SectionAlignment); + SEC_RELOC.VirtualAddress := SEC_EDATA.VirtualAddress + + SEC_EDATA.Misc.VirtualSize; + SEC_RELOC.SizeOfRawData := section_reloc_size; + SEC_RELOC.PointerToRawData := SEC_EDATA.PointerToRawData + + section_edata_size; + SEC_RELOC.PointerToRelocations := 0; + SEC_RELOC.PointerToLinenumbers := 0; + SEC_RELOC.NumberOfRelocations := 0; + SEC_RELOC.NumberOfLinenumbers := 0; + SEC_RELOC.Characteristics := $C0000048; + // Section contains initialized data, Section can be read, Section can be written to + + // end of section table + NT.OptionalHeader.SizeOfInitializedData := + SEC_IDATA.Misc.VirtualSize + SEC_DATA.Misc.VirtualSize + + SEC_EDATA.Misc.VirtualSize + SEC_RELOC.Misc.VirtualSize; + NT.OptionalHeader.SizeOfImage := + SectionAlignment + + SEC_CODE.Misc.VirtualSize + + SEC_IDATA.Misc.VirtualSize + + SEC_DATA.Misc.VirtualSize + + SEC_EDATA.Misc.VirtualSize + + SEC_RELOC.Misc.VirtualSize; + + if What = peDLL then + begin + prg.AsmPush_REG(_EBP); + prg.AsmMovREG_REG(_EBP, _ESP); + + prg.AsmMovREG_REG(_EAX, _ESP); + prg.AsmAddReg_Imm(_EAX, 16); + prg.AsmMovREG32_REGPtr(_EAX, _EAX); + + prg.AsmMovREG_REG(_ECX, _ESP); + prg.AsmAddReg_Imm(_ECX, 12); + prg.AsmMovREG32_REGPtr(_ECX, _ECX); + + prg.AsmMovREG_REG(_EDX, _ESP); + prg.AsmAddReg_Imm(_EDX, 8); + prg.AsmMovREG32_REGPtr(_EDX, _EDX); + + prg.AsmPush_REG(_EAX); + prg.AsmPush_REG(_ECX); + prg.AsmPush_REG(_EDX); + + prg.AsmPush_Imm(ImageBase + SEC_DATA.VirtualAddress); + // push data segment + prg.AsmMovREG_Imm(_EAX, ImageBase + + SEC_IDATA.VirtualAddress); + // ptr to address of RunScript + prg.AsmMovREG32_REGPtr(_EAX, _EAX); + prg.AsmCall_REG(_EAX); + + prg.AsmMovREG_REG(_ESP, _EBP); + prg.AsmPop_REG(_EBP); + + prg.AsmRet(12); + + for I := 0 to ExportTable.ExportList.Count - 1 do + begin + prg.AsmMovREG_Imm(_EBX, 0); + prg.AsmJMP_Reg(_EBX); + end; + end + else + begin + prg.AsmPush_Imm(ImageBase + SEC_DATA.VirtualAddress); // push data segment + prg.AsmMovREG_Imm(_EAX, ImageBase + + SEC_IDATA.VirtualAddress); + // ptr to address of RunScript + prg.AsmMovREG32_REGPtr(_EAX, _EAX); + prg.AsmCall_REG(_EAX); + prg.AsmRet(0); + end; + +// if IsDump then +// TSymbolProg_Dump(prg, '1.txt'); + + prg.CreateProgramSimple(P); + + ExportTable.Calc(SEC_EDATA.VirtualAddress, + SEC_CODE.VirtualAddress + DllJumpsOffset); + ImportTable.Calc(SEC_IDATA.VirtualAddress); + + if ExportTable.GetImageSize > 0 then + with NT.OptionalHeader do + with DataDirectory[IMAGE_DIRECTORY_ENTRY_EXPORT] do + begin + VirtualAddress := SEC_EDATA.VirtualAddress; + Size := ExportTable.GetImageSize; + end; + + with NT.OptionalHeader do + with DataDirectory[IMAGE_DIRECTORY_ENTRY_IMPORT] do + begin + VirtualAddress := ImportTable.IMAGE_IMPORT_DESCRIPTOR_RVA; + Size := ImportTable.IMAGE_IMPORT_DESCRIPTOR_SIZE; + end; + + with NT.OptionalHeader do + with DataDirectory[IMAGE_DIRECTORY_ENTRY_IAT] do + begin + VirtualAddress := ImportTable.IAT_RVA1; + Size := ImportTable.IAT_SIZE; + end; + + if RelocTable.Size > 0 then + with NT.OptionalHeader do + with DataDirectory[IMAGE_DIRECTORY_ENTRY_BASERELOC] do + begin + VirtualAddress := SEC_RELOC.VirtualAddress; + Size := RelocTable.Size; + end; + + // OUTPUT + F.Write(DOS, SizeOf(DOS)); + F.Write(NT, SizeOf(NT)); + F.Write(SEC_CODE, SizeOf(SEC_CODE)); + F.Write(SEC_IDATA, SizeOf(SEC_IDATA)); + F.Write(SEC_DATA, SizeOf(SEC_DATA)); + F.Write(SEC_EDATA, SizeOf(SEC_EDATA)); + F.Write(SEC_RELOC, SizeOf(SEC_RELOC)); + + // .code + + while F.Position < Integer(SEC_CODE.PointerToRawData) do + F.Write(B, 1); + + Move(P.CodePtr^, psection_code^, P.CodeSize); + F.Write(psection_code^, section_code_size); + + // .idata + + while F.Position < Integer(SEC_IDATA.PointerToRawData) do + F.Write(B, 1); + ImportTable.SaveToStream(F); + + // .data + + while F.Position < Integer(SEC_DATA.PointerToRawData) do + F.Write(B, 1); + + F.Write(psection_data^, section_data_size); + + // .edata + ExportTable.SaveToStream(F); + while F.Position < Integer(SEC_EDATA.PointerToRawData) + + Integer(SEC_EDATA.SizeOfRawData) do + F.Write(B, 1); + + // .reloc + RelocTable.SaveToStream(F); + while F.Position < Integer(SEC_RELOC.PointerToRawData) + + Integer(SEC_RELOC.SizeOfRawData) do + F.Write(B, 1); + + finally + FreeMem(psection_code, section_code_size); + FreeMem(psection_data, section_data_size); + FreeAndNil(F); + end; + + finally + FreeAndNil(ExportTable); + FreeAndNil(ImportTable); + FreeAndNil(RelocTable); + FreeAndNil(prg); + FreeAndNil(P); + end; +end; + +end. + diff --git a/Sources/PAXCOMP_PROG.pas b/Sources/PAXCOMP_PROG.pas new file mode 100644 index 0000000..6cbb215 --- /dev/null +++ b/Sources/PAXCOMP_PROG.pas @@ -0,0 +1,2703 @@ +//////////////////////////////////////////////////////////////////////////// +// PaxCompiler +// Site: http://www.paxcompiler.com +// Author: Alexander Baranovsky (paxscript@gmail.com) +// ======================================================================== +// Copyright (c) Alexander Baranovsky, 2006-2014. All rights reserved. +// Code Version: 4.2 +// ======================================================================== +// Unit: PAXCOMP_PROG.pas +// ======================================================================== +//////////////////////////////////////////////////////////////////////////// + +{$I PaxCompiler.def} +{$O-} + +unit PAXCOMP_PROG; +interface +uses {$I uses.def} + TypInfo, + SysUtils, + Classes, + PaxInfos, + PAXCOMP_CONSTANTS, + PAXCOMP_TYPES, + PAXCOMP_SYS, + PAXCOMP_STDLIB, + PAXCOMP_SYMBOL_REC, + PAXCOMP_BASESYMBOL_TABLE, + PAXCOMP_LOCALSYMBOL_TABLE, + PAXCOMP_CLASSLST, + PAXCOMP_CLASSFACT, + PAXCOMP_DISASM, + PAXCOMP_TRYLST, + PAXCOMP_PAUSE, + PAXCOMP_RTI, + PAXCOMP_EVENT, + PAXCOMP_MAP, + PAXCOMP_TYPEINFO, + PAXCOMP_PROGLIST, + PAXCOMP_GC, + PAXCOMP_BASERUNNER, + PAXCOMP_INVOKE, + PaxInvoke; + +type + TProgram = class; + + TCallStackRec = class + public + EBP: Integer; + SubId: Integer; + NCall: Integer; + Prg: TProgram; + procedure SaveToStream(S: TStream); + procedure LoadFromStream(S: TStream); + end; + + TCallStack = class(TTypedList) + private + function GetRecord(I: Integer): TCallStackRec; + public + function Push(EBP, SubId, NCall: Integer; Prg: TProgram): TCallStackRec; + procedure Pop; + function Top: TCallStackRec; + function IndexOf(SubId: Integer): Integer; + function LastIndexOf(SubId: Integer): Integer; + procedure SaveToStream(S: TStream); + procedure LoadFromStream(S: TStream); + property Records[I: Integer]: TCallStackRec read GetRecord; default; + end; + + TTryStackRec = class + public + TryBlockNumber: Integer; + Prog: TProgram; + TR: TTryRec; + constructor Create; + destructor Destroy; override; + end; + + TTryStack = class(TTypedList) + private + function GetRecord(I: Integer): TTryStackRec; + function GetTop: TTryStackRec; + public + function Push(ATryBlockNumber: Integer; AProg: TProgram): TTryStackRec; + procedure Pop; + function IndexOf(ATryBlockNumber: Integer): Integer; + procedure SaveToStream(S: TStream); + procedure LoadFromStream(S: TStream); + property Top: TTryStackRec read GetTop; + property Records[I: Integer]: TTryStackRec read GetRecord; default; + end; + + TProgram = class(TBaseRunner) + private + fTryList: TTryList; + fTryStack: TTryStack; + fPauseRec: TPauseRec; + + fESP0: Integer; + + fCallStack: TCallStack; + + InitialOffset: Integer; + + fVirtualAllocProg: Boolean; + + procedure SetVirtualAllocProg(value: Boolean); + + function GetInteger(Shift: Integer): Integer; + function GetInt64(Shift: Integer): Int64; + function GetPChar(Shift: Integer): PChar; + function GetShortString(Shift: Integer): ShortString; + function GetRootProg: TProgram; + + function GetTryStack: TTryStack; + + function GetCallStack: TCallStack; + function GetESP0: Integer; + procedure SetESP0(value: Integer); + function GetCurrException: Exception; + procedure SetCurrException(value: Exception); + +protected + function GetProgramSize: Integer; override; + function _VirtualAlloc(Address: Pointer; + Size, flAllocType, flProtect: Cardinal): Pointer; override; + procedure _VirtualFree(Address: Pointer; Size: Cardinal); override; + + function GetVirtualAllocProg: Boolean; + function GetCodePtr: PBytes; override; + procedure DoOnReaderFindMethod( + Reader: TReader; + const MethodName: string; + var Address: Pointer; + var Error: Boolean); + + public + EventHandlerList: TEventHandlerList; + + ZList: TIntegerList; + + OwnerEventHandlerMethod: TMethod; + +{$IFDEF MSWINDOWS} + mbi: TMemoryBasicInformation; +{$ENDIF} + OldProtect: Cardinal; + IsProtected: Boolean; + IsPauseUpdated: Boolean; + ExitLevelId: Integer; + FinalizationOffset: Integer; + + SourceLineFinally: Integer; + ModuleNameFinally: String; + + PauseSEH: Boolean; + ExcFrame0: PExcFrame; + + constructor Create; override; + destructor Destroy; override; + procedure Reset; override; + procedure ResetRun; override; + function GetDestructorAddress: Pointer; override; + procedure SaveToStream(S: TStream); override; + procedure LoadFromStream(S: TStream); override; + procedure Reallocate(NewCodeSize: Integer); + procedure AssignEventHandlerRunner(MethodAddress: Pointer; + Instance: TObject); override; + function GetCallStackCount: Integer; override; + function GetCallStackItem(I: Integer): Integer; override; + function GetCallStackLineNumber(I: Integer): Integer; override; + function GetCallStackModuleName(I: Integer): String; override; + function GetCallStackModuleIndex(I: Integer): Integer; override; + + procedure RunInternal; override; + procedure Run; override; + + procedure RunInitialization; override; + procedure RunExceptInitialization; override; + procedure RunFinalization; override; + + procedure PushPtrs; + function GetPauseFlag: Integer; + procedure InitByteCodeLine; + function IsPaused: Boolean; override; + procedure Pause; override; + procedure DiscardPause; override; + + procedure Terminate; + procedure RemovePause; override; + function Valid: Boolean; override; + procedure SetZList; + + function GetImageCodePtr: Integer; + function GetImageAddress(const FullName: String; var MR: TMapRec): Integer; + + function CreateScriptObject(const ScriptClassName: String; + const ParamList: array of const): TObject; override; + procedure DiscardDebugMode; override; + procedure RunEx; + procedure SaveState(S: TStream); override; + procedure LoadState(S: TStream); override; + + procedure RebindEvents(AnInstance: TObject); override; + + function CallFunc(const FullName: String; + This: Pointer; + const ParamList: array of OleVariant; + OverCount: Integer = 0): OleVariant; override; + function CallFuncEx(const FullName: String; + This: Pointer; + const ParamList: array of const; + IsConstructor: Boolean = false; + OverCount: integer = 0): Variant; + procedure Protect; override; + procedure UnProtect; override; + procedure ResetException; + procedure SetEntryPoint(EntryPoint: TPaxInvoke); override; + procedure ResetEntryPoint(EntryPoint: TPaxInvoke); override; + + function GetParamAddress(Offset: Integer): Pointer; overload; override; + function GetLocalAddress(Offset: Integer): Pointer; overload; override; + function GetParamAddress(StackFrameNumber, Offset: Integer): Pointer; overload; override; + function GetLocalAddress(StackFrameNumber, Offset: Integer): Pointer; overload; override; + + property Integers[Shift: Integer]: Integer read GetInteger; + property Int64s[Shift: Integer]: Int64 read GetInt64; + property PChars[Shift: Integer]: PChar read GetPChar; + property ShortStrings[Shift: Integer]: ShortString read GetShortString; + property TryList: TTryList read fTryList; + property PauseRec: TPauseRec read fPauseRec; + + property RootTryStack: TTryStack read GetTryStack; + + property RootCallStack: TCallStack read GetCallStack; + property RootESP0: Integer read GetESP0 write SetESP0; + property CurrException: Exception read GetCurrException write SetCurrException; + property VirtualAllocProg: Boolean + read GetVirtualAllocProg write SetVirtualAllocProg; + property RootProg: TProgram read GetRootProg; + end; + +procedure ZZZ; + +implementation + +uses + PAXCOMP_PROGLIB, + PAXCOMP_JavaScript; + +// TCallStackRec --------------------------------------------------------------- + +procedure TCallStackRec.SaveToStream(S: TStream); +begin + S.Write(EBP, SizeOf(Integer)); + S.Write(SubId, SizeOf(Integer)); + S.Write(NCall, SizeOf(Integer)); +end; + +procedure TCallStackRec.LoadFromStream(S: TStream); +begin + S.Read(EBP, SizeOf(Integer)); + S.Read(SubId, SizeOf(Integer)); + S.Read(NCall, SizeOf(Integer)); +end; + +// TCallStack ------------------------------------------------------------------ + +function TCallStack.GetRecord(I: Integer): TCallStackRec; +begin + result := TCallStackRec(L[I]); +end; + +function TCallStack.Push(EBP, SubId, NCall: Integer; + Prg: TProgram): TCallStackRec; +begin + result := TCallStackRec.Create; + result.EBP := EBP; + result.SubId := SubId; + result.NCall := NCall; + result.Prg := Prg; + L.Add(result); +end; + +procedure TCallStack.Pop; +begin + RemoveAt(Count - 1); +end; + +function TCallStack.Top: TCallStackRec; +begin + result := TCallStackRec(L[Count - 1]); +end; + +function TCallStack.IndexOf(SubId: Integer): Integer; +var + I: Integer; +begin + result := -1; + for I := 0 to Count - 1 do + if Records[I].SubId = SubId then + begin + result := I; + Exit; + end; +end; + +function TCallStack.LastIndexOf(SubId: Integer): Integer; +var + I: Integer; +begin + result := -1; + for I := Count - 1 downto 0 do + if Records[I].SubId = SubId then + begin + result := I; + Exit; + end; +end; + +procedure TCallStack.SaveToStream(S: TStream); +var + I, K: Integer; +begin + K := Count; + S.Write(K, SizeOf(Integer)); + for I := 0 to K - 1 do + Records[I].SaveToStream(S); +end; + +procedure TCallStack.LoadFromStream(S: TStream); +var + I, K: Integer; + R: TCallStackRec; +begin + S.Read(K, SizeOf(Integer)); + for I := 0 to K - 1 do + begin + R := TCallStackRec.Create; + R.LoadFromStream(S); + L.Add(R); + end; +end; + +// TTryRec --------------------------------------------------------------------- + +constructor TTryStackRec.Create; +begin + inherited; +end; + +destructor TTryStackRec.Destroy; +begin + if TR <> nil then + FreeAndNil(TR); + + inherited; +end; + +// TTryStack ------------------------------------------------------------------- + +function TTryStack.GetRecord(I: Integer): TTryStackRec; +begin + result := TTryStackRec(L[I]); +end; + +function TTryStack.GetTop: TTryStackRec; +begin + if Count = 0 then + raise PaxCompilerException.Create(errInternalError); + result := Records[Count - 1]; +end; + +function TTryStack.IndexOf(ATryBlockNumber: Integer): Integer; +var + I: Integer; +begin + result := -1; + for I := 0 to Count - 1 do + if Records[I].TryBlockNumber = ATryBlockNumber then + begin + result := I; + Exit; + end; +end; + +function TTryStack.Push(ATryBlockNumber: Integer; AProg: TProgram): TTryStackRec; +begin + result := TTryStackRec.Create; + result.TryBlockNumber := ATryBlockNumber; + result.Prog := AProg; + result.TR := AProg.TryList[ATryBlockNumber].Clone; + L.Add(result); +end; + +procedure TTryStack.Pop; +begin + Records[Count - 1].Free; + L.Delete(Count - 1); +end; + +procedure TTryStack.SaveToStream(S: TStream); +var + I, K: Integer; +begin + K := Count; + S.Write(K, SizeOf(K)); + for I := 0 to K - 1 do + with Records[I] do + begin + S.Write(TryBlockNumber, SizeOf(TryBlockNumber)); + S.Write(Prog, SizeOf(Prog)); + TR.SaveToStream(S); + end; +end; + +procedure TTryStack.LoadFromStream(S: TStream); +var + I, K: Integer; + R: TTryStackRec; +begin + Clear; + S.Read(K, SizeOf(K)); + for I := 0 to K - 1 do + begin + R := TTryStackRec.Create; + with R do + begin + S.Read(TryBlockNumber, SizeOf(TryBlockNumber)); + S.Read(Prog, SizeOf(Prog)); + TR := TTryRec.Create; + TR.LoadFromStream(S); + end; + L.Add(R); + end; +end; + +// TProgram -------------------------------------------------------------------- + +constructor TProgram.Create; +begin + inherited Create; + +{$IFDEF MSWINDOWS} + fVirtualAllocProg := true; +{$ENDIF} + + CurrProg := Self; + + fTryList := TTryList.Create; + fTryStack := TTryStack.Create; + fPauseRec := TPauseRec.Create; + + EventHandlerList := TEventHandlerList.Create; + + fCallStack := TCallStack.Create; + + EPoint := nil; + + PCUOwner := nil; + ZList := TIntegerList.Create; + + IsRunning := false; + + UseMapping := false; +end; + +destructor TProgram.Destroy; +begin + ResetException; + UnloadDlls; + FreeAndNil(ZList); + + FreeAndNil(fTryList); + FreeAndNil(fTryStack); + FreeAndNil(fPauseRec); + FreeAndNil(fCallStack); + + try + Deallocate; + except + end; + + FreeAndNil(EventHandlerList); + + ClearCurrException; + + inherited; +end; + +procedure TProgram.Reset; +begin + inherited; + + fImageDataPtr := 0; + + ZList.Clear; + fTryList.Clear; + fTryStack.Clear; + fPauseRec.Clear; + EventHandlerList.Clear; + fCallStack.Clear; + + RootInitCallStackCount := 0; + Deallocate; + EPoint := nil; + + IsRunning := false; + RootIsEvent := false; + + PauseSEH := false; + + FinallyCount := 0; + + PCULang := 0; +end; + +procedure TProgram.ResetRun; +begin + fTryStack.Clear; + fPauseRec.Clear; + fCallStack.Clear; + RootInitCallStackCount := 0; + EPoint := nil; + + IsRunning := false; + RootIsEvent := false; + PauseSEH := false; +end; + +procedure TProgram.SetZList; +var + I, S: Integer; + P: Pointer; +begin +{$IFDEF PAX64} + for I:=0 to ZList.Count - 1 do + begin + S := ZList[I]; + + P := ShiftPointer(CodePtr, S + 2); + Pointer(P^) := CodePtr; + + P := ShiftPointer(P, 10); + Pointer(P^) := DataPtr; + end; +{$ELSE} + for I:=0 to ZList.Count - 1 do + begin + S := ZList[I]; + + P := ShiftPointer(CodePtr, S + 1); + Pointer(P^) := CodePtr; + + P := ShiftPointer(P, 5); + Pointer(P^) := DataPtr; + end; +{$ENDIF} +end; + +function TProgram.GetInteger(Shift: Integer): Integer; +var + P: Pointer; +begin + P := ShiftPointer(DataPtr, Shift); + result := LongInt(P^); +end; + +function TProgram.GetInt64(Shift: Integer): Int64; +var + P: Pointer; +begin + P := ShiftPointer(DataPtr, Shift); + result := Int64(P^); +end; + +function TProgram.GetPChar(Shift: Integer): PChar; +var + P: Pointer; +begin + P := ShiftPointer(DataPtr, Shift); + result := PChar(P^); +end; + +function TProgram.GetShortString(Shift: Integer): ShortString; +var + P: Pointer; +begin + P := ShiftPointer(DataPtr, Shift); + result := ShortString(P^); +end; + +procedure TProgram.Reallocate(NewCodeSize: Integer); +var + buff: Pointer; +begin + if NewCodeSize = CodeSize then + Exit; + + if NewCodeSize < CodeSize then + RaiseError(errInternalError, []); + + Unprotect; + + buff := _VirtualAlloc(nil, CodeSize, MEM_COMMIT, PAGE_EXECUTE_READWRITE); + Move(Prog^, buff^, CodeSize); + _VirtualFree(Prog, CodeSize); + Prog := _VirtualAlloc(nil, NewCodeSize, MEM_COMMIT, PAGE_EXECUTE_READWRITE); + Move(buff^, Prog^, CodeSize); + _VirtualFree(buff, CodeSize); + CodeSize := NewCodeSize; + + Protect; +end; + +function TProgram.Valid: Boolean; +begin + result := (Data <> nil) and (Prog <> nil); +end; + +function TProgram.GetImageAddress(const FullName: String; var MR: TMapRec): Integer; +begin + result := 0; + MR := ScriptMapTable.Lookup(FullName); + if MR <> nil then + begin + case MR.Kind of + KindVAR, kindTYPE: result := GetImageDataPtr + MR.Offset; + KindSUB, KindCONSTRUCTOR, KindDESTRUCTOR: + begin + if MR.IsExternal then + result := 0 + else + result := GetImageCodePtr + MR.Offset; + end; + end; + Exit; + end; + + MR := HostMapTable.Lookup(FullName); + if MR <> nil then + if MR.Kind in KindSUBS + [KindVAR] then + begin + result := GetImageDataPtr + MR.Offset; +// result := Pointer(result^); + end; +end; + +function TProgram.GetCodePtr: PBytes; +begin + result := Prog; +end; + +function TProgram.GetPauseFlag: Integer; +var + P: Pointer; +begin + P := ShiftPointer(Data, H_Flag); + result := LongInt(P^); +end; + +procedure TProgram.InitByteCodeLine; +var + P: Pointer; +begin + P := ShiftPointer(Data, H_ByteCodePtr); + LongInt(P^) := -1; +end; + +function TProgram.GetImageCodePtr: Integer; +begin + result := GetImageDataPtr + DataSize; +end; + +procedure TProgram.SaveToStream(S: TStream); +var + StartSize, EndSize, StartPos, EndPos, StreamSize: Integer; + CustomDataSize, CustomDataSizePos, temp: Integer; + SS: ShortString; +begin + StartSize := S.Size; + StartPos := S.Position; + + S.Write(StreamSize, SizeOf(Integer)); + S.Write(CompiledScriptVersion, SizeOf(CompiledScriptVersion)); + + PShortStringFromString(@ SS, TProgram.ClassName); + SaveShortStringToStream(SS, S); + + CustomDataSize := 0; + CustomDataSizePos := S.Position; + S.Write(CustomDataSize, SizeOf(Integer)); + if Assigned(OnSaveToStream) and IsRootProg then + begin + OnSaveToStream(Owner, S); + CustomDataSize := S.Position - CustomDataSizePos - 4; + if CustomDataSize > 0 then + begin + temp := S.Position; + S.Position := CustomDataSizePos; + S.Write(CustomDataSize, SizeOf(Integer)); + S.Position := temp; + end + else + begin + CustomDataSize := 0; + S.Position := CustomDataSizePos; + S.Write(CustomDataSize, SizeOf(Integer)); + end; + end; + + S.Write(DataSize, SizeOf(Integer)); + S.Write(fCodeSize, SizeOf(Integer)); + + fImageDataPtr := S.Position - StartPos; + + S.Write(Data^, DataSize); + S.Write(Prog^, fCodeSize); + S.Write(JS_Record, SizeOf(JS_Record)); + + S.Write(ModeSEH, SizeOf(ModeSEH)); + S.Write(PAX64, SizeOf(PAX64)); + + if GENERICS_ALLOWED then + S.Write(PCULang, SizeOf(PCULang)); + + ClassList.SaveToStream(S); + RunTimeModuleList.SaveToStream(S); + TryList.SaveToStream(S); + ZList.SaveToStream(S); + + HostMapTable.SaveToStream(S); + ScriptMapTable.SaveToStream(S); + OffsetList.SaveToStream(S); + ExportList.SaveToStream(S); + MessageList.SaveToStream(S); + ProgTypeInfoList.SaveToStream(S); + + ProgList.SaveToStream(S); + + EndSize := S.Size; + EndPos := S.Position; + StreamSize := EndSize - StartSize; + S.Position := StartPos; + S.Write(StreamSize, SizeOf(Integer)); + S.Position := EndPos; +end; + +procedure TProgram.LoadFromStream(S: TStream); +var + Version: Integer; + K: Integer; + CustomDataSize, temp: Integer; + P: Pointer; + SS: ShortString; + ST: String; +begin + Deallocate; + S.Read(K, SizeOf(Integer)); + S.Read(Version, SizeOf(CompiledScriptVersion)); + if Version <> CompiledScriptVersion then + RaiseError(errIncorrectCompiledScriptVersion, []); + + SS := LoadShortStringFromStream(S); + ST := TProgram.ClassName; + if not StrEql(StringFromPShortString(@SS), ST) then + RaiseError(errIncorrectCompiledScriptVersion, []); + + S.Read(CustomDataSize, SizeOf(Integer)); + if Assigned(OnLoadFromStream) and IsRootProg then + begin + temp := S.Position; + OnLoadFromStream(Owner, S); + if S.Position - temp <> CustomDataSize then + RaiseError(errIncorrectCustomDataSize, []); + end + else + if CustomDataSize > 0 then + begin + P := AllocMem(CustomDataSize); + try + S.Read(P^, CustomDataSize); + finally + FreeMem(P, CustomDataSize); + end; + end; + + S.Read(fDataSize, SizeOf(Integer)); + S.Read(fCodeSize, SizeOf(Integer)); + + Data := AllocMem(fDataSize); + Prog := _VirtualAlloc(nil, fCodeSize, MEM_COMMIT, PAGE_EXECUTE_READWRITE); + + S.Read(Data^, fDataSize); + S.Read(Prog^, fCodeSize); + S.Read(JS_Record, SizeOf(JS_Record)); + + S.Read(ModeSEH, SizeOf(ModeSEH)); + S.Read(PAX64, SizeOf(PAX64)); + if GENERICS_ALLOWED then + S.Read(PCULang, SizeOf(PCULang)); + +{$IFDEF MACOS} + ModeSEH := false; +{$ENDIF} + + ClassList.Clear; + ClassList.LoadFromStream(S, Version); + + RunTimeModuleList.Clear; + RunTimeModuleList.LoadFromStream(S); + TryList.Clear; + TryList.LoadFromStream(S); + + ZList.Clear; + ZList.LoadFromStream(S); + + HostMapTable.Clear; + HostMapTable.LoadFromStream(S); + ScriptMapTable.Clear; + ScriptMapTable.LoadFromStream(S); + + OffsetList.Clear; + OffsetList.LoadFromStream(S); + ExportList.Clear; + ExportList.LoadFromStream(S); + MessageList.Clear; + MessageList.LoadFromStream(S); + ProgTypeInfoList.Clear; + ProgTypeInfoList.LoadFromStream(S); + + ProgList.Clear; + ProgList.LoadFromStream(S, Self); + ProgList.SetPCUOwner(Self); + + UseMapping := HostMapTable.Count > 0; + + SetAddress(H_SelfPtr, Self); + SetAddress(H_ExceptionPtr, @ fCurrException); + + RegisterDefinitions(GlobalSym); + if UseMapping then + begin + FreeAndNil(LocalSymbolTable); + LocalSymbolTable := TProgSymbolTable.Create(GlobalSym); + + LocalSymbolTable.Reset; + RegisterDefinitions(LocalSymbolTable); + end; + + SetZList; + SetupInterfaces(CodePtr); + + ProgClassFactory.ForceCreate := true; +end; + +function TProgram.IsPaused: Boolean; +begin + result := RootProg.PauseRec.ProgOffset > 0; +end; + +{ +procedure TProgram.Resume; +begin + if not IsPaused then + RaiseError(errProgramIsNotPaused, []); + Run; +end; +} + +procedure TProgram.Pause; +var + P: Pointer; +begin + P := ShiftPointer(Data, H_Flag); + LongInt(P^) := 1; +end; + +procedure TProgram.Terminate; +var + P: Pointer; +begin + P := ShiftPointer(Data, H_Flag); + LongInt(P^) := 2; +end; + +procedure TProgram.RemovePause; +var + P: Pointer; +begin + P := ShiftPointer(Data, H_Flag); + LongInt(P^) := 0; +end; + +procedure TProgram.Protect; +begin +{$IFDEF MSWINDOWS} + if IsProtected then + Exit; + + VirtualQuery(Prog, mbi, sizeof(mbi)); +// VirtualProtect(mbi.BaseAddress, mbi.RegionSize, PAGE_EXECUTE_READWRITE, OldProtect); + VirtualProtect(Prog, fCodeSize, PAGE_EXECUTE_READWRITE, OldProtect); + FlushInstructionCache(GetCurrentProcess, Prog, fCodeSize); +// Applications should call FlushInstructionCache if they generate or modify +// code in memory. The CPU cannot detect the change, and may execute the old +// code it cached. +{$ENDIF} + IsProtected := true; +end; + +procedure TProgram.UnProtect; +begin +{$IFDEF MSWINDOWS} + if not IsProtected then + Exit; + +// VirtualProtect(mbi.BaseAddress, mbi.RegionSize, OldProtect, OldProtect); + VirtualProtect(Prog, fCodeSize, OldProtect, OldProtect); +{$ENDIF} + + IsProtected := false; +end; + +procedure TProgram.ResetException; +var + aPrg : TProgram; + i : integer; +begin + for i := 0 to ProgList.count - 1 do + begin + aPrg := TProgram(ProgList.Records[i].Prog); + if (aPrg <> nil) then + aPrg.ResetException; + end; + + if HasError then + begin + if fCurrException <> nil then + fCurrException.Free; + fCurrException := nil; + fPrevException := nil; + ExceptionRec := nil; + HasError := false; + fGC.Collect; + end; +end; + +{$IFDEF PAX64} +function GetFS0: Pointer; assembler; +{$IFDEF FPC} +nostackframe; asm +{$ELSE} +asm + .NOFRAME +{$ENDIF} + mov rax, fs:[0] +end; + +function GetRSP: IntPax; assembler; +{$IFDEF FPC} +nostackframe; asm +{$ELSE} +asm + .NOFRAME +{$ENDIF} + mov rax, rsp +end; + +procedure CopyStackFrame(I: IntPax; + StackFrame: Pointer; + StackFrameSize, K: IntPax); +asm + mov rax, I + mov rbx, StackFrame + + add rbx, StackFrameSize //!! + sub rbx, 8 //!! + + mov rcx, K + + @@loop: + + mov rdx, [rbx] + mov [rax], rdx + + sub rax, 8 + sub rbx, 8 + + sub rcx, 1 + cmp rcx, 0 + jnz @@loop +end; + +procedure AssignFS0(I: IntPax); assembler; +{$IFDEF FPC} +nostackframe; asm +{$ELSE} +asm + .NOFRAME +{$ENDIF} + mov fs:[0], rcx +end; + +procedure AssignSegmentsAndJump(D, P0, P: Pointer; + _ESP, _EBP: IntPax); assembler; +asm + // assign code and data registers + mov rsi, D + mov rdi, P0 + + mov rax, P + + mov rsp, _ESP + mov rbp, _EBP + + jmp rax +end; + +procedure AssignSegmentsAndCall(D, P: Pointer); assembler; +{$IFDEF FPC} +nostackframe; asm +{$ELSE} +asm + .NOFRAME +{$ENDIF} + push rbp + mov rbp, rsp + + mov rsi, rcx + mov rdi, rdx + + call rdx + + pop rbp + ret +end; + +procedure AssignSegments(D, P: Pointer); assembler; +{$IFDEF FPC} +nostackframe; asm +{$ELSE} +asm + .NOFRAME +{$ENDIF} + mov rsi, rcx + mov rdi, rdx +end; + +procedure Assign_R14(P: Pointer); assembler; +{$IFDEF FPC} +nostackframe; asm +{$ELSE} +asm + .NOFRAME +{$ENDIF} + mov r14, rcx +end; + +procedure Assign_R15(P: Pointer); assembler; +{$IFDEF FPC} +nostackframe; asm +{$ELSE} +asm + .NOFRAME +{$ENDIF} + mov r15, rcx +end; + +procedure Call_R15; assembler; +{$IFDEF FPC} +nostackframe; asm +{$ELSE} +asm + .NOFRAME +{$ENDIF} + push rbp + sub rsp, $1000 + mov rbp, rsp + +// if EPoint.IsInternal then +// EPoint.PushArgumentsBackward +// else +// EPoint.PushArguments; + + mov rcx, r14 + call TInvoke.IsInternal + cmp al, 0 + jz @@l1 + mov rcx, r14 + call TInvoke.PushArgumentsBackward + jmp @@l2 + @@l1: + mov rcx, r14 + call TInvoke.PushArguments + @@l2: + + call r15 + add rsp, $1000 + pop rbp + ret +end; + +{$ENDIF} + +procedure TProgram.Run; +var + PaxFrame: PPaxExcFrame; + Delta: IntPax; + I: Integer; + D, P, P0, temp: Pointer; + ProgOffset: Integer; + Handled: Boolean; + _EBP, _ESP: IntPax; + TryRec: TTryRec; + ClsIndex: Integer; + ClassRec: TClassRec; + StackFrame: Pointer; + K: Integer; + SourceLine: Integer; + ModuleName: String; + CE: TExceptionClass; + PEpoint: Pointer; + StackFrameSize: Integer; + IsHaltException: Boolean; + IsPauseException: Boolean; + IsExitException: Boolean; + TryBlockNumber: Integer; + + SelfPtr: TProgram; + HandledByExcept: Boolean; + +label + Again; +begin +// PChars[0]; +// ShortStrings[0]; + Integers[0]; + Int64s[0]; + SourceLineFinally := -1; + ModuleNameFinally := ''; + + IsRootProg; + + if ProgClassFactory.ForceCreate then + begin + CreateClassFactory; + ProgClassFactory.ForceCreate := false; + end; + + IsRunning := true; + IsHalted := false; + IsPauseUpdated := false; + + PEpoint := nil; + + ProgOffset := 0; + Handled := false; + + SelfPtr := Self; + + with SelfPtr do + begin + D := Data; + P0 := Prog; + end; + + SourceLine := -1; + ExitCode := 0; + + IsHaltException := false; + IsPauseException := false; + + RootInitCallStackCount := fCallStack.Count; + + if IsPaused then + begin + Handled := true; + StackFrameSize := PauseRec.StackFrameSize; + K := StackFrameSize div 4; + StackFrame := PauseRec.StackFrame; + ProgOffset := PauseRec.ProgOffset; + _ESP := PauseRec._ESP; + _EBP := PauseRec._EBP; + + PauseRec.ProgOffset := 0; + end; + + RemovePause; + +Again: + + if HasError then + GetRootProg.ResetException; + + HasError := false; + HandledByExcept := false; + + try + if ModeSEH then + begin + {$IFDEF PAX64} +// temp := GetFS0; + {$ELSE} + asm + mov eax, fs:[0] + mov temp, eax + end; + {$ENDIF} + ExcFrame0 := temp; + end; + + if Handled then + begin + Handled := false; + + {$IFDEF PAX64} + I := GetRSP; + {$ELSE} + asm + mov I, esp + end; + {$ENDIF} + + PaxFrame := PauseRec.PaxExcFrame1; + + Delta := fESP0 - I; + fESP0 := I; + _ESP := _ESP - Delta; + _EBP := _EBP - Delta; + + for I := 0 to fCallStack.Count - 1 do + fCallStack[I].EBP := fCallStack[I].EBP - Delta; + + {$IFDEF PAX64} + // restore stack frame + I := fESP0 - 8; + CopyStackFrame(I, StackFrame, StackFrameSize, K); + P := Pointer(LongInt(P0) + ProgOffset); + + if ModeSEH and PauseSEH then + begin + IntPax(PaxFrame) := + Integer(PaxFrame) - Delta; + I := IntPax(PaxFrame); + AssignFS0(I); + while PaxFrame.Magic = PAX_SEH do + begin + PaxFrame^.hEBP := PaxFrame^.hEBP - Delta; + PaxFrame^.hESP := PaxFrame^.hESP - Delta; + + PaxFrame^.Next := Pointer(Integer(PaxFrame^.Next) - Delta); + PaxFrame := PaxFrame^.Next; + end; + PaxFrame^.Next := Pointer(ExcFrame0); + + PauseSEH := false; + end; + AssignSegmentsAndJump(D, P0, P, _ESP, _EBP); + // end of win64 + + {$ELSE} //win32 + // restore stack frame + I := fESP0 - 4; + + asm + mov eax, I + mov ebx, StackFrame + + add ebx, StackFrameSize //!! + sub ebx, 4 //!! + + mov ecx, K + + @@loop: + + mov edx, [ebx] + mov [eax], edx + + sub eax, 4 + +// add ebx, 4 + sub ebx, 4 + + sub ecx, 1 + cmp ecx, 0 + jnz @@loop + end; + + P := Pointer(LongInt(P0) + ProgOffset); + + if ModeSEH and PauseSEH then + begin + Integer(PaxFrame) := + Integer(PaxFrame) - Delta; + I := Integer(PaxFrame); + asm + mov eax, I + mov fs:[0], eax + end; + while PaxFrame.Magic = PAX_SEH do + begin + PaxFrame^.hEBP := PaxFrame^.hEBP - Delta; + PaxFrame^.hESP := PaxFrame^.hESP - Delta; + + PaxFrame^.Next := Pointer(Integer(PaxFrame^.Next) - Delta); + PaxFrame := PaxFrame^.Next; + end; + PaxFrame^.Next := Pointer(ExcFrame0); + + PauseSEH := false; + end; + + asm + // assign code and data registers + mov esi, D + mov edi, P0 + + mov eax, P + + mov esp, _ESP + mov ebp, _EBP + + jmp eax + end; + {$ENDIF} // win32 + end + else + begin + InitByteCodeLine; + + {$IFDEF PAX64} + _ESP := GetRSP(); + {$ELSE} + asm + mov _ESP, esp + end; + {$ENDIF} + + fESP0 := _ESP; + +{$IFDEF PCU_EX} + RootProg.fESP0 := fESP0; +{$ENDIF} + + if EPoint = nil then + begin + P := P0; + + {$IFDEF PAX64} + AssignSegmentsAndCall(D, P); + {$ELSE} + asm + mov esi, D + mov edi, P +{$IFDEF MACOS} + add esp, - $0c +{$ENDIF} + call P + +{$IFDEF MACOS} + add esp, $0c +{$ENDIF} + end; + {$ENDIF} + end + else + begin + if not EPoint.IsInternal then + EPoint.Setup; + + PEpoint := EPoint; + +// P := ShiftPointer(EPoint.Address, 14); + P := EPoint.Address; + + {$IFDEF PAX64} + AssignSegments(D, P0); + Assign_R14(EPoint); + Assign_R15(P); + Call_R15; + EPoint.SaveResult; + {$ELSE} + asm + mov esi, D + mov edi, P0 + end; + + if EPoint.IsInternal then + EPoint.PushArgumentsBackward + else + EPoint.PushArguments; + + asm + call P + end; + + asm + mov ebx, PEpoint + + cmp ebx, 0 + jz @@Return + + // if call convention is cdecl then pop arguments + mov ecx, [ebx + 28] // fCallConv + cmp ecx, ccCDECL + jnz @@Ret + mov ecx, [ebx + 8] // fStackSize + add esp, ecx + + @@Ret: + + mov ecx, [ebx + 32] // fResultType + + cmp ecx, typeINTEGER + jnz @@RetDOUBLE + mov ecx, [ebx + 28] // fCallConv + cmp ecx, ccSAFECALL + jz @@Return + mov [ebx + INVOKE_RESULT_OFFSET], eax + jmp @@Return + // + + @@RetDOUBLE: + + cmp ecx, typeDOUBLE + jnz @@RetSINGLE + fstp qword ptr [ebx + INVOKE_RESULT_OFFSET] + jmp @@Return + // + + @@RetSINGLE: + + cmp ecx, typeSINGLE + jnz @@RetEXTENDED + fstp dword ptr [ebx + INVOKE_RESULT_OFFSET] + jmp @@Return + // + + @@RetEXTENDED: + + cmp ecx, typeEXTENDED + jnz @@RetCURRENCY + fstp tbyte ptr [ebx + INVOKE_RESULT_OFFSET] + jmp @@Return + // + + @@RetCURRENCY: + + cmp ecx, typeCURRENCY + jnz @@RetINT64 + fistp qword ptr [ebx + INVOKE_RESULT_OFFSET] + jmp @@Return + // + + @@RetINT64: + cmp ecx, typeINT64 + jnz @@Return + mov [ebx + INVOKE_RESULT_OFFSET], eax + mov [ebx + INVOKE_RESULT_OFFSET + 4], edx + + @@Return: + end; + {$ENDIF} + + end; + end; + except + on E: Exception do + begin + if fTryStack.Count > 0 then + begin + TryBlockNumber := fTryStack.Top.TryBlockNumber; + SelfPtr := fTryStack.Top.Prog; + end + else + begin + SelfPtr := Self; + TryBlockNumber := 0; + end; + + with SelfPtr do + begin + D := Data; + P0 := Prog; + SourceLine := GetSourceLine; + ModuleName := GetModuleName; + end; + + IsExitException := E is PaxExitException; + IsPauseException := E is TPauseException; + IsHaltException := (E is THaltException) or + ((E is EAbort) and (not IsPauseException) and (not IsExitException)); + + IsHalted := IsHaltException; + + HasError := true; + + if E is THaltException then + ExitCode := (E as THaltException).ExitCode; + + with SelfPtr do + if RootTryStack.Count > 0 then + if (not IsPauseException) and (not IsHaltException) and + (TryBlockNumber >= 0) and (TryBlockNumber < TryList.Count) then + begin +// TryRec := TryList[TryBlockNumber]; + TryRec := fTryStack.Top.TR; + _EBP := TryRec._EBP; + _ESP := TryRec._ESP; + + K := TryRec.StackFrameSize div 4; + StackFrame := TryRec.StackFrame; + StackFrameSize := TryRec.StackFrameSize; + + if TryRec.TryKind = tryFinally then + begin + ProcessingExceptBlock := false; + if SourceLineFinally = -1 then + begin + SourceLineFinally := GetSourceLine; + ModuleNameFinally := GetModuleName; + end; + end + else + begin + ProcessingExceptBlock := true; + HandledByExcept := true; + end; + + if TryRec.ExceptOnInfo.Count = 0 then + ProgOffset := TryRec.ProgOffset + else + begin + for I:=0 to TryRec.ExceptOnInfo.Count - 1 do + begin + ClsIndex := TryRec.ExceptOnInfo.Keys[I]; + ProgOffset := TryRec.ExceptOnInfo.Values[I]; + if ClsIndex >= 0 then + begin + ClassRec := ClassList[ClsIndex]; + if ClassRec.PClass <> nil then + begin + if E is ClassRec.PClass then + break; + + if StrEql(ClassRec.PClass.ClassName, 'TJS_Object') then + break; + end; + end; + end; + end; + + Handled := true; + end; + + if Assigned(fCurrException) then + FreeAndNil(fCurrException); + + fPrevException := nil; + + if (not IsPauseException) and (not IsHaltException) then + begin + IntPax(CE) := IntPax(E.ClassType); + fCurrException := CE.Create(E.Message); + + if Assigned(OnCustomExceptionHelper) then + OnCustomExceptionHelper(Owner, E, fCurrException); + end; + + end; // on: E Exception + else + begin + // custom exception + end; + end; // try + + RuntimeModuleList.TempBreakpoint.Clear; + + if Handled then + begin + if Assigned(OnException) and RootExceptionIsAvailableForHostApplication then + if HandledByExcept then + OnException(Owner, fCurrException, ModuleName, SourceLine); + RootExceptionIsAvailableForHostApplication := true; + goto Again; + end + else + begin + IsRunning := false; + + if (not SuspendFinalization) and (ProgTag <> 1) then + fGC.ClearObjects; + + if HasError then + begin + if Assigned(OnHalt) and IsHaltException then + begin + OnHalt(Owner, ExitCode, ModuleName, SourceLine); + RootExceptionIsAvailableForHostApplication := true; + fPauseRec.Clear; + ClearCurrException; + Exit; + end + else if Assigned(OnPause) and IsPauseException then + begin + OnPause(Owner, ModuleName, SourceLine); + RootExceptionIsAvailableForHostApplication := true; + ClearCurrException; + Exit; + end; + + if Assigned(OnUnhandledException) then + if fCurrException <> nil then + if RootExceptionIsAvailableForHostApplication then + begin + if SourceLineFinally = -1 then + OnUnhandledException(Owner, fCurrException, ModuleName, SourceLine) + else + OnUnhandledException(Owner, fCurrException, ModuleNameFinally, SourceLineFinally); + end; + RootExceptionIsAvailableForHostApplication := true; + end; + end; + ClearCurrException; +end; + +{$O-} +procedure TProgram.RunInternal; +begin + Run; +end; + +procedure TProgram.RunInitialization; +var + P: Pointer; +begin + if InitializationIsProcessed then + Exit; + + Protect; + + if fGC = RootGC then + fGC.Clear; + + ProgList.RunInitialization; + + P := ShiftPointer(Data, H_InitOnly); + LongInt(P^) := 2; + try + ProgTag := 1; + Run; + InitMessageList; + finally + ProgTag := 0; + LongInt(P^) := 0; + InitializationIsProcessed := true; + InitialOffset := GetInitializationOffset(CodePtr, CodeSize, PAX64); + end; +end; + +procedure TProgram.RunExceptInitialization; +var + P: Pointer; +begin + if InitialOffset <= 0 then + InitialOffset := GetInitializationOffset(CodePtr, CodeSize, PAX64); + if InitialOffset = -1 then + Exit; + + P := ShiftPointer(Data, H_BodyOnly); + if SuspendFinalization then + LongInt(P^) := 3 + else + LongInt(P^) := 0; + + EPoint := nil; + + P := ShiftPointer(CodePtr, 1); + Move(InitialOffset, P^, 4); + try + Run; + finally + LongInt(P^) := 0; + end; +end; + +procedure TProgram.RunFinalization; +var + P: Pointer; + Offset: Integer; +begin + if CodePtr = nil then + Exit; + + ProgList.RunFinalization; + + Offset := GetFinalizationOffset(CodePtr, CodeSize, PAX64); + if Offset = -1 then + Exit; + + EPoint := nil; + + P := ShiftPointer(CodePtr, 1); + Move(Offset, P^, 4); + try + Run; + finally + InitializationIsProcessed := false; + + LongInt(P^) := 0; + Unprotect; + end; +end; + +procedure TProgram.SaveState(S: TStream); +var + K: Integer; +begin + S.Write(DataPtr^, DataSize); + fCallStack.SaveToStream(S); + + K := fTryStack.Count; + S.Write(K, SizeOf(Integer)); + +// fTryStack.SaveToStream(S); +end; + +procedure TProgram.LoadState(S: TStream); +var + K: Integer; +begin + S.Read(DataPtr^, DataSize); + fCallStack.Clear; + fCallStack.LoadFromStream(S); + + S.Read(K, SizeOf(Integer)); + while fTryStack.Count > K do + fTryStack.Pop; + +// fTryStack.LoadFromStream(S); +end; + +{$IFDEF PAX64} +procedure TProgram.PushPtrs; +{$IFDEF FPC} +nostackframe; asm +{$ELSE} +asm + .NOFRAME +{$ENDIF} + mov rcx, [rsp] + push rcx + push rcx + + mov rdx, [rax + 8] + mov [rsp + 8], rdx + + mov rdx, [rax + 8 + 8] + mov [rsp + 8 + 8], rdx +end; +{$ELSE} +procedure TProgram.PushPtrs; assembler; +{$IFDEF FPC} +nostackframe; asm +{$ELSE} +asm +{$ENDIF} + mov ecx, [esp] + push ecx + push ecx + + mov edx, [eax + 4] + mov [esp + 4], edx + + mov edx, [eax + 8] + mov [esp + 8], edx +end; +{$ENDIF} + +function TProgram.GetProgramSize: Integer; +begin + result := DataSize + CodeSize + 2; +end; + +procedure TProgram.DiscardDebugMode; +begin + PAXCOMP_DISASM.DiscardDebugMode(CodePtr, CodeSize, PAX64); +end; + +{$IFDEF PAX64} +procedure Call_M_2(Code, Data: Pointer); assembler; +asm + CALL RCX +end; +procedure Call_M(M: TMethod); +begin + Call_M_2(M.Code, M.Data); +end; +{$ENDIF} + +{$IFDEF PAX64} +procedure TProgram.RunEx; +var + M: TMethod; +begin + M := OwnerEventHandlerMethod; + if Assigned(M.Code) then + begin + Call_M(M); + end + else + Run; +end; +{$ELSE} +procedure TProgram.RunEx; +var + M: TMethod; +begin + M := OwnerEventHandlerMethod; + if Assigned(M.Code) then + begin + asm + MOV EAX,DWORD PTR M.Data; + CALL M.Code; + end; + end + else + Run; +end; +{$ENDIF} + +procedure TProgram.DoOnReaderFindMethod( + Reader: TReader; + const MethodName: string; + var Address: Pointer; + var Error: Boolean); +Var + aFullName: String; + ER: TEventHandlerRec; + MR: TMapRec; + M: TMethod; +begin + aFullName := ProgTypeInfoList.FindMethodFullName(Address); + Address := GetAddress(aFullName, MR); + M.Code := Address; + M.Data := gInstance; + Error := Address = Nil; + + ER := EventHandlerList.Add(Self, + M.Code, M.Data, + GetCallConv(aFullName), + GetRetSize(aFullName)); + + M.Code := @ TEventHandlerRec.Invoke; + M.Data := ER; + +// Address := nil; +end; + +procedure TProgram.RebindEvents(AnInstance: TObject); + + procedure _RebindEvents(Instance: TObject); + var + pti, PropType: PTypeInfo; + ptd: PTypeData; + Loop, nProps: Integer; + pProps: PPropList; + ppi: PPropInfo; + M: TMethod; + C: TComponent; + I: Integer; + aFullName: String; + ER: TEventHandlerRec; + begin + pti := Instance.ClassInfo; + if pti = nil then Exit; + ptd := GetTypeData(pti); + nProps := ptd^.PropCount; + if nProps > 0 then + begin + GetMem(pProps, SizeOf(PPropInfo) * nProps); + GetPropInfos(pti, pProps); + + for Loop:=0 to nProps - 1 do + begin + {$ifdef fpc} + ppi := pProps^[Loop]; + PropType := PPropInfo(ppi)^.PropType; + {$else} + ppi := pProps[Loop]; + PropType := PPropInfo(ppi)^.PropType^; + {$endif} + if PropType^.Kind = tkMethod then + begin + M := GetMethodProp(Instance, ppi); + if Assigned(M.Code) and Assigned(M.Data) then + begin + aFullName := ProgTypeInfoList.FindMethodFullName(M.Code); + + if AFullName = '' then + continue; + + ER := EventHandlerList.Add(Self, + M.Code, + M.Data, + GetCallConv(aFullName), + GetRetSize(aFullName)); + + M.Code := @ TEventHandlerRec.Invoke; + M.Data := ER; + + SetMethodProp(Instance, ppi, M); + end; + end; + end; + FreeMem(pProps, SizeOf(PPropInfo) * nProps); + end; + + if Instance is TComponent then + begin + C := TComponent(Instance); + for I := 0 to C.ComponentCount - 1 do + _RebindEvents(C.Components[I]); + end; + end; +begin + _RebindEvents(AnInstance); +end; + +{$IFDEF PAX64} +procedure ZZZ; assembler; +{$IFDEF FPC} +nostackframe; asm +{$ELSE} +asm + .NOFRAME +{$ENDIF} + pop rsi; + jmp rsi; +end; +{$ELSE} +procedure ZZZ; +{$IFDEF FPC} +nostackframe; asm +{$ELSE} +asm +{$ENDIF} + pop esi; + jmp esi; +end; +{$ENDIF} + +function TProgram.CallFunc(const FullName: String; + This: Pointer; + const ParamList: array of OleVariant; + OverCount: Integer = 0): OleVariant; +const + MaxParam = 30; +var + Invoke, OldEPoint: TInvoke; + Address: Pointer; + MR: TMapRec; + OldESP0, I, NP, T: Integer; + Value: OleVariant; +{$IFNDEF PAXARM} + AnsiStrings: array [0..MaxParam] of AnsiString; + WideStrings: array [0..MaxParam] of WideString; + ShortStrings: array [0..MaxParam] of ShortString; + AnsiS: AnsiString; +{$ENDIF} + UnicStrings: array [0..MaxParam] of UnicString; + valueDouble: Double; + valueSingle: Single; + valueExtended: Extended; + valueCurrency: Currency; + UnicS: UnicString; +begin + Address := GetAddressEx(FullName, OverCount, MR); + if Address = nil then + RaiseError(errRoutineNotFound, [FullName]); + + NP := MR.SubDesc.ParamList.Count; + if NP > System.Length(ParamList) then + RaiseError(errNotEnoughActualParameters, []) + else if NP < System.Length(ParamList) then + RaiseError(errTooManyActualParameters, []); + + Invoke := TInvoke.Create; + Invoke.CallConv := MR.SubDesc.CallConv; + if MR.SubDesc.ResTypeId in + (OrdinalTypes + [typeCLASS, typeCLASSREF, typePOINTER, typePROC, typeINTERFACE]) then + Invoke.SetResType(typeINTEGER) + else + Invoke.SetResType(MR.SubDesc.ResTypeId); + Invoke.SetResSize(MR.SubDesc.RetSize); + + Invoke.Address := Address; + Invoke.SetThis(This); + + for I := 0 to NP - 1 do + begin + T := MR.SubDesc.ParamList[I].FinTypeId; + value := ParamList[I]; + case T of + typeVOID: Invoke.AddArg(value, typeINTEGER); + typeBOOLEAN: Invoke.AddArg(value, typeINTEGER); + typeBYTE: Invoke.AddArg(value, typeINTEGER); +{$IFNDEF PAXARM} + typeANSICHAR: Invoke.AddArg(value, typeINTEGER); + typeANSISTRING: + begin + AnsiStrings[I] := AnsiString(value); + Invoke.AddArg(IntPax(AnsiStrings[I]), typeINTEGER); + end; + typeSHORTSTRING: + begin + ShortStrings[I] := ShortString(value); + Invoke.AddArg(LongInt(@ShortStrings[I]), typeINTEGER); + end; + typeWIDESTRING: + begin + WideStrings[I] := value; + Invoke.AddArg(IntPax(WideStrings[I]), typeINTEGER); + end; +{$ENDIF} + typeWORD: Invoke.AddArg(value, typeINTEGER); + typeINTEGER: Invoke.AddArg(value, typeINTEGER); + typeDOUBLE: + begin + valueDouble := value; + Invoke.AddArgByVal(valueDouble, SizeOf(Double)); + end; + typePOINTER: Invoke.AddArg(LongInt(value), typeINTEGER); + typeRECORD: Invoke.AddArg(LongInt(value), typeINTEGER); + typeARRAY: Invoke.AddArg(LongInt(value), typeINTEGER); + typeALIAS: Invoke.AddArg(LongInt(value), typeINTEGER); + typeENUM: Invoke.AddArg(LongInt(value), typeINTEGER); + typePROC: Invoke.AddArg(LongInt(value), typeINTEGER); + typeSET: Invoke.AddArg(LongInt(value), typeINTEGER); + typeSINGLE: + begin + valueSingle := value; + Invoke.AddArgByVal(valueSingle, SizeOf(Single)); + end; + typeEXTENDED: + begin + valueExtended := value; + Invoke.AddArgByVal(valueExtended, SizeOf(Extended)); + end; + typeCLASS: Invoke.AddArg(LongInt(value), typeINTEGER); + typeCLASSREF: Invoke.AddArg(LongInt(value), typeINTEGER); + typeWIDECHAR: Invoke.AddArg(LongInt(value), typeINTEGER); + typeVARIANT: + begin + if MR.SubDesc.ParamList[I].ParamMod = PM_BYVAL then + Invoke.AddArg(value, typeVARIANT) + else + Invoke.AddArg(LongInt(@ParamList[I]), typeINTEGER); + end; + typeDYNARRAY: Invoke.AddArg(LongInt(value), typeINTEGER); + typeINT64: Invoke.AddArgByVal(value, SizeOf(Int64)); + typeINTERFACE: Invoke.AddArg(LongInt(value), typeINTEGER); + typeCARDINAL: Invoke.AddArg(LongInt(value), typeINTEGER); + typeEVENT: Invoke.AddArg(LongInt(value), typeINTEGER); + typeCURRENCY: + begin + valueCurrency := value; + Invoke.AddArgByVal(valueCurrency, SizeOf(Single)); + end; + typeSMALLINT: Invoke.AddArg(LongInt(value), typeINTEGER); + typeSHORTINT: Invoke.AddArg(LongInt(value), typeINTEGER); + typeWORDBOOL: Invoke.AddArg(LongInt(value), typeINTEGER); + typeLONGBOOL: Invoke.AddArg(LongInt(value), typeINTEGER); + typeBYTEBOOL: Invoke.AddArg(LongInt(value), typeINTEGER); + typeOLEVARIANT: Invoke.AddArg(value, typeVARIANT); + typeUNICSTRING: + begin + UnicStrings[I] := value; + Invoke.AddArg(IntPax(UnicStrings[I]), typeINTEGER); + end; + end; + end; + + OldEPoint := EPoint; + OldESP0 := fESP0; + + try + Invoke.SetUp; + EPoint := Invoke; + + Run; + + finally + + Address := EPoint.GetResultPtr; + + fESP0 := OldESP0; + EPoint := OldEPoint; + FreeAndNil(Invoke); + end; + + case MR.SubDesc.ResTypeId of + typeVOID: result := Unassigned; + typeBOOLEAN: result := Boolean(Address^); + typeBYTE: result := Byte(Address^); +{$IFNDEF PAXARM} + typeANSICHAR: result := AnsiChar(Address^); + typeANSISTRING: + begin + AnsiS := AnsiString(Address^); + if Length(AnsiS) > 0 then + begin + Address := StrRefCountPtr(Pointer(AnsiS)); + Integer(Address^) := Integer(Address^) - 1; + end; + result := AnsiS; + end; + typeSHORTSTRING: result := ShortString(Address^); + typeWIDESTRING: result := WideString(Address^); +{$ENDIF} + typeWORD: result := Word(Address^); + typeINTEGER: result := LongInt(Address^); + typeDOUBLE: result := Double(Address^); + typePOINTER: result := LongInt(Address^); + typeRECORD: result := LongInt(Address); + typeARRAY: result := LongInt(Address); + typeALIAS: result := Unassigned; + typeENUM: result := Byte(Address^); + typePROC: result := LongInt(Address^); + typeSET: result := LongInt(Address^); + typeSINGLE: result := Single(Address^); + typeEXTENDED: result := Extended(Address^); + typeCLASS: result := LongInt(Address^); + typeCLASSREF: result := LongInt(Address^); + typeWIDECHAR: result := WideChar(Address^); + typeVARIANT: result := Variant(Address^); + typeDYNARRAY: result := LongInt(Address^); + typeINT64: result := Integer(Address^); + typeINTERFACE: result := LongInt(Address^); +{$IFDEF VARIANTS} + typeCARDINAL: result := Cardinal(Address^); +{$ELSE} + typeCARDINAL: result := LongInt(Address^); +{$ENDIF} + typeEVENT: result := Unassigned; + typeCURRENCY: result := Currency(Address^); + typeSMALLINT: result := SmallInt(Address^); + typeSHORTINT: result := ShortInt(Address^); + typeWORDBOOL: result := WordBool(Address^); + typeLONGBOOL: result := LongBool(Address^); + typeBYTEBOOL: result := ByteBool(Address^); + typeOLEVARIANT: result := OleVariant(Address^); + typeUNICSTRING: + begin + UnicS := UnicString(Address^); + if Length(UnicS) > 0 then + begin + Address := StrRefCountPtr(Pointer(UnicS)); + Integer(Address^) := Integer(Address^) - 1; + end; + result := UnicS; + end; + else + result := Integer(Address^); + end; + + if IsHalted then + raise THaltException.Create(ExitCode); +end; + +function TProgram.CallFuncEx(const FullName: String; + This: Pointer; + const ParamList: array of const; + IsConstructor: Boolean = false; + OverCount: integer = 0): Variant; +const + MaxParam = 30; +var + Invoke, OldEPoint: TInvoke; + Address: Pointer; + MR: TMapRec; + OldESP0, I, NP, T: Integer; +{$IFNDEF PAXARM} + AnsiStrings: array [0..MaxParam] of AnsiString; + ShortStrings: array [0..MaxParam] of ShortString; + WideStrings: array [0..MaxParam] of WideString; +{$ENDIF} + UnicStrings: array [0..MaxParam] of UnicString; + valueDouble: Double; + valueSingle: Single; + valueExtended: Extended; + valueCurrency: Currency; + valueInt64: Int64; +begin + Address := GetAddressEx(FullName, OverCount, MR); + if Address = nil then + RaiseError(errRoutineNotFound, [FullName]); + + NP := MR.SubDesc.ParamList.Count; + if NP > System.Length(ParamList) then + RaiseError(errNotEnoughActualParameters, []) + else if NP < System.Length(ParamList) then + RaiseError(errTooManyActualParameters, []); + + Invoke := TInvoke.Create; + Invoke.CallConv := MR.SubDesc.CallConv; + if MR.SubDesc.ResTypeId in + (OrdinalTypes + [typeCLASS, typeCLASSREF, typePOINTER, typePROC, typeINTERFACE]) then + Invoke.SetResType(typeINTEGER) + else + Invoke.SetResType(MR.SubDesc.ResTypeId); + Invoke.SetResSize(MR.SubDesc.RetSize); + + Invoke.Address := Address; + Invoke.SetThis(This); + + if IsConstructor then + Invoke.AddArg(1, typeINTEGER); // EDX + + for I := 0 to NP - 1 do + begin + T := MR.SubDesc.ParamList[I].FinTypeId; + case T of + typeVOID: Invoke.AddArg(ParamList[I].VInteger, typeINTEGER); + typeBOOLEAN: Invoke.AddArg(ParamList[I].VBoolean, typeINTEGER); + typeBYTE: Invoke.AddArg(ParamList[I].VInteger, typeINTEGER); +{$IFNDEF PAXARM} + typeANSICHAR: Invoke.AddArg(ParamList[I].VChar, typeINTEGER); + typeANSISTRING: + begin + case ParamList[I].VType of + vtString: AnsiStrings[I] := + PShortString(ParamList[I].VString)^; + vtAnsiString: AnsiStrings[I] := + PAnsiString(ParamList[I].VAnsiString)^; + vtWideString: AnsiStrings[I] := + AnsiString(PWideString(ParamList[I].VWideString)^); + {$IFDEF UNIC} + vtUnicodeString: AnsiStrings[I] := + AnsiString(PUnicodeString(ParamList[I].VUnicodeString)^); + {$ENDIF} + vtVariant: AnsiStrings[I] := + AnsiString(PVariant(ParamList[I].VVariant)^); + vtChar: AnsiStrings[I] := + ParamList[I].VChar; + vtWideChar: AnsiStrings[I] := + AnsiChar(ParamList[I].VWideChar); + end; + Invoke.AddArg(IntPax(AnsiStrings[I]), typeINTEGER); + end; + typeSHORTSTRING: + begin + case ParamList[I].VType of + vtString: ShortStrings[I] := + PShortString(ParamList[I].VString)^; + vtAnsiString: ShortStrings[I] := + PAnsiString(ParamList[I].VAnsiString)^; + vtWideString: ShortStrings[I] := + ShortString(PWideString(ParamList[I].VWideString)^); + {$IFDEF UNIC} + vtUnicodeString: ShortStrings[I] := + AnsiString(PUnicodeString(ParamList[I].VUnicodeString)^); + {$ENDIF} + vtVariant: ShortStrings[I] := + ShortString(PVariant(ParamList[I].VVariant)^); + vtChar: ShortStrings[I] := + ParamList[I].VChar; + vtWideChar: ShortStrings[I] := + AnsiChar(ParamList[I].VWideChar); + end; + Invoke.AddArg(LongInt(@ShortStrings[I]), typeINTEGER); + end; + typeWIDESTRING: + begin + case ParamList[I].VType of + vtString: WideStrings[I] := + WideString(PShortString(ParamList[I].VString)^); + vtAnsiString: WideStrings[I] := + WideString(PAnsiString(ParamList[I].VAnsiString)^); + vtWideString: WideStrings[I] := + PWideString(ParamList[I].VWideString)^; + {$IFDEF UNIC} + vtUnicodeString: WideStrings[I] := + PUnicodeString(ParamList[I].VUnicodeString)^; + {$ENDIF} + vtVariant: WideStrings[I] := + PVariant(ParamList[I].VVariant)^; + vtChar: WideStrings[I] := + WideChar(ParamList[I].VChar); + vtWideChar: WideStrings[I] := + ParamList[I].VWideChar; + vtPWideChar: WideStrings[I] := + ParamList[I].VPWideChar; + end; + Invoke.AddArg(IntPax(WideStrings[I]), typeINTEGER); + end; +{$ENDIF} + typeWORD: Invoke.AddArg(ParamList[I].VInteger, typeINTEGER); + typeINTEGER: Invoke.AddArg(ParamList[I].VInteger, typeINTEGER); + typeDOUBLE: + begin + valueDouble := ParamList[I].VExtended^; + Invoke.AddArgByVal(valueDouble, SizeOf(Double)); + end; + typePOINTER: Invoke.AddArg(LongInt(ParamList[I].VPointer), typeINTEGER); + typeRECORD: Invoke.AddArg(LongInt(ParamList[I].VPointer), typeINTEGER); + typeARRAY: Invoke.AddArg(LongInt(ParamList[I].VPointer), typeINTEGER); + typeALIAS: Invoke.AddArg(ParamList[I].VInteger, typeINTEGER); + typeENUM: Invoke.AddArg(ParamList[I].VInteger, typeINTEGER); + typePROC: Invoke.AddArg(LongInt(ParamList[I].VPointer), typeINTEGER); + typeSET: Invoke.AddArg(ParamList[I].VInteger, typeINTEGER); + typeSINGLE: + begin + valueSingle := ParamList[I].VExtended^; + Invoke.AddArgByVal(valueSingle, SizeOf(Single)); + end; + typeEXTENDED: + begin + valueExtended := ParamList[I].VExtended^; + Invoke.AddArgByVal(valueExtended, SizeOf(Extended)); + end; + typeCLASS: Invoke.AddArg(LongInt(ParamList[I].VObject), typeINTEGER); + typeCLASSREF: Invoke.AddArg(LongInt(ParamList[I].VPointer), typeINTEGER); + typeWIDECHAR: Invoke.AddArg(LongInt(ParamList[I].VWideChar), typeINTEGER); + typeVARIANT: + begin + if MR.SubDesc.ParamList[I].ParamMod = PM_BYVAL then + Invoke.AddArg(ParamList[I].VVariant^, typeVARIANT) + else + Invoke.AddArg(LongInt(ParamList[I].VVariant), typeINTEGER); + end; + typeDYNARRAY: Invoke.AddArg(LongInt(ParamList[I].VPointer), typeINTEGER); + typeINT64: + case ParamList[i].VType of + vtInteger: begin + valueInt64 := Int64(ParamList[I].VInteger); + Invoke.AddArgByVal(valueInt64, SizeOf(Int64)); + end; + else + Invoke.AddArgByVal(ParamList[I].VInt64^, SizeOf(Int64)); + end; + typeINTERFACE: Invoke.AddArg(LongInt(ParamList[I].VInterface), typeINTEGER); + typeCARDINAL: Invoke.AddArg(ParamList[I].VInteger, typeINTEGER); + typeEVENT: Invoke.AddArg(ParamList[I].VInteger, typeINTEGER); + typeCURRENCY: + begin + valueCurrency := ParamList[I].VExtended^; + Invoke.AddArgByVal(valueCurrency, SizeOf(Single)); + end; + typeSMALLINT: Invoke.AddArg(ParamList[I].VInteger, typeINTEGER); + typeSHORTINT: Invoke.AddArg(ParamList[I].VInteger, typeINTEGER); + typeWORDBOOL: Invoke.AddArg(ParamList[I].VInteger, typeINTEGER); + typeLONGBOOL: Invoke.AddArg(ParamList[I].VInteger, typeINTEGER); + typeBYTEBOOL: Invoke.AddArg(ParamList[I].VInteger, typeINTEGER); + typeOLEVARIANT: + begin + if MR.SubDesc.ParamList[I].ParamMod = PM_BYVAL then + Invoke.AddArg(ParamList[I].VVariant^, typeVARIANT) + else + Invoke.AddArg(LongInt(ParamList[I].VVariant), typeINTEGER); + end; + typeUNICSTRING: + begin + case ParamList[I].VType of +{$IFNDEF PAXARM} + vtString: UnicStrings[I] := + UnicString(PShortString(ParamList[I].VString)^); + vtAnsiString: UnicStrings[I] := + UnicString(PAnsiString(ParamList[I].VAnsiString)^); + vtWideString: UnicStrings[I] := + PWideString(ParamList[I].VWideString)^; + vtChar: UnicStrings[I] := + WideChar(ParamList[I].VChar); +{$ENDIF} + {$IFDEF UNIC} + vtUnicodeString: UnicStrings[I] := + PUnicodeString(ParamList[I].VUnicodeString)^; + {$ENDIF} + vtVariant: UnicStrings[I] := + PVariant(ParamList[I].VVariant)^; + vtWideChar: UnicStrings[I] := + ParamList[I].VWideChar; + vtPWideChar: UnicStrings[I] := + ParamList[I].VPWideChar; + end; + Invoke.AddArg(IntPax(UnicStrings[I]), typeINTEGER); + end; + end; + end; + + OldEPoint := EPoint; + OldESP0 := fESP0; + + try + Invoke.SetUp; + EPoint := Invoke; + Run; + + finally + + Address := EPoint.GetResultPtr; + + fESP0 := OldESP0; + EPoint := OldEPoint; + FreeAndNil(Invoke); + end; + + case MR.SubDesc.ResTypeId of + typeVOID: result := Unassigned; + typeBOOLEAN: result := Boolean(Address^); + typeBYTE: result := Byte(Address^); +{$IFNDEF PAXARM} + typeANSICHAR: result := AnsiChar(Address^); + typeANSISTRING: result := AnsiString(Address^); + typeSHORTSTRING: result := ShortString(Address^); + typeWIDESTRING: result := WideString(Address^); +{$ENDIF} + typeWORD: result := Word(Address^); + typeINTEGER: result := LongInt(Address^); + typeDOUBLE: result := Double(Address^); + typePOINTER: result := LongInt(Address^); + typeRECORD: result := LongInt(Address); + typeARRAY: result := LongInt(Address); + typeALIAS: result := Unassigned; + typeENUM: result := Byte(Address^); + typePROC: result := LongInt(Address^); + typeSET: result := LongInt(Address^); + typeSINGLE: result := Single(Address^); + typeEXTENDED: result := Extended(Address^); + typeCLASS: result := LongInt(Address^); + typeCLASSREF: result := LongInt(Address^); + typeWIDECHAR: result := WideChar(Address^); + typeVARIANT: result := Variant(Address^); + typeDYNARRAY: result := LongInt(Address^); + typeINT64: result := LongInt(Address^); + typeINTERFACE: result := LongInt(Address^); +{$IFDEF VARIANTS} + typeCARDINAL: result := Cardinal(Address^); +{$ELSE} + typeCARDINAL: result := LongInt(Address^); +{$ENDIF} + typeEVENT: result := Unassigned; + typeCURRENCY: result := Currency(Address^); + typeSMALLINT: result := SmallInt(Address^); + typeSHORTINT: result := ShortInt(Address^); + typeWORDBOOL: result := WordBool(Address^); + typeLONGBOOL: result := LongBool(Address^); + typeBYTEBOOL: result := ByteBool(Address^); + typeOLEVARIANT: result := OleVariant(Address^); + typeUNICSTRING: result := UnicString(Address^); + else + result := LongInt(Address^); + end; + + if IsHalted then + raise THaltException.Create(ExitCode); +end; + +function TProgram.CreateScriptObject(const ScriptClassName: String; + const ParamList: array of const): TObject; +var + ClassIndex: Integer; + PClass: TClass; + MR: TMapRec; + NP: Integer; + V: Variant; +begin + result := nil; + + ClassIndex := ClassList.IndexOf(ScriptClassName); + + if ClassIndex = -1 then + RaiseError(errClassNotFound, [ScriptClassName]); + + PClass := ClassList[ClassIndex].PClass; + + NP := System.Length(ParamList); + MR := ScriptMapTable.LookupConstructor(ScriptClassName, NP); + + if MR = nil then + Exit; + + V := CallFuncEx(MR.FullName, PClass, ParamList, true, MR.SubDesc.OverCount); + result := TObject(TVarData(V).VInteger); +end; + +function TProgram.GetTryStack: TTryStack; +begin + result := RootProg.fTryStack; +end; + +function TProgram.GetCallStack: TCallStack; +begin + result := RootProg.fCallStack; +end; + +function TProgram.GetESP0: Integer; +begin + result := RootProg.fESP0; +end; + +procedure TProgram.SetESP0(value: Integer); +begin + RootProg.fESP0 := value; +end; + +function TProgram.GetCurrException: Exception; +begin + result := fCurrException; +end; + +procedure TProgram.SetCurrException(value: Exception); +begin + fCurrException := value; +end; + +function TProgram.GetVirtualAllocProg: Boolean; +begin + result := RootProg.fVirtualAllocProg; +end; + +procedure TProgram.SetVirtualAllocProg(value: Boolean); +begin + RootProg.fVirtualAllocProg := value; +end; + +function TProgram._VirtualAlloc(Address: Pointer; + Size, flAllocType, flProtect: Cardinal): Pointer; +begin +{$IFDEF MSWINDOWS} + if VirtualAllocProg then + result := VirtualAlloc(Address, Size, flAllocType, flProtect) + else + result := AllocMem(Size); +{$ELSE} + result := AllocMem(Size); +{$ENDIF} +end; + +procedure TProgram._VirtualFree(Address: Pointer; Size: Cardinal); +begin +{$IFDEF MSWINDOWS} + if VirtualAllocProg then + VirtualFree(Address, 0, MEM_RELEASE) + else + FreeMem(Address, Size); +{$ELSE} + FreeMem(Address, Size); +{$ENDIF} +end; + +function TProgram.GetRootProg: TProgram; +begin + result := Self; + while result.PCUOwner <> nil do + result := result.PCUOwner as TProgram; +end; + +function TProgram.GetCallStackCount: Integer; +begin + result := RootCallStack.Count; +end; + +function TProgram.GetCallStackItem(I: Integer): Integer; +begin + if (I >= 0) and (I < GetCallStackCount) then + result := RootCallStack[I].SubId + else + result := 0; +end; + +function TProgram.GetCallStackLineNumber(I: Integer): Integer; +var + N: Integer; +begin + if (I >= 0) and (I < GetCallStackCount) then + begin + N := RootCallStack[I].NCall; + if N = -1 then + begin + N := GetByteCodeLine; + RootCallStack[I].NCall := N; + end; + + result := RunTimeModuleList.GetSourceLine(N); + end + else + result := 0; +end; + +function TProgram.GetCallStackModuleName(I: Integer): String; +var + N: Integer; +begin + result := ''; + if (I >= 0) and (I < GetCallStackCount) then + begin + N := RootCallStack[I].NCall; + if N = - 1 then + Exit; + result := RunTimeModuleList.GetModuleName(N); + end; +end; + +function TProgram.GetCallStackModuleIndex(I: Integer): Integer; +var + N: Integer; +begin + result := -1; + if (I >= 0) and (I < GetCallStackCount) then + begin + N := RootCallStack[I].NCall; + if N = - 1 then + Exit; + result := RunTimeModuleList.GetModuleIndex(N); + end; +end; + +procedure TProgram.DiscardPause; +begin + PauseRec.ProgOffset := 0; +end; + +procedure TProgram.SetEntryPoint(EntryPoint: TPaxInvoke); +begin + if EntryPoint = nil then + EPoint := nil + else + begin + EPoint := TInvoke(EntryPoint.GetImplementation); + TInvoke(EntryPoint.GetImplementation).OldESP0 := RootESP0; + end; +end; + +procedure TProgram.ResetEntryPoint(EntryPoint: TPaxInvoke); +begin + if EntryPoint = nil then + Exit + else + RootESP0 := TInvoke(EntryPoint.GetImplementation).OldESP0; +end; + +procedure TProgram.AssignEventHandlerRunner(MethodAddress: Pointer; + Instance: TObject); +begin + OwnerEventHandlerMethod.Code := MethodAddress; + OwnerEventHandlerMethod.Data := Instance; +end; + +function TProgram.GetDestructorAddress: Pointer; +begin + result := Address_DestroyObject; +end; + +function TProgram.GetParamAddress(Offset: Integer): Pointer; +var + EBP_Value: IntPax; +begin + EBP_Value := RootCallStack.Top.EBP; + result := PauseRec.GetPtr(EBP_Value, Offset); +end; + +function TProgram.GetLocalAddress(Offset: Integer): Pointer; +var + EBP_Value: IntPax; +begin + EBP_Value := RootCallStack.Top.EBP; + result := PauseRec.GetPtr(EBP_Value, Offset); +end; + +function TProgram.GetParamAddress(StackFrameNumber, Offset: Integer): Pointer; +var + EBP_Value: IntPax; +begin + result := nil; + + if StackFrameNumber >= 0 then + EBP_Value := RootCallStack[StackFrameNumber].EBP + else + Exit; + + result := PauseRec.GetPtr(EBP_Value, Offset); +end; + +function TProgram.GetLocalAddress(StackFrameNumber, Offset: Integer): Pointer; +var + EBP_Value: IntPax; +begin + result := nil; + + if StackFrameNumber >= 0 then + EBP_Value := RootCallStack[StackFrameNumber].EBP + else + Exit; + + result := PauseRec.GetPtr(EBP_Value, Offset); +end; + +end. + diff --git a/Sources/PAXCOMP_PROGLIB.pas b/Sources/PAXCOMP_PROGLIB.pas new file mode 100644 index 0000000..7224d4c --- /dev/null +++ b/Sources/PAXCOMP_PROGLIB.pas @@ -0,0 +1,893 @@ +////////////////////////////////////////////////////////////////////////// +// PaxCompiler +// Site: http://www.paxcompiler.com +// Author: Alexander Baranovsky (paxscript@gmail.com) +// ======================================================================== +// Copyright (c) Alexander Baranovsky, 2006-2014. All rights reserved. +// Code Version: 4.2 +// ======================================================================== +// Unit: PAXCOMP_PROGLIB.pas +// ======================================================================== +//////////////////////////////////////////////////////////////////////////// + +{$I PaxCompiler.def} +{$O-} +{$R-} +unit PAXCOMP_PROGLIB; +interface + +procedure AssignRunnerLib; + +implementation + +uses {$I uses.def} + SysUtils, + Classes, + TypInfo, + PAXCOMP_BASERUNNER, + PAXCOMP_CONSTANTS, + PAXCOMP_TYPES, + PAXCOMP_SYS, + PAXCOMP_PROG, + PAXCOMP_MAP, + PAXCOMP_CLASSLST, + PAXCOMP_SEH, + PAXCOMP_EVENT, + PAXCOMP_STDLIB, + PAXCOMP_TRYLST; + +procedure _Exit(Runner: TBaseRunner; Level: Integer; em: TExitMode); stdcall; +var + E: PaxExitException; + TryRec: TTryRec; + EstablisherFrame: PPaxExcFrame; + P: TProgram; +begin + P := TProgram(Runner); + if P.ModeSEH then + begin +{$IFDEF PAX64} +{$ELSE} + asm + mov eax, fs:[0] + mov EstablisherFrame, eax + end; + while EstablisherFrame^.Magic <> PAX_SEH do + EstablisherFrame := EstablisherFrame^.Next; + asm + mov eax, EstablisherFrame + mov fs:[0], eax + end; +{$ENDIF} + end; + P.ClearCurrException; + + E := PaxExitException.Create(''); + E.Mode := em; + P.ExitLevelId := Level; + P.RootExceptionIsAvailableForHostApplication := false; + + if P.ModeSEH then + begin + raise E; + end; + + if P.RootTryStack.Count > 0 then + begin + TryRec := P.RootTryStack.Top.TR; + while TryRec.TryKind <> tryFinally do + begin + P.RootTryStack.Pop; + if P.RootTryStack.Count > 0 then + TryRec := P.RootTryStack.Top.TR + else + raise E; + end; + + TryRec.SaveStackFrame; + end; + + raise E; +end; + +procedure _CondRaise(P: TProgram; var IsExit: Byte; + SubId: Integer; + LastCondRaise: Integer; + CurrESP: Integer + ); stdcall; +var + E: Exception; + CE: TExceptionClass; + I, K, LevelId: Integer; + Temp1: Integer; + Temp2: Pointer; + EstablisherFrame: PPaxExcFrame; + em: TExitMode; +begin + IsExit := 0; + em := emExit; + + if P.ProcessingExceptBlock then + Exit; + + Dec(P.RootProg.FinallyCount); + if P.RootProg.FinallyCount <> 0 then + Exit; + + if P.CurrException <> nil then + begin + if P.CurrException is PaxExitException then + begin + em := (P.CurrException as PaxExitException).Mode; + IsExit := 1; + if em = emBreak then + IsExit := 2; + if em = emContinue then + IsExit := 3; + end; + + if P.ModeSEH then + begin +{$IFDEF PAX64} +{$ELSE} + asm + MOV EAX, DWORD PTR FS:[0] + mov EstablisherFrame, eax + end; +{$ENDIF} + if IsExit > 0 then + begin + if LastCondRaise = 1 then + begin + P.RootExceptionIsAvailableForHostApplication := true; + P.CurrException.Free; + P.CurrException := nil; + Exit; + end; + end; + + if (EstablisherFrame <> nil ) and (EstablisherFrame^.Magic <> PAX_SEH) and (LastCondRaise = 1) then + begin + IntPax(CE) := IntPax(P.CurrException.ClassType); + E := CE.Create(P.CurrException.Message); + P.CurrException.Free; + P.CurrException := nil; + P.fPrevException := E; + end + else + E := P.CurrException; + + raise E; + end; + + if IsExit > 0 then + begin + K := 0; + if P.RootTryStack.Count > 0 then + begin + LevelId := P.ExitLevelId; + + for I := P.RootTryStack.Count - 1 downto 0 do + begin + if P.RootTryStack[I].Prog <> P then + continue; + + if P.TryList[P.RootTryStack[I].TryBlockNumber].Level = LevelId then + Inc(K) + else + begin + P.RootTryStack.Pop; + + P.ExitLevelId := 0; + P.CurrException.Free; + P.CurrException := nil; + + Exit; + end; + end; + end; + + if K = 0 then + Exit + else if K = 1 then + begin + if P.RootTryStack.Count > 0 then + P.RootTryStack.Pop; + + P.ExitLevelId := 0; + P.CurrException.Free; + P.CurrException := nil; + + Exit; + end; + + P.RootTryStack.Pop; + + _Exit(P, P.ExitLevelId, em); + end; + + IntPax(CE) := IntPax(P.CurrException.ClassType); + E := CE.Create(P.CurrException.Message); + + Temp1 := P.RootTryStack.Top.TryBlockNumber; + Temp2 := P.RootTryStack.Top.Prog; + + P.RootTryStack.Pop; + + if P.RootTryStack.Count > 0 then + begin + P.RootExceptionIsAvailableForHostApplication := false; + + if IsExit > 0 then + while (P.TryList[P.RootTryStack.Top.TryBlockNumber].TryKind = tryFinally) and (P.RootTryStack.Count > 0) do + begin + if P.TryList[P.RootTryStack.Top.TryBlockNumber].Level <> SubId then + begin + P.RootTryStack.Push(Temp1, Temp2); + Exit; + end; + P.RootTryStack.Pop; + + if P.RootTryStack.Count = 0 then + break; + end; + end + else + P.RootExceptionIsAvailableForHostApplication := true; + + raise E; + end; +end; + +{$IFDEF PAX64} +procedure AssignRSI_RDI(Data: Pointer; Code: Pointer); assembler; +{$IFDEF FPC} +nostackframe; asm +{$ELSE} +asm + .NOFRAME +{$ENDIF} + mov rsi, rcx + mov rdi, rdx +end; +{$ENDIF} + +procedure _LoadSeg(P: TProgram; + FullProcName: PChar); stdcall; +var + S: String; + I: Integer; + CurrProg: TProgram; + MR: TMapRec; + Code, Data: Pointer; +begin + S := FullProcName; + P := P.RootProg; + for I := 0 to P.ProgList.Count - 1 do + begin + CurrProg := TProgram(P.ProgList[I].Prog); + if CurrProg.GetAddress(S, MR) <> nil then + begin + Code := CurrProg.CodePtr; + Data := CurrProg.DataPtr; +{$IFDEF PAX64} + AssignRSI_RDI(Data, Code); +{$ELSE} + asm + mov edi, Code + mov esi, Data + end; +{$ENDIF} + end; + end; +end; + +procedure _CreateObject(C: TClass; + var X: TObject); stdcall; +var + ClassIndex: Integer; + PaxInfo: PPaxInfo; + P: TProgram; +label + Again; +begin + Again: + + if not IsDelphiClass(C) then + begin + if Assigned(X) then + Exit; + C := TObject(C).ClassType; + end; + + PaxInfo := GetPaxInfo(C); + if PaxInfo = nil then + begin + ErrMessageBox(C.ClassName); + raise Exception.Create(errInternalError); + end; + P := TProgram(PaxInfo^.Prog); + + if P.RootProg.PassedClassRef <> nil then + begin + C := P.RootProg.PassedClassRef; + P.RootProg.PassedClassRef := nil; + goto Again; + end; + + ClassIndex := PaxInfo^.ClassIndex; + if ClassIndex = -1 then + begin + raise Exception.Create(errInternalError); + end; + + if C.InstanceSize = 0 then + P.RaiseError(errInternalError, []); + + Pointer(X) := nil; + X := C.NewInstance; +{$IFDEF ARC} + X.__ObjRelease; +{$ENDIF} +end; + +{$IFDEF PAX64} +procedure _64_CallDestructor(Self: TObject; //rcx + Code: Pointer; //rdx + Data: Pointer; //r8 + _ProgOffset: IntPax //r9 + ); assembler; +{$IFDEF FPC} +nostackframe; asm +{$ELSE} +asm + .NOFRAME +{$ENDIF} + push rbp + + push rsi + push rdi + push rbx + push rcx + + sub rsp, $100 + mov rbp, rsp + +// mov rcx, rcx // Self + mov rdi, rdx // Code + mov rsi, r8 // Data + + mov rbx, rdi +// add rbx, _ProgOffset + add rbx, r9 + + call rbx + + add rsp, $100 + + pop rcx + pop rbx + pop rdi + pop rsi + + pop rbp + ret +end; +{$ENDIF} + +procedure ClearStrProps(X: TObject); +var + pti: PTypeInfo; + ptd: PTypeData; + Loop, nProps: Integer; + pProps: PPropList; + ppi: PPropInfo; +begin + try + pti := X.ClassInfo; + if pti = nil then Exit; + ptd := GetTypeData(pti); + if ptd = nil then Exit; + nProps := ptd^.PropCount; + if nProps = 0 then + Exit; + GetMem(pProps, SizeOf(PPropInfo) * nProps); + GetPropInfos(pti, pProps); + for Loop:=0 to nProps - 1 do + begin + try +{$ifdef fpc} + ppi := pProps^[Loop]; +{$else} + ppi := pProps[Loop]; +{$endif} + if ppi^.SetProc <> nil then + case ppi^.PropType^.Kind of +{$IFDEF PAXARM} + tkUString: SetStrProp(X, ppi, ''); +{$ELSE} + tkLString: + {$IFDEF UNIC} + SetAnsiStrProp(X, ppi, ''); + {$ELSE} + SetStrProp(X, ppi, ''); + {$ENDIF} + tkWString: + {$IFDEF VARIANTS} + SetWideStrProp(X, ppi, ''); + {$ENDIF} +{$IFDEF UNIC} + tkUString: +{$IFDEF VARIANTS} + {$IFDEF UNIC} + SetUnicodeStrProp(X, ppi, ''); + {$ELSE} + SetWideStrProp(X, ppi, ''); + {$ENDIF} +{$ENDIF} +{$ENDIF} +{$ENDIF} + end; + except + end; + end; + FreeMem(pProps, SizeOf(PPropInfo) * nProps); + except + end; +end; + +procedure _DestroyObject(ASelf: Pointer; OuterMost: ShortInt); +var + PaxInfo: PPaxInfo; + ClassRec: TClassRec; + _ProgOffset, _Self: Integer; + Data, Code: Pointer; + P, RootProg, TargetProg: TProgram; + C: TClass; + VMT: PVMT; + I: Integer; + FullName: String; + Self: TObject; +begin + Self := TObject(ASelf); + + C := Self.ClassType; + + VMT := GetVMTFromClass(C); + if OuterMost <> 0 then + if not C.InheritsFrom(TInterfacedObject) then + PBeforeDestruction(vmtBeforeDestructionSlot(VMT)^)(Self); + + PaxInfo := GetPaxInfo(C); + if PaxInfo = nil then + raise Exception.Create(errInternalError); + + P := TProgram(PaxInfo^.Prog); + + if Assigned(P.OnDestroyObject) then + if OuterMost <> 0 then + P.OnDestroyObject(P.Owner, Self); + + ClassRec := P.ClassList[PaxInfo^.ClassIndex]; + _ProgOffset := ClassRec.DestructorProgOffset; + +{$IFDEF FPC} +{$ELSE} + if C.InheritsFrom(TPersistent) then + ClearStrProps(Self); +{$ENDIF} + + TargetProg := nil; + if _ProgOffset = 0 then + begin + FullName := ClassRec.FullName; + RootProg := P.RootProg; + for I := 0 to RootProg.ProgList.Count - 1 do + begin + TargetProg := TProgram(RootProg.ProgList[I].Prog); + ClassRec := TargetProg.ClassList.Lookup(FullName); + if ClassRec <> nil then + begin + _ProgOffset := ClassRec.DestructorProgOffset; + break; + end; + end; + end + else + TargetProg := P; + + if _ProgOffset > 0 then + begin + Data := TargetProg.DataPtr; + Code := TargetProg.CodePtr; + +{$IFDEF PAX64} + _64_CallDestructor(Self, Code, Data, _ProgOffset); +{$ELSE} + + asm + push esi + push edi + push ebx + + mov esi, Data; + mov edi, Code; + end; + + _Self := Integer(Self); + asm + push eax + mov eax, _Self + mov ebx, edi + add ebx, _ProgOffset + call ebx + pop eax + end; + + asm + pop ebx + pop edi + pop esi + end; + +{$ENDIF} + end; + + if OuterMost = 0 then + Exit; + + _ToParentClass2(Self); + Self.CleanupInstance; + _UpdateInstance2(Self, C); + + FreeMem(Pointer(Self), Self.InstanceSize); + + if Assigned(P.OnAfterObjectDestruction) then + P.OnAfterObjectDestruction(P.Owner, C); + + Pointer(Self) := nil; +end; + +// processing try-except-finally + +procedure _TryOn(P: TProgram; TryBlockNumber: Integer; _EBP, _ESP: Integer); +stdcall; +var + R: TTryRec; +begin + with P.RootProg do + begin + P.SetAddress(H_ExceptionPtr, @ P.fCurrException); + SourceLineFinally := -1; + end; + + P.RootTryStack.Push(TryBlockNumber, P); + + R := P.RootTryStack.Top.TR; + R._EBP := _EBP; + R._ESP := _ESP; + R.ESP0 := P.RootESP0; + R.SaveStackFrame; +end; + +procedure _TryOff(P: TProgram; TryBlockNumber: Integer); stdcall; +begin + P := P.RootProg; + + if P.RootTryStack.Count = 0 then + Exit; + P.RootTryStack.Pop; + P.SetAddress(H_ExceptionPtr, @ P.fCurrException); +end; + +procedure _Raise(P: TProgram; E: Exception; + RaiseMode: Integer; CurrESP: Integer); stdcall; +var + CE: TExceptionClass; + EstablisherFrame: PPaxExcFrame; +begin + if P.ModeSEH then + begin +{$IFDEF PAX64} +{$ELSE} + if not P.ProcessingExceptBlock then + begin + asm + mov eax, fs:[0] + mov EstablisherFrame, eax + end; + while EstablisherFrame^.Magic <> PAX_SEH do + begin + EstablisherFrame := EstablisherFrame^.Next; + end; + asm + mov eax, EstablisherFrame + mov fs:[0], eax + end; + end; +{$ENDIF} +{ + if P.ProcessingExceptBlock then + begin + asm + MOV EAX, CurrESP + MOV EAX, DWORD PTR [EAX] + XOR EBX, EBX + MOV DWORD PTR FS:[EBX], EAX + end; + end; +} + if E <> nil then + begin + if RaiseMode = 0 then + P.SourceLineFinally := -1; + raise E; + end + else if P.fCurrException <> nil then + begin + IntPax(CE) := IntPax(P.CurrException.ClassType); + E := CE.Create(P.CurrException.Message); + raise E; + end + else + raise Exception.Create(''); + end; + + if RaiseMode = 0 then + begin + end + else + begin + if P.RootTryStack.Count > 0 then + P.RootTryStack.Pop; + end; + + if P.RootTryStack.Count > 0 then + P.RootTryStack.Top.TR.SaveStackFrame; + + if E <> nil then + raise E + else + begin + IntPax(CE) := IntPax(P.CurrException.ClassType); + E := CE.Create(P.CurrException.Message); + raise E; + end; +end; + +// processing pause + +procedure _Pause(P: TProgram; ProgOffset, _EBP, _ESP: Integer); stdcall; +var + EstablisherFrame: PPaxExcFrame; +begin + if Assigned(P.OnPauseUpdated) then + begin + P.PauseRec._EBP := _EBP; + P.PauseRec._ESP := _ESP; + P.PauseRec.ESP0 := P.RootESP0; + P.PauseRec.ProgOffset := ProgOffset; + +{$IFDEF PCU_EX} + P.PauseRec.ESP0 := _EBP + 4096; +{$ENDIF} + + P.PauseRec.SaveStackFrame; + + P.RootProg.IsPauseUpdated := true; + P.PauseRec.ProgOffset := 1; + P.RootProg.PauseRec.ProgOffset := 1; + + try + P.RootProg.PausedPCU := P; + P.OnPauseUpdated(P.RootProg.Owner, P.GetModuleName, P.GetSourceLine); + finally +// P.RootProg.PausedPCU := nil; + P.PauseRec.ProgOffset := 0; + P.RootProg.PauseRec.ProgOffset := 0; + P.RemovePause; +// P.RootProg.RemovePause; + P.RootInitCallStackCount := P.RootCallStack.Count; + P.RootProg.IsPauseUpdated := false; + end; + Exit; + end; + + P.PauseRec._EBP := _EBP; + P.PauseRec._ESP := _ESP; + P.PauseRec.ESP0 := P.RootESP0; + P.PauseRec.ProgOffset := ProgOffset; + P.PauseRec.SaveStackFrame; + + P.RootExceptionIsAvailableForHostApplication := false; + + if P.ModeSEH then + if P.ProcessingExceptBlock then + begin + + with P do + if Assigned(OnPause) then + OnPause(Owner, GetModuleName, GetSourceLine); + +{$IFDEF PAX64} +{$ELSE} + asm + mov eax, fs:[0] + mov EstablisherFrame, eax + end; + + while EstablisherFrame^.Magic <> PAX_SEH do + EstablisherFrame := EstablisherFrame^.Next; + + P.PauseRec.PaxExcFrame1 := EstablisherFrame; + + while EstablisherFrame^.Magic = PAX_SEH do + EstablisherFrame := EstablisherFrame^.Next; + + asm + mov eax, EstablisherFrame + mov fs:[0], eax + end; +{$ENDIF} + + P.PauseSEH := true; + end; + + raise TPauseException.Create; +end; + +procedure _InitSub(P: TProgram; SubId: Integer; _EBP: Integer); +var + N: Integer; + CallerProg: TProgram; + MR: TMapRec; +begin + if Assigned(P.OnBeginProcNotifyEvent) then + begin + MR := P.ScriptMapTable.LookupSub(SubId); + if MR = nil then + MR := P.HostMapTable.LookupSub(SubId); + if MR <> nil then + P.OnBeginProcNotifyEvent(P.Owner, MR.FullName, MR.SubDesc.OverCount); + end; + + if (P.RunMode <> rmTRACE_INTO) and (P.RunMode <> rmNEXT_SOURCE_LINE) then + if P.RootCallStack.Count > 0 then + begin + CallerProg := P.RootCallStack.Top.Prg; + if CallerProg <> P then + P.RemovePause; + end; + + N := P.GetByteCodeLine; + P.RootCallStack.Push(_EBP, SubId, N, P); +end; + +procedure _EndSub(P: TProgram); +var + N, SubId: Integer; + MR: TMapRec; +begin + if Assigned(P.OnEndProcNotifyEvent) then + begin + SubId := P.RootCallStack.Top.SubId; + MR := P.ScriptMapTable.LookupSub(SubId); + if MR = nil then + MR := P.HostMapTable.LookupSub(SubId); + if MR <> nil then + P.OnEndProcNotifyEvent(P.Owner, MR.FullName, MR.SubDesc.OverCount); + end; + + N := P.RootCallStack.Top.NCall; + P.SetByteCodeLine(N); + + P.RootCallStack.Pop; + + if P.RunMode = rmSTEP_OVER then + begin + if P.RootInitCallStackCount >= P.RootCallStack.Count then + P.Pause; + end; +end; + +procedure _SetEventProp(P: TProgram; + PropInfo: PPropInfo; + Instance: TObject; + Code: Pointer; + Data: TObject; + CallConv: Integer; + RetSize: Integer); stdcall; +var + M: TMethod; + ER: TEventHandlerRec; + + B, B1, B2: Integer; +begin + if Data = nil then + begin + M.Code := nil; + M.Data := nil; + SetMethodProp(Instance, PropInfo, M); + Exit; + end; + + if P.ModeSEH then + begin + M.Code := Code; + M.Data := Data; + SetMethodProp(Instance, PropInfo, M); + Exit; + end; + + B := Integer(Code); + B1 := Integer(P.CodePtr); + B2 := B1 + P.CodeSize; + + if (B >= B1) and (B <= B2) then + begin + ER := P.EventHandlerList.Add(P, Code, Data, CallConv, RetSize); + M.Code := @ TEventHandlerRec.Invoke; + M.Data := ER; + end + else + begin + M.Code := Code; + M.Data := Data; + end; + + SetMethodProp(Instance, PropInfo, M); +end; + +procedure _SetEventProp2(P: TProgram; PropInfo: PPropInfo; + Instance: TObject; + var N: TMethod); stdcall; +var + M: TMethod; + ER: TEventHandlerRec; + + B, B1, B2: Integer; +begin + B := Integer(N.Code); + B1 := Integer(P.CodePtr); + B2 := B1 + P.CodeSize; + + if (B >= B1) and (B <= B2) then + begin + ER := P.EventHandlerList.Add(P, N.Code, TObject(N.Data), ccREGISTER, 0); + M.Code := @ TEventHandlerRec.Invoke; + M.Data := ER; + end + else + begin + M := N; + end; + + SetMethodProp(Instance, PropInfo, M); +end; + +procedure AssignRunnerLib; +begin + DefaultRunnerClass := TProgram; + + RegisterSEH := PAXCOMP_SEH.Register_SEH; + + Address_Exit := @_Exit; + Address_CondRaise := @_CondRaise; + Address_LoadSeg := @_LoadSeg; + Address_CreateObject := @_CreateObject; + Address_DestroyObject := @_DestroyObject; + Address_TryOn := @_TryOn; + Address_TryOff := @_TryOff; + Address_Raise := @_Raise; + Address_Pause := @_Pause; + Address_InitSub := @_InitSub; + Address_EndSub := @_EndSub; + Address_SetEventProp := @_SetEventProp; + Address_SetEventProp2 := @_SetEventProp2; +end; + +initialization + + AssignRunnerLibProc := AssignRunnerLib; + +end. diff --git a/Sources/PAXCOMP_PROGLIST.pas b/Sources/PAXCOMP_PROGLIST.pas new file mode 100644 index 0000000..b78c0c1 --- /dev/null +++ b/Sources/PAXCOMP_PROGLIST.pas @@ -0,0 +1,307 @@ +//////////////////////////////////////////////////////////////////////////// +// PaxCompiler +// Site: http://www.paxcompiler.com +// Author: Alexander Baranovsky (paxscript@gmail.com) +// ======================================================================== +// Copyright (c) Alexander Baranovsky, 2006-2014. All rights reserved. +// Code Version: 4.2 +// ======================================================================== +// Unit: PAXCOMP_PROGLIST.pas +// ======================================================================== +//////////////////////////////////////////////////////////////////////////// + +{$I PaxCompiler.def} +{$O-} + +unit PAXCOMP_PROGLIST; +interface +uses {$I uses.def} + SysUtils, + Classes, + PAXCOMP_CONSTANTS, + PAXCOMP_TYPES, + PAXCOMP_SYS, + PAXCOMP_MAP; +type + TProgRec = class + public + FullPath: String; + Prog: Pointer; + InitProcessed: Boolean; + destructor Destroy; override; + procedure SaveToStream(S: TStream); + procedure LoadFromStream(S: TStream; PCUOwner: Pointer); + procedure RunInitialization; + procedure RunFinalization; + end; + + TProgList = class(TTypedList) + private + fOwner: Pointer; + function GetRecord(I: Integer): TProgRec; + function AddRecord: TProgRec; + public + constructor Create(AOwner: Pointer); + function LoadAddress(const FileName, ProcName: String; + RunInit: Boolean; + OverCount: Integer; + var MR: TMapRec; + var DestProg: Pointer): Pointer; + procedure SaveToStream(S: TStream); + procedure LoadFromStream(S: TStream; PCUOwner: Pointer); + procedure LoadFromStreamList(S: TStreamList; PCUOwner: Pointer); + procedure SetPCUOwner(PCUOwner: Pointer); + procedure RunInitialization; + procedure RunFinalization; + procedure Add(Rec: TProgRec); + function IndexOf(const FullPath: String): Integer; + procedure RemoveProg(const FullPath: String); + property Records[I: Integer]: TProgRec read GetRecord; default; + end; + +implementation + +uses + PAXCOMP_BASERUNNER; + +destructor TProgRec.Destroy; +begin + if Prog <> nil then + TBaseRunner(Prog).Destroy; + inherited; +end; + +procedure TProgRec.RunInitialization; +begin + if not InitProcessed then + begin + TBaseRunner(Prog).RunInitialization; + InitProcessed := true; + end; +end; + +procedure TProgRec.RunFinalization; +begin + TBaseRunner(Prog).RunFinalization; +end; + +procedure TProgRec.SaveToStream(S: TStream); +begin + SaveStringToStream(FullPath, S); + TBaseRunner(Prog).SaveToStream(S); +end; + +procedure TProgRec.LoadFromStream(S: TStream; PCUOwner: Pointer); +var + C: TBaseRunnerClass; +begin + C := TBaseRunnerClass(TBaseRunner(PCUOwner).ClassType); + + FullPath := LoadStringFromStream(S); + TBaseRunner(Prog) := C.Create; + TBaseRunner(Prog).PCUOwner := PCUOwner; + TBaseRunner(Prog).CopyRootEvents; + TBaseRunner(Prog).LoadFromStream(S); +end; + +// TProgList ------------------------------------------------------------------- + +constructor TProgList.Create(AOwner: Pointer); +begin + inherited Create; + fOwner := AOwner; +end; + +function TProgList.GetRecord(I: Integer): TProgRec; +begin + result := TProgRec(L[I]); +end; + +function TProgList.AddRecord: TProgRec; +begin + result := TProgRec.Create; + L.Add(result); +end; + +procedure TProgList.Add(Rec: TProgRec); +begin + L.Add(Rec); +end; + +procedure TProgList.SaveToStream(S: TStream); +var + I, K: Integer; +begin + K := Count; + S.Write(K, SizeOf(Integer)); + for I := 0 to K - 1 do + Records[I].SaveToStream(S); +end; + +procedure TProgList.LoadFromStream(S: TStream; PCUOwner: Pointer); +var + I, K: Integer; + R: TProgRec; +begin + S.Read(K, SizeOf(Integer)); + for I := 0 to K - 1 do + begin + R := AddRecord; + R.LoadFromStream(S, PCUOwner); + end; +end; + +procedure TProgList.LoadFromStreamList(S: TStreamList; PCUOwner: Pointer); +var + I: Integer; + R: TProgRec; + C: TBaseRunnerClass; + FullName: String; +begin + C := TBaseRunnerClass(TBaseRunner(PCUOwner).ClassType); + + for I := 0 to S.Count - 1 do + begin + FullName := S[I].UnitName + '.' + PCU_FILE_EXT; + if IndexOf(FullName) >= 0 then + continue; + + R := AddRecord; + R.FullPath := FullName; + TBaseRunner(R.Prog) := C.Create; + TBaseRunner(R.Prog).PCUOwner := PCUOwner; + TBaseRunner(R.Prog).CopyRootEvents; + TBaseRunner(R.Prog).LoadFromStream(S[I].Stream); + end; +end; + +procedure TProgList.RunInitialization; +var + I: Integer; +begin + for I := 0 to Count - 1 do + Records[I].RunInitialization; +end; + +procedure TProgList.RunFinalization; +var + I: Integer; +begin + for I := 0 to Count - 1 do + Records[I].RunFinalization; +end; + +procedure TProgList.SetPCUOwner(PCUOwner: Pointer); +var + I: Integer; +begin + for I := 0 to Count - 1 do + TBaseRunner(Records[I].Prog).PCUOwner := PCUOwner; +end; + +function TProgList.LoadAddress(const FileName, ProcName: String; + RunInit: Boolean; + OverCount: Integer; + var MR: TMapRec; + var DestProg: Pointer): Pointer; +var + I: Integer; + Owner, P: TBaseRunner; + UnitName, FullPath, S: String; + ProgRec: TProgRec; + InputStream: TStream; + C: TBaseRunnerClass; +begin + Owner := TBaseRunner(fOwner); + + DestProg := nil; + + ProgRec := nil; + FullPath := ''; + UnitName := ExtractFullOwner(FileName); + + InputStream := nil; + +// if not Owner.FileExists(FileName, FullPath) then +// Owner.RaiseError(errFileNotFound, [FileName]); + + for I := 0 to Count - 1 do + begin + S := ExtractFileName(TProgRec(L[I]).FullPath); + if StrEql(S, FileName) then + begin + ProgRec := TProgRec(L[I]); + FullPath := ProgRec.FullPath; + break; + end; + end; + + if ProgRec = nil then + begin + if Assigned(Owner.OnLoadPCU) then + begin + Owner.OnLoadPCU(Owner.Owner, UnitName, InputStream); + end; + + if not Owner.FileExists(FileName, FullPath) then + if InputStream = nil then + begin + result := nil; + Owner.RaiseError(errFileNotFound, [FileName]); + Exit; + end; + + C := TBaseRunnerClass(Owner.ClassType); + + P := C.Create; + P.PCUOwner := Owner; + if InputStream <> nil then + P.LoadFromStream(InputStream) + else + P.LoadFromFile(FullPath); + ProgRec := TProgRec.Create; + ProgRec.FullPath := FullPath; + ProgRec.Prog := P; + L.Add(ProgRec); + + if RunInit then + ProgRec.RunInitialization; + end + else + begin + P := ProgRec.Prog; + if RunInit then + ProgRec.RunInitialization; + end; + + P.CopyRootEvents; + P.CopyRootBreakpoints(UnitName); + + S := ExtractName(UnitName)+ '.' + ProcName; + result := P.GetAddressEx(S, OverCount, MR); + DestProg := P; +end; + +function TProgList.IndexOf(const FullPath: String): Integer; +var + I: Integer; +begin + result := -1; + for I := 0 to Count - 1 do + if StrEql(Records[I].FullPath, FullPath) then + begin + result := I; + Exit; + end; +end; + +procedure TProgList.RemoveProg(const FullPath: String); +var + I: Integer; +begin + I := IndexOf(FullPath); + if I >= 0 then + RemoveAt(I); +end; + +end. diff --git a/Sources/PAXCOMP_RTI.pas b/Sources/PAXCOMP_RTI.pas new file mode 100644 index 0000000..e6e0058 --- /dev/null +++ b/Sources/PAXCOMP_RTI.pas @@ -0,0 +1,502 @@ +//////////////////////////////////////////////////////////////////////////// +// PaxCompiler +// Site: http://www.paxcompiler.com +// Author: Alexander Baranovsky (paxscript@gmail.com) +// ======================================================================== +// Copyright (c) Alexander Baranovsky, 2006-2014. All rights reserved. +// Code Version: 4.2 +// ======================================================================== +// Unit: PAXCOMP_RTI.pas +// ======================================================================== +//////////////////////////////////////////////////////////////////////////// + +{$I PaxCompiler.def} +unit PAXCOMP_RTI; +interface +uses {$I uses.def} + SysUtils, + Classes, + PAXCOMP_CONSTANTS, + PAXCOMP_TYPES, + PAXCOMP_SYS; + +type + TBreakpoint = class; + TBreakpointList = class; + + TModuleRec = class + public + ModuleName: String; + P1, P2, P3: Integer; + UsedModules: TStringList; + ExecutableLines: TIntegerList; + constructor Create; + destructor Destroy; override; + procedure SaveToStream(S: TStream); + procedure LoadFromStream(S: TStream); + end; + + TModuleLst = class(TTypedList) + private + function GetRecord(I: Integer): TModuleRec; + public + function AddRecord: TModuleRec; + procedure SaveToStream(S: TStream); + procedure LoadFromStream(S: TStream); + function GetModuleRec(const ModuleName: String): TModuleRec; + property Records[I: Integer]: TModuleRec read GetRecord; default; + end; + + TRuntimeModuleList = class + private + OwnerProg: Pointer; + public + SourceLines: array of Integer; + ModuleIndexes: array of Integer; + Modules: TModuleLst; + BreakpointList: TBreakpointList; + TempBreakpoint: TBreakpoint; + constructor Create(AOwnerProg: Pointer); + destructor Destroy; override; + procedure Clear; + function GetSourceLine(ByteCodeLine: Integer): Integer; + function GetModuleName(ByteCodeLine: Integer): String; + function GetModuleIndex(ByteCodeLine: Integer): Integer; + function GetModuleIndexByName(const ModuleName: String): Integer; + function IsExecutableLine(const ModuleName: String; + SourceLine: Integer): Boolean; + function AddBreakpoint(const ModuleName: String; + SourceLine: Integer): TBreakpoint; + function AddTempBreakpoint(const ModuleName: String; + SourceLine: Integer): TBreakpoint; + function RemoveBreakpoint(const ModuleName: String; + SourceLine: Integer): Boolean; overload; + function RemoveBreakpoint(const ModuleName: String): Boolean; overload; + procedure RemoveAllBreakpoints; + function HasBreakpoint(const ModuleName: String; + SourceLine: Integer): Boolean; + procedure SaveToStream(S: TStream); + procedure LoadFromStream(S: TStream); + end; + + TBreakpoint = class + private + function GetModuleName: String; + public + OwnerProg: Pointer; + SourceLine: Integer; + ModuleIndex: Integer; + public + constructor Create(AOwnerProg: Pointer); + destructor Destroy; override; + procedure Clear; + property ModuleName: String read GetModuleName; + end; + + TBreakpointList = class(TTypedList) + private + OwnerProg: Pointer; + function GetItem(I: Integer): TBreakpoint; + function GetCount: Integer; + public + constructor Create(AOwnerProg: Pointer); + procedure Clear; override; + function AddBreakpoint(ModuleIndex: Integer; + SourceLine: Integer): TBreakpoint; + procedure RemoveBreakpoint(ModuleIndex: Integer; + SourceLine: Integer); overload; + procedure RemoveBreakpoint(ModuleIndex: Integer); overload; + function IndexOf(ModuleIndex: Integer; + SourceLine: Integer): Integer; + property Count: Integer read GetCount; + property Items[I: Integer]: TBreakpoint read GetItem; default; + end; + +implementation + +uses + PAXCOMP_BASERUNNER; + +// TModuleRec ------------------------------------------------------------------ + +constructor TModuleRec.Create; +begin + inherited; + UsedModules := TStringList.Create; + ExecutableLines := TIntegerList.Create; +end; + +destructor TModuleRec.Destroy; +begin + FreeAndNil(UsedModules); + FreeAndNil(ExecutableLines); + inherited; +end; + +procedure TModuleRec.SaveToStream(S: TStream); +begin + SaveStringToStream(ModuleName, S); + S.Write(P1, SizeOf(Integer)); + S.Write(P2, SizeOf(Integer)); + S.Write(P3, SizeOf(Integer)); + SaveStringListToStream(UsedModules, S); + {$IFDEF PCU_EX} + ExecutableLines.SaveToStream(S); + {$ENDIF} +end; + +procedure TModuleRec.LoadFromStream(S: TStream); +begin + ModuleName := LoadStringFromStream(S); + S.Read(P1, SizeOf(Integer)); + S.Read(P2, SizeOf(Integer)); + S.Read(P3, SizeOf(Integer)); + LoadStringListFromStream(UsedModules, S); + {$IFDEF PCU_EX} + ExecutableLines.Clear; + ExecutableLines.LoadFromStream(S); + {$ENDIF} +end; + +// TModuleLst ------------------------------------------------------------------ + +function TModuleLst.GetRecord(I: Integer): TModuleRec; +begin + result := TModuleRec(L[I]); +end; + +function TModuleLst.AddRecord: TModuleRec; +begin + result := TModuleRec.Create; + L.Add(result); +end; + +procedure TModuleLst.SaveToStream(S: TStream); +var + I, K: Integer; +begin + K := Count; + S.Write(K, SizeOf(Integer)); + for I:=0 to K - 1 do + Records[I].SaveToStream(S); +end; + +procedure TModuleLst.LoadFromStream(S: TStream); +var + I, K: Integer; +begin + S.Read(K, SizeOf(Integer)); + for I:=0 to K - 1 do + AddRecord.LoadFromStream(S); +end; + +function TModuleLst.GetModuleRec(const ModuleName: String): TModuleRec; +var + I: Integer; +begin + result := nil; + for I := 0 to Count - 1 do + if StrEql(Records[I].ModuleName, ModuleName) then + begin + result := Records[I]; + Exit; + end; +end; + +//-- TRuntimeModuleList -------------------------------------------------------- + +constructor TRuntimeModuleList.Create(AOwnerProg: Pointer); +begin + inherited Create; + OwnerProg := AOwnerProg; + BreakpointList := TBreakpointList.Create(AOwnerProg); + TempBreakpoint := TBreakpoint.Create(OwnerProg); + Modules := TModuleLst.Create; + Clear; +end; + +destructor TRuntimeModuleList.Destroy; +begin + Clear; + FreeAndNil(BreakpointList); + FreeAndNil(TempBreakpoint); + FreeAndNil(Modules); + inherited; +end; + +procedure TRuntimeModuleList.Clear; +begin + SourceLines := nil; + ModuleIndexes := nil; + Modules.Clear; + BreakpointList.Clear; + TempBreakpoint.Clear; +end; + +function TRuntimeModuleList.GetSourceLine(ByteCodeLine: Integer): Integer; +begin + result := SourceLines[ByteCodeLine]; +end; + +function TRuntimeModuleList.GetModuleIndex(ByteCodeLine: Integer): Integer; +begin + result := ModuleIndexes[ByteCodeLine]; +end; + +function TRuntimeModuleList.GetModuleName(ByteCodeLine: Integer): String; +var + I: Integer; +begin + result := ''; + for I:=0 to Modules.Count - 1 do + if (ByteCodeLine >= Modules[I].P1) and (ByteCodeLine <= Modules[I].P3) then + begin + result := Modules[I].ModuleName; + Exit; + end; + + raise Exception.Create(errInternalError); +end; + +function TRuntimeModuleList.GetModuleIndexByName(const ModuleName: String): Integer; +var + I: Integer; +begin + Result := -1; + for I:=0 to Modules.Count - 1 do + if Modules[I].ModuleName = ModuleName then + begin + result := I; + Exit; + end; +end; + +function TRuntimeModuleList.IsExecutableLine(const ModuleName: String; + SourceLine: Integer): Boolean; +var + I: Integer; +begin + I := GetModuleIndexByName(ModuleName); + if I > -1 then + result := Modules[I].ExecutableLines.IndexOf(SourceLine) >= 0 + else + result := false; +end; + +function TRuntimeModuleList.AddBreakpoint(const ModuleName: String; + SourceLine: Integer): TBreakpoint; +var + ModuleIndex: Integer; +begin + result := nil; + ModuleIndex := GetModuleIndexByName(ModuleName); + if ( ModuleIndex > -1 ) then + begin + if BreakpointList.IndexOf(ModuleIndex, SourceLine) = -1 then + result := BreakpointList.AddBreakpoint(ModuleIndex, SourceLine); + end; +end; + +function TRuntimeModuleList.AddTempBreakpoint(const ModuleName: String; + SourceLine: Integer): TBreakpoint; +var + ModuleIndex: Integer; +begin + ModuleIndex := GetModuleIndexByName(ModuleName); + if ( ModuleIndex > -1 ) then begin + TempBreakpoint.SourceLine := SourceLine; + TempBreakpoint.ModuleIndex := ModuleIndex; + result := TempBreakpoint; + end + else + begin + result := nil; + end; +end; + +function TRuntimeModuleList.RemoveBreakpoint(const ModuleName: String; + SourceLine: Integer): Boolean; +var + ModuleIndex: Integer; +begin + ModuleIndex := GetModuleIndexByName(ModuleName); + if ( ModuleIndex > -1 ) then + begin + BreakpointList.RemoveBreakpoint(ModuleIndex, SourceLine); + result := true; + end + else + result := false; +end; + +function TRuntimeModuleList.RemoveBreakpoint(const ModuleName: String): Boolean; +var + ModuleIndex: Integer; +begin + ModuleIndex := GetModuleIndexByName(ModuleName); + if ( ModuleIndex > -1 ) then + begin + BreakpointList.RemoveBreakpoint(ModuleIndex); + result := true; + end + else + result := false; +end; + +procedure TRuntimeModuleList.RemoveAllBreakpoints; +begin + BreakpointList.Clear; +end; + +function TRuntimeModuleList.HasBreakpoint(const ModuleName: String; + SourceLine: Integer): Boolean; +var + ModuleIndex: Integer; +begin + Result := FALSE; + ModuleIndex := GetModuleIndexByName(ModuleName); + if ( ModuleIndex > -1 ) then begin + result := BreakpointList.IndexOf(ModuleIndex, SourceLine) >= 0; + end; +end; + +procedure TRuntimeModuleList.SaveToStream(S: TStream); +var + K: Integer; + P: Pointer; +begin + K := System.Length(SourceLines); + S.Write(K, SizeOf(Integer)); + P := @SourceLines[0]; + S.Write(P^, K * SizeOf(Integer)); + + K := System.Length(ModuleIndexes); + S.Write(K, SizeOf(Integer)); + P := @ModuleIndexes[0]; + S.Write(P^, K * SizeOf(Integer)); + + Modules.SaveToStream(S); +end; + +procedure TRuntimeModuleList.LoadFromStream(S: TStream); +var + K: Integer; + P: Pointer; +begin + S.Read(K, SizeOf(Integer)); + SetLength(SourceLines, K); + P := @SourceLines[0]; + S.Read(P^, K * SizeOf(Integer)); + + S.Read(K, SizeOf(Integer)); + SetLength(ModuleIndexes, K); + P := @ModuleIndexes[0]; + S.Read(P^, K * SizeOf(Integer)); + + Modules.LoadFromStream(S); +end; + +//-- TBreakpointList ----------------------------------------------------------- + +constructor TBreakpointList.Create(AOwnerProg: Pointer); +begin + inherited Create; + OwnerProg := AOwnerProg; +end; + +procedure TBreakpointList.Clear; +begin + inherited; +end; + +function TBreakpointList.AddBreakpoint(ModuleIndex: Integer; + SourceLine: Integer): TBreakpoint; +begin + result := TBreakpoint.Create(OwnerProg); + result.SourceLine := SourceLine; + result.ModuleIndex := ModuleIndex; + L.Add(result); +end; + +procedure TBreakpointList.RemoveBreakpoint(ModuleIndex: Integer; + SourceLine: Integer); +var + I: Integer; +begin + I := IndexOf(ModuleIndex, SourceLine); + if I = -1 then + Exit; +{$IFDEF ARC} + L[I] := nil; +{$ELSE} + Items[I].Free; +{$ENDIF} + L.Delete(I); +end; + +procedure TBreakpointList.RemoveBreakpoint(ModuleIndex: Integer); +var + I: Integer; + B: TBreakpoint; +begin + for I := Count - 1 downto 0 do + begin + B := Items[I]; + if B.ModuleIndex = ModuleIndex then + begin + FreeAndNil(B); + L.Delete(I); + end; + end; +end; + +function TBreakpointList.IndexOf(ModuleIndex: Integer; + SourceLine: Integer): Integer; +var + I: Integer; +begin + result := -1; + for I:=0 to Count - 1 do + if Items[I].ModuleIndex = ModuleIndex then + if Items[I].SourceLine = SourceLine then + begin + result := I; + Exit; + end; +end; + +function TBreakpointList.GetItem(I: Integer): TBreakpoint; +begin + result := TBreakpoint(L[I]); +end; + +function TBreakpointList.GetCount: Integer; +begin + result := L.Count; +end; + +// TBreakpoint ----------------------------------------------------------------- + +constructor TBreakpoint.Create(AOwnerProg: Pointer); +begin + inherited Create; + OwnerProg := AOwnerProg; +end; + +procedure TBreakpoint.Clear; +begin + SourceLine := 0; + ModuleIndex := 0; +end; + +destructor TBreakpoint.Destroy; +begin + inherited; +end; + +function TBreakpoint.GetModuleName: String; +begin + result := TBaseRunner(OwnerProg).RunTimeModuleList.Modules[ModuleIndex].ModuleName; +end; + +end. diff --git a/Sources/PAXCOMP_SCANNER.pas b/Sources/PAXCOMP_SCANNER.pas new file mode 100644 index 0000000..c1b1f27 --- /dev/null +++ b/Sources/PAXCOMP_SCANNER.pas @@ -0,0 +1,2323 @@ +//////////////////////////////////////////////////////////////////////////// +// PaxCompiler +// Site: http://www.paxcompiler.com +// Author: Alexander Baranovsky (paxscript@gmail.com) +// ======================================================================== +// Copyright (c) Alexander Baranovsky, 2006-2014. All rights reserved. +// Code Version: 4.2 +// ======================================================================== +// Unit: PAXCOMP_SCANNER.pas +// ======================================================================== +//////////////////////////////////////////////////////////////////////////// + +{$I PaxCompiler.def} +unit PAXCOMP_SCANNER; +interface +uses {$I uses.def} + SysUtils, + Classes, + PAXCOMP_CONSTANTS, + PAXCOMP_TYPES, + PAXCOMP_SYS; + +const + _IFDEF = 1; + _IFNDEF = 2; + _ELSE = 3; + _ENDIF = 4; + _ELSEIF = 5; +type + TScannerState = (scanText, scanProg); + + TBaseScanner = class; + + TDefRec = class + public + Word: Integer; + What: String; + Vis: boolean; + value: variant; + end; + + TDefList = class(TTypedList) + private + function GetRecord(I: Integer): TDefRec; + public + procedure Add(const S: String); overload; + procedure Add(const S: String; const value: Variant); overload; + function IndexOf(const S: String): Integer; + property Records[I: Integer]: TDefRec read GetRecord; default; + end; + + TDefStack = class(TDefList) + private + function GetTop: TDefRec; + function GetOuterVis: Boolean; + public + procedure Push(Word: Integer; What: String; Vis: Boolean); + procedure Pop; + property OuterVis: Boolean read GetOuterVis; + property Top: TDefRec read GetTop; + end; + + TToken = class + private + scanner: TBaseScanner; + function GetText: String; + public + TokenClass: TTokenClass; + Position: Integer; + Length: Integer; + Id: Integer; + Tag: Integer; + constructor Create(i_scanner: TBaseScanner); + procedure Push(StateStack: TIntegerStack); + procedure Pop(StateStack: TIntegerStack); + property Text: String read GetText; + end; + + TScannerRec = class + private + LineCount: Integer; + P: Integer; + Buff: String; + public + IncludedFileName: String; + end; + + TScannerStack = class(TTypedList) + private + function GetTop: TScannerRec; + public + procedure Push(Scanner: TBaseScanner; const IncludedFileName: String); + procedure Pop(Scanner: TBaseScanner); + property Top: TScannerRec read GetTop; + end; + + TCurrComment = class + private + P1: Integer; + public + Comment: String; + CommentValue: Integer; + CurrCommN: Integer; + CommentedTokens: TAssocStringInt; + AllowedDoComment: Boolean; + constructor Create; + procedure Clear; + function Valid: Boolean; + destructor Destroy; override; + end; + + TBaseScanner = class + private + StateStack: TIntegerStack; + p: Integer; + fScannerState: TScannerState; + fBackSlash: Boolean; + function GetLinePos: Integer; + function GetBuffLength: Integer; + function _GetCurrText: String; + function GetExAlphaList: TAssocIntegers; + public + DefStack: TDefStack; + kernel: Pointer; + Token: TToken; + Buff: String; + LineCount: Integer; + LookForward: Boolean; + ScannerStack: TScannerStack; + CancelPos: Integer; + VarNameList: TStringList; + + CurrComment: TCurrComment; + + CustomInt64Val: Int64; +{$IFDEF PAXARM} + CustomStringVal: String; +{$ELSE} + CustomStringVal: WideString; +{$ENDIF} + SCAN_EXPR: Boolean; + MacroList: TMacroList; + + constructor Create; + destructor Destroy; override; + procedure Init(i_kernel: Pointer; + const SourceCode: string; + i_CancelPos: Integer); + procedure GenSeparator; + procedure GenWarnings(OnOff: Boolean); + procedure GenFramework(OnOff: Boolean); + procedure GenBeginText; + procedure GenEndText; + + function LA(N: Integer): Char; + function GetNextChar: Char; + function IsNewLine: Boolean; + function IsEOF: Boolean; overload; + class function IsEOF(c: Char): Boolean; overload; + function IsAlpha(c: Char): Boolean; + function IsAlphaEx(c: Char): Boolean; + class function IsDigit(c: Char): Boolean; + class function IsHexDigit(c: Char): Boolean; + class function IsWhiteSpace(c: Char): Boolean; + procedure ScanEOF; + procedure ScanSpecial; + procedure ScanSeparator; + procedure ScanIdentifier; + procedure ScanNumberLiteral; + procedure ScanHexLiteral; + procedure ScanStringLiteral(ch: Char); virtual; + procedure ScanDigits; + procedure ScanHexDigits; + procedure ScanSingleLineComment; + procedure ReadToken; + procedure ReadCustomToken; virtual; abstract; + function UpdateToken: String; virtual; + procedure RaiseError(const Message: string; params: array of Const); + procedure CreateError(const Message: string; params: array of Const); + procedure Push; + procedure Pop; + procedure SetCompleteBooleanEval(value: Boolean); + procedure SetOverflowCheck(value: Boolean); + procedure SetAlignment(value: Integer); + procedure ScanCondDir(Start1: Char; + Start2: TByteSet); + function ScanRegExpLiteral: String; + procedure ScanChars(CSet: TByteSet); + procedure ScanHtmlString(const Ch: String); + function ScanFormatString: String; + procedure IncLineCount; + procedure InsertText(const S: String); + class function IsValidToken(const S: String): Boolean; virtual; + + procedure BeginComment(value: Integer); + procedure EndComment(value: Integer); + procedure DoComment; + procedure AttachId(Id: Integer; Upcase: Boolean); + class function IsConstToken(AToken: TToken): Boolean; + procedure SetScannerState(Value: TScannerState); + + function IsCurrText(const S: String): Boolean; virtual; + procedure Match(const S: String); virtual; + function Scan_Factor: Variant; virtual; + function Scan_Expression: Variant; virtual; + function Scan_Ident: Variant; virtual; + + function ParametrizedTypeExpected: Boolean; virtual; + function FindPosition(Chars: TByteSet): Integer; + function Precede(ch1, ch2: Char): Boolean; + + function AreNextChars(const S: String): Boolean; + + property Position: Integer read p write p; + property LinePos: Integer read GetLinePos; + property BuffLength: Integer read GetBuffLength; + property LookAhead[N: Integer]: Char read LA; default; + property ScannerState: TScannerState read fScannerState write SetScannerState; + property _CurrText: String read _GetCurrText; + property ExAlphaList: TAssocIntegers read GetExAlphaList; + end; + +function ConvertString(const S: String): String; + +implementation + +uses + PAXCOMP_KERNEL, + PAXCOMP_MODULE, + PAXCOMP_BYTECODE; + +// TCurrComment ---------------------------------------------------------------- + +constructor TCurrComment.Create; +begin + inherited; + CommentedTokens := TAssocStringInt.Create; + AllowedDoComment := true; +end; + +procedure TCurrComment.Clear; +begin + Comment := ''; + CommentedTokens.Clear; + CurrCommN := 0; + AllowedDoComment := true; +end; + +function TCurrComment.Valid: Boolean; +begin + result := Comment <> ''; +end; + +destructor TCurrComment.Destroy; +begin + FreeAndNil(CommentedTokens); + inherited; +end; + +// TDefList -------------------------------------------------------------------- + +function TDefList.GetRecord(I: Integer): TDefRec; +begin + result := TDefRec(L[I]); +end; + +procedure TDefList.Add(const S: String); +var + R: TDefRec; + I: Integer; + V: Variant; + Q: String; +begin + R := TDefRec.Create; + L.Add(R); + R.What := S; + + I := PosCh('=', S); + if I > 0 then + begin + R.What := SCopy(S, SLow(S), I - SLow(S)); + R.What := RemoveChars([ord(' ')], R.What); + Q := SCopy(S, I + 1, 100); + Q := RemoveChars([ord(' ')], Q); + if PosCh('.', Q ) > 0 then + V := StrToFloat(Q) + else + V := StrToInt(Q); + R.Value := V; + end; +end; + +procedure TDefList.Add(const S: String; const value: Variant); +var + R: TDefRec; + I: Integer; +begin + I := IndexOf(S); + if I >= 0 then + begin + R := Records[I]; + R.value := value; + Exit; + end; + + R := TDefRec.Create; + L.Add(R); + R.What := S; + R.value := value; +end; + +function TDefList.IndexOf(const S: String): Integer; +var + I: Integer; +begin + result := -1; + for I := 0 to Count - 1 do + if StrEql(Records[I].What, S) then + begin + result := I; + Exit; + end; +end; + +// TDefStack ---------------------------------------------------------------- + +function TDefStack.GetTop: TDefRec; +begin + result := TDefRec(L[Count - 1]); +end; + +procedure TDefStack.Push(Word: Integer; What: String; Vis: Boolean); +var + R: TDefRec; +begin + R := TDefRec.Create; + R.Word := Word; + R.What := What; + R.Vis := Vis; + L.Add(R); +end; + +procedure TDefStack.Pop; +var + R: TDefRec; +begin + R := TDefRec(L[Count - 1]); + L.Delete(Count - 1); + FreeAndNil(R); +end; + +function TDefStack.GetOuterVis: Boolean; +var + I: Integer; +begin + result := true; + for I:= Count - 1 downto 0 do + if Records[I].Word in [_IFDEF, _IFNDEF] then + begin + if I > 0 then + result := Records[I-1].Vis; + Exit; + end; +end; + +//------- TToken --------------------------------------------------------------- + +constructor TToken.Create(i_scanner: TBaseScanner); +begin + Self.scanner := i_scanner; + Length := 0; + Id := 0; + Tag := 0; +end; + +function TToken.GetText: String; +begin + result := SCopy(scanner.Buff, Position, Length); +end; + +procedure TToken.Push(StateStack: TIntegerStack); +begin + StateStack.Push(Integer(TokenClass)); + StateStack.Push(Position); + StateStack.Push(Length); + StateStack.Push(Id); + StateStack.Push(Tag); +end; + +procedure TToken.Pop(StateStack: TIntegerStack); +begin + Tag := StateStack.Pop; + Id := StateStack.Pop; + Length := StateStack.Pop; + Position := StateStack.Pop; + TokenClass := TTokenClass(StateStack.Pop); +end; + +//------- TScannerStack --------------------------------------------------------- + +procedure TScannerStack.Push(Scanner: TBaseScanner; const IncludedFileName: String); +var + R: TScannerRec; + kernel: TKernel; + M: TModule; +begin + R := TScannerRec.Create; + R.LineCount := Scanner.LineCount; + R.P := Scanner.P; + R.Buff := Scanner.Buff; + R.IncludedFileName := IncludedFileName; + L.Add(R); + + if Assigned(Scanner.kernel) then + begin + kernel := TKernel(Scanner.kernel); + kernel := kernel.RootKernel; + M := kernel.CurrParser.CurrModule; + M.IncludedFiles.Add(IncludedFileName); + kernel.CurrParser.Gen(OP_BEGIN_INCLUDED_FILE, + M.IncludedFiles.Count - 1, 0, 0); + end; +end; + +procedure TScannerStack.Pop(Scanner: TBaseScanner); +var + R: TScannerRec; + kernel: TKernel; + M: TModule; +begin + R := TScannerRec(L[Count - 1]); + L.Delete(Count - 1); + + if Scanner <> nil then + begin + Scanner.LineCount := R.LineCount; + Scanner.P := R.P; + Scanner.Buff := R.Buff; + + if Assigned(Scanner.kernel) then + begin + kernel := TKernel(Scanner.kernel); + kernel := kernel.RootKernel; + M := kernel.CurrParser.CurrModule; + kernel.CurrParser.Gen(OP_END_INCLUDED_FILE, + M.IncludedFiles.Count - 1, 0, 0); + end; + end; + + FreeAndNil(R); +end; + +function TScannerStack.GetTop: TScannerRec; +begin + if Count = 0 then + result := nil + else + result := TScannerRec(L[Count - 1]); +end; + +//------- TBaseScanner --------------------------------------------------------- + +constructor TBaseScanner.Create; +begin + inherited; + + p := 0; + Buff := ''; + token := TToken.Create(Self); + + StateStack := TIntegerStack.Create; + DefStack := TDefStack.Create; + LookForward := false; + + ScannerStack := TScannerStack.Create; + CancelPos := -1; + + VarNameList := TStringList.Create; + CurrComment := TCurrComment.Create; + MacroList := TMacroList.Create; +end; + +destructor TBaseScanner.Destroy; +begin + FreeAndNil(token); + FreeAndNil(StateStack); + FreeAndNil(DefStack); + FreeAndNil(ScannerStack); + FreeAndNil(VarNameList); + FreeAndNil(CurrComment); + FreeAndNil(MacroList); + inherited; +end; + +procedure TBaseScanner.Init(i_kernel: Pointer; + const SourceCode: string; + i_CancelPos: Integer); +begin + Self.kernel := i_kernel; + Buff := SourceCode + CHAR_EOF; + p := SLow(Buff) - 1; + LineCount := 0; + StateStack.Clear; + LookForward := false; + ScannerStack.Clear; + CancelPos := i_CancelPos; + SetScannerState(scanText); + with DefStack do + while Count > 0 do + Pop; + VarNameList.Clear; + + CurrComment.Clear; + MacroList.Clear; +end; + +procedure TBaseScanner.GenSeparator; +begin + if Assigned(kernel) then + with TKernel(kernel) do + CurrParser.Gen(OP_SEPARATOR, CurrParser.CurrModule.ModuleNumber, LineCount, 0); +end; + +procedure TBaseScanner.GenWarnings(OnOff: Boolean); +begin + if Assigned(kernel) then + with TKernel(kernel) do + if OnOff = true then + CurrParser.Gen(OP_WARNINGS_ON, 0, 0, 0) + else + CurrParser.Gen(OP_WARNINGS_OFF, 0, 0, 0); +end; + +procedure TBaseScanner.GenFramework(OnOff: Boolean); +begin + if Assigned(kernel) then + with TKernel(kernel) do + if OnOff = true then + CurrParser.Gen(OP_FRAMEWORK_ON, 0, 0, 0) + else + CurrParser.Gen(OP_FRAMEWORK_OFF, 0, 0, 0); +end; + +procedure TBaseScanner.GenBeginText; +begin + if Assigned(kernel) then + with TKernel(kernel) do + CurrParser.Gen(OP_BEGIN_TEXT, CurrParser.CurrModule.ModuleNumber, LineCount, 0); +end; + +procedure TBaseScanner.GenEndText; +begin + if Assigned(kernel) then + with TKernel(kernel) do + CurrParser.Gen(OP_END_TEXT, CurrParser.CurrModule.ModuleNumber, LineCount, 0); +end; + +function TBaseScanner.LA(N: Integer): Char; +begin + result := Buff[p + N]; +end; + +function TBaseScanner.GetNextChar: Char; +var + I: Integer; +begin + Inc(p); + result := Buff[P]; + + if P = CancelPos then + begin + TKernel(kernel).CompletionHasParsed := true; + + TKernel(kernel).CurrParser.CurrModule.S3 := TKernel(kernel).SymbolTable.Card; + TKernel(kernel).CurrParser.CurrModule.P3 := TKernel(kernel).Code.Card; + + + if TKernel(kernel).FindDeclId < 0 then + begin + TKernel(kernel).CurrParser.FIND_DECL_SWITCH := true; + Exit; + end; + + case result of + '.': + begin + Buff := Copy(Buff, 1, P) + DummyName + + result + #254; + end; + '(': Buff := Copy(Buff, 1, P) + DummyName + ')' + + result + #254; + ' ', #13, #10: Buff := Copy(Buff, 1, P) + DummyName + + result + #254; + ',': Buff := Copy(Buff, 1, P) + DummyName + ')' + + result + #254; + else + RaiseError(errInternalError, []); + end; + + if P <= 1 then + begin + TKernel(kernel).CancelChar := #255; + Exit; + end; + I := P; + while ByteInSet(Buff[I], [32, 13, 10]) do + begin + Dec(I); + if I = 1 then + Exit; + end; + TKernel(kernel).CancelChar := Buff[I]; + end; +end; + +class function TBaseScanner.IsEOF(c: Char): Boolean; +begin + result := (c = CHAR_EOF); +end; + +function TBaseScanner.IsEOF: Boolean; +begin + result := P >= SHigh(Buff); +end; + +function TBaseScanner.IsNewLine: Boolean; +begin + if p = 0 then + result := false + else + result := ByteInSet(LA(0), [13, 10]); +end; + +function TBaseScanner.IsAlpha(c: Char): Boolean; +begin + result := PAXCOMP_SYS.IsAlpha(c); + if not result then + if ExAlphaList <> nil then + result := ExAlphaList.Inside(ord(c)); +end; + +function TBaseScanner.IsAlphaEx(c: Char): Boolean; +begin + if ByteInSet(c, [Ord('e'),Ord('E')]) then + result := false + else + result := IsAlpha(c); +end; + +class function TBaseScanner.IsDigit(c: Char): Boolean; +begin + result := PAXCOMP_SYS.IsDigit(c); +end; + +class function TBaseScanner.IsHexDigit(c: Char): Boolean; +begin + result := ByteInSet(c, [Ord('0')..Ord('9'),Ord('A')..Ord('F'),Ord('a')..Ord('f')]); +end; + +class function TBaseScanner.IsWhiteSpace(c: Char): Boolean; +begin + result := ByteInSet(c, WhiteSpaces); +end; + +procedure TBaseScanner.ScanIdentifier; +begin + while IsAlpha(LA(1)) or IsDigit(LA(1)) do + GetNextChar; + Token.TokenClass := tcIdentifier; + SetScannerState(scanProg); +end; + +procedure TBaseScanner.ScanDigits; +begin + while IsDigit(LA(1)) do + GetNextChar; + SetScannerState(scanProg); +end; + +procedure TBaseScanner.ScanHexDigits; +begin + while IsHexDigit(LA(1)) do + GetNextChar; + SetScannerState(scanProg); +end; + +procedure TBaseScanner.ScanNumberLiteral; +begin + ScanDigits; + Token.TokenClass := tcIntegerConst; + + if (LA(1) = '.') and (LA(2) <> '.') and (not IsAlphaEx(LA(2))) then + begin + GetNextChar(); + + if IsDigit(LA(1)) then + ScanDigits; + + if ByteInSet(LA(1), [Ord('e'), Ord('E')]) then + begin + GetNextChar(); + if ByteInSet(LA(1), [Ord('+'), Ord('-')]) then + GetNextChar(); + ScanDigits; + end; + + Token.TokenClass := tcDoubleConst; + end + else if ByteInSet(LA(1), [Ord('e'),Ord('E')]) and ByteInSet(LA(2), [Ord('0')..Ord('9'),Ord('+'),Ord('-')]) then + begin + GetNextChar(); + if ByteInSet(LA(1), [Ord('+'), Ord('-')]) then + GetNextChar(); + ScanDigits; + Token.TokenClass := tcDoubleConst; + end; + SetScannerState(scanProg); +end; + +procedure TBaseScanner.ScanHexLiteral; +begin + GetNextChar; + ScanHexDigits; + Token.TokenClass := tcIntegerConst; + SetScannerState(scanProg); +end; + +procedure TBaseScanner.ScanStringLiteral(ch: Char); +var + K: Integer; +begin + K := 0; + GetNextChar; + if (LA(0) = ch) and (LA(1) <> ch) then // empty string + begin + Token.TokenClass := tcPCharConst; + Exit; + end; + + repeat + if IsEOF then + begin + RaiseError(errUnterminatedString, []); + Exit; + end; + + if (LA(0) = ch) and (LA(1) = ch) then + begin + GetNextChar; + buff[p] := CHAR_REMOVE; + end + else if (LA(0) = ch) then + break; + + GetNextChar; + Inc(K); + until false; + + if K = 1 then + Token.TokenClass := tcCharConst + else + Token.TokenClass := tcPCharConst; + SetScannerState(scanProg); +end; + +procedure TBaseScanner.ScanSpecial; +begin + Token.TokenClass := tcSpecial; + Token.Id := 0; + SetScannerState(scanProg); +end; + +procedure TBaseScanner.ScanSeparator; +begin + if LA(1) = #10 then + GetNextChar; + Token.TokenClass := tcSeparator; + Inc(LineCount); + Token.Id := LineCount; + SetScannerState(scanProg); +end; + +procedure TBaseScanner.ScanEOF; +begin + SetScannerState(scanProg); + if ScannerStack.Count > 0 then + begin + ScannerStack.Pop(Self); + Exit; + end; + + Token.TokenClass := tcSpecial; + Token.Id := 0; +end; + +procedure TBaseScanner.ReadToken; +begin + token.TokenClass := tcNone; + token.Position := p; + ReadCustomToken; + token.Length := p - token.Position + 1; + + with CurrComment do + if Valid then + if IsValidToken(Token.Text) then + begin + CommentedTokens.Add(Token.Text); + if CurrComment.CommentedTokens.Count >= MAX_COMMENTED_TOKENS then + if AllowedDoComment then + DoComment; + end; +end; + +function TBaseScanner.UpdateToken: String; +begin + result := Token.Text; +end; + +procedure TBaseScanner.ScanSingleLineComment; +begin + BeginComment(0); + repeat + if IsEOF then + break; + GetNextChar; + + until ByteInSet(LA(1), [13, 10]); + SetScannerState(scanProg); + EndComment(0); +end; + +procedure TBaseScanner.RaiseError(const Message: string; params: array of Const); +begin + TKernel(kernel).Code.N := TKernel(kernel).Code.Card; + TKernel(kernel).RaiseError(Message, params); +end; + +procedure TBaseScanner.CreateError(const Message: string; params: array of Const); +begin + TKernel(kernel).CreateError(Message, params); +end; + +procedure TBaseScanner.Push; +begin + StateStack.Push(p); + StateStack.Push(LineCount); + StateStack.Push(Integer(ScannerState)); + + Token.Push(StateStack); +end; + +procedure TBaseScanner.Pop; +begin + Token.Pop(StateStack); + + ScannerState := TScannerState(StateStack.Pop); + LineCount := StateStack.Pop; + p := StateStack.Pop; +end; + +procedure TBaseScanner.SetCompleteBooleanEval(value: Boolean); +begin + TKernel(kernel).CurrParser.CompleteBooleanEval := value; +end; + +procedure TBaseScanner.SetOverflowCheck(value: Boolean); +begin + if value then + TKernel(kernel).CurrParser.Gen(OP_OVERFLOW_CHECK, 1, 0, 0) + else + TKernel(kernel).CurrParser.Gen(OP_OVERFLOW_CHECK, 0, 0, 0); +end; + +procedure TBaseScanner.SetAlignment(value: Integer); +begin + TKernel(kernel).CurrParser.Alignment := value; +end; + +procedure TBaseScanner.ScanCondDir(Start1: Char; + Start2: TByteSet); + + procedure ScanChars(CSet: TByteSet); + begin + Token.Position := P; + while ByteInSet(LA(1), CSet) do + GetNextChar; + + token.Length := p - token.Position + 1; + Token.TokenClass := tcIdentifier; + end; + + +label + NextComment, Fin; +var + S: String; + I, J, J1, J2: Integer; + Visible: Boolean; + FileName, DirName: String; + ok: Boolean; + value: variant; + ch: Char; +begin + GetNextChar; // skip $ + + DirName := ''; + +// writeln(CurrKernel.Code.CurrSourceLineNumber); +// if CurrKernel.Code.CurrSourceLineNumber = 54 then +// I := 1; + + if ByteInSet(LA(1), [Ord('b'),Ord('B')]) and ByteInSet(LA(2), [Ord('+'),Ord('-')]) then + begin + DirName := LA(1); + + GetNextChar; + if LA(1) = '+' then + begin + DirName := DirName + LA(1); + + GetNextChar; + SetCompleteBooleanEval(true); + end + else if LA(1) = '-' then + begin + DirName := DirName + LA(1); + + GetNextChar; + SetCompleteBooleanEval(false); + end; + + ScanChars(WhiteSpaces); + if LA(1) = '}' then + GetNextChar + else + Self.RaiseError(errInvalidCompilerDirective, [DirName]); + + Exit; + end; + + if ByteInSet(LA(1),[Ord('q'),Ord('Q')]) and ByteInSet(LA(2), [Ord('+'),Ord('-')]) then + begin + DirName := LA(1); + + GetNextChar; + if LA(1) = '+' then + begin + DirName := DirName + LA(1); + + GetNextChar; + SetOverflowCheck(true); + end + else if LA(1) = '-' then + begin + DirName := DirName + LA(1); + + GetNextChar; + SetOverflowCheck(false); + end; + + ScanChars(WhiteSpaces); + if LA(1) = '}' then + GetNextChar + else + Self.RaiseError(errInvalidCompilerDirective, [DirName]); + + Exit; + end; + + if ByteInSet(LA(1), [Ord('a'), Ord('A')]) and ByteInSet(LA(2), + [Ord('1'), Ord('2'), Ord('4'), Ord('8'), Ord('-')]) then + begin + DirName := LA(1); + + GetNextChar; + if LA(1) = '1' then + begin + DirName := DirName + LA(1); + + GetNextChar; + SetAlignment(1); + end + else if LA(1) = '2' then + begin + DirName := DirName + LA(1); + + GetNextChar; + SetAlignment(2); + end + else if LA(1) = '4' then + begin + DirName := DirName + LA(1); + + GetNextChar; + SetAlignment(4); + end + else if LA(1) = '8' then + begin + DirName := DirName + LA(1); + + GetNextChar; + SetAlignment(8); + end + else if LA(1) = '-' then + begin + DirName := DirName + LA(1); + + GetNextChar; + SetAlignment(1); + end; + + ScanChars(WhiteSpaces); + if LA(1) = '}' then + GetNextChar + else + Self.RaiseError(errInvalidCompilerDirective, [DirName]); + + Exit; + end; + + Visible := true; + +NextComment: + + S := ''; + if LA(1) = '$' then + GetNextChar; + repeat + GetNextChar; + S := S + LA(0); + if ByteInSet(LA(0), [10,13]) then + begin + Inc(LineCount); + + if LA(0) = #13 then + GetNextChar; + end; + until not ByteInSet(LA(0), (IdsSet + Start2)); + + I := Pos('INCLUDE ', UpperCase(S) + ' '); + if I = 0 then + I := Pos('I ', UpperCase(S)); + + DirName := RemoveLeftChars1(WhiteSpaces + [Ord('}')], S); + + if I = 1 then + begin + while not ByteInSet(LA(0), IdsSet) do GetNextChar; + + ScanChars(IdsSet + [32]); + + FileName := Token.Text; + if LA(1) = '.' then + begin + GetNextChar; + + ScanChars(IdsSet); + + FileName := FileName + Token.Text; + end; + if LA(1) = CHAR_AP then + GetNextChar; + + if Assigned(TKernel(kernel).OnInclude) then + begin + S := ''; + TKernel(kernel).OnInclude(TKernel(kernel).Owner, FileName, S); + end + else + begin + if Pos('.', FileName) = 0 then + if TKernel(kernel).CurrParser.GetIncludedFileExt <> '' then + FileName := FileName + '.' + TKernel(kernel).CurrParser.GetIncludedFileExt; + + S := TKernel(kernel).FindFullPath(FileName); + + if not FileExists(S) then + Self.RaiseError(errFileNotFound, [FileName]) + else + begin + FileName := S; + S := LoadText(FileName); + end; + end; + + ScanChars(WhiteSpaces); + if LA(1) = '}' then + GetNextChar; + + if S = '' then + Exit; + + ScannerStack.Push(Self, FileName); + + P := 0; + Buff := S + CHAR_EOF; + LineCount := 0; + + Exit; + end; + + I := Pos('WARNINGS ', UpperCase(S) + ' '); + if I > 0 then + begin + while not ByteInSet(LA(0), IdsSet) do GetNextChar; + + ScanChars(IdsSet); + DirName := Token.Text; + if StrEql(DirName, 'On') then + GenWarnings(true) + else + if StrEql(DirName, 'Off') then + GenWarnings(false) + else + Self.RaiseError(errInvalidCompilerDirective, ['WARNINGS ' + DirName]); + + if LA(1) = '}' then + GetNextChar; + + Exit; + end; + + I := Pos('FRAMEWORK ', UpperCase(S) + ' '); + if I > 0 then + begin + while not ByteInSet(LA(0), IdsSet) do GetNextChar; + + ScanChars(IdsSet); + DirName := Token.Text; + if StrEql(DirName, 'On') then + GenFramework(true) + else + if StrEql(DirName, 'Off') then + GenFramework(false) + else + Self.RaiseError(errInvalidCompilerDirective, ['FRAMEWORK ' + DirName]); + + if LA(1) = '}' then + GetNextChar; + + Exit; + end; + + I := Pos('NODEFINE ', UpperCase(S) + ' '); + if I > 0 then + begin + while not ByteInSet(LA(0), IdsSet) do GetNextChar; + + ScanChars(IdsSet + WhiteSpaces + [Ord('.'), Ord('-'), Ord('['), Ord(']'), + Ord('('), Ord(')'), Ord(',')]); + + DirName := RemoveLeftChars1(WhiteSpaces, Token.Text); + + I := TKernel(kernel).DefList.IndexOf(DirName); + if I <> -1 then + TKernel(kernel).DefList.RemoveAt(I); + + with TKernel(kernel) do + if Assigned(OnUndefineDirective) then + begin + ok := true; + OnUndefineDirective(Owner, DirName, ok); + if not ok then + Self.RaiseError(errInvalidCompilerDirective, [DirName]); + end; + + while LA(0) <> '}' do + GetNextChar; + + Exit; + end; + + I := Pos('DEFINE ', UpperCase(S) + ' '); + if I > 0 then + begin + while not ByteInSet(LA(0), IdsSet) do + GetNextChar; + + ScanChars(IdsSet + WhiteSpaces + [Ord('.'), Ord('-'), Ord('['), Ord(']'), + Ord('('), Ord(')'), Ord(',')]); + + DirName := RemoveLeftChars1(WhiteSpaces, Token.Text); + + if LA(1) = '=' then + begin + SCAN_EXPR := true; + try + ScanChars([Ord('='), Ord(' ')]); + ReadToken; + value := Scan_Expression; + finally + SCAN_EXPR := false; + end; + end; + + TKernel(kernel).DefList.Add(DirName, value); + + with TKernel(kernel) do + if Assigned(OnDefineDirective) then + begin + ok := true; + OnDefineDirective(Owner, DirName, ok); + if not ok then + Self.RaiseError(errInvalidCompilerDirective, [DirName]); + end; + + if LA(1) = '}' then + GetNextChar; + + Exit; + end; + + I := Pos('UNDEF ', UpperCase(S) + ' '); + if I > 0 then + begin + while not ByteInSet(LA(0), IdsSet) do GetNextChar; + + ScanChars(IdsSet + WhiteSpaces + [Ord('.'), Ord('-'), Ord('['), Ord(']'), + Ord('('), Ord(')'), Ord(',')]); + + DirName := RemoveLeftChars1(WhiteSpaces, Token.Text); + + I := TKernel(kernel).DefList.IndexOf(DirName); + if I <> -1 then + TKernel(kernel).DefList.RemoveAt(I); + + with TKernel(kernel) do + if Assigned(OnUndefineDirective) then + begin + ok := true; + OnUndefineDirective(Owner, DirName, ok); + if not ok then + Self.RaiseError(errInvalidCompilerDirective, [DirName]); + end; + + if LA(1) = '}' then + GetNextChar; + + Exit; + end; + + I := Pos('IFOPT ', UpperCase(S) + ' '); + + if I > 0 then + begin + while not ByteInSet(LA(0), IdsSet) do GetNextChar; + + ScanChars(IdsSet + WhiteSpaces + [Ord('.'), Ord('-'), Ord('['), Ord(']'), + Ord('('), Ord(')'), Ord(',')]); + + DirName := RemoveLeftChars1(WhiteSpaces, Token.Text); + + ch := LA(1); + + Visible := false; + if UpperCase(DirName) = 'B' then + begin + if ch = '+' then + Visible := TKernel(kernel).CurrParser.CompleteBooleanEval + else if ch = '-' then + Visible := not TKernel(kernel).CurrParser.CompleteBooleanEval; + end + else if UpperCase(DirName) = 'H' then + begin + if ch = '+' then + Visible := TKernel(kernel).CurrParser.IsUNIC + else if ch = '-' then + Visible := not TKernel(kernel).CurrParser.IsUNIC; + end; + + DefStack.Push(_IFDEF, DirName, Visible); + + while LA(0) <> '}' do + GetNextChar; + + goto Fin; + end; + + I := Pos('IFDEF ', UpperCase(S) + ' '); + + if I > 0 then + begin + while not ByteInSet(LA(0), IdsSet) do GetNextChar; + + ScanChars(IdsSet + WhiteSpaces + [Ord('.'), Ord('-'), Ord('['), Ord(']'), + Ord('('), Ord(')'), Ord(',')]); + + DirName := RemoveLeftChars1(WhiteSpaces, Token.Text); + + Visible := TKernel(kernel).DefList.IndexOf(DirName) <> -1; + Visible := Visible and DefStack.OuterVis; + + DefStack.Push(_IFDEF, DirName, Visible); + + while LA(0) <> '}' do + GetNextChar; + + goto Fin; + end; + + I := Pos('IFNDEF ', UpperCase(S) + ' '); + if I > 0 then + begin + while not ByteInSet(LA(0), IdsSet) do GetNextChar; + + ScanChars(IdsSet + WhiteSpaces + [Ord('.'), Ord('-'), Ord('['), Ord(']'), + Ord('('), Ord(')'), Ord(',')]); + DirName := RemoveLeftChars1(WhiteSpaces, Token.Text); + + Visible := TKernel(kernel).DefList.IndexOf(DirName) = -1; + Visible := Visible and (DefStack.OuterVis); + + DefStack.Push(_IFNDEF, DirName, Visible); + + while LA(0) <> '}' do + GetNextChar; + + goto Fin; + end; + + I := Pos('ELSE ', UpperCase(S) + ' '); + if I = 0 then + I := Pos('ELSE}', UpperCase(S) + '}'); + + if I > 0 then + begin + if DefStack.Count = 0 then + Self.RaiseError(errInvalidCompilerDirective, ['']); + + Visible := DefStack.OuterVis; + + if DefStack.Top.Word in [_IFDEF, _IFNDEF, _ELSEIF] then + begin + + for J:=DefStack.Count - 1 downto 0 do + begin + if DefStack[J].Vis then + begin + Visible := false; + Break; + end; + if DefStack[J].Word = _IFDEF then + break; + if DefStack[J].Word = _IFNDEF then + begin +// Visible := not Visible; + break; + end; + end; + + end + else + Self.RaiseError(errInvalidCompilerDirective, ['']); + + DefStack.Push(_ELSE, '', Visible); + + while LA(0) <> '}' do + GetNextChar; + goto Fin; + end; + + I := Pos('ENDIF ', UpperCase(S) + ' '); + if I = 0 then + I := Pos('ENDIF}', UpperCase(S) + '}'); + + if I > 0 then + begin + while LA(0) <> '}' do + GetNextChar; + + J1 := 0; + J2 := 0; + for I := DefStack.Count - 1 downto 0 do + if DefStack[I].Word in [_IFDEF, _IFNDEF] then + Inc(J1) + else if DefStack[I].Word = _ENDIF then + Inc(J2); + if J2 >= J1 then + Self.RaiseError(errInvalidCompilerDirective, ['']); + + for I:=DefStack.Count - 1 downto 0 do + if DefStack[I].Word in [_IFDEF, _IFNDEF] then + begin + while DefStack.Count > I do + DefStack.Pop; + Break; + end; + + if DefStack.Count = 0 then + Visible := true + else + Visible := DefStack[DefStack.Count - 1].Vis; + + while LA(0) <> '}' do + GetNextChar; + goto Fin; + end; + + I := Pos('IF ', UpperCase(S) + ' '); + if I = 1 then + begin + SCAN_EXPR := true; + try + ScanChars(WhiteSpaces); + ReadToken; + value := Scan_Expression; + finally + SCAN_EXPR := false; + end; + + if value then + Visible := DefStack.OuterVis + else + Visible := false; + + DefStack.Push(_IFDEF, '', Visible); + + ScanChars(WhiteSpaces); + if not Visible then + GenSeparator; + goto Fin; + end; + + I := Pos('CONST ', UpperCase(S) + ' '); + if I = 1 then + begin + while not ByteInSet(LA(0), IdsSet) do + GetNextChar; + + ScanChars(IdsSet + [Ord('.'), Ord('-'), Ord('['), Ord(']'), + Ord('('), Ord(')'), Ord(',')]); + + DirName := Token.Text; + + ScanChars(WhiteSpaces); + + if LA(1) = '=' then + begin + SCAN_EXPR := true; + try + ScanChars([Ord('='), Ord(' ')]); + ReadToken; + value := Scan_Expression; + finally + SCAN_EXPR := false; + end; + end; + + TKernel(kernel).DefList.Add(DirName, value); + + with TKernel(kernel) do + if Assigned(OnDefineDirective) then + begin + ok := true; + OnDefineDirective(Owner, DirName, ok); + if not ok then + Self.RaiseError(errInvalidCompilerDirective, [DirName]); + end; + + ScanChars(WhiteSpaces); + GenSeparator; + Exit; + end; + + I := Pos('ELSEIF ', UpperCase(S) + ' '); + if I > 0 then + begin + SCAN_EXPR := true; + try + ScanChars(WhiteSpaces); + ReadToken; + value := Scan_Expression; + finally + SCAN_EXPR := false; + end; + if value then + Visible := DefStack.OuterVis + else + Visible := false; + + if DefStack.Count = 0 then + Self.RaiseError(errInvalidCompilerDirective, ['ElseIf']); + + if not DefStack.Top.Word in [_IFDEF, _ELSEIF] then + Self.RaiseError(errInvalidCompilerDirective, ['ElseIf']); + + for J:=DefStack.Count - 1 downto 0 do + begin + if DefStack[J].Vis then + begin + Visible := false; + Break; + end; + if DefStack[J].Word = _IFDEF then + break; + end; + + DefStack.Push(_ELSEIF, '', Visible); + + ScanChars(WhiteSpaces); + if not Visible then + GenSeparator; + goto Fin; + end; + + + I := Pos('IFEND ', UpperCase(S) + ' '); + if I = 0 then + I := Pos('IFEND}', UpperCase(S) + '}'); + + if I = 1 then + begin + ScanChars(IdsSet + WhiteSpaces + [Ord('.'), Ord('-'), Ord('['), Ord(']'), + Ord('('), Ord(')'), Ord(',')]); + if LA(1) = '}' then + GetNextChar; + + J1 := 0; + J2 := 0; + for I := DefStack.Count - 1 downto 0 do + if DefStack[I].Word in [_IFDEF, _IFNDEF] then + Inc(J1) + else if DefStack[I].Word = _ENDIF then + Inc(J2); + if J2 >= J1 then + Self.RaiseError(errInvalidCompilerDirective, ['']); + + for I:=DefStack.Count - 1 downto 0 do + if DefStack[I].Word in [_IFDEF, _IFNDEF] then + begin + while DefStack.Count > I do + DefStack.Pop; + Break; + end; + + if DefStack.Count = 0 then + Visible := true + else + Visible := DefStack[DefStack.Count - 1].Vis; + + goto Fin; + end; + + with TKernel(kernel) do + if Assigned(OnUnknownDirective) then + begin + ok := true; + + if LA(0) <> '}' then + if LA(1) <> '}' then + begin + ScanChars(IdsSet + WhiteSpaces + [Ord('.'), Ord('-'), Ord('['), Ord(']'), + Ord('('), Ord(')'), Ord(','), Ord('+'), Ord('*'), + Ord(''''), Ord('"'), Ord('\'), Ord('/'), Ord(':')]); + + if Token.Text <> '}' then + DirName := DirName + ' ' + Token.Text; + end; + DirName := RemoveRightChars(WhiteSpaces, DirName); + + OnUnknownDirective(Owner, DirName, ok); + if not ok then + Self.RaiseError(errInvalidCompilerDirective, [DirName]); + + while LA(0) <> '}' do + GetNextChar; + end + else + Self.RaiseError(errInvalidCompilerDirective, [DirName]); + +Fin: + + if not Visible then + begin + I := 1; + repeat + GetNextChar; + if ByteInSet(LA(0), [10, 13]) then + begin + Inc(LineCount); + if LA(0) = #13 then + GetNextChar; + end; + if IsEOF then + break; + + if LA(0) = Start1 then + if ByteInSet(LA(1), Start2) then + begin + S := Copy(Buff, P + 2, 3); + if StrEql(S, 'if ') then + Inc(I); + + S := Copy(Buff, P + 2, 6); + if StrEql(S, 'ifdef ') then + Inc(I); + + S := Copy(Buff, P + 2, 7); + if StrEql(S, 'ifndef ') then + Inc(I); + + S := Copy(Buff, P + 2, 6); + if StrEql(S, 'endif ') or StrEql(S, 'endif}') then + begin + if I <= 1 then + break; + Dec(I); + end; + + if StrEql(S, 'ifend ') or StrEql(S, 'ifend}') then + begin + if I <= 1 then + break; + Dec(I); + end; + + S := Copy(Buff, P + 2, 5); + if StrEql(S, 'else ') or StrEql(S, 'else}') then + begin + if I <= 1 then + break; + end; + + S := Copy(Buff, P + 2, 7); + if StrEql(S, 'elseif ') or StrEql(S, 'elseif}') then + begin + if I <= 1 then + break; + end; + end; + + until false; + + if IsEOF then + Self.RaiseError(errMissingENDIFdirective, []); + + goto NextComment; + end; +end; + +function TBaseScanner.GetLinePos: Integer; +var + I: Integer; +begin + I := P; + result := P; + + if I = 0 then + Exit; + + repeat + if ByteInSet(Buff[I], [13, 10]) then + Break + else + Dec(I); + until I <= 0; + result := P - I; + +end; + +function TBaseScanner.ScanRegExpLiteral: String; +begin + result := ''; + while not ((LA(1) = '/') and + ByteInSet(LA(2), [Ord('i'), Ord('I'), Ord('g'), Ord('G'), Ord('m'), Ord('M'), + Ord('.'), Ord(','), Ord(')')])) do + begin + GetNextChar; + if IsEOF(LA(0)) then Exit; + result := result + LA(0); + end; + SetScannerState(scanProg); +end; + +procedure TBaseScanner.ScanChars(CSet: TByteSet); +begin + Token.Position := P; + while ByteInSet(LA(1), CSet) do + GetNextChar; + + token.Length := p - token.Position + 1; + Token.TokenClass := tcIdentifier; + SetScannerState(scanProg); +end; + +function TBaseScanner.GetBuffLength: Integer; +begin + result := Length(Buff); +end; + +procedure TBaseScanner.SetScannerState(Value: TScannerState); +begin + fScannerState := Value; + if Value = scanText then + fBackslash := true + else + fBackslash := false; +end; + +function TBaseScanner.ScanFormatString: String; +var + P1, P2: Integer; + StrFormat, VarName: String; +begin +// "%" [index ":"] ["-"] [width] ["." prec] type + + GetNextChar; + P1 := P; + if IsDigit(LA(1)) then // Index + begin + while IsDigit(LA(1)) do + GetNextChar; + if LA(1) <> ':' then + RaiseError(errTokenExpected, [':', LA(1)]); + + GetNextChar; + end; + if LA(1) = '-' then + GetNextChar; + if IsDigit(LA(1)) then // width + while IsDigit(LA(1)) do + GetNextChar; + if LA(1) = '.' then + GetNextChar; + if IsDigit(LA(1)) then // prec + while IsDigit(LA(1)) do + GetNextChar; + GetNextChar; // type + + P2 := P; + + StrFormat := Copy(Buff, P1, P2 - P1 + 1); + + result := Token.Text; + result := result + StrFormat; + + if LA(1) <> '=' then + RaiseError(errTokenExpected, ['=', LA(1)]); + GetNextChar; + + if not IsAlpha(LA(1)) then + RaiseError(errIdentifierExpected, []); + VarName := GetNextChar; + while ByteInSet(LA(1), IdsSet) do + VarName := VarName + GetNextChar; + + VarNameList.Add(VarName); +end; + +procedure TBaseScanner.ScanHtmlString(const Ch: String); +var + K1, K2: Integer; + c: Char; +begin + GenBeginText; + K1 := 0; + K2 := 0; + with Token do + begin + TokenClass := tcHtmlStringConst; + repeat + c := GetNextChar; + case c of + #0,#13,#10: + begin + if c = #13 then + GetNextChar; + IncLineCount; + GenSeparator; + end; + '\': + if (K1 mod 2 = 0) and (K2 mod 2 = 0) then + begin + if fBackslash then + case LA(1) of + '%': ScanFormatString; + 'b': + begin + Buff[P] := #$08; + GetNextChar; + end; + 't': + begin + Buff[P] := #$09; + GetNextChar; + end; + 'n': + begin + Buff[P] := #$0A; + GetNextChar; + end; + 'v': + begin + Buff[P] := #$0B; + GetNextChar; + end; + 'f': + begin + Buff[P] := #$0C; + GetNextChar; + end; + 'r': + begin + Buff[P] := #$0D; + GetNextChar; + end; + '\': + begin + Buff[P] := #$5C; + GetNextChar; + end; + end; // case + end; + '''': + begin + Inc(K1); + end; + '"': + begin + Inc(K2); + end; + '<': + if LA(1) = '?' then + begin + Dec(P); + Break; + end + else if LA(1) = '%' then + begin + Dec(P); + Break; + end; + #255: + begin + Dec(P); + Break; + end; + end; + until false; + end; + GenEndText; +end; + +procedure TBaseScanner.IncLineCount; +begin + if ScannerStack.Count = 0 then + begin + Inc(LineCount); + end; +end; + +procedure TBaseScanner.InsertText(const S: String); +begin + Insert(S, Buff, P + 1); +end; + +function ConvertString(const S: String): String; +var + I, L: Integer; + Ch: Char; +begin + result := ''; + L := SHigh(S); + if L = 0 then + Exit; + I := SLow(S); + repeat + Ch := S[I]; + if Ch = '\' then + begin + if I = L then + begin + result := result + Ch; + Exit; + end; + case S[I + 1] of + 'b': + begin + result := result + #$08; + Inc(I); + Inc(I); + if I > L then + break; + end; + 't': + begin + result := result + #$09; + Inc(I); + Inc(I); + if I > L then + break; + end; + 'n': + begin + result := result + #$0A; + Inc(I); + Inc(I); + if I > L then + break; + end; + 'v': + begin + result := result + #$0B; + Inc(I); + Inc(I); + if I > L then + break; + end; + 'f': + begin + result := result + #$0C; + Inc(I); + Inc(I); + if I > L then + break; + end; + 'r': + begin + result := result + #$0D; + Inc(I); + Inc(I); + if I > L then + break; + end; + '\': + begin + result := result + '\'; + Inc(I); + Inc(I); + if I > L then + break; + end; + else + begin + result := result + Ch; + Inc(I); + if I > L then + break; + end; + end; + end + else + begin + result := result + Ch; + Inc(I); + if I > L then + break; + end; + until false; +end; + +class function TBaseScanner.IsValidToken(const S: String): Boolean; +var + I: Integer; +begin + if S = '' then + begin + result := false; + Exit; + end; + result := true; + for I := SLow(S) to SHigh(S) do + if ByteInSet(S[I], [10, 13] + Whitespaces) then + begin + result := false; + Exit; + end; +end; + +procedure TBaseScanner.BeginComment(value: Integer); +begin + with CurrComment do + if Valid then + if CommentedTokens.Count = 0 then + begin + if CommentValue = value then + Exit; + end; + + if CurrComment.Valid then + DoComment; + CurrComment.P1 := P; +end; + +procedure TBaseScanner.EndComment(value: Integer); +begin + with CurrComment do + begin + Comment := Copy(Buff, P1, Position - P1 + 1); + CommentValue := value; + CurrCommN := TKernel(kernel).Code.Card; + end; +end; + +procedure TBaseScanner.DoComment; +var + N, ClsId, NsId: Integer; + Context, S: String; +begin + if Assigned(TKernel(kernel).OnComment) then + with CurrComment do + if Valid then + begin + S := Comment; + + N := CurrCommN; + ClsId := TKernel(kernel).Code.GetCurrClassId(N); + NsId := TKernel(kernel).Code.GetCurrNamespaceId(N); + if NsId > 0 then + begin + Context := TKernel(kernel).SymbolTable[NsId].FullName; + if ClsId > 0 then + Context := Context + '.' + TKernel(kernel).SymbolTable[ClsId].Name; + end + else + if ClsId > 0 then + Context := TKernel(kernel).SymbolTable[ClsId].Name; + + + CommentedTokens.Pack; + TKernel(kernel).OnComment(TKernel(kernel).Owner, + S, + Context, + CommentedTokens.Keys); + Clear; + end; +end; + +procedure TBaseScanner.AttachId(Id: Integer; Upcase: Boolean); +var + S: String; + I: Integer; + b: Boolean; +begin + S := TKernel(kernel).SymbolTable[Id].Name; + with CurrComment do + for I := 0 to CommentedTokens.Count - 1 do + begin + if Upcase then + b := StrEql(S, CommentedTokens.Keys[I]) + else + b := S = CommentedTokens.Keys[I]; + if b then + begin + CommentedTokens.Values[I] := Id; + break; + end; + end; +end; + +class function TBaseScanner.IsConstToken(AToken: TToken): Boolean; +begin + result := AToken.TokenClass in + [tcBooleanConst, tcCharConst, tcPCharConst, tcIntegerConst, + tcDoubleConst, tcNumCharConst, tcVariantConst, + tcHtmlStringConst]; +end; + +function TBaseScanner.IsCurrText(const S: String): Boolean; +begin + result := StrEql(Token.Text, S); +end; + +procedure TBaseScanner.Match(const S: String); +begin + if IsCurrText(S) then + ReadToken + else + RaiseError(errTokenExpected, [S, Token.Text]); +end; + +function TBaseScanner.Scan_Factor: Variant; +begin + if IsCurrText('true') then + begin + result := true; + ReadToken; + end + else if IsCurrText('false') then + begin + result := false; + ReadToken; + end + else if IsCurrText('defined') then + begin + ReadToken; + Match('('); + result := TKernel(kernel).DefList.IndexOf(Token.Text) >= 0; + ReadToken; + Match(')'); + end + else if IsCurrText('declared') then + begin + ReadToken; + Match('('); + result := TKernel(kernel).SymbolTable.Lookup(Token.Text, + TKernel(kernel).CurrParser.CurrLevel, true) > 0; + ReadToken; + Match(')'); + end + else if IsCurrText('sizeof') then + begin + ReadToken; + Match('('); + if IsCurrText('Pointer') then + result := SizeOf(Pointer) + else + result := 0; + ReadToken; + Match(')'); + end + else if Token.TokenClass = tcIntegerConst then + begin + result := StrToInt(Token.Text); + ReadToken; + end + else if Token.TokenClass = tcCharConst then + begin + result := Copy(Token.Text, 2, Length(Token.Text) - 2); + ReadToken; + end + else if Token.TokenClass = tcPCharConst then + begin + result := Copy(Token.Text, 2, Length(Token.Text) - 2); + ReadToken; + end + else if Token.TokenClass = tcDoubleConst then + begin + result := StrToFloat(Token.Text); + ReadToken; + end + else if IsCurrText('+') then + begin + ReadToken; + result := Scan_Factor; + end + else if IsCurrText('-') then + begin + ReadToken; + result := - Scan_Factor; + end + else if IsCurrText('not') then + begin + ReadToken; + result := not Scan_Factor; + end + else if IsCurrText('(') then + begin + Match('('); + result := Scan_Expression; + Match(')'); + end + else + result := Scan_Ident; +end; + +function TBaseScanner.Scan_Ident: Variant; +begin + RaiseError(errNotImplementedYet, []); +end; + +function TBaseScanner.Scan_Expression: Variant; +begin + RaiseError(errNotImplementedYet, []); +end; + +function _ParametrizedTypeExpected(scanner: TBaseScanner; const Buff: String; P: Integer): Boolean; +var + I, L: Integer; +label again, again2; +begin + result := false; + L := Length(Buff); + I := P; + while ByteInSet(Buff[I], WhiteSpaces) do + begin + Inc(I); + if I > L then + Exit; + end; + if Buff[I] <> '<' then + Exit; + Inc(I); +again: + while ByteInSet(Buff[I], WhiteSpaces) do + begin + Inc(I); + if I > L then + Exit; + end; + + if not scanner.IsAlpha(Buff[I]) then + Exit; + + Inc(I); + while scanner.IsAlpha(Buff[I]) or TBaseScanner.IsDigit(Buff[I]) do + begin + Inc(I); + if I > L then + Exit; + end; +again2: + while ByteInSet(Buff[I], WhiteSpaces) do + begin + Inc(I); + if I > L then + Exit; + end; + if Buff[I] = '>' then + begin + result := true; + Exit; + end; + if Buff[I] = ',' then + begin + Inc(I); + goto again; + end; + if Buff[I] = ';' then + begin + Inc(I); + goto again; + end; + if Buff[I] = ':' then + begin + result := true; + Exit; + end; + if Buff[I] = '<' then + begin + result := true; + Exit; + end; + if Buff[I] = '.' then + begin + Inc(I); + goto again; + end; + if Buff[I] = '{' then + begin + while Buff[I] <> '}' do + begin + Inc(I); + if I > L then + Exit; + end; + Inc(I); + goto again2; + end; + if (Buff[I] = '(') and (Buff[I+1] = '*') then + begin + while not ((Buff[I] = '*') and (Buff[I+1] = ')')) do + begin + Inc(I); + if I > L then + Exit; + end; + Inc(I); + Inc(I); + goto again2; + end; +end; + +function TBaseScanner.ParametrizedTypeExpected: Boolean; +begin + result := _ParametrizedTypeExpected(Self, Buff, P + 1); +end; + +function TBaseScanner._GetCurrText: String; +begin + result := Copy(Buff, P, 30); +end; + +function TBaseScanner.FindPosition(Chars: TByteSet): Integer; +begin + result := P; + while not (Ord(Buff[result]) in Chars) do + begin + Dec(result); + if result = 0 then + Exit; + end; +end; + +function TBaseScanner.Precede(ch1, ch2: Char): Boolean; +var + I: Integer; + c: Char; +begin + result := false; + I := P; + repeat + Inc(I); + c := Buff[I]; + if c = CHAR_EOF then + Exit; + if c = ch1 then + begin + result := true; + Exit; + end; + if c = ch2 then + Exit; + until false; +end; + +function TBaseScanner.GetExAlphaList: TAssocIntegers; +begin + if kernel = nil then + result := nil + else + result := TKernel(kernel).ExAlphaList; +end; + +function TBaseScanner.AreNextChars(const S: String): Boolean; +var + Q: String; +begin + Q := Copy(Buff, P + 1, Length(S)); + result := Q = S; +end; + +end. diff --git a/Sources/PAXCOMP_SEH.pas b/Sources/PAXCOMP_SEH.pas new file mode 100644 index 0000000..e52dbec --- /dev/null +++ b/Sources/PAXCOMP_SEH.pas @@ -0,0 +1,387 @@ +// PaxCompiler +// Site: http://www.paxcompiler.com +// Author: Alexander Baranovsky (paxscript@gmail.com) +// ======================================================================== +// Copyright (c) Alexander Baranovsky, 2006-2014. All rights reserved. +// Code Version: 4.2 +// ======================================================================== +// Unit: PAXCOMP_EMIT.pas +// ======================================================================== +//////////////////////////////////////////////////////////////////////////// + +{$I PaxCompiler.def} +unit PAXCOMP_SEH; +interface +uses {$I uses.def} + SysUtils, + PAXCOMP_TYPES, + PAXCOMP_SYS, + PAXCOMP_BASESYMBOL_TABLE; + +function _PaxSEHHandler(ExcRecord: Pointer; + EstablisherFrame: PPaxExcFrame; + ContextRecord: Pointer; + DispatcherContext: Pointer): Integer; cdecl; + +procedure Register_SEH(st: TBaseSymbolTable); + +var + PaxHandlerAddress: Pointer; + +implementation + +uses + PAXCOMP_CONSTANTS, + PAXCOMP_PROG, + PAXCOMP_CLASSLST, + PAXCOMP_PAUSE, + PAXCOMP_TRYLST, + PAXCOMP_STDLIB; + +{$IFDEF UNIX} // Ozz +procedure Register_SEH(st: TBaseSymbolTable); +begin +end; + +function _PaxSEHHandler(ExcRecord: Pointer; + EstablisherFrame: PPaxExcFrame; + ContextRecord: Pointer; + DispatcherContext: Pointer): Integer; cdecl; +begin + result := 0; + RaiseNotImpl; +end; +{$ELSE} + + +type + PExcDescEntry = ^TExcDescEntry; + TExcDescEntry = record + VTable: LongWord; // 32 bit RVA + Handler: LongWord; // 32 bit RVA + end; + PExcDesc = ^TExcDesc; + TExcDesc = record + DescCount: Integer; + DescTable: array [0..0{DescCount-1}] of TExcDescEntry; + end; + PExcScope = ^TExcScope; + TExcScope = record + BeginOffset: LongWord; // 32 bit RVA + EndOffset: LongWord; // 32 bit RVA + TableOffset: LongWord; // 32 bit RVA. 0:TargetOffset=finally block + // 1:TargetOffset=safecall catch block + // 2:TargetOffset=catch block + // other:TableOffset=TExcDesc + TargetOffset: LongWord; // 32 bit RVA. start of finally/catch block. + // TableOffset=0: signature is _TDelphiFinallyHandlerProc + // TableOffset=1: signature is _TDelphiSafeCallCatchHandlerProc + // TableOffset=2: Location to the catch block + // other: TargetOffset=0 + end; + PExcData = ^TExcData; + TExcData = record + ScopeCount: Integer; + ScopeTable: array [0..0{ScopeCount-1}] of TExcScope; + end; + +// win32 + PExceptionRecord = ^TExceptionRecord; + TExceptionRecord = + record + ExceptionCode : Longint; + ExceptionFlags : Longint; + OuterException : PExceptionRecord; + ExceptionAddress : Pointer; + NumberParameters : Longint; + case {IsOsException:} Boolean of + True: (ExceptionInformation : array [0..14] of Longint); + False: (ExceptAddr: Pointer; ExceptObject: Pointer); + end; + +var _Default8087CW: word; + pp: Pointer; + +procedure _FpuInit; {$IFDEF UNIX}oldfpccall;{$ENDIF} +asm + FNINIT + FWAIT + FLDCW _Default8087CW +end; + +const + cNonContinuable = 1; + cUnwinding = 2; + cUnwindingForExit = 4; + cUnwindInProgress = cUnwinding or cUnwindingForExit; + cDelphiException = $0EEDFADE; + cDelphiReRaise = $0EEDFADF; + +{$IFDEF PAX64} +function _PaxSEHHandler(ExcRecord: Pointer; + EstablisherFrame: PPaxExcFrame; + ContextRecord: Pointer; + DispatcherContext: Pointer): Integer; cdecl; +begin + result := 0; + RaiseNotImpl; +end; +{$ELSE} +function _PaxSEHHandler(ExcRecord: Pointer; + EstablisherFrame: PPaxExcFrame; + ContextRecord: Pointer; + DispatcherContext: Pointer): Integer; cdecl; +var + E: Exception; + ExceptionRecord: PExceptionRecord; + Prog: TProgram; + TryBlockNumber: Integer; + Data, Code: Pointer; + + IsExitException: Boolean; + IsBreakException: Boolean; + IsContinueException: Boolean; + IsPauseException: Boolean; + IsHaltException: Boolean; +// HandledByExcept: Boolean; + TryRec: TTryRec; + ProgOffset: Integer; + I: Integer; + ClsIndex: Integer; + ClassRec: TClassRec; + P: Pointer; + _EBP: Integer; + _ESP: Integer; +begin + asm + CLD + end; + + ExceptionRecord := ExcRecord; + + result := 1; + +// if (ExceptionRecord^.ExceptionFlags and cUnwindInProgress = 0) then + if ExceptionRecord^.ExceptionFlags <> 0 then + + begin + if (ExceptionRecord^.ExceptionCode = cDelphiException) then + begin + E := Exception(ExceptionRecord.ExceptObject); + end + else + begin + asm + MOV EDX,[EAX].TExceptionRecord.ExceptObject + MOV ECX,[EAX].TExceptionRecord.ExceptAddr + CLD + CALL _FpuInit + MOV EDX, pp //ExceptObjProc + CALL EDX + Mov E, EAX + end; + end; + + ProgOffset := -1; + TryRec := nil; + + if PAX_SEH = EstablisherFrame^.Magic then + begin + TryBlockNumber := EstablisherFrame^.TryBlockNumber; + Prog := EstablisherFrame^.Prog; + + if ExceptionRecord^.ExceptionFlags = 1 then + begin + Exit; + end; + + Prog.RootProg.FinallyCount := 0; + + IsExitException := E is PaxExitException; + IsBreakException := false; + IsContinueException := false; + + if IsExitException then + begin + IsBreakException := (E as PaxExitException).Mode = emBreak; + IsContinueException := (E as PaxExitException).Mode = emContinue; + IsExitException := (not IsBreakException) and (not IsContinueException); + end; + + IsPauseException := E is TPauseException; + IsHaltException := (E is THaltException) or + ((E is EAbort) and (not IsPauseException) + and + (not IsExitException) + and + (not IsBreakException) + and + (not IsContinueException)); + + if IsPauseException {or IsHaltException} then + begin + Prog.PauseRec.PaxExcFrame1 := EstablisherFrame; + + while EstablisherFrame^.Magic = PAX_SEH do + begin + EstablisherFrame := EstablisherFrame^.Next; + end; + + P := EstablisherFrame; + asm + mov eax, P + mov fs:[0], eax + end; + Prog.PauseSEH := true; + raise E; + end; + + Prog.IsHalted := IsHaltException; + + Prog.HasError := true; + + if E is THaltException then + ExitCode := (E as THaltException).ExitCode; + + with Prog do + if (not IsPauseException) {and (not IsHaltException)} and + (TryBlockNumber >= 0) and (TryBlockNumber < TryList.Count) then + begin + TryRec := TryList[TryBlockNumber]; + + if IsExitException then + if TryRec.TryKind = tryExcept then + begin + P := EstablisherFrame^.Next; + asm + mov eax, P + mov fs:[0], eax + end; + raise E; + end; + + if TryRec.TryKind = tryFinally then + begin + ProcessingExceptBlock := false; + if SourceLineFinally = -1 then + if (not IsExitException) and (not IsPauseException) then + begin + SourceLineFinally := GetSourceLine; + ModuleNameFinally := GetModuleName; + end; + end + else + begin + ProcessingExceptBlock := true; + end; + + if IsBreakException and (TryRec.BreakOffset > 0) then + begin + ProgOffset := TryRec.BreakOffset; + ProcessingExceptBlock := false; + end + else if IsContinueException and (TryRec.ContinueOffset > 0) then + begin + ProgOffset := TryRec.ContinueOffset; + ProcessingExceptBlock := false; + end + else if TryRec.ExceptOnInfo.Count = 0 then + ProgOffset := TryRec.ProgOffset + else + begin + for I:=0 to TryRec.ExceptOnInfo.Count - 1 do + begin + ClsIndex := TryRec.ExceptOnInfo.Keys[I]; + ProgOffset := TryRec.ExceptOnInfo.Values[I]; + if ClsIndex >= 0 then + begin + ClassRec := ClassList[ClsIndex]; + if ClassRec.PClass <> nil then + begin + if E is ClassRec.PClass then + break; + + if StrEql(ClassRec.PClass.ClassName, 'TJS_Object') then + break; + end; + end; + end; + end; + end; + + Prog.fCurrException := E; + if E <> Prog.fPrevException then + begin + Prog.fPrevException := E; + if Assigned(Prog.OnException) then + if TryRec <> nil then +// if TryRec.TryKind <> tryFinally then + if Prog.RootExceptionIsAvailableForHostApplication then + begin + Prog.ExceptionRec := ExceptionRecord; + Prog.OnException(Prog.Owner, Prog.fCurrException, Prog.GetModuleName, Prog.GetSourceLine); + Prog.ExceptionRec := nil; + end; + end; + + if ProgOffset > 0 then + begin + Data := Prog.DataPtr; + Code := Prog.CodePtr; + P := ShiftPointer(Code, ProgOffset); + _EBP := EstablisherFrame^.hEBP; + _ESP := EstablisherFrame^.hESP; + Dec(_ESP, SizeOf(TPaxExcFrame)); + + asm + MOV EAX, _ESP + MOV EAX, DWORD PTR [EAX] + XOR EBX, EBX + MOV DWORD PTR FS:[EBX], EAX + end; + + Inc(_ESP, SizeOf(TPaxExcFrame)); + asm + mov esi, Data + mov edi, Code + mov ebx, P + mov esp, _ESP + mov ebp, _EBP + + jmp ebx + end; + end; + end; + end; +end; +{$ENDIF} + +procedure Register_SEH(st: TBaseSymbolTable); +var + H: Integer; +begin + with st do + begin + H := RegisterNamespace(0, 'PaxCompilerSEH'); + H_PaxCompilerSEH := H; + + PaxHandlerAddress := @_PaxSEHHandler; + RegisterRoutine(H, '', typeVOID, ccCDECL, PaxHandlerAddress); + Id_PaxSEHHandler := LastSubId; + end; +end; + +initialization +{$IFDEF VARIANTS} + _Default8087CW := Get8087CW; +{$ELSE} + _Default8087CW := system.Default8087CW; +{$ENDIF} + +{$IFDEF MACOS32} +{$ELSE} + pp := ExceptObjProc; +{$ENDIF} +{$ENDIF} + +end. diff --git a/Sources/PAXCOMP_STDLIB.pas b/Sources/PAXCOMP_STDLIB.pas new file mode 100644 index 0000000..0655024 --- /dev/null +++ b/Sources/PAXCOMP_STDLIB.pas @@ -0,0 +1,8078 @@ +////////////////////////////////////////////////////////////////////////// +// PaxCompiler +// Site: http://www.paxcompiler.com +// Author: Alexander Baranovsky (paxscript@gmail.com) +// ======================================================================== +// Copyright (c) Alexander Baranovsky, 2006-2014. All rights reserved. +// Code Version: 4.2 +// ======================================================================== +// Unit: PAXCOMP_STDLIB.pas +// ======================================================================== +//////////////////////////////////////////////////////////////////////////// + +{$I PaxCompiler.def} +{$O-} +{$R-} +unit PAXCOMP_STDLIB; +interface +{$I-} +uses {$I uses.def} + TypInfo, + SysUtils, + Classes, + +{$IFDEF DRTTI} + Rtti, +{$ENDIF} + + PaxInfos, + PAXCOMP_CONSTANTS, + PAXCOMP_TYPES, + PAXCOMP_SYS, + PAXCOMP_SYMBOL_REC, + PAXCOMP_BASESYMBOL_TABLE, + PAXCOMP_CLASSLST, + PAXCOMP_CLASSFACT, +{$IFDEF PAXARM} +{$ELSE} + PAXCOMP_SEH, +{$ENDIF} +{$IFNDEF INTERPRETER_ONLY} + PAXCOMP_PROGLIB, +{$ENDIF} + + PAXCOMP_MAP; +type + TExtraImportTableList = class(TTypedList) + private + function GetRecord(I: Integer): TBaseSymbolTable; + public + function Add(st: TBaseSymbolTable): Integer; + procedure Remove(st: TBaseSymbolTable); + function Import(CurrentTable: TBaseSymbolTable; + const FullName: String; + UpCase: Boolean; + DoRaiseError: Boolean = true): Integer; + property Records[I: Integer]: TBaseSymbolTable read GetRecord; default; + end; +var + RUNNER_OWNER_OFFSET: IntPax; + + AvailUnitList: TStringList; + AvailUnitList1: TStringList; + AvailTypeList: TStringList; + + H_PascalNamespace: Integer; + H_BasicNamespace: Integer; + H_PaxCompilerSEH: Integer; + + H_PaxCompilerFramework: Integer; + + H_Writeln: Integer; + H_WriteBool: Integer; + H_WriteByteBool: Integer; + H_WriteWordBool: Integer; + H_WriteLongBool: Integer; + H_WriteInteger: Integer; + H_WriteInt64: Integer; + H_WriteByte: Integer; + H_WriteWord: Integer; + H_WriteCardinal: Integer; + H_WriteSmallInt: Integer; + H_WriteShortInt: Integer; + H_WriteAnsiString: Integer; + H_WriteShortString: Integer; + H_WriteAnsiChar: Integer; + H_WriteWideChar: Integer; + H_WriteWideString: Integer; + H_WriteUnicString: Integer; + H_WriteDouble: Integer; + H_WriteSingle: Integer; + H_WriteCurrency: Integer; + H_WriteExtended: Integer; + H_WriteVariant: Integer; + H_WriteObject: Integer; + H_TObject: Integer; + H_TClass: Integer; + H_TInterfacedObject: Integer; + + H_PInteger: Integer; + H_PSmallInt: Integer; + H_PShortInt: Integer; + H_PCardinal: Integer; + H_PWord: Integer; + H_PByte: Integer; + H_PInt64: Integer; + H_PSingle: Integer; + H_PDouble: Integer; + H_PExtended: Integer; + H_PCurrency: Integer; + H_PVariant: Integer; + H_PPointer: Integer; + H_PBoolean: Integer; + H_PWideChar: Integer; + H_PAnsiChar: Integer; + H_PShortString: Integer; + H_PAnsiString: Integer; + H_PWideString: Integer; + H_PUnicString: Integer; + H_PString: Integer; + + H_PPInteger: Integer; + H_PPSmallInt: Integer; + H_PPShortInt: Integer; + H_PPCardinal: Integer; + H_PPWord: Integer; + H_PPByte: Integer; + H_PPInt64: Integer; + H_PPSingle: Integer; + H_PPDouble: Integer; + H_PPExtended: Integer; + H_PPCurrency: Integer; + H_PPVariant: Integer; + H_PPPointer: Integer; + H_PPBoolean: Integer; + H_PPWideChar: Integer; + H_PPAnsiChar: Integer; + H_PPShortString: Integer; + H_PPAnsiString: Integer; + H_PPWideString: Integer; + H_PPUnicString: Integer; + H_PPString: Integer; + + H_QueryInterface, + H_AddRef, + H_Release, + + H_TGUID: Integer; + H_PGUID: Integer; + H_IUnknown: Integer; + H_IDispatch: Integer; + + Id_ImplicitInt: Integer = -1; + + Id_CallJNIMethod: Integer = -1; + + H_TValue: Integer = -1; + Id_VarFromTValue: Integer = -1; + Id_GetDRTTIProperty: Integer = -1; + Id_GetDRTTIIntegerProperty: Integer = -1; + Id_GetDRTTIStringProperty: Integer = -1; + Id_GetDRTTIExtendedProperty: Integer = -1; + Id_GetDRTTIVariantProperty: Integer = -1; + Id_GetDRTTIInt64Property: Integer = -1; + Id_SetDRTTIProperty: Integer = -1; + + H_TVarRec: Integer; + H_TFileRec: Integer; + H_TTextRec: Integer; + H_Dynarray_TVarRec: Integer; + + H_Dynarray_Integer: Integer; + H_Dynarray_Byte: Integer; + H_Dynarray_Word: Integer; + H_Dynarray_ShortInt: Integer; + H_Dynarray_SmallInt: Integer; + H_Dynarray_Cardinal: Integer; + H_Dynarray_Int64: Integer; + H_Dynarray_UInt64: Integer; + H_Dynarray_AnsiChar: Integer; + H_Dynarray_WideChar: Integer; + H_Dynarray_AnsiString: Integer; + H_Dynarray_WideString: Integer; + H_Dynarray_UnicodeString: Integer; + H_Dynarray_ShortString: Integer; + H_Dynarray_Double: Integer; + H_Dynarray_Single: Integer; + H_Dynarray_Extended: Integer; + H_Dynarray_Currency: Integer; + H_Dynarray_Boolean: Integer; + H_Dynarray_ByteBool: Integer; + H_Dynarray_WordBool: Integer; + H_Dynarray_LongBool: Integer; + H_Dynarray_Variant: Integer; + H_Dynarray_OleVariant: Integer; + H_Dynarray_Pointer: Integer; + + H_Unassigned: Integer; + + H_TMethod: Integer; + + H_DYN_VAR: Integer; + Id_CallVirt: Integer; + Id_PutVirt: Integer; + + Id_CondHalt: Integer; + + Id_ToParentClass: Integer; + Id_UpdateInstance: Integer; + Id_DestroyInherited: Integer; + + ID_Prog: Integer; + + Id_GetAddressGetCallerEIP: Integer; + Id_WriteBool: Integer; + Id_WriteByteBool: Integer; + Id_WriteWordBool: Integer; + Id_WriteLongBool: Integer; + Id_WriteAnsiChar: Integer; + Id_WriteByte: Integer; + Id_WriteWord: Integer; + Id_WriteCardinal: Integer; + Id_WriteSmallInt: Integer; + Id_WriteShortInt: Integer; + Id_WriteInt: Integer; + Id_WriteInt64: Integer; + Id_WriteDouble: Integer; + Id_WriteSingle: Integer; + Id_WriteCurrency: Integer; + Id_WriteExtended: Integer; + Id_WriteString: Integer; + Id_WriteShortString: Integer; + Id_WriteWideChar: Integer; + Id_WriteWideString: Integer; + Id_WriteUnicString: Integer; + Id_WriteVariant: Integer; + Id_WriteObject: Integer; + + Id_PrintEx: Integer; + Id_Is: Integer; + + Id_DynArrayLength: Integer; + Id_VariantArrayLength: Integer; + Id_AnsiStringLength: Integer; + + Id_SetVariantLength: Integer; + Id_SetVariantLength2: Integer; + Id_SetVariantLength3: Integer; + Id_SetStringLength: Integer; + Id_SetWideStringLength: Integer; + Id_SetUnicStringLength: Integer; + Id_SetShortStringLength: Integer; + + Id_LockVArray: Integer; + Id_UnlockVArray: Integer; + + Id_LoadProc: Integer; + Id_LoadSeg: Integer; + Id_LoadClassRef: Integer; + + Id_TypeInfo, + Id_GetDynamicMethodAddress, + Id_AddMessage, + + Id_AnsiStringFromPAnsiChar: Integer; + Id_AnsiStringFromPWideChar: Integer; + Id_WideStringFromPAnsiChar: Integer; + Id_WideStringFromPWideChar: Integer; + Id_UnicStringFromPWideChar: Integer; + Id_AnsiStringFromAnsiChar: Integer; + Id_WideStringFromAnsiChar: Integer; + Id_UnicStringFromAnsiChar: Integer; + Id_WideStringFromWideChar: Integer; + Id_UnicStringFromWideChar: Integer; + Id_AnsiStringFromWideChar: Integer; + + Id_UnicStringFromPAnsiChar: Integer; + + Id_AnsiStringAssign: Integer; + Id_AnsiStringAddition: Integer; + Id_ShortStringAddition: Integer; + Id_WideStringAddition: Integer; + Id_UnicStringAddition: Integer; + Id_ShortStringAssign: Integer; + Id_WideStringAssign: Integer; + Id_UnicStringAssign: Integer; + Id_AnsiStringClr: Integer; + Id_WideStringClr: Integer; + Id_UnicStringClr: Integer; + Id_InterfaceClr: Integer; + Id_ClassClr: Integer = 0; + + Id_UniqueAnsiString: Integer = 0; + Id_UniqueUnicString: Integer = 0; + + Id_StringAddRef: Integer; + Id_WideStringAddRef: Integer; + Id_UnicStringAddRef: Integer; + Id_VariantAddRef: Integer; + Id_DynarrayAddRef: Integer; + Id_InterfaceAddRef: Integer; + + Id_ShortStringFromAnsiString: Integer; + Id_ShortStringFromWideString: Integer; + Id_ShortStringFromPWideChar: Integer; + Id_ShortStringFromUnicString: Integer; + Id_AnsiStringFromShortString: Integer; + Id_UnicStringFromWideString: Integer; + Id_WideStringFromShortString: Integer; + Id_WideStringFromUnicString: Integer; + Id_UnicStringFromShortString: Integer; + Id_AnsiStringFromWideString: Integer; + Id_AnsiStringFromUnicString: Integer; + Id_WideStringFromAnsiString: Integer; + Id_UnicStringFromAnsiString: Integer; + Id_StrInt: Integer; + Id_StrDouble: Integer; + Id_StrSingle: Integer; + Id_StrExtended: Integer; + Id_DecStringCounter: Integer; + Id_IncStringCounter: Integer; + Id_AnsiStringEquality: Integer; + Id_AnsiStringNotEquality: Integer; + Id_ShortStringEquality: Integer; + Id_ShortStringNotEquality: Integer; + Id_WideStringEquality: Integer; + Id_UnicStringEquality: Integer; + Id_WideStringNotEquality: Integer; + Id_UnicStringNotEquality: Integer; + Id_ShortstringHigh: Integer; + Id_AnsiStringGreaterThan: Integer; + Id_AnsiStringGreaterThanOrEqual: Integer; + Id_AnsiStringLessThan: Integer; + Id_AnsiStringLessThanOrEqual: Integer; + Id_ShortStringGreaterThan: Integer; + Id_ShortStringGreaterThanOrEqual: Integer; + Id_ShortStringLessThan: Integer; + Id_ShortStringLessThanOrEqual: Integer; + Id_WideStringGreaterThan: Integer; + Id_UnicStringGreaterThan: Integer; + Id_WideStringGreaterThanOrEqual: Integer; + Id_UnicStringGreaterThanOrEqual: Integer; + Id_WideStringLessThan: Integer; + Id_UnicStringLessThan: Integer; + Id_WideStringLessThanOrEqual: Integer; + Id_UnicStringLessThanOrEqual: Integer; + Id_Int64Multiplication: Integer; + Id_Int64Division: Integer; + Id_Int64Modulo: Integer; + Id_Int64LeftShift: Integer; + Id_Int64RightShift: Integer; + Id_Int64LessThan: Integer; + Id_Int64LessThanOrEqual: Integer; + Id_Int64GreaterThan: Integer; + Id_Int64GreaterThanOrEqual: Integer; + Id_Int64Equality: Integer; + Id_Int64NotEquality: Integer; + Id_Int64Abs: Integer; + + Id_UInt64LessThan: Integer; + Id_UInt64LessThanOrEqual: Integer; + Id_UInt64GreaterThan: Integer; + Id_UInt64GreaterThanOrEqual: Integer; + + Id_VariantClr: Integer; + Id_VariantAssign: Integer; + Id_VariantFromPAnsiChar: Integer; + Id_VariantFromPWideChar: Integer; + Id_VariantFromInterface: Integer; + + Id_OleVariantAssign: Integer; + + Id_ClassAssign: Integer; + + Id_VariantFromClass: Integer; // JS only + Id_VariantFromPointer: Integer; // JS only + Id_ClassFromVariant: Integer; // JS only + + Id_InterfaceFromClass, + Id_InterfaceCast, + Id_InterfaceAssign, + + Id_VariantFromAnsiString: Integer; + Id_VariantFromWideString: Integer; + Id_VariantFromUnicString: Integer; + Id_VariantFromShortString: Integer; + Id_VariantFromAnsiChar: Integer; + Id_VariantFromWideChar: Integer; + Id_VariantFromInt: Integer; + Id_VariantFromInt64: Integer; + Id_VariantFromByte: Integer; + Id_VariantFromBool: Integer; + Id_VariantFromWord: Integer; + Id_VariantFromCardinal: Integer; + Id_VariantFromSmallInt: Integer; + Id_VariantFromShortInt: Integer; + Id_VariantFromDouble: Integer; + Id_VariantFromCurrency: Integer; + Id_VariantFromSingle: Integer; + Id_VariantFromExtended: Integer; + + Id_AnsiStringFromInt: Integer; // JS only + Id_AnsiStringFromDouble: Integer; // JS only + Id_AnsiStringFromSingle: Integer; // JS only + Id_AnsiStringFromExtended: Integer; // JS only + Id_AnsiStringFromBoolean: Integer; // JS only + + Id_UnicStringFromInt: Integer; // JS only + Id_UnicStringFromDouble: Integer; // JS only + Id_UnicStringFromSingle: Integer; // JS only + Id_UnicStringFromExtended: Integer; // JS only + Id_UnicStringFromBoolean: Integer; // JS only + + Id_FuncObjFromVariant: Integer; // JS only + + Id_PushContext: Integer; // JS only + Id_PopContext: Integer; // JS only + Id_FindContext: Integer; // JS only + + Id_AnsiCharFromVariant: Integer; + Id_WideCharFromVariant: Integer; + Id_AnsiStringFromVariant: Integer; + Id_WideStringFromVariant: Integer; + Id_UnicStringFromVariant: Integer; + Id_ShortStringFromVariant: Integer; + Id_DoubleFromVariant: Integer; + Id_CurrencyFromVariant: Integer; + Id_SingleFromVariant: Integer; + Id_ExtendedFromVariant: Integer; + Id_IntFromVariant: Integer; + Id_Int64FromVariant: Integer; + Id_ByteFromVariant: Integer; + Id_WordFromVariant: Integer; + Id_CardinalFromVariant: Integer; + Id_SmallIntFromVariant: Integer; + Id_ShortIntFromVariant: Integer; + Id_BoolFromVariant: Integer; + Id_ByteBoolFromVariant: Integer; + Id_WordBoolFromVariant: Integer; + Id_LongBoolFromVariant: Integer; + Id_VariantAddition: Integer; + Id_VariantSubtraction: Integer; + Id_VariantMultiplication: Integer; + Id_VariantDivision: Integer; + Id_VariantIDivision: Integer; + Id_VariantModulo: Integer; + Id_VariantLeftShift: Integer; + Id_VariantRightShift: Integer; + Id_VariantAnd: Integer; + Id_VariantOr: Integer; + Id_VariantXor: Integer; + Id_VariantLessThan: Integer; + Id_VariantLessThanOrEqual: Integer; + Id_VariantGreaterThan: Integer; + Id_VariantGreaterThanOrEqual: Integer; + Id_VariantEquality: Integer; + Id_VariantNotEquality: Integer; + Id_StructEquality: Integer; + Id_StructNotEquality: Integer; + Id_VariantNegation: Integer; + Id_VariantAbs: Integer; + Id_VariantNot: Integer; + Id_VarArrayGet1: Integer; + Id_VarArrayPut1: Integer; + Id_VarArrayGet2: Integer; + Id_VarArrayPut2: Integer; + Id_VarArrayGet3: Integer; + Id_VarArrayPut3: Integer; + Id_DynarrayClr: Integer; + Id_DynarrayAssign: Integer; + Id_CreateEmptyDynarray: Integer; + Id_DynarraySetLength: Integer; + Id_DynarraySetLength2: Integer; + Id_DynarraySetLength3: Integer; + Id_DynarrayHigh: Integer; + + Id_DoubleMultiplication: Integer; + Id_DoubleDivision: Integer; + Id_DoubleAddition: Integer; + Id_DoubleSubtraction: Integer; + Id_DoubleNegation: Integer; + + Id_OleVariantFromVariant: Integer; + Id_OleVariantFromPAnsiChar: Integer; + Id_OleVariantFromPWideChar: Integer; + Id_OleVariantFromAnsiString: Integer; + Id_OleVariantFromWideString: Integer; + Id_OleVariantFromUnicString: Integer; + Id_OleVariantFromShortString: Integer; + Id_OleVariantFromAnsiChar: Integer; + Id_OleVariantFromWideChar: Integer; + Id_OleVariantFromInt: Integer; + Id_OleVariantFromInt64: Integer; + Id_OleVariantFromByte: Integer; + Id_OleVariantFromBool: Integer; + Id_OleVariantFromWord: Integer; + Id_OleVariantFromCardinal: Integer; + Id_OleVariantFromSmallInt: Integer; + Id_OleVariantFromShortInt: Integer; + Id_OleVariantFromDouble: Integer; + Id_OleVariantFromCurrency: Integer; + Id_OleVariantFromSingle: Integer; + Id_OleVariantFromExtended: Integer; + Id_OleVariantFromInterface: Integer; + + Id_GetComponent: Integer; + + Id_SetInclude: Integer; + Id_SetIncludeInterval: Integer; + Id_SetExclude: Integer; + Id_SetUnion: Integer; + Id_SetDifference: Integer; + Id_SetIntersection: Integer; + Id_SetSubset: Integer; + Id_SetSuperset: Integer; + Id_SetEquality: Integer; + Id_SetInequality: Integer; + Id_SetMembership: Integer; + + Id_ClassName: Integer; + Id_OnCreateObject: Integer; + Id_OnAfterObjectCreation: Integer; + + Id_OnCreateHostObject: Integer; + Id_OnDestroyHostObject: Integer; + + Id_BeforeCallHost: Integer; + Id_AfterCallHost: Integer; + + Id_GetAnsiStrProp: Integer; + Id_SetAnsiStrProp: Integer; + Id_GetWideStrProp: Integer; + Id_SetWideStrProp: Integer; + Id_GetUnicStrProp: Integer; + Id_SetUnicStrProp: Integer; + Id_GetOrdProp: Integer; + Id_SetOrdProp: Integer; + Id_GetInterfaceProp: Integer; + Id_SetInterfaceProp: Integer; + Id_GetSetProp: Integer; + Id_SetSetProp: Integer; + Id_GetFloatProp: Integer; + Id_SetFloatProp: Integer; + Id_GetVariantProp: Integer; + Id_SetVariantProp: Integer; + Id_GetInt64Prop: Integer; + Id_SetInt64Prop: Integer; + Id_GetEventProp: Integer; + Id_SetEventProp: Integer; + Id_SetEventProp2: Integer; + Id_CreateMethod: Integer; + + Id_CreateObject: Integer; + + Id_TryOn: Integer; + Id_TryOff: Integer; + Id_Raise: Integer; + Id_Exit: Integer; + Id_Finally: Integer; + Id_CondRaise: Integer; + Id_BeginExceptBlock: Integer; + Id_EndExceptBlock: Integer; + Id_Pause: Integer; + Id_Halt: Integer; + + Id_GetClassByIndex: Integer; + + Id_CheckPause: Integer; + Id_InitSub: Integer; + Id_EndSub: Integer; + + Id_IntOver: Integer; + Id_BoundError: Integer; + + Id_AssignTVarRec: Integer; + Id_TObject_Destroy: Integer; + + Id_ErrAbstract: Integer; + Id_RecordAssign: Integer; + + Id_TObject_Free: Integer; + Id_TObject_GetInterface: Integer; + + CURR_FMUL_ID: Integer; + + Id_TDateTime: integer = 0; + H_TFW_Object: Integer = 0; + H_TFW_Boolean: Integer = 0; + H_TFW_ByteBool: Integer = 0; + H_TFW_WordBool: Integer = 0; + H_TFW_LongBool: Integer = 0; + H_TFW_Byte: Integer = 0; + H_TFW_SmallInt: Integer = 0; + H_TFW_ShortInt: Integer = 0; + H_TFW_Word: Integer = 0; + H_TFW_Cardinal: Integer = 0; + H_TFW_Double: Integer = 0; + H_TFW_Single: Integer = 0; + H_TFW_Extended: Integer = 0; + H_TFW_Currency: Integer = 0; + H_TFW_AnsiChar: Integer = 0; + H_TFW_WideChar: Integer = 0; + H_TFW_Integer: Integer = 0; + H_TFW_Int64: Integer = 0; + H_TFW_Variant: Integer = 0; + H_TFW_DateTime: Integer = 0; + H_TFW_AnsiString: Integer = 0; + H_TFW_UnicString: Integer = 0; + H_TFW_Array: Integer = 0; + FWArrayOffset: Integer = 0; + Id_FWArray_Create: Integer = 0; + Id_FWArray_GetLength: Integer = 0; + + Id_ToFWObject: Integer = 0; + Id_PaxSEHHandler: Integer = 0; + + Id_InitFWArray: Integer = 0; + +{$IFDEF TRIAL} +var strShowTrial: array[0..10] of Char; +{$ENDIF} + GlobalSymbolTable: TBaseSymbolTable; + GlobalImportTable: TBaseSymbolTable; + GlobalExtraImportTableList: TExtraImportTableList; + List: TExtraImportTableList; + +type + TMyInterfacedObject = class(TInterfacedObject); +procedure TMyInterfacedObject_AddRef(Self: TObject); stdcall; +procedure TMyInterfacedObject_Release(Self: TObject); stdcall; + +{$IFNDEF PAXARM} +procedure _SetAnsiStrProp(PropInfo: PPropInfo; Instance: TObject; + const value: AnsiString); stdcall; +procedure _SetWideStrProp(PropInfo: PPropInfo; Instance: TObject; + const value: WideString); stdcall; +procedure _WideStringFromPWideChar(source: PWideChar; var dest: WideString); stdcall; +{$ENDIF} +procedure _SetUnicStrProp(PropInfo: PPropInfo; Instance: TObject; + const value: UnicString); stdcall; + +procedure _DynarrayClr(var A: Pointer; + FinalTypeID, TypeID, ElSize, + FinalTypeID2, TypeID2, ElSize2: Integer); stdcall; +procedure _DynarrayAssign(var Source, Dest: Pointer; + FinalTypeID, TypeID, ElSize, + FinalTypeID2, TypeID2, ElSize2: Integer); stdcall; + +procedure _DynarraySetLength(var A: Pointer; L: Integer; + ElFinalTypeID, ElTypeID, ElSize: Integer); stdcall; +procedure _DynarraySetLength2(var A: Pointer; L1, L2: Integer; + ElFinalTypeID, ElTypeID, ElSize: Integer); stdcall; +procedure _DynarraySetLength3(var A: Pointer; L1, L2, L3: Integer; + ElFinalTypeID, ElTypeID, ElSize: Integer); stdcall; + +procedure _DynarrayClr1(var A: Pointer; + FinalTypeID, TypeID, ElSize: Integer); stdcall; +procedure _DynarrayClr2(var A: Pointer; + FinalTypeID, TypeID, ElSize: Integer); stdcall; +procedure _DynarrayClr3(var A: Pointer; + FinalTypeID, TypeID, ElSize: Integer); stdcall; +function _DynarrayLength(P: Pointer): Integer; +procedure _ClearTVarRec(var Dest: TVarRec); +procedure _SetVariantLength(var V: Variant; VType: Integer; L: Integer); stdcall; +procedure _SetVariantLength2(var V: Variant; VType: Integer; L1, L2: Integer); stdcall; +procedure _SetVariantLength3(var V: Variant; VType: Integer; L1, L2, L3: Integer); stdcall; + +procedure AddStdRoutines(st: TBaseSymbolTable); + +type + DynarrayPointer = array of Pointer; + +var + Import_TValue: procedure(Level: Integer; st: TBaseSymbolTable) = nil; + +procedure _InterfaceFromClass(Dest: PIUnknown; + GUID: PGUID; + SourceAddress: Pointer); stdcall; +procedure _InterfaceCast(Dest: PIUnknown; + GUID: PGUID; + Source: PIUnknown); stdcall; +function GetPaxInterface(Self: TObject; const GUID: TGUID; var obj: Pointer): Boolean; +function UpdateSet(const S: TByteSet; L: Integer): TByteSet; + +procedure _PrintEx(PP: Pointer; + Address: Pointer; + Kind: Integer; + FT: Integer; + L1, L2: Integer); stdcall; +procedure _AssignTVarRec(P: Pointer; + Address: Pointer; + var Dest: TVarRec; + TypeID: Integer); stdcall; +function _LoadProc(Runner: Pointer; + ProcHandle: Integer; + ProcName: PChar; + DllName: PChar; + OverCount: Integer): Pointer; stdcall; +procedure _Halt(Runner: Pointer; ExitCode: Integer); stdcall; +procedure _AddMessage(Runner: Pointer; msg_id: Integer; FullName: PChar); stdcall; +procedure _OnAfterObjectCreation(Runner: Pointer; Instance: PObject); stdcall; +procedure _TypeInfo(Prog: Pointer; FullTypeName: PChar; var result: PTypeInfo); stdcall; +{$IFNDEF PAXARM} +function _InitInstance(Self: TClass; Instance: Pointer): TObject; +{$ENDIF} +procedure _ToParentClass2(Instance: TObject); stdcall; +procedure _UpdateInstance2(Instance: TObject; C: TClass); stdcall; +procedure _SetInclude(S: PByteSet; value: Integer); stdcall; +procedure _SetIncludeInterval(S: PByteSet; B1, B2: Integer); stdcall; +procedure _ShortStringAssign(const source: ShortString; Ldest: Integer; dest: PShortString); +stdcall; +procedure _CreateEmptyDynarray(var A: Pointer); stdcall; +procedure _GetComponent(X: TComponent; I: Integer; var Y: TComponent); stdcall; + +function GetPointerType(T: Integer): Integer; + +procedure FindAvailTypes; + +implementation + +uses +{$IFDEF DRTTI} + PAXCOMP_2010, + PAXCOMP_2010Reg, +{$ENDIF} + PAXCOMP_BASERUNNER, + PAXCOMP_JavaScript, + PAXCOMP_Basic, + PAXCOMP_GC, + PAXCOMP_FRAMEWORK, + PAXCOMP_TYPEINFO, + Math; + +{$IFDEF TRIAL} +procedure ShowTrial; +var a: array[0..50] of ansichar; + b: array[0..20] of ansichar; +begin + a[00] := 'T'; + a[01] := 'h'; + a[02] := 'i'; + a[03] := 's'; + a[04] := ' '; + a[05] := 'i'; + a[06] := 's'; + a[07] := ' '; + a[08] := 'a'; + a[09] := 'n'; + a[10] := ' '; + a[11] := 'e'; + a[12] := 'v'; + a[13] := 'a'; + a[14] := 'l'; + a[15] := 'u'; + a[16] := 'a'; + a[17] := 't'; + a[18] := 'i'; + a[19] := 'o'; + a[20] := 'n'; + a[21] := ' '; + a[22] := 'c'; + a[23] := 'o'; + a[24] := 'p'; + a[25] := 'y'; + a[26] := ' '; + a[27] := 'o'; + a[28] := 'f'; + a[29] := ' '; + a[30] := 'p'; + a[31] := 'a'; + a[32] := 'x'; + a[33] := 'C'; + a[34] := 'o'; + a[35] := 'm'; + a[36] := 'p'; + a[37] := 'i'; + a[38] := 'l'; + a[39] := 'e'; + a[40] := 'r'; + a[41] := '.'; + a[42] := #0; + + b[00] := 'p'; + b[01] := 'a'; + b[02] := 'x'; + b[03] := 'C'; + b[04] := 'o'; + b[05] := 'm'; + b[06] := 'p'; + b[07] := 'i'; + b[08] := 'l'; + b[09] := 'e'; + b[10] := 'r'; + b[11] := #0; + +{$IFDEF LINUX} +{$IFDEF FPC} +// I will give you a better call for FPC/LINUX // +{$ELSE} + Application.MessageBox(PChar(S), 'paxCompiler', [smbOK]); +{$ENDIF} +{$ELSE} +{$IFDEF UNIX} + Writeln('Error '+S); +{$ELSE} + MessageBox(GetActiveWindow(), PChar(String(a)), PChar(String(b)), + MB_ICONEXCLAMATION or MB_OK); +{$ENDIF} +{$ENDIF} + +end; +{$ENDIF} + +procedure _BeginSub; +begin +end; + +procedure _Write; +begin +end; + +procedure _Writeln; +begin + writeln; +end; + +procedure _WriteBool(value: Boolean); +begin + write(value); +end; + +procedure _WriteByteBool(value: ByteBool); +begin + write(value); +end; + +procedure _WriteWordBool(value: WordBool); +begin + write(value); +end; + +procedure _WriteLongBool(value: LongBool); +begin + write(value); +end; + +{$IFDEF VARIANTS} +procedure _WriteWideChar(value: WideChar); +begin + write(value); +end; +{$ELSE} +procedure _WriteWideChar(value: WideChar); +var + S: AnsiString; +begin + S := value; + write(S); +end; +{$ENDIF} + +procedure _WriteByte(value: Byte; L: Integer); +begin + if L = 0 then + write(value) + else + write(value:L); +end; + +procedure _WriteWord(value: Word; L: Integer); +begin + if L = 0 then + write(value) + else + write(value:L); +end; + +procedure _WriteCardinal(value: Cardinal; L: Integer); +begin + if L = 0 then + write(value) + else + write(value:L); +end; + +procedure _WriteSmallInt(value: SmallInt; L: Integer); +begin + if L = 0 then + write(value) + else + write(value:L); +end; + +procedure _WriteShortInt(value: ShortInt; L: Integer); +begin + if L = 0 then + write(value) + else + write(value:L); +end; + +procedure _WriteInt(value: Integer; L: Integer); +begin + if L = 0 then + write(value) + else + write(value:L); +end; + +procedure _WriteInt64(value: Int64; L: Integer); +begin + if L = 0 then + write(value) + else + write(value:L); +end; + +procedure _WriteDouble(value: Double; L1, L2: Integer); +begin + if L1 > 0 then + begin + if L2 > 0 then + write(value:L1:L2) + else + write(value:L1); + end + else + write(value); +end; + +procedure _WriteSingle(value: Single; L1, L2: Integer); +begin + if L1 > 0 then + begin + if L2 > 0 then + write(value:L1:L2) + else + write(value:L1); + end + else + write(value); +end; + +procedure _WriteCurrency(value: Currency; L1, L2: Integer); +begin + if L1 > 0 then + begin + if L2 > 0 then + write(value:L1:L2) + else + write(value:L1); + end + else + write(value); +end; + +procedure _WriteExtended(value: Extended; L1, L2: Integer); +begin + if L1 > 0 then + begin + if L2 > 0 then + write(value:L1:L2) + else + write(value:L1); + end + else + write(value); +end; + +{$IFNDEF PAXARM} + +procedure _WriteString(const value: AnsiString; L: Integer); +begin + if L = 0 then + write(value) + else + write(value:L); +end; + +procedure _WriteAnsiChar(value: AnsiChar); +begin + write(value); +end; + +procedure _WriteShortString(const value: ShortString; L: Integer); +begin + if L = 0 then + write(value) + else + write(value:L); +end; +{$ENDIF} + +{$IFDEF VARIANTS} +{$IFNDEF PAXARM} +procedure _WriteWideString(const value: WideString; L: Integer); +begin + if L = 0 then + write(value) + else + write(value:L); +end; +{$ENDIF} +{$ELSE} +procedure _WriteWideString(const value: WideString; L: Integer); +var + S: AnsiString; +begin + S := value; + if L = 0 then + write(S) + else + write(S:L); +end; +{$ENDIF} + +{$IFDEF VARIANTS} +procedure _WriteUnicString(const value: UnicString; L: Integer); +begin + if L = 0 then + write(value) + else + write(value:L); +end; +{$ELSE} +procedure _WriteUnicString(const value: UnicString; L: Integer); +var + S: AnsiString; +begin + S := value; + if L = 0 then + write(S) + else + write(S:L); +end; +{$ENDIF} + +procedure _WriteVariant(const value: Variant; L1, L2: Integer); +var +{$IFDEF PAXARM} + S: String; +{$ELSE} + {$IFDEF FPC} + S: String; + {$ELSE} + S: ShortString; + {$ENDIF} +{$ENDIF} +begin + if L1 > 0 then + begin +{$IFDEF PAXARM} + S := VarToStr(value); +{$ELSE} +{$IFDEF FPC} + S := VarToStr(value); +{$ELSE} + if L2 > 0 then + STR(value:L1:L2, S) + else + STR(value:L1, S); + write(S); +{$ENDIF} +{$ENDIF} + end + else + begin + if VarType(value) = varEmpty then + write('undefined') + else + write(VarToStr(value)); + end; +end; + +procedure _WriteObject(const value: TObject); +begin + write('[' + value.ClassName + ']'); +end; + +{$IFDEF DRTTI} +function CheckField(t: TRTTIType; f: TRTTIField): Boolean; +begin + result := false; + if not CheckType(f.FieldType) then + Exit; + if f.Parent <> t then + Exit; + result := true; +end; +{$ENDIF} + +type + TStdPrintHandler = class + public + S: String; + procedure DoPrintClassTypeField(Sender: TObject; + const Infos: TPrintClassTypeFieldInfo); + procedure DoPrintClassTypeProp(Sender: TObject; + const Infos: TPrintClassTypePropInfo); + end; + +procedure TStdPrintHandler.DoPrintClassTypeField(Sender: TObject; + const Infos: TPrintClassTypeFieldInfo); +begin + if Infos.FieldIndex = 0 then + begin + if Infos.Started then + S := '(' + else + S := S + '('; + end; + S := S + Infos.FieldName; + S := S + ': '; + S := S + ScalarValueToString(Infos.Address, Infos.TypeId); + if Infos.FieldIndex = Infos.FieldCount - 1 then + begin + S := S + ')'; + if Infos.Finished then + Exit; + end + else + S := S + '; '; +end; + +procedure TStdPrintHandler.DoPrintClassTypeProp(Sender: TObject; + const Infos: TPrintClassTypePropInfo); +begin + if Infos.PropIndex = 0 then + begin + if Infos.Started then + S := '(' + else + S := S + '('; + end; + S := S + Infos.PropName; + S := S + ': '; + S := S + Infos.StrValue; + if Infos.PropIndex = Infos.PropCount - 1 then + begin + S := S + ')'; + if Infos.Finished then + Exit; + end + else + S := S + '; '; +end; + +procedure _PrintEx(PP: Pointer; + Address: Pointer; + Kind: Integer; + FT: Integer; + L1, L2: Integer); stdcall; +var + S: String; +{$IFDEF PAXARM} + SS: String; + type ShortString = string; + var +{$ELSE} + SS: ShortString; +{$ENDIF} +{$IFDEF DRTTI} + ClassTypeInfoContainer: TClassTypeInfoContainer; + ClassTypeDataContainer: TClassTypeDataContainer; + FieldInfos: TPrintClassTypeFieldInfo; + PropInfos: TPrintClassTypePropInfo; + f: TRTTIField; + t: TRTTIType; + K: Integer; + ptd: PTypeData; + I: Integer; + pti: PTypeInfo; + nProps: Integer; + pProps: PPropList; + ppi: PPropInfo; +{$ENDIF} + X: TObject; + P: TBaseRunner; +label + ByRef; +begin + P := TBaseRunner(PP); + + if Assigned(P) then + if Assigned(P.OnPrintEx) then + begin + P.OnPrintEx(P.Owner, Address, Kind, FT, L1, L2); + Exit; + end; + +try + if Kind = KindCONST then + begin +{$IFNDEF PAXARM} + if FT = typeANSICHAR then + begin + S := String(AnsiChar(Byte(Address))); + end + else +{$ENDIF} + if FT = typeWIDECHAR then + begin + S := String(WideChar(Word(Address))); + end + else if FT in UnsignedIntegerTypes then + begin + if L1 > 0 then + STR(Cardinal(Address):L1, SS) + else + STR(Cardinal(Address), SS); + S := String(SS); + end + else if FT in OrdinalTypes then + begin + if L1 > 0 then + STR(Integer(Address):L1, SS) + else + STR(Integer(Address), SS); + S := String(SS); + end +{$IFNDEF PAXARM} + else if FT = typePANSICHAR then + begin + S := String(StrPas(PAnsiChar(Address))); + end +{$ENDIF} + else if FT = typePWIDECHAR then + begin + S := String(UnicString(PWideChar(Address))); + end + else + goto ByRef; + end + else // Kind = KindVAR + begin + +ByRef: + + case FT of + typeBOOLEAN: if Boolean(Address^) then + S := 'true' + else + S := 'false'; + typeBYTE, typeENUM: + begin + if L1 > 0 then + STR(Byte(Address^):L1, SS) + else + STR(Byte(Address^), SS); + S := String(SS); + end; +{$IFNDEF PAXARM} + typeANSICHAR: S := String(AnsiChar(Address^)); + typeANSISTRING: + begin + S := String(AnsiString(Address^)); + while Length(S) < L1 do + S := S + ' '; + end; +{$ENDIF} + typeUNICSTRING: + begin + S := String(UnicString(Address^)); + while Length(S) < L1 do + S := S + ' '; + end; +{$IFNDEF PAXARM} + typePANSICHAR: + S := String(StrPas(PAnsiChar(Address^))); +{$ENDIF} + typePWIDECHAR: + S := String(PWideChar(Address^)); + typeWORD: + begin + if L1 > 0 then + STR(Word(Address^):L1, SS) + else + STR(Word(Address^), SS); + S := String(SS); + end; + typeINTEGER: + begin + if L1 > 0 then + STR(Integer(Address^):L1, SS) + else + STR(Integer(Address^), SS); + S := String(SS); + end; + typeDOUBLE: + begin + if (L1 > 0) and (L2 > 0) then + STR(Double(Address^):L1:L2, SS) + else if L1 > 0 then + STR(Double(Address^):L1, SS) + else + STR(Double(Address^), SS); + S := String(SS); + end; + typePOINTER: S := String(Format('%x', [Cardinal(Address^)])); + typeRECORD: S := '[record]'; + typeARRAY: S := '[array]'; + typePROC: S := '[proc]'; + typeSET: S := '[set]'; +{$IFNDEF PAXARM} + typeSHORTSTRING: + begin + S := String(ShortString(Address^)); + while Length(S) < L1 do + S := S + ' '; + end; +{$ENDIF} + typeSINGLE: + begin + if (L1 > 0) and (L2 > 0) then + STR(Single(Address^):L1:L2, SS) + else if L1 > 0 then + STR(Single(Address^):L1, SS) + else + STR(Single(Address^), SS); + S := String(SS); + end; + typeEXTENDED: + begin + if (L1 > 0) and (L2 > 0) then + begin + STR(Extended(Address^):L1:L2, SS); + end + else if L1 > 0 then + begin + STR(Extended(Address^):L1, SS); + end + else + SS := ShortString(FloatToStr(Extended(Address^))); + S := String(SS); + end; + typeCLASS: + if Integer(Address^) = 0 then + S := 'nil' + else if TObject(Address^).InheritsFrom(TFW_Object) then + begin + S := TFW_Object(Address^)._ToString; + end + else + begin + X := TObject(Address^); +{$IFDEF DRTTI} + ClassTypeInfoContainer := + GetClassTypeInfoContainer(X); + if ClassTypeInfoContainer <> nil then + begin + try + ClassTypeDataContainer := + ClassTypeInfoContainer.TypeDataContainer as + TClassTypeDataContainer; + + with ClassTypeDataContainer.FieldListContainer do + for I := 0 to Count - 1 do + begin + Address := ShiftPointer(Pointer(X), + Records[I].Offset); + + if Records[I].FinalFieldTypeId = typeCLASS then + begin + _PrintEx(P, Address, KindTYPE_FIELD, + Records[I].FinalFieldTypeId, 0, 0); + end + else + begin + FieldInfos.Host := false; + + FieldInfos.Started := false; + FieldInfos.Finished := false; + if I = 0 then + if Kind = KindVAR then + FieldInfos.Started := true; + + FieldInfos.Owner := X; + FieldInfos.FieldIndex := I; + FieldInfos.FieldCount := Count; + FieldInfos.Address := Address; + FieldInfos.FieldName := StringFromPShortString(@Records[I].Name); + FieldInfos.TypeId := Records[I].FinalFieldTypeId; + FieldInfos.Visibility := GetVisibility(Records[I].Vis); + if I = Count - 1 then + FieldInfos.Finished := true; + + if Assigned(P) then + if Assigned(P.OnPrintClassTypeField) then + begin + P.OnPrintClassTypeField(P.Owner, FieldInfos); + end; + end; + end; + + with ClassTypeDataContainer.AnotherFieldListContainer do + for I := 0 to Count - 1 do + begin + Address := ShiftPointer(Pointer(X), + Records[I].Offset); + + if Records[I].FinalFieldTypeId = typeCLASS then + begin + _PrintEx(P, Address, KindTYPE_FIELD, + Records[I].FinalFieldTypeId, 0, 0); + end + else + begin + FieldInfos.Host := false; + + FieldInfos.Started := false; + FieldInfos.Finished := false; + if I = 0 then + if Kind = KindVAR then + FieldInfos.Started := true; + + FieldInfos.Owner := X; + FieldInfos.FieldIndex := I; + FieldInfos.FieldCount := Count; + FieldInfos.Address := Address; + FieldInfos.FieldName := StringFromPShortString(@Records[I].Name); + FieldInfos.TypeId := Records[I].FinalFieldTypeId; + FieldInfos.Visibility := GetVisibility(Records[I].Vis); + if I = Count - 1 then + FieldInfos.Finished := true; + + if Assigned(P) then + if Assigned(P.OnPrintClassTypeField) then + begin + P.OnPrintClassTypeField(P.Owner, FieldInfos); + end; + end; + end; + + // published properties + + pti := X.ClassInfo; + if pti <> nil then + begin + ptd := GetTypeData(pti); + nProps := ptd^.PropCount; + GetMem(pProps, SizeOf(PPropInfo) * nProps); + try + GetPropInfos(pti, pProps); + for I:=0 to nProps - 1 do + begin + {$ifdef fpc} + ppi := pProps^[I]; + {$else} + ppi := pProps[I]; + {$endif} + case ppi^.PropType^.Kind of + tkClass: + begin + IntPax(X) := GetOrdProp(X, ppi); + _PrintEx(P, @X, KindTYPE_FIELD, + typeCLASS, 0, 0); + end; + else + begin + PropInfos.Host := false; + + PropInfos.Started := false; + PropInfos.Finished := false; + if I = 0 then + if Kind = KindVAR then + PropInfos.Started := true; + + PropInfos.Owner := X; + PropInfos.PropIndex := I; + PropInfos.PropCount := nProps; + PropInfos.StrValue := + VarToStr(GetPropValue(X, ppi)); + PropInfos.PropName := StringFromPShortString(@ppi^.Name); + PropInfos.Visibility := mvPublished; + if I = nProps - 1 then + PropInfos.Finished := true; + + if Assigned(P) then + if Assigned(P.OnPrintClassTypeProp) then + begin + P.OnPrintClassTypeProp(P.Owner, PropInfos); + end; + end; + end; + end; + finally + FreeMem(pProps, SizeOf(PPropInfo) * nProps); + end; + end; + finally + FreeAndNil(ClassTypeInfoContainer); + end; + end + else // this is an object of host-defined class. + begin + t := PaxContext.GetType(X.ClassType); + + K := 0; + + for f in t.GetFields do + if CheckField(t, f) then + Inc(K); + + I := 0; + for f in t.GetFields do + if CheckField(t, f) then + begin + Inc(I); + Address := ShiftPointer(Pointer(X), + f.Offset); + + if f.FieldType is TRTTIRecordType then + begin + _PrintEx(P, Address, KindTYPE_FIELD, + typeRECORD, 0, 0); + end + else if f.FieldType is TRTTIInstanceType then + begin + _PrintEx(P, Address, KindTYPE_FIELD, + typeCLASS, 0, 0); + end + else + begin + FieldInfos.Host := true; + FieldInfos.Started := false; + FieldInfos.Finished := false; + if I = 0 then + if Kind = KindVAR then + FieldInfos.Started := true; + FieldInfos.Owner := X; + FieldInfos.FieldIndex := I; + FieldInfos.FieldCount := K; + FieldInfos.Address := Address; + FieldInfos.FieldName := f.Name; + FieldInfos.FieldTypeName := f.FieldType.Name; + FieldInfos.TypeId := PtiToFinType(f.FieldType.Handle); + FieldInfos.Visibility := f.Visibility; + if I = K - 1 then + FieldInfos.Finished := true; + if Assigned(P) then + if Assigned(P.OnPrintClassTypeField) then + begin + P.OnPrintClassTypeField(P.Owner, FieldInfos); + end; + end; + end; + end; + +{$ELSE} + S := '[Object: ' + X.ClassName + ']'; +{$ENDIF} + end; + typeCLASSREF: + if Integer(Address^) = 0 then + S := 'nil' + else + S := '[Class ref: ' + TClass(Address^).ClassName + ']'; + typeWIDECHAR: S := WideChar(Address^); +{$IFNDEF PAXARM} + typeWIDESTRING: S := WideString(Address^); +{$ENDIF} + typeVARIANT, typeOLEVARIANT: + begin + if TVarData(Variant(Address^)).VType = varDispatch then + S := '[dispatch]' + else + if (L1 > 0) and (L2 > 0) then + begin + {$IFDEF FPC} + S := VarToStr(Variant(Address^)); + {$ELSE} + STR(Variant(Address^):L1:L2, SS); + S := String(SS); + {$ENDIF} + end + else if L1 > 0 then + begin + {$IFDEF FPC} + S := VarToStr(Variant(Address^)); + {$ELSE} + STR(Variant(Address^):L1, SS); + S := String(SS); + {$ENDIF} + end + else + S := VarToStr(Variant(Address^)); + end; + typeDYNARRAY: S := '[dynarray]'; + typeINT64: + begin + if L1 > 0 then + STR(Int64(Address^):L1, SS) + else + STR(Int64(Address^), SS); + S := String(SS); + end; + typeUINT64: + begin + if L1 > 0 then + STR(UInt64(Address^):L1, SS) + else + STR(UInt64(Address^), SS); + S := String(SS); + end; + typeINTERFACE: S := '[interface]'; + typeCARDINAL: + begin + if L1 > 0 then + STR(Cardinal(Address^):L1, SS) + else + STR(Cardinal(Address^), SS); + S := String(SS); + end; + typeEVENT: S := '[event]'; + typeCURRENCY: + begin + if (L1 > 0) and (L2 > 0) then + STR(Currency(Address^):L1:L2, SS) + else if L1 > 0 then + STR(Currency(Address^):L1, SS) + else + STR(Currency(Address^), SS); + S := String(SS); + end; + typeSMALLINT: + begin + if L1 > 0 then + STR(SmallInt(Address^):L1, SS) + else + STR(SmallInt(Address^), SS); + S := String(SS); + end; + typeSHORTINT: + begin + if L1 > 0 then + STR(ShortInt(Address^):L1, SS) + else + STR(ShortInt(Address^), SS); + S := String(SS); + end; + typeWORDBOOL: if WordBool(Address^) then + S := 'true' + else + S := 'false'; + typeLONGBOOL: if LongBool(Address^) then + S := 'true' + else + S := 'false'; + typeBYTEBOOL: if ByteBool(Address^) then + S := 'true' + else + S := 'false'; + else + S := ''; + end; + end; + +except + on E: Exception do + begin + S := E.Message; + raise; + end; +end; + + if Assigned(P) then + if Assigned(P.OnPrint) then + begin + P.OnPrint(P.Owner, S); + Exit; + end; + +{$IFDEF CONSOLE} + write(S); + Exit; +{$ELSE} +{$IFDEF PAXARM} +{$IFDEF PAXARM_DEVICE} + ShowMessage(S); +{$ELSE} + ShowMessage(S); +{$ENDIF} +{$ELSE} +{$IFDEF LINUX} + ShowMessage(S); +{$ELSE} + {$IFDEF MACOS32} + ShowMessage(S); + {$ELSE} + MessageBox(GetActiveWindow(), PChar(String(S)), PChar('paxCompiler'), MB_ICONEXCLAMATION or MB_OK); + {$ENDIF} +{$ENDIF} +{$ENDIF} +{$ENDIF} +end; + +procedure _GetMem(var P: Pointer; Size: Integer); +begin + GetMem(P, Size); +end; + +procedure _FreeMem(P: Pointer; Size: Integer); +begin + FreeMem(P, Size); +end; + +// -------- ORDINAL FUNCTIONS -------------------------------------------------- + +function _Odd(X: Integer): Boolean; +begin + result := Odd(X); +end; + +//--------- SET ROUTINES ------------------------------------------------------ + +type + TSetBytes = array[1..SizeOf(TByteSet)] of Byte; + +function UpdateSet(const S: TByteSet; L: Integer): TByteSet; +var + I: Integer; +begin + FillChar(result, SizeOf(result), 0); + for I := 1 to L do + TSetBytes(result)[I] := TSetBytes(S)[I]; +end; + +procedure _SetInclude(S: PByteSet; value: Integer); stdcall; +begin + if (value < 0) or (value > 255) then + raise Exception.Create(errInvalidSet); + Include(S^, value); +end; + +procedure _SetIncludeInterval(S: PByteSet; B1, B2: Integer); stdcall; +var + value: Integer; +begin + if (B1 < 0) or (B1 > 255) then + raise Exception.Create(errInvalidSet); + if (B2 < 0) or (B2 > 255) then + raise Exception.Create(errInvalidSet); + for value:=B1 to B2 do + Include(S^, value); +end; + +procedure _SetExclude(var S: TByteSet; value: Integer); stdcall; +begin + if (value < 0) or (value > 255) then + raise Exception.Create(errInvalidSet); + Exclude(S, value); +end; + +procedure _SetUnion(var S1: TByteSet; var S2: TByteSet; + var R: TByteSet; + SZ1, SZ2: Integer); stdcall; +var + L: Integer; + Res: TByteSet; +begin + if SZ2 < SZ1 then + L := SZ2 + else + L := SZ1; + Res := UpdateSet(S1, L) + UpdateSet(S2, L); + Move(Res, R, L); +end; + +procedure _SetDifference(var S1: TByteSet; var S2: TByteSet; + var R: TByteSet; + SZ1, SZ2: Integer); stdcall; +var + L: Integer; + Res: TByteSet; +begin + if SZ2 < SZ1 then + L := SZ2 + else + L := SZ1; + Res := UpdateSet(S1, L) - UpdateSet(S2, L); + Move(Res, R, L); +end; + +procedure _SetIntersection(var S1: TByteSet; var S2: TByteSet; + var R: TByteSet; + SZ1, SZ2: Integer); stdcall; +var + L: Integer; + Res: TByteSet; +begin + if SZ2 < SZ1 then + L := SZ2 + else + L := SZ1; + Res := UpdateSet(S1, L) * UpdateSet(S2, L); + Move(Res, R, L); +end; + +function _SetSubset(var S1: TByteSet; var S2: TByteSet; + SZ1, SZ2: Integer): Boolean; stdcall; +var + L: Integer; +begin + if SZ2 < SZ1 then + L := SZ2 + else + L := SZ1; + result := UpdateSet(S1, L) <= UpdateSet(S2, L); +end; + +function _SetSuperset(var S1: TByteSet; var S2: TByteSet; + SZ1, SZ2: Integer): Boolean; stdcall; +var + L: Integer; +begin + if SZ2 < SZ1 then + L := SZ2 + else + L := SZ1; + result := UpdateSet(S1, L) >= UpdateSet(S2, L); +end; + +function _SetEquality(const S1: TByteSet; const S2: TByteSet; + SZ1, SZ2: Integer): Boolean; stdcall; +var + L, I: Integer; +begin + if SZ2 < SZ1 then + L := SZ2 + else + L := SZ1; + result := true; + for I := 1 to L do + if TSetBytes(S1)[I] <> TSetBytes(S2)[I] then + begin + result := false; + Exit; + end; +end; + +function _SetInequality(const S1: TByteSet; const S2: TByteSet; + SZ1, SZ2: Integer): Boolean; stdcall; +var + L, I: Integer; +begin + if SZ2 < SZ1 then + L := SZ2 + else + L := SZ1; + result := false; + for I := 1 to L do + if TSetBytes(S1)[I] <> TSetBytes(S2)[I] then + begin + result := true; + Exit; + end; +end; + +function _SetMembership(value: Integer; var S: TByteSet): Boolean; stdcall; +begin + result := value in S; +end; + +//--------- AnsiString ROUTINES ---------------------------------------------------- + +type + PStringRec = ^TStringRec; + TStringRec = packed record + RefCount: Longint; + Length: Longint; + end; + +{$IFNDEF PAXARM} +{$IFDEF MACOS32} +procedure _DecStringCounter(var S: AnsiString); +var + P: PStringRec; + D: Pointer; +begin + D := Pointer(S); + if D <> nil then + begin + P := PStringRec(Integer(D) - sizeof(TStringRec)); + if P^.RefCount > 0 then + begin + Dec(P^.RefCount); + if P^.refCount = 0 then + FreeMem(P); + end; + end; +end; +{$ELSE} +procedure _DecStringCounter(var S: AnsiString); +var + P: PStringRec; + D: Pointer; +begin + D := Pointer(S); + if D <> nil then + begin + P := PStringRec(Integer(D) - sizeof(TStringRec)); + if P^.RefCount > 0 then + if InterlockedDecrement(P^.refCount) = 0 then + FreeMem(P); + end; +end; +{$ENDIF} +{$ENDIF} + +{$IFNDEF PAXARM} +{$IFDEF MACOS32} +procedure _IncStringCounter(var S: AnsiString); +var + P: PStringRec; + D: Pointer; +begin + D := Pointer(S); + if D <> nil then + begin + P := PStringRec(Integer(D) - sizeof(TStringRec)); + Inc(P^.RefCount); + end; +end; +{$ELSE} +procedure _IncStringCounter(var S: AnsiString); +var + P: PStringRec; + D: Pointer; +begin + D := Pointer(S); + if D <> nil then + begin + P := PStringRec(Integer(D) - sizeof(TStringRec)); + InterlockedIncrement(P^.refCount); + end; +end; +{$ENDIF} +{$ENDIF} + +procedure _LoadClassRef(P: TBaseRunner; + C: TClass); stdcall; +begin + P.GetRootProg.PassedClassRef := C; +end; + +function _LoadProc(Runner: Pointer; + ProcHandle: Integer; + ProcName: PChar; + DllName: PChar; + OverCount: Integer): Pointer; stdcall; +var + H: THandle; + Address: Pointer; + I: Integer; + Ext: String; + MR: TMapRec; + AClassName: String; + C: TClass; + VarName: String; + S, S1, S2: String; + Offset: Integer; + MapFieldRec: TMapFieldRec; + P: TBaseRunner; +label + ProcessDll; +begin + P := TBaseRunner(Runner); + Address := nil; + result := nil; + + Ext := ExtractFileExt(DllName); + if StrEql(Ext, '.' + PCU_FILE_EXT) then + begin + if Assigned(P.PausedPCU) then + Address := P.PausedPCU.LoadAddressEx( + DllName, ProcName, true, OverCount, MR, result) + else + Address := P.LoadAddressEx( + DllName, ProcName, true, OverCount, MR, result); + + if Address = nil then + begin + if MR <> nil then + if MR.SubDesc.DllName <> '' then + begin + DllName := PChar(MR.SubDesc.DllName); + ProcName := PChar(MR.SubDesc.AliasName); + goto ProcessDll; + end; + + raise Exception.Create(Format(errProcNotFoundInPCU, + [String(ProcName), String(DllName)])); + end; + + P.SetAddress(ProcHandle, Address); + + if (PosCh('.', ProcName) > 0) and (result <> nil) then + begin + AClassName := ExtractOwner(DllName) + '.' + ExtractOwner(ProcName); + Address := TBaseRunner(result).GetAddress(AClassName, MR); + if Address <> nil then + C := TClass(Address^) + else + Exit; + if C = nil then + Exit; + Address := P.GetAddress(AClassName, MR); + if Address <> nil then + Pointer(Address^) := C; + end; + + Exit; + end + else if (StrEql(Ext, '.' + PRM_FILE_EXT) or StrEql(Ext, '.' + PRR_FILE_EXT)) + and + (not StrEql(ProcName, 'Self')) then + begin + VarName := ProcName; + S := ExtractFullOwner(DllName); + S1 := ExtractOwner(S) + '.' + PCU_FILE_EXT; + S2 := ExtractFullName(S); + + Address := P.PausedPCU.LoadAddressEx( + S1, S2, true, OverCount, MR, result); + + if MR <> nil then + begin + I := MR.SubDesc.ParamList.IndexOf(VarName); + if I >= 0 then + begin + Offset := MR.SubDesc.ParamList[I].ParamOffset; + Address := P.PausedPCU.GetParamAddress(Offset); + if StrEql(Ext, '.' + PRR_FILE_EXT) then + Address := Pointer(Address^); + P.SetAddress(ProcHandle, Address); + end + else + P.RaiseError(errEntryPointNotFoundInPCU, [S2, S1]); + end + else + P.RaiseError(errEntryPointNotFoundInPCU, [S2, S1]); + + Exit; + end + else if StrEql(Ext, '.' + LOC_FILE_EXT) or + StrEql(Ext, '.' + LOR_FILE_EXT) then + begin + VarName := ProcName; + S := ExtractFullOwner(DllName); + S1 := ExtractOwner(S) + '.' + PCU_FILE_EXT; + S2 := ExtractFullName(S); + Address := P.PausedPCU.LoadAddressEx( + S1, S2, true, OverCount, MR, result); + if MR <> nil then + begin + I := MR.SubDesc.LocalVarList.IndexOf(VarName); + if I >= 0 then + begin + Offset := MR.SubDesc.LocalVarList[I].LocalVarOffset; + Address := P.PausedPCU.GetLocalAddress(Offset); + if StrEql(Ext, '.' + LOR_FILE_EXT) then + Address := Pointer(Address^); + P.SetAddress(ProcHandle, Address); + end + else + P.RaiseError(errEntryPointNotFoundInPCU, [S2, S1]); + end + else + P.RaiseError(errEntryPointNotFoundInPCU, [S2, S1]); + Exit; + end + else if StrEql(Ext, '.' + SLF_FILE_EXT) then + begin + VarName := ProcName; + S := ExtractFullOwner(DllName); + S1 := ExtractOwner(S) + '.' + PCU_FILE_EXT; + S2 := ExtractFullName(S); + Address := P.PausedPCU.LoadAddressEx( + S1, S2, true, OverCount, MR, result); + if MR <> nil then + begin + Offset := MR.SubDesc.SelfOffset; + Address := P.PausedPCU.GetLocalAddress(Offset); + P.SetAddress(ProcHandle, Address); + end + else + P.RaiseError(errEntryPointNotFoundInPCU, [S2, S1]); + + Exit; + end + else if StrEql(Ext, '.' + FLD_FILE_EXT) then + begin + VarName := ProcName; + S := ExtractFullOwner(DllName); + S1 := ExtractOwner(S) + '.' + PCU_FILE_EXT; + S2 := ExtractFullName(S); + Address := P.PausedPCU.LoadAddressEx( + S1, S2, true, OverCount, MR, result); + if MR <> nil then + begin + Offset := MR.SubDesc.SelfOffset; + Address := P.PausedPCU.GetLocalAddress(Offset); + if Address <> nil then + begin + MR := TBaseRunner(result).ScriptMapTable.LookupType( + ExtractFullOwner(S)); + if MR <> nil then + begin + MapFieldRec := MR.FieldList.Lookup(VarName); + if MapFieldRec <> nil then + begin + Address := ShiftPointer(Pointer(Address^), MapFieldRec.FieldOffset); + P.SetAddress(ProcHandle, Address); + end + else + P.RaiseError(errEntryPointNotFoundInPCU, [S2, S1]); + end + else + P.RaiseError(errEntryPointNotFoundInPCU, [S2, S1]); + end + else + P.RaiseError(errEntryPointNotFoundInPCU, [S2, S1]); + end; + Exit; + end; + +ProcessDll: + + if Assigned(P.OnLoadProc) then + begin + P.OnLoadProc(P.Owner, ProcName, DllName, Address); + if Address <> nil then + begin + P.SetAddress(ProcHandle, Address); + Exit; + end; + end; + + I := P.DllList.IndexOf(DllName); + if I = - 1 then + begin + {$IFDEF LINUX} + H := HMODULE(dynlibs.LoadLibrary(DLLName)); + Address := dynlibs.GetProcedureAddress(H, ProcName); + {$ELSE} + H := LoadLibrary(DllName); + Address := GetProcAddress(H, ProcName); + {$ENDIF} + if Address <> nil then + P.DllList.AddObject(DllName, TObject(H)); + end + else + begin + H := Cardinal(P.DllList.Objects[I]); + {$IFDEF LINUX} + Address := dynlibs.GetProcedureAddress(H, ProcName); + {$ELSE} + Address := GetProcAddress(H, PChar(ProcName)); + {$ENDIF} + end; + + if H = 0 then + raise Exception.Create(Format(errDllNotFound, [String(DllName)])); + + if Address = nil then + raise Exception.Create(Format(errProcNotFound, + [String(ProcName), String(DllName)])); + + P.SetAddress(ProcHandle, Address); +end; + +{$IFNDEF PAXARM} +procedure _AnsiStringFromPAnsiChar(source: PAnsiChar; var dest: AnsiString); stdcall; +begin + dest := source; +end; + +procedure _AnsiStringFromPWideChar(source: PWideChar; + var dest: AnsiString); stdcall; +begin + dest := AnsiString(WideString(source)); +end; + +procedure _AnsiStringFromAnsiChar(source: AnsiChar; var dest: AnsiString); stdcall; +begin + dest := source; +end; + +procedure _WideStringFromAnsiChar(source: AnsiChar; var dest: WideString); stdcall; +begin + dest := WideString(source); +end; + +procedure _UnicStringFromAnsiChar(source: AnsiChar; var dest: UnicString); stdcall; +begin + dest := UnicString(source); +end; + +procedure _WideStringFromShortString(var Dest: WideString; Source: ShortString); +stdcall; +begin + Dest := WideString(Source); +end; + +procedure _ShortStringFromAnsiString(var Dest: ShortString; L: Integer; var Source: AnsiString); +stdcall; +begin + Dest := Copy(Source, 1, L); +end; + +procedure _ShortStringFromWideString(var Dest: ShortString; L: Integer; var Source: WideString); +stdcall; +begin + Dest := ShortString(Copy(Source, 1, L)); +end; + +procedure _ShortStringFromPWideChar(var Dest: ShortString; L: Integer; Source: PWideChar); +stdcall; +begin + Dest := ShortString(Copy(WideString(Source), 1, L)); +end; + +procedure _ShortStringFromUnicString(var Dest: ShortString; L: Integer; var Source: UnicString); +stdcall; +begin + Dest := ShortString(Copy(Source, 1, L)); +end; + +procedure _AnsiStringFromShortString(var Dest: AnsiString; Source: ShortString); stdcall; +begin + Dest := Source; +end; + +procedure _UnicStringFromShortString(var Dest: UnicString; Source: ShortString); +stdcall; +begin + Dest := UnicString(Source); +end; + +procedure _AnsiStringFromWideString(var Dest: AnsiString; var Source: WideString); +stdcall; +begin + Dest := AnsiString(Source); +end; + +procedure _AnsiStringFromUnicString(var Dest: AnsiString; var Source: UnicString); +stdcall; +begin + Dest := AnsiString(Source); +end; + +procedure _WideStringFromAnsiString(var Dest: WideString; var Source: AnsiString); +stdcall; +begin + Dest := WideString(Source); +end; + +procedure _UnicStringFromAnsiString(var Dest: UnicString; var Source: AnsiString); +stdcall; +begin + Dest := UnicString(Source); +end; + +procedure _AnsiStringAddition(var s1: AnsiString; var s2: AnsiString; var dest: AnsiString); +stdcall; +begin + dest := s1 + s2; +end; + +procedure _ShortStringAddition(var s1, s2, dest: ShortString); +stdcall; +begin + dest := s1 + s2; +end; + +procedure _AnsiStringEquality(var s1: AnsiString; var s2: AnsiString; var dest: Boolean); +stdcall; +begin + dest := s1 = s2; +end; + +procedure _AnsiStringNotEquality(var s1: AnsiString; var s2: AnsiString; var dest: Boolean); +stdcall; +begin + dest := s1 <> s2; +end; + +procedure _ShortStringEquality(const s1: ShortString; const s2: ShortString; + var dest: Boolean); stdcall; +begin + dest := s1 = s2; +end; + +procedure _ShortStringNotEquality(const s1: ShortString; const s2: ShortString; + var dest: Boolean); stdcall; +begin + dest := s1 <> s2; +end; + +procedure _AnsiStringGreaterThan(var s1: AnsiString; var s2: AnsiString; var dest: Boolean); +stdcall; +begin + dest := s1 > s2; +end; + +procedure _AnsiStringGreaterThanOrEqual(var s1: AnsiString; var s2: AnsiString; + var dest: Boolean); stdcall; +begin + dest := s1 >= s2; +end; + +procedure _AnsiStringLessThan(var s1: AnsiString; var s2: AnsiString; var dest: Boolean); +stdcall; +begin + dest := s1 < s2; +end; + +procedure _AnsiStringLessThanOrEqual(var s1: AnsiString; var s2: AnsiString; + var dest: Boolean); stdcall; +begin + dest := s1 <= s2; +end; + +procedure _ShortStringGreaterThan(const s1: ShortString; const s2: ShortString; + var dest: Boolean); +stdcall; +begin + dest := s1 > s2; +end; + +procedure _ShortStringGreaterThanOrEqual(const s1: ShortString; + const s2: ShortString; var dest: Boolean); stdcall; +begin + dest := s1 >= s2; +end; + +procedure _ShortStringLessThan(const s1: ShortString; const s2: ShortString; + var dest: Boolean); stdcall; +begin + dest := s1 < s2; +end; + +procedure _ShortStringLessThanOrEqual(const s1: ShortString; const s2: ShortString; + var dest: Boolean); stdcall; +begin + dest := s1 <= s2; +end; + +procedure _SetShortStringLength(var S: ShortString; L: Integer); stdcall; +begin + SetLength(S, L); +end; + +procedure _SetWideStringLength(var S: WideString; L: Integer); stdcall; +begin + SetLength(S, L); +end; + +procedure _WideStringFromPAnsiChar(source: PAnsiChar; var dest: WideString); stdcall; +begin + dest := WideString(AnsiString(source)); +end; + +procedure _UnicStringFromPAnsiChar(source: PAnsiChar; var dest: UnicString); stdcall; +begin + dest := String(AnsiString(source)); +end; + +procedure _WideStringFromPWideChar(source: PWideChar; var dest: WideString); stdcall; +begin + dest := WideString(source); +end; + +procedure _WideStringFromWideChar(source: WideChar; var dest: WideString); +stdcall; +begin + dest := source; +end; + +procedure _AnsiStringFromWideChar(source: WideChar; var dest: AnsiString); +stdcall; +begin + dest := AnsiString(source); +end; + +procedure _AnsiStringAssign(var dest: AnsiString; var source: AnsiString); stdcall; +begin + dest := source; +end; + +procedure _UnicStringFromWideString(var Dest: UnicString; var Source: WideString); stdcall; +begin + Dest := Source; +end; + +procedure _WideStringFromUnicString(var Dest: WideString; var Source: UnicString); +stdcall; +begin + Dest := Source; +end; + +procedure _WideStringAssign(var dest: WideString; var source: WideString); +stdcall; +begin + dest := source; +end; + +procedure _WideStringAddition(var s1: WideString; var s2: WideString; + var dest: WideString); stdcall; +begin + dest := s1 + s2; +end; + +procedure _WideStringEquality(var s1: WideString; var s2: WideString; + var dest: Boolean); stdcall; +begin + dest := s1 = s2; +end; + +procedure _WideStringNotEquality(var s1: WideString; var s2: WideString; + var dest: Boolean); stdcall; +begin + dest := s1 <> s2; +end; + +function _Copy(const S: AnsiString; Index, Count:Integer): AnsiString; +begin + result := Copy(S, Index, Count); +end; + +procedure _Insert(Source: AnsiString; var S: AnsiString; Index: Integer); +begin + Insert(Source, S, Index); +end; + +function _PosString(const Substr: AnsiString; const S: AnsiString): Integer; +begin + result := Pos(Substr, S); +end; + +function _PosChar(c: AnsiChar; const S: AnsiString): Integer; +var + I: Integer; +begin + for I:=SLow(s) to SHigh(s) do + if s[I] = c then + begin + result := I; + Exit; + end; + result := 0; +end; + +procedure _StrInt(var S: AnsiString; L1, L2: Integer; value: Integer); stdcall; +begin + if L1 > 0 then + Str(value:L1, S) + else + Str(value, S); +end; + +procedure _StrDouble(var S: AnsiString; L2, L1: Integer; value: Double); stdcall; +begin + if L1 > 0 then + begin + if L2 > 0 then + Str(value:L1:L2, S) + else + Str(value:L1, S); + end + else + Str(value, S); +end; + +procedure _StrSingle(var S: AnsiString; L2, L1: Integer; value: Single); stdcall; +begin + if L1 > 0 then + begin + if L2 > 0 then + Str(value:L1:L2, S) + else + Str(value:L1, S); + end + else + Str(value, S); +end; + +procedure _StrExtended(var S: AnsiString; L2, L1: Integer; value: Extended); stdcall; +begin + if L1 > 0 then + begin + if L2 > 0 then + Str(value:L1:L2, S) + else + Str(value:L1, S); + end + else + Str(value, S); +end; + +procedure _VariantFromShortString(var Dest: Variant; var Source: ShortString); +stdcall; +begin + Dest := Source; +end; + +procedure _OleVariantFromShortString(var Dest: OleVariant; var Source: ShortString); +stdcall; +begin + Dest := Source; +end; + +procedure _VariantFromAnsiChar(source: AnsiChar; var dest: Variant); stdcall; +begin + dest := source; +end; + +procedure _OleVariantFromAnsiChar(source: AnsiChar; var dest: OleVariant); stdcall; +begin + dest := source; +end; + +procedure _ShortStringFromVariant(var Dest: ShortString; L: Integer; var Source: Variant); +stdcall; +begin + Dest := Copy(ShortString(source), 1, L); +end; + +procedure _WideStringGreaterThan(var s1: WideString; var s2: WideString; + var dest: Boolean); stdcall; +begin + dest := s1 > s2; +end; + +procedure _WideStringGreaterThanOrEqual(var s1: WideString; var s2: WideString; + var dest: Boolean); stdcall; +begin + dest := s1 >= s2; +end; + +procedure _WideStringLessThan(var s1: WideString; var s2: WideString; + var dest: Boolean);stdcall; +begin + dest := s1 < s2; +end; + +procedure _WideStringLessThanOrEqual(var s1: WideString; var s2: WideString; + var dest: Boolean); stdcall; +begin + dest := s1 <= s2; +end; + +procedure _SetStringLength(var S: AnsiString; L: Integer); stdcall; +begin + SetLength(S, L); +end; + +procedure _AnsiStringClr(var S: AnsiString); stdcall; +begin + S := ''; +end; + +procedure _WideStringClr(var S: WideString); stdcall; +begin + S := ''; +end; + +procedure _UniqueAnsiString(var S: AnsiString); stdcall; +begin + UniqueString(S); +end; + +function _LengthString(const S: AnsiString): Integer; +begin + result := Length(S); +end; + +function _LengthWideString(const S: WideString): Integer; +begin + result := Length(S); +end; + +procedure _Delete(var S: AnsiString; Index, Count:Integer); +begin + Delete(S, Index, Count); +end; + +procedure _VariantFromPAnsiChar(source: PAnsiChar; var dest: Variant); stdcall; +begin + dest := AnsiString(Source); +end; + +procedure _OleVariantFromPAnsiChar(source: PAnsiChar; var dest: OleVariant); stdcall; +begin + dest := AnsiString(Source); +end; + +procedure _VariantFromAnsiString(var Dest: Variant; var Source: AnsiString); stdcall; +begin + Dest := Source; +end; + +procedure _OleVariantFromAnsiString(var Dest: OleVariant; var Source: AnsiString); stdcall; +begin + Dest := Source; +end; + +procedure _VariantFromWideString(var Dest: Variant; var Source: WideString); +stdcall; +begin + Dest := Source; +end; + +procedure _OleVariantFromWideString(var Dest: OleVariant; var Source: WideString); +stdcall; +begin + Dest := Source; +end; + +procedure _AnsiStringFromInt(var dest: AnsiString; var source: Integer); stdcall; //JS only +begin + dest := AnsiString(IntToStr(source)); +end; + +procedure _AnsiStringFromDouble(var dest: AnsiString; var source: Double); stdcall; //JS only +begin + dest := AnsiString(FloatToStr(source)); +end; + +procedure _AnsiStringFromSingle(var dest: AnsiString; var source: Single); stdcall; //JS only +begin + dest := AnsiString(FloatToStr(source)); +end; + +procedure _AnsiStringFromExtended(var dest: AnsiString; var source: Extended); stdcall; //JS only +begin + dest := AnsiString(FloatToStr(source)); +end; + +procedure _AnsiStringFromBoolean(var dest: AnsiString; var source: Boolean); stdcall; //JS only +begin + if source then + dest := 'true' + else + dest := 'false'; +end; + +procedure _AnsiCharFromVariant(var dest: AnsiChar; var source: Variant); stdcall; +begin + dest := AnsiChar(TVarData(Source).VInteger); +end; + +procedure _AnsiStringFromVariant(var dest: AnsiString; var source: Variant); stdcall; +begin + dest := AnsiString(source); +end; + +procedure _WideStringFromVariant(var dest: WideString; var source: Variant); +stdcall; +begin + dest := source; +end; + +//////////////////////////////////////// NOT PAXARM ///////////////// +{$ENDIF} /////////////////////////////// NOT PAXARM ///////////////// +//////////////////////////////////////// NOT PAXARM ///////////////// + +procedure _ShortStringAssign(const source: ShortString; Ldest: Integer; dest: PShortString); stdcall; +var + I, L: Integer; +begin +{$IFDEF ARC} + L := Source[0]; +{$ELSE} + L := Length(Source); +{$ENDIF} + if L > Ldest then + L := Ldest; +{$IFDEF ARC} + dest^[0] := L; +{$ELSE} + dest^[0] := AnsiChar(Chr(L)); +{$ENDIF} + for I := 1 to L do + dest^[I] := Source[I]; +end; + +procedure _UnicStringFromPWideChar(source: PWideChar; var dest: UnicString); stdcall; +begin + dest := UnicString(source); +end; + +procedure _UnicStringFromWideChar(source: WideChar; var dest: UnicString); +stdcall; +begin + dest := source; +end; + +procedure _UnicStringAssign(var dest: UnicString; var source: UnicString); +stdcall; +begin + dest := source; +end; + +procedure _UnicStringAddition(var s1: UnicString; var s2: UnicString; + var dest: UnicString); stdcall; +begin + dest := s1 + s2; +end; + +procedure _UnicStringEquality(var s1: UnicString; var s2: UnicString; + var dest: Boolean); stdcall; +begin + dest := s1 = s2; +end; + +procedure _UnicStringNotEquality(var s1: UnicString; var s2: UnicString; + var dest: Boolean); stdcall; +begin + dest := s1 <> s2; +end; + +procedure _UnicStringGreaterThan(var s1: UnicString; var s2: UnicString; + var dest: Boolean); stdcall; +begin + dest := s1 > s2; +end; + +procedure _UnicStringGreaterThanOrEqual(var s1: UnicString; var s2: UnicString; + var dest: Boolean); stdcall; +begin + dest := s1 >= s2; +end; + +procedure _UnicStringLessThan(var s1: UnicString; var s2: UnicString; + var dest: Boolean);stdcall; +begin + dest := s1 < s2; +end; + +procedure _UnicStringLessThanOrEqual(var s1: UnicString; var s2: UnicString; + var dest: Boolean); stdcall; +begin + dest := s1 <= s2; +end; + +procedure _SetVariantLength(var V: Variant; VType: Integer; L: Integer); stdcall; +begin + V := VarArrayCreate([0, L - 1], VType); +end; + +procedure _SetVariantLength2(var V: Variant; VType: Integer; L1, L2: Integer); stdcall; +begin + V := VarArrayCreate([0, L1 - 1, 0, L2 - 1], VType); +end; + +procedure _SetVariantLength3(var V: Variant; VType: Integer; L1, L2, L3: Integer); stdcall; +begin + V := VarArrayCreate([0, L1 - 1, 0, L2 - 1, 0, L3 - 1], VType); +end; + +procedure _SetUnicStringLength(var S: UnicString; L: Integer); stdcall; +begin + SetLength(S, L); +end; + +procedure _UnicStringClr(var S: UnicString); stdcall; +begin + S := ''; +end; + +procedure _InterfaceClr(var I: IUnknown); stdcall; +begin + I := nil; +end; + +procedure _UniqueUnicString(var S: UnicString); stdcall; +begin +{$IFDEF VARIANTS} + UniqueString(S); +{$ENDIF} +end; + +function _LengthShortString(const S: ShortString): Integer; +begin + result := Length(S); +end; + +function _LengthUnicString(const S: UnicString): Integer; +begin + result := Length(S); +end; + +procedure _ValInt(const S: String; var V: Integer; var Code: Integer); +begin + Val(S, V, Code); +end; + +procedure _ValDouble(const S: String; var V: Double; var Code: Integer); +begin + Val(S, V, Code); +end; + +procedure _ShortstringHigh(const P: Shortstring; var result: Integer); stdcall; +begin + result := Length(P) - 1; +end; + +// unic string routines + +function _UnicLength(const S: UnicString): Integer; +begin + result := Length(S); +end; + +procedure _UnicDelete(var S: UnicString; Index, Count: Integer); +begin + Delete(S, Index, Count); +end; + +function _UnicCopy(const S: UnicString; Index, Count: Integer): UnicString; +begin + result := Copy(S, Index, Count); +end; + +procedure _UnicInsert(Source: UnicString; var S: UnicString; Index: Integer); +begin + Insert(Source, S, Index); +end; + +procedure _UnicValInt(const S: UnicString; var V: Integer; var Code: Integer); +begin + Val(S, V, Code); +end; + +procedure _UnicValDouble(const S: UnicString; var V: Double; var Code: Integer); +begin + Val(S, V, Code); +end; + +function _UnicPos(const Substr: UnicString; const S: UnicString): Integer; +begin + result := Pos(Substr, S); +end; + +// INT64 ROUTINES /////////////////////////////////////// + +procedure _Int64Multiplication(var v1: Int64; var v2: Int64; var dest: Int64); +stdcall; +begin + dest := v1 * v2; +end; + +procedure _Int64Division(var v1: Int64; var v2: Int64; var dest: Int64); +stdcall; +begin + dest := v1 div v2; +end; + +procedure _Int64Modulo(var v1: Int64; var v2: Int64; var dest: Int64); +stdcall; +begin + dest := v1 mod v2; +end; + +procedure _Int64LeftShift(var v1: Int64; var v2: Int64; var dest: Int64); +stdcall; +begin + dest := v1 shl v2; +end; + +procedure _Int64RightShift(var v1: Int64; var v2: Int64; var dest: Int64); +stdcall; +begin + dest := v1 shr v2; +end; + +procedure _Int64LessThan(var v1: Int64; var v2: Int64; var dest: Boolean); +stdcall; +begin + dest := v1 < v2; +end; + +procedure _Int64LessThanOrEqual(var v1: Int64; var v2: Int64; + var dest: Boolean); stdcall; +begin + dest := v1 <= v2; +end; + +procedure _Int64GreaterThan(var v1: Int64; var v2: Int64; + var dest: Boolean); stdcall; +begin + dest := v1 > v2; +end; + +procedure _Int64GreaterThanOrEqual(var v1: Int64; var v2: Int64; + var dest: Boolean); stdcall; +begin + dest := v1 >= v2; +end; + +procedure _Int64Equality(var v1: Int64; var v2: Int64; + var dest: Boolean); stdcall; +begin + dest := v1 = v2; +end; + +procedure _Int64NotEquality(var v1: Int64; var v2: Int64; + var dest: Boolean); stdcall; +begin + dest := v1 <> v2; +end; + +procedure _Int64Abs(var v1: Int64; var dest: Int64); stdcall; +begin + dest := Abs(v1); +end; + +procedure _UInt64LessThan(var v1: UInt64; var v2: UInt64; var dest: Boolean); +stdcall; +begin + dest := v1 < v2; +end; + +procedure _UInt64LessThanOrEqual(var v1: UInt64; var v2: UInt64; + var dest: Boolean); stdcall; +begin + dest := v1 <= v2; +end; + +procedure _UInt64GreaterThan(var v1: UInt64; var v2: UInt64; + var dest: Boolean); stdcall; +begin + dest := v1 > v2; +end; + +procedure _UInt64GreaterThanOrEqual(var v1: UInt64; var v2: UInt64; + var dest: Boolean); stdcall; +begin + dest := v1 >= v2; +end; + +procedure _VariantAssign(var dest: Variant; var source: Variant); stdcall; +begin + if VarIsNull(source) then + VarClear(dest); + dest := source; +end; + +procedure _OleVariantAssign(var dest: OleVariant; var source: OleVariant); stdcall; +begin + dest := source; +end; + +procedure _VariantFromInterface(const source: IDispatch; var dest: Variant); stdcall; +begin + dest := Source; +end; + +procedure _OleVariantFromInterface(const source: IDispatch; var dest: OleVariant); stdcall; +begin + dest := Source; +end; + +procedure _VariantFromPWideChar(source: PWideChar; var dest: Variant); stdcall; +begin + dest := UnicString(Source); +end; + +procedure _OleVariantFromPWideChar(source: PWideChar; var dest: OleVariant); stdcall; +begin + dest := UnicString(Source); +end; + +procedure _OleVariantFromVariant(var Dest: OleVariant; var Source: Variant); stdcall; +begin + Dest := Source; +end; + +procedure _VariantFromUnicString(var Dest: Variant; var Source: UnicString); +stdcall; +begin + Dest := Source; +end; + +procedure _OleVariantFromUnicString(var Dest: OleVariant; var Source: UnicString); +stdcall; +begin + Dest := Source; +end; + +procedure _VariantFromWideChar(source: WideChar; var dest: Variant); stdcall; +begin + dest := source; +end; + +procedure _OleVariantFromWideChar(source: WideChar; var dest: OleVariant); stdcall; +begin + dest := source; +end; + +procedure _VariantFromInt(source: Integer; var dest: Variant); stdcall; +begin + dest := source; +end; + +procedure _OleVariantFromInt(source: Integer; var dest: OleVariant); stdcall; +begin + dest := source; +end; + +{$IFDEF VARIANTS} +procedure _VariantFromInt64(var dest: Variant; var source: Int64); stdcall; +begin + dest := source; +end; +procedure _OleVariantFromInt64(var dest: OleVariant; var source: Int64); stdcall; +begin + dest := source; +end; + +{$ELSE} +procedure _VariantFromInt64(var dest: Variant; var source: Int64); stdcall; +begin + dest := Integer(source); +end; +procedure _OleVariantFromInt64(var dest: OleVariant; var source: Int64); stdcall; +begin + dest := Integer(source); +end; +{$ENDIF} + +procedure _VariantFromByte(source: Byte; var dest: Variant); stdcall; +begin + dest := source; +end; + +procedure _OleVariantFromByte(source: Byte; var dest: OleVariant); stdcall; +begin + dest := source; +end; + +procedure _VariantFromBool(source: Boolean; var dest: Variant); stdcall; +begin + dest := source; +end; + +procedure _OleVariantFromBool(source: Boolean; var dest: OleVariant); stdcall; +begin + dest := source; +end; + +procedure _VariantFromWord(source: Word; var dest: Variant); stdcall; +begin + dest := source; +end; + +procedure _OleVariantFromWord(source: Word; var dest: OleVariant); stdcall; +begin + dest := source; +end; + +procedure _VariantFromCardinal(source: Cardinal; var dest: Variant); stdcall; +begin +{$IFDEF VARIANTS} + dest := source; +{$ELSE} + dest := Integer(source); +{$ENDIF} +end; + +{$IFDEF VARIANTS} +procedure _OleVariantFromCardinal(source: Cardinal; var dest: OleVariant); stdcall; +begin + dest := source; +end; +{$ELSE} +procedure _OleVariantFromCardinal(source: Integer; var dest: OleVariant); stdcall; +begin + dest := source; +end; +{$ENDIF} + +procedure _VariantFromSmallInt(source: SmallInt; var dest: Variant); stdcall; +begin + dest := source; +end; + +procedure _OleVariantFromSmallInt(source: SmallInt; var dest: OleVariant); stdcall; +begin + dest := source; +end; + +procedure _VariantFromShortInt(source: ShortInt; var dest: Variant); stdcall; +begin + dest := source; +end; + +procedure _OleVariantFromShortInt(source: ShortInt; var dest: OleVariant); stdcall; +begin + dest := source; +end; + +procedure _VariantFromDouble(var dest: Variant; var source: Double); stdcall; +begin + dest := source; +end; + +procedure _OleVariantFromDouble(var dest: OleVariant; var source: Double); stdcall; +begin + dest := source; +end; + +procedure _VariantFromCurrency(var dest: Variant; var source: Currency); stdcall; +begin + dest := source; +end; + +procedure _OleVariantFromCurrency(var dest: OleVariant; var source: Currency); stdcall; +begin + dest := source; +end; + +procedure _VariantFromSingle( var dest: Variant; var source: Single); stdcall; +begin + dest := source; +end; + +procedure _OleVariantFromSingle(var dest: OleVariant; var source: Single); stdcall; +begin + dest := source; +end; + +procedure _VariantFromExtended(var dest: Variant; var source: Extended); stdcall; +begin + dest := source; +end; + +procedure _OleVariantFromExtended(var dest: OleVariant; var source: Extended); stdcall; +begin + dest := source; +end; + +procedure _UnicStringFromInt(var dest: UnicString; var source: Integer); stdcall; //JS only +begin + dest := IntToStr(source); +end; + +procedure _UnicStringFromDouble(var dest: UnicString; var source: Double); stdcall; //JS only +begin + dest := FloatToStr(source); +end; + +procedure _UnicStringFromSingle(var dest: UnicString; var source: Single); stdcall; //JS only +begin + dest := FloatToStr(source); +end; + +procedure _UnicStringFromExtended(var dest: UnicString; var source: Extended); stdcall; //JS only +begin + dest := FloatToStr(source); +end; + +procedure _UnicStringFromBoolean(var dest: UnicString; var source: Boolean); stdcall; //JS only +begin + if source then + dest := 'true' + else + dest := 'false'; +end; + +procedure _WideCharFromVariant(var dest: WideChar; var source: Variant); stdcall; +begin + dest := WideChar(TVarData(Source).VInteger); +end; + +procedure _UnicStringFromVariant(var dest: UnicString; var source: Variant); +stdcall; +begin + dest := source; +end; + +procedure _DoubleFromVariant(var dest: Double; var source: Variant); stdcall; +begin + dest := source; +end; + +procedure _CurrencyFromVariant(var dest: Currency; var source: Variant); stdcall; +begin + dest := source; +end; + +procedure _SingleFromVariant(var dest: Single; var source: Variant); stdcall; +begin + dest := source; +end; + +procedure _ExtendedFromVariant(var dest: Extended; var source: Variant); stdcall; +begin + dest := source; +end; + +procedure _IntFromVariant(var dest: Integer; var source: Variant); stdcall; +begin + dest := source; +end; + +{$IFDEF VARIANTS} +procedure _Int64FromVariant(var dest: Int64; var source: Variant); stdcall; +begin + dest := source; +end; +{$ELSE} +procedure _Int64FromVariant(var dest: Int64; var source: Variant); stdcall; +begin + dest := Integer(source); +end; +{$ENDIF} + +procedure _ByteFromVariant(var dest: Byte; var source: Variant); stdcall; +begin + dest := source; +end; + +procedure _WordFromVariant(var dest: Word; var source: Variant); stdcall; +begin + dest := source; +end; + +procedure _CardinalFromVariant(var dest: Cardinal; var source: Variant); stdcall; +begin + dest := source; +end; + +procedure _SmallIntFromVariant(var dest: SmallInt; var source: Variant); stdcall; +begin + dest := source; +end; + +procedure _ShortIntFromVariant(var dest: ShortInt; var source: Variant); stdcall; +begin + dest := source; +end; + +procedure _BoolFromVariant(var dest: Boolean; var source: Variant); stdcall; +begin + dest := source; +end; + +procedure _ByteBoolFromVariant(var dest: ByteBool; var source: Variant); stdcall; +begin +{$IFDEF FPC} + if source <> 0 then + dest := true + else + dest := false; +{$ELSE} + dest := source; +{$ENDIF} +end; + +procedure _WordBoolFromVariant(var dest: WordBool; var source: Variant); stdcall; +begin + dest := source; +end; + +procedure _LongBoolFromVariant(var dest: LongBool; var source: Variant); stdcall; +begin + dest := source; +end; + +procedure _StructEquality(P1, P2: Pointer; SZ: Integer; var dest: Boolean); stdcall; +begin + dest := CompareMem(P1, P2, SZ); +end; + +procedure _StructNotEquality(P1, P2: Pointer; SZ: Integer; var dest: Boolean); stdcall; +begin + dest := not CompareMem(P1, P2, SZ); +end; + +procedure _VariantNot(var v1: Variant; var dest: Variant); stdcall; +begin + dest := not v1; +end; + +procedure _VariantNegation(var v1: Variant; var dest: Variant); stdcall; +begin + dest := - v1; +end; + +procedure _VariantAbs(var v1: Variant; var dest: Variant); stdcall; +begin + if v1 >= 0 then + dest := v1 + else + dest := -v1; +end; + +procedure _VarArrayPut1(var V: Variant; var value: Variant; const I1: Variant); +stdcall; +begin + V[I1] := value; +end; + +procedure _VarArrayGet1(var V: Variant; var result: Variant; const I1: Variant); +stdcall; +begin + result := V[I1]; +end; + +procedure _VarArrayPut2(var V: Variant; var value: Variant; const I2, I1: Variant); +stdcall; +begin + V[I1, I2] := value; +end; + +procedure _VarArrayGet2(var V: Variant; var result: Variant; const I2, I1: Variant); +stdcall; +begin + result := V[I1, I2]; +end; + +procedure _VarArrayPut3(var V: Variant; var value: Variant; const I3, I2, I1: Variant); +stdcall; +begin + V[I1, I2, I3] := value; +end; + +procedure _VarArrayGet3(var V: Variant; var result: Variant; const I3, I2, I1: Variant); +stdcall; +begin + result := V[I1, I2, I3]; +end; + +procedure _DoubleMultiplication(Language: Integer; + var v1: Double; var v2: Double; var dest: Double); stdcall; +begin + dest := v1 * v2; +end; + +procedure _DoubleDivision(Language: Integer; + var v1: Double; var v2: Double; var dest: Double); stdcall; +begin + dest := v1 / v2; +end; + +procedure _DoubleAddition(Language: Integer; + var v1: Double; var v2: Double; var dest: Double); stdcall; +begin + dest := v1 + v2; +end; + +procedure _DoubleSubtraction(Language: Integer; + var v1: Double; var v2: Double; var dest: Double); stdcall; +begin + dest := v1 - v2; +end; + +procedure _DoubleNegation(var v1: Double; var dest: Double); stdcall; +begin + dest := - v1; +end; + +function GetPaxInterface(Self: TObject; const GUID: TGUID; var obj: Pointer): Boolean; +var + PaxInfo: PPaxInfo; + P: TBaseRunner; + ClassRec: TClassRec; + IntfList: TIntfList; + I, SZ: Integer; +begin + PaxInfo := GetPaxInfo(Self.ClassType); + if PaxInfo = nil then + raise Exception.Create(errInternalError); + + P := TBaseRunner(PaxInfo^.Prog); + ClassRec := P.ClassList[PaxInfo^.ClassIndex]; + IntfList := ClassRec.IntfList; + I := IntfList.IndexOf(GUID); + if I = -1 then + result := false + else + begin + SZ := Self.InstanceSize - IntfList.Count * SizeOf(Pointer); + Obj := ShiftPointer(Self, SZ + I * SizeOf(Pointer)); + result := true; + end; +end; + +{ +procedure _IntfCast(var Dest: IInterface; const Source: IInterface; const IID: TGUID); +// PIC: EBX must be correct before calling QueryInterface +var + Temp: IInterface; +begin + if Source = nil then + Dest := nil + else + begin + Temp := nil; + if Source.QueryInterface(IID, Temp) <> 0 then + Error(reIntfCastError) + else + Dest := Temp; + end; +end; +} + +{$IFNDEF PAXARM} +{$IFNDEF PAX64} +function TObject_GetScriptInterface(Self: TObject; const IID: TGUID; out Obj): Boolean; +var + InterfaceEntry: PInterfaceEntry; +begin + Pointer(Obj) := nil; + InterfaceEntry := Self.GetInterfaceEntry(IID); + if InterfaceEntry <> nil then + begin + if InterfaceEntry^.IOffset <> 0 then + begin + Pointer(Obj) := ShiftPointer(Pointer(Self), InterfaceEntry^.IOffset); + asm + push edi + push esi + push ebx + end; + if Pointer(Obj) <> nil then IInterface(Obj)._AddRef; + asm + pop ebx + pop esi + pop edi + end; + end; + end; + Result := Pointer(Obj) <> nil; +end; +{$ENDIF} +{$ENDIF} + +procedure _InterfaceFromClass(Dest: PIUnknown; + GUID: PGUID; + SourceAddress: Pointer); stdcall; +var + Temp: IInterface; +begin + if Pointer(SourceAddress^) = nil then + begin + Dest^ := nil; + Exit; + end; + + Temp := nil; + +{$IFNDEF PAXARM} +{$IFNDEF PAX64} + if IsPaxObject(TObject(SourceAddress^)) then + begin + if not TObject_GetScriptInterface(TObject(SourceAddress^), GUID^, Temp) then + raise Exception.Create(errIncompatibleTypesNoArgs); + end + else +{$ENDIF} +{$ENDIF} + begin + if not TMyInterfacedObject(SourceAddress^).GetInterface(GUID^, Temp) then + raise Exception.Create(errIncompatibleTypesNoArgs); + end; + + Dest^ := Temp; +end; + +procedure _InterfaceCast(Dest: PIUnknown; + GUID: PGUID; + Source: PIUnknown); stdcall; +var + Temp: Pointer; +begin + if Source^ = nil then + Dest^ := nil + else + begin + Temp := nil; + if Source.QueryInterface(GUID^, Temp) <> 0 then + raise Exception.Create(errIncompatibleTypesNoArgs); + if Assigned(Dest^) then + Dest^._Release; + Pointer(Dest^) := Temp; + end; +end; + +procedure _InterfaceAssign(var Dest: IUnknown; + var Source: IUnknown); stdcall; +begin + Dest := Source; +end; + +// PASCAL ARITHMETIC ROUTINES /////////////////////////////////////// + +function _ArcTan(const X: Extended): Extended; +begin + result := ArcTan(X); +end; + +function _Cos(const X: Extended): Extended; +begin + result := Cos(X); +end; + +function _Exp(X: Extended): Extended; +begin + result := Exp(X); +end; + +function _Frac(X: Extended): Extended; +begin + result := Frac(X); +end; + +function _Int(X: Extended): Extended; +begin + result := Int(X); +end; + +function _Ln(X: Extended): Extended; +begin + result := Ln(X); +end; + +function _Sin(X: Extended): Extended; +begin + result := Sin(X); +end; + +function _Sqr(X: Extended): Extended; +begin + result := Sqr(X); +end; + +function _Sqrt(X: Extended): Extended; +begin + result := Sqrt(X); +end; + +function _Trunc(X: Extended): Integer; +begin + result := Trunc(X); +end; + +function _Power(const Base, Exponent: Extended): Extended; +begin + result := Power(Base, Exponent); +end; + +// PASCAL MISCELLANEOUS ROUTINES //////////////////////////////////// + +procedure _FillChar(var X; Count: Integer; Value: Byte); +begin + FillChar(X, Count, Value); +end; + +function _Random: Double; +begin + result := Random; +end; + +function _Random1(N: Integer): Integer; +begin + result := Random(N); +end; + +function _HiInt(N: Integer): Byte; +begin + result := Hi(N); +end; + +function _HiWord(N: Word): Byte; +begin + result := Hi(N); +end; + +function _LoInt(N: Integer): Byte; +begin + result := Lo(N); +end; + +function _LoWord(N: Word): Byte; +begin + result := Lo(N); +end; + +{$IFDEF FPC} +function _UpCase(Ch: AnsiChar): AnsiChar; +begin + result := Upcase(Ch); +end; +{$ENDIF} + +function GetClassByIndex(P: TBaseRunner; I: Integer): TClass; +begin + result := P.ClassList[I].PClass; +end; + +procedure _Is(PClass: TClass; Instance: TObject; + var result: Boolean); stdcall; +begin + result := Instance is PClass; +end; + +procedure _ToParentClass2(Instance: TObject); stdcall; +var + C: TClass; +begin + C := Instance.ClassType; + while IsPaxClass(C) do + C := C.ClassParent; + Move(C, Pointer(Instance)^, SizeOf(Pointer)); +end; + +procedure _UpdateInstance2(Instance: TObject; C: TClass); stdcall; +begin + Move(C, Pointer(Instance)^, SizeOf(Pointer)); +end; + +{$IFDEF NO_PARENT_CLASS} +procedure _ToParentClass(P: TBaseRunner; + Instance: TObject); stdcall; +begin +end; +procedure _UpdateInstance(P: TBaseRunner; + Instance: TObject); stdcall; +begin +end; +{$ELSE} +procedure _ToParentClass(P: TBaseRunner; + Instance: TObject); stdcall; +var + C: TClass; +begin +{$IFNDEF PAXARM_DEVICE} +{$IFNDEF FPC} + if not (Instance is TCustomForm) then + Exit; +{$ENDIF} +{$ENDIF} + + C := Instance.ClassType; + P.SavedClass := C; + + while IsPaxClass(C) do + C := C.ClassParent; + + if Instance is TComponent then + TComponent(Instance).Tag := Integer(P.SavedClass); + + Move(C, Pointer(Instance)^, SizeOf(Pointer)); +end; + +procedure _UpdateInstance(P: TBaseRunner; + Instance: TObject); stdcall; +var + C: TClass; +begin +{$IFNDEF PAXARM_DEVICE} +{$IFNDEF FPC} + if not (Instance is TCustomForm) then + Exit; +{$ENDIF} +{$ENDIF} + + C := P.SavedClass; + Move(C, Pointer(Instance)^, SizeOf(Pointer)); + P.SavedClass := nil; +end; +{$ENDIF} + +{$IFNDEF PAXARM} +{$IFDEF PAX64} +procedure _DestroyInherited(Instance: TObject); +begin + RaiseNotImpl; +end; +{$ELSE} +procedure _DestroyInherited(Instance: TObject); +var + C, Temp: TClass; +begin + Temp := Instance.ClassType; + C := Instance.ClassParent; + Move(C, Pointer(Instance)^, 4); + asm + xor edx, edx + mov eax, instance + mov ecx, [eax] +{$IFDEF FPC} + mov ecx, [ecx + $30] +{$ELSE} + mov ecx, [ecx - $04] +{$ENDIF} + call ecx + end; + Move(Temp, Pointer(Instance)^, 4); +end; +{$ENDIF} +{$ENDIF} + +{ +procedure _DestroyInherited(Instance: TObject); +var + C: TClass; +begin + C := Instance.ClassParent; + asm + xor edx, edx + mov eax, instance + mov ecx, C + mov ecx, [ecx - $04] + call ecx + end; +end; +} + +{$IFDEF PAXARM} +procedure _ClassName(P: Pointer; result: PString); stdcall; +begin + if IsDelphiClass(P) then + result^ := TClass(P).ClassName + else + result^ := TObject(P).ClassName; +end; +{$ELSE} +procedure _ClassName(P: Pointer; result: PShortString); stdcall; +var + ST: String; +begin + if IsDelphiClass(P) then + ST := TClass(P).ClassName + else + ST := TObject(P).ClassName; + result^ := ShortString(ST); +end; +{$ENDIF} + +procedure _OnCreateObject(P: TBaseRunner; Instance: TObject); stdcall; +begin + if Assigned(P.OnCreateObject) then + P.OnCreateObject(P.Owner, Instance); +end; + +procedure _BeforeCallHost(P: TBaseRunner; Id: Integer); stdcall; +begin + if Assigned(P.OnBeforeCallHost) then + P.OnBeforeCallHost(P.Owner, Id); +end; + +procedure _AfterCallHost(P: TBaseRunner; Id: Integer); stdcall; +begin + if Assigned(P.OnAfterCallHost) then + P.OnAfterCallHost(P.Owner, Id); +end; + +procedure _OnCreateHostObject(P: TBaseRunner; Instance: TObject); stdcall; +begin + if Instance is TFW_Object then + (Instance as TFW_Object).prog := P; + + if Assigned(P.OnCreateHostObject) then + P.OnCreateHostObject(P.Owner, Instance); +end; + +procedure _OnDestroyHostObject(P: TBaseRunner; Instance: TObject); stdcall; +begin + if Assigned(P.OnDestroyHostObject) then + P.OnDestroyHostObject(P.Owner, Instance); +end; + +procedure _OnAfterObjectCreation(Runner: Pointer; Instance: PObject); stdcall; +var + P: TBaseRunner; +begin + P := TBaseRunner(Runner); + Instance^.AfterConstruction; + if Assigned(P.OnAfterObjectCreation) then + P.OnAfterObjectCreation(P.Owner, Instance^); +end; + +{$IFNDEF PAXARM} +{$IFDEF PAX64} +function _InitInstance(Self: TClass; Instance: Pointer): TObject; +var + IntfTable: PInterfaceTable; + ClassPtr: TClass; + I: Integer; +begin + with Self do + begin + ClassPtr := Self; + while ClassPtr <> nil do + begin + IntfTable := ClassPtr.GetInterfaceTable; + if IntfTable <> nil then + for I := 0 to IntfTable.EntryCount-1 do + with IntfTable.Entries[I] do + begin + if VTable <> nil then + PPointer(@PByte(Instance)[IOffset])^ := VTable; + end; + ClassPtr := ClassPtr.ClassParent; + end; + end; + Result := Instance; +end; +{$ELSE} +function _InitInstance(Self: TClass; Instance: Pointer): TObject; +var + IntfTable: PInterfaceTable; + ClassPtr: TClass; + I: Integer; +begin + with Self do + begin + ClassPtr := Self; + while ClassPtr <> nil do + begin + IntfTable := ClassPtr.GetInterfaceTable; + if IntfTable <> nil then + for I := 0 to IntfTable.EntryCount-1 do + with IntfTable.Entries[I] do + begin + if VTable <> nil then + PInteger(@PAnsiChar(Instance)[IOffset])^ := Integer(VTable); + end; + ClassPtr := ClassPtr.ClassParent; + end; + Result := Instance; + end; +end; +{$ENDIF} +{$ENDIF} + +{$IFDEF PAXARM} +procedure _ErrAbstract(S: PWideChar); stdcall; +begin + raise Exception.Create(Format(ErrAbstractMethodCall, [S])); +end; +{$ELSE} +procedure _ErrAbstract(S: PAnsiChar); stdcall; +begin + raise Exception.Create(Format(ErrAbstractMethodCall, [S])); +end; +{$ENDIF} + +procedure _Finally(P: TBaseRunner); stdcall; +begin + Inc(P.GetRootProg.FinallyCount); +end; + +procedure _BeginExceptBlock(P: TBaseRunner); stdcall; +begin + P.ProcessingExceptBlock := true; +end; + +procedure _EndExceptBlock(P: TBaseRunner); stdcall; +begin + P.ProcessingExceptBlock := false; + + if Assigned(P.CurrException) then +{$IFDEF ARC} + P.CurrException := nil; +{$ELSE} + P.CurrException.Free; +{$ENDIF} + P.CurrException := nil; +end; + +// processing breakpoints + +procedure _CheckPause(P: TBaseRunner); +var + SourceLine, ModuleIndex: Integer; + HasBreakpoint: Boolean; +begin + SourceLine := P.GetSourceLine; + ModuleIndex := P.GetModuleIndex; + + HasBreakpoint := + P.RunTimeModuleList.BreakpointList.IndexOf(ModuleIndex, SourceLine) >= 0; + + if HasBreakpoint then + P.Pause + else + begin + if P.RunMode = rmRUN then + begin + end + else if P.RunMode = rmTRACE_INTO then + P.Pause + else if P.RunMode = rmNEXT_SOURCE_LINE then + P.Pause + else if P.RunMode = rmSTEP_OVER then + begin + if P.RootInitCallStackCount >= P.GetCallStackCount then + P.Pause; + end else if P.RunMode = rmRUN_TO_CURSOR then + begin + if P.RunTimeModuleList.TempBreakpoint.SourceLine = SourceLine then + if P.RunTimeModuleList.TempBreakpoint.ModuleIndex = ModuleIndex then + P.Pause; + end; + end; +end; + +// processing halt + +procedure _Halt(Runner: Pointer; ExitCode: Integer); stdcall; +var + P: TBaseRunner; +begin + P := TBaseRunner(Runner); + P.RootExceptionIsAvailableForHostApplication := false; + P.ExitCode := ExitCode; + raise THaltException.Create(ExitCode); +end; + +// processing CondHalt + +procedure _CondHalt(P: TBaseRunner); stdcall; +begin + if P.IsHalted then + begin + P.RootExceptionIsAvailableForHostApplication := false; + raise THaltException.Create(P.ExitCode); + end; +end; + +// processing of published properties + +{$IFNDEF PAXARM} +procedure _GetAnsiStrProp(PropInfo: PPropInfo; Instance: TObject; + var result: AnsiString); stdcall; +begin +{$IFDEF UNIC} + Result := GetAnsiStrProp(Instance, PropInfo); +{$ELSE} + result := GetStrProp(Instance, PropInfo); +{$ENDIF} +end; + +procedure _SetAnsiStrProp(PropInfo: PPropInfo; Instance: TObject; + const value: AnsiString); stdcall; +begin +{$IFDEF UNIC} + SetAnsiStrProp(Instance, PropInfo, Value); +{$ELSE} + SetStrProp(Instance, PropInfo, Value); +{$ENDIF} +end; + +procedure _GetWideStrProp(PropInfo: PPropInfo; Instance: TObject; + var result: WideString); stdcall; +begin +{$IFDEF VARIANTS} + result := GetWideStrProp(Instance, PropInfo); +{$ELSE} + result := ''; +{$ENDIF} +end; + +procedure _SetWideStrProp(PropInfo: PPropInfo; Instance: TObject; + const value: WideString); stdcall; +begin +{$IFDEF VARIANTS} + SetWideStrProp(Instance, PropInfo, Value); +{$ENDIF} +end; +{$ENDIF} + +procedure _GetUnicStrProp(PropInfo: PPropInfo; Instance: TObject; + var result: UnicString); stdcall; +begin +{$IFDEF VARIANTS} + {$IFDEF UNIC} + {$IFDEF PAXARM} + result := GetStrProp(Instance, PropInfo); + {$ELSE} + result := GetUnicodeStrProp(Instance, PropInfo); + {$ENDIF} + {$ELSE} + result := GetWideStrProp(Instance, PropInfo); + {$ENDIF} +{$ELSE} + result := ''; +{$ENDIF} +end; + +procedure _SetUnicStrProp(PropInfo: PPropInfo; Instance: TObject; + const value: UnicString); stdcall; +begin +{$IFDEF VARIANTS} + {$IFDEF UNIC} + {$IFDEF PAXARM} + SetStrProp(Instance, PropInfo, Value); + {$ELSE} + SetUnicodeStrProp(Instance, PropInfo, Value); + {$ENDIF} + {$ELSE} + SetWideStrProp(Instance, PropInfo, Value); + {$ENDIF} +{$ENDIF} +end; + +procedure _GetOrdProp(PropInfo: PPropInfo; Instance: TObject; + var result: IntPax); stdcall; +begin + result := GetOrdProp(Instance, PropInfo); +end; + +procedure _SetOrdProp(PropInfo: PPropInfo; Instance: TObject; value: Integer); +stdcall; +begin + SetOrdProp(Instance, PropInfo, Value); +end; + +{$IFDEF VARIANTS} +procedure _GetInterfaceProp(PropInfo: PPropInfo; Instance: TObject; + var result: IInterface); stdcall; +begin +{$IFDEF FPC} + {$IFDEF LINUX} + {$ELSE} + result := GetInterfaceProp(Instance, PropInfo); + {$ENDIF} +{$ELSE} + result := GetInterfaceProp(Instance, PropInfo); +{$ENDIF} +end; + +procedure _SetInterfaceProp(PropInfo: PPropInfo; Instance: TObject; value: IInterface); +stdcall; +begin +{$IFDEF FPC} + {$IFDEF LINUX} + {$ELSE} + SetInterfaceProp(Instance, PropInfo, Value); + {$ENDIF} +{$ELSE} + SetInterfaceProp(Instance, PropInfo, Value); +{$ENDIF} +end; +{$ELSE} +procedure _GetInterfaceProp(PropInfo: PPropInfo; Instance: TObject; + var result: IUnknown); stdcall; +begin +// result := GetInterfaceProp(Instance, PropInfo); +end; + +procedure _SetInterfaceProp(PropInfo: PPropInfo; Instance: TObject; value: IUnknown); +stdcall; +begin +// SetInterfaceProp(Instance, PropInfo, Value); +end; +{$ENDIF} + +procedure _GetSetProp(PropInfo: PPropInfo; Instance: TObject; + var result: TByteSet); stdcall; +var + I: Integer; +begin + I := GetOrdProp(Instance, PropInfo); + result := Int32ToByteSet(I); +end; + +procedure _SetSetProp(PropInfo: PPropInfo; Instance: TObject; + var value: TByteSet); stdcall; +var + I: Integer; +begin + I := ByteSetToInt32(value); + SetOrdProp(Instance, PropInfo, I); +end; + +procedure _GetFloatProp(PropInfo: PPropInfo; Instance: TObject; + var result: Extended); stdcall; +begin + result := GetFloatProp(Instance, PropInfo); +end; + +procedure _SetFloatProp(PropInfo: PPropInfo; Instance: TObject; + var value: Extended); stdcall; +begin + SetFloatProp(Instance, PropInfo, Value); +end; + +procedure _GetVariantProp(PropInfo: PPropInfo; Instance: TObject; + var result: Variant); stdcall; +begin + result := GetVariantProp(Instance, PropInfo); +end; + +procedure _SetVariantProp(PropInfo: PPropInfo; Instance: TObject; + var value: Variant); stdcall; +begin + SetVariantProp(Instance, PropInfo, Value); +end; + +procedure _GetInt64Prop(PropInfo: PPropInfo; Instance: TObject; + var result: Int64); stdcall; +begin + result := GetInt64Prop(Instance, PropInfo); +end; + +procedure _SetInt64Prop(PropInfo: PPropInfo; Instance: TObject; + var value: Int64); stdcall; +begin + SetInt64Prop(Instance, PropInfo, Value); +end; + +procedure _GetEventProp(PropInfo: PPropInfo; Instance: TObject; + var N: TMethod); stdcall; +begin + N := GetMethodProp(Instance, PropInfo); +end; + +procedure _CreateMethod(Data, Code: Pointer; var M: TMethod); stdcall; +begin + M.Code := Code; + M.Data := Data; +end; + +procedure _RecordAssign(dest, source: Pointer; Size: Integer); stdcall; +begin + Move(source^, dest^, Size); +end; + +//------------------ Dynamic array support routines ---------------------------- + +procedure FreeDynarrayTVarRec(const A: DynarrayTVarRec); +var + I: Integer; +begin + for I:=0 to System.Length(A) - 1 do + begin + case A[I].VType of + vtInt64: + Dispose(PInt64(A[I].VInt64)); + vtExtended: + Dispose(PExtended(A[I].VExtended)); + vtVariant: + Dispose(PVariant(A[I].VVariant)); +{$IFNDEF PAXARM} + vtString: + Dispose(PShortString(A[I].VString)); + vtWideString: + WideString(A[I].VWideString) := ''; +{$ENDIF} + {$IFDEF UNIC} + vtUnicodeString: + UnicString(A[I].VUnicodeString) := ''; + {$ENDIF} + end; + end; +end; + +procedure _ClearTVarRec(var Dest: TVarRec); +begin + case Dest.VType of + vtInt64: + if Assigned(Dest.VInt64) then + begin + Dispose(PInt64(Dest.VInt64)); + end; + vtExtended: + if Assigned(Dest.VExtended) then + begin + Dispose(PExtended(Dest.VExtended)); + end; +{$IFNDEF PAXARM} + vtString: + if Assigned(Dest.VString) then + begin + Dispose(PShortString(Dest.VString)); + end; +{$ENDIF} + vtVariant: + if Assigned(Dest.VVariant) then + begin + Dispose(PVariant(Dest.VVariant)); + end; +{$IFNDEF PAXARM} + vtWideString: + if Assigned(Dest.VWideString) then + begin + WideString(Dest.VWideString) := ''; + end; +{$ENDIF} + {$IFDEF UNIC} + vtUnicodeString: + if Assigned(Dest.VUnicodeString) then + begin + UnicString(Dest.VUnicodeString) := ''; + end; + {$ENDIF} + end; + FillChar(Dest, SizeOf(Dest), 0); +end; + +procedure _AssignTVarRec(P: Pointer; + Address: Pointer; + var Dest: TVarRec; + TypeID: Integer); +stdcall; +{$IFNDEF PAXARM} +var + WS: WideString; +{$ENDIF} +begin + _ClearTVarRec(Dest); + case TypeId of + typeINTEGER: + begin + Dest.VType := vtInteger; + Dest.VInteger := Integer(Address^); + end; + typeBYTE: + begin + Dest.VType := vtInteger; + Dest.VInteger := Byte(Address^); + end; + typeWORD: + begin + Dest.VType := vtInteger; + Dest.VInteger := Word(Address^); + end; + typeSHORTINT: + begin + Dest.VType := vtInteger; + Dest.VInteger := ShortInt(Address^); + end; + typeSMALLINT: + begin + Dest.VType := vtInteger; + Dest.VInteger := SmallInt(Address^); + end; + typeCARDINAL: + begin + Dest.VType := vtInt64; + New(PInt64(Dest.VInt64)); + Dest.VInt64^ := Cardinal(Address^); + end; + typeINT64, typeUINT64: + begin + Dest.VType := vtInt64; + New(PInt64(Dest.VInt64)); + Dest.VInt64^ := Int64(Address^); + end; + typeCURRENCY: + begin + Dest.VType := vtCurrency; + New(PCurrency(Dest.VCurrency)); + Dest.VCurrency^ := Currency(Address^); + end; + typeBOOLEAN: + begin + Dest.VType := vtBoolean; + Dest.VBoolean := Boolean(Address^); + end; +{$IFNDEF PAXARM} + typeANSICHAR: + begin + Dest.VType := vtChar; + Dest.VChar := AnsiChar(Address^); + end; + typeSHORTSTRING: + begin + Dest.VType := vtString; + New(PShortString(Dest.VString)); + PShortString(Dest.VString)^ := PShortString(Address)^; + end; + typeANSISTRING: + begin + Dest.VType := vtAnsiString; + AnsiString(Dest.VAnsiString) := PAnsiString(Address)^; + end; + typeWIDESTRING: + begin +{$IFDEF UNIC} + Dest.VType := vtUnicodeString; + UnicString(Dest.VUnicodeString) := PWideString(Address)^; +{$ELSE} + Dest.VType := vtString; + New(PShortString(Dest.VString)); + PShortString(Dest.VString)^ := PWideString(Address)^; +{$ENDIF} + end; +{$ENDIF} + typeDOUBLE, typeSINGLE, typeEXTENDED: + begin + Dest.VType := vtExtended; + New(PExtended(Dest.VExtended)); + case TypeId of + typeDOUBLE: PExtended(Dest.VExtended)^ := PDouble(Address)^; + typeSINGLE: PExtended(Dest.VExtended)^ := PSingle(Address)^; + typeEXTENDED: PExtended(Dest.VExtended)^ := PExtended(Address)^; + end; + end; + typePOINTER: + begin + Dest.VType := vtPointer; + Dest.VPointer := Pointer(Address^); + end; +{$IFNDEF PAXARM} + typePANSICHAR: + begin + Dest.VType := vtPChar; + Dest.VPChar := Pointer(Address^); + end; +{$ENDIF} + typeCLASS: + begin + Dest.VType := vtObject; + Dest.VObject := TObject(Address^); + end; + typeCLASSREF: + begin + Dest.VType := vtClass; + Dest.VClass := TClass(Address^); + end; + typeWIDECHAR: + begin + Dest.VType := vtWideChar; + Dest.VWideChar := WideChar(Address^); + end; + typePWIDECHAR: + begin +{$IFDEF PAXARM} + Dest.VType := vtUnicodeString; + UnicString(Dest.VUnicodeString) := PWideChar(Pointer(Address^)); +{$ELSE} +{$IFDEF UNIC} + Dest.VType := vtUnicodeString; + _WideStringFromPWideChar(PWideChar(Pointer(Address^)), WS); + UnicString(Dest.VUnicodeString) := WS; +{$ELSE} + Dest.VType := vtString; + New(PShortString(Dest.VString)); + _WideStringFromPWideChar(PWideChar(Pointer(Address^)), WS); + PShortString(Dest.VString)^ := AnsiString(WS); +{$ENDIF} +{$ENDIF} + end; + typeVARIANT: + begin + Dest.VType := vtVariant; + New(PVariant(Dest.VVariant)); + PVariant(Dest.VVariant)^ := PVariant(Address)^; + end; + typeUNICSTRING: + begin +{$IFDEF UNIC} + Dest.VType := vtUnicodeString; + UnicString(Dest.VUnicodeString) := PUnicString(Address)^; +{$ELSE} + Dest.VType := vtString; + New(PShortString(Dest.VString)); + PShortString(Dest.VString)^ := PUnicString(Address)^; +{$ENDIF} + end; + end; +end; + + +type + PDynArrayRec = ^TDynArrayRec; + TDynArrayRec = packed record + {$IFDEF CPUX64} + _Padding: LongInt; // Make 16 byte align for payload.. + {$ENDIF} + RefCnt: LongInt; + Length: IntPax; + end; + +procedure _CreateEmptyDynarray(var A: Pointer); stdcall; +var + P: Pointer; +begin + if A <> nil then + begin + P := ShiftPointer(A, - SizeOf(TDynArrayRec)); + FreeMem(P, SizeOf(TDynArrayRec)); + end; + P := AllocMem(SizeOf(TDynArrayRec)); + PDynArrayRec(P)^.RefCnt := 1; + A := ShiftPointer(P, SizeOf(TDynArrayRec)); +end; + +function _DynarrayRefCount(P: Pointer): Integer; +begin + if P = nil then + result := -1 + else + begin + P := ShiftPointer(P, - SizeOf(TDynArrayRec)); + Result := PDynArrayRec(P)^.RefCnt; + end; +end; + +function _DynarrayLength(P: Pointer): Integer; +var + Q: Pointer; +begin + if P = nil then + result := 0 + else + begin + Q := ShiftPointer(P, - SizeOf(TDynArrayRec)); + Result := PDynArrayRec(Q)^.Length; +{$IFDEF FPC} + Inc(result); +{$ENDIF} + end; +end; + +procedure _DynarraySetLength(var A: Pointer; L: Integer; + ElFinalTypeID, ElTypeID, ElSize: Integer); stdcall; +var + P: Pointer; +begin + case ElFinalTypeID of +{$IFNDEF PAXARM} + typeANSICHAR: SetLength(DynarrayChar(A), L); + typeANSISTRING: SetLength(DynarrayString(A), L); + typeSHORTSTRING: SetLength(DynarrayShortString(A), L); + typeWIDESTRING: SetLength(DynarrayWideString(A), L); +{$ENDIF} + typeBOOLEAN: SetLength(DynarrayBoolean(A), L); + typeBYTE: SetLength(DynarrayByte(A), L); + typeWORD: SetLength(DynarrayWord(A), L); + typeCARDINAL: SetLength(DynarrayCardinal(A), L); + typeINTEGER: SetLength(DynarrayInteger(A), L); + typeDOUBLE: SetLength(DynarrayDouble(A), L); + typePOINTER: SetLength(DynarrayPointer(A), L); + typeENUM: SetLength(DynarrayInteger(A), L); + typePROC: SetLength(DynarrayPointer(A), L); + typeSINGLE: SetLength(DynarraySingle(A), L); + typeEXTENDED: SetLength(DynarrayExtended(A), L); + typeCURRENCY: SetLength(DynarrayCurrency(A), L); + typeCLASS: SetLength(DynarrayPointer(A), L); + typeCLASSREF: SetLength(DynarrayPointer(A), L); + typeWIDECHAR: SetLength(DynarrayWideChar(A), L); + typeUNICSTRING: SetLength(DynarrayUnicString(A), L); + typeVARIANT: SetLength(DynarrayVariant(A), L); + typeDYNARRAY: SetLength(DynarrayPointer(A), L); + else + begin + if ElTypeID = H_TVarRec then + begin + SetLength(DynarrayTVarRec(A), L); + Exit; + end; + +{$IFDEF FPC} + Dec(L); +{$ENDIF} + + if A <> nil then + begin + P := ShiftPointer(A, - SizeOf(TDynArrayRec)); + ReallocMem(P, L * ElSize + SizeOf(TDynArrayRec)); + PDynArrayRec(P)^.Length := L; + A := ShiftPointer(P, SizeOf(TDynArrayRec)); + Exit; + end; + + A := AllocMem(SizeOf(TDynArrayRec) + L * ElSize); + PDynArrayRec(A)^.RefCnt := 1; + PDynArrayRec(A)^.Length := L; + A := ShiftPointer(A, SizeOf(TDynArrayRec)); + end; + end; +end; + +procedure _DynarraySetLength2(var A: Pointer; L1, L2: Integer; + ElFinalTypeID, ElTypeID, ElSize: Integer); stdcall; +var + I: Integer; +begin + case ElFinalTypeID of +{$IFNDEF PAXARM} + typeANSICHAR: SetLength(DynarrayChar2(A), L1, L2); + typeANSISTRING: SetLength(DynarrayString2(A), L1, L2); + typeSHORTSTRING: SetLength(DynarrayShortString2(A), L1, L2); + typeWIDESTRING: SetLength(DynarrayWideString2(A), L1, L2); +{$ENDIF} + typeBOOLEAN: SetLength(DynarrayBoolean2(A), L1, L2); + typeBYTE: SetLength(DynarrayByte2(A), L1, L2); + typeWORD: SetLength(DynarrayWord2(A), L1, L2); + typeCARDINAL: SetLength(DynarrayCardinal2(A), L1, L2); + typeINTEGER: SetLength(DynarrayInteger2(A), L1, L2); + typeDOUBLE: SetLength(DynarrayDouble2(A), L1, L2); + typePOINTER: SetLength(DynarrayPointer2(A), L1, L2); + typeENUM: SetLength(DynarrayInteger2(A), L1, L2); + typePROC: SetLength(DynarrayPointer2(A), L1, L2); + typeSINGLE: SetLength(DynarraySingle2(A), L1, L2); + typeEXTENDED: SetLength(DynarrayExtended2(A), L1, L2); + typeCURRENCY: SetLength(DynarrayCurrency2(A), L1, L2); + typeCLASS: SetLength(DynarrayPointer2(A), L1, L2); + typeCLASSREF: SetLength(DynarrayPointer2(A), L1, L2); + typeWIDECHAR: SetLength(DynarrayWideChar2(A), L1, L2); + typeUNICSTRING: SetLength(DynarrayUnicString2(A), L1, L2); + typeVARIANT: SetLength(DynarrayVariant2(A), L1, L2); + typeDYNARRAY: SetLength(DynarrayPointer2(A), L1, L2); + else + begin + _DynarraySetLength(A, L1, typePOINTER, 0, 0); + for I := 0 to L1 - 1 do + _DynarraySetLength(DynarrayPointer(A)[I], L2, ElFinalTypeId, ElTypeId, ElSize); + end; + end; +end; + +procedure _DynarraySetLength3(var A: Pointer; L1, L2, L3: Integer; + ElFinalTypeID, ElTypeID, ElSize: Integer); stdcall; +type + DynarrayPointer2 = array of array of Pointer; +var + I, J: Integer; +begin + case ElFinalTypeID of +{$IFNDEF PAXARM} + typeANSICHAR: SetLength(DynarrayChar3(A), L1, L2, L3); + typeANSISTRING: SetLength(DynarrayString3(A), L1, L2, L3); + typeSHORTSTRING: SetLength(DynarrayShortString3(A), L1, L2, L3); + typeWIDESTRING: SetLength(DynarrayWideString3(A), L1, L2, L3); +{$ENDIF} + typeBOOLEAN: SetLength(DynarrayBoolean3(A), L1, L2, L3); + typeBYTE: SetLength(DynarrayByte3(A), L1, L2, L3); + typeWORD: SetLength(DynarrayWord3(A), L1, L2, L3); + typeCARDINAL: SetLength(DynarrayCardinal3(A), L1, L2, L3); + typeINTEGER: SetLength(DynarrayInteger3(A), L1, L2, L3); + typeDOUBLE: SetLength(DynarrayDouble3(A), L1, L2, L3); + typePOINTER: SetLength(DynarrayPointer3(A), L1, L2, L3); + typeENUM: SetLength(DynarrayInteger3(A), L1, L2, L3); + typePROC: SetLength(DynarrayPointer3(A), L1, L2, L3); + typeSINGLE: SetLength(DynarraySingle3(A), L1, L2, L3); + typeEXTENDED: SetLength(DynarrayExtended3(A), L1, L2, L3); + typeCURRENCY: SetLength(DynarrayCurrency3(A), L1, L2, L3); + typeCLASS: SetLength(DynarrayPointer3(A), L1, L2, L3); + typeCLASSREF: SetLength(DynarrayPointer3(A), L1, L2, L3); + typeWIDECHAR: SetLength(DynarrayWideChar3(A), L1, L2, L3); + typeUNICSTRING: SetLength(DynarrayUnicString3(A), L1, L2, L3); + typeVARIANT: SetLength(DynarrayVariant3(A), L1, L2, L3); + typeDYNARRAY: SetLength(DynarrayPointer3(A), L1, L2, L3); + else + begin + _DynarraySetLength2(A, L1, L2, typePOINTER, 0, 0); + for I := 0 to L1 - 1 do + for J := 0 to L2 - 1 do + _DynarraySetLength(DynarrayPointer2(A)[I][J], L2, ElFinalTypeId, ElTypeId, ElSize); + end; + end; +end; + +procedure _DynarrayHigh(var P: Pointer; var result: Integer); stdcall; +begin + result := _DynarrayLength(P) - 1; +end; + +function _DynarrayIncRefCount(P: Pointer): Integer; +var + Q: Pointer; +begin + if P <> nil then + begin + Q := ShiftPointer(P, - SizeOf(TDynArrayRec)); + Inc(PDynArrayRec(Q)^.RefCnt, 1); + result := _DynarrayRefCount(P); + end + else + result := 0; +end; + +function _DynarrayDecRefCount(P: Pointer): Integer; +var + Q: Pointer; +begin + if P <> nil then + begin + Q := ShiftPointer(P, - SizeOf(TDynArrayRec)); + Dec(PDynArrayRec(Q)^.RefCnt, 1); + result := _DynarrayRefCount(P); + end + else + result := 0; +end; + +procedure _DynarrayClr(var A: Pointer; + FinalTypeID, TypeID, ElSize, + FinalTypeID2, TypeID2, ElSize2: Integer); stdcall; +var + P: Pointer; + I, K, L: Integer; +begin + case FinalTypeID of +{$IFNDEF PAXARM} + typeANSISTRING: DynarrayString(A) := nil; + typeWIDESTRING: DynarrayWideString(A) := nil; + typeANSICHAR: DynarrayChar(A) := nil; + typeSHORTSTRING: DynarrayShortString(A) := nil; +{$ENDIF} + typeUNICSTRING: DynarrayUnicString(A) := nil; + typeVARIANT, typeOLEVARIANT: DynarrayVariant(A) := nil; + + typeBOOLEAN: DynarrayBoolean(A) := nil; + typeBYTE: DynarrayByte(A) := nil; + typeWORD: DynarrayWord(A) := nil; + typeCARDINAL: DynarrayCardinal(A) := nil; + typeINTEGER: DynarrayInteger(A) := nil; + typeDOUBLE: DynarrayDouble(A) := nil; + typePOINTER: DynarrayPointer(A) := nil; + typeENUM: DynarrayInteger(A) := nil; + typePROC: DynarrayPointer(A) := nil; + typeSINGLE: DynarraySingle(A) := nil; + typeEXTENDED: DynarrayExtended(A) := nil; + typeCURRENCY: DynarrayCurrency(A) := nil; + typeCLASS: DynarrayPointer(A) := nil; + typeCLASSREF: DynarrayPointer(A) := nil; + typeWIDECHAR: DynarrayWideChar(A) := nil; + + typeDYNARRAY: + begin + if A <> nil then + begin + for I := 0 to System.Length(DynarrayPointer(A)) - 1 do + _DynarrayClr(DynarrayPointer(A)[I], + FinalTypeID2, TypeID2, ElSize2, 0, 0, 0); + DynarrayPointer(A) := nil; + end; + end + else + begin + if A <> nil then + begin + if TypeID = H_TVarRec then + begin + K := _DynarrayRefCount(A); + if K = 1 then + begin +{$ifdef Ver360} // Delphi 12 Athens + FreeDynarrayTVarRec(DynarrayTVarRec(A)); +{$else} + FreeDynarrayTVarRec(A); +{$endif} + DynarrayTVarRec(A) := nil; + Exit; + end; + end; + + K := _DynarrayRefCount(A); + if K > 1 then + begin + _DynarrayDecRefCount(A); + Exit; + end; + + L := _DynarrayLength(A); + P := ShiftPointer(A, - SizeOf(TDynArrayRec)); + FreeMem(P, L * ElSize + SizeOf(TDynArrayRec)); + A := nil; + end; + end; + end; +end; + +procedure _DynarrayClr1(var A: Pointer; + FinalTypeID, TypeID, ElSize: Integer); stdcall; +var + P: Pointer; + K, L: Integer; +begin + case FinalTypeID of +{$IFNDEF PAXARM} + typeANSISTRING: DynarrayString(A) := nil; + typeWIDESTRING: DynarrayWideString(A) := nil; + typeANSICHAR: DynarrayChar(A) := nil; + typeSHORTSTRING: DynarrayShortString(A) := nil; +{$ENDIF} + typeUNICSTRING: DynarrayUnicString(A) := nil; + typeVARIANT, typeOLEVARIANT: DynarrayVariant(A) := nil; + + typeBOOLEAN: DynarrayBoolean(A) := nil; + typeBYTE: DynarrayByte(A) := nil; + typeWORD: DynarrayWord(A) := nil; + typeCARDINAL: DynarrayCardinal(A) := nil; + typeINTEGER: DynarrayInteger(A) := nil; + typeDOUBLE: DynarrayDouble(A) := nil; + typePOINTER: DynarrayPointer(A) := nil; + typeENUM: DynarrayInteger(A) := nil; + typePROC: DynarrayPointer(A) := nil; + typeSINGLE: DynarraySingle(A) := nil; + typeEXTENDED: DynarrayExtended(A) := nil; + typeCURRENCY: DynarrayCurrency(A) := nil; + typeCLASS: DynarrayPointer(A) := nil; + typeCLASSREF: DynarrayPointer(A) := nil; + typeWIDECHAR: DynarrayWideChar(A) := nil; + + else + begin + if A <> nil then + begin + if TypeID = H_TVarRec then + begin + K := _DynarrayRefCount(A); + if K = 1 then + begin +{$ifdef Ver360} // Delphi 12 Athens + FreeDynarrayTVarRec(DynarrayTVarRec(A)); +{$else} + FreeDynarrayTVarRec(A); +{$endif} + DynarrayTVarRec(A) := nil; + Exit; + end; + end; + + K := _DynarrayRefCount(A); + if K > 1 then + begin + _DynarrayDecRefCount(A); + Exit; + end; + + L := _DynarrayLength(A); + P := ShiftPointer(A, - SizeOf(TDynArrayRec)); + FreeMem(P, L * ElSize + SizeOf(TDynArrayRec)); + A := nil; + end; + end; + end; +end; + +procedure _DynarrayClr2(var A: Pointer; + FinalTypeID, TypeID, ElSize: Integer); stdcall; +var + I: Integer; +begin + if A = nil then + Exit; + for I := 0 to System.Length(DynarrayPointer(A)) - 1 do + _DynarrayClr1(DynarrayPointer(A)[I], FinalTypeID, TypeID, ElSize); + DynarrayPointer(A) := nil; +end; + +procedure _DynarrayClr3(var A: Pointer; + FinalTypeID, TypeID, ElSize: Integer); stdcall; +var + I: Integer; +begin + if A = nil then + Exit; + for I := 0 to System.Length(DynarrayPointer(A)) - 1 do + _DynarrayClr2(DynarrayPointer(A)[I], FinalTypeID, TypeID, ElSize); + DynarrayPointer(A) := nil; +end; + +procedure _DynarrayAssign(var Source, Dest: Pointer; + FinalTypeID, TypeID, ElSize, + FinalTypeID2, TypeID2, ElSize2: Integer); stdcall; +var + K: Integer; +begin + if Source = nil then + begin + _DynArrayClr(Dest, FinalTypeId, TypeId, ElSize, + FinalTypeId2, TypeId2, ElSize2); + Exit; + end; + _DynarrayIncRefCount(Source); + if Dest <> nil then + begin + K := _DynarrayDecRefCount(Dest); + if K = 0 then + _DynArrayClr(Dest, FinalTypeId, TypeId, ElSize, + FinalTypeId2, TypeId2, ElSize2); + end; + Dest := Source; +end; + +function _VariantLength(const V: Variant): Integer; +var + VT: Word; + I: Integer; +begin + VT := VarType(V); + if VT < varArray then + result := Length(V) + else + begin + result := 1; + for I := 1 to VarArrayDimCount(V) do + result := result * (VarArrayHighBound(V, I) + 1); + end; +end; + +procedure _LockVArray(var V: Variant; var Result: Pointer); stdcall; +begin + result := VarArrayLock(V); +end; + +procedure _UnlockVArray(var V: Variant); stdcall; +begin + VarArrayUnlock(V); +end; + +procedure _IntOver; stdcall; +begin + raise EIntOverflow.Create(errIntegerOverflow); +end; + +procedure _BoundError; stdcall; +begin + raise ERangeError.Create(errRangeCheckError); +end; + +procedure _StringAddRef(var S: Pointer); stdcall; +var + P: PStringRec; +begin + if S <> nil then + begin + P := Pointer(Integer(S) - Sizeof(TStringRec)); + Inc(P^.RefCount); + end; +end; + +procedure _DynarrayAddRef(P: Pointer); stdcall; +begin + _DynarrayIncRefCount(P); +end; + +procedure _InterfaceAddRef(var I: Pointer); stdcall; +begin + IUnknown(I)._AddRef; +end; + +procedure _VariantAddRef(var V: Variant); stdcall; +var + VT: Integer; +begin + VT := VarType(V); +{$IFNDEF PAXARM} + if VT = varString then + _StringAddRef(TVarData(V).VString) + else if VT = varOleStr then + _StringAddRef(Pointer(TVarData(V).VOleStr)) + else +{$ENDIF} +{$IFDEF UNIC} + if VT = varUString then + _StringAddRef(Pointer(TVarData(V).VUString)) + else +{$ENDIF} + if VT = varDispatch then + _InterfaceAddRef(TVarData(V).VDispatch); +end; + +{$IFDEF PAXARM} +function TObject_ClassName(IsClass: Integer; P: Pointer): String; stdcall; +begin + if IsClass = 1 then + result := TClass(P).ClassName + else + result := TObject(P).ClassName; +end; +{$ELSE} +function TObject_ClassName(IsClass: Integer; P: Pointer): ShortString; stdcall; +var + X: TObject; + S: String; +begin + if IsClass = 1 then + begin + S := TClass(P).ClassName; + result := ShortString(S); + end + else + begin + X := TObject(P); + S := X.ClassName; + result := ShortString(S); + end; +end; +{$ENDIF} + +function _GetProgAddress: Pointer; +begin + result := @ CurrProg; +end; + +function GetRefCount(Self: TInterfacedObject): Integer; +begin + result := Self.RefCount; +end; + +function _Round(E: Extended): Int64; +begin + result := Round(E); +end; + +procedure _GetComponent(X: TComponent; I: Integer; var Y: TComponent); stdcall; +begin + Y := X.Components[I]; +end; + +procedure Dummy; +begin +end; + +// TExtraImportTableList ------------------------------------------------------- + +function TExtraImportTableList.GetRecord(I: Integer): TBaseSymbolTable; +begin + result := TBaseSymbolTable(L[I]); +end; + +function TExtraImportTableList.Import(CurrentTable: TBaseSymbolTable; + const FullName: String; + UpCase: Boolean; + DoRaiseError: Boolean = true): Integer; +var + I: Integer; +begin + result := 0; + for I := 0 to Count - 1 do + begin + result := CurrentTable.ImportFromTable(Records[I], FullName, UpCase, DoRaiseError); + if result <> 0 then + Exit; + end; +end; + +function TExtraImportTableList.Add(st: TBaseSymbolTable): Integer; +begin + result := L.Add(st); +end; + +procedure TExtraImportTableList.Remove(st: TBaseSymbolTable); +var + I: Integer; +begin + I := L.IndexOf(st); + if I >= 0 then + L.Delete(I); + FreeAndNil(st); +end; + +//------------------------------------------------------------------------------ + +procedure TMyInterfacedObject_AddRef(Self: TObject); stdcall; +begin + TMyInterfacedObject(Self)._AddRef; +end; + +procedure TMyInterfacedObject_Release(Self: TObject); stdcall; +begin + TMyInterfacedObject(Self)._Release; +end; + +function TObject_GetInterface(Self: TObject; const IID: TGUID; out Obj): Boolean; +begin + result := Self.GetInterface(IID, Obj); +end; + +procedure Set_ExitCode(P: TBaseRunner; value: Integer); stdcall; +begin + P.ExitCode := value; +end; + +function Get_ExitCode(P: TBaseRunner): Integer; stdcall; +begin + result := P.ExitCode; +end; + +procedure _GetDynamicMethodAddress(AClass: TClass; Id: integer; + var result: Pointer); stdcall; +var + Dmt: PDmtTable; + DmtMethodList: PDmtMethodList; + I: Integer; + C: TClass; +begin + Result := nil; + + C := AClass; + repeat + Dmt := GetDmtFromClass(C); + if Assigned(Dmt) then + begin + DmtMethodList := @Dmt^.IndexList[Dmt.Count]; + for I := 0 to Dmt^.Count - 1 do + if Dmt^.IndexList[I] = Id then + begin + Result := DmtMethodList[I]; + Exit; + end; + end; + + C := C.ClassParent; + if C = nil then + break; + until false; +end; + +procedure _CallVirt(Runner: TBaseRunner; ObjectName, PropName: PChar; A: array of Variant; var Result: Variant); stdcall; +begin + if not Assigned(Runner.OnVirtualObjectMethodCall) then + Runner.RaiseError(errVirtualObjectMethodCallEventNotAssigned, []); + Runner.OnVirtualObjectMethodCall(Runner.Owner, String(ObjectName), String(PropName), A, result); +end; + +procedure _PutVirt(Runner: TBaseRunner; ObjectName, PropName: PChar; A: array of Variant; const value: Variant); stdcall; +begin + if not Assigned(Runner.OnVirtualObjectPutProperty) then + Runner.RaiseError(errVirtualObjectPutPropertyEventNotAssigned, []); + Runner.OnVirtualObjectPutProperty(Runner.Owner, String(ObjectName), String(PropName), A, value); +end; + +procedure _AddMessage(Runner: Pointer; msg_id: Integer; FullName: PChar); stdcall; +var + R: TMessageRec; + I: Integer; + P: TBaseRunner; +begin + P := TBaseRunner(Runner); + I := P.MessageList.IndexOf(FullName); + if I >= 0 then + Exit; + + R := P.MessageList.AddRecord; + R.msg_id := msg_id; + R.FullName := FullName; +end; + +procedure _TypeInfo(Prog: Pointer; FullTypeName: PChar; var result: PTypeInfo); stdcall; +var + R: TTypeInfoContainer; +{$ifdef DRTTI} + t: TRTTIType; + PackageInfo: PPackageTypeInfo; + lib: PLibModule; + lp: PByte; + i: integer; + aName: String; + aUnit: String; + procedure PeekData(var P: PByte; var Data; Len: Integer); + begin + Move(P^, Data, Len); + end; + procedure ReadData(var P: PByte; var Data; Len: Integer); + begin + PeekData(P, Data, Len); + Inc(P, Len); + end; + function ReadU8(var P: PByte): Byte; + begin + ReadData(P, Result, SizeOf(Result)); + end; + function ReadShortString(var P: PByte): string; + var + len: Integer; + begin + Result := UTF8ToString(PShortString(P)^); + len := ReadU8(P); + Inc(P, len); + end; +{$endif} +var P: TBaseRunner; +begin + P := TBaseRunner(Prog); + R := P.ProgTypeInfoList.LookupFullName(FullTypeName); + if R = nil then + begin +{$ifdef DRTTI} + t := PaxContext.FindType(FullTypeName); + if t = nil then + t := PaxContext.FindType(ExtractName(FullTypeName)); + aName := ExtractName(FullTypeName); + lib := LibModuleList; + while lib <> nil do + begin + PackageInfo := lib^.TypeInfo; + if PackageInfo <> nil then + begin + lp := Pointer(PackageInfo^.UnitNames); + for i := 0 to PackageInfo^.UnitCount - 1 do + begin + aUnit := ReadShortString(lp); + t := PaxContext.FindType(aUnit + '.' + aName); + if t <> nil then + break; + end; + end; + if t <> nil then + break; + lib := lib.Next; + end; + if t = nil then + result := nil + else + result := t.Handle; +{$else} + result := nil; +{$endif} + end + else + result := R.TypeInfoPtr; +end; + +function GetPointerType(T: Integer): Integer; +begin + if T = typeINTEGER then + result := H_PInteger + else if T = typeSMALLINT then + result := H_PSmallInt + else if T = typeSHORTINT then + result := H_PShortInt + else if T = typeCARDINAL then + result := H_PCardinal + else if T = typeWORD then + result := H_PWord + else if T = typeBYTE then + result := H_PByte + else if T = typeINT64 then + result := H_PInt64 + else if T = typeSINGLE then + result := H_PSingle + else if T = typeDOUBLE then + result := H_PDouble + else if T = typeEXTENDED then + result := H_PExtended + else if T = typeCURRENCY then + result := H_PCurrency + else if T = typeVARIANT then + result := H_PVariant + else if T = typePOINTER then + result := H_PPointer + else if T = typeBOOLEAN then + result := H_PBoolean + else if T = typeWIDECHAR then + result := H_PWideChar +{$IFNDEF PAXARM} + else if T = typeANSICHAR then + result := H_PAnsiChar + else if T = typeSHORTSTRING then + result := H_PShortString + else if T = typeANSISTRING then + result := H_PAnsiString + else if T = typeWIDESTRING then + result := H_PWideString +{$ENDIF} + else if T = typeUNICSTRING then + result := H_PUnicString + + else if T = H_PINTEGER then + result := H_PPInteger + else if T = H_PSMALLINT then + result := H_PPSmallInt + else if T = H_PSHORTINT then + result := H_PPShortInt + else if T = H_PCARDINAL then + result := H_PPCardinal + else if T = H_PWORD then + result := H_PPWord + else if T = H_PBYTE then + result := H_PPByte + else if T = H_PINT64 then + result := H_PPInt64 + else if T = H_PSINGLE then + result := H_PPSingle + else if T = H_PDOUBLE then + result := H_PPDouble + else if T = H_PEXTENDED then + result := H_PPExtended + else if T = H_PCURRENCY then + result := H_PPCurrency + else if T = H_PVARIANT then + result := H_PPVariant + else if T = H_PPOINTER then + result := H_PPPointer + else if T = H_PBOOLEAN then + result := H_PPBoolean + else if T = typeWIDECHAR then + result := H_PWideChar +{$IFNDEF PAXARM} + else if T = H_PANSICHAR then + result := H_PPAnsiChar + else if T = H_PSHORTSTRING then + result := H_PPShortString + else if T = H_PANSISTRING then + result := H_PPAnsiString + else if T = H_PWIDESTRING then + result := H_PPWideString +{$ENDIF} + else if T = H_PUNICSTRING then + result := H_PPUnicString + else + result := 0; +end; + +var + Unassigned: Variant; + +procedure Register_TYPEINFO(H_Namespace: Integer; st: TBaseSymbolTable); +var + H_Sub: Integer; +begin + with st do + begin + H_Sub := RegisterRoutine(H_Namespace, 'TypeInfo', typeVOID, ccSTDCALL, nil); + RegisterParameter(H_Sub, typePOINTER, Unassigned, false, 'X'); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @ _TypeInfo); + Id_TypeInfo := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + end; +end; + +procedure FindAvailTypes; +begin + if AvailTypeList.Count = 0 then + begin +{$IFDEF DRTTI} + CreateAvailTypes; +{$ENDIF} + end; +end; + +type + TMyObject = class(TObject); + +const + ByRef = true; + +procedure AddStdRoutines(st: TBaseSymbolTable); +var + H_Namespace, H_Sub, H, T1, T2, T3, T4, T5: Integer; + H_R0_7, H_TGUID_D4, H_TEntries, H_TPOINT: Integer; +begin + with st do + begin + Reset; + + RegisterRoutine(0, strWrite, typeVOID, ccREGISTER, @_Write); + + H_Sub := RegisterRoutine(0, strWriteln, typeVOID, ccREGISTER, @_Writeln); + H_Writeln := H_Sub; + + H_Sub := RegisterRoutine(0, '', typeVOID, ccREGISTER, @_WriteBool); + Id_WriteBool := LastSubId; + RegisterParameter(H_Sub, typeBOOLEAN, Unassigned); + H_WriteBool := H_Sub; + + H_Sub := RegisterRoutine(0, '', typeVOID, ccREGISTER, @_WriteByteBool); + Id_WriteByteBool := LastSubId; + RegisterParameter(H_Sub, typeBYTEBOOL, Unassigned); + H_WriteByteBool := H_Sub; + + H_Sub := RegisterRoutine(0, '', typeVOID, ccREGISTER, @_WriteWordBool); + Id_WriteWordBool := LastSubId; + RegisterParameter(H_Sub, typeWORDBOOL, Unassigned); + H_WriteWordBool := H_Sub; + + H_Sub := RegisterRoutine(0, '', typeVOID, ccREGISTER, @_WriteLongBool); + Id_WriteLongBool := LastSubId; + RegisterParameter(H_Sub, typeLONGBOOL, Unassigned); + H_WriteLongBool := H_Sub; +{$IFNDEF PAXARM} + H_Sub := RegisterRoutine(0, '', typeVOID, ccREGISTER, @_WriteAnsiChar); + Id_WriteAnsiChar := LastSubId; + RegisterParameter(H_Sub, typeANSICHAR, Unassigned); + H_WriteAnsiChar := H_Sub; +{$ENDIF} + H_Sub := RegisterRoutine(0, '', typeVOID, ccREGISTER, @_WriteByte); + Id_WriteByte := LastSubId; + RegisterParameter(H_Sub, typeBYTE, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + H_WriteByte := H_Sub; + + H_Sub := RegisterRoutine(0, '', typeVOID, ccREGISTER, @_WriteWord); + Id_WriteWord := LastSubId; + RegisterParameter(H_Sub, typeWORD, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + H_WriteWord := H_Sub; + + H_Sub := RegisterRoutine(0, '', typeVOID, ccREGISTER, @_WriteCardinal); + Id_WriteCardinal := LastSubId; + RegisterParameter(H_Sub, typeCARDINAL, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + H_WriteCardinal := H_Sub; + + H_Sub := RegisterRoutine(0, '', typeVOID, ccREGISTER, @_WriteSmallInt); + Id_WriteSmallInt := LastSubId; + RegisterParameter(H_Sub, typeSMALLINT, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + H_WriteSmallInt := H_Sub; + + H_Sub := RegisterRoutine(0, '', typeVOID, ccREGISTER, @_WriteShortInt); + Id_WriteShortInt := LastSubId; + RegisterParameter(H_Sub, typeSHORTINT, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + H_WriteShortInt := H_Sub; + + H_Sub := RegisterRoutine(0, '', typeVOID, ccREGISTER, @_WriteInt); + Id_WriteInt := LastSubId; + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + H_WriteInteger := H_Sub; + + H_Sub := RegisterRoutine(0, '', typeVOID, ccREGISTER, @_WriteInt64); + Id_WriteInt64 := LastSubId; + RegisterParameter(H_Sub, typeINT64, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + H_WriteInt64 := H_Sub; + + H_Sub := RegisterRoutine(0, '', typeVOID, ccREGISTER, @_WriteDouble); + Id_WriteDouble := LastSubId; + RegisterParameter(H_Sub, typeDOUBLE, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + H_WriteDouble := H_Sub; + + H_Sub := RegisterRoutine(0, '', typeVOID, ccREGISTER, @_WriteSingle); + Id_WriteSingle := LastSubId; + RegisterParameter(H_Sub, typeSINGLE, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + H_WriteSingle := H_Sub; + + H_Sub := RegisterRoutine(0, '', typeVOID, ccREGISTER, @_WriteCurrency); + Id_WriteCurrency := LastSubId; + RegisterParameter(H_Sub, typeCURRENCY, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + H_WriteCurrency := H_Sub; + + H_Sub := RegisterRoutine(0, '', typeVOID, ccREGISTER, @_WriteExtended); + Id_WriteExtended := LastSubId; + RegisterParameter(H_Sub, typeEXTENDED, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + H_WriteExtended := H_Sub; +{$IFNDEF PAXARM} + H_Sub := RegisterRoutine(0, '', typeVOID, ccREGISTER, @_WriteString); + Id_WriteString := LastSubId; + RegisterParameter(H_Sub, typeANSISTRING, Unassigned); + Records[Card].IsConst := true; + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + H_WriteAnsiString := H_Sub; + + H_Sub := RegisterRoutine(0, '', typeVOID, ccREGISTER, @_WriteShortString); + Id_WriteShortString := LastSubId; + RegisterParameter(H_Sub, typeSHORTSTRING, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + H_WriteShortString := H_Sub; +{$ENDIF} + H_Sub := RegisterRoutine(0, '', typeVOID, ccREGISTER, @_WriteWideChar); + Id_WriteWideChar := LastSubId; + RegisterParameter(H_Sub, typeWIDECHAR, Unassigned); + H_WriteWideChar := H_Sub; +{$IFNDEF PAXARM} + H_Sub := RegisterRoutine(0, '', typeVOID, ccREGISTER, @_WriteWideString); + Id_WriteWideString := LastSubId; + RegisterParameter(H_Sub, typeWIDESTRING, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + H_WriteWideString := H_Sub; +{$ENDIF} + H_Sub := RegisterRoutine(0, '', typeVOID, ccREGISTER, @_WriteVariant); + Id_WriteVariant := LastSubId; + RegisterParameter(H_Sub, typeVARIANT, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + H_WriteVariant := H_Sub; + + H_Sub := RegisterRoutine(0, '', typeVOID, ccREGISTER, @_WriteObject); + Id_WriteObject := LastSubId; + RegisterParameter(H_Sub, typeCLASS, Unassigned); + H_WriteObject := H_Sub; + +//--------- SET ROUTINES ------------------------------------------------------- + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_SetInclude); + Id_SetInclude := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_SetIncludeInterval); + Id_SetIncludeInterval := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_SetExclude); + Id_SetExclude := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_SetUnion); + Id_SetUnion := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_SetDifference); + Id_SetDifference := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_SetIntersection); + Id_SetIntersection := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeBOOLEAN, ccSTDCALL, @_SetSubset); + Id_SetSubset := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeBOOLEAN, ccSTDCALL, @_SetSuperset); + Id_SetSuperset := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeBOOLEAN, ccSTDCALL, @_SetEquality); + Id_SetEquality := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeBOOLEAN, ccSTDCALL, @_SetInequality); + Id_SetInequality := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeBOOLEAN, ccSTDCALL, @_SetMembership); + Id_SetMembership := LastSubId; + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typePOINTER, ccSTDCALL, @ _LoadProc); + Id_LoadProc := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + +//--------- String ROUTINES ---------------------------------------------------- + +{$IFNDEF PAXARM} + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @ _AnsiStringFromPAnsiChar); + Id_AnsiStringFromPAnsiChar := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_WideStringFromPAnsiChar); + Id_WideStringFromPAnsiChar := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_WideStringFromPWideChar); + Id_WideStringFromPWideChar := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_AnsiStringFromAnsiChar); + Id_AnsiStringFromAnsiChar := LastSubId; + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_WideStringFromAnsiChar); + Id_WideStringFromAnsiChar := LastSubId; + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @ _WideStringFromWideChar); + Id_WideStringFromWideChar := LastSubId; + RegisterParameter(H_Sub, typeWIDECHAR, Unassigned); + RegisterParameter(H_Sub, typeWIDESTRING, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @ _AnsiStringFromWideChar); + Id_AnsiStringFromWideChar := LastSubId; + RegisterParameter(H_Sub, typeWIDECHAR, Unassigned); + RegisterParameter(H_Sub, typeWIDESTRING, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_AnsiStringAssign); + Id_AnsiStringAssign := LastSubId; + RegisterParameter(H_Sub, typeANSISTRING, Unassigned, ByRef); + RegisterParameter(H_Sub, typeANSISTRING, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_WideStringAssign); + Id_WideStringAssign := LastSubId; + RegisterParameter(H_Sub, typeWIDESTRING, Unassigned, ByRef); + RegisterParameter(H_Sub, typeWIDESTRING, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_AnsiStringAddition); + Id_AnsiStringAddition := LastSubId; + RegisterParameter(H_Sub, typeANSISTRING, Unassigned, ByRef); + RegisterParameter(H_Sub, typeANSISTRING, Unassigned, ByRef); + RegisterParameter(H_Sub, typeANSISTRING, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_WideStringAddition); + Id_WideStringAddition := LastSubId; + RegisterParameter(H_Sub, typeWIDESTRING, Unassigned, ByRef); + RegisterParameter(H_Sub, typeWIDESTRING, Unassigned, ByRef); + RegisterParameter(H_Sub, typeWIDESTRING, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_ShortStringAssign); + Id_ShortStringAssign := LastSubId; + RegisterParameter(H_Sub, typeSHORTSTRING, Unassigned, ByRef); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typeSHORTSTRING, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_ShortStringAddition); + Id_ShortStringAddition := LastSubId; + RegisterParameter(H_Sub, typeSHORTSTRING, Unassigned, ByRef); + RegisterParameter(H_Sub, typeSHORTSTRING, Unassigned, ByRef); + RegisterParameter(H_Sub, typeSHORTSTRING, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_AnsiStringClr); + Id_AnsiStringClr := LastSubId; + RegisterParameter(H_Sub, typeANSISTRING, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_WideStringClr); + Id_WideStringClr := LastSubId; + RegisterParameter(H_Sub, typeWIDESTRING, Unassigned, ByRef); +{$ENDIF} + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_InterfaceClr); + Id_InterfaceClr := LastSubId; + RegisterParameter(H_Sub, typeINTERFACE, Unassigned, ByRef); + +{$IFNDEF PAXARM} + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_StringAddRef); + Id_StringAddRef := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_StringAddRef); + Id_WideStringAddRef := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned, ByRef); +{$ENDIF} + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_DynarrayAddRef); + Id_DynarrayAddRef := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_InterfaceAddRef); + Id_InterfaceAddRef := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_VariantAddRef); + Id_VariantAddRef := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + +{$IFNDEF PAXARM} + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_ShortStringFromAnsiString); + Id_ShortStringFromAnsiString := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_ShortStringFromWideString); + Id_ShortStringFromWideString := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_AnsiStringFromShortString); + Id_AnsiStringFromShortString := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_WideStringFromShortString); + Id_WideStringFromShortString := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_AnsiStringFromWideString); + Id_AnsiStringFromWideString := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_WideStringFromAnsiString); + Id_WideStringFromAnsiString := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_StrInt); + Id_StrInt := LastSubId; + RegisterParameter(H_Sub, typeANSISTRING, Unassigned, ByRef); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_StrDouble); + Id_StrDouble := LastSubId; + RegisterParameter(H_Sub, typeANSISTRING, Unassigned, ByRef); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typeDOUBLE, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_StrSingle); + Id_StrSingle := LastSubId; + RegisterParameter(H_Sub, typeANSISTRING, Unassigned, ByRef); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typeSINGLE, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_StrExtended); + Id_StrExtended := LastSubId; + RegisterParameter(H_Sub, typeANSISTRING, Unassigned, ByRef); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typeEXTENDED, Unassigned); + + RegisterRoutine(0, '', typeVOID, ccREGISTER, @_DecStringCounter); + Id_DecStringCounter := LastSubId; +{$IFDEF FPC} + RegisterRoutine(0, '', typeVOID, ccREGISTER, @_IncStringCounter); + Id_IncStringCounter := LastSubId; +{$ENDIF} + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_AnsiStringEquality); + Id_AnsiStringEquality := LastSubId; + RegisterParameter(H_Sub, typeANSISTRING, Unassigned, ByRef); + RegisterParameter(H_Sub, typeANSISTRING, Unassigned, ByRef); + RegisterParameter(H_Sub, typeBOOLEAN, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_AnsiStringNotEquality); + Id_AnsiStringNotEquality := LastSubId; + RegisterParameter(H_Sub, typeANSISTRING, Unassigned, ByRef); + RegisterParameter(H_Sub, typeANSISTRING, Unassigned, ByRef); + RegisterParameter(H_Sub, typeBOOLEAN, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_ShortStringEquality); + Id_ShortStringEquality := LastSubId; + RegisterParameter(H_Sub, typeSHORTSTRING, Unassigned, ByRef); + RegisterParameter(H_Sub, typeSHORTSTRING, Unassigned, ByRef); + RegisterParameter(H_Sub, typeBOOLEAN, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_ShortStringNotEquality); + Id_ShortStringNotEquality := LastSubId; + RegisterParameter(H_Sub, typeSHORTSTRING, Unassigned, ByRef); + RegisterParameter(H_Sub, typeSHORTSTRING, Unassigned, ByRef); + RegisterParameter(H_Sub, typeBOOLEAN, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_WideStringEquality); + Id_WideStringEquality := LastSubId; + RegisterParameter(H_Sub, typeWIDESTRING, Unassigned, ByRef); + RegisterParameter(H_Sub, typeWIDESTRING, Unassigned, ByRef); + RegisterParameter(H_Sub, typeBOOLEAN, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_WideStringNotEquality); + Id_WideStringNotEquality := LastSubId; + RegisterParameter(H_Sub, typeWIDESTRING, Unassigned, ByRef); + RegisterParameter(H_Sub, typeWIDESTRING, Unassigned, ByRef); + RegisterParameter(H_Sub, typeBOOLEAN, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeINTEGER, ccSTDCALL, @_ShortstringHigh); + Id_ShortstringHigh := LastSubId; + RegisterParameter(H_Sub, typeSHORTSTRING, Unassigned, ByRef); + RegisterParameter(H_Sub, typeINTEGER, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @ _AnsiStringGreaterThan); + Id_AnsiStringGreaterThan := LastSubId; + RegisterParameter(H_Sub, typeANSISTRING, Unassigned, ByRef); + RegisterParameter(H_Sub, typeANSISTRING, Unassigned, ByRef); + RegisterParameter(H_Sub, typeBOOLEAN, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_AnsiStringGreaterThanOrEqual); + Id_AnsiStringGreaterThanOrEqual := LastSubId; + RegisterParameter(H_Sub, typeANSISTRING, Unassigned, ByRef); + RegisterParameter(H_Sub, typeANSISTRING, Unassigned, ByRef); + RegisterParameter(H_Sub, typeBOOLEAN, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_AnsiStringLessThan); + Id_AnsiStringLessThan := LastSubId; + RegisterParameter(H_Sub, typeANSISTRING, Unassigned, ByRef); + RegisterParameter(H_Sub, typeANSISTRING, Unassigned, ByRef); + RegisterParameter(H_Sub, typeBOOLEAN, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_AnsiStringLessThanOrEqual); + Id_AnsiStringLessThanOrEqual := LastSubId; + RegisterParameter(H_Sub, typeANSISTRING, Unassigned, ByRef); + RegisterParameter(H_Sub, typeANSISTRING, Unassigned, ByRef); + RegisterParameter(H_Sub, typeBOOLEAN, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @ _ShortStringGreaterThan); + Id_ShortStringGreaterThan := LastSubId; + RegisterParameter(H_Sub, typeSHORTSTRING, Unassigned, ByRef); + RegisterParameter(H_Sub, typeSHORTSTRING, Unassigned, ByRef); + RegisterParameter(H_Sub, typeBOOLEAN, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_ShortStringGreaterThanOrEqual); + Id_ShortStringGreaterThanOrEqual := LastSubId; + RegisterParameter(H_Sub, typeSHORTSTRING, Unassigned, ByRef); + RegisterParameter(H_Sub, typeSHORTSTRING, Unassigned, ByRef); + RegisterParameter(H_Sub, typeBOOLEAN, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_ShortStringLessThan); + Id_ShortStringLessThan := LastSubId; + RegisterParameter(H_Sub, typeSHORTSTRING, Unassigned, ByRef); + RegisterParameter(H_Sub, typeSHORTSTRING, Unassigned, ByRef); + RegisterParameter(H_Sub, typeBOOLEAN, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_ShortStringLessThanOrEqual); + Id_ShortStringLessThanOrEqual := LastSubId; + RegisterParameter(H_Sub, typeSHORTSTRING, Unassigned, ByRef); + RegisterParameter(H_Sub, typeSHORTSTRING, Unassigned, ByRef); + RegisterParameter(H_Sub, typeBOOLEAN, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @ _WideStringGreaterThan); + Id_WideStringGreaterThan := LastSubId; + RegisterParameter(H_Sub, typeWIDESTRING, Unassigned, ByRef); + RegisterParameter(H_Sub, typeWIDESTRING, Unassigned, ByRef); + RegisterParameter(H_Sub, typeBOOLEAN, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_WideStringGreaterThanOrEqual); + Id_WideStringGreaterThanOrEqual := LastSubId; + RegisterParameter(H_Sub, typeWIDESTRING, Unassigned, ByRef); + RegisterParameter(H_Sub, typeWIDESTRING, Unassigned, ByRef); + RegisterParameter(H_Sub, typeBOOLEAN, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_WideStringLessThan); + Id_WideStringLessThan := LastSubId; + RegisterParameter(H_Sub, typeWIDESTRING, Unassigned, ByRef); + RegisterParameter(H_Sub, typeWIDESTRING, Unassigned, ByRef); + RegisterParameter(H_Sub, typeBOOLEAN, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_WideStringLessThanOrEqual); + Id_WideStringLessThanOrEqual := LastSubId; + RegisterParameter(H_Sub, typeWIDESTRING, Unassigned, ByRef); + RegisterParameter(H_Sub, typeWIDESTRING, Unassigned, ByRef); + RegisterParameter(H_Sub, typeBOOLEAN, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_SetStringLength); + Id_SetStringLength := LastSubId; + RegisterParameter(H_Sub, typeANSISTRING, Unassigned, ByRef); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_SetWideStringLength); + Id_SetWideStringLength := LastSubId; + RegisterParameter(H_Sub, typeWIDESTRING, Unassigned, ByRef); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_SetShortStringLength); + Id_SetShortStringLength := LastSubId; + RegisterParameter(H_Sub, typeSHORTSTRING, Unassigned, ByRef); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + +{$ENDIF} + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_SetVariantLength); + Id_SetVariantLength := LastSubId; + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + +//--------- INT64 ROUTINES ----------------------------------------------------- + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @ _Int64Multiplication); + Id_Int64Multiplication := LastSubId; + RegisterParameter(H_Sub, typeINT64, Unassigned, ByRef); + RegisterParameter(H_Sub, typeINT64, Unassigned, ByRef); + RegisterParameter(H_Sub, typeINT64, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @ _Int64Division); + Id_Int64Division := LastSubId; + RegisterParameter(H_Sub, typeINT64, Unassigned, ByRef); + RegisterParameter(H_Sub, typeINT64, Unassigned, ByRef); + RegisterParameter(H_Sub, typeINT64, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @ _Int64Modulo); + Id_Int64Modulo := LastSubId; + RegisterParameter(H_Sub, typeINT64, Unassigned, ByRef); + RegisterParameter(H_Sub, typeINT64, Unassigned, ByRef); + RegisterParameter(H_Sub, typeINT64, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @ _Int64LeftShift); + Id_Int64LeftShift := LastSubId; + RegisterParameter(H_Sub, typeINT64, Unassigned, ByRef); + RegisterParameter(H_Sub, typeINT64, Unassigned, ByRef); + RegisterParameter(H_Sub, typeINT64, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @ _Int64RightShift); + Id_Int64RightShift := LastSubId; + RegisterParameter(H_Sub, typeINT64, Unassigned, ByRef); + RegisterParameter(H_Sub, typeINT64, Unassigned, ByRef); + RegisterParameter(H_Sub, typeINT64, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @ _Int64LessThan); + Id_Int64LessThan := LastSubId; + RegisterParameter(H_Sub, typeINT64, Unassigned, ByRef); + RegisterParameter(H_Sub, typeINT64, Unassigned, ByRef); + RegisterParameter(H_Sub, typeBOOLEAN, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @ _Int64LessThanOrEqual); + Id_Int64LessThanOrEqual := LastSubId; + RegisterParameter(H_Sub, typeINT64, Unassigned, ByRef); + RegisterParameter(H_Sub, typeINT64, Unassigned, ByRef); + RegisterParameter(H_Sub, typeBOOLEAN, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @ _Int64GreaterThan); + Id_Int64GreaterThan := LastSubId; + RegisterParameter(H_Sub, typeINT64, Unassigned, ByRef); + RegisterParameter(H_Sub, typeINT64, Unassigned, ByRef); + RegisterParameter(H_Sub, typeBOOLEAN, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @ _Int64GreaterThanOrEqual); + Id_Int64GreaterThanOrEqual := LastSubId; + RegisterParameter(H_Sub, typeINT64, Unassigned, ByRef); + RegisterParameter(H_Sub, typeINT64, Unassigned, ByRef); + RegisterParameter(H_Sub, typeBOOLEAN, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @ _Int64Equality); + Id_Int64Equality := LastSubId; + RegisterParameter(H_Sub, typeINT64, Unassigned, ByRef); + RegisterParameter(H_Sub, typeINT64, Unassigned, ByRef); + RegisterParameter(H_Sub, typeBOOLEAN, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @ _Int64NotEquality); + Id_Int64NotEquality := LastSubId; + RegisterParameter(H_Sub, typeINT64, Unassigned, ByRef); + RegisterParameter(H_Sub, typeINT64, Unassigned, ByRef); + RegisterParameter(H_Sub, typeBOOLEAN, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @ _Int64Abs); + Id_Int64Abs := LastSubId; + RegisterParameter(H_Sub, typeINT64, Unassigned, ByRef); + RegisterParameter(H_Sub, typeINT64, Unassigned, ByRef); + +// uint64 + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @ _UInt64LessThan); + Id_UInt64LessThan := LastSubId; + RegisterParameter(H_Sub, typeUINT64, Unassigned, ByRef); + RegisterParameter(H_Sub, typeUINT64, Unassigned, ByRef); + RegisterParameter(H_Sub, typeBOOLEAN, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @ _UInt64LessThanOrEqual); + Id_UInt64LessThanOrEqual := LastSubId; + RegisterParameter(H_Sub, typeUINT64, Unassigned, ByRef); + RegisterParameter(H_Sub, typeUINT64, Unassigned, ByRef); + RegisterParameter(H_Sub, typeBOOLEAN, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @ _UInt64GreaterThan); + Id_UInt64GreaterThan := LastSubId; + RegisterParameter(H_Sub, typeUINT64, Unassigned, ByRef); + RegisterParameter(H_Sub, typeUINT64, Unassigned, ByRef); + RegisterParameter(H_Sub, typeBOOLEAN, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @ _UInt64GreaterThanOrEqual); + Id_UInt64GreaterThanOrEqual := LastSubId; + RegisterParameter(H_Sub, typeUINT64, Unassigned, ByRef); + RegisterParameter(H_Sub, typeUINT64, Unassigned, ByRef); + RegisterParameter(H_Sub, typeBOOLEAN, Unassigned, ByRef); + +//--------- VARIANT ROUTINES --------------------------------------------------- + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_OleVariantFromVariant); + Id_OleVariantFromVariant := LastSubId; + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @ _VariantAssign); + Id_VariantAssign := LastSubId; + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @ _OleVariantAssign); + Id_OleVariantAssign := LastSubId; + RegisterParameter(H_Sub, typeOLEVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeOLEVARIANT, Unassigned, ByRef); + +{$IFNDEF PAXARM} + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_VariantFromPAnsiChar); + Id_VariantFromPAnsiChar := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_OleVariantFromPAnsiChar); + Id_OleVariantFromPAnsiChar := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); +{$ENDIF} + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_VariantFromInterface); + Id_VariantFromInterface := LastSubId; + RegisterParameter(H_Sub, typeINTERFACE, Unassigned); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_OleVariantFromInterface); + Id_OleVariantFromInterface := LastSubId; + RegisterParameter(H_Sub, typeINTERFACE, Unassigned); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + +{$IFNDEF PAXARM} + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_VariantFromAnsiString); + Id_VariantFromAnsiString := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_OleVariantFromAnsiString); + Id_OleVariantFromAnsiString := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_VariantFromWideString); + Id_VariantFromWideString := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_OleVariantFromWideString); + Id_OleVariantFromWideString := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_VariantFromShortString); + Id_VariantFromShortString := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_OleVariantFromShortString); + Id_OleVariantFromShortString := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_VariantFromAnsiChar); + Id_VariantFromAnsiChar := LastSubId; + RegisterParameter(H_Sub, typeANSICHAR, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_OleVariantFromAnsiChar); + Id_OleVariantFromAnsiChar := LastSubId; + RegisterParameter(H_Sub, typeANSICHAR, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + +{$ENDIF} + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_VariantFromWideChar); + Id_VariantFromWideChar := LastSubId; + RegisterParameter(H_Sub, typeWIDECHAR, Unassigned); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_OleVariantFromWideChar); + Id_OleVariantFromWideChar := LastSubId; + RegisterParameter(H_Sub, typeWIDECHAR, Unassigned); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_VariantFromInt); + Id_VariantFromInt := LastSubId; + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_OleVariantFromInt); + Id_OleVariantFromInt := LastSubId; + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typeOLEVARIANT, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_VariantFromInt64); + Id_VariantFromInt64 := LastSubId; + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeINT64, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_OleVariantFromInt64); + Id_OleVariantFromInt64 := LastSubId; + RegisterParameter(H_Sub, typeOLEVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeINT64, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @ _VariantFromByte); + Id_VariantFromByte := LastSubId; + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeBYTE, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @ _OleVariantFromByte); + Id_OleVariantFromByte := LastSubId; + RegisterParameter(H_Sub, typeOLEVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeBYTE, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_VariantFromBool); + Id_VariantFromBool := LastSubId; + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeBOOLEAN, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_OleVariantFromBool); + Id_OleVariantFromBool := LastSubId; + RegisterParameter(H_Sub, typeOLEVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeBOOLEAN, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_VariantFromWord); + Id_VariantFromWord := LastSubId; + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeWORD, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_OleVariantFromWord); + Id_OleVariantFromWord := LastSubId; + RegisterParameter(H_Sub, typeOLEVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeWORD, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_VariantFromCardinal); + Id_VariantFromCardinal := LastSubId; + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeCARDINAL, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_OleVariantFromCardinal); + Id_OleVariantFromCardinal := LastSubId; + RegisterParameter(H_Sub, typeOLEVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeCARDINAL, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_VariantFromSmallInt); + Id_VariantFromSmallInt := LastSubId; + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeSMALLINT, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_OleVariantFromSmallInt); + Id_OleVariantFromSmallInt := LastSubId; + RegisterParameter(H_Sub, typeOLEVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeSMALLINT, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_VariantFromShortInt); + Id_VariantFromShortInt := LastSubId; + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeSHORTINT, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_OleVariantFromShortInt); + Id_OleVariantFromShortInt := LastSubId; + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeSHORTINT, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_VariantFromDouble); + Id_VariantFromDouble := LastSubId; + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeDOUBLE, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_OleVariantFromDouble); + Id_OleVariantFromDouble := LastSubId; + RegisterParameter(H_Sub, typeOLEVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeDOUBLE, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_VariantFromCurrency); + Id_VariantFromCurrency := LastSubId; + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeCURRENCY, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_OleVariantFromCurrency); + Id_OleVariantFromCurrency := LastSubId; + RegisterParameter(H_Sub, typeOLEVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeCURRENCY, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_VariantFromSingle); + Id_VariantFromSingle := LastSubId; + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeSINGLE, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_OleVariantFromSingle); + Id_OleVariantFromSingle := LastSubId; + RegisterParameter(H_Sub, typeOLEVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeSINGLE, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_VariantFromExtended); + Id_VariantFromExtended := LastSubId; + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeEXTENDED, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_OleVariantFromExtended); + Id_OleVariantFromExtended := LastSubId; + RegisterParameter(H_Sub, typeOLEVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeEXTENDED, Unassigned, ByRef); + +{$IFDEF UNIC} + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_UnicStringFromInt); + Id_UnicStringFromInt := LastSubId; // js only + RegisterParameter(H_Sub, typeINTEGER, Unassigned, ByRef); + RegisterParameter(H_Sub, typeUNICSTRING, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_UnicStringFromDouble); + Id_UnicStringFromDouble := LastSubId; // js only + RegisterParameter(H_Sub, typeDOUBLE, Unassigned, ByRef); + RegisterParameter(H_Sub, typeUNICSTRING, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_UnicStringFromSingle); + Id_UnicStringFromSingle := LastSubId; // js only + RegisterParameter(H_Sub, typeSINGLE, Unassigned, ByRef); + RegisterParameter(H_Sub, typeUNICSTRING, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_UnicStringFromExtended); + Id_UnicStringFromExtended := LastSubId; // js only + RegisterParameter(H_Sub, typeEXTENDED, Unassigned, ByRef); + RegisterParameter(H_Sub, typeUNICSTRING, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_UnicStringFromBoolean); + Id_UnicStringFromBoolean := LastSubId; // js only + RegisterParameter(H_Sub, typeUNICSTRING, Unassigned, ByRef); + RegisterParameter(H_Sub, typeBOOLEAN, Unassigned, ByRef); +{$ELSE} + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_AnsiStringFromInt); + Id_AnsiStringFromInt := LastSubId; // js only + RegisterParameter(H_Sub, typeANSISTRING, Unassigned, ByRef); + RegisterParameter(H_Sub, typeINTEGER, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_AnsiStringFromDouble); + Id_AnsiStringFromDouble := LastSubId; // js only + RegisterParameter(H_Sub, typeANSISTRING, Unassigned, ByRef); + RegisterParameter(H_Sub, typeDOUBLE, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_AnsiStringFromSingle); + Id_AnsiStringFromSingle := LastSubId; // js only + RegisterParameter(H_Sub, typeANSISTRING, Unassigned, ByRef); + RegisterParameter(H_Sub, typeSINGLE, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_AnsiStringFromExtended); + Id_AnsiStringFromExtended := LastSubId; // js only + RegisterParameter(H_Sub, typeANSISTRING, Unassigned, ByRef); + RegisterParameter(H_Sub, typeEXTENDED, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_AnsiStringFromBoolean); + Id_AnsiStringFromBoolean := LastSubId; // js only + RegisterParameter(H_Sub, typeANSISTRING, Unassigned, ByRef); + RegisterParameter(H_Sub, typeBOOLEAN, Unassigned, ByRef); +{$ENDIF} // not unic + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_WideCharFromVariant); + Id_WideCharFromVariant := LastSubId; + RegisterParameter(H_Sub, typeWIDECHAR, Unassigned, ByRef); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + +{$IFNDEF PAXARM} + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_AnsiCharFromVariant); + Id_AnsiCharFromVariant := LastSubId; + RegisterParameter(H_Sub, typeANSICHAR, Unassigned, ByRef); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_AnsiStringFromVariant); + Id_AnsiStringFromVariant := LastSubId; + RegisterParameter(H_Sub, typeANSISTRING, Unassigned, ByRef); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_WideStringFromVariant); + Id_WideStringFromVariant := LastSubId; + RegisterParameter(H_Sub, typeWIDESTRING, Unassigned, ByRef); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_ShortStringFromVariant); + Id_ShortStringFromVariant := LastSubId; + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typeSHORTSTRING, Unassigned, ByRef); +{$ENDIF} + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_DoubleFromVariant); + Id_DoubleFromVariant := LastSubId; + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeDOUBLE, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_CurrencyFromVariant); + Id_CurrencyFromVariant := LastSubId; + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeCURRENCY, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_SingleFromVariant); + Id_SingleFromVariant := LastSubId; + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeDOUBLE, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_ExtendedFromVariant); + Id_ExtendedFromVariant := LastSubId; + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeEXTENDED, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_IntFromVariant); + Id_IntFromVariant := LastSubId; + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeINTEGER, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_Int64FromVariant); + Id_Int64FromVariant := LastSubId; + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeINT64, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_ByteFromVariant); + Id_ByteFromVariant := LastSubId; + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeBYTE, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_WordFromVariant); + Id_WordFromVariant := LastSubId; + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeWORD, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_CardinalFromVariant); + Id_CardinalFromVariant := LastSubId; + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeCARDINAL, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_SmallIntFromVariant); + Id_SmallIntFromVariant := LastSubId; + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeSMALLINT, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_ShortIntFromVariant); + Id_ShortIntFromVariant := LastSubId; + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeSHORTINT, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_BoolFromVariant); + Id_BoolFromVariant := LastSubId; + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeBOOLEAN, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_ByteBoolFromVariant); + Id_ByteBoolFromVariant := LastSubId; + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeBYTEBOOL, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_WordBoolFromVariant); + Id_WordBoolFromVariant := LastSubId; + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeWORDBOOL, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_LongBoolFromVariant); + Id_LongBoolFromVariant := LastSubId; + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeLONGBOOL, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @ _VariantAddition); + Id_VariantAddition := LastSubId; + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @ _VariantSubtraction); + Id_VariantSubtraction := LastSubId; + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @ _VariantMultiplication); + Id_VariantMultiplication := LastSubId; + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @ _VariantDivision); + Id_VariantDivision := LastSubId; + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @ _VariantIDivision); + Id_VariantIDivision := LastSubId; + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @ _VariantModulo); + Id_VariantModulo := LastSubId; + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @ _VariantLeftShift); + Id_VariantLeftShift := LastSubId; + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @ _VariantRightShift); + Id_VariantRightShift := LastSubId; + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @ _VariantAnd); + Id_VariantAnd := LastSubId; + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @ _VariantOr); + Id_VariantOr := LastSubId; + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @ _VariantXor); + Id_VariantXor := LastSubId; + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @ _VariantLessThan); + Id_VariantLessThan := LastSubId; + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeBOOLEAN, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @ _VariantLessThanOrEqual); + Id_VariantLessThanOrEqual := LastSubId; + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeBOOLEAN, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @ _VariantGreaterThan); + Id_VariantGreaterThan := LastSubId; + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeBOOLEAN, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @ _VariantGreaterThanOrEqual); + Id_VariantGreaterThanOrEqual := LastSubId; + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeBOOLEAN, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @ _VariantEquality); + Id_VariantEquality := LastSubId; + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeBOOLEAN, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @ _VariantNotEquality); + Id_VariantNotEquality := LastSubId; + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeBOOLEAN, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @ _VariantNegation); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + Id_VariantNegation := LastSubId; + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @ _VariantAbs); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + Id_VariantAbs := LastSubId; + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @ _VariantNot); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + Id_VariantNot := LastSubId; + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @ _VarArrayGet1); + Id_VarArrayGet1 := LastSubId; + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @ _VarArrayPut1); + Id_VarArrayPut1 := LastSubId; + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @ _VarArrayGet2); + Id_VarArrayGet2 := LastSubId; + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @ _VarArrayPut2); + Id_VarArrayPut2 := LastSubId; + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @ _VarArrayGet3); + Id_VarArrayGet3 := LastSubId; + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @ _VarArrayPut3); + Id_VarArrayPut3 := LastSubId; + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @ _InterfaceFromClass); + Id_InterfaceFromClass := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @ _InterfaceCast); + Id_InterfaceCast := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @ _InterfaceAssign); + Id_InterfaceAssign := LastSubId; + RegisterParameter(H_Sub, typeINTERFACE, Unassigned, ByRef); + RegisterParameter(H_Sub, typeINTERFACE, Unassigned, ByRef); + +{$IFDEF PAX64} + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @ _DoubleMultiplication); + Id_DoubleMultiplication := LastSubId; + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typeDOUBLE, Unassigned, ByRef); + RegisterParameter(H_Sub, typeDOUBLE, Unassigned, ByRef); + RegisterParameter(H_Sub, typeDOUBLE, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @ _DoubleDivision); + Id_DoubleDivision := LastSubId; + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typeDOUBLE, Unassigned, ByRef); + RegisterParameter(H_Sub, typeDOUBLE, Unassigned, ByRef); + RegisterParameter(H_Sub, typeDOUBLE, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @ _DoubleAddition); + Id_DoubleAddition := LastSubId; + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typeDOUBLE, Unassigned, ByRef); + RegisterParameter(H_Sub, typeDOUBLE, Unassigned, ByRef); + RegisterParameter(H_Sub, typeDOUBLE, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @ _DoubleSubtraction); + Id_DoubleSubtraction := LastSubId; + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typeDOUBLE, Unassigned, ByRef); + RegisterParameter(H_Sub, typeDOUBLE, Unassigned, ByRef); + RegisterParameter(H_Sub, typeDOUBLE, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @ _DoubleNegation); + Id_DoubleNegation := LastSubId; + RegisterParameter(H_Sub, typeDOUBLE, Unassigned, ByRef); + RegisterParameter(H_Sub, typeDOUBLE, Unassigned, ByRef); +{$ENDIF} + +//------------------ Dynamic array support routines ---------------------------- + RegisterRoutine(0, 'SetLength', typeVOID, ccSTDCALL, nil); + + RegisterRoutine(0, '', typeVOID, ccREGISTER, @_CondHalt); + Id_CondHalt := LastSubId; + + H_Sub := RegisterRoutine(0, '_toParentClass', typeVOID, ccSTDCALL, @_ToParentClass); + Id_ToParentClass := LastSubId; + RegisterParameter(H_Sub, typeCLASS, Unassigned); + RegisterParameter(H_Sub, typeCLASS, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_UpdateInstance); + Id_UpdateInstance := LastSubId; + RegisterParameter(H_Sub, typeCLASS, Unassigned); + RegisterParameter(H_Sub, typeCLASS, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_BeginExceptBlock); + Id_BeginExceptBlock := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + // reserved +// RegisterRoutine(0, '', typeVOID, ccSTDCALL, @Dummy); +{$IFNDEF PAXARM} + RegisterRoutine(0, '', typeVOID, ccREGISTER, @_DestroyInherited); + Id_DestroyInherited := LastSubId; +{$ENDIF} + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, + @ _DynarraySetLength); + Id_DynarraySetLength := LastSubId; + RegisterParameter(H_Sub, typeDYNARRAY, Unassigned, ByRef); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, + @ _CreateEmptyDynarray); + Id_CreateEmptyDynarray := LastSubId; + RegisterParameter(H_Sub, typeDYNARRAY, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, + @ _DynarrayClr); + Id_DynarrayClr := LastSubId; + RegisterParameter(H_Sub, typeDYNARRAY, Unassigned, ByRef); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, + @ _DynarrayAssign); + Id_DynarrayAssign := LastSubId; + RegisterParameter(H_Sub, typeDYNARRAY, Unassigned, ByRef); + RegisterParameter(H_Sub, typeDYNARRAY, Unassigned, ByRef); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeINTEGER, ccSTDCALL, + @_DynarrayHigh); + Id_DynarrayHigh := LastSubId; + RegisterParameter(H_Sub, typeDYNARRAY, Unassigned, ByRef); + RegisterParameter(H_Sub, typeINTEGER, Unassigned, ByRef); + +//------------------------------------------------------------------------------ + +{$IFDEF MSWINDOWS} + RegisterRoutine(0, strGetTickCount, typeINTEGER, ccREGISTER, @GetTickCount); +{$ELSE} + RegisterRoutine(0, '', typeINTEGER, ccREGISTER, nil); +{$ENDIF} + + RegisterRoutine(0, '', typePOINTER, ccREGISTER, @GetClassByIndex); + Id_GetClassByIndex := LastSubId; + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_PrintEx); + Id_PrintEx := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); //runner + RegisterParameter(H_Sub, typePOINTER, Unassigned); //address + RegisterParameter(H_Sub, typeINTEGER, Unassigned); //kind + RegisterParameter(H_Sub, typeINTEGER, Unassigned); //ft + RegisterParameter(H_Sub, typeINTEGER, Unassigned); //L1 + RegisterParameter(H_Sub, typeINTEGER, Unassigned); //L2 + +// processing IS + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_Is); + Id_Is := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typeBOOLEAN, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_ClassName); + Id_ClassName := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned, ByRef); + RegisterParameter(H_Sub, typePOINTER, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_BeforeCallHost); + Id_BeforeCallHost := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_AfterCallHost); + Id_AfterCallHost := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_OnCreateObject); + Id_OnCreateObject := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_OnCreateHostObject); + Id_OnCreateHostObject := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_OnDestroyHostObject); + Id_OnDestroyHostObject := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_OnAfterObjectCreation); + Id_OnAfterObjectCreation := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + +// processing of published properties +{$IFNDEF PAXARM} + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_GetAnsiStrProp); + Id_GetAnsiStrProp := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_SetAnsiStrProp); + Id_SetAnsiStrProp := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_GetWideStrProp); + Id_GetWideStrProp := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_SetWideStrProp); + Id_SetWideStrProp := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); +{$ENDIF} + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_GetOrdProp); + Id_GetOrdProp := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_SetOrdProp); + Id_SetOrdProp := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_GetInterfaceProp); + Id_GetInterfaceProp := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_SetInterfaceProp); + Id_SetInterfaceProp := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_GetSetProp); + Id_GetSetProp := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_SetSetProp); + Id_SetSetProp := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_GetFloatProp); + Id_GetFloatProp := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_SetFloatProp); + Id_SetFloatProp := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_GetVariantProp); + Id_GetVariantProp := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_SetVariantProp); + Id_SetVariantProp := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_GetInt64Prop); + Id_GetInt64Prop := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @ _SetInt64Prop); + Id_SetInt64Prop := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @ _GetEventProp); + Id_GetEventProp := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, Address_SetEventProp); + Id_SetEventProp := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, Address_SetEventProp2); + Id_SetEventProp2 := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @ _CreateMethod); + Id_CreateMethod := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + +// processing try-except-finally + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, Address_TryOn); + Id_TryOn := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, Address_TryOff); + Id_TryOff := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, Address_Raise); + Id_Raise := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, Address_Exit); + Id_Exit := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_Finally); + Id_Finally := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, Address_CondRaise); + Id_CondRaise := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_EndExceptBlock); + Id_EndExceptBlock := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + +// processing pause + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, Address_Pause); + Id_Pause := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + + RegisterRoutine(0, 'pause', typeVOID, ccSTDCALL, nil); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccREGISTER, Address_InitSub); + Id_InitSub := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccREGISTER, Address_EndSub); + Id_EndSub := LastSubId; + RegisterParameter(H_Sub, typeCLASS, Unassigned); + +// processing halt + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_Halt); + Id_Halt := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + + RegisterRoutine(0, 'halt', typeVOID, ccSTDCALL, nil); + RegisterRoutine(0, 'abort', typeVOID, ccSTDCALL, nil); + + RegisterRoutine(0, 'print', typeVOID, ccSTDCALL, nil); + RegisterRoutine(0, 'println', typeVOID, ccSTDCALL, nil); + +// processing breakpoints + + H_Sub := RegisterRoutine(0, '', typeVOID, ccREGISTER, @_CheckPause); + Id_CheckPause := LastSubId; + RegisterParameter(H_Sub, typeCLASS, Unassigned); + +// processing integer overflow + + RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_IntOver); + Id_IntOver := LastSubId; + +// processing bound error + + RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_BoundError); + Id_BoundError := LastSubId; + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, Address_CreateObject); + Id_CreateObject := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @ _ErrAbstract); + Id_ErrAbstract := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @ _RecordAssign); + Id_RecordAssign := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + + RegisterRoutine(0, '_GetProgAddress', typePOINTER, ccSTDCALL, @ _GetProgAddress); + + CURR_FMUL_ID := RegisterConstant(0, '_10000.0', typeSINGLE, 10000.0); + +///////////////////////////////////////////////////////////////////// +/// PASCAL NAMESPASCE /////////////////////////////////////////////// +///////////////////////////////////////////////////////////////////// + + H_Namespace := RegisterNamespace(0, StrPascalNamespace); + H_PascalNamespace := H_Namespace; + + H_Sub := RegisterRoutine(H_Namespace, 'GetMem', typeVOID, ccREGISTER, + @_GetMem); + RegisterParameter(H_Sub, typePOINTER, Unassigned, ByRef, 'P'); + RegisterParameter(H_Sub, typeINTEGER, Unassigned, false, 'Size'); + + H_Sub := RegisterRoutine(H_Namespace, 'FreeMem', typeVOID, ccREGISTER, + @_FreeMem); + RegisterParameter(H_Sub, typePOINTER, Unassigned, false, 'P'); + RegisterParameter(H_Sub, typeINTEGER, Unassigned, false, 'Size'); + + H_Sub := RegisterRoutine(H_Namespace, 'AllocMem', typePOINTER, ccREGISTER, + @AllocMem); + RegisterParameter(H_Sub, typeCARDINAL, Unassigned, false, 'Size'); + +// PASCAL ARITHMETIC ROUTINES /////////////////////////////////////// + + H_Sub := RegisterRoutine(H_Namespace, 'Abs', typeVOID, ccSTDCALL, nil); + RegisterParameter(H_Sub, typeVOID, Unassigned, ByRef, 'X'); + + H_Sub := RegisterRoutine(H_Namespace, 'ArcTan', typeEXTENDED, ccREGISTER, + @_ArcTan); + RegisterParameter(H_Sub, typeEXTENDED, Unassigned, false, 'X'); + + H_Sub := RegisterRoutine(H_Namespace, 'Cos', typeEXTENDED, ccREGISTER, @_Cos); + RegisterParameter(H_Sub, typeEXTENDED, Unassigned, false, 'X'); + + H_Sub := RegisterRoutine(H_Namespace, 'Exp', typeEXTENDED, ccREGISTER, @_Exp); + RegisterParameter(H_Sub, typeEXTENDED, Unassigned, false, 'X'); + + H_Sub := RegisterRoutine(H_Namespace, 'Frac', typeEXTENDED, ccREGISTER, @_Frac); + RegisterParameter(H_Sub, typeEXTENDED, Unassigned, false, 'X'); + + H_Sub := RegisterRoutine(H_Namespace, 'Int', typeEXTENDED, ccREGISTER, @_Int); + RegisterParameter(H_Sub, typeEXTENDED, Unassigned, false, 'X'); + + H_Sub := RegisterRoutine(H_Namespace, 'Ln', typeEXTENDED, ccREGISTER, @_Ln); + RegisterParameter(H_Sub, typeEXTENDED, Unassigned, false, 'X'); + + RegisterConstant(H_Namespace, 'Pi', typeEXTENDED, Pi); + + H_Sub := RegisterRoutine(H_Namespace, 'Sin', typeEXTENDED, ccREGISTER, @_Sin); + RegisterParameter(H_Sub, typeEXTENDED, Unassigned, false, 'X'); + + H_Sub := RegisterRoutine(H_Namespace, 'Sqr', typeEXTENDED, ccREGISTER, @_Sqr); + RegisterParameter(H_Sub, typeEXTENDED, Unassigned, false, 'X'); + + H_Sub := RegisterRoutine(H_Namespace, 'Sqrt', typeEXTENDED, ccREGISTER, @_Sqrt); + RegisterParameter(H_Sub, typeEXTENDED, Unassigned, false, 'X'); + + H_Sub := RegisterRoutine(H_Namespace, 'Trunc', typeINTEGER, ccREGISTER, @_Trunc); + RegisterParameter(H_Sub, typeEXTENDED, Unassigned, false, 'X'); + + H_Sub := RegisterRoutine(H_Namespace, 'Power', typeEXTENDED, ccREGISTER, @_Power); + RegisterParameter(H_Sub, typeEXTENDED, Unassigned, false, 'Base'); + RegisterParameter(H_Sub, typeEXTENDED, Unassigned, false, 'Exponent'); + +///////////////////////////////////////////////////////////////////// + + RegisterRoutine(H_Namespace, 'New', typeVOID, ccSTDCALL, nil); + RegisterRoutine(H_Namespace, 'Dispose', typeVOID, ccSTDCALL, nil); + RegisterRoutine(H_Namespace, 'Inc', typeVOID, ccSTDCALL, nil); + RegisterRoutine(H_Namespace, 'Dec', typeVOID, ccSTDCALL, nil); + RegisterRoutine(H_Namespace, 'Pred', typeVOID, ccSTDCALL, nil); + RegisterRoutine(H_Namespace, 'Succ', typeVOID, ccSTDCALL, nil); + RegisterRoutine(H_Namespace, 'Ord', typeVOID, ccSTDCALL, nil); + RegisterRoutine(H_Namespace, 'Chr', typeVOID, ccSTDCALL, nil); + RegisterRoutine(H_Namespace, 'Low', typeVOID, ccSTDCALL, nil); + RegisterRoutine(H_Namespace, 'High', typeVOID, ccSTDCALL, nil); + RegisterRoutine(0, 'Assigned', typeVOID, ccSTDCALL, nil); + + H_Sub := RegisterRoutine(H_Namespace, 'Odd', typeBOOLEAN, ccREGISTER, @_Odd); + RegisterParameter(H_Sub, typeINTEGER, Unassigned, false, 'X'); + +// PASCAL AnsiString ROUTINES /////////////////////////////////////// + + H_Sub := RegisterRoutine(0, 'Length', typeINTEGER, ccREGISTER, + @_DynarrayLength); + Id_DynArrayLength := LastSubId; + RegisterParameter(H_Sub, typeDYNARRAY, Unassigned, false, 'X'); +{$IFNDEF PAXARM} + H_Sub := RegisterRoutine(0, 'Length', typeINTEGER, ccREGISTER, + @_LengthString); + Id_AnsiStringLength := LastSubId; + RegisterParameter(H_Sub, typeANSISTRING, Unassigned, false, 'S'); + + H_Sub := RegisterRoutine(0, 'Length', typeINTEGER, ccREGISTER, + @ _LengthShortString); + RegisterParameter(H_Sub, typeSHORTSTRING, Unassigned, false, 'S'); + + H_Sub := RegisterRoutine(0, 'Length', typeINTEGER, ccREGISTER, + @_LengthWideString); + RegisterParameter(H_Sub, typeWIDESTRING, Unassigned, false, 'S'); +{$ENDIF} + H_Sub := RegisterRoutine(0, 'Length', typeINTEGER, ccREGISTER, + @_LengthUnicString); + RegisterParameter(H_Sub, typeUNICSTRING, Unassigned, false, 'S'); + + H_Sub := RegisterRoutine(0, 'Length', typeINTEGER, ccREGISTER, + @_VariantLength); + Id_VariantArrayLength := LastSubId; + RegisterParameter(H_Sub, typeVARIANT, Unassigned, false, 'S'); +{$IFNDEF PAXARM} + H_Sub := RegisterRoutine(H_Namespace, 'Delete', typeVOID, ccREGISTER, + @_Delete); + RegisterParameter(H_Sub, typeANSISTRING, Unassigned, ByRef, 'S'); + RegisterParameter(H_Sub, typeINTEGER, Unassigned, false, 'Index'); + RegisterParameter(H_Sub, typeINTEGER, Unassigned, false, 'Count'); + + H_Sub := RegisterRoutine(H_Namespace, 'Insert', typeVOID, ccREGISTER, + @_Insert); + RegisterParameter(H_Sub, typeANSISTRING, Unassigned, false, 'Substr'); + RegisterParameter(H_Sub, typeANSISTRING, Unassigned, ByRef, 'Dest'); + RegisterParameter(H_Sub, typeINTEGER, Unassigned, false, 'Index'); +{$ENDIF} + RegisterRoutine(H_Namespace, 'Str', typeVOID, ccSTDCALL, nil); + + H_Sub := RegisterRoutine(H_Namespace, 'Val', typeVOID, ccREGISTER, @_ValInt); + RegisterParameter(H_Sub, typeSTRING, Unassigned, false, 'S'); + RegisterParameter(H_Sub, typeINTEGER, Unassigned, ByRef, 'V'); + RegisterParameter(H_Sub, typeINTEGER, Unassigned, ByRef, 'Code'); + + H_Sub := RegisterRoutine(H_Namespace, 'Val', typeVOID, ccREGISTER, + @_ValDouble); + RegisterParameter(H_Sub, typeSTRING, Unassigned, false, 'X'); + RegisterParameter(H_Sub, typeDOUBLE, Unassigned, ByRef, 'V'); + RegisterParameter(H_Sub, typeINTEGER, Unassigned, ByRef, 'Code'); +{$IFNDEF PAXARM} + H_Sub := RegisterRoutine(H_Namespace, 'Copy', typeANSISTRING, ccREGISTER, + @_Copy); + RegisterParameter(H_Sub, typeANSISTRING, Unassigned, false, 'S'); + RegisterParameter(H_Sub, typeINTEGER, Unassigned, false, 'Index'); + RegisterParameter(H_Sub, typeINTEGER, Unassigned, false, 'Count'); + + H_Sub := RegisterRoutine(H_Namespace, 'Pos', typeINTEGER, ccREGISTER, + @_PosString); + RegisterParameter(H_Sub, typeANSISTRING, Unassigned, false, 'Substr'); + RegisterParameter(H_Sub, typeANSISTRING, Unassigned, false, 'Str'); + + H_Sub := RegisterRoutine(H_Namespace, 'Pos', typeINTEGER, ccREGISTER, @_PosChar); + RegisterParameter(H_Sub, typeANSICHAR, Unassigned, false, 'Ch'); + RegisterParameter(H_Sub, typeANSISTRING, Unassigned, false, 'Str'); +{$ENDIF} +///////////////////////////////////////////////////////////////////// +// PASCAL MISCELLANEOUS ROUTINES //////////////////////////////////// + + H_Sub := RegisterRoutine(H_Namespace, 'SizeOf', typeVOID, ccSTDCALL, nil); + RegisterParameter(H_Sub, typeVOID, Unassigned, ByRef, 'X'); + + H_Sub := RegisterRoutine(H_Namespace, 'Move', typeVOID, ccREGISTER, @Move); + RegisterParameter(H_Sub, typePVOID, Unassigned, false, 'Source'); + RegisterParameter(H_Sub, typePVOID, Unassigned, ByRef, 'Dest'); + RegisterParameter(H_Sub, typeINTEGER, Unassigned, false, 'Count'); +{$IFNDEF PAXARM} + H_Sub := RegisterRoutine(H_Namespace, 'FillChar', typeVOID, ccREGISTER, + @_FillChar); + RegisterParameter(H_Sub, typePVOID, Unassigned, ByRef, 'X'); + RegisterParameter(H_Sub, typeINTEGER, Unassigned, false, 'Count'); + RegisterParameter(H_Sub, typeANSICHAR, Unassigned, false, 'Value'); +{$ENDIF} + H_Sub := RegisterRoutine(H_Namespace, 'FillChar', typeVOID, ccREGISTER, + @_FillChar); + RegisterParameter(H_Sub, typePVOID, Unassigned, ByRef, 'X'); + RegisterParameter(H_Sub, typeINTEGER, Unassigned, false, 'Count'); + RegisterParameter(H_Sub, typeBYTE, Unassigned, false, 'Value'); + +{$IFNDEF PAXARM} +{$IFDEF FPC} + H_Sub := RegisterRoutine(H_Namespace, 'Upcase', typeANSICHAR, ccREGISTER, + @_Upcase); +{$ELSE} + H_Sub := RegisterRoutine(H_Namespace, 'Upcase', typeANSICHAR, ccREGISTER, + @ Upcase); +{$ENDIF} + RegisterParameter(H_Sub, typeANSICHAR, Unassigned, false, 'C'); +{$ENDIF} + + RegisterRoutine(H_Namespace, 'Randomize', typeVOID, ccREGISTER, @Randomize); + + H_Sub := RegisterRoutine(H_Namespace, 'Random', typeINTEGER, ccREGISTER, + @_Random1); + RegisterParameter(H_Sub, typeINTEGER, Unassigned, false, 'X'); + + RegisterRoutine(H_Namespace, 'Random', typeDOUBLE, ccREGISTER, @_Random); + + H_Sub := RegisterRoutine(H_Namespace, 'Hi', typeBYTE, ccREGISTER, @_HiInt); + RegisterParameter(H_Sub, typeINTEGER, Unassigned, false, 'X'); + + H_Sub := RegisterRoutine(H_Namespace, 'Hi', typeBYTE, ccREGISTER, @_HiWord); + RegisterParameter(H_Sub, typeWORD, Unassigned, false, 'X'); + + H_Sub := RegisterRoutine(H_Namespace, 'Lo', typeBYTE, ccREGISTER, @_LoInt); + RegisterParameter(H_Sub, typeINTEGER, Unassigned, false, 'X'); + + H_Sub := RegisterRoutine(H_Namespace, 'Lo', typeBYTE, ccREGISTER, @_LoWord); + RegisterParameter(H_Sub, typeWORD, Unassigned, false, 'X'); + + H_Sub := RegisterRoutine(H_Namespace, 'Round', typeINT64, ccREGISTER, @_Round); + RegisterParameter(H_Sub, typeEXTENDED, Unassigned, false, 'X'); + + {$IFDEF TRIAL} + + strShowTrial[0] := '_'; + strShowTrial[1] := '_'; + strShowTrial[2] := '_'; + strShowTrial[3] := '9'; + strShowTrial[4] := '^'; + strShowTrial[5] := '*'; + strShowTrial[6] := #0; + + RegisterRoutine(0, strShowTrial, typeVOID, ccREGISTER, @ ShowTrial); + + {$ENDIF} + + H_TPOINT := RegisterRecordType(0, 'TPoint', 1); + RegisterTypeField(H_TPOINT, 'X', typeINTEGER); + RegisterTypeField(H_TPOINT, 'Y', typeINTEGER); + + H := RegisterRecordType(0, 'TRect', 1); + RegisterTypeField(H, 'Left', typeINTEGER); + RegisterTypeField(H, 'Top', typeINTEGER); + RegisterTypeField(H, 'Right', typeINTEGER); + RegisterTypeField(H, 'Bottom', typeINTEGER); + +// PASCAL CLASSES ROUTINES ///////////////////////////////////////////////////// + + RegisterTypeAlias(H_Namespace, 'Real', typeDOUBLE); + Id_TDateTime := RegisterTypeAlias(H_Namespace, 'TDateTime', typeDOUBLE); + RegisterTypeAlias(H_Namespace, 'Longint', typeINTEGER); + RegisterTypeAlias(H_Namespace, 'THandle', typeCARDINAL); + RegisterTypeAlias(H_Namespace, 'LongWord', typeCARDINAL); + RegisterTypeAlias(H_Namespace, 'HRESULT', typeINTEGER); + RegisterTypeAlias(H_Namespace, 'HMODULE', typeINTEGER); + + H_PInteger := RegisterPointerType(H_Namespace, 'PInteger', typeINTEGER); + H_PSmallInt := RegisterPointerType(H_Namespace, 'PSmallInt', typeSMALLINT); + H_PShortInt := RegisterPointerType(H_Namespace, 'PShortInt', typeSHORTINT); + H_PCardinal := RegisterPointerType(H_Namespace, 'PCardinal', typeCARDINAL); + H_PWord := RegisterPointerType(H_Namespace, 'PWord', typeWORD); + H_PByte := RegisterPointerType(H_Namespace, 'PByte', typeBYTE); + H_PInt64 := RegisterPointerType(H_Namespace, 'PInt64', typeINT64); + H_PSingle := RegisterPointerType(H_Namespace, 'PSingle', typeSINGLE); + H_PDouble := RegisterPointerType(H_Namespace, 'PDouble', typeDOUBLE); + H_PExtended := RegisterPointerType(H_Namespace, 'PExtended', typeEXTENDED); + H_PCurrency := RegisterPointerType(H_Namespace, 'PCurrency', typeCURRENCY); + H_PVariant := RegisterPointerType(H_Namespace, 'PVariant', typeVARIANT); + H_PPointer := RegisterPointerType(H_Namespace, 'PPointer', typePOINTER); + H_PBoolean := RegisterPointerType(H_Namespace, 'PBoolean', typeBOOLEAN); + H_PWideChar := typePWIDECHAR; +{$IFNDEF PAXARM} + H_PAnsiChar := typePANSICHAR; + H_PShortString := RegisterPointerType(0, 'PShortString', typeSHORTSTRING); + H_PAnsiString := RegisterPointerType(0, 'PAnsiString', typeANSISTRING); + H_PWideString := RegisterPointerType(0, 'PWideString', typeWIDESTRING); +{$ENDIF} + H_PUnicString := RegisterPointerType(0, 'PUnicString', typeUNICSTRING); + +{$IFDEF UNIC} + H_PString := H_PUnicString; +{$ELSE} + H_PString := H_PAnsiString; +{$ENDIF} + + RegisterTypeAlias(H_Namespace, 'PLongint', H_PINTEGER); + RegisterTypeAlias(H_Namespace, 'PLongWord', H_PCARDINAL); + RegisterTypeAlias(H_Namespace, 'PDate', H_PDOUBLE); +{$IFNDEF PAXARM} + RegisterTypeAlias(H_Namespace, 'PAnsiChar', typePANSICHAR); +{$ENDIF} + + H_PPInteger := RegisterPointerType(H_Namespace, 'PPInteger', H_PINTEGER); + H_PPSmallInt := RegisterPointerType(H_Namespace, 'PPSmallInt', H_PSMALLINT); + H_PPShortInt := RegisterPointerType(H_Namespace, 'PPShortInt', H_PSHORTINT); + H_PPCardinal := RegisterPointerType(H_Namespace, 'PPCardinal', H_PCARDINAL); + H_PPWord := RegisterPointerType(H_Namespace, 'PPWord', H_PWORD); + H_PPByte := RegisterPointerType(H_Namespace, 'PPByte', H_PBYTE); + H_PPInt64 := RegisterPointerType(H_Namespace, 'PPInt64', H_PINT64); + H_PPSingle := RegisterPointerType(H_Namespace, 'PPSingle', H_PSINGLE); + H_PPDouble := RegisterPointerType(H_Namespace, 'PPDouble', H_PDOUBLE); + H_PPExtended := RegisterPointerType(H_Namespace, 'PPExtended', H_PEXTENDED); + H_PPCurrency := RegisterPointerType(H_Namespace, 'PPCurrency', H_PCURRENCY); + H_PPVariant := RegisterPointerType(H_Namespace, 'PPVariant', H_PVARIANT); + H_PPPointer := RegisterPointerType(H_Namespace, 'PPPointer', H_PPOINTER); + H_PPBoolean := RegisterPointerType(H_Namespace, 'PPBoolean', H_PBOOLEAN); + H_PPWideChar := RegisterPointerType(H_Namespace, 'PPWideChar', H_PWIDECHAR); +{$IFNDEF PAXARM} + H_PPAnsiChar := RegisterPointerType(H_Namespace, 'PPAnsiChar', H_PANSICHAR); + H_PPShortString := RegisterPointerType(0, 'PPShortString', H_PSHORTSTRING); + H_PPAnsiString := RegisterPointerType(0, 'PPAnsiString', H_PANSISTRING); + H_PPWideString := RegisterPointerType(0, 'PPWideString', H_PWIDESTRING); +{$ENDIF} + H_PPUnicString := RegisterPointerType(0, 'PPUnicString', H_PUNICSTRING); + + H_R0_7 := RegisterSubrangeType(0, '%0-7', typeINTEGER, 0, 7); + H_TGUID_D4 := RegisterArrayType(0, '%TGUID_D4', H_R0_7, typeBYTE, 1); + + H_TGUID := RegisterRecordType(0, 'TGUID', 1); + RegisterTypeField(H_TGUID, 'D1', typeCARDINAL); + RegisterTypeField(H_TGUID, 'D2', typeWORD); + RegisterTypeField(H_TGUID, 'D3', typeWORD); + + RegisterTypeField(H_TGUID, 'D4', H_TGUID_D4); + + H_PGUID := RegisterPointerType(0, 'PGUID', H_TGUID); + + H_IUnknown := RegisterInterfaceType(0, 'IUnknown', IUnknown); + RegisterHeader(H_IUnknown, 'function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;', nil, 1); + H_QueryInterface := LastSubId; + RegisterHeader(H_IUnknown, 'function _AddRef: Integer; stdcall;', nil, 2); + H_AddRef := LastSubId; + RegisterHeader(H_IUnknown, 'function _Release: Integer; stdcall;', nil, 3); + H_Release := LastSubId; + + RegisterTypeAlias(0, 'IInterface', H_IUNKNOWN); + + H_IDispatch := RegisterInterfaceType(0, 'IDispatch', IDispatch); + RegisterHeader(H_IDispatch, + 'function GetTypeInfoCount(out Count: Integer): HResult; stdcall;', nil, 4); + RegisterHeader(H_IDispatch, + 'function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall;', nil, 5); + RegisterHeader(H_IDispatch, + 'function GetIDsOfNames(const IID: TGUID; Names: Pointer;' + + 'NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall;', nil, 6); + RegisterHeader(H_IDispatch, + 'function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;' + + 'Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall;', nil, 7); + +// TObject + + H_TObject := RegisterClassType(0, TObject); + H_TClass := RegisterClassReferenceType(0, 'TClass', H_TObject); + + RegisterConstructor(H_TObject, 'Create', @TObject.Create); + + RegisterDestructor(H_TObject, 'Destroy', @TMyObject.Destroy); + Id_TObject_Destroy := LastSubId; + + RegisterMethod(H_TObject, 'Free', typeVOID, ccREGISTER, @TObject.Free); + Id_TObject_Free := LastSubId; + +{$IFDEF PAXARM} + RegisterMethod(H_TObject, 'ClassName', typeSTRING, ccSTDCALL, @TObject_ClassName); + Id_TObject_ClassName := LastSubId; +{$ELSE} + RegisterMethod(H_TObject, 'ClassName', typeSHORTSTRING, ccSTDCALL, + @TObject_ClassName); + Id_TObject_ClassName := LastSubId; +{$ENDIF} + + RegisterMethod(H_TObject, 'ClassType', H_TClass, ccREGISTER, + @TObject.ClassType); + RegisterMethod(H_TObject, 'ClassParent', H_TClass, ccREGISTER, + @TObject.ClassParent, true); + RegisterMethod(H_TObject, 'InstanceSize', typeINTEGER, ccREGISTER, + @TObject.InstanceSize, true); + + RegisterHeader(H_TObject, 'function SafeCallException(ExceptObject: TObject; ExceptAddr: Pointer): HResult; virtual;', + @TObject.SafeCallException); + RegisterHeader(H_TObject, 'procedure AfterConstruction; virtual;', + @TObject.AfterConstruction); + RegisterHeader(H_TObject, 'procedure BeforeDestruction; virtual;', + @TObject.BeforeDestruction); + RegisterHeader(H_TObject, 'procedure Dispatch(var Message); virtual;', + @TObject.Dispatch); + RegisterHeader(H_TObject, 'procedure DefaultHandler(var Message); virtual;', + @TObject.DefaultHandler); + RegisterHeader(H_TObject, 'class function NewInstance: TObject; virtual;', + @TObject.NewInstance); + RegisterHeader(H_TObject, 'procedure FreeInstance; virtual;', + @TObject.FreeInstance); + + {$ifdef UNIC} + RegisterHeader(H_TObject, 'function ToString: String; virtual;', + @TObject.ToString); + RegisterHeader(H_TObject, 'function Equals(Obj: TObject): Boolean; virtual;', + @TObject.Equals); + RegisterHeader(H_TObject, 'function GetHashCode: Integer; virtual;', + @TObject.GetHashCode); + {$endif} + +{$IFDEF PAXARM} + H_Sub := RegisterMethod(H_TObject, 'FieldAddress', typePOINTER, ccREGISTER, + @TObject.FieldAddress); + RegisterParameter(H_Sub, typeSTRING, Unassigned, false, 'Name'); + + H_Sub := RegisterMethod(H_TObject, 'InheritsFrom', typeBOOLEAN, ccREGISTER, + @TObject.InheritsFrom, true); + RegisterParameter(H_Sub, H_TClass, Unassigned, false, 'AClass'); + + H_Sub := RegisterMethod(H_TObject, 'MethodAddress', typePOINTER, ccREGISTER, + @TObject.MethodAddress, true); + RegisterParameter(H_Sub, typeSTRING, Unassigned, false, 'Name'); + + H_Sub := RegisterMethod(H_TObject, 'MethodName', typeSTRING, ccREGISTER, + @TObject.MethodName, true); + RegisterParameter(H_Sub, typePOINTER, Unassigned, false, 'Address'); +{$ELSE} + H_Sub := RegisterMethod(H_TObject, 'FieldAddress', typePOINTER, ccREGISTER, + @TObject.FieldAddress); + RegisterParameter(H_Sub, typeSHORTSTRING, Unassigned, false, 'Name'); + + H_Sub := RegisterMethod(H_TObject, 'InheritsFrom', typeBOOLEAN, ccREGISTER, + @TObject.InheritsFrom, true); + RegisterParameter(H_Sub, H_TClass, Unassigned, false, 'AClass'); + + H_Sub := RegisterMethod(H_TObject, 'MethodAddress', typePOINTER, ccREGISTER, + @TObject.MethodAddress, true); + RegisterParameter(H_Sub, typeSHORTSTRING, Unassigned, false, 'Name'); + + H_Sub := RegisterMethod(H_TObject, 'MethodName', typeSHORTSTRING, ccREGISTER, + @TObject.MethodName, true); + RegisterParameter(H_Sub, typePOINTER, Unassigned, false, 'Address'); +{$ENDIF} + RegisterHeader(H_TObject, 'function GetInterface(const IID: TGUID; out Obj): Boolean;', + @ TObject_GetInterface); + Id_TObject_GetInterface := LastSubId; + +// TInterfacedObject + H_TInterfacedObject := RegisterClassType(0, TInterfacedObject); + RegisterSupportedInterface(H_TInterfacedObject, 'IUnknown', IUnknown); + RegisterConstructor(H_TInterfacedObject, 'Create', @TInterfacedObject.Create); + RegisterHeader(H_TInterfacedObject, 'class function NewInstance: TObject; override;', + @TInterfacedObject.NewInstance); + + RegisterHeader(H_TInterfacedObject, 'function __GetRefCount: Integer;', @GetRefCount); + RegisterHeader(H_TInterfacedObject, 'property RefCount: Integer read __GetRefCount;', nil); + + RegisterHeader(H_TInterfacedObject, 'function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;', + @TMyInterfacedObject.QueryInterface); + RegisterHeader(H_TInterfacedObject, 'function _AddRef: Integer; stdcall;', + @TMyInterfacedObject_AddRef); + RegisterHeader(H_TInterfacedObject, 'function _Release: Integer; stdcall;', + @TMyInterfacedObject_Release); + +// TInterfacedClass + RegisterClassReferenceType(0, 'TInterfacedClass', H_TInterfacedObject); + + RegisterConstant(0, 'vtInteger', typeINTEGER, vtInteger); + RegisterConstant(0, 'vtBoolean', typeINTEGER, vtBoolean); + RegisterConstant(0, 'vtChar', typeINTEGER, vtChar); + RegisterConstant(0, 'vtExtended', typeINTEGER, vtExtended); + RegisterConstant(0, 'vtString', typeINTEGER, vtString); + RegisterConstant(0, 'vtPointer', typeINTEGER, vtPointer); + RegisterConstant(0, 'vtPChar', typeINTEGER, vtPChar); + RegisterConstant(0, 'vtObject', typeINTEGER, vtObject); + RegisterConstant(0, 'vtClass', typeINTEGER, vtClass); + RegisterConstant(0, 'vtWideChar', typeINTEGER, vtWideChar); + RegisterConstant(0, 'vtPWideChar', typeINTEGER, vtPWideChar); + RegisterConstant(0, 'vtAnsiString', typeINTEGER, vtAnsiString); + RegisterConstant(0, 'vtCurrency', typeINTEGER, vtCurrency); + RegisterConstant(0, 'vtVariant', typeINTEGER, vtVariant); + RegisterConstant(0, 'vtInterface', typeINTEGER, vtInterface); + RegisterConstant(0, 'vtWideString', typeINTEGER, vtWideString); + RegisterConstant(0, 'vtInt64', typeINTEGER, vtInt64); + + H_TVarRec := RegisterRecordType(0, 'TVarRec', 1); + RegisterTypeField(H_TVarRec, 'VInteger', typeINTEGER, 0); + RegisterTypeField(H_TVarRec, 'VBoolean', typeBOOLEAN, 0); +{$IFNDEF PAXARM} + RegisterTypeField(H_TVarRec, 'VChar', typeANSICHAR, 0); +{$ENDIF} + RegisterTypeField(H_TVarRec, 'VExtended', H_PExtended, 0); + RegisterTypeField(H_TVarRec, 'VString', H_PShortString, 0); + RegisterTypeField(H_TVarRec, 'VPointer', typePOINTER, 0); +{$IFNDEF PAXARM} + RegisterTypeField(H_TVarRec, 'VPChar', typePANSICHAR, 0); +{$ENDIF} + RegisterTypeField(H_TVarRec, 'VObject', H_TObject, 0); + RegisterTypeField(H_TVarRec, 'VClass', H_TClass, 0); + RegisterTypeField(H_TVarRec, 'VWideChar', typeWIDECHAR, 0); + RegisterTypeField(H_TVarRec, 'VAnsiString', H_PSTRING, 0); + RegisterTypeField(H_TVarRec, 'VCurrency', typePOINTER, 0); + RegisterTypeField(H_TVarRec, 'VVariant', H_PVARIANT, 0); + RegisterTypeField(H_TVarRec, 'VInterface', typePOINTER, 0); + RegisterTypeField(H_TVarRec, 'VWideString', typePOINTER, 0); + RegisterTypeField(H_TVarRec, 'VInt64', typePOINTER, 0); + + RegisterTypeField(H_TVarRec, 'VType', typeINTEGER, 4); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @ _AssignTVarRec); + Id_AssignTVarRec := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + + H_Dynarray_TVarRec := RegisterDynamicArrayType(0, 'DYNARRAY_TVarRec', H_TVarRec); + + H_Dynarray_Integer := RegisterDynamicArrayType(0, 'DYNARRAY_Integer', typeINTEGER); + H_Dynarray_Byte := RegisterDynamicArrayType(0, 'DYNARRAY_Byte', typeBYTE); + H_Dynarray_Word := RegisterDynamicArrayType(0, 'DYNARRAY_Word', typeWORD); + H_Dynarray_ShortInt := RegisterDynamicArrayType(0, 'DYNARRAY_ShortInt', typeSHORTINT); + H_Dynarray_SmallInt := RegisterDynamicArrayType(0, 'DYNARRAY_SmallInt', typeSMALLINT); + H_Dynarray_Cardinal := RegisterDynamicArrayType(0, 'DYNARRAY_Cardinal', typeCARDINAL); + H_Dynarray_Int64 := RegisterDynamicArrayType(0, 'DYNARRAY_Int64', typeINT64); + H_Dynarray_UInt64 := RegisterDynamicArrayType(0, 'DYNARRAY_UInt64', typeUINT64); +{$IFNDEF PAXARM} + H_Dynarray_AnsiChar := RegisterDynamicArrayType(0, 'DYNARRAY_AnsiChar', typeANSICHAR); + H_Dynarray_WideChar := RegisterDynamicArrayType(0, 'DYNARRAY_WideChar', typeWIDECHAR); + H_Dynarray_AnsiString := RegisterDynamicArrayType(0, 'DYNARRAY_AnsiString', typeANSISTRING); + H_Dynarray_WideString := RegisterDynamicArrayType(0, 'DYNARRAY_WideString', typeWIDESTRING); + H_Dynarray_ShortString := RegisterDynamicArrayType(0, 'DYNARRAY_ShortString', typeSHORTSTRING); +{$ENDIF} + H_Dynarray_UnicodeString := RegisterDynamicArrayType(0, 'DYNARRAY_UnicodeString', typeUNICSTRING); + H_Dynarray_Double := RegisterDynamicArrayType(0, 'DYNARRAY_Double', typeDOUBLE); + H_Dynarray_Single := RegisterDynamicArrayType(0, 'DYNARRAY_Single', typeSINGLE); + H_Dynarray_Extended := RegisterDynamicArrayType(0, 'DYNARRAY_Extended', typeEXTENDED); + H_Dynarray_Currency := RegisterDynamicArrayType(0, 'DYNARRAY_Currency', typeCURRENCY); + H_Dynarray_Boolean := RegisterDynamicArrayType(0, 'DYNARRAY_Boolean', typeBOOLEAN); + H_Dynarray_ByteBool := RegisterDynamicArrayType(0, 'DYNARRAY_ByteBool', typeBYTEBOOL); + H_Dynarray_WordBool := RegisterDynamicArrayType(0, 'DYNARRAY_WordBool', typeWORDBOOL); + H_Dynarray_LongBool := RegisterDynamicArrayType(0, 'DYNARRAY_LongBool', typeLONGBOOL); + H_Dynarray_Variant := RegisterDynamicArrayType(0, 'DYNARRAY_Variant', typeVARIANT); + H_Dynarray_OleVariant := RegisterDynamicArrayType(0, 'DYNARRAY_OleVariant', typeOLEVARIANT); + H_Dynarray_Pointer := RegisterDynamicArrayType(0, 'DYNARRAY_Pointer', typePOINTER); + + RegisterConstant(0, 'Null', typeVARIANT, Null); + H_Unassigned := RegisterConstant(0, strUnassigned, typeVARIANT, Unassigned); + + RegisterConstant(0, 'MaxInt', typeINTEGER, MaxInt); + RegisterConstant(0, 'MaxLongint', typeINTEGER, MaxInt); + + H_TMethod := RegisterRecordType(0, 'TMethod', 1); + RegisterTypeField(H_TMethod, 'Code', typePOINTER, 0); + RegisterTypeField(H_TMethod, 'Data', typePOINTER, 4); + +// RegisterClassType(0, TPersistent); +// RegisterClassType(0, TComponent); + + + RegisterTypeAlias(H_Namespace, 'TVarType', typeWORD); +{$IFNDEF PAXARM} + RegisterPointerType(H_Namespace, 'PWideString', typeWIDESTRING); + RegisterTypeAlias(0, 'DWORD', typeCARDINAL); + RegisterTypeAlias(0, 'AnsiString', typeANSISTRING); + RegisterTypeAlias(0, 'AnsiChar', typeANSICHAR); +{$ENDIF} + RegisterConstant (H_Namespace, 'MaxLongInt', typeINTEGER, MaxLongInt); + RegisterTypeAlias (H_Namespace, 'IInvokable', H_IUNKNOWN); + H_Sub := RegisterRecordType (H_Namespace, 'TDispatchMessage', 8); + RegisterTypeField(H_Sub, 'MsgID', typeWORD, 0); +{$IFNDEF PAXARM} + RegisterPointerType (H_Namespace, 'PAnsiString', typeANSISTRING); + H := RegisterTypeAlias (H_Namespace, 'UCS2Char', typeWIDECHAR); + RegisterPointerType (H_Namespace, 'PUCS2Char', H); + H := RegisterTypeAlias (H_Namespace, 'UCS4Char', typeINTEGER); // typeLONGWORD + RegisterPointerType (H_Namespace, 'PUCS4Char', H); + H_Sub := RegisterArrayType (H_Namespace, 'TUCS4CharArray', + RegisterSubrangeType (0, '%TUCS4CharArray', typeINTEGER, 0, $effffff), + H, + 8 + ); + RegisterPointerType (H_Namespace, 'PUCS4CharArray', H_Sub); + RegisterDynamicArrayType (H_Namespace, 'UCS4String', H); + H_Sub := RegisterTypeAlias (H_Namespace, 'UTF8String', typeANSISTRING); + RegisterPointerType (H_Namespace, 'PUTF8String', H_Sub); + H_Sub := RegisterArrayType (H_Namespace, 'IntegerArray', + RegisterSubrangeType (0, '%IntegerArray', typeINTEGER, 0, $effffff), + typeINTEGER, + 8 + ); + RegisterPointerType (H_Namespace, 'PIntegerArray', H_Sub); + H_Sub := RegisterArrayType (H_Namespace, 'PointerArray', + RegisterSubRangeType (0, '%PointerArray', typeINTEGER, 0, 512*1024*1024 - 2), + typePOINTER, + 8 + ); + RegisterPointerType (H_Namespace, 'PPointerArray', H_Sub); + RegisterDynamicArrayType (H_Namespace, 'TBoundArray', typeINTEGER); + H_Sub := RegisterArrayType (H_Namespace, 'TPCharArray', + RegisterSubRangeType (0, '%TPCharArray', typeINTEGER, 0, (MaxLongint div SizeOf(PChar))-1), + typePANSICHAR, + 1 + ); + RegisterPointerType (H_Namespace, 'PPCharArray', H_Sub); +{$ENDIF} + RegisterPointerType (H_Namespace, 'PSmallInt', typeSMALLINT); + RegisterPointerType (H_Namespace, 'PShortInt', typeSHORTINT); + H := RegisterPointerType (H_Namespace, 'PDispatch', H_IDispatch); + RegisterPointerType (H_Namespace, 'PPDispatch', H); + RegisterPointerType (H_Namespace, 'PError', typeINTEGER); //typeLONGWORD + RegisterPointerType (H_Namespace, 'PWordBool', typeWORDBOOL); + H := RegisterPointerType (H_Namespace, 'PUnknown', H_IUnknown); + RegisterPointerType (H_Namespace, 'PPUnknown', H); + RegisterPointerType (H_Namespace, 'POleVariant', typeOLEVARIANT); + RegisterPointerType (H_Namespace, 'PDateTime', typeDOUBLE); + H_Sub := RegisterRecordType (H_Namespace, 'TVarArrayBound', 1); + RegisterTypeField (H_Sub, 'ElementCount', typeINTEGER); + RegisterTypeField (H_Sub, 'LowBound', typeINTEGER); + H_Sub := RegisterArrayType (H_Namespace, 'TVarArrayBoundArray', + RegisterSubRangeType (H_Namespace, '%TVarArrayBoundArray', typeBYTE, H_Namespace, H_Namespace), + H_Sub, + 8 + ); + RegisterPointerType (H_Namespace, 'PVarArrayBoundArray', H_Sub); + H := RegisterArrayType (H_Namespace, 'TVarArrayCoorArray', + RegisterSubRangeType (H_Namespace, '%TVarArrayCoorArray', typeBYTE, H_Namespace, H_Namespace), + typeINTEGER, + 8 + ); + RegisterPointerType (H_Namespace, 'PVarArrayCoorArray', H); + + H := RegisterRecordType (H_Namespace, 'TVarArray', 1); + RegisterTypeField (H, 'DimCount', typeWORD); + RegisterTypeField (H, 'Flags', typeWORD); + RegisterTypeField (H, 'ElementSize', typeINTEGER); + RegisterTypeField (H, 'LockCount', typeINTEGER); + RegisterTypeField (H, 'Data', typePOINTER); + RegisterTypeField (H, 'Bounds', H_Sub); + RegisterPointerType (0, 'PVarArray', H); + H_Sub := RegisterRecordType(0, 'TVarData', 1); + RegisterVariantRecordTypeField(H_Sub, 'VType: TVarType', 01); + RegisterVariantRecordTypeField(H_Sub, 'Reserved1: Word', 0101); + RegisterVariantRecordTypeField(H_Sub, 'Reserved2: Word', 010101); + RegisterVariantRecordTypeField(H_Sub, 'Reserved3: Word', 010101); + RegisterVariantRecordTypeField(H_Sub, 'VSmallInt: SmallInt', 01010101); + RegisterVariantRecordTypeField(H_Sub, 'VInteger: Integer', 02010101); + RegisterVariantRecordTypeField(H_Sub, 'VSingle: Single', 03010101); + RegisterVariantRecordTypeField(H_Sub, 'VDouble: Double', 04010101); + RegisterVariantRecordTypeField(H_Sub, 'VCurrency: Currency', 05010101); + RegisterVariantRecordTypeField(H_Sub, 'VDate: TDateTime', 06010101); + RegisterVariantRecordTypeField(H_Sub, 'VOleStr: PWideChar', 07010101); + RegisterVariantRecordTypeField(H_Sub, 'VDispatch: Pointer', 08010101); + RegisterVariantRecordTypeField(H_Sub, 'VError: HRESULT', 09010101); + RegisterVariantRecordTypeField(H_Sub, 'VBoolean: WordBool', 10010101); + RegisterVariantRecordTypeField(H_Sub, 'VUnknown: Pointer', 11010101); + RegisterVariantRecordTypeField(H_Sub, 'VShortInt: ShortInt', 12010101); + RegisterVariantRecordTypeField(H_Sub, 'VByte: Byte', 13010101); + RegisterVariantRecordTypeField(H_Sub, 'VWord: Word', 14010101); + RegisterVariantRecordTypeField(H_Sub, 'VLongWord: LongWord', 15010101); + RegisterVariantRecordTypeField(H_Sub, 'VInt64: Int64', 16010101); + RegisterVariantRecordTypeField(H_Sub, 'VString: Pointer', 17010101); + RegisterVariantRecordTypeField(H_Sub, 'VAny: Pointer', 18010101); + RegisterVariantRecordTypeField(H_Sub, 'VArray: Pointer', 19010101); + RegisterVariantRecordTypeField(H_Sub, 'VPointer: Pointer', 20010101); + RegisterPointerType (H_Namespace, 'PVarData', H_Sub); + RegisterTypeAlias (H_Namespace, 'TVarOp', typeINTEGER); + H_Sub := RegisterRecordType (H_Namespace, 'TCallDesc', 1); + RegisterTypeField (H_Sub, 'CallType', typeBYTE); + RegisterTypeField (H_Sub, 'ArgCount', typeBYTE); + RegisterTypeField (H_Sub, 'NamedArgCount', typeBYTE); + H := RegisterDynamicArrayType (0, '%ArgTypes', + RegisterSubRangeType (0, '%%ArgTypes', typeINTEGER, 0, 255) + ); + RegisterTypeField (H_Sub, 'ArgTypes', H); + RegisterPointerType (H_Namespace, 'PCallDesc', H_Sub); + + H := RegisterRecordType (H_Namespace, 'TDispDesc', 1); + RegisterTypeField (H, 'DispID', typeINTEGER); + RegisterTypeField (H, 'ResType', typeBYTE); + RegisterTypeField (H, 'CallDesc', H_Sub); + RegisterPointerType (H_Namespace, 'PDispDesc', H); + + { + TDynArrayTypeInfo + PDynArrayTypeInfo + } + RegisterPointerType (H_Namespace, 'PVarRec', H_TVarRec); + H := RegisterEnumType (H_Namespace, 'TTextLineBreakStyle', typeINTEGER); + RegisterEnumValue (H, 'tlbsLF', H_Namespace); + RegisterEnumValue (H, 'tlbsCRLF', 1); + H := RegisterTypeAlias (H_Namespace, 'HRSRC', typeCARDINAL); // THandle + RegisterTypeAlias (H_Namespace, 'TResourceHandle', H); + H := RegisterTypeAlias (H_Namespace, 'HINST', typeCARDINAL); // THandle + RegisterTypeAlias (H_Namespace, 'HGLOBAL', H); + H := RegisterPointerType(H_Namespace, 'PCardinal', typeCARDINAL); // redefined + H_Sub := RegisterRecordType (H_Namespace, 'TResStringRec', 1); + RegisterTypeField (H_Sub, 'Module', H); + RegisterTypeField (H_Sub, 'Identifier', typeINTEGER); + RegisterPointerType (H_Namespace, 'PResStringRec', H_Sub); + + H := RegisterRoutine (H_Namespace, '%TThreadFunc', typeINTEGER, ccREGISTER, Nil); + RegisterParameter (H, typePOINTER, Unassigned); + H_Sub := RegisterProceduralType (H_Namespace, 'TThreadFunc', H); + H := RegisterRoutine (H_Namespace, 'BeginThread', typeINTEGER, ccREGISTER, @BeginThread); + RegisterParameter (H, typePointer, Unassigned); // SecurityAttributes: Pointer; + RegisterParameter (H, typeCARDINAL, Unassigned); // StackSize: LongWord; + RegisterParameter (H, H_Sub, Unassigned); //ThreadFunc: TThreadFunc; + RegisterParameter (H, typePOINTER, Unassigned); //Parameter: Pointer; + RegisterParameter (H, typeCARDINAL, Unassigned); //CreationFlags: LongWord; + RegisterParameter (H, typeCARDINAL, Unassigned, ByRef); // var ThreadId: LongWord + H := RegisterRoutine (H_Namespace, 'EndThread', typeVOID, ccREGISTER, @EndThread); + RegisterParameter (H, typeINTEGER, Unassigned); // EndThread(ExitCode: Integer); + + { + H_Sub := RegisterClass (H_Namespace, TAggregatedObject); + H_Sub := RegisterClass (H_Namespace, TContainedObject); + } + + RegisterConstant(H_Namespace, 'varEmpty', varEmpty); + RegisterConstant(H_Namespace, 'varNull', varNull); + RegisterConstant(H_Namespace, 'varSmallint', varSmallint); + RegisterConstant(H_Namespace, 'varInteger', varInteger); + RegisterConstant(H_Namespace, 'varSingle', varSingle); + RegisterConstant(H_Namespace, 'varDouble', varDouble); + RegisterConstant(H_Namespace, 'varCurrency', varCurrency); + RegisterConstant(H_Namespace, 'varDate', varDate); + RegisterConstant(H_Namespace, 'varOleStr', varOleStr); + RegisterConstant(H_Namespace, 'varDispatch', varDispatch); + RegisterConstant(H_Namespace, 'varError', varError); + RegisterConstant(H_Namespace, 'varBoolean', varBoolean); + RegisterConstant(H_Namespace, 'varVariant', varVariant); + RegisterConstant(H_Namespace, 'varUnknown', varUnknown); +{$IFDEF VARIANTS} + RegisterConstant(H_Namespace, 'varShortInt', varShortInt); +{$ENDIF} + RegisterConstant(H_Namespace, 'varByte', varByte); +{$IFDEF VARIANTS} + RegisterConstant(H_Namespace, 'varWord', varWord); + RegisterConstant(H_Namespace, 'varLongWord', varLongWord); + RegisterConstant(H_Namespace, 'varInt64', varInt64); + RegisterConstant(H_Namespace, 'varUInt64', $0015); +{$ENDIF} + RegisterConstant(H_Namespace, 'varStrArg', varStrArg); + RegisterConstant(H_Namespace, 'varString', varString); + RegisterConstant(H_Namespace, 'varAny', varAny); + RegisterConstant(H_Namespace, 'varTypeMask', varTypeMask); + RegisterConstant(H_Namespace, 'varArray', varArray); + RegisterConstant(H_Namespace, 'varByRef', varByRef); +{$IFDEF UNIC} + RegisterConstant(H_Namespace, 'varUString', varUString); +{$ENDIF} + + H := RegisterRecordType (H_Namespace, 'TInterfaceEntry', 1); + RegisterTypeField(H, 'IID', H_TGUID); + RegisterTypeField(H, 'VTable', typePOINTER); + RegisterTypeField(H, 'IOffset', typeINTEGER); + RegisterTypeField(H, 'ImplGetter', typeINTEGER); + RegisterPointerType(H_Namespace, 'PInterfaceEntry', H); + + H_TEntries := RegisterArrayType(0, '', + RegisterSubrangeType(0, '', typeINTEGER, 0, 9999), H, 1); + + H := RegisterRecordType (H_Namespace, 'TInterfaceTable', 1); + RegisterTypeField(H, 'EntryCount', typeINTEGER); + RegisterTypeField(H, 'Entries', H_TEntries); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccREGISTER, @_WriteUnicString); + Id_WriteUnicString := LastSubId; + RegisterParameter(H_Sub, typeUNICSTRING, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + H_WriteUnicString := H_Sub; + +{$IFNDEF PAXARM} + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_UnicStringFromPAnsiChar); + Id_UnicStringFromPAnsiChar := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_UnicStringFromAnsiChar); + Id_UnicStringFromAnsiChar := LastSubId; + RegisterParameter(H_Sub, typeANSICHAR, Unassigned); + RegisterParameter(H_Sub, typeUNICSTRING, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_ShortStringFromUnicString); + Id_ShortStringFromUnicString := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_UnicStringFromShortString); + Id_UnicStringFromShortString := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_AnsiStringFromUnicString); + Id_AnsiStringFromUnicString := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_UnicStringFromAnsiString); + Id_UnicStringFromAnsiString := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_WideStringFromUnicString); + Id_WideStringFromUnicString := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_UnicStringFromWideString); + Id_UnicStringFromWideString := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); +{$ENDIF} + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_UnicStringFromPWideChar); + Id_UnicStringFromPWideChar := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @ _UnicStringFromWideChar); + Id_UnicStringFromWideChar := LastSubId; + RegisterParameter(H_Sub, typeWIDECHAR, Unassigned); + RegisterParameter(H_Sub, typeUNICSTRING, Unassigned, ByRef); + + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_VariantFromUnicString); + Id_VariantFromUnicString := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_UnicStringFromVariant); + Id_UnicStringFromVariant := LastSubId; + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeUNICSTRING, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_OleVariantFromUnicString); + Id_OleVariantFromUnicString := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_UnicStringAddition); + Id_UnicStringAddition := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_UnicStringAssign); + Id_UnicStringAssign := LastSubId; + RegisterParameter(H_Sub, typeUNICSTRING, Unassigned, ByRef); + RegisterParameter(H_Sub, typeUNICSTRING, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_UnicStringEquality); + Id_UnicStringEquality := LastSubId; + RegisterParameter(H_Sub, typeUNICSTRING, Unassigned, ByRef); + RegisterParameter(H_Sub, typeUNICSTRING, Unassigned, ByRef); + RegisterParameter(H_Sub, typeBOOLEAN, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_UnicStringNotEquality); + Id_UnicStringNotEquality := LastSubId; + RegisterParameter(H_Sub, typeUNICSTRING, Unassigned, ByRef); + RegisterParameter(H_Sub, typeUNICSTRING, Unassigned, ByRef); + RegisterParameter(H_Sub, typeBOOLEAN, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @ _UnicStringGreaterThan); + Id_UnicStringGreaterThan := LastSubId; + RegisterParameter(H_Sub, typeUNICSTRING, Unassigned, ByRef); + RegisterParameter(H_Sub, typeUNICSTRING, Unassigned, ByRef); + RegisterParameter(H_Sub, typeBOOLEAN, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_UnicStringGreaterThanOrEqual); + Id_UnicStringGreaterThanOrEqual := LastSubId; + RegisterParameter(H_Sub, typeUNICSTRING, Unassigned, ByRef); + RegisterParameter(H_Sub, typeUNICSTRING, Unassigned, ByRef); + RegisterParameter(H_Sub, typeBOOLEAN, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_UnicStringLessThan); + Id_UnicStringLessThan := LastSubId; + RegisterParameter(H_Sub, typeUNICSTRING, Unassigned, ByRef); + RegisterParameter(H_Sub, typeUNICSTRING, Unassigned, ByRef); + RegisterParameter(H_Sub, typeBOOLEAN, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_UnicStringLessThanOrEqual); + Id_UnicStringLessThanOrEqual := LastSubId; + RegisterParameter(H_Sub, typeUNICSTRING, Unassigned, ByRef); + RegisterParameter(H_Sub, typeUNICSTRING, Unassigned, ByRef); + RegisterParameter(H_Sub, typeBOOLEAN, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_UnicStringClr); + Id_UnicStringClr := LastSubId; + RegisterParameter(H_Sub, typeUNICSTRING, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_StringAddRef); + Id_UnicStringAddRef := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_SetUnicStringLength); + Id_SetUnicStringLength := LastSubId; + RegisterParameter(H_Sub, typeUNICSTRING, Unassigned, ByRef); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_VariantFromPWideChar); + Id_VariantFromPWideChar := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_OleVariantFromPWideChar); + Id_OleVariantFromPWideChar := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_GetUnicStrProp); + Id_GetUnicStrProp := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_SetUnicStrProp); + Id_SetUnicStrProp := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + +{$IFNDEF PAXARM} + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @ _AnsiStringFromPWideChar); + Id_AnsiStringFromPWideChar := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_ShortStringFromPWideChar); + Id_ShortStringFromPWideChar := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); +{$ENDIF} + +{$IFDEF UNIC} + // Length, Pos, Copy, Insert, Delete + + H_Sub := RegisterRoutine(H_Namespace, 'Length', typeINTEGER, ccREGISTER, + @_UnicLength); + RegisterParameter(H_Sub, typeUNICSTRING, Unassigned, false, 'S'); + + H_Sub := RegisterRoutine(H_Namespace, 'Delete', typeVOID, ccREGISTER, + @_UnicDelete); + RegisterParameter(H_Sub, typeUNICSTRING, Unassigned, ByRef, 'S'); + RegisterParameter(H_Sub, typeINTEGER, Unassigned, false, 'Index'); + RegisterParameter(H_Sub, typeINTEGER, Unassigned, false, 'Count'); + + H_Sub := RegisterRoutine(H_Namespace, 'Insert', typeVOID, ccREGISTER, + @_UnicInsert); + RegisterParameter(H_Sub, typeUNICSTRING, Unassigned, false, 'Substr'); + RegisterParameter(H_Sub, typeUNICSTRING, Unassigned, ByRef, 'Dest'); + RegisterParameter(H_Sub, typeINTEGER, Unassigned, false, 'Index'); + + H_Sub := RegisterRoutine(H_Namespace, 'Val', typeVOID, ccREGISTER, + @_UnicValInt); + RegisterParameter(H_Sub, typeUNICSTRING, Unassigned, false, 'S'); + RegisterParameter(H_Sub, typeINTEGER, Unassigned, ByRef, 'V'); + RegisterParameter(H_Sub, typeINTEGER, Unassigned, ByRef, 'Code'); + + H_Sub := RegisterRoutine(H_Namespace, 'Val', typeVOID, ccREGISTER, + @_UnicValDouble); + RegisterParameter(H_Sub, typeUNICSTRING, Unassigned, false, 'X'); + RegisterParameter(H_Sub, typeDOUBLE, Unassigned, ByRef, 'V'); + RegisterParameter(H_Sub, typeINTEGER, Unassigned, ByRef, 'Code'); + + H_Sub := RegisterRoutine(H_Namespace, 'Copy', typeUNICSTRING, ccREGISTER, + @_UnicCopy); + RegisterParameter(H_Sub, typeUNICSTRING, Unassigned, false, 'S'); + RegisterParameter(H_Sub, typeINTEGER, Unassigned, false, 'Index'); + RegisterParameter(H_Sub, typeINTEGER, Unassigned, false, 'Count'); + + H_Sub := RegisterRoutine(H_Namespace, 'Pos', typeINTEGER, ccREGISTER, + @_UnicPos); + RegisterParameter(H_Sub, typeUNICSTRING, Unassigned, false, 'Substr'); + RegisterParameter(H_Sub, typeUNICSTRING, Unassigned, false, 'Str'); + +{$ENDIF} //unic + + ID_Prog := RegisterClassType(0, TBaseRunner); + RegisterHeader(ID_Prog, 'procedure __Set_ExitCode(value: Integer); stdcall;', + @Set_ExitCode); + RegisterHeader(ID_Prog, 'function __Get_ExitCode: Integer; stdcall;', + @Get_ExitCode); + RegisterHeader(ID_Prog, 'property ExitCode: Integer read __Get_ExitCode write __Set_ExitCode;', nil); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @ _StructEquality); + Id_StructEquality := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @ _StructNotEquality); + Id_StructNotEquality := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + Register_TYPEINFO(H_Namespace, st); + + RegisterRoutine(0, '', typeVOID, ccSTDCALL, Address_LoadSeg); + Id_LoadSeg := LastSubId; + + RegisterRoutine(0, '', typeVOID, ccSTDCALL, @ _LoadClassRef); + Id_LoadClassRef := LastSubId; + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_SetVariantLength2); + Id_SetVariantLength2 := LastSubId; + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_SetVariantLength3); + Id_SetVariantLength3 := LastSubId; + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_LockVArray); + Id_LockVArray := LastSubId; + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + RegisterParameter(H_Sub, typePOINTER, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_UnlockVArray); + Id_UnlockVArray := LastSubId; + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_DynarraySetLength2); + Id_DynarraySetLength2 := LastSubId; + RegisterParameter(H_Sub, typeDYNARRAY, Unassigned, ByRef); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_DynarraySetLength3); + Id_DynarraySetLength3 := LastSubId; + RegisterParameter(H_Sub, typeDYNARRAY, Unassigned, ByRef); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + + H := RegisterRecordType(0, 'TMsg', 1); + RegisterTypeField(H, 'hwnd', typeCARDINAL); + RegisterTypeField(H, 'message', typeCARDINAL); + RegisterTypeField(H, 'wParam', typeINTEGER); + RegisterTypeField(H, 'lParam', typeINTEGER); + RegisterTypeField(H, 'time', typeCARDINAL); + RegisterTypeField(H, 'pt', H_TPOINT); + + RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_GetDynamicMethodAddress); + Id_GetDynamicMethodAddress := LastSubId; + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_AddMessage); + Id_AddMessage := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + if Assigned(RegisterSEH) then + RegisterSEH(st); + + Register_StdJavaScript(st); + Register_StdBasic(st); + Register_Framework(st); + + if Assigned(Import_TValue) then + Import_TValue(0, st); +{$IFNDEF PAXARM} + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_UniqueAnsiString); + Id_UniqueAnsiString := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); +{$ENDIF} + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_UniqueUnicString); + Id_UniqueUnicString := LastSubId; + RegisterParameter(H_Sub, typePOINTER, Unassigned); + + H_Sub := RegisterRoutine(0, '', typeVOID, ccSTDCALL, @_GetComponent); + Id_GetComponent := LastSubId; + RegisterParameter(H_Sub, typeCLASS, Unassigned); + RegisterParameter(H_Sub, typeINTEGER, Unassigned); + RegisterParameter(H_Sub, typeCLASS, Unassigned, ByRef); + + H_DYN_VAR := RegisterDynamicArrayType(0, '#DYN_VAR', typeVARIANT); + + H_SUB := RegisterRoutine(0, '#CallVirt', typeVOID, ccSTDCALL, @_CallVirt); + Records[LastSubId].PushProgRequired := true; + Id_CallVirt := LastSubId; + + RegisterParameter(H_Sub, typePCHAR, Unassigned, false, 'Obj'); + RegisterParameter(H_Sub, typePCHAR, Unassigned, false, 'Prop'); + RegisterParameter(H_Sub, H_DYN_VAR, Unassigned, false, 'A'); + Records[Card].IsOpenArray := true; + RegisterParameter(H_Sub, typeVARIANT, Unassigned, ByRef, 'Res'); + + H_SUB := RegisterRoutine(0, '#PutVirt', typeVOID, ccSTDCALL, @_PutVirt); + Records[LastSubId].PushProgRequired := true; + Id_PutVirt := LastSubId; + + RegisterParameter(H_Sub, typePCHAR, Unassigned, false, 'Obj'); + RegisterParameter(H_Sub, typePCHAR, Unassigned, false, 'Prop'); + RegisterParameter(H_Sub, H_DYN_VAR, Unassigned, false, 'A'); + Records[Card].IsOpenArray := true; + RegisterParameter(H_Sub, typeVARIANT, Unassigned, false, 'value'); + Records[Card].IsConst := true; + + H_SUB := RegisterRoutine(0, 'FreeAndNil', typeVOID, ccREGISTER, @ FreeAndNil); + RegisterParameter(H_SUB, typePVOID, Unassigned, true, 'X'); + + if SizeOf(Pointer) = SizeOf(Integer) then + typeNATIVEINT := typeINTEGER + else + typeNATIVEINT := typeINT64; +{$IFNDEF PAXARM} + T1 := RegisterArrayType(H, '', + RegisterSubrangeType(0, '', typeINTEGER, 1, 32), + typeBYTE, + 1); + T2 := RegisterArrayType(H, '', + RegisterSubrangeType(0, '', typeINTEGER, 0, 259), + typeCHAR, + 1); + T3 := RegisterArrayType(H, '', + RegisterSubrangeType(0, '', typeINTEGER, 0, 127), + typeANSICHAR, + 1); + + H := RegisterRecordType(H, 'TFileRec', 1); + H_TFileRec := H; + RegisterTypeField(H, 'Handle', typeNATIVEINT); + RegisterTypeField(H, 'Mode', typeWORD); + RegisterTypeField(H, 'Flags', typeWORD); + RegisterVariantRecordTypeField(H, 'RecSize', typeCARDINAL, 1); + RegisterVariantRecordTypeField(H, 'BufSize', typeCARDINAL, 2); + RegisterVariantRecordTypeField(H, 'BufPos', typeCARDINAL, 2); + RegisterVariantRecordTypeField(H, 'BufEnd', typeCARDINAL, 2); + RegisterVariantRecordTypeField(H, 'BufPtr', typePANSICHAR, 2); + RegisterVariantRecordTypeField(H, 'OpenFunc', typePOINTER, 2); + RegisterVariantRecordTypeField(H, 'InOutFunc', typePOINTER, 2); + RegisterVariantRecordTypeField(H, 'FlushFunc', typePOINTER, 2); + RegisterVariantRecordTypeField(H, 'CloseFunc', typePOINTER, 2); + RegisterVariantRecordTypeField(H, 'UserData', T1, 2); + RegisterVariantRecordTypeField(H, 'Name', T2, 2); + + T4 := RegisterArrayType(H, '', + RegisterSubrangeType(0, '', typeINTEGER, 0, 5), + typeANSICHAR, + 1); + T5 := RegisterArrayType(H, '', + RegisterSubrangeType(0, '', typeINTEGER, 0, 2), + typeANSICHAR, + 1); + + H := RegisterRecordType(H, 'TTextRec', 1); + H_TTextRec := H; + RegisterTypeField(H, 'Handle', typeNATIVEINT); + RegisterTypeField(H, 'Mode', typeWORD); + RegisterTypeField(H, 'Flags', typeWORD); + RegisterTypeField(H, 'BufSize', typeCARDINAL); + RegisterTypeField(H, 'BufPos', typeCARDINAL); + RegisterTypeField(H, 'BufEnd', typeCARDINAL); + RegisterTypeField(H, 'BufPtr', typePANSICHAR); + RegisterTypeField(H, 'OpenFunc', typePOINTER); + RegisterTypeField(H, 'InOutFunc', typePOINTER); + RegisterTypeField(H, 'FlushFunc', typePOINTER); + RegisterTypeField(H, 'CloseFunc', typePOINTER); + RegisterTypeField(H, 'UserData', T1); + RegisterTypeField(H, 'Name', T2); + RegisterTypeField(H, 'Buffer', T3); +{$IFDEF UNIC} + RegisterTypeField(H, 'CodePage', typeWORD); + RegisterTypeField(H, 'MBCSLength', typeSHORTINT); + RegisterTypeField(H, 'MBCSBufPos', typeBYTE); + RegisterVariantRecordTypeField(H, 'MBCSBuffer', T4, 1); + RegisterVariantRecordTypeField(H, 'UTF16Buffer', T5, 2); +{$ENDIF} +{$ENDIF} //ndef paxarm + + RegisterRoutine(0, '', typeVOID, ccREGISTER, @ GetAddressGetCallerEIP); + Id_GetAddressGetCallerEIP := LastSubId; + + end; +end; + +initialization + + RUNNER_OWNER_OFFSET := IntPax(@TBaseRunner(nil).Owner); + + if Assigned(AssignRunnerLibProc) then + AssignRunnerLibProc; + + {$IFDEF DRTTI} + Initialize_paxcomp_2010; + InitializePAXCOMP_2010Reg; + {$ENDIF} + + GlobalSymbolTable := TBaseSymbolTable.Create; + AddStdRoutines(GlobalSymbolTable); + StdCard := GlobalSymbolTable.Card; + StdSize := GlobalSymbolTable.GetDataSize; + + GlobalImportTable := GlobalSymbolTable; + GlobalExtraImportTableList := TExtraImportTableList.Create; + + AvailUnitList := TStringList.Create; + AvailUnitList1:= TStringList.Create; + AvailTypeList := TStringList.Create; + +{$IFDEF DRTTI} + AvailUnitList.Sorted := true; + AvailUnitList.Duplicates := dupIgnore; + AvailUnitList.CaseSensitive := false; + + AvailUnitList1.Sorted := true; + AvailUnitList1.Duplicates := dupIgnore; + AvailUnitList1.CaseSensitive := false; + + AvailTypeList.Sorted := true; + AvailTypeList.Duplicates := dupIgnore; + AvailTypeList.CaseSensitive := false; +{$ENDIF} + +finalization + AvailUnitList.Free; + AvailUnitList1.Free; + AvailTypeList.Free; + + GlobalSymbolTable.Free; + + GlobalExtraImportTableList.Free; + + {$IFDEF DRTTI} + Finalize_paxcomp_2010; + {$ENDIF} + +end. + diff --git a/Sources/PAXCOMP_SYMBOL_PROGRAM.pas b/Sources/PAXCOMP_SYMBOL_PROGRAM.pas new file mode 100644 index 0000000..5c44899 --- /dev/null +++ b/Sources/PAXCOMP_SYMBOL_PROGRAM.pas @@ -0,0 +1,6109 @@ +//////////////////////////////////////////////////////////////////////////// +// PaxCompiler +// Site: http://www.paxcompiler.com +// Author: Alexander Baranovsky (paxscript@gmail.com) +// ======================================================================== +// Copyright (c) Alexander Baranovsky, 2006-2014. All rights reserved. +// Code Version: 4.2 +// ======================================================================== +// Unit: PAXCOMP_SYMBOL_PROGRAM.pas +// ======================================================================== +//////////////////////////////////////////////////////////////////////////// + +{$I PaxCompiler.def} +{$R-} + +unit PAXCOMP_SYMBOL_PROGRAM; +interface + +uses {$I uses.def} + SysUtils, + Classes, + PAXCOMP_CONSTANTS, + PAXCOMP_TYPES, + PAXCOMP_SYS, + PAXCOMP_PROG, + PAXCOMP_SYMBOL_REC, + PAXCOMP_BASESYMBOL_TABLE, + PAXCOMP_SYMBOL_TABLE, + PAXCOMP_BYTECODE, + PAXCOMP_MODULE, + PAXCOMP_CLASSLST, + PAXCOMP_CLASSFACT, + PAXCOMP_TRYLST, + PAXCOMP_RTI, + PAXCOMP_DISASM, + PAXCOMP_STDLIB; +type + TSymbolProgRec = class + private + fPAX64: Boolean; + fLabelId: Integer; + procedure SetLabelId(value: Integer); + function GetPAX64: Boolean; + public + Op: Integer; + Arg1, Arg2: TArg; + Size: Integer; + code: array[0..11] of byte; + Comment: String; + SaveSubId: Integer; + ShiftValue: Integer; + Z: Boolean; + + ProgOffset: Integer; + MustBeFixed: Boolean; + OpOffset: Integer; + SubId: Integer; + + MapSub: Integer; + + constructor Create(aPAX64: Boolean); + function ToStr: String; + procedure Decompile; + property LabelId: Integer read fLabelId write SetLabelId; + property PAX64: Boolean read GetPAX64; + end; + + TSymbolProg = class(TTypedList) + private + function GetRecord(I: Integer): TSymbolProgRec; + function GetCard: Integer; + function GetProgSize: Integer; + function GetMovCode(Reg1, Reg2: Integer): Integer; + function Get64Code(Reg1, Reg2: Integer): Integer; + function GetMovESIPtrCode(Reg: Integer): Integer; + function GetMovEBPPtrCode(Reg: Integer): Integer; + function GetPAX64: Boolean; + function GetSizeOfPointer: Integer; + public + kernel: Pointer; + constructor Create(i_kernel: Pointer); + function AddRecord: TSymbolProgRec; + function Top: TSymbolProgRec; + procedure Optimization; + procedure Delete(I: Integer); + function GetOffset(S: TSymbolRec): Integer; + + function AsmComment(const S: String): TSymbolProgRec; + + // requires EmitGetAddressRegister + // MOV PTR [REG], Imm + procedure AsmMovREGPtr_Imm(Reg: Integer; S: TSymbolRec; value: IntPax); overload; + // requires EmitGetAddressRegister + // ADD PTR [REG], Imm + procedure AsmAddREGPtr_Imm(Reg: Integer; S: TSymbolRec; value: IntPax); + // requires EmitGetAddressRegister + // CMP PTR [REG], Imm + procedure AsmCmpREGPtr_Imm(Reg: Integer; S: TSymbolRec; value: IntPax); + // requires EmitGetAddressRegister + // NEG DWORD PTR [REG + Shift] + procedure AsmNEG_REGPtr(Reg: Integer; S: TSymbolRec); + // requires EmitGetAddressRegister + // Fld QWORD PTR [REG + Shift] + procedure AsmFldDouble_REGPtr(Reg: Integer; S: TSymbolRec); overload; + // requires EmitGetAddressRegister + // FStp QWORD PTR [REG + Shift] + procedure AsmFstpDouble_REGPtr(Reg: Integer; S: TSymbolRec); overload; + // requires EmitGetAddressRegister + // Fld DWORD PTR [REG + Shift] + procedure AsmFldSingle_REGPtr(Reg: Integer; S: TSymbolRec); overload; + // requires EmitGetAddressRegister + // Fld TBYTE PTR [REG + Shift] + procedure AsmFldExtended_REGPtr(Reg: Integer; S: TSymbolRec); overload; + // requires EmitGetAddressRegister + // FStp DWORD PTR [REG + Shift] + procedure AsmFstpSingle_REGPtr(Reg: Integer; S: TSymbolRec); overload; + // requires EmitGetAddressRegister + // FStp TBYTE PTR [REG + Shift] + procedure AsmFstpExtended_REGPtr(Reg: Integer; S: TSymbolRec); overload; + + function AsmAddREG_Imm(Reg: Integer; value: Integer): TSymbolProgRec; + procedure AsmSubREG_Imm(Reg: Integer; value: IntPax); + procedure AsmAddREG_REG(Reg1, Reg2: Integer); + procedure AsmAdcREG_REG(Reg1, Reg2: Integer); + procedure AsmSbbREG_REG(Reg1, Reg2: Integer); + + procedure AsmMulREG(Reg: Integer); + procedure AsmIMulREG(Reg: Integer); + procedure AsmDivREG(Reg: Integer); + procedure AsmIDivREG(Reg: Integer); + procedure AsmShlREG(Reg: Integer); + procedure AsmShrREG(Reg: Integer); + + procedure AsmNotREG(Reg: Integer); + procedure AsmNegREG(Reg: Integer); + + procedure AsmSubREG_REG(Reg1, Reg2: Integer); + procedure AsmXorREG_REG(Reg1, Reg2: Integer); + procedure AsmAndREG_REG(Reg1, Reg2: Integer); + procedure AsmOrREG_REG(Reg1, Reg2: Integer); + + function AsmMovREG_REG(Reg1, Reg2: Integer): TSymbolProgRec; +{$IFDEF VARIANTS} + function AsmMovREG_Imm(Reg: Integer; value: Int64): TSymbolProgRec; +{$ELSE} + function AsmMovREG_Imm(Reg: Integer; value: Integer): TSymbolProgRec; +{$ENDIF} + procedure AsmMovREGPtr_Imm(Reg: Integer; value: IntPax); overload; + procedure AsmMovREGPtr_Imm(Reg, shift: Integer; value: IntPax); overload; + + procedure AsmMovFS_REGPtr_REG32(Reg1, Reg2: Integer); + + procedure AsmMovRSPPtr_REG64(Reg: Integer; Shift: Integer); + procedure AsmMovREG64_RSPPtr(Reg: Integer; Shift: Integer); + + procedure AsmMovREGPtr_REG(Reg1, Reg2: Integer); + procedure AsmMovREGPtr_REG64(Reg1, Reg2: Integer); + procedure AsmMovREGPtr_REG32(Reg1, Reg2: Integer); + procedure AsmMovREGPtr_REG16(Reg1, Reg2: Integer); + procedure AsmMovREGPtr_REG8(Reg1, Reg2: Integer); + + procedure AsmMovREG_REGPtr(Reg1, Reg2: Integer); + procedure AsmMovREG64_REGPtr(Reg1, Reg2: Integer); + procedure AsmMovREG32_REGPtr(Reg1, Reg2: Integer); + procedure AsmMovREG16_REGPtr(Reg1, Reg2: Integer); + procedure AsmMovREG8_REGPtr(Reg1, Reg2: Integer); +//< ? + procedure AsmFldDouble_REGPtr(Reg: Integer); overload; + procedure AsmFldSingle_REGPtr(Reg: Integer); overload; + procedure AsmFldExtended_REGPtr(Reg: Integer); overload; +//? > + procedure AsmFild_REG16Ptr(Reg: Integer); + procedure AsmFild_REG32Ptr(Reg: Integer); + procedure AsmFild_REG64Ptr(Reg: Integer); + + procedure AsmFistp_REG64Ptr(Reg: Integer); + + procedure AsmFAdd_REGPtr(Reg: Integer); + + procedure AsmWait; + + procedure AsmFAdd; + procedure AsmFSub; + procedure AsmFMul; + procedure AsmFDiv; + procedure AsmFChs; + procedure AsmFAbs; + procedure AsmFSub_REGPtr(Reg: Integer); + procedure AsmFMul_REGPtr(Reg: Integer); + procedure AsmFDiv_REGPtr(Reg: Integer); + + procedure AsmFMul_ESIPtr32(Shift: Integer); + procedure AsmFDiv_ESIPtr32(Shift: Integer); + + procedure AsmFstpDouble_REGPtr(Reg: Integer); overload; + procedure AsmFstpSingle_REGPtr(Reg: Integer); overload; + procedure AsmFstpExtended_REGPtr(Reg: Integer); overload; + + procedure AsmFComp_REGPtr(Reg: Integer); + procedure AsmFCompP; + procedure AsmFstsw_AX; + procedure AsmSahv; + + procedure AsmCDQ; + + procedure AsmSet_REGPtr(ASM_OP, Reg: Integer; S: TSymbolRec); + + procedure AsmSetL_REGPtr(Reg: Integer); // < + procedure AsmSetLE_REGPtr(Reg: Integer); // <= + procedure AsmSetNLE_REGPtr(Reg: Integer); // > + procedure AsmSetNL_REGPtr(Reg: Integer); // >= + + procedure AsmSetB_REGPtr(Reg: Integer); + procedure AsmSetBE_REGPtr(Reg: Integer); + procedure AsmSetNBE_REGPtr(Reg: Integer); + procedure AsmSetNB_REGPtr(Reg: Integer); + procedure AsmSetZ_REGPtr(Reg: Integer); + procedure AsmSetNZ_REGPtr(Reg: Integer); + + procedure AsmCmpByteREGPtr_Imm(Reg: Integer; value: Byte); + procedure AsmCmpREG_REG(Reg1, Reg2: Integer); + procedure AsmCmpREG_Imm(Reg: Integer; Value: Integer); + + procedure AsmTestREG8_REG8(Reg1, Reg2: Integer); + + procedure AsmCmpReg32Ptr_Imm(Reg: Integer; shift: Integer; value: Integer); + + procedure AsmIncReg32Ptr(Reg: Integer; shift: Integer); + procedure AsmDecReg32Ptr(Reg: Integer; shift: Integer); + + procedure AsmIncBytePtr(Reg: Integer; shift: Integer); + + function AsmJmp_REG(Reg: Integer): TSymbolProgRec; + procedure AsmCall_REG(Reg: Integer); + procedure AsmPush_Imm(value: Integer); + function AsmPush_REG(Reg: Integer): TSymbolProgRec; + procedure AsmPush_Reg16(Reg: Integer); + + procedure AsmPush_FS_REGPtr(Reg: Integer); + + function AsmPop_REG(Reg: Integer): TSymbolProgRec; + procedure AsmPush_REGPtr(Reg: Integer); + + function AsmGetREG_ESIPtr(Reg: Integer; shift: Integer): TSymbolProgRec; + function AsmGetREG64_RSIPtr(Reg: Integer; shift: Integer): TSymbolProgRec; + function AsmGetREG32_ESIPtr(Reg: Integer; shift: Integer): TSymbolProgRec; + procedure AsmGetREG16_ESIPtr(Reg: Integer; shift: Integer); + procedure AsmGetREG8_ESIPtr(Reg: Integer; shift: Integer); + + procedure AsmPutREG_ESIPtr(Reg: Integer; shift: Integer); + procedure AsmPutREG64_RSIPtr(Reg: Integer; shift: Integer); + procedure AsmPutREG32_ESIPtr(Reg: Integer; shift: Integer); + procedure AsmPutREG16_ESIPtr(Reg: Integer; shift: Integer); + procedure AsmPutREG8_ESIPtr(Reg: Integer; shift: Integer); + + procedure AsmGetREG_EBPPtr(Reg: Integer; shift: Integer); + procedure AsmGetREG64_RBPPtr(Reg: Integer; shift: Integer); + procedure AsmGetREG32_EBPPtr(Reg: Integer; shift: Integer); + procedure AsmGetREG16_EBPPtr(Reg: Integer; shift: Integer); + procedure AsmGetREG8_EBPPtr(Reg: Integer; shift: Integer); + + procedure AsmPutREG_EBPPtr(Reg: Integer; shift: Integer); + procedure AsmPutREG64_RBPPtr(Reg: Integer; shift: Integer); + procedure AsmPutREG32_EBPPtr(Reg: Integer; shift: Integer); + procedure AsmPutREG16_EBPPtr(Reg: Integer; shift: Integer); + procedure AsmPutREG8_EBPPtr(Reg: Integer; shift: Integer); + + procedure AsmNop; + procedure AsmClc; + procedure AsmPushfd; + procedure AsmPopfd; + procedure AsmXCHG(Reg1, Reg2: Integer); + procedure AsmRet(value: Word = 0); + procedure AsmJMP_Imm(value: Integer); + + procedure AsmJNO_Imm(value: Byte); + procedure AsmJNC_Imm(value: Byte); + procedure AsmJBE_Imm(value: Byte); + procedure AsmJNLE_Imm(value: Byte); + + procedure AsmJZ_Imm(value: SmallInt); + procedure AsmJNZ_Imm(value: SmallInt); + + procedure AsmLeaReg32_RegPtr(Reg1, Reg2: Integer; shift: Integer); + + procedure AsmRep_MOVSB; + procedure AsmRep_MOVSD; + + procedure AsmCvtsd2ssXMM_RegPtr(XMMReg, Reg: Integer); + procedure AsmCvtss2sdXMM_RegPtr(XMMReg, Reg: Integer); + + procedure AsmMovsdXMM_RegPtr(XMMReg, Reg: Integer); + procedure AsmMovsdRegPtr_XMM(XMMReg, Reg: Integer); + procedure AsmMovssXMM_RegPtr(XMMReg, Reg: Integer); + procedure AsmMovssRegPtr_XMM(XMMReg, Reg: Integer); + + procedure AsmLoadESI_ESPPtr(shift: Integer); // not used + procedure AsmLoadEDI_ESPPtr(shift: Integer); // not used + + procedure CreateProgram(result: TProgram; IsEval: Boolean = false); + procedure CreateProgramSimple(result: TProgram); + + procedure AsmLeaRSP_RBPPtr(Shift: Integer); + + function GetShiftOfRecord(R: TSymbolProgRec): Integer; + function GetShiftOfLabel(LabelId: Integer): Integer; + procedure CreateZList(P: TProgram); + function EmitZ: Integer; + function EmitGetCallerEIP: Integer; + + procedure RaiseError(const Message: string; params: array of Const); + procedure CreateError(const Message: string; params: array of Const); + property Card: Integer read GetCard; + property ProgSize: Integer read GetProgSize; + property Records[I: Integer]: TSymbolProgRec read GetRecord; default; + property PAX64: Boolean read GetPAX64; + property SizeOfPointer: Integer read GetSizeOfPointer; + end; + +implementation + +uses + PAXCOMP_MAP, + PAXCOMP_KERNEL; + +constructor TSymbolProgRec.Create(aPAX64: Boolean); +begin + FillChar(code, SizeOf(code), 0); + Op := 0; + ClearArg(Arg1); + ClearArg(Arg2); + Size := 0; + LabelId := 0; + Comment := ''; + SaveSubId := 0; + ShiftValue := 0; + Z := false; + fPAX64 := aPAX64; +end; + +procedure TSymbolProgRec.SetLabelId(value: Integer); +begin + fLabelId := Value; +end; + +function TSymbolProgRec.GetPAX64: Boolean; +begin + result := fPAX64; +end; + +procedure SwapRegs(var Reg1, Reg2: Integer); +var + temp: Integer; +begin + temp := Reg1; + Reg1 := Reg2; + Reg2 := temp; +end; + +function TSymbolProgRec.ToStr: String; +var + I: Integer; +begin + result := ''; + for I := 0 to Size - 1 do + result := result + ByteToHex(code[I]); + + if Size = -1 then + result := AlignLeft('', 25) + Comment + else + begin + if Arg2.valid then + result := AlignLeft(result, 25) + AsmOperators[Op] + ' ' + ArgToString(Arg1, PAX64) + + ', ' + ArgToString(Arg2, PAX64) + else + result := AlignLeft(result, 25) + AsmOperators[Op] + ' ' + ArgToString(Arg1, PAX64); + end; +end; + +procedure TSymbolProgRec.Decompile; +var + S: Integer; +begin + Decomp(@code, S, Op, Arg1, Arg2, PAX64); + if S <> Size then + raise Exception.Create(errInternalError); +end; + +constructor TSymbolProg.Create(i_kernel: Pointer); +begin + inherited Create; + Self.kernel := i_kernel; +end; + +function TSymbolProg.GetCard: Integer; +begin + result := L.Count; +end; + +function TSymbolProg.GetMovESIPtrCode(Reg: Integer): Integer; +begin + result := 0; + case Reg of + _EAX: result := $86; + _ECX: result := $8E; + _EDX: result := $96; + _EBX: result := $9E; + _ESP: result := $A6; + _EBP: result := $AE; + _ESI: result := $B6; + _EDI: result := $BE; + _R8: result := $86; + _R9: result := $8E; + _R10: result := $96; + _R11: result := $9E; + _R12: result := $A6; + _R13: result := $AE; + _R14: result := $B6; + _R15: result := $BE; + else + RaiseError(errInternalError, []); + end; +end; + +function TSymbolProg.GetMovEBPPtrCode(Reg: Integer): Integer; +begin + result := 0; + case Reg of + _EAX: result := $85; + _ECX: result := $8D; + _EDX: result := $95; + _EBX: result := $9D; + _ESP: result := $A5; + _EBP: result := $AD; + _ESI: result := $B5; + _EDI: result := $BD; + _R8: result := $85; + _R9: result := $8D; + _R10: result := $95; + _R11: result := $9D; + _R12: result := $A5; + _R13: result := $AD; + _R14: result := $B5; + _R15: result := $BD; + else + RaiseError(errInternalError, []); + end; +end; + +function TSymbolProg.GetMovCode(Reg1, Reg2: Integer): Integer; +begin + result := 0; + case Reg1 of + _EAX, _R8: + case Reg2 of + _EAX, _R8: result := $C0; + _ECX, _R9: result := $C8; + _EDX, _R10: result := $D0; + _EBX, _R11: result := $D8; + _ESP, _R12: result := $E0; + _EBP, _R13: result := $E8; + _ESI, _R14: result := $F0; + _EDI, _R15: result := $F8; + else + RaiseError(errInternalError, []); + end; + _ECX, _R9: + case Reg2 of + _EAX, _R8: result := $C1; + _ECX, _R9: result := $C9; + _EDX, _R10: result := $D1; + _EBX, _R11: result := $D9; + _ESP, _R12: result := $E1; + _EBP, _R13: result := $E9; + _ESI, _R14: result := $F1; + _EDI, _R15: result := $F9; + else + RaiseError(errInternalError, []); + end; + _EDX, _R10: + case Reg2 of + _EAX, _R8: result := $C2; + _ECX, _R9: result := $CA; + _EDX, _R10: result := $D2; + _EBX, _R11: result := $DA; + _ESP, _R12: result := $E2; + _EBP, _R13: result := $EA; + _ESI, _R14: result := $F2; + _EDI, _R15: result := $FA; + else + RaiseError(errInternalError, []); + end; + _EBX, _R11: + case Reg2 of + _EAX, _R8: result := $C3; + _ECX, _R9: result := $CB; + _EDX, _R10: result := $D3; + _EBX, _R11: result := $DB; + _ESP, _R12: result := $E3; + _EBP, _R13: result := $EB; + _ESI, _R14: result := $F3; + _EDI, _R15: result := $FB; + else + RaiseError(errInternalError, []); + end; + _ESP: + case Reg2 of + _EAX, _R8: result := $C4; + _ECX, _R9: result := $CC; + _EDX, _R10: result := $D4; + _EBX, _R11: result := $DC; + _ESP, _R12: result := $E4; + _EBP, _R13: result := $EC; + _ESI, _R14: result := $F4; + _EDI, _R15: result := $FC; + else + RaiseError(errInternalError, []); + end; + _EBP: + case Reg2 of + _EAX, _R8: result := $C5; + _ECX, _R9: result := $CD; + _EDX, _R10: result := $D5; + _EBX, _R11: result := $DD; + _ESP, _R12: result := $E5; + _EBP, _R13: result := $ED; + _ESI, _R14: result := $F5; + _EDI, _R15: result := $FD; + else + RaiseError(errInternalError, []); + end; + _ESI, _R13: + case Reg2 of + _EAX, _R8: result := $C6; + _ECX, _R9: result := $CE; + _EDX, _R10: result := $D6; + _EBX, _R11: result := $DE; + _ESP, _R12: result := $E6; + _EBP, _R13: result := $EE; + _ESI, _R14: result := $F6; + _EDI, _R15: result := $FE; + else + RaiseError(errInternalError, []); + end; + _EDI, _R14: + case Reg2 of + _EAX, _R8: result := $C7; + _ECX, _R9: result := $CF; + _EDX, _R10: result := $D7; + _EBX, _R11: result := $DF; + _ESP, _R12: result := $E7; + _EBP, _R13: result := $EF; + _ESI, _R14: result := $F7; + _EDI, _R15: result := $FF; + else + RaiseError(errInternalError, []); + end; + end; +end; + +function TSymbolProg.Get64Code(Reg1, Reg2: Integer): Integer; +begin + result := 0; + case Reg1 of + _EAX, _R8: + case Reg2 of + _EAX: result := $00; + _ECX: result := $01; + _EDX: result := $02; + _EBX: result := $03; + _ESP: result := $04; + _EBP: result := $05; + _ESI: result := $06; + _EDI: result := $07; + + _R8: result := $00; + _R9: result := $01; + _R10: result := $02; + _R11: result := $03; + _R12: result := $04; + _R13: result := $05; + _R14: result := $06; + _R15: result := $07; + else + RaiseError(errInternalError, []); + end; + _ECX, _R9: + case Reg2 of + _EAX: result := $08; + _ECX: result := $09; + _EDX: result := $0A; + _EBX: result := $0B; + _ESP: result := $0C; + _EBP: result := $0D; + _ESI: result := $0E; + _EDI: result := $0F; + + _R8: result := $08; + _R9: result := $09; + _R10: result := $0A; + _R11: result := $0B; + _R12: result := $0C; + _R13: result := $0D; + _R14: result := $0E; + _R15: result := $0F; + else + RaiseError(errInternalError, []); + end; + _EDX, _R10: + case Reg2 of + _EAX: result := $10; + _ECX: result := $11; + _EDX: result := $12; + _EBX: result := $13; + _ESP: result := $14; + _EBP: result := $15; + _ESI: result := $16; + _EDI: result := $17; + + _R8: result := $10; + _R9: result := $11; + _R10: result := $12; + _R11: result := $13; + _R12: result := $14; + _R13: result := $15; + _R14: result := $16; + _R15: result := $17; + else + RaiseError(errInternalError, []); + end; + _EBX, _R11: + case Reg2 of + _EAX: result := $18; + _ECX: result := $19; + _EDX: result := $1A; + _EBX: result := $1B; + _ESP: result := $1C; + _EBP: result := $1D; + _ESI: result := $1E; + _EDI: result := $1F; + + _R8: result := $18; + _R9: result := $19; + _R10: result := $1A; + _R11: result := $1B; + _R12: result := $1C; + _R13: result := $1D; + _R14: result := $1E; + _R15: result := $1F; + else + RaiseError(errInternalError, []); + end; + _ESP, _R12: + case Reg2 of + _EAX: result := $20; + _ECX: result := $21; + _EDX: result := $22; + _EBX: result := $23; + _ESP: result := $24; + _EBP: result := $25; + _ESI: result := $26; + _EDI: result := $27; + + _R8: result := $20; + _R9: result := $21; + _R10: result := $22; + _R11: result := $23; + _R12: result := $24; + _R13: result := $25; + _R14: result := $26; + _R15: result := $27; + else + RaiseError(errInternalError, []); + end; + _EBP, _R13: + case Reg2 of + _EAX: result := $28; + _ECX: result := $29; + _EDX: result := $2A; + _EBX: result := $2B; + _ESP: result := $2C; + _EBP: result := $2D; + _ESI: result := $2E; + _EDI: result := $2F; + + _R8: result := $28; + _R9: result := $29; + _R10: result := $2A; + _R11: result := $2B; + _R12: result := $2C; + _R13: result := $2D; + _R14: result := $2E; + _R15: result := $2F; + else + RaiseError(errInternalError, []); + end; + _ESI, _R14: + case Reg2 of + _EAX: result := $30; + _ECX: result := $31; + _EDX: result := $32; + _EBX: result := $33; + _ESP: result := $34; + _EBP: result := $35; + _ESI: result := $36; + _EDI: result := $37; + + _R8: result := $30; + _R9: result := $31; + _R10: result := $32; + _R11: result := $33; + _R12: result := $34; + _R13: result := $35; + _R14: result := $36; + _R15: result := $37; + else + RaiseError(errInternalError, []); + end; + _EDI, _R15: + case Reg2 of + _EAX: result := $38; + _ECX: result := $39; + _EDX: result := $3A; + _EBX: result := $3B; + _ESP: result := $3C; + _EBP: result := $3D; + _ESI: result := $3E; + _EDI: result := $3F; + + _R8: result := $38; + _R9: result := $39; + _R10: result := $3A; + _R11: result := $3B; + _R12: result := $3C; + _R13: result := $3D; + _R14: result := $3E; + _R15: result := $3F; + else + RaiseError(errInternalError, []); + end; + else + RaiseError(errInternalError, []); + end; +end; + +function TSymbolProg.GetProgSize: Integer; +var + I, SZ: Integer; +begin + result := 0; + for I:=1 to Card do + begin + SZ := Records[I].Size; + if SZ > 0 then + result := result + SZ; + end; +end; + +function TSymbolProg.GetShiftOfLabel(LabelId: Integer): Integer; +var + I, SZ: Integer; +begin + result := 0; + for I:=1 to Card do + begin + if Records[I].LabelId = LabelId then + Exit; + + SZ := Records[I].Size; + if SZ > 0 then + result := result + SZ; + end; + result := -1; +end; + +function TSymbolProg.GetShiftOfRecord(R: TSymbolProgRec): Integer; +var + I, SZ: Integer; +begin + result := 0; + for I:=1 to Card do + begin + if Records[I] = R then + Exit; + + SZ := Records[I].Size; + if SZ > 0 then + result := result + SZ; + end; + result := -1; +end; + +function TSymbolProg.AddRecord: TSymbolProgRec; +begin + result := TSymbolProgRec.Create(PAX64); + L.Add(result); +end; + +function TSymbolProg.Top: TSymbolProgRec; +begin + result := Records[Card]; +end; + +procedure TSymbolProg.Delete(I: Integer); +begin + Records[I].Free; + L.Delete(I - 1); +end; + +function TSymbolProg.AsmComment(const S: String): TSymbolProgRec; +begin + result := AddRecord; + with result do + begin + Size := -1; + Comment := ';' + S; + end; +end; + +{$IFDEF VARIANTS} +function TSymbolProg.AsmMovREG_Imm(Reg: Integer; value: Int64): TSymbolProgRec; +{$ELSE} +function TSymbolProg.AsmMovREG_Imm(Reg: Integer; value: Integer): TSymbolProgRec; +{$ENDIF} +begin + result := AddRecord; + if PAX64 then + begin + with result do + begin + Size := 10; + code[0] := $48; + + if Reg in R64 then + Code[0] := $49; + + case Reg of + _EAX: code[1] := $B8; + _ECX: code[1] := $B9; + _EDX: code[1] := $BA; + _EBX: code[1] := $BB; + _ESP: code[1] := $BC; + _EBP: code[1] := $BD; + _ESI: code[1] := $BE; + _EDI: code[1] := $BF; + + _R8: code[1] := $B8; + _R9: code[1] := $B9; + _R10: code[1] := $BA; + _R11: code[1] := $BB; + _R12: code[1] := $BC; + _R13: code[1] := $BD; + _R14: code[1] := $BE; + _R15: code[1] := $BF; + + else + RaiseError(errInternalError, []); + end; + Move(value, code[2], 8); + Decompile; + end; + end + else //32bit + begin + with result do + begin + Size := 5; + case Reg of + _EAX: code[0] := $B8; + _ECX: code[0] := $B9; + _EDX: code[0] := $BA; + _EBX: code[0] := $BB; + _ESP: code[0] := $BC; + _EBP: code[0] := $BD; + _ESI: code[0] := $BE; + _EDI: code[0] := $BF; + else + RaiseError(errInternalError, []); + end; + Move(value, code[1], 4); + Decompile; + end; + end; +end; + +procedure TSymbolProg.AsmLeaRSP_RBPPtr(Shift: Integer); +begin + if PAX64 then + with AddRecord do + begin + Size := 7; + code[0] := $48; + code[1] := $8D; + code[2] := $A5; + Move(Shift, code[3], 4); + Decompile; + end + else //32bit + RaiseError(errInternalError, []); +end; + +procedure TSymbolProg.AsmMovREGPtr_Imm(Reg: Integer; value: IntPax); +begin + if PAX64 then + with AddRecord do + begin + Size := 7; + code[0] := $48; + if Reg in R64 then + Code[0] := $49; + + code[1] := $C7; + case Reg of + _EAX: code[2] := $00; + _ECX: code[2] := $01; + _EDX: code[2] := $02; + _EBX: code[2] := $03; + + _R8: code[2] := $00; + _R9: code[2] := $01; + _R10: code[2] := $02; + _R11: code[2] := $03; + _R12: code[2] := $04; + _R13: code[2] := $05; + _R14: code[2] := $06; + _R15: code[2] := $07; + else + RaiseError(errInternalError, []); + end; + Move(value, code[3], 4); + Decompile; + end + else //32bit + with AddRecord do + begin + Size := 6; + code[0] := $C7; + case Reg of + _EAX: code[1] := $00; + _ECX: code[1] := $01; + _EDX: code[1] := $02; + _EBX: code[1] := $03; + else + RaiseError(errInternalError, []); + end; + Move(value, code[2], 4); + Decompile; + end; +end; + +procedure TSymbolProg.AsmMovREGPtr_Imm(Reg, shift: Integer; value: IntPax); +begin + if PAX64 then + with AddRecord do + begin + Size := 11; + code[0] := $48; + if Reg in R64 then + Code[0] := $49; + + code[1] := $C7; + case Reg of + _EAX: code[2] := $80; + _ECX: code[2] := $81; + _EDX: code[2] := $82; + _EBX: code[2] := $83; + _EBP: code[2] := $85; + _ESI: code[2] := $86; + + _R8: code[2] := $80; + _R9: code[2] := $81; + _R10: code[2] := $82; + _R11: code[2] := $83; + _R12: code[2] := $84; + _R13: code[2] := $85; + _R14: code[2] := $86; + _R15: code[2] := $87; + else + RaiseError(errInternalError, []); + end; + Move(shift, code[3], 4); + Move(value, code[7], 4); + Decompile; + end + else //32bit + with AddRecord do + begin + Size := 10; + code[0] := $C7; + case Reg of + _EAX: code[1] := $80; + _ECX: code[1] := $81; + _EDX: code[1] := $82; + _EBX: code[1] := $83; + _EBP: code[1] := $85; + _ESI: code[1] := $86; + else + RaiseError(errInternalError, []); + end; + Move(shift, code[2], 4); + Move(value, code[6], 4); + Decompile; + end; +end; + +procedure TSymbolProg.AsmMovREG_REGPtr(Reg1, Reg2: Integer); +begin + if PAX64 then + AsmMovREG64_REGPtr(Reg1, Reg2) + else + AsmMovREG32_REGPtr(Reg1, Reg2); +end; + +procedure TSymbolProg.AsmMovREG64_REGPtr(Reg1, Reg2: Integer); +begin + with AddRecord do + begin + if Reg1 in R32 then + begin + if Reg2 in R64 then + begin + Size := 3; + code[0] := $49; + code[1] := $8B; + code[2] := Get64Code(Reg1, Reg2); + end + else + begin + Size := 3; + code[0] := $48; + code[1] := $8B; + code[2] := Get64Code(Reg1, Reg2); + end; + end + else if Reg1 in R64 then + begin + Size := 3; + if Reg2 in R64 then + Code[0] := $4D + else + Code[0] := $4C; + Code[1] := $8B; + Code[2] := Get64Code(Reg1, Reg2); + end + else + RaiseError(errInternalError, []); + Decompile; + end; +end; + +procedure TSymbolProg.AsmMovREG32_REGPtr(Reg1, Reg2: Integer); +begin + with AddRecord do + begin + if Reg1 in R32 then + begin + if Reg2 in R64 then + begin + Size := 4; + code[0] := $67; + code[1] := $41; + code[2] := $8B; + code[3] := Get64Code(Reg1, Reg2); + end + else + begin + Size := 2; + code[0] := $8B; + code[1] := Get64Code(Reg1, Reg2); + end; + end + else if Reg1 in R64 then + begin + Size := 3; + if Reg2 in R64 then + Code[0] := $45 + else + Code[0] := $44; + Code[1] := $8B; + Code[2] := Get64Code(Reg1, Reg2); + end + else + RaiseError(errInternalError, []); + Decompile; + end; +end; + +procedure TSymbolProg.AsmMovREG16_REGPtr(Reg1, Reg2: Integer); +begin + with AddRecord do + begin + if Reg1 in R32 then + begin + if Reg2 in R64 then + begin + Size := 4; + code[0] := $66; + code[1] := $41; + code[2] := $8B; + code[3] := Get64Code(Reg1, Reg2); + end + else + begin + Size := 3; + code[0] := $66; + code[1] := $8B; + code[2] := Get64Code(Reg1, Reg2); + end; + end + else if Reg1 in R64 then + begin + Size := 4; + code[0] := $66; + if Reg2 in R64 then + code[1] := $45 + else + code[1] := $44; + code[2] := $8B; + code[3] := Get64Code(Reg1, Reg2); + end + else + RaiseError(errInternalError, []); + Decompile; + end; +end; + +procedure TSymbolProg.AsmMovREG8_REGPtr(Reg1, Reg2: Integer); +begin + with AddRecord do + begin + if Reg1 in R32 then + begin + if Reg2 in R64 then + begin + Size := 3; + code[0] := $41; + code[1] := $8A; + code[2] := Get64Code(Reg1, Reg2); + end + else + begin + Size := 2; + code[0] := $8A; + code[1] := Get64Code(Reg1, Reg2); + end; + end + else if Reg1 in R64 then + begin + Size := 3; + if Reg2 in R64 then + code[0] := $45 + else + code[0] := $44; + code[1] := $8A; + Code[2] := Get64Code(Reg1, Reg2); + end + else + RaiseError(errInternalError, []); + Decompile; + end; +end; + +function TSymbolProg.AsmMovREG_REG(Reg1, Reg2: Integer): TSymbolProgRec; +begin + result := AddRecord; + if PAX64 then + with result do + begin + Size := 3; + if Reg1 in R32 then + begin + if Reg2 in R64 then + code[0] := $4C + else + code[0] := $48; + end + else if Reg1 in R64 then + begin + if Reg2 in R64 then + code[0] := $4D + else + code[0] := $49; + end + else + RaiseError(errInternalError, []); + code[1] := $89; + code[2] := GetMovCode(Reg1, Reg2); + Decompile; + end + else //32bit + with result do + begin + Size := 2; + code[0] := $89; + code[1] := GetMovCode(Reg1, Reg2); + Decompile; + end; +end; + +procedure TSymbolProg.AsmCmpREG_Imm(Reg: Integer; Value: Integer); +begin + with AddRecord do + begin + case Reg of + _EAX: + begin + Size := 5; + code[0] := $3D; + Move(Value, code[1], 4); + end; + _ECX, _EDX, _EBX: + begin + Size := 6; + code[0] := $81; + case Reg of + _ECX: code[1] := $F9; + _EDX: code[1] := $FA; + _EBX: code[1] := $FB; + _ESP: code[1] := $FC; + _EBP: code[1] := $FD; + _ESI: code[1] := $FE; + _EDI: code[1] := $FF; + end; + Move(Value, code[2], 4); + end; + else + RaiseError(errInternalError, []); + end; + Decompile; + end; +end; + +procedure TSymbolProg.AsmCmpREG_REG(Reg1, Reg2: Integer); +begin + with AddRecord do + begin + Size := 2; + code[0] := $39; + case Reg1 of + _EAX: + case Reg2 of + _EAX: code[1] := $C0; + _ECX: code[1] := $C8; + _EDX: code[1] := $D0; + _EBX: code[1] := $D8; + else + RaiseError(errInternalError, []); + end; + _ECX: + case Reg2 of + _EAX: code[1] := $C1; + _ECX: code[1] := $C9; + _EDX: code[1] := $D1; + _EBX: code[1] := $D9; + else + RaiseError(errInternalError, []); + end; + _EDX: + case Reg2 of + _EAX: code[1] := $C2; + _ECX: code[1] := $CA; + _EDX: code[1] := $D2; + _EBX: code[1] := $DA; + else + RaiseError(errInternalError, []); + end; + _EBX: + case Reg2 of + _EAX: code[1] := $C3; + _ECX: code[1] := $CB; + _EDX: code[1] := $D3; + _EBX: code[1] := $DB; + else + RaiseError(errInternalError, []); + end; + else + RaiseError(errInternalError, []); + end; + Decompile; + end; +end; + +procedure TSymbolProg.AsmTestREG8_REG8(Reg1, Reg2: Integer); +begin + with AddRecord do + begin + Size := 2; + if (Reg1 = _EDX) and (Reg2 = _EDX) then + begin + Code[0] := $84; + Code[1] := $d2; + end + else + RaiseError(errInternalError, []); + Decompile; + end; +end; + +procedure TSymbolProg.AsmMovFS_REGPtr_REG32(Reg1, Reg2: Integer); +begin + with AddRecord do + begin + Size := 3; + code[0] := $64; + code[1] := $89; + case Reg1 of + _EAX: + case Reg2 of + _EAX: code[2] := $00; + _ECX: code[2] := $08; + _EDX: code[2] := $10; + _EBX: code[2] := $18; + _ESP: code[2] := $20; + _EBP: code[2] := $28; + _ESI: code[2] := $30; + _EDI: code[2] := $38; + else + RaiseError(errInternalError, []); + end; + _ECX: + case Reg2 of + _EAX: code[2] := $01; + _ECX: code[2] := $09; + _EDX: code[2] := $11; + _EBX: code[2] := $19; + _ESP: code[2] := $21; + _EBP: code[2] := $29; + _ESI: code[2] := $31; + _EDI: code[2] := $39; + else + RaiseError(errInternalError, []); + end; + _EDX: + case Reg2 of + _EAX: code[2] := $02; + _ECX: code[2] := $0A; + _EDX: code[2] := $12; + _EBX: code[2] := $1A; + _ESP: code[2] := $22; + _EBP: code[2] := $2A; + _ESI: code[2] := $32; + _EDI: code[2] := $3A; + else + RaiseError(errInternalError, []); + end; + _EBX: + case Reg2 of + _EAX: code[2] := $03; + _ECX: code[2] := $0B; + _EDX: code[2] := $13; + _EBX: code[2] := $1B; + _ESP: code[2] := $23; + _EBP: code[2] := $2B; + _ESI: code[2] := $33; + _EDI: code[2] := $3B; + else + RaiseError(errInternalError, []); + end; + else + RaiseError(errInternalError, []); + end; + Decompile; + end; +end; + +procedure TSymbolProg.AsmMovRSPPtr_REG64(Reg: Integer; Shift: Integer); +begin + with AddRecord do + begin + Size := 8; + if Reg in R64 then + code[0] := $4C + else + code[0] := $48; + code[1] := $89; + case Reg of + _EAX: code[2] := $84; + _ECX: code[2] := $8C; + _EDX: code[2] := $94; + _EBX: code[2] := $9C; + _ESP: code[2] := $A4; + _EBP: code[2] := $AC; + _ESI: code[2] := $B4; + _EDI: code[2] := $BC; + + _R8: code[2] := $84; + _R9: code[2] := $8C; + _R10: code[2] := $94; + _R11: code[2] := $9C; + _R12: code[2] := $A4; + _R13: code[2] := $AC; + _R14: code[2] := $B4; + _R15: code[2] := $BC; + else + RaiseError(errInternalError, []); + end; + code[3] := $24; + Move(Shift, code[4], 4); + Decompile; + end; +end; + +procedure TSymbolProg.AsmMovREG64_RSPPtr(Reg: Integer; Shift: Integer); +begin + with AddRecord do + begin + Size := 8; + if Reg in R64 then + code[0] := $4C + else + code[0] := $48; + code[1] := $8B; + case Reg of + _EAX: code[2] := $84; + _ECX: code[2] := $8C; + _EDX: code[2] := $94; + _EBX: code[2] := $9C; + _ESP: code[2] := $A4; + _EBP: code[2] := $AC; + _ESI: code[2] := $B4; + _EDI: code[2] := $BC; + + _R8: code[2] := $84; + _R9: code[2] := $8C; + _R10: code[2] := $94; + _R11: code[2] := $9C; + _R12: code[2] := $A4; + _R13: code[2] := $AC; + _R14: code[2] := $B4; + _R15: code[2] := $BC; + else + RaiseError(errInternalError, []); + end; + code[3] := $24; + Move(Shift, code[4], 4); + Decompile; + end; +end; + +procedure TSymbolProg.AsmMovREGPtr_REG(Reg1, Reg2: Integer); +begin + if PAX64 then + AsmMovREGPtr_REG64(Reg1, Reg2) + else + AsmMovREGPtr_REG32(Reg1, Reg2); +end; + +procedure TSymbolProg.AsmMovREGPtr_REG64(Reg1, Reg2: Integer); +begin + SwapRegs(Reg1, Reg2); + with AddRecord do + begin + if Reg1 in R32 then + begin + if Reg2 in R64 then + begin + Size := 3; + code[0] := $49; + code[1] := $89; + code[2] := Get64Code(Reg1, Reg2); + end + else + begin + Size := 3; + code[0] := $48; + code[1] := $89; + code[2] := Get64Code(Reg1, Reg2); + end; + end + else if Reg1 in R64 then + begin + Size := 3; + if Reg2 in R64 then + Code[0] := $4D + else + Code[0] := $4C; + Code[1] := $89; + Code[2] := Get64Code(Reg1, Reg2); + end + else + RaiseError(errInternalError, []); + Decompile; + end; +end; + +procedure TSymbolProg.AsmMovREGPtr_REG32(Reg1, Reg2: Integer); +begin + SwapRegs(Reg1, Reg2); + with AddRecord do + begin + if Reg1 in R32 then + begin + if Reg2 in R64 then + begin + Size := 4; + code[0] := $67; + code[1] := $41; + code[2] := $89; + code[3] := Get64Code(Reg1, Reg2); + end + else + begin + Size := 2; + code[0] := $89; + code[1] := Get64Code(Reg1, Reg2); + end; + end + else if Reg1 in R64 then + begin + Size := 3; + if Reg2 in R64 then + Code[0] := $45 + else + Code[0] := $44; + Code[1] := $89; + Code[2] := Get64Code(Reg1, Reg2); + end + else + RaiseError(errInternalError, []); + Decompile; + end; +end; + +procedure TSymbolProg.AsmMovREGPtr_REG16(Reg1, Reg2: Integer); +begin + SwapRegs(Reg1, Reg2); + with AddRecord do + begin + if Reg1 in R32 then + begin + if Reg2 in R64 then + begin + Size := 4; + code[0] := $66; + code[1] := $41; + code[2] := $89; + code[3] := Get64Code(Reg1, Reg2); + end + else + begin + Size := 3; + code[0] := $66; + code[1] := $89; + code[2] := Get64Code(Reg1, Reg2); + end; + end + else if Reg1 in R64 then + begin + Size := 4; + code[0] := $66; + if Reg2 in R64 then + code[1] := $45 + else + code[1] := $44; + code[2] := $89; + code[3] := Get64Code(Reg1, Reg2); + end + else + RaiseError(errInternalError, []); + Decompile; + end; +end; + +procedure TSymbolProg.AsmMovREGPtr_REG8(Reg1, Reg2: Integer); +begin + SwapRegs(Reg1, Reg2); + with AddRecord do + begin + if Reg1 in R32 then + begin + if Reg2 in R64 then + begin + Size := 3; + code[0] := $41; + code[1] := $88; + code[2] := Get64Code(Reg1, Reg2); + end + else + begin + Size := 2; + code[0] := $88; + code[1] := Get64Code(Reg1, Reg2); + end; + end + else if Reg1 in R64 then + begin + Size := 3; + if Reg2 in R64 then + code[0] := $45 + else + code[0] := $44; + code[1] := $88; + Code[2] := Get64Code(Reg1, Reg2); + end + else + RaiseError(errInternalError, []); + Decompile; + end; +exit; + with AddRecord do + begin + Size := 2; + code[0] := $88; + case Reg1 of + _EAX: + case Reg2 of + _EAX: code[1] := $00; + _ECX: code[1] := $08; + _EDX: code[1] := $10; + _EBX: code[1] := $18; + else + RaiseError(errInternalError, []); + end; + _ECX: + case Reg2 of + _EAX: code[1] := $01; + _ECX: code[1] := $09; + _EDX: code[1] := $11; + _EBX: code[1] := $19; + else + RaiseError(errInternalError, []); + end; + _EDX: + case Reg2 of + _EAX: code[1] := $02; + _ECX: code[1] := $0A; + _EDX: code[1] := $12; + _EBX: code[1] := $1A; + else + RaiseError(errInternalError, []); + end; + _EBX: + case Reg2 of + _EAX: code[1] := $03; + _ECX: code[1] := $0B; + _EDX: code[1] := $13; + _EBX: code[1] := $1B; + else + RaiseError(errInternalError, []); + end; + else + RaiseError(errInternalError, []); + end; + Decompile; + end; +end; + +function TSymbolProg.AsmAddREG_Imm(Reg: Integer; value: Integer): TSymbolProgRec; +begin + result := AddRecord; + with result do + begin + if PAX64 then + begin + Size := 7; + if Reg in R64 then + code[0] := $49 + else + code[0] := $48; + + code[1] := $81; + case Reg of + _EAX: code[2] := $C0; + _ECX: code[2] := $C1; + _EDX: code[2] := $C2; + _EBX: code[2] := $C3; + _ESP: code[2] := $C4; + _EBP: code[2] := $C5; + _ESI: code[2] := $C6; + _EDI: code[2] := $C7; + + _R8: code[2] := $C0; + _R9: code[2] := $C1; + _R10: code[2] := $C2; + _R11: code[2] := $C3; + _R12: code[2] := $C4; + _R13: code[2] := $C5; + _R14: code[2] := $C6; + _R15: code[2] := $C7; + else + RaiseError(errInternalError, []); + end; + Move(value, code[3], 4); + end + else // 32bit + case Reg of + _EAX: + begin + Size := 5; + code[0] := $05; + Move(value, code[1], 4); + end; + _ECX: + begin + Size := 6; + code[0] := $81; + code[1] := $C1; + Move(value, code[2], 4); + end; + _EDX: + begin + Size := 6; + code[0] := $81; + code[1] := $C2; + Move(value, code[2], 4); + end; + _EBX: + begin + Size := 6; + code[0] := $81; + code[1] := $C3; + Move(value, code[2], 4); + end; + _ESP: + begin + Size := 6; + code[0] := $81; + code[1] := $C4; + Move(value, code[2], 4); + end; + _EBP: + begin + Size := 6; + code[0] := $81; + code[1] := $C5; + Move(value, code[2], 4); + end; + else + RaiseError(errInternalError, []); + end; + Decompile; + end; +end; + +procedure TSymbolProg.AsmSubREG_Imm(Reg: Integer; value: IntPax); +begin + with AddRecord do + begin + if PAX64 then + begin + Size := 7; + code[0] := $48; + code[1] := $81; + case Reg of + _EAX: code[2] := $E8; + _ECX: code[2] := $E9; + _EDX: code[2] := $EA; + _EBX: code[2] := $EB; + _ESP: code[2] := $EC; + _EBP: code[2] := $ED; + _ESI: code[2] := $EE; + _EDI: code[2] := $EF; + else + RaiseError(errInternalError, []); + end; + Move(value, code[3], 4); + end + else //32bit + case Reg of + _EAX: + begin + Size := 5; + code[0] := $2D; + Move(value, code[1], 4); + end; + _ECX: + begin + Size := 6; + code[0] := $81; + code[1] := $E9; + Move(value, code[2], 4); + end; + _EDX: + begin + Size := 6; + code[0] := $81; + code[1] := $EA; + Move(value, code[2], 4); + end; + _EBX: + begin + Size := 6; + code[0] := $81; + code[1] := $EB; + Move(value, code[2], 4); + end; + _ESP: + begin + Size := 6; + code[0] := $81; + code[1] := $EC; + Move(value, code[2], 4); + end; + _EBP: + begin + Size := 6; + code[0] := $81; + code[1] := $ED; + Move(value, code[2], 4); + end; + _ESI: + begin + Size := 6; + code[0] := $81; + code[1] := $EE; + Move(value, code[2], 4); + end; + _EDI: + begin + Size := 6; + code[0] := $81; + code[1] := $EF; + Move(value, code[2], 4); + end; + else + RaiseError(errInternalError, []); + end; + Decompile; + end; +end; + +// requires EmitGetAddressRegister +// MOV PTR [REG], Imm + +procedure TSymbolProg.AsmMovREGPtr_Imm(Reg: Integer; S: TSymbolRec; value: IntPax); +var + shift: Integer; +begin + shift := GetOffset(S); + if Reg in CommonRegisters then + Shift := 0; + with AddRecord do + begin + case S.PtrSize of + 1: + begin + Size := 7; + code[0] := $C6; + case Reg of + _EAX: code[1] := $80; + _ECX: code[1] := $81; + _EDX: code[1] := $82; + _EBX: code[1] := $83; + _ESP: code[1] := $84; + _EBP: code[1] := $85; + _ESI: code[1] := $86; + else + RaiseError(errInternalError, []); + end; + Move(shift, code[2], 4); + code[6] := value; + end; + 2: + begin + Size := 9; + code[0] := $66; + code[1] := $C7; + case Reg of + _EAX: code[2] := $80; + _ECX: code[2] := $81; + _EDX: code[2] := $82; + _EBX: code[2] := $83; + _ESP: code[2] := $84; + _EBP: code[2] := $85; + _ESI: code[2] := $86; + else + RaiseError(errInternalError, []); + end; + Move(shift, code[3], 4); + Move(value, code[7], 2); + end; + 4: + begin + Size := 10; + code[0] := $C7; + case Reg of + _EAX: code[1] := $80; + _ECX: code[1] := $81; + _EDX: code[1] := $82; + _EBX: code[1] := $83; + _EBP: code[1] := $85; + _ESI: code[1] := $86; + else + RaiseError(errInternalError, []); + end; + Move(shift, code[2], 4); + Move(value, code[6], 4); + end; + 8: + begin + Size := 11; + code[0] := $48; + code[1] := $C7; + case Reg of + _EAX: code[2] := $80; + _ECX: code[2] := $81; + _EDX: code[2] := $82; + _EBX: code[2] := $83; + _EBP: code[2] := $85; + _ESI: code[2] := $86; + else + RaiseError(errInternalError, []); + end; + Move(shift, code[3], 4); + Move(value, code[7], 4); + end; + else + RaiseError(errInternalError, []); + end; + Decompile; + end; +end; + +// requires EmitGetAddressRegister +// ADD PTR [REG], Imm +procedure TSymbolProg.AsmAddREGPtr_Imm(Reg: Integer; S: TSymbolRec; value: IntPax); +var + shift: Integer; +begin + shift := GetOffset(S); + if Reg in CommonRegisters then + Shift := 0; + + with AddRecord do + begin + + case S.PtrSize of + 1: + begin + Size := 7; + code[0] := $80; + case Reg of + _EAX: code[1] := $80; + _ECX: code[1] := $81; + _EDX: code[1] := $82; + _EBX: code[1] := $83; + _ESP: code[1] := $84; + _EBP: code[1] := $85; + _ESI: code[1] := $86; + else + RaiseError(errInternalError, []); + end; + Move(shift, code[2], 4); + Move(value, code[6], 1); + end; + 2: + begin + Size := 9; + code[0] := $66; + code[1] := $81; + case Reg of + _EAX: code[2] := $80; + _ECX: code[2] := $81; + _EDX: code[2] := $82; + _EBX: code[2] := $83; + _ESP: code[2] := $84; + _EBP: code[2] := $85; + _ESI: code[2] := $86; + else + RaiseError(errInternalError, []); + end; + Move(shift, code[3], 4); + Move(value, code[7], 2); + end; + 4: + begin + Size := 10; + code[0] := $81; + case Reg of + _EAX: code[1] := $80; + _ECX: code[1] := $81; + _EDX: code[1] := $82; + _EBX: code[1] := $83; + _EBP: code[1] := $85; + _ESI: code[1] := $86; + else + RaiseError(errInternalError, []); + end; + Move(shift, code[2], 4); + Move(value, code[6], 4); + end; + 8: + begin + Size := 11; + code[0] := $48; + code[1] := $81; + case Reg of + _EAX: code[2] := $80; + _ECX: code[2] := $81; + _EDX: code[2] := $82; + _EBX: code[2] := $83; + _EBP: code[2] := $85; + _ESI: code[2] := $86; + else + RaiseError(errInternalError, []); + end; + Move(shift, code[3], 4); + Move(value, code[7], 4); + end; + else + RaiseError(errInternalError, []); + end; + Decompile; + end; +end; + +// requires EmitGetAddressRegister +// CMP PTR [REG], Imm +procedure TSymbolProg.AsmCmpREGPtr_Imm(Reg: Integer; S: TSymbolRec; value: IntPax); +var + shift: Integer; +begin + shift := GetOffset(S); + if Reg in CommonRegisters then + Shift := 0; + + with AddRecord do + begin + case S.PtrSize of + 1: + begin + Size := 7; + code[0] := $80; + case Reg of + _EAX: code[1] := $B8; + _ECX: code[1] := $B9; + _EDX: code[1] := $BA; + _EBX: code[1] := $BB; + _ESP: code[1] := $BC; + _EBP: code[1] := $BD; + _ESI: code[1] := $BE; + else + RaiseError(errInternalError, []); + end; + Move(shift, code[2], 4); + Move(value, code[6], 1); + end; + 2: + begin + Size := 9; + code[0] := $66; + code[1] := $81; + case Reg of + _EAX: code[2] := $B8; + _ECX: code[2] := $B9; + _EDX: code[2] := $BA; + _EBX: code[2] := $BB; + _ESP: code[2] := $BC; + _EBP: code[2] := $BD; + _ESI: code[2] := $BE; + else + RaiseError(errInternalError, []); + end; + Move(shift, code[3], 4); + Move(value, code[7], 2); + end; + 4: + begin + Size := 10; + code[0] := $81; + case Reg of + _EAX: code[1] := $B8; + _ECX: code[1] := $B9; + _EDX: code[1] := $BA; + _EBX: code[1] := $BB; + _ESP: code[1] := $BC; + _EBP: code[1] := $BD; + _ESI: code[1] := $BE; + else + RaiseError(errInternalError, []); + end; + Move(shift, code[2], 4); + Move(value, code[6], 4); + end; + 8: + begin + Size := 11; + code[0] := $48; + code[1] := $81; + case Reg of + _EAX: code[2] := $B8; + _ECX: code[2] := $B9; + _EDX: code[2] := $BA; + _EBX: code[2] := $BB; + _ESP: code[2] := $BC; + _EBP: code[2] := $BD; + _ESI: code[2] := $BE; + else + RaiseError(errInternalError, []); + end; + Move(shift, code[3], 4); + Move(value, code[7], 4); + end; + else + RaiseError(errInternalError, []); + end; + Decompile; + end; +end; + +procedure TSymbolProg.AsmIncReg32Ptr(Reg: Integer; shift: Integer); +begin + with AddRecord do + begin + Size := 6; + code[0] := $FF; + case Reg of + _EAX: code[1] := $80; + _ECX: code[1] := $81; + _EDX: code[1] := $82; + _EBX: code[1] := $83; + _EBP: code[1] := $85; + _ESI: code[1] := $86; + _EDI: code[1] := $87; + else + RaiseError(errInternalError, []); + end; + Move(shift, code[2], 4); + Decompile; + end; +end; + +procedure TSymbolProg.AsmIncBytePtr(Reg: Integer; shift: Integer); +begin + with AddRecord do + begin + case Reg of + _ESP: + begin + if Shift <> -12 then + RaiseError(errInternalError, []); + + Size := 4; + Code[0] := $FE; + Code[1] := $44; + Code[2] := $24; + Code[3] := $F4; + Decompile; + end; + else + RaiseError(errInternalError, []); + end; + end; +end; + +procedure TSymbolProg.AsmDecReg32Ptr(Reg: Integer; shift: Integer); +begin + with AddRecord do + begin + Size := 6; + code[0] := $FF; + case Reg of + _EAX: code[1] := $88; + _ECX: code[1] := $89; + _EDX: code[1] := $8A; + _EBX: code[1] := $8B; +// _ESP: code[1] := $8C; special case + _EBP: code[1] := $8D; + _ESI: code[1] := $8E; + _EDI: code[1] := $8F; + else + RaiseError(errInternalError, []); + end; + Move(shift, code[2], 4); + Decompile; + end; +end; + +procedure TSymbolProg.AsmCmpReg32Ptr_Imm(Reg: Integer; shift: Integer; value: Integer); +begin + with AddRecord do + begin + Size := 10; + code[0] := $81; + case Reg of + _EAX: code[1] := $B8; + _ECX: code[1] := $B9; + _EDX: code[1] := $BA; + _EBX: code[1] := $BB; + _ESP: code[1] := $BC; + _EBP: code[1] := $BD; + _ESI: code[1] := $BE; + else + RaiseError(errInternalError, []); + end; + Move(shift, code[2], 4); + Move(value, code[6], 4); + Decompile; + end; +end; + +procedure TSymbolProg.AsmAddREG_REG(Reg1, Reg2: Integer); +begin + if PAX64 then + with AddRecord do + begin + Size := 3; + code[0] := $48; + code[1] := $01; + case Reg1 of + _EAX: + case Reg2 of + _EAX: code[2] := $C0; + _ECX: code[2] := $C8; + _EDX: code[2] := $D0; + _EBX: code[2] := $D8; + else + RaiseError(errInternalError, []); + end; + _ECX: + case Reg2 of + _EAX: code[2] := $C1; + _ECX: code[2] := $C9; + _EDX: code[2] := $D1; + _EBX: code[2] := $D9; + else + RaiseError(errInternalError, []); + end; + _EDX: + case Reg2 of + _EAX: code[2] := $C2; + _ECX: code[2] := $CA; + _EDX: code[2] := $D2; + _EBX: code[2] := $DA; + else + RaiseError(errInternalError, []); + end; + _EBX: + case Reg2 of + _EAX: code[2] := $C3; + _ECX: code[2] := $CB; + _EDX: code[2] := $D3; + _EBX: code[2] := $DB; + else + RaiseError(errInternalError, []); + end; + else + RaiseError(errInternalError, []); + end; + Decompile; + end + else //32bit + with AddRecord do + begin + Size := 2; + code[0] := $01; + case Reg1 of + _EAX: + case Reg2 of + _EAX: code[1] := $C0; + _ECX: code[1] := $C8; + _EDX: code[1] := $D0; + _EBX: code[1] := $D8; + else + RaiseError(errInternalError, []); + end; + _ECX: + case Reg2 of + _EAX: code[1] := $C1; + _ECX: code[1] := $C9; + _EDX: code[1] := $D1; + _EBX: code[1] := $D9; + else + RaiseError(errInternalError, []); + end; + _EDX: + case Reg2 of + _EAX: code[1] := $C2; + _ECX: code[1] := $CA; + _EDX: code[1] := $D2; + _EBX: code[1] := $DA; + else + RaiseError(errInternalError, []); + end; + _EBX: + case Reg2 of + _EAX: code[1] := $C3; + _ECX: code[1] := $CB; + _EDX: code[1] := $D3; + _EBX: code[1] := $DB; + else + RaiseError(errInternalError, []); + end; + else + RaiseError(errInternalError, []); + end; + Decompile; + end; +end; + +procedure TSymbolProg.AsmAdcREG_REG(Reg1, Reg2: Integer); +begin + if PAX64 then + with AddRecord do + begin + Size := 3; + code[0] := $48; + code[1] := $11; + case Reg1 of + _EAX: + case Reg2 of + _EAX: code[2] := $C0; + _ECX: code[2] := $C8; + _EDX: code[2] := $D0; + _EBX: code[2] := $D8; + else + RaiseError(errInternalError, []); + end; + _ECX: + case Reg2 of + _EAX: code[2] := $C1; + _ECX: code[2] := $C9; + _EDX: code[2] := $D1; + _EBX: code[2] := $D9; + else + RaiseError(errInternalError, []); + end; + _EDX: + case Reg2 of + _EAX: code[2] := $C2; + _ECX: code[2] := $CA; + _EDX: code[2] := $D2; + _EBX: code[2] := $DA; + else + RaiseError(errInternalError, []); + end; + _EBX: + case Reg2 of + _EAX: code[2] := $C3; + _ECX: code[2] := $CB; + _EDX: code[2] := $D3; + _EBX: code[2] := $DB; + else + RaiseError(errInternalError, []); + end; + else + RaiseError(errInternalError, []); + end; + Decompile; + end + else //32bit + with AddRecord do + begin + Size := 2; + code[0] := $11; + case Reg1 of + _EAX: + case Reg2 of + _EAX: code[1] := $C0; + _ECX: code[1] := $C8; + _EDX: code[1] := $D0; + _EBX: code[1] := $D8; + else + RaiseError(errInternalError, []); + end; + _ECX: + case Reg2 of + _EAX: code[1] := $C1; + _ECX: code[1] := $C9; + _EDX: code[1] := $D1; + _EBX: code[1] := $D9; + else + RaiseError(errInternalError, []); + end; + _EDX: + case Reg2 of + _EAX: code[1] := $C2; + _ECX: code[1] := $CA; + _EDX: code[1] := $D2; + _EBX: code[1] := $DA; + else + RaiseError(errInternalError, []); + end; + _EBX: + case Reg2 of + _EAX: code[1] := $C3; + _ECX: code[1] := $CB; + _EDX: code[1] := $D3; + _EBX: code[1] := $DB; + else + RaiseError(errInternalError, []); + end; + else + RaiseError(errInternalError, []); + end; + Decompile; + end; +end; + +procedure TSymbolProg.AsmSbbREG_REG(Reg1, Reg2: Integer); +begin + if PAX64 then + with AddRecord do + begin + Size := 3; + code[0] := $48; + code[1] := $19; + case Reg1 of + _EAX: + case Reg2 of + _EAX: code[2] := $C0; + _ECX: code[2] := $C8; + _EDX: code[2] := $D0; + _EBX: code[2] := $D8; + else + RaiseError(errInternalError, []); + end; + _ECX: + case Reg2 of + _EAX: code[2] := $C1; + _ECX: code[2] := $C9; + _EDX: code[2] := $D1; + _EBX: code[2] := $D9; + else + RaiseError(errInternalError, []); + end; + _EDX: + case Reg2 of + _EAX: code[2] := $C2; + _ECX: code[2] := $CA; + _EDX: code[2] := $D2; + _EBX: code[2] := $DA; + else + RaiseError(errInternalError, []); + end; + _EBX: + case Reg2 of + _EAX: code[2] := $C3; + _ECX: code[2] := $CB; + _EDX: code[2] := $D3; + _EBX: code[2] := $DB; + else + RaiseError(errInternalError, []); + end; + else + RaiseError(errInternalError, []); + end; + Decompile; + end + else //32bit + with AddRecord do + begin + Size := 2; + code[0] := $19; + case Reg1 of + _EAX: + case Reg2 of + _EAX: code[1] := $C0; + _ECX: code[1] := $C8; + _EDX: code[1] := $D0; + _EBX: code[1] := $D8; + else + RaiseError(errInternalError, []); + end; + _ECX: + case Reg2 of + _EAX: code[1] := $C1; + _ECX: code[1] := $C9; + _EDX: code[1] := $D1; + _EBX: code[1] := $D9; + else + RaiseError(errInternalError, []); + end; + _EDX: + case Reg2 of + _EAX: code[1] := $C2; + _ECX: code[1] := $CA; + _EDX: code[1] := $D2; + _EBX: code[1] := $DA; + else + RaiseError(errInternalError, []); + end; + _EBX: + case Reg2 of + _EAX: code[1] := $C3; + _ECX: code[1] := $CB; + _EDX: code[1] := $D3; + _EBX: code[1] := $DB; + else + RaiseError(errInternalError, []); + end; + else + RaiseError(errInternalError, []); + end; + Decompile; + end; +end; + +procedure TSymbolProg.AsmSubREG_REG(Reg1, Reg2: Integer); +begin + if PAX64 then + with AddRecord do + begin + Size := 3; + code[0] := $48; + code[1] := $29; + case Reg1 of + _EAX: + case Reg2 of + _EAX: code[2] := $C0; + _ECX: code[2] := $C8; + _EDX: code[2] := $D0; + _EBX: code[2] := $D8; + else + RaiseError(errInternalError, []); + end; + _ECX: + case Reg2 of + _EAX: code[2] := $C1; + _ECX: code[2] := $C9; + _EDX: code[2] := $D1; + _EBX: code[2] := $D9; + else + RaiseError(errInternalError, []); + end; + _EDX: + case Reg2 of + _EAX: code[2] := $C2; + _ECX: code[2] := $CA; + _EDX: code[2] := $D2; + _EBX: code[2] := $DA; + else + RaiseError(errInternalError, []); + end; + _EBX: + case Reg2 of + _EAX: code[2] := $C3; + _ECX: code[2] := $CB; + _EDX: code[2] := $D3; + _EBX: code[2] := $DB; + else + RaiseError(errInternalError, []); + end; + else + RaiseError(errInternalError, []); + end; + Decompile; + end + else //32bit + with AddRecord do + begin + Size := 2; + code[0] := $29; + case Reg1 of + _EAX: + case Reg2 of + _EAX: code[1] := $C0; + _ECX: code[1] := $C8; + _EDX: code[1] := $D0; + _EBX: code[1] := $D8; + else + RaiseError(errInternalError, []); + end; + _ECX: + case Reg2 of + _EAX: code[1] := $C1; + _ECX: code[1] := $C9; + _EDX: code[1] := $D1; + _EBX: code[1] := $D9; + else + RaiseError(errInternalError, []); + end; + _EDX: + case Reg2 of + _EAX: code[1] := $C2; + _ECX: code[1] := $CA; + _EDX: code[1] := $D2; + _EBX: code[1] := $DA; + else + RaiseError(errInternalError, []); + end; + _EBX: + case Reg2 of + _EAX: code[1] := $C3; + _ECX: code[1] := $CB; + _EDX: code[1] := $D3; + _EBX: code[1] := $DB; + else + RaiseError(errInternalError, []); + end; + else + RaiseError(errInternalError, []); + end; + Decompile; + end; +end; + +procedure TSymbolProg.AsmXorREG_REG(Reg1, Reg2: Integer); +begin + if PAX64 then + with AddRecord do + begin + Size := 3; + code[0] := $48; + code[1] := $31; + case Reg1 of + _EAX: + case Reg2 of + _EAX: code[2] := $C0; + _ECX: code[2] := $C8; + _EDX: code[2] := $D0; + _EBX: code[2] := $D8; + else + RaiseError(errInternalError, []); + end; + _ECX: + case Reg2 of + _EAX: code[2] := $C1; + _ECX: code[2] := $C9; + _EDX: code[2] := $D1; + _EBX: code[2] := $D9; + else + RaiseError(errInternalError, []); + end; + _EDX: + case Reg2 of + _EAX: code[2] := $C2; + _ECX: code[2] := $CA; + _EDX: code[2] := $D2; + _EBX: code[2] := $DA; + else + RaiseError(errInternalError, []); + end; + _EBX: + case Reg2 of + _EAX: code[2] := $C3; + _ECX: code[2] := $CB; + _EDX: code[2] := $D3; + _EBX: code[2] := $DB; + else + RaiseError(errInternalError, []); + end; + else + RaiseError(errInternalError, []); + end; + Decompile; + end + else //32bit + with AddRecord do + begin + Size := 2; + code[0] := $31; + case Reg1 of + _EAX: + case Reg2 of + _EAX: code[1] := $C0; + _ECX: code[1] := $C8; + _EDX: code[1] := $D0; + _EBX: code[1] := $D8; + else + RaiseError(errInternalError, []); + end; + _ECX: + case Reg2 of + _EAX: code[1] := $C1; + _ECX: code[1] := $C9; + _EDX: code[1] := $D1; + _EBX: code[1] := $D9; + else + RaiseError(errInternalError, []); + end; + _EDX: + case Reg2 of + _EAX: code[1] := $C2; + _ECX: code[1] := $CA; + _EDX: code[1] := $D2; + _EBX: code[1] := $DA; + else + RaiseError(errInternalError, []); + end; + _EBX: + case Reg2 of + _EAX: code[1] := $C3; + _ECX: code[1] := $CB; + _EDX: code[1] := $D3; + _EBX: code[1] := $DB; + else + RaiseError(errInternalError, []); + end; + else + RaiseError(errInternalError, []); + end; + Decompile; + end; +end; + +procedure TSymbolProg.AsmAndREG_REG(Reg1, Reg2: Integer); +begin + if PAX64 then + with AddRecord do + begin + Size := 3; + code[0] := $48; + code[1] := $21; + case Reg1 of + _EAX: + case Reg2 of + _EAX: code[2] := $C0; + _ECX: code[2] := $C8; + _EDX: code[2] := $D0; + _EBX: code[2] := $D8; + else + RaiseError(errInternalError, []); + end; + _ECX: + case Reg2 of + _EAX: code[2] := $C1; + _ECX: code[2] := $C9; + _EDX: code[2] := $D1; + _EBX: code[2] := $D9; + else + RaiseError(errInternalError, []); + end; + _EDX: + case Reg2 of + _EAX: code[2] := $C2; + _ECX: code[2] := $CA; + _EDX: code[2] := $D2; + _EBX: code[2] := $DA; + else + RaiseError(errInternalError, []); + end; + _EBX: + case Reg2 of + _EAX: code[2] := $C3; + _ECX: code[2] := $CB; + _EDX: code[2] := $D3; + _EBX: code[2] := $DB; + else + RaiseError(errInternalError, []); + end; + else + RaiseError(errInternalError, []); + end; + Decompile; + end + else //32bit + with AddRecord do + begin + Size := 2; + code[0] := $21; + case Reg1 of + _EAX: + case Reg2 of + _EAX: code[1] := $C0; + _ECX: code[1] := $C8; + _EDX: code[1] := $D0; + _EBX: code[1] := $D8; + else + RaiseError(errInternalError, []); + end; + _ECX: + case Reg2 of + _EAX: code[1] := $C1; + _ECX: code[1] := $C9; + _EDX: code[1] := $D1; + _EBX: code[1] := $D9; + else + RaiseError(errInternalError, []); + end; + _EDX: + case Reg2 of + _EAX: code[1] := $C2; + _ECX: code[1] := $CA; + _EDX: code[1] := $D2; + _EBX: code[1] := $DA; + else + RaiseError(errInternalError, []); + end; + _EBX: + case Reg2 of + _EAX: code[1] := $C3; + _ECX: code[1] := $CB; + _EDX: code[1] := $D3; + _EBX: code[1] := $DB; + else + RaiseError(errInternalError, []); + end; + else + RaiseError(errInternalError, []); + end; + Decompile; + end; +end; + +procedure TSymbolProg.AsmOrREG_REG(Reg1, Reg2: Integer); +begin + if PAX64 then + with AddRecord do + begin + Size := 3; + code[0] := $48; + code[1] := $09; + case Reg1 of + _EAX: + case Reg2 of + _EAX: code[2] := $C0; + _ECX: code[2] := $C8; + _EDX: code[2] := $D0; + _EBX: code[2] := $D8; + else + RaiseError(errInternalError, []); + end; + _ECX: + case Reg2 of + _EAX: code[2] := $C1; + _ECX: code[2] := $C9; + _EDX: code[2] := $D1; + _EBX: code[2] := $D9; + else + RaiseError(errInternalError, []); + end; + _EDX: + case Reg2 of + _EAX: code[2] := $C2; + _ECX: code[2] := $CA; + _EDX: code[2] := $D2; + _EBX: code[2] := $DA; + else + RaiseError(errInternalError, []); + end; + _EBX: + case Reg2 of + _EAX: code[2] := $C3; + _ECX: code[2] := $CB; + _EDX: code[2] := $D3; + _EBX: code[2] := $DB; + else + RaiseError(errInternalError, []); + end; + else + RaiseError(errInternalError, []); + end; + Decompile; + end + else //32bit + with AddRecord do + begin + Size := 2; + code[0] := $09; + case Reg1 of + _EAX: + case Reg2 of + _EAX: code[1] := $C0; + _ECX: code[1] := $C8; + _EDX: code[1] := $D0; + _EBX: code[1] := $D8; + else + RaiseError(errInternalError, []); + end; + _ECX: + case Reg2 of + _EAX: code[1] := $C1; + _ECX: code[1] := $C9; + _EDX: code[1] := $D1; + _EBX: code[1] := $D9; + else + RaiseError(errInternalError, []); + end; + _EDX: + case Reg2 of + _EAX: code[1] := $C2; + _ECX: code[1] := $CA; + _EDX: code[1] := $D2; + _EBX: code[1] := $DA; + else + RaiseError(errInternalError, []); + end; + _EBX: + case Reg2 of + _EAX: code[1] := $C3; + _ECX: code[1] := $CB; + _EDX: code[1] := $D3; + _EBX: code[1] := $DB; + else + RaiseError(errInternalError, []); + end; + else + RaiseError(errInternalError, []); + end; + Decompile; + end; +end; + +procedure TSymbolProg.AsmMulREG(Reg: Integer); +begin + if PAX64 then + with AddRecord do + begin + Size := 3; + code[0] := $48; + code[1] := $F7; + case Reg of + _EAX: code[2] := $E0; + _ECX: code[2] := $E1; + _EDX: code[2] := $E2; + _EBX: code[2] := $E3; + else + RaiseError(errInternalError, []); + end; + Decompile; + end + else //32bit + with AddRecord do + begin + Size := 2; + code[0] := $F7; + case Reg of + _EAX: code[1] := $E0; + _ECX: code[1] := $E1; + _EDX: code[1] := $E2; + _EBX: code[1] := $E3; + else + RaiseError(errInternalError, []); + end; + Decompile; + end; +end; + +procedure TSymbolProg.AsmIMulREG(Reg: Integer); +begin + if PAX64 then + with AddRecord do + begin + Size := 3; + code[0] := $48; + code[1] := $F7; + case Reg of + _EAX: code[2] := $E8; + _ECX: code[2] := $E9; + _EDX: code[2] := $EA; + _EBX: code[2] := $EB; + else + RaiseError(errInternalError, []); + end; + Decompile; + end + else //32bit + with AddRecord do + begin + Size := 2; + code[0] := $F7; + case Reg of + _EAX: code[1] := $E8; + _ECX: code[1] := $E9; + _EDX: code[1] := $EA; + _EBX: code[1] := $EB; + else + RaiseError(errInternalError, []); + end; + Decompile; + end; +end; + +procedure TSymbolProg.AsmDivREG(Reg: Integer); +begin + if PAX64 then + with AddRecord do + begin + Size := 3; + code[0] := $48; + code[1] := $F7; + case Reg of + _EAX: code[2] := $F0; + _ECX: code[2] := $F1; + _EDX: code[2] := $F2; + _EBX: code[2] := $F3; + else + RaiseError(errInternalError, []); + end; + Decompile; + end + else //32bit + with AddRecord do + begin + Size := 2; + code[0] := $F7; + case Reg of + _EAX: code[1] := $F0; + _ECX: code[1] := $F1; + _EDX: code[1] := $F2; + _EBX: code[1] := $F3; + else + RaiseError(errInternalError, []); + end; + Decompile; + end; +end; + +procedure TSymbolProg.AsmIDivREG(Reg: Integer); +begin + if PAX64 then + with AddRecord do + begin + Size := 3; + code[0] := $48; + code[1] := $F7; + case Reg of + _EAX: code[2] := $F8; + _ECX: code[2] := $F9; + _EDX: code[2] := $FA; + _EBX: code[2] := $FB; + else + RaiseError(errInternalError, []); + end; + Decompile; + end + else //32bit + with AddRecord do + begin + Size := 2; + code[0] := $F7; + case Reg of + _EAX: code[1] := $F8; + _ECX: code[1] := $F9; + _EDX: code[1] := $FA; + _EBX: code[1] := $FB; + else + RaiseError(errInternalError, []); + end; + Decompile; + end; +end; + +procedure TSymbolProg.AsmShlREG(Reg: Integer); +begin + if PAX64 then + with AddRecord do + begin + Size := 3; + code[0] := $48; + code[1] := $D3; + case Reg of + _EAX: code[2] := $E0; + _ECX: code[2] := $E1; + _EDX: code[2] := $E2; + _EBX: code[2] := $E3; + else + RaiseError(errInternalError, []); + end; + Decompile; + end + else //32bit + with AddRecord do + begin + Size := 2; + code[0] := $D3; + case Reg of + _EAX: code[1] := $E0; + _ECX: code[1] := $E1; + _EDX: code[1] := $E2; + _EBX: code[1] := $E3; + else + RaiseError(errInternalError, []); + end; + Decompile; + end; +end; + +procedure TSymbolProg.AsmShrREG(Reg: Integer); +begin + if PAX64 then + with AddRecord do + begin + Size := 3; + code[0] := $48; + code[1] := $D3; + case Reg of + _EAX: code[2] := $E8; + _ECX: code[2] := $E9; + _EDX: code[2] := $EA; + _EBX: code[2] := $EB; + else + RaiseError(errInternalError, []); + end; + Decompile; + end + else + with AddRecord do + begin + Size := 2; + code[0] := $D3; + case Reg of + _EAX: code[1] := $E8; + _ECX: code[1] := $E9; + _EDX: code[1] := $EA; + _EBX: code[1] := $EB; + else + RaiseError(errInternalError, []); + end; + Decompile; + end; +end; + +procedure TSymbolProg.AsmNotREG(Reg: Integer); +begin + if PAX64 then + with AddRecord do + begin + Size := 3; + code[0] := $48; + code[1] := $F7; + case Reg of + _EAX: code[2] := $D0; + _ECX: code[2] := $D1; + _EDX: code[2] := $D2; + _EBX: code[2] := $D3; + else + RaiseError(errInternalError, []); + end; + Decompile; + end + else + with AddRecord do + begin + Size := 2; + code[0] := $F7; + case Reg of + _EAX: code[1] := $D0; + _ECX: code[1] := $D1; + _EDX: code[1] := $D2; + _EBX: code[1] := $D3; + else + RaiseError(errInternalError, []); + end; + Decompile; + end; +end; + +procedure TSymbolProg.AsmNegREG(Reg: Integer); +begin + if PAX64 then + with AddRecord do + begin + Size := 3; + code[0] := $48; + code[1] := $F7; + case Reg of + _EAX: code[2] := $D8; + _ECX: code[2] := $D9; + _EDX: code[2] := $DA; + _EBX: code[2] := $DB; + else + RaiseError(errInternalError, []); + end; + Decompile; + end + else + with AddRecord do + begin + Size := 2; + code[0] := $F7; + case Reg of + _EAX: code[1] := $D8; + _ECX: code[1] := $D9; + _EDX: code[1] := $DA; + _EBX: code[1] := $DB; + else + RaiseError(errInternalError, []); + end; + Decompile; + end; +end; + +// requires EmitGetAddressRegister +// NEG PTR [REG + Shift] +procedure TSymbolProg.AsmNEG_REGPtr(Reg: Integer; S: TSymbolRec); +var + shift: Integer; +begin + shift := GetOffset(S); + if Reg in CommonRegisters then + Shift := 0; + + case S.PtrSize of + 4: + begin + with AddRecord do + begin + Size := 6; + code[0] := $F7; + + case Reg of + _EAX: code[1] := $98; + _ECX: code[1] := $99; + _EDX: code[1] := $9A; + _EBX: code[1] := $9B; + _ESP: code[1] := $9C; + _EBP: code[1] := $9D; + _ESI: code[1] := $9E; + else + RaiseError(errInternalError, []); + end; + + Move(shift, code[2], 4); + Decompile; + end; + end; + 8: + begin + with AddRecord do + begin + Size := 7; + code[0] := $48; + code[1] := $F7; + + case Reg of + _EAX: code[2] := $98; + _ECX: code[2] := $99; + _EDX: code[2] := $9A; + _EBX: code[2] := $9B; + _ESP: code[2] := $9C; + _EBP: code[2] := $9D; + _ESI: code[2] := $9E; + else + RaiseError(errInternalError, []); + end; + + Move(shift, code[3], 4); + Decompile; + end; + end; + else + RaiseError(errInternalError, []); + end; +end; + +procedure TSymbolProg.AsmLoadESI_ESPPtr(shift: Integer); // not used +begin + with AddRecord do + begin + Size := 7; + code[0] := $8B; + code[1] := $B4; + code[2] := $24; + Move(shift, code[3], 4); + Decompile; + end; +end; + +procedure TSymbolProg.AsmLoadEDI_ESPPtr(shift: Integer); // not used +begin + with AddRecord do + begin + Size := 7; + code[0] := $8B; + code[1] := $BC; + code[2] := $24; + Move(shift, code[3], 4); + Decompile; + end; +end; + +function TSymbolProg.AsmGetREG_ESIPtr(Reg: Integer; shift: Integer): TSymbolProgRec; +begin + if PAX64 then + result := AsmGetREG64_RSIPtr(Reg, shift) + else + result := AsmGetREG32_ESIPtr(Reg, shift); +end; + +function TSymbolProg.AsmGetREG64_RSIPtr(Reg: Integer; shift: Integer): TSymbolProgRec; +begin + result := AddRecord; + with result do + begin + Size := 7; + if Reg in R64 then + code[0] := $4C + else + code[0] := $48; + code[1] := $8B; + code[2] := GetMovESIPtrCode(Reg); + Move(shift, code[3], 4); + Decompile; + end; +end; + +function TSymbolProg.AsmGetREG32_ESIPtr(Reg: Integer; shift: Integer): TSymbolProgRec; +begin + result := AddRecord; + if Reg in R64 then + with result do + begin + Size := 7; + code[0] := $44; + code[1] := $8B; + code[2] := GetMovESIPtrCode(Reg); + Move(shift, code[3], 4); + Decompile; + end + else + with result do + begin + Size := 6; + code[0] := $8B; + code[1] := GetMovESIPtrCode(Reg); + Move(shift, code[2], 4); + Decompile; + end; +end; + +procedure TSymbolProg.AsmGetREG16_ESIPtr(Reg: Integer; shift: Integer); +begin + if Reg in R64 then + with AddRecord do + begin + Size := 8; + code[0] := $66; + code[1] := $44; + code[2] := $8B; + code[3] := GetMovESIPtrCode(Reg); + Move(shift, code[4], 4); + Decompile; + end + else + with AddRecord do + begin + Size := 7; + code[0] := $66; + code[1] := $8B; + code[2] := GetMovESIPtrCode(Reg); + Move(shift, code[3], 4); + Decompile; + end; +end; + +procedure TSymbolProg.AsmGetREG8_ESIPtr(Reg: Integer; shift: Integer); +begin + if Reg in R64 then + with AddRecord do + begin + Size := 7; + code[0] := $44; + code[1] := $8A; + code[2] := GetMovESIPtrCode(Reg); + Move(shift, code[3], 4); + Decompile; + end + else + with AddRecord do + begin + Size := 6; + code[0] := $8A; + code[1] := GetMovESIPtrCode(Reg); + Move(shift, code[2], 4); + Decompile; + end; +end; + +procedure TSymbolProg.AsmPutREG_ESIPtr(Reg: Integer; shift: Integer); +begin + if PAX64 then + AsmPutREG64_RSIPtr(Reg, shift) + else + AsmPutREG32_ESIPtr(Reg, shift); +end; + +procedure TSymbolProg.AsmPutREG64_RSIPtr(Reg: Integer; shift: Integer); +begin + with AddRecord do + begin + Size := 7; + if Reg in R64 then + code[0] := $4C + else + code[0] := $48; + code[1] := $89; + code[2] := GetMovESIPtrCode(Reg); + Move(shift, code[3], 4); + Decompile; + end; +end; + +procedure TSymbolProg.AsmPutREG32_ESIPtr(Reg: Integer; shift: Integer); +begin + if Reg in R64 then + with AddRecord do + begin + Size := 7; + code[0] := $44; + code[1] := $89; + code[2] := GetMovESIPtrCode(Reg); + Move(shift, code[3], 4); + Decompile; + end + else + with AddRecord do + begin + Size := 6; + code[0] := $89; + code[1] := GetMovESIPtrCode(Reg); + Move(shift, code[2], 4); + Decompile; + end; +end; + +procedure TSymbolProg.AsmPutREG16_ESIPtr(Reg: Integer; shift: Integer); +begin + if Reg in R64 then + with AddRecord do + begin + Size := 8; + code[0] := $66; + code[1] := $44; + code[2] := $89; + code[3] := GetMovESIPtrCode(Reg); + Move(shift, code[4], 4); + Decompile; + end + else + with AddRecord do + begin + Size := 7; + code[0] := $66; + code[1] := $89; + code[2] := GetMovESIPtrCode(Reg); + Move(shift, code[3], 4); + Decompile; + end; +end; + +procedure TSymbolProg.AsmPutREG8_ESIPtr(Reg: Integer; shift: Integer); +begin + if Reg in R64 then + with AddRecord do + begin + Size := 7; + code[0] := $44; + code[1] := $88; + code[2] := GetMovESIPtrCode(Reg); + Move(shift, code[3], 4); + Decompile; + end + else + with AddRecord do + begin + Size := 6; + code[0] := $88; + code[1] := GetMovESIPtrCode(Reg); + Move(shift, code[2], 4); + Decompile; + end; +end; + +procedure TSymbolProg.AsmLeaReg32_RegPtr(Reg1, Reg2: Integer; shift: Integer); +begin + with AddRecord do + begin + Size := 6; + code[0] := $8D; + case Reg1 of + _EAX: + case Reg2 of + _EAX: code[1] := $80; + _ECX: code[1] := $81; + _EDX: code[1] := $82; + _EBX: code[1] := $83; + + _EBP: code[1] := $85; + _ESI: code[1] := $86; + _EDI: code[1] := $87; + else + RaiseError(errInternalError, []); + end; + _ECX: + case Reg2 of + _EAX: code[1] := $88; + _ECX: code[1] := $89; + _EDX: code[1] := $8A; + _EBX: code[1] := $8B; + + _EBP: code[1] := $8D; + _ESI: code[1] := $8E; + _EDI: code[1] := $8F; + else + RaiseError(errInternalError, []); + end; + _EDX: + case Reg2 of + _EAX: code[1] := $90; + _ECX: code[1] := $91; + _EDX: code[1] := $92; + _EBX: code[1] := $93; + + _EBP: code[1] := $95; + _ESI: code[1] := $96; + _EDI: code[1] := $97; + else + RaiseError(errInternalError, []); + end; + _EBX: + case Reg2 of + _EAX: code[1] := $98; + _ECX: code[1] := $99; + _EDX: code[1] := $9A; + _EBX: code[1] := $9B; + + _EBP: code[1] := $9D; + _ESI: code[1] := $9E; + _EDI: code[1] := $9F; + else + RaiseError(errInternalError, []); + end; + else + RaiseError(errInternalError, []); + end; + Move(shift, code[2], 4); + Decompile; + end; +end; + +procedure TSymbolProg.AsmGetREG_EBPPtr(Reg: Integer; shift: Integer); +begin + if PAX64 then + AsmGetREG64_RBPPtr(Reg, shift) + else + AsmGetREG32_EBPPtr(Reg, shift); +end; + +procedure TSymbolProg.AsmGetREG64_RBPPtr(Reg: Integer; shift: Integer); +begin + if Reg in R64 then + with AddRecord do + begin + Size := 7; + code[0] := $4C; + code[1] := $8B; + code[2] := GetMovEBPPtrCode(Reg); + Move(shift, code[3], 4); + Decompile; + end + else + with AddRecord do + begin + Size := 7; + code[0] := $48; + code[1] := $8B; + code[2] := GetMovEBPPtrCode(Reg); + Move(shift, code[3], 4); + Decompile; + end; +end; + +procedure TSymbolProg.AsmGetREG32_EBPPtr(Reg: Integer; shift: Integer); +begin + if Reg in R64 then + with AddRecord do + begin + Size := 7; + code[0] := $44; + code[1] := $8B; + code[2] := GetMovEBPPtrCode(Reg); + Move(shift, code[3], 4); + Decompile; + end + else + with AddRecord do + begin + Size := 6; + code[0] := $8B; + code[1] := GetMovEBPPtrCode(Reg); + Move(shift, code[2], 4); + Decompile; + end; +end; + +procedure TSymbolProg.AsmGetREG16_EBPPtr(Reg: Integer; shift: Integer); +begin + if Reg in R64 then + with AddRecord do + begin + Size := 8; + code[0] := $66; + code[1] := $44; + code[2] := $8B; + code[3] := GetMovEBPPtrCode(Reg); + Move(shift, code[4], 4); + Decompile; + end + else + with AddRecord do + begin + Size := 7; + code[0] := $66; + code[1] := $8B; + code[2] := GetMovEBPPtrCode(Reg); + Move(shift, code[3], 4); + Decompile; + end; +end; + +procedure TSymbolProg.AsmPutREG_EBPPtr(Reg: Integer; shift: Integer); +begin + if PAX64 then + AsmPutREG64_RBPPtr(Reg, shift) + else + AsmPutREG32_EBPPtr(Reg, shift); +end; + +procedure TSymbolProg.AsmPutREG64_RBPPtr(Reg: Integer; shift: Integer); +begin + if Reg in R64 then + with AddRecord do + begin + Size := 7; + code[0] := $4C; + code[1] := $89; + code[2] := GetMovEBPPtrCode(Reg); + Move(shift, code[3], 4); + Decompile; + end + else + with AddRecord do + begin + Size := 7; + code[0] := $48; + code[1] := $89; + code[2] := GetMovEBPPtrCode(Reg); + Move(shift, code[3], 4); + Decompile; + end; +end; + +procedure TSymbolProg.AsmPutREG32_EBPPtr(Reg: Integer; shift: Integer); +begin + if Reg in R64 then + with AddRecord do + begin + Size := 7; + code[0] := $44; + code[1] := $89; + code[2] := GetMovEBPPtrCode(Reg); + Move(shift, code[3], 4); + Decompile; + end + else + with AddRecord do + begin + Size := 6; + code[0] := $89; + code[1] := GetMovEBPPtrCode(Reg); + Move(shift, code[2], 4); + Decompile; + end; +end; + +procedure TSymbolProg.AsmPutREG16_EBPPtr(Reg: Integer; shift: Integer); +begin + if Reg in R64 then + with AddRecord do + begin + Size := 8; + code[0] := $66; + code[1] := $44; + code[2] := $89; + code[3] := GetMovEBPPtrCode(Reg); + Move(shift, code[4], 4); + Decompile; + end + else + with AddRecord do + begin + Size := 7; + code[0] := $66; + code[1] := $89; + code[2] := GetMovEBPPtrCode(Reg); + Move(shift, code[3], 4); + Decompile; + end; +end; + +procedure TSymbolProg.AsmGetREG8_EBPPtr(Reg: Integer; shift: Integer); +begin + if Reg in R64 then + with AddRecord do + begin + Size := 7; + code[0] := $44; + code[1] := $8A; + code[2] := GetMovEBPPtrCode(Reg); + Move(shift, code[3], 4); + Decompile; + end + else + with AddRecord do + begin + Size := 6; + code[0] := $8A; + code[1] := GetMovEBPPtrCode(Reg); + Move(shift, code[2], 4); + Decompile; + end; +end; + +procedure TSymbolProg.AsmPutREG8_EBPPtr(Reg: Integer; shift: Integer); +begin + if Reg in R64 then + with AddRecord do + begin + Size := 7; + code[0] := $44; + code[1] := $88; + code[2] := GetMovEBPPtrCode(Reg); + Move(shift, code[3], 4); + Decompile; + end + else + with AddRecord do + begin + Size := 6; + code[0] := $88; + code[1] := GetMovEBPPtrCode(Reg); + Move(shift, code[2], 4); + Decompile; + end; +end; + +procedure TSymbolProg.AsmFldDouble_REGPtr(Reg: Integer); +begin + with AddRecord do + begin + Size := 2; + code[0] := $DD; + case Reg of + _EAX: code[1] := $00; + _ECX: code[1] := $01; + _EDX: code[1] := $02; + _EBX: code[1] := $03; + else + RaiseError(errInternalError, []); + end; + Decompile; + end; +end; + +procedure TSymbolProg.AsmFldSingle_REGPtr(Reg: Integer); +begin + with AddRecord do + begin + Size := 2; + code[0] := $D9; + case Reg of + _EAX: code[1] := $00; + _ECX: code[1] := $01; + _EDX: code[1] := $02; + _EBX: code[1] := $03; + else + RaiseError(errInternalError, []); + end; + Decompile; + end; +end; + +procedure TSymbolProg.AsmFldExtended_REGPtr(Reg: Integer); +begin + with AddRecord do + begin + Size := 2; + code[0] := $DB; + case Reg of + _EAX: code[1] := $28; + _ECX: code[1] := $29; + _EDX: code[1] := $2A; + _EBX: code[1] := $2B; + else + RaiseError(errInternalError, []); + end; + Decompile; + end; +end; + +// requires EmitGetAddressRegister +// Fld QWORD PTR [REG + Shift] +procedure TSymbolProg.AsmFldDouble_REGPtr(Reg: Integer; S: TSymbolRec); +var + shift: Integer; +begin + shift := GetOffset(S); + if Reg in CommonRegisters then + Shift := 0; + + if PAX64 then + with AddRecord do + begin + Size := 7; + code[0] := $48; + code[1] := $DD; + case Reg of + _EAX: code[2] := $80; + _ECX: code[2] := $81; + _EDX: code[2] := $82; + _EBX: code[2] := $83; + _EBP: code[2] := $85; + _ESI: code[2] := $86; + else + RaiseError(errInternalError, []); + end; + Move(shift, code[3], 4); + Decompile; + end + else // 32bit + with AddRecord do + begin + Size := 6; + code[0] := $DD; + case Reg of + _EAX: code[1] := $80; + _ECX: code[1] := $81; + _EDX: code[1] := $82; + _EBX: code[1] := $83; + _EBP: code[1] := $85; + _ESI: code[1] := $86; + else + RaiseError(errInternalError, []); + end; + Move(shift, code[2], 4); + Decompile; + end; +end; + +// requires EmitGetAddressRegister +// Fld DWORD PTR [REG + Shift] +procedure TSymbolProg.AsmFldSingle_REGPtr(Reg: Integer; S: TSymbolRec); +var + shift: Integer; +begin + shift := GetOffset(S); + if Reg in CommonRegisters then + Shift := 0; + + with AddRecord do + begin + Size := 6; + code[0] := $D9; + case Reg of + _EAX: code[1] := $80; + _ECX: code[1] := $81; + _EDX: code[1] := $82; + _EBX: code[1] := $83; + _EBP: code[1] := $85; + _ESI: code[1] := $86; + else + RaiseError(errInternalError, []); + end; + Move(shift, code[2], 4); + Decompile; + end; +end; + +// requires EmitGetAddressRegister +// Fld TBYTE PTR [REG + Shift] +procedure TSymbolProg.AsmFldExtended_REGPtr(Reg: Integer; S: TSymbolRec); +var + shift: Integer; +begin + shift := GetOffset(S); + if Reg in CommonRegisters then + Shift := 0; + + with AddRecord do + begin + Size := 6; + code[0] := $DB; + case Reg of + _EAX: code[1] := $A8; + _ECX: code[1] := $A9; + _EDX: code[1] := $AA; + _EBX: code[1] := $AB; + _EBP: code[1] := $AD; + _ESI: code[1] := $AE; + else + RaiseError(errInternalError, []); + end; + Move(shift, code[2], 4); + Decompile; + end; +end; + +procedure TSymbolProg.AsmFild_REG32Ptr(Reg: Integer); +begin + with AddRecord do + begin + Size := 2; + code[0] := $DB; + case Reg of + _EAX: code[1] := $00; + _ECX: code[1] := $01; + _EDX: code[1] := $02; + _EBX: code[1] := $03; + _ESI: code[1] := $06; + _EDI: code[1] := $07; + else + RaiseError(errInternalError, []); + end; + Decompile; + end; +end; + +procedure TSymbolProg.AsmFild_REG16Ptr(Reg: Integer); +begin + with AddRecord do + begin + Size := 2; + code[0] := $DF; + case Reg of + _EAX: code[1] := $00; + _ECX: code[1] := $01; + _EDX: code[1] := $02; + _EBX: code[1] := $03; + _ESI: code[1] := $06; + _EDI: code[1] := $07; + else + RaiseError(errInternalError, []); + end; + Decompile; + end; +end; + +procedure TSymbolProg.AsmFild_REG64Ptr(Reg: Integer); +begin + with AddRecord do + begin + Size := 2; + code[0] := $DF; + case Reg of + _EAX: code[1] := $28; + _ECX: code[1] := $29; + _EDX: code[1] := $2A; + _EBX: code[1] := $2B; + else + RaiseError(errInternalError, []); + end; + Decompile; + end; +end; + +procedure TSymbolProg.AsmFistp_REG64Ptr(Reg: Integer); +begin + with AddRecord do + begin + Size := 2; + code[0] := $DF; + case Reg of + _EAX: code[1] := $38; + _ECX: code[1] := $39; + _EDX: code[1] := $3A; + _EBX: code[1] := $3B; + else + RaiseError(errInternalError, []); + end; + Decompile; + end; +end; + +procedure TSymbolProg.AsmFAdd_REGPtr(Reg: Integer); +begin + with AddRecord do + begin + Size := 2; + code[0] := $DC; + case Reg of + _EAX: code[1] := $00; + _ECX: code[1] := $01; + _EDX: code[1] := $02; + _EBX: code[1] := $03; + else + RaiseError(errInternalError, []); + end; + Decompile; + end; +end; + +procedure TSymbolProg.AsmFSub_REGPtr(Reg: Integer); +begin + with AddRecord do + begin + Size := 2; + code[0] := $DC; + case Reg of + _EAX: code[1] := $20; + _ECX: code[1] := $21; + _EDX: code[1] := $22; + _EBX: code[1] := $23; + else + RaiseError(errInternalError, []); + end; + Decompile; + end; +end; + +procedure TSymbolProg.AsmFMul_REGPtr(Reg: Integer); +begin + with AddRecord do + begin + Size := 2; + code[0] := $DC; + case Reg of + _EAX: code[1] := $08; + _ECX: code[1] := $09; + _EDX: code[1] := $0A; + _EBX: code[1] := $0B; + else + RaiseError(errInternalError, []); + end; + Decompile; + end; +end; + +procedure TSymbolProg.AsmFMul_ESIPtr32(Shift: Integer); +begin + with AddRecord do + begin + Size := 6; + code[0] := $D8; + code[1] := $8E; + Move(Shift, code[2], 4); + Decompile; + end; +end; + +procedure TSymbolProg.AsmFDiv_ESIPtr32(Shift: Integer); +begin + with AddRecord do + begin + Size := 6; + code[0] := $D8; + code[1] := $B6; + Move(Shift, code[2], 4); + Decompile; + end; +end; + +procedure TSymbolProg.AsmFDiv_REGPtr(Reg: Integer); +begin + with AddRecord do + begin + Size := 2; + code[0] := $DC; + case Reg of + _EAX: code[1] := $30; + _ECX: code[1] := $31; + _EDX: code[1] := $32; + _EBX: code[1] := $33; + else + RaiseError(errInternalError, []); + end; + Decompile; + end; +end; + +procedure TSymbolProg.AsmFComp_REGPtr(Reg: Integer); +begin + with AddRecord do + begin + Size := 2; + code[0] := $D8; + case Reg of + _EAX: code[1] := $18; + _ECX: code[1] := $19; + _EDX: code[1] := $1A; + _EBX: code[1] := $1B; + else + RaiseError(errInternalError, []); + end; + Decompile; + end; +end; + +procedure TSymbolProg.AsmFAdd; +begin + with AddRecord do + begin + Size := 2; + code[0] := $DE; + code[1] := $C1; + Decompile; + end; +end; + +procedure TSymbolProg.AsmFSub; +begin + with AddRecord do + begin + Size := 2; + code[0] := $DE; + code[1] := $E9; + Decompile; + end; +end; + +procedure TSymbolProg.AsmFMul; +begin + with AddRecord do + begin + Size := 2; + code[0] := $DE; + code[1] := $C9; + Decompile; + end; +end; + +procedure TSymbolProg.AsmFDiv; +begin + with AddRecord do + begin + Size := 2; + code[0] := $DE; + code[1] := $F9; + Decompile; + end; +end; + +procedure TSymbolProg.AsmFChs; +begin + with AddRecord do + begin + Size := 2; + code[0] := $D9; + code[1] := $E0; + Decompile; + end; +end; + +procedure TSymbolProg.AsmFAbs; +begin + with AddRecord do + begin + Size := 2; + code[0] := $D9; + code[1] := $E1; + Decompile; + end; +end; + +procedure TSymbolProg.AsmFCompP; +begin + with AddRecord do + begin + Size := 2; + code[0] := $DE; + code[1] := $D9; + Decompile; + end; +end; + +procedure TSymbolProg.AsmFstsw_AX; +begin + with AddRecord do + begin + Size := 2; + code[0] := $DF; + code[1] := $E0; + Decompile; + end; +end; + +procedure TSymbolProg.AsmSahv; +begin + with AddRecord do + begin + Size := 1; + code[0] := $9E; + Decompile; + end; +end; + +procedure TSymbolProg.AsmCDQ; +begin + with AddRecord do + begin + Size := 1; + code[0] := $99; + Decompile; + end; +end; + +procedure TSymbolProg.AsmSetL_REGPtr(Reg: Integer); +begin + with AddRecord do + begin + Size := 3; + code[0] := $0F; + code[1] := $9C; + case Reg of + _EAX: code[2] := $00; + _ECX: code[2] := $01; + _EDX: code[2] := $02; + _EBX: code[2] := $03; + else + RaiseError(errInternalError, []); + end; + Decompile; + end; +end; + +procedure TSymbolProg.AsmSetLE_REGPtr(Reg: Integer); +begin + with AddRecord do + begin + Size := 3; + code[0] := $0F; + code[1] := $9E; + case Reg of + _EAX: code[2] := $00; + _ECX: code[2] := $01; + _EDX: code[2] := $02; + _EBX: code[2] := $03; + else + RaiseError(errInternalError, []); + end; + Decompile; + end; +end; + +procedure TSymbolProg.AsmSetNLE_REGPtr(Reg: Integer); +begin + with AddRecord do + begin + Size := 3; + code[0] := $0F; + code[1] := $9F; + case Reg of + _EAX: code[2] := $00; + _ECX: code[2] := $01; + _EDX: code[2] := $02; + _EBX: code[2] := $03; + else + RaiseError(errInternalError, []); + end; + Decompile; + end; +end; + +procedure TSymbolProg.AsmSetNL_REGPtr(Reg: Integer); +begin + with AddRecord do + begin + Size := 3; + code[0] := $0F; + code[1] := $9D; + case Reg of + _EAX: code[2] := $00; + _ECX: code[2] := $01; + _EDX: code[2] := $02; + _EBX: code[2] := $03; + else + RaiseError(errInternalError, []); + end; + Decompile; + end; +end; + +procedure TSymbolProg.AsmSetB_REGPtr(Reg: Integer); +begin + with AddRecord do + begin + Size := 3; + code[0] := $0F; + code[1] := $92; + case Reg of + _EAX: code[2] := $00; + _ECX: code[2] := $01; + _EDX: code[2] := $02; + _EBX: code[2] := $03; + else + RaiseError(errInternalError, []); + end; + Decompile; + end; +end; + +procedure TSymbolProg.AsmSet_REGPtr(ASM_OP, Reg: Integer; S: TSymbolRec); +var + shift: Integer; +begin + with AddRecord do + begin + shift := GetOffset(S); + + Size := 7; + code[0] := $0F; + + if ASM_OP = ASM_SETB then code[1] := $92 + else if ASM_OP = ASM_SETNB then code[1] := $93 + else if ASM_OP = ASM_SETZ then code[1] := $94 + else if ASM_OP = ASM_SETNZ then code[1] := $95 + else if ASM_OP = ASM_SETBE then code[1] := $96 + else if ASM_OP = ASM_SETNBE then code[1] := $97 + else if ASM_OP = ASM_SETL then code[1] := $9C + else if ASM_OP = ASM_SETNL then code[1] := $9D + else if ASM_OP = ASM_SETLE then code[1] := $9E + else if ASM_OP = ASM_SETNLE then code[1] := $9F + else + RaiseError(errInternalError, []); + + case Reg of + _EAX: code[2] := $80; + _ECX: code[2] := $81; + _EDX: code[2] := $82; + _EBX: code[2] := $83; + _EBP: code[2] := $85; + _ESI: code[2] := $86; + else + RaiseError(errInternalError, []); + end; + Move(shift, code[3], 4); + Decompile; + end; +end; + +procedure TSymbolProg.AsmSetBE_REGPtr(Reg: Integer); +begin + with AddRecord do + begin + Size := 3; + code[0] := $0F; + code[1] := $96; + case Reg of + _EAX: code[2] := $00; + _ECX: code[2] := $01; + _EDX: code[2] := $02; + _EBX: code[2] := $03; + else + RaiseError(errInternalError, []); + end; + Decompile; + end; +end; + +procedure TSymbolProg.AsmSetNBE_REGPtr(Reg: Integer); +begin + with AddRecord do + begin + Size := 3; + code[0] := $0F; + code[1] := $97; + case Reg of + _EAX: code[2] := $00; + _ECX: code[2] := $01; + _EDX: code[2] := $02; + _EBX: code[2] := $03; + else + RaiseError(errInternalError, []); + end; + Decompile; + end; +end; + +procedure TSymbolProg.AsmSetNB_REGPtr(Reg: Integer); +begin + with AddRecord do + begin + Size := 3; + code[0] := $0F; + code[1] := $93; + case Reg of + _EAX: code[2] := $00; + _ECX: code[2] := $01; + _EDX: code[2] := $02; + _EBX: code[2] := $03; + else + RaiseError(errInternalError, []); + end; + Decompile; + end; +end; + +procedure TSymbolProg.AsmSetZ_REGPtr(Reg: Integer); +begin + with AddRecord do + begin + Size := 3; + code[0] := $0F; + code[1] := $94; + case Reg of + _EAX: code[2] := $00; + _ECX: code[2] := $01; + _EDX: code[2] := $02; + _EBX: code[2] := $03; + else + RaiseError(errInternalError, []); + end; + Decompile; + end; +end; + +procedure TSymbolProg.AsmSetNZ_REGPtr(Reg: Integer); +begin + with AddRecord do + begin + Size := 3; + code[0] := $0F; + code[1] := $95; + case Reg of + _EAX: code[2] := $00; + _ECX: code[2] := $01; + _EDX: code[2] := $02; + _EBX: code[2] := $03; + else + RaiseError(errInternalError, []); + end; + Decompile; + end; +end; + +procedure TSymbolProg.AsmFstpDouble_REGPtr(Reg: Integer); +begin + with AddRecord do + begin + Size := 2; + code[0] := $DD; + case Reg of + _EAX: code[1] := $18; + _ECX: code[1] := $19; + _EDX: code[1] := $1A; + _EBX: code[1] := $1B; + else + RaiseError(errInternalError, []); + end; + Decompile; + end; +end; + +procedure TSymbolProg.AsmFstpSingle_REGPtr(Reg: Integer); +begin + with AddRecord do + begin + Size := 2; + code[0] := $D9; + case Reg of + _EAX: code[1] := $18; + _ECX: code[1] := $19; + _EDX: code[1] := $1A; + _EBX: code[1] := $1B; + else + RaiseError(errInternalError, []); + end; + Decompile; + end; +end; + +// FStp TBYTE PTR [REG] +procedure TSymbolProg.AsmFstpExtended_REGPtr(Reg: Integer); +begin + with AddRecord do + begin + Size := 2; + code[0] := $DB; + case Reg of + _EAX: code[1] := $38; + _ECX: code[1] := $39; + _EDX: code[1] := $3A; + _EBX: code[1] := $3B; + else + RaiseError(errInternalError, []); + end; + Decompile; + end; +end; + +// requires EmitGetAddressRegister +// FStp QWORD PTR [REG + Shift] +procedure TSymbolProg.AsmFstpDouble_REGPtr(Reg: Integer; S: TSymbolRec); +var + shift: Integer; +begin + shift := GetOffset(S); + if Reg in CommonRegisters then + Shift := 0; + + if PAX64 then + with AddRecord do + begin + Size := 7; + code[0] := $48; + code[1] := $DD; + case Reg of + _EAX: code[2] := $98; + _ECX: code[2] := $99; + _EDX: code[2] := $9A; + _EBX: code[2] := $9B; + _EBP: code[2] := $9D; + _ESI: code[2] := $9E; + else + RaiseError(errInternalError, []); + end; + Move(shift, code[3], 4); + Decompile; + end + else + with AddRecord do + begin + Size := 6; + code[0] := $DD; + case Reg of + _EAX: code[1] := $98; + _ECX: code[1] := $99; + _EDX: code[1] := $9A; + _EBX: code[1] := $9B; + _EBP: code[1] := $9D; + _ESI: code[1] := $9E; + else + RaiseError(errInternalError, []); + end; + Move(shift, code[2], 4); + Decompile; + end; +end; + +// requires EmitGetAddressRegister +// FStp DWORD PTR [REG + Shift] +procedure TSymbolProg.AsmFstpSingle_REGPtr(Reg: Integer; S: TSymbolRec); +var + shift: Integer; +begin + shift := GetOffset(S); + if Reg in CommonRegisters then + Shift := 0; + + with AddRecord do + begin + Size := 6; + code[0] := $D9; + case Reg of + _EAX: code[1] := $98; + _ECX: code[1] := $99; + _EDX: code[1] := $9A; + _EBX: code[1] := $9B; + _EBP: code[1] := $9D; + _ESI: code[1] := $9E; + else + RaiseError(errInternalError, []); + end; + Move(shift, code[2], 4); + Decompile; + end; +end; + +// requires EmitGetAddressRegister +// FStp TBYTE PTR [REG + Shift] +procedure TSymbolProg.AsmFstpExtended_REGPtr(Reg: Integer; S: TSymbolRec); +var + shift: Integer; +begin + shift := GetOffset(S); + if Reg in CommonRegisters then + Shift := 0; + + if PAX64 then + with AddRecord do + begin + Size := 7; + code[0] := $48; + code[1] := $DB; + case Reg of + _EAX: code[2] := $B8; + _ECX: code[2] := $B9; + _EDX: code[2] := $BA; + _EBX: code[2] := $BB; + _EBP: code[2] := $BD; + _ESI: code[2] := $BE; + else + RaiseError(errInternalError, []); + end; + Move(shift, code[3], 4); + Decompile; + end + else //32bit + with AddRecord do + begin + Size := 6; + code[0] := $DB; + case Reg of + _EAX: code[1] := $B8; + _ECX: code[1] := $B9; + _EDX: code[1] := $BA; + _EBX: code[1] := $BB; + _EBP: code[1] := $BD; + _ESI: code[1] := $BE; + else + RaiseError(errInternalError, []); + end; + Move(shift, code[2], 4); + Decompile; + end; +end; + +procedure TSymbolProg.AsmCmpByteREGPtr_Imm(Reg: Integer; value: Byte); +begin + with AddRecord do + begin + Size := 3; + code[0] := $80; + case Reg of + _EAX: code[1] := $38; + _ECX: code[1] := $39; + _EDX: code[1] := $3A; + _EBX: code[1] := $3B; + else + RaiseError(errInternalError, []); + end; + code[2] := value; + Decompile; + end; +end; + +function TSymbolProg.AsmJmp_REG(Reg: Integer): TSymbolProgRec; +begin + result := AddRecord; + with result do + begin + Size := 2; + code[0] := $FF; + case Reg of + _EAX: code[1] := $E0; + _ECX: code[1] := $E1; + _EDX: code[1] := $E2; + _EBX: code[1] := $E3; + else + begin + if Reg in [_R8.._R15] then + begin + Size := 3; + code[0] := $49; + code[1] := $FF; + case Reg of + _R8: code[2] := $E0; + _R9: code[2] := $E1; + _R10: code[2] := $E2; + _R11: code[2] := $E3; + _R12: code[2] := $E4; + _R13: code[2] := $E5; + _R14: code[2] := $E6; + _R15: code[2] := $E7; + end; + end + else + RaiseError(errInternalError, []); + end; + end; + Decompile; + end; +end; + +procedure TSymbolProg.AsmCall_REG(Reg: Integer); +begin + if PAX64 then + begin + with AddRecord do + begin + Size := 3; + code[0] := $48; + code[1] := $FF; + case Reg of + _EAX: code[2] := $D0; + _ECX: code[2] := $D1; + _EDX: code[2] := $D2; + _EBX: code[2] := $D3; + _ESP: code[2] := $D4; + _EBP: code[2] := $D5; + _ESI: code[2] := $D6; + _EDI: code[2] := $D7; + else + RaiseError(errInternalError, []); + end; + Decompile; + end; + end + else + with AddRecord do + begin + Size := 2; + code[0] := $FF; + case Reg of + _EAX: code[1] := $D0; + _ECX: code[1] := $D1; + _EDX: code[1] := $D2; + _EBX: code[1] := $D3; + _ESP: code[1] := $D4; + _EBP: code[1] := $D5; + _ESI: code[1] := $D6; + _EDI: code[1] := $D7; + else + RaiseError(errInternalError, []); + end; + Decompile; + end; +end; + +procedure TSymbolProg.AsmPush_Imm(value: Integer); +begin + with AddRecord do + begin + Size := 5; + code[0] := $68; + Move(value, code[1], 4); + Decompile; + end; +end; + +function TSymbolProg.AsmPush_REG(Reg: Integer): TSymbolProgRec; +begin + result := AddRecord; + if Reg in R64 then + with result do + begin + Size := 2; + code[0] := $41; + case Reg of + _R8: code[1] := $50; + _R9: code[1] := $51; + _R10: code[1] := $52; + _R11: code[1] := $53; + _R12: code[1] := $54; + _R13: code[1] := $55; + _R14: code[1] := $56; + _R15: code[1] := $57; + else + RaiseError(errInternalError, []); + end; + Decompile; + end + else + with result do + begin + Size := 1; + case Reg of + _EAX: code[0] := $50; + _ECX: code[0] := $51; + _EDX: code[0] := $52; + _EBX: code[0] := $53; + _ESP: code[0] := $54; + _EBP: code[0] := $55; + _ESI: code[0] := $56; + _EDI: code[0] := $57; + else + RaiseError(errInternalError, []); + end; + Decompile; + end; +end; + +function TSymbolProg.AsmPop_REG(Reg: Integer): TSymbolProgRec; +begin + result := AddRecord; + if Reg in R64 then + with result do + begin + Size := 2; + code[0] := $41; + case Reg of + _R8: code[1] := $58; + _R9: code[1] := $59; + _R10: code[1] := $5A; + _R11: code[1] := $5B; + _R12: code[1] := $5C; + _R13: code[1] := $5D; + _R14: code[1] := $5E; + _R15: code[1] := $5F; + else + RaiseError(errInternalError, []); + end; + Decompile; + end + else + with result do + begin + Size := 1; + case Reg of + _EAX: code[0] := $58; + _ECX: code[0] := $59; + _EDX: code[0] := $5A; + _EBX: code[0] := $5B; + _ESP: code[0] := $5C; + _EBP: code[0] := $5D; + _ESI: code[0] := $5E; + _EDI: code[0] := $5F; + else + RaiseError(errInternalError, []); + end; + Decompile; + end; +end; + +procedure TSymbolProg.AsmPush_REGPtr(Reg: Integer); +begin + with AddRecord do + begin + Size := 2; + code[0] := $FF; + case Reg of + _EAX: code[1] := $30; + _ECX: code[1] := $31; + _EDX: code[1] := $32; + _EBX: code[1] := $33; + else + RaiseError(errInternalError, []); + end; + Decompile; + end; +end; + +procedure TSymbolProg.AsmPush_FS_REGPtr(Reg: Integer); +begin + with AddRecord do + begin + Size := 3; + code[0] := $64; + code[1] := $FF; + case Reg of + _EAX: code[2] := $30; + _ECX: code[2] := $31; + _EDX: code[2] := $32; + _EBX: code[2] := $33; + else + RaiseError(errInternalError, []); + end; + Decompile; + end; +end; + +procedure TSymbolProg.AsmPush_Reg16(Reg: Integer); +begin + with AddRecord do + begin + Size := 2; + code[0] := $66; + case Reg of + _EAX: code[1] := $50; + _ECX: code[1] := $51; + _EDX: code[1] := $52; + _EBX: code[1] := $53; + else + RaiseError(errInternalError, []); + end; + Decompile; + end; +end; + +procedure TSymbolProg.AsmRet(value: Word = 0); +begin + with AddRecord do + begin + if value = 0 then + begin + Size := 1; + code[0] := $c3; + end + else + begin + Size := 3; + code[0] := $c2; + Move(value, code[1], 2); + end; + Decompile; + end; +end; + +procedure TSymbolProg.AsmNop; +begin + with AddRecord do + begin + Size := 1; + code[0] := $90; + Decompile; + end; +end; + +procedure TSymbolProg.AsmWait; +begin + with AddRecord do + begin + Size := 1; + code[0] := $9B; + Decompile; + end; +end; + +procedure TSymbolProg.AsmClc; +begin + with AddRecord do + begin + Size := 1; + code[0] := $F8; + Decompile; + end; +end; + +procedure TSymbolProg.AsmPushfd; +begin + with AddRecord do + begin + Size := 1; + code[0] := $9C; + Decompile; + end; +end; + +procedure TSymbolProg.AsmPopfd; +begin + with AddRecord do + begin + Size := 1; + code[0] := $9D; + Decompile; + end; +end; + +procedure TSymbolProg.AsmXCHG(Reg1, Reg2: Integer); +begin + with AddRecord do + begin + if Reg2 = _EAX then + begin + Reg2 := Reg1; + Reg1 := _EAX; + end; + + if Reg1 = _EAX then + begin + Size := 1; + case Reg2 of + _EAX: code[0] := $90; // nop + _ECX: code[0] := $91; + _EDX: code[0] := $92; + _EBX: code[0] := $93; + _ESP: code[0] := $94; + _EBP: code[0] := $95; + _ESI: code[0] := $96; + _EDI: code[0] := $97; + else + RaiseError(errInternalError, []); + end; + end + else if Reg1 = _ECX then + begin + Size := 2; + code[0] := $87; + case Reg2 of + _ECX: code[1] := $C9; + _EDX: code[1] := $CA; + _EBX: code[1] := $CB; + _ESP: code[1] := $CC; + _EBP: code[1] := $CD; + _ESI: code[1] := $CE; + _EDI: code[1] := $CF; + else + RaiseError(errInternalError, []); + end; + end + else if Reg1 = _EDX then + begin + Size := 2; + code[0] := $87; + case Reg2 of + _ECX: code[1] := $D1; + _EDX: code[1] := $D2; + _EBX: code[1] := $D3; + _ESP: code[1] := $D4; + _EBP: code[1] := $D5; + _ESI: code[1] := $D6; + _EDI: code[1] := $D7; + else + RaiseError(errInternalError, []); + end; + end + else if Reg1 = _EBX then + begin + Size := 2; + code[0] := $87; + case Reg2 of + _ECX: code[1] := $D9; + _EDX: code[1] := $DA; + _EBX: code[1] := $DB; + _ESP: code[1] := $DC; + _EBP: code[1] := $DD; + _ESI: code[1] := $DE; + _EDI: code[1] := $DF; + else + RaiseError(errInternalError, []); + end; + end + else + RaiseError(errInternalError, []); + + Decompile; + end; +end; + +procedure TSymbolProg.AsmJMP_Imm(value: Integer); +begin + with AddRecord do + begin + Size := 5; + code[0] := $E9; + Move(value, code[1], 4); + Decompile; + end; +end; + +procedure TSymbolProg.AsmJNO_Imm(value: Byte); +begin + with AddRecord do + begin + Size := 2; + code[0] := $71; + code[1] := value; + Decompile; + end; +end; + +procedure TSymbolProg.AsmJNC_Imm(value: Byte); +begin + with AddRecord do + begin + Size := 2; + code[0] := $73; + code[1] := value; + Decompile; + end; +end; + +procedure TSymbolProg.AsmJZ_Imm(value: SmallInt); +begin + with AddRecord do + begin + Size := 2; + code[0] := $74; + code[1] := value; + Decompile; + end; +end; + +procedure TSymbolProg.AsmJNZ_Imm(value: SmallInt); +begin + with AddRecord do + begin + Size := 2; + code[0] := $75; + code[1] := value; + Decompile; + end; +end; + +procedure TSymbolProg.AsmJBE_Imm(value: Byte); +begin + with AddRecord do + begin + Size := 2; + code[0] := $76; + code[1] := value; + Decompile; + end; +end; + +procedure TSymbolProg.AsmJNLE_Imm(value: Byte); +begin + with AddRecord do + begin + Size := 2; + code[0] := $7F; + code[1] := value; + Decompile; + end; +end; + + +procedure TSymbolProg.AsmRep_MOVSB; +begin + with AddRecord do + begin + Size := 2; + code[0] := $F3; + code[1] := $A4; + Decompile; + end; +end; + +procedure TSymbolProg.AsmRep_MOVSD; +begin + with AddRecord do + begin + Size := 2; + code[0] := $F3; + code[1] := $A5; + Decompile; + end; +end; + +procedure TSymbolProg.AsmCvtsd2ssXMM_RegPtr(XMMReg, Reg: Integer); +begin + with AddRecord do + begin + Size := 4; + code[0] := $F2; + code[1] := $0F; + code[2] := $5A; + case XMMReg of + _XMM0: + case Reg of + _EAX: code[3] := $00; + _ECX: code[3] := $01; + _EDX: code[3] := $02; + _EBX: code[3] := $03; + else + RaiseError(errInternalError, []); + end; + _XMM1: + case Reg of + _EAX: code[3] := $08; + _ECX: code[3] := $09; + _EDX: code[3] := $0A; + _EBX: code[3] := $0B; + else + RaiseError(errInternalError, []); + end; + _XMM2: + case Reg of + _EAX: code[3] := $10; + _ECX: code[3] := $11; + _EDX: code[3] := $12; + _EBX: code[3] := $13; + else + RaiseError(errInternalError, []); + end; + _XMM3: + case Reg of + _EAX: code[3] := $18; + _ECX: code[3] := $19; + _EDX: code[3] := $1A; + _EBX: code[3] := $1B; + else + RaiseError(errInternalError, []); + end; + _XMM4: + case Reg of + _EAX: code[3] := $20; + _ECX: code[3] := $21; + _EDX: code[3] := $22; + _EBX: code[3] := $23; + else + RaiseError(errInternalError, []); + end; + else + RaiseError(errInternalError, []); + end; + Decompile; + end; +end; + +procedure TSymbolProg.AsmCvtss2sdXMM_RegPtr(XMMReg, Reg: Integer); +begin + with AddRecord do + begin + Size := 4; + code[0] := $F3; + code[1] := $0F; + code[2] := $5A; + case XMMReg of + _XMM0: + case Reg of + _EAX: code[3] := $00; + _ECX: code[3] := $01; + _EDX: code[3] := $02; + _EBX: code[3] := $03; + else + RaiseError(errInternalError, []); + end; + _XMM1: + case Reg of + _EAX: code[3] := $08; + _ECX: code[3] := $09; + _EDX: code[3] := $0A; + _EBX: code[3] := $0B; + else + RaiseError(errInternalError, []); + end; + _XMM2: + case Reg of + _EAX: code[3] := $10; + _ECX: code[3] := $11; + _EDX: code[3] := $12; + _EBX: code[3] := $13; + else + RaiseError(errInternalError, []); + end; + _XMM3: + case Reg of + _EAX: code[3] := $18; + _ECX: code[3] := $19; + _EDX: code[3] := $1A; + _EBX: code[3] := $1B; + else + RaiseError(errInternalError, []); + end; + _XMM4: + case Reg of + _EAX: code[3] := $20; + _ECX: code[3] := $21; + _EDX: code[3] := $22; + _EBX: code[3] := $23; + else + RaiseError(errInternalError, []); + end; + else + RaiseError(errInternalError, []); + end; + Decompile; + end; +end; + +procedure TSymbolProg.AsmMovsdXMM_RegPtr(XMMReg, Reg: Integer); +begin + with AddRecord do + begin + Size := 6; + code[0] := $67; + code[1] := $F2; + code[2] := $48; + code[3] := $0F; + code[4] := $10; + case XMMReg of + _XMM0: + case Reg of + _EAX: code[5] := $00; + _ECX: code[5] := $01; + _EDX: code[5] := $02; + _EBX: code[5] := $03; + else + RaiseError(errInternalError, []); + end; + _XMM1: + case Reg of + _EAX: code[5] := $08; + _ECX: code[5] := $09; + _EDX: code[5] := $0A; + _EBX: code[5] := $0B; + else + RaiseError(errInternalError, []); + end; + _XMM2: + case Reg of + _EAX: code[5] := $10; + _ECX: code[5] := $11; + _EDX: code[5] := $12; + _EBX: code[5] := $13; + else + RaiseError(errInternalError, []); + end; + _XMM3: + case Reg of + _EAX: code[5] := $18; + _ECX: code[5] := $19; + _EDX: code[5] := $1A; + _EBX: code[5] := $1B; + else + RaiseError(errInternalError, []); + end; + _XMM4: + case Reg of + _EAX: code[5] := $20; + _ECX: code[5] := $21; + _EDX: code[5] := $22; + _EBX: code[5] := $23; + else + RaiseError(errInternalError, []); + end; + else + RaiseError(errInternalError, []); + end; + Decompile; + end; +end; + +procedure TSymbolProg.AsmMovsdRegPtr_XMM(XMMReg, Reg: Integer); +begin + with AddRecord do + begin + Size := 6; + code[0] := $67; + code[1] := $F2; + code[2] := $48; + code[3] := $0F; + code[4] := $11; + case XMMReg of + _XMM0: + case Reg of + _EAX: code[5] := $00; + _ECX: code[5] := $01; + _EDX: code[5] := $02; + _EBX: code[5] := $03; + else + RaiseError(errInternalError, []); + end; + _XMM1: + case Reg of + _EAX: code[5] := $08; + _ECX: code[5] := $09; + _EDX: code[5] := $0A; + _EBX: code[5] := $0B; + else + RaiseError(errInternalError, []); + end; + _XMM2: + case Reg of + _EAX: code[5] := $10; + _ECX: code[5] := $11; + _EDX: code[5] := $12; + _EBX: code[5] := $13; + else + RaiseError(errInternalError, []); + end; + _XMM3: + case Reg of + _EAX: code[5] := $18; + _ECX: code[5] := $19; + _EDX: code[5] := $1A; + _EBX: code[5] := $1B; + else + RaiseError(errInternalError, []); + end; + _XMM4: + case Reg of + _EAX: code[5] := $20; + _ECX: code[5] := $21; + _EDX: code[5] := $22; + _EBX: code[5] := $23; + else + RaiseError(errInternalError, []); + end; + else + RaiseError(errInternalError, []); + end; + Decompile; + end; +end; + +procedure TSymbolProg.AsmMovssXMM_RegPtr(XMMReg, Reg: Integer); +begin + with AddRecord do + begin + Size := 5; + code[0] := $67; + code[1] := $F3; + code[2] := $0F; + code[3] := $10; + case XMMReg of + _XMM0: + case Reg of + _EAX: code[4] := $00; + _ECX: code[4] := $01; + _EDX: code[4] := $02; + _EBX: code[4] := $03; + else + RaiseError(errInternalError, []); + end; + _XMM1: + case Reg of + _EAX: code[4] := $08; + _ECX: code[4] := $09; + _EDX: code[4] := $0A; + _EBX: code[4] := $0B; + else + RaiseError(errInternalError, []); + end; + _XMM2: + case Reg of + _EAX: code[4] := $10; + _ECX: code[4] := $11; + _EDX: code[4] := $12; + _EBX: code[4] := $13; + else + RaiseError(errInternalError, []); + end; + _XMM3: + case Reg of + _EAX: code[4] := $18; + _ECX: code[4] := $19; + _EDX: code[4] := $1A; + _EBX: code[4] := $1B; + else + RaiseError(errInternalError, []); + end; + _XMM4: + case Reg of + _EAX: code[4] := $20; + _ECX: code[4] := $21; + _EDX: code[4] := $22; + _EBX: code[4] := $23; + else + RaiseError(errInternalError, []); + end; + else + RaiseError(errInternalError, []); + end; + Decompile; + end; +end; + +procedure TSymbolProg.AsmMovssRegPtr_XMM(XMMReg, Reg: Integer); +begin + with AddRecord do + begin + Size := 5; + code[0] := $67; + code[1] := $F3; + code[2] := $0F; + code[3] := $11; + case XMMReg of + _XMM0: + case Reg of + _EAX: code[4] := $00; + _ECX: code[4] := $01; + _EDX: code[4] := $02; + _EBX: code[4] := $03; + else + RaiseError(errInternalError, []); + end; + _XMM1: + case Reg of + _EAX: code[4] := $08; + _ECX: code[4] := $09; + _EDX: code[4] := $0A; + _EBX: code[4] := $0B; + else + RaiseError(errInternalError, []); + end; + _XMM2: + case Reg of + _EAX: code[4] := $10; + _ECX: code[4] := $11; + _EDX: code[4] := $12; + _EBX: code[4] := $13; + else + RaiseError(errInternalError, []); + end; + _XMM3: + case Reg of + _EAX: code[4] := $18; + _ECX: code[4] := $19; + _EDX: code[4] := $1A; + _EBX: code[4] := $1B; + else + RaiseError(errInternalError, []); + end; + _XMM4: + case Reg of + _EAX: code[4] := $20; + _ECX: code[4] := $21; + _EDX: code[4] := $22; + _EBX: code[4] := $23; + else + RaiseError(errInternalError, []); + end; + else + RaiseError(errInternalError, []); + end; + Decompile; + end; +end; + + +function TSymbolProg.GetRecord(I: Integer): TSymbolProgRec; +begin + result := TSymbolProgRec(L[I - 1]); +end; + +procedure TSymbolProg.Optimization; +var + I: Integer; +begin + for I:= 1 to Card - 2 do + if Records[I].Op = ASM_MOV then + begin + + if Records[I + 1].Op = ASM_MOV then + begin + if EqualArgs(Records[I].Arg1, Records[I+1].Arg2) and + EqualArgs(Records[I].Arg2, Records[I+1].Arg1) then + begin + Records[I+1].Size := 0; + end; + end + else if (Records[I + 2].Op = ASM_MOV) and (Records[I + 1].Size < 0) then + begin + if EqualArgs(Records[I].Arg1, Records[I+2].Arg2) and + EqualArgs(Records[I].Arg2, Records[I+2].Arg1) then + begin + Records[I+2].Size := -1; + end; + end + end; + + for I:=Card downto 1 do + if Records[I].Size = 0 then + Delete(I); +end; + +procedure TSymbolProg.CreateProgramSimple(result: TProgram); +var + I, N, SZ: Integer; +begin + result.AllocateSimple(ProgSize, 0); + N := 0; + for I:=1 to Card do + begin + SZ := Records[I].Size; + if SZ >= 0 then + begin + Move(Records[I].code, result.CodePtr^[N], SZ); + Inc(N, SZ); + end; + end; +end; + +procedure TSymbolProg.CreateProgram(result: TProgram; IsEval: Boolean = false); +var + I, J, K, N, SZ: Integer; + SymbolTable: TSymbolTable; + Shift: Integer; + ProgOffset: Integer; + + Code: TCode; + OP: Integer; + ID: Integer; + TryRec: TTryRec; + ClsIndex: Integer; + ClassRec: TClassRec; + DestructorId, + AfterConstructionId, + BeforeDestructionId, + SafeCallExceptionId, + DispatchId, + DefaultHandlerId, + NewInstanceId, + ToStringId, + FreeInstanceId : Integer; + RR: TSymbolRec; + temp: Boolean; + IntfId: Integer; + InterfaceMethodIds: TIntegerList; + ClassMethodIds: TIntegerList; + IntfRec: TIntfRec; + + UpdatedProgSize, LastCard, NN: Integer; + PaxInfo: PPaxInfo; + PaxFactoryRec: TPaxClassFactoryRec; + SS: String; + InterfaceToObjectOffset: Integer; + RegX, RegY: Integer; + N1, N2: Integer; + MR: TMapRec; +begin + SymbolTable := TKernel(kernel).SymbolTable; + Code := TKernel(kernel).Code; + + if TKernel(kernel).SignCompression then + SZ := TKernel(kernel).OffsetList.GetSize + else + SZ := SymbolTable.GetDataSize + 4096; + + temp := result.UseMapping; + result.UseMapping := false; + result.Allocate(ProgSize, SZ); + result.UseMapping := temp; + + N := 0; + N1 := 0; + for I:=1 to Card do + begin + SZ := Records[I].Size; + if SZ >= 0 then + begin + Records[I].ProgOffset := N; + + Move(Records[I].code, result.CodePtr^[N], SZ); + Inc(N, SZ); + end + else if Records[I].MapSub < 0 then + begin + N1 := N; + end + else if Records[I].MapSub > 0 then + begin + N2 := N; + MR := result.ScriptMapTable.LookupSub(Records[I].MapSub); + if MR <> nil then + MR.SubDesc.SubSize := N2 - N1; + end; + end; + + LastCard := Card; + NN := N; + UpdatedProgSize := ProgSize; + + TKernel(kernel).AllocateConstants(result.ResultPtr); + + with SymbolTable do + for I:=FirstLocalId + 1 to Card do + if Records[I].Host then + begin + RR := SymbolTable[I]; + + if RR.Address <> nil then + begin + if not InCode[I] then + continue; + + if not TKernel(kernel).ExistsOffset(RR) then + begin + continue; + end; + + result.SetAddress(GetOffset(RR), RR.Address); + end + else if RR.ClassIndex <> -1 then + begin + RR := SymbolTable[I + 1]; // cls ref + J := RR.Value; + if J = 0 then + begin + ClassRec := result.ClassList.Add(SymbolTable[I].FullName, SymbolTable[I].Host); + ClassRec.InstSize := SizeOfPointer; + end + else + begin + ClassRec := result.RegisterClass(TClass(Pointer(J)), SymbolTable[I].FullName, GetOffset(RR)); + ClassRec.InstSize := TClass(Pointer(J)).InstanceSize; + end; + ClassRec.ParentFullName := Records[Records[I].AncestorId].FullName; + end; + end + else + if Records[I].ClassIndex > 0 then + begin + ClassRec := result.ClassList.Add(Records[I].FullName, Records[I].Host); + ClassRec.Host := false; + ClassRec.Offset := GetOffset(Records[I + 1]); + ClassRec.SizeOfScriptClassFields := Records[I].GetSizeOfScriptClassFields; + + ClassRec.PClass := TClass(IntPax(Records[I + 1].Value)); + ClassRec.ParentFullName := Records[Records[I].AncestorId].FullName; + + DestructorId := FindDestructorId(I); + if DestructorId > 0 then + ClassRec.DestructorProgOffset := Records[DestructorId].Value; + + SafeCallExceptionId := Lookup('SafeCallException', I, true); + if SafeCallExceptionId > 0 then + ClassRec.SafeCallExceptionProgOffset := Records[SafeCallExceptionId].Value; + + AfterConstructionId := Lookup('AfterConstruction', I, true); + if AfterConstructionId > 0 then + ClassRec.AfterConstructionProgOffset := Records[AfterConstructionId].Value; + + BeforeDestructionId := Lookup('BeforeDestruction', I, true); + if BeforeDestructionId > 0 then + ClassRec.BeforeDestructionProgOffset := Records[BeforeDestructionId].Value; + + DispatchId := Lookup('Dispatch', I, true); + if DispatchId > 0 then + ClassRec.DispatchProgOffset := Records[DispatchId].Value; + + DefaultHandlerId := Lookup('DefaultHandler', I, true); + if DefaultHandlerId > 0 then + ClassRec.DefaultHandlerProgOffset := Records[DefaultHandlerId].Value; + + NewInstanceId := Lookup('NewInstance', I, true); + if NewInstanceId > 0 then + ClassRec.NewInstanceProgOffset := Records[NewInstanceId].Value; + + FreeInstanceId := Lookup('FreeInstance', I, true); + if FreeInstanceId > 0 then + ClassRec.FreeInstanceProgOffset := Records[FreeInstanceId].Value; + +{$IFDEF UNIC} + ToStringId := Lookup('ToString', I, true); + if ToStringId > 0 then + ClassRec.ToStringProgOffset := Records[ToStringId].Value; +{$ENDIF} + + PaxInfo := GetPaxInfo(ClassRec.PClass); + if PaxInfo = nil then + RaiseError(errInternalError, []); + + if not IsEval then + begin + PaxInfo^.Prog := result; + PaxInfo^.ClassIndex := Records[I].ClassIndex; + end; + + PaxFactoryRec := TKernel(kernel).ClassFactory.FindRecord(ClassRec.PClass); + if PaxFactoryRec = nil then + RaiseError(errInternalError, []); + + if Records[I].SupportedInterfaces = nil then + begin + ClassRec.InstSize := Records[I].GetSizeOfAllClassFields(result); + Inc(ClassRec.InstSize, SizeOf(Pointer)); // add monitor space + PaxFactoryRec.SetInstanceSize(ClassRec.InstSize); + continue; + end + else + begin + ClassRec.InstSize := Records[I].GetSizeOfAllClassFields(result) + + Records[I].SupportedInterfaces.Count * SizeOfPointer; + Inc(ClassRec.InstSize, SizeOf(Pointer)); // add monitor space + PaxFactoryRec.SetInstanceSize(ClassRec.InstSize); + end; + + if Records[I].SupportedInterfaces.Count = 0 then + continue; + + InterfaceMethodIds := TIntegerList.Create; + ClassMethodIds := TIntegerList.Create; + try + for J:=0 to Records[I].SupportedInterfaces.Count - 1 do + begin + + IntfId := Records[I].SupportedInterfaces[J].Id; + CreateInterfaceMethodList(I, IntfId, + InterfaceMethodIds, + ClassMethodIds); + if (not Records[I].IsAbstract) and (InterfaceMethodIds.Count > 0) then // some methods not found + begin + for K:=0 to InterfaceMethodIds.Count - 1 do + begin + Code.N := Code.FindRecord1(OP_END_CLASS_TYPE, I); + CreateError(errUndeclaredIdentifier, + [Records[InterfaceMethodIds[K]].Name]); + end; + break; + end + else + begin + InterfaceToObjectOffset := + -Records[I].GetSizeOfAllClassFields(result) + J * SizeOfPointer; + + IntfRec := ClassRec.IntfList.Add; + IntfRec.GUID := Records[I].SupportedInterfaces[J].GUID; + for K:=0 to ClassMethodIds.Count - 1 do + begin + Id := ClassMethodIds[K]; + + IntfRec.IntfMethods.AddMethod(Records[Id].FullName, + UpdatedProgSize, + InterfaceToObjectOffset); + Inc(UpdatedProgSize, EmitZ); + +{$IFDEF PAX64} + RegX := _R10; + RegY := _R11; +{$ELSE} + if Records[Id].Host then + RegX := _EDI + else + RegX := _ESI; + RegY := _EBX; +{$ENDIF} + + if Records[Id].CallConv in [ccSTDCALL, ccCDECL, ccPASCAL, ccSAFECALL] then + begin + if Records[Id].ExtraParamNeeded then + Inc(UpdatedProgSize, AsmPop_REG(RegX).Size); + + Inc(UpdatedProgSize, AsmPop_REG(RegY).Size); + Inc(UpdatedProgSize, AsmPop_REG(_EAX).Size); + end; + + if PAX64 then + Inc(UpdatedProgSize, AsmAddREG_Imm(_ECX, InterfaceToObjectOffset).Size) + else + Inc(UpdatedProgSize, AsmAddREG_Imm(_EAX, InterfaceToObjectOffset).Size); + // EAX contains instance of object + + if Records[Id].CallConv in [ccSTDCALL, ccCDECL, ccPASCAL, ccSAFECALL] then + begin + Inc(UpdatedProgSize, AsmPush_REG(_EAX).Size); + Inc(UpdatedProgSize, AsmPush_REG(RegY).Size); + if Records[Id].ExtraParamNeeded then + Inc(UpdatedProgSize, AsmPush_REG(RegX).Size); + end; + + // jump to address + + if Records[Id].Host then + begin + Inc(UpdatedProgSize, AsmGetREG_ESIPtr(RegY, GetOffset(Records[Id])).Size); + end + else + begin + Inc(UpdatedProgSize, AsmMovREG_REG(RegY, _EDI).Size); + Inc(UpdatedProgSize, AsmAddREG_Imm(RegY, Records[Id].Value).Size); + end; + Inc(UpdatedProgSize, AsmJMP_REG(RegY).Size); + end; + end; + end; + finally + FreeAndNil(InterfaceMethodIds); + FreeAndNil(ClassMethodIds); + end; + end; + + result.Reallocate(UpdatedProgSize); + + for I:= LastCard + 1 to Card do + begin + SZ := Records[I].Size; + if SZ >= 0 then + begin + Records[I].ProgOffset := NN; + + Move(Records[I].code, result.CodePtr^[NN], SZ); + Inc(NN, SZ); + end; + end; + + result.TryList.Clear; + result.RootTryStack.Clear; + + for I:=1 to Code.Card do + if Code[I].Op = OP_TRY_ON then + begin + TryRec := result.TryList.Add; + TryRec.Level := Code[I].Res; + + for J := I + 1 to Code.Card do + begin + Op := Code[J].Op; + if OP = OP_FINALLY then + begin + if Code[J].Arg1 = Code[I].Arg1 then + begin + TryRec.TryKind := tryFinally; + ID := Code[J].Arg2; + TryRec.ProgOffset := SymbolTable[ID].Value; + break; + end; + end + else if OP = OP_EXCEPT then + begin + if Code[J].Arg1 = Code[I].Arg1 then + begin + TryRec.TryKind := tryExcept; + ID := Code[J].Arg2; + TryRec.ProgOffset := SymbolTable[ID].Value; + break; + end; + end + else if OP = OP_TRY_OFF then + begin + if Code[J].Arg1 = Code[I].Arg1 then + begin + break; + end; + end; + end; + end; + + for I:=1 to Code.Card do + begin + OP := Code[I].Op; + if OP = OP_FINALLY then + begin + ID := Code[I].Arg2; + ProgOffset := SymbolTable[ID].Value; + + TryRec := result.TryList[Code[I].Arg1]; + + TryRec.TryKind := tryFinally; + TryRec._ESP := 0; // will be determined at run-time + TryRec._EBP := 0; // will be determined at run-time + TryRec.ProgOffset := ProgOffset; + + TryRec.N := I; + + if (Code[I].BreakLabel > 0) and (Code[I].ContinueLabel > 0) then + begin + Id := Code[I].BreakLabel; + TryRec.BreakOffset := SymbolTable[ID].Value; + + Id := Code[I].ContinueLabel; + TryRec.ContinueOffset := SymbolTable[ID].Value; + + Id := Code[I].LoopLabel; + N1 := SymbolTable[ID].Value; // begin loop offset + N2 := TryRec.BreakOffset; // break offset (end loop offset) + for J := Code[I].Arg1 - 1 downto 0 do + if result.TryList[J].TryKind = tryFinally then + begin + if result.TryList[J].ProgOffset >= N1 then + if result.TryList[J].ProgOffset <= N2 then + begin + TryRec.BreakOffset := 0; + TryRec.ContinueOffset := 0; + end; + end; + end; + end + else if OP = OP_EXCEPT then + begin + ID := Code[I].Arg2; + ProgOffset := SymbolTable[ID].Value; + + TryRec := result.TryList[Code[I].Arg1]; + + TryRec.TryKind := tryExcept; + TryRec._ESP := 0; // will be determined at run-time + TryRec._EBP := 0; // will be determined at run-time + TryRec.ProgOffset := ProgOffset; + + TryRec.N := I; + + if (Code[I].BreakLabel > 0) and (Code[I].ContinueLabel > 0) then + begin + Id := Code[I].BreakLabel; + TryRec.BreakOffset := SymbolTable[ID].Value; + + Id := Code[I].ContinueLabel; + TryRec.ContinueOffset := SymbolTable[ID].Value; + + Id := Code[I].LoopLabel; + N1 := SymbolTable[ID].Value; // begin loop offset + N2 := TryRec.BreakOffset; // break offset (end loop offset) + for J := Code[I].Arg1 - 1 downto 0 do + if result.TryList[J].TryKind = tryFinally then + begin + if result.TryList[J].ProgOffset >= N1 then + if result.TryList[J].ProgOffset <= N2 then + begin + TryRec.BreakOffset := result.TryList[J].ProgOffset; + TryRec.ContinueOffset := result.TryList[J].ProgOffset; + end; + end; + end; + end + else if OP = OP_EXCEPT_ON then + begin + ID := Code[I].Arg2; + ProgOffset := SymbolTable[ID].Value; + + TryRec := result.TryList[Code[I].Arg1]; + + if Code[I].Res = 0 then + ClsIndex := -1 // else part + else + begin + ID := SymbolTable[Code[I].Res].TerminalTypeId; + ClsIndex := SymbolTable[ID].ClassIndex; + + if ClsIndex <= 0 then + RaiseError(errInternalError, []); + end; + + TryRec.ExceptOnInfo.Add(ClsIndex, ProgOffset); + + TryRec.N := I; + end; + end; + + TKernel(kernel).CreateRTI(result); + CreateZList(result); + + if not IsEval then + begin + SymbolTable.ProcessClassFactory(Tkernel(kernel).ClassFactory, result); + TKernel(kernel).ClassFactory.SetupStdVirtuals(result.ClassList, result.CodePtr); + result.SetupInterfaces(result.CodePtr); + result.ProgTypeInfoList.AddToProgram(result); + end; + + for I:= 1 to Card do + if Records[I].MustBeFixed then + begin + if SymbolTable[Records[I].SubId].MethodIndex = 0 then + begin + SS := SymbolTable[Records[I].SubId].Name; + + if StrEql(SS, 'SafeCallException') then + Shift := -32 + else if StrEql(SS, 'AfterConstruction') then + Shift := -28 + else if StrEql(SS, 'BeforeDestruction') then + Shift := -24 + else if StrEql(SS, 'Dispatch') then + Shift := -20 + else if StrEql(SS, 'DefaultHandler') then + Shift := -16 + else if StrEql(SS, 'NewInstance') then + Shift := -12 + else if StrEql(SS, 'FreeInstance') then + Shift := -8 + else if StrEql(SS, 'Destroy') then + Shift := -4 + +{$IFDEF UNIC} + else if StrEql(SS, 'ToString') then + Shift := -36 + else if StrEql(SS, 'GetHashCode') then + Shift := -40 + else if StrEql(SS, 'Equals') then + Shift := -44 +{$ENDIF} + + else + begin + TKernel(kernel).CreateError(errInternalErrorMethodIndex, []); + end; + end + else + Shift := (SymbolTable[Records[I].SubId].MethodIndex - 1) * 4; + Move(Shift, Records[I].Code[Records[I].OpOffset], 4); + Records[I].Decompile; + Move(Shift, ShiftPointer(result.CodePtr, Records[I].ProgOffset + Records[I].OpOffset)^, 4); + end; +end; + +procedure TSymbolProg.CreateZList(P: TProgram); +var + I, S, SZ: Integer; + R: TSymbolProgRec; +begin + P.ZList.Clear; +{ + + for I:=1 to Card do + begin + R := Records[I]; + if R.Z then + begin + S := GetShiftOfRecord(R); + P.ZList.Add(S); + end; + end; +} + S := 0; + for I:=1 to Card do + begin + R := Records[I]; + + if R.Z then + P.ZList.Add(S); + + SZ := R.Size; + if SZ > 0 then + S := S + SZ; + end; + + P.SetZList; +end; + +procedure TSymbolProg.RaiseError(const Message: string; params: array of Const); +begin + raise Exception.Create(Format(Message, params)); +end; + +procedure TSymbolProg.CreateError(const Message: string; params: array of Const); +begin + TKernel(kernel).CreateError(Message, params); +end; + +function TSymbolProg.GetOffset(S: TSymbolRec): Integer; +begin + result := TKernel(kernel).GetOffset(S); +end; + +function TSymbolProg.EmitGetCallerEIP: Integer; +begin + AsmGetREG32_ESIPtr(_EAX, GetOffset(TKernel(kernel).SymbolTable[Id_GetAddressGetCallerEIP])); + //6 + AsmSubREG_Imm(_ESP, 12);//6 + AsmCall_REG(_EAX); //2 + AsmCall_REG(_EAX); //2 + AsmAddREG_Imm(_ESP, 12); //6 + result := 6 + 6 + 2 + 2 + 6; +end; + +function TSymbolProg.EmitZ: Integer; +var + R: TSymbolProgRec; +begin + R := AsmMovREG_Imm(_EDI, 400000); // 5 or 10 CodePtr + R.Z := true; + AsmMovREG_Imm(_ESI, 400000); // 5 or 10 DataPtr + if TKernel(kernel).TargetPlatform = tpWin64 then + result := 20 + else + result := 10; +end; + +function TSymbolProg.GetPAX64: Boolean; +begin + if kernel = nil then + result := false + else + result := TKernel(kernel).PAX64; +end; + +function TSymbolProg.GetSizeOfPointer: Integer; +begin + if PAX64 then + result := 8 + else + result := 4; +end; + +end. diff --git a/Sources/PAXCOMP_SYMBOL_REC.pas b/Sources/PAXCOMP_SYMBOL_REC.pas new file mode 100644 index 0000000..8115d25 --- /dev/null +++ b/Sources/PAXCOMP_SYMBOL_REC.pas @@ -0,0 +1,2023 @@ +//////////////////////////////////////////////////////////////////////////// +// PaxCompiler +// Site: http://www.paxcompiler.com +// Author: Alexander Baranovsky (paxscript@gmail.com) +// ======================================================================== +// Copyright (c) Alexander Baranovsky, 2006-2014. All rights reserved. +// Code Version: 4.2 +// ======================================================================== +// Unit: PAXCOMP_SYMBOL_REC.pas +// ======================================================================== +//////////////////////////////////////////////////////////////////////////// + +{$I PaxCompiler.def} +unit PAXCOMP_SYMBOL_REC; +interface +uses {$I uses.def} + SysUtils, + Classes, + PAXCOMP_CONSTANTS, + PAXCOMP_TYPES, + PAXCOMP_SYS, + PAXCOMP_VAROBJECT; + +type + TSymbolRec = class + private + s_table: Pointer; + fTypeID: Integer; + fShift: Integer; + fUnionId: Integer; + fValue: Variant; + fKind: Integer; + fRegister: Integer; + fClassIndex: Integer; + fAncestorId: Integer; + fIsSharedMethod: Boolean; + fPropIndex: Integer; + fReadId: Integer; + fWriteId: Integer; + fIsDefault: Boolean; + fVis: TClassVisibility; + fCallMode: Byte; + fIsConst: Boolean; + fMustBeAllocated: Boolean; + fPosition: Integer; + fTypedConst: Boolean; + fByRef: Boolean; + fByRefEx: Boolean; + fIsJavaScriptClass: Boolean; + fIsDeprecated: Boolean; + fIsFakeMethod: Boolean; + fMethodIndex: Integer; + fNegativeMethodIndex: Integer; + fSupportedInterfaces: TGuidList; + fDefaultAlignment: Byte; + fOverCount: Byte; + fVarCount: Int64; + fPushProgRequired: Boolean; + + fFinSize: Integer; + + fSavedShift: Integer; + fOverScript: Boolean; + fIsOpenArray: Boolean; + fIsFinal: Boolean; + fPatternId: Integer; + + fIsExternal: Boolean; + fInImplementation: Boolean; + fCount: Integer; + + fName: String; + + fDynamicMethodIndex: Integer; + fIsDRTTI: Boolean; + fDefVal: String; + fNoRelocate: Boolean; + fIsAbstract: Boolean; + fIsJSFunction: Boolean; + fSig: String; + fIsDummyType: Boolean; + fIsOut: Boolean; + fRunnerParameter: Boolean; + fNoGUID: Boolean; + + fRSPOffset: Byte; + fXMMReg: Byte; + + fCompIndex: Integer; + fIsUnion: Boolean; + + procedure SetIsSharedMethod(value: Boolean); + procedure SetKind(value: Integer); + procedure SetTypeId(value: Integer); + function GetNativeName: String; + procedure SetName(const S: String); + function GetName: String; + function GetNameEx: String; + function GetLocal: Boolean; + function GetSize: Integer; + function GetPtrSize: Integer; + function GetFinalTypeId: Integer; + function GetTerminalTypeId: Integer; + function GetTerminalHostClassId: Integer; + function GetShift: Integer; + function GetFinalOwnerId: Integer; + function GetInternalField: Boolean; + function GetLocalInternalField: Boolean; + procedure SetValue(const Value: Variant); + procedure SetCount(value: Integer); + function GetValueAsByteSet: TByteSet; + procedure SetValueAsByteSet(const val: TByteSet); + function GetSymbolRec(i_id: Integer): TSymbolRec; + function GetSignatureSimple: String; + function GetSignature: String; + function GetSignatureEx: String; + function GetSignatureBrief: String; + function GetIsStatic: Boolean; + function GetIsVirtual: Boolean; + procedure SetByRef(value: Boolean); + procedure SetByRefEx(value: Boolean); + function GetFullName: String; + function GetHeight: Integer; + procedure SetTypedConst(value: Boolean); + procedure SetPatternId(value: Integer); + function GetIsPublished: Boolean; + procedure SetIsPublished(value: Boolean); + procedure SetIsOpenArray(value: Boolean); + procedure SetRegister(value: Integer); + procedure SetMethodIndex(value: Integer); + procedure SetOverCount(value: Byte); + + public + Id: Integer; + Host: Boolean; + Param: Boolean; + Optional: Boolean; + Completed: Boolean; + Level: Integer; + OwnerId: Integer; + CallConv: Integer; + IsForward: Boolean; + PClass: TClass; + Address: POinter; + NSOwnerId: Integer; + constructor Create(i_s_table: Pointer); + destructor Destroy; override; + function HasName: Boolean; + function HasFrameworkType: Boolean; + function HasPAnsiCharType: Boolean; + function HasPWideCharType: Boolean; + function HasPVoidType: Boolean; + function ExtraParamNeeded: Boolean; + function IsSubrangeEnumType: Boolean; + function HasSubrangeEnumType: Boolean; + function HasByRefOwner: Boolean; + function IsNestedSub: Boolean; + function IsMethod: Boolean; + function IsConstructor: Boolean; + function IsDestructor: Boolean; + function Inherits(T: Integer): Boolean; + function IsGlobalVar: Boolean; + function IsGlobalVarEx: Boolean; + function IsLocalVarEx: Boolean; + function IsGlobalConst: Boolean; + function IsGlobalConstEx: Boolean; + function GetIsGeneric: Boolean; + + function IsGlobalSub: Boolean; + function IsPacked: Boolean; + procedure SetVariantValue(const Value: Variant); + procedure SetUnionId(const Value: Integer); + procedure Update; + + procedure SaveToStream(S: TWriter); + procedure LoadFromStream(S: TReader); + function IsSubPartOfEventType: Boolean; + function IsSubPartOfProcType: Boolean; + function GetNamespaceId: Integer; + function IsFWArrayVar: Boolean; + + function GetSizeOfScriptClassFields: Integer; + function GetSizeOfHostClassFields(P: Pointer): Integer; + function GetSizeOfAllClassFields(P: Pointer): Integer; + + property Name: String read GetName write SetName; + property FullName: String read GetFullName; + property Kind: Integer read fKind write SetKind; + property Local: Boolean read GetLocal; + property Size: Integer read GetSize; + property PtrSize: Integer read GetPtrSize; + property FinalTypeId: Integer read GetFinalTypeId; + property TerminalTypeId: Integer read GetTerminalTypeId; + property TerminalHostClassId: Integer read GetTerminalHostClassId; + property Count: Integer read fCount write SetCount; + property Shift: Integer read GetShift write fShift; + property TypeID: Integer read fTypeID write SetTypeID; + property FinalOwnerId: Integer read GetFinalOwnerId; + property InternalField: Boolean read GetInternalField; + property LocalInternalField: Boolean read GetLocalInternalField; + property Value: Variant read fValue write SetValue; + property UnionId: Integer read fUnionId write SetUnionId; + property ValueAsByteSet: TByteSet read GetValueAsByteSet write SetValueAsByteSet; + property SignatureSimple: String read GetSignatureSimple; + property Signature: String read GetSignature; + property SignatureEx: String read GetSignatureEx; + property SignatureBrief: String read GetSignatureBrief; + property IsStatic: Boolean read GetIsStatic; + property Register: Integer read fRegister write SetRegister; + property ClassIndex: Integer read fClassIndex write fClassIndex; + property AncestorId: Integer read fAncestorId write fAncestorId; + property IsSharedMethod: Boolean read fIsSharedMethod write SetIsSharedMethod; + property IsPublished: Boolean read GetIsPublished write SetIsPublished; + property IsDRTTI: Boolean read fIsDRTTI write fIsDRTTI; + property PropIndex: Integer read fPropIndex write fPropIndex; + property ReadId: Integer read fReadId write fReadId; + property WriteId: Integer read fWriteId write fWriteId; + property IsDefault: Boolean read fIsDefault write fIsDefault; + property Vis: TClassVisibility read fVis write fVis; + property CallMode: Byte read fCallMode write fCallMode; + property IsVirtual: Boolean read GetIsVirtual; + property IsConst: Boolean read fIsConst write fIsConst; + property MustBeAllocated: Boolean read fMustBeallocated write fMustBeAllocated; + property Position: Integer read fPosition write fPosition; + property TypedConst: Boolean read fTypedConst write SetTypedConst; + property ByRef: Boolean read fByRef write SetByRef; + property ByRefEx: Boolean read fByRefEx write SetByRefEx; + property IsJavaScriptClass: Boolean read fIsJavaScriptClass write fIsJavaScriptClass; + property IsDeprecated: Boolean read fIsDeprecated write fIsDeprecated; + property IsFakeMethod: Boolean read fIsFakeMethod write fIsFakeMethod; + property MethodIndex: Integer read fMethodIndex write SetMethodIndex; + property NegativeMethodIndex: Integer read fNegativeMethodIndex write fNegativeMethodIndex; + property SupportedInterfaces: TGuidList read fSupportedInterfaces + write fSupportedInterfaces; + property DefaultAlignment: Byte read fDefaultAlignment write fDefaultAlignment; + property VarCount: Int64 read fVarCount write fVarCount; + property OverCount: Byte read fOverCount write SetOverCount; + property FinSize: Integer read fFinSize write fFinSize; + + property SavedShift: Integer read fSavedShift write fSavedShift; + property OverScript: Boolean read fOverScript write fOverScript; + + property NativeName: String read GetNativeName; + property IsOpenArray: Boolean read fIsOpenArray write SetIsOpenArray; + property Height: Integer read GetHeight; + property NameEx: String read GetNameEx; + property PatternId: Integer read fPatternId write SetPatternId; + property IsExternal: Boolean read fIsExternal write fIsExternal; + property InImplementation: Boolean read fInImplementation write fInImplementation; + property DynamicMethodIndex: Integer read fDynamicMethodIndex write fDynamicMethodIndex; + property DefVal: String read fDefVal write fDefVal; + property NoRelocate: Boolean read fNoRelocate write fNoRelocate; + property IsFinal: Boolean read fIsFinal write fIsFinal; + property IsAbstract: Boolean read fIsAbstract write fIsAbstract; + property IsGeneric: Boolean read GetIsGeneric; + property IsJSFunction: Boolean read fIsJSFunction write fIsJSFunction; + property IsDummyType: Boolean read fIsDummyType write fIsDummyType; + property IsOut: Boolean read fIsOut write fIsOut; + property Sig: String read fSig write fSig; + property RSPOffset: Byte read fRSPOffset write fRSPOffset; + property XMMReg: Byte read fXMMReg write fXMMreg; + property RunnerParameter: Boolean read fRunnerParameter write fRunnerParameter; + property NoGUID: Boolean read fNoGUID write fNoGUID; + property CompIndex: Integer read fCompIndex write fCompIndex; + property PushProgRequired: Boolean read fPushProgRequired write fPushProgRequired; + property IsUnion: Boolean read fIsUnion write fIsUnion; + end; + +implementation + +uses + PAXCOMP_BASESYMBOL_TABLE, + PAXCOMP_STDLIB, + PAXCOMP_BASERUNNER; + +constructor TSymbolRec.Create(i_s_table: Pointer); +begin + inherited Create; + + Self.s_table := i_s_table; + TypeID := 0; + Completed := false; + Shift := 0; + Host := false; + Param := false; + fByRef := false; + fByRefEx := false; + Optional := false; + Level := 0; + CallConv := 0; + Count := 0; + PatternId := 0; + OwnerId := 0; + fUnionId := 0; + IsForward := false; + fKind := KindNONE; + fRegister := 0; + fClassIndex := -1; + fIsSharedMethod := false; + fAncestorId := 0; + PClass := nil; + fPropIndex := -1; + fReadId := 0; + fWriteId := 0; + fIsDefault := false; + fVis := cvNone; + fName := ''; + fCallMode := 0; + fIsConst := false; + fMustBeAllocated := false; + fPosition := 0; + fTypedConst := false; + fIsJavaScriptClass := false; + fIsDeprecated := false; + fIsFakeMethod := false; + fMethodIndex := 0; + fNegativeMethodIndex := 0; + fSupportedInterfaces := nil; + fDefaultAlignment := 0; + fVarCount := 0; + fFinSize := -1; + fOverScript := false; + fIsOpenArray := false; + fIsFinal := false; + fIsAbstract := false; + fIsJSFunction := false; + fSig := ''; + fCompIndex := -1; +end; + +destructor TSymbolRec.Destroy; +begin + if Assigned(fSupportedInterfaces) then + FreeAndNil(fSupportedInterfaces); + + inherited; +end; + +procedure TSymbolRec.SetName(const S: String); +var + HashArray: THashArray; +begin + HashArray := TBaseSymbolTable(s_table).HashArray; + + if fName <> '' then + if HashArray <> nil then + HashArray.DeleteName(fName, Id); + + fName := S; + + if S <> '' then + if HashArray <> nil then + HashArray.AddName(S, Id); +end; + +function TSymbolRec.GetName: String; +begin + result := fName; +end; + +function TSymbolRec.GetNativeName: String; +begin + if (Id >= 0) and (Id < Types.Count) then + result := Types[Id].NativeName + else + result := fName; +end; + +function TSymbolRec.GetShift: Integer; +begin + result := fShift; +end; + +function TSymbolRec.GetSize: Integer; +var + I, T, TRange, TElem, B1, B2, PrevShift, + CurrAlign, DefAlign, MaxAlign, J1, FT, FT1, VJ, VS, VK, VSize, MaxVSize: Integer; + SymbolTable: TBaseSymbolTable; + VarPathList: TVarPathList; + Path: TVarPath; + RI: TSymbolRec; +begin + if fFinSize > 0 then + begin + result := fFinSize; + Exit; + end; + + SymbolTable := TBaseSymbolTable(s_table); + result := 0; + case Kind of + KindSUB: + result := SymbolTable.SizeOfPointer; + KindLABEL: + result := SymbolTable.SizeOfPointer; + else + begin + + if Kind = kindTYPE then + begin + T := Id; + if TypeId = typeALIAS then + T := TerminalTypeId; + end + else + T := TerminalTypeId; + + if (Kind = KindVAR) and ByRef then + begin + result := SymbolTable.SizeOfPointer; + fFinSize := result; + Exit; + end; + + if T < Types.Count then + result := Types.GetSize(T) + else + begin +{ + if (T = typePCHAR) and (Kind = KindCONST) then + begin + result := Length(Value) + 1; + end + else +} + if SymbolTable[T].Completed then + begin + result := 0; + case FinalTypeId of +{$IFNDEF PAXARM} + typeSHORTSTRING: + begin + result := SymbolTable[T].Count + 1; + end; +{$ENDIF} + typeSET: + begin + result := SymbolTable.GetSizeOfSetType(T); + end; + typeRECORD: + begin + + VarPathList := TVarPathList.Create; + try + + for I:=T + 1 to SymbolTable.Card do + begin + RI := SymbolTable[I]; + if RI = SymbolTable.SR0 then + break; + + if RI.Kind = KindSUB then + if RI.Level <> T then + break; + + if (RI.Kind = KindTYPE_FIELD) and (RI.Level = T) then + if RI.VarCount > 0 then + VarPathList.Add(I, RI.VarCount); + end; + + PrevShift := -1; + + if SymbolTable[T].IsPacked then + begin + if VarPathList.Count = 0 then + begin + for I:=T + 1 to SymbolTable.Card do + begin + RI := SymbolTable[I]; + if RI = SymbolTable.SR0 then + break; + + if RI.Kind = KindSUB then + if RI.Level <> T then + break; + + if (RI.Kind = KindTYPE_FIELD) and + (RI.Level = T) then + begin + if RI.Shift > PrevShift then + begin + PrevShift := RI.Shift; + Inc(result, RI.Size); + end; + end; + end; + end + else // packed record with variant part + begin + for I:=T + 1 to SymbolTable.Card do + begin + RI := SymbolTable[I]; + if RI = SymbolTable.SR0 then + break; + + if RI.Kind = KindSUB then + if RI.Level <> T then + break; + + if (RI.Kind = KindTYPE_FIELD) and + (RI.Level = T) then + begin + + if RI.VarCount > 0 then + break; + + if RI.Shift > PrevShift then + begin + PrevShift := RI.Shift; + Inc(result, RI.Size); + end; + end; + end; + + MaxVSize := 0; + VS := PrevShift; + + for VK :=0 to VarPathList.Count - 1 do + begin + Path := VarPathList[VK]; + + PrevShift := VS; + VSize := result; + + for VJ := 0 to Path.Count - 1 do + begin + I := Path[VJ].Id; + if SymbolTable[I].Shift > PrevShift then + begin + PrevShift := SymbolTable[I].Shift; + Inc(VSize, SymbolTable[I].Size); + end; + end; + + if VSize > MaxVSize then + MaxVSize := VSize; + end; + + result := MaxVSize; + end; + + end + else // not packed record + begin + DefAlign := SymbolTable[T].DefaultAlignment; + MaxAlign := 0; + J1 := -1; + + if VarPathList.Count = 0 then + begin + + for I:=T + 1 to SymbolTable.Card do + begin + + RI := SymbolTable[I]; + if RI = SymbolTable.SR0 then + break; + + if RI.Kind = KindSUB then + if RI.Level <> T then + break; + + if (RI.Kind = KindTYPE_FIELD) and + (RI.Level = T) then + begin + if RI.Shift > PrevShift then + begin + PrevShift := RI.Shift; + + CurrAlign := SymbolTable.GetAlignmentSize( + RI.TypeId, DefAlign); + + if J1 > 0 then + begin + FT1 := SymbolTable[I-1].FinalTypeId; + FT := RI.FinalTypeId; + if FT = FT1 then + begin + CurrAlign := 1; + J1 := -1; + end + else + J1 := I; + end + else + J1 := I; + + if CurrAlign > MaxAlign then + MaxAlign := CurrAlign; + + if CurrAlign > 1 then + begin + while result mod CurrAlign <> 0 do + Inc(result); + end; + + Inc(result, RI.Size); + end; + end; + end; + end + else // unpacked record with variant part + begin + for I:=T + 1 to SymbolTable.Card do + begin + RI := SymbolTable[I]; + if RI = SymbolTable.SR0 then + break; + + if RI.Kind = KindSUB then + if RI.Level <> T then + break; + + if (RI.Kind = KindTYPE_FIELD) and + (RI.Level = T) then + begin + + if RI.VarCount > 0 then + break; + + if RI.Shift > PrevShift then + begin + PrevShift := RI.Shift; + + CurrAlign := SymbolTable.GetAlignmentSize( + RI.TypeId, DefAlign); + + if J1 > 0 then + begin + FT1 := SymbolTable[I-1].FinalTypeId; + FT := RI.FinalTypeId; + if FT = FT1 then + begin + CurrAlign := 1; + J1 := -1; + end + else + J1 := I; + end + else + J1 := I; + + if CurrAlign > MaxAlign then + MaxAlign := CurrAlign; + + + if CurrAlign > 1 then + begin + while result mod CurrAlign <> 0 do + Inc(result); + end; + + Inc(result, RI.Size); + end; + end; + end; + + // process variant part of record + MaxVSize := 0; + VS := PrevShift; + + for VK :=0 to VarPathList.Count - 1 do + begin + Path := VarPathList[VK]; + + PrevShift := VS; + VSize := result; + + for VJ := 0 to Path.Count - 1 do + begin + I := Path[VJ].Id; + + RI := SymbolTable[I]; + if RI.Shift > PrevShift then + begin + PrevShift := RI.Shift; + + CurrAlign := SymbolTable.GetAlignmentSize( + RI.TypeId, DefAlign); + + if J1 > 0 then + begin + FT1 := SymbolTable[I-1].FinalTypeId; + FT := RI.FinalTypeId; + if FT = FT1 then + begin + CurrAlign := 1; + J1 := -1; + end + else + J1 := I; + end + else + J1 := I; + + if CurrAlign > MaxAlign then + MaxAlign := CurrAlign; + + if CurrAlign > 1 then + begin + while VSize mod CurrAlign <> 0 do + Inc(VSize); + end; + + Inc(VSize, RI.Size); + end; + end; + + if VSize > MaxVSize then + MaxVSize := VSize; + end; + result := MaxVSize; + end; + + if MaxAlign > 1 then + begin + while result mod MaxAlign <> 0 do + Inc(result); + end; + + end; + + finally + FreeAndNil(VarPathList); + end; + + end; + typeARRAY: + begin + SymbolTable.GetArrayTypeInfo(T, TRange, TElem); + + if SymbolTable[TRange].Completed and SymbolTable[TElem].Completed then + begin + B1 := SymbolTable.GetLowBoundRec(TRange).Value; + B2 := SymbolTable.GetHighBoundRec(TRange).Value; + + result := SymbolTable[TElem].Size * (B2 - B1 + 1); + end; + end; + else + begin + if FinalTypeId < Types.Count then + result := Types.GetSize(FinalTypeId) + else + TBaseSymbolTable(s_table).RaiseError(errInternalError, []); + end; + end; + end + else + begin + end; + end; + end; + end; + + if Id = H_TVarRec then + result := SizeOf(TVarRec); + + fFinSize := result; + + if fFinSize = 0 then + fFinSize := -1; +end; + +function TSymbolRec.GetPtrSize: Integer; +var + temp1, temp2: Boolean; + temp3: Integer; +begin + temp1 := ByRef; + temp2 := Host; + + ByRef := false; + Host := false; + + temp3 := fFinSize; + fFinSize := -1; + result := GetSize; + fFinSize := temp3; + + if result = 0 then + result := 4; + + ByRef := temp1; + Host := temp2; +end; + +function TSymbolRec.GetFinalTypeId: Integer; +var + T: Integer; +begin + if Kind = KindTYPE then + begin + if id < Types.Count then + begin + result := Id; + Exit; + end; + + T := TerminalTypeId; + if T < Types.Count then + result := T + else + begin + T := TBaseSymbolTable(s_table)[T].TypeID; + result := TBaseSymbolTable(s_table)[T].FinalTypeId; + end; + end + else + begin + if TypeId <= 0 then + begin + result := 0; + Exit; + end; + + result := TBaseSymbolTable(s_table)[TypeId].FinalTypeId; + end; +end; + +function TSymbolRec.GetTerminalTypeId: Integer; +var + SymbolTable: TBaseSymbolTable; +begin + result := 0; + SymbolTable := TBaseSymbolTable(s_table); + if Kind = KindTYPE then + begin + result := Id; + if TypeId = typeALIAS then + while SymbolTable[result].TypeId = typeALIAS do + result := SymbolTable[result].PatternId; + end + else + begin + if TypeId = 0 then + result := 0 + else if TypeId < 0 then + SymbolTable.RaiseError(errInternalError, []) + else + result := SymbolTable[TypeId].TerminalTypeId; + end; +end; + +function TSymbolRec.GetTerminalHostClassId: Integer; +var + SymbolTable: TBaseSymbolTable; +begin + if FinalTypeId <> typeCLASS then + raise Exception.Create(errInternalError); + + SymbolTable := TBaseSymbolTable(s_table); + if Kind = KindTYPE then + begin + result := TerminalTypeId; + if Host then Exit; + + if AncestorId = 0 then + raise Exception.Create(errInternalError); + + result := SymbolTable[AncestorId].GetTerminalHostClassId; + end + else + result := SymbolTable[TypeId].TerminalHostClassId; +end; + + +function TSymbolRec.GetFinalOwnerId: Integer; +begin + result := OwnerId; + if result = 0 then + Exit; + + if TBaseSymbolTable(s_table)[result].OwnerId = 0 then + Exit; + + result := TBaseSymbolTable(s_table)[result].FinalOwnerId; +end; + +function TSymbolRec.HasByRefOwner: Boolean; +begin + result := false; + + if OwnerId = 0 then + Exit; + + if TBaseSymbolTable(s_table)[OwnerId].ByRef or + TBaseSymbolTable(s_table)[OwnerId].ByRefEx then + begin + result := true; + Exit; + end; + + result := TBaseSymbolTable(s_table)[OwnerId].HasByRefOwner; +end; + +function TSymbolRec.GetLocal: Boolean; +begin + if OverScript then + begin + result := false; + Exit; + end; + + if Param and (Register > 0) then + begin + result := true; + Exit; + end; + + result := (not Host) and (not TypedConst) and + (TBaseSymbolTable(s_table)[Level].Kind in KindSubs) and + (Kind = KindVAR) and (not Param) and (not InternalField); +end; + +function TSymbolRec.GetInternalField: Boolean; +begin + result := (Kind = KindVAR) and (OwnerId <> 0) and (not ByRef); + + if result then + result := TBaseSymbolTable(s_table)[OwnerId].Kind in [KindVAR, kindNONE]; +end; + +function TSymbolRec.GetLocalInternalField: Boolean; +begin + result := GetInternalField; + + if result then + result := TBaseSymbolTable(s_table)[OwnerId].Local + or + TBaseSymbolTable(s_table)[OwnerId].Param; +end; + +procedure TSymbolRec.SetValue(const Value: Variant); +begin + if VarType(Value) = varBoolean then + fValue := Abs(Integer(Value)) + else + fValue := Value; +end; + +procedure TSymbolRec.SetVariantValue(const Value: Variant); +begin + fValue := Value; +end; + +procedure TSymbolRec.SetUnionId(const Value: Integer); +begin + fUnionId := Value; +end; + +function TSymbolRec.GetValueAsByteSet: TByteSet; +begin + if GetSymbolRec(TypeId).PatternId = typeVOID then + result := [] + else if VarType(Value) = varObject then + result := VariantToSetObject(Value).Value + else + result := []; +end; + +procedure TSymbolRec.SetValueAsByteSet(const val: TByteSet); +var + SetObject: TSetObject; +begin + if not IsVarObject(Value) then + begin + SetObject := TSetObject.Create(s_table, val, TypeId, typeBYTE); + Value := VarObjectToVariant(SetObject); + end + else + VariantToSetObject(Value).Value := val; +end; + +function TSymbolRec.GetSymbolRec(i_id: Integer): TSymbolRec; +begin + result := TBaseSymbolTable(s_table)[i_id]; +end; + +function TSymbolRec.HasName: Boolean; +begin + result := Name <> ''; +end; + +{$IFDEF PAXARM} +function TSymbolRec.HasPAnsiCharType: Boolean; +begin + result := false; +end; +{$ELSE} +function TSymbolRec.HasPAnsiCharType: Boolean; +var + T: Integer; +begin + result := TypeId = typePANSICHAR; + if result then + Exit; + + result := FinalTypeId = typePOINTER; + if result then + begin + T := TBaseSymbolTable(s_table)[Id].TerminalTypeId; + result := TBaseSymbolTable(s_table)[T].PatternId = typeANSICHAR; + end; +end; +{$ENDIF} + +function TSymbolRec.HasPWideCharType: Boolean; +var + T: Integer; +begin + result := TypeId = typePWIDECHAR; + if result then + Exit; + + result := FinalTypeId = typePOINTER; + if result then + begin + T := TBaseSymbolTable(s_table)[Id].TerminalTypeId; + result := TBaseSymbolTable(s_table)[T].PatternId = typeWIDECHAR; + end; +end; + +function TSymbolRec.HasPVoidType: Boolean; +begin + result := TerminalTypeId = typePVOID; +end; + +function TSymbolRec.ExtraParamNeeded: Boolean; +var + T: Integer; +begin + if Kind in [KindCONSTRUCTOR, KindDESTRUCTOR] then + begin + result := false; + Exit; + end; + + T := FinalTypeId; + + if CallConv = ccMSFASTCALL then + if T = typeRECORD then + if GetSymbolRec(TypeId).Size <= 8 then + begin + result := false; + Exit; + end; + +// if Host then + if T = typeSET then + begin + if TBaseSymbolTable(s_table).GetSizeOfSetType(TypeId) <= 4 then + begin + result := false; + Exit; + end; + end; + + result := T in [ +{$IFNDEF PAXARM} + typeANSISTRING, typeWIDESTRING, + typeSHORTSTRING, +{$ENDIF} +{$IFDEF ARC} + typeCLASS, +{$ENDIF} + typeUNICSTRING, + typeRECORD, + typeEVENT, + typeARRAY, typeDYNARRAY, typeSET, typeVARIANT, typeOLEVARIANT, typeINTERFACE]; +end; + +function TSymbolRec.GetSignatureSimple: String; +var + I, ParamId, T: Integer; + SymbolTable: TBaseSymbolTable; + S: String; +begin + result := ''; + if not (Kind in KindSUBS) then + Exit; + + SymbolTable := TBaseSymbolTable(s_table); + + result := '('; + + for I:=0 to Count - 1 do + begin + ParamId := SymbolTable.GetParamId(Id, I); + T := SymbolTable[ParamId].TypeID; + + S := ''; + if SymbolTable[ParamId].ByRef then + S := 'Var' + else if SymbolTable[ParamId].IsConst then + S := 'Const'; + + result := result + S + ' ' + SymbolTable[T].Name; + + if I < Count - 1 then + result := result + ';'; + end; + + result := result + ')'; +end; + +function TSymbolRec.GetSignature: String; +var + I, ParamId, T: Integer; + SymbolTable: TBaseSymbolTable; + S: String; +begin + result := ''; + if not (Kind in KindSUBS) then + Exit; + + SymbolTable := TBaseSymbolTable(s_table); + + result := '('; + + for I:=0 to Count - 1 do + begin + ParamId := SymbolTable.GetParamId(Id, I); + T := SymbolTable[ParamId].TypeID; + + S := ''; + if SymbolTable[ParamId].ByRef then + S := 'Var' + else if SymbolTable[ParamId].IsConst then + S := 'Const'; + + result := result + S + ' ' + + SymbolTable[ParamId].Name + ':' + SymbolTable[T].Name; + + if I < Count - 1 then + result := result + ';'; + end; + + result := result + ')'; +end; + +function TSymbolRec.GetSignatureEx: String; +begin + result := GetSignature; + if result = '' then + Exit; + + if GetSymbolRec(Id + 1).Name = '' then + result := 'procedure' + result + else + begin + result := 'function' + result; + result := result + ':' + TBaseSymbolTable(s_table)[TypeId].Name; + end; +end; + +function TSymbolRec.GetSignatureBrief: String; +var + I, ParamId, T: Integer; + SymbolTable: TBaseSymbolTable; +begin + result := ''; + if not (Kind in KindSUBS) then + Exit; + + SymbolTable := TBaseSymbolTable(s_table); + + result := '('; + + for I:=0 to Count - 1 do + begin + ParamId := SymbolTable.GetParamId(Id, I); + T := SymbolTable[ParamId].TypeID; + + result := result + ', ' + SymbolTable[T].Name; + + if I < Count - 1 then + result := result + ';'; + end; + + result := result + ')'; +end; + +function TSymbolRec.GetIsStatic: Boolean; +begin + result := (Level = 0) or + (TBaseSymbolTable(s_table)[Level].Kind = KindNAMESPACE); +end; + +procedure TSymbolRec.SetKind(value: Integer); +begin + fKind := value; +end; + +procedure TSymbolRec.SetTypeID(value: Integer); +begin + fTypeID := value; +end; + +function TSymbolRec.IsSubrangeEnumType: Boolean; +begin + result := (Kind = KindTYPE) and (FinalTypeID = typeENUM) and (PatternID = 0); +end; + +function TSymbolRec.HasSubrangeEnumType: Boolean; +begin + result := TBaseSymbolTable(s_table)[TypeId].IsSubrangeEnumType; +end; + +function TSymbolRec.IsNestedSub: Boolean; +begin + result := (Kind = KindSUB) and + (Level > 0) and + (TBaseSymbolTable(s_table)[Level].Kind in KindSubs); +end; + +function TSymbolRec.IsMethod: Boolean; +begin + result := (Kind = KindSUB) and (Level > 0) and (TBaseSymbolTable(s_table)[Level].Kind = KindTYPE); +end; + +function TSymbolRec.IsConstructor: Boolean; +begin + result := (Kind = KindCONSTRUCTOR); +end; + +function TSymbolRec.IsDestructor: Boolean; +begin + result := (Kind = KindDESTRUCTOR); +end; + +function TSymbolRec.Inherits(T: Integer): Boolean; +var + S: TSymbolRec; +begin + result := false; + + if TBaseSymbolTable(s_table).st_tag = 0 then + if T > TBaseSymbolTable(s_table).Card then + Exit; + + S := TBaseSymbolTable(s_table)[T]; + S := TBaseSymbolTable(s_table)[S.TerminalTypeId]; + + if Kind <> kindTYPE then + TBaseSymbolTable(s_table).RaiseError(errInternalError, []); + if FinalTypeId <> typeCLASS then + TBaseSymbolTable(s_table).RaiseError(errInternalError, []); + +{ + if (PClass <> nil) and (S.PClass <> nil) then + if Host and S.Host then + begin + result := PClass.InheritsFrom(S.PClass); + Exit; + end; +} + + if AncestorId > 0 then + begin + result := AncestorId = S.Id; + if not result then + begin + S := TBaseSymbolTable(s_table)[AncestorId]; + S := TBaseSymbolTable(s_table)[S.TerminalTypeId]; + result := S.Inherits(T); + end; + end; +end; + +function TSymbolRec.IsGlobalConst: Boolean; +begin + if Kind <> KindCONST then + begin + result := false; + Exit; + end; + if Level = 0 then + begin + result := true; + Exit; + end; + result := GetSymbolRec(Level).Kind = kindNAMESPACE; +end; + +function TSymbolRec.IsGlobalConstEx: Boolean; +begin + result := IsGlobalConst and + (OwnerId = 0) and (Name <> '') and (Name <> '@'); +end; + +function TSymbolRec.IsGlobalVar: Boolean; +begin + if Kind <> KindVAR then + begin + result := false; + Exit; + end; + if Level = 0 then + begin + result := true; + Exit; + end; + result := GetSymbolRec(Level).Kind = kindNAMESPACE; +end; + +function TSymbolRec.IsGlobalVarEx: Boolean; +begin + result := IsGlobalVar and + (OwnerId = 0) and (Name <> '') and (Name <> '@'); +end; + +function TSymbolRec.IsLocalVarEx: Boolean; +begin + result := false; + if Kind = KindVAR then + if OwnerId = 0 then + if PatternId = 0 then + if Local then + if Name <> '' then + if Name <> '@' then + result := true; +end; + +function TSymbolRec.IsGlobalSub: Boolean; +begin + if Kind <> KindSUB then + begin + result := false; + Exit; + end; + if Level = 0 then + begin + result := true; + Exit; + end; + result := GetSymbolRec(Level).Kind = kindNAMESPACE; +end; + +function TSymbolRec.GetSizeOfScriptClassFields: Integer; + +function _Size: Integer; +var + I, T, TRange, TElem, B1, B2, PrevShift: Integer; + SymbolTable: TBaseSymbolTable; +begin + SymbolTable := TBaseSymbolTable(s_table); + result := 0; + case Kind of + KindSUB: + result := SymbolTable.SizeOfPointer; + KindLABEL: + result := SymbolTable.SizeOfPointer; + else + begin + + if Kind = kindTYPE then + begin + T := Id; + if TypeId = typeALIAS then + T := TerminalTypeId; + end + else + T := TerminalTypeId; + + if (Kind = KindVAR) and ByRef then + begin + result := SymbolTable.SizeOfPointer; + Exit; + end; + + if T < Types.Count then + result := Types.GetSize(T) + else + begin + if SymbolTable[T].Completed then + begin + result := 0; + case FinalTypeId of +{$IFNDEF PAXARM} + typeSHORTSTRING: + begin + result := SymbolTable[T].Count + 1; + end; +{$ENDIF} + typeRECORD, typeCLASS: + begin + PrevShift := -1; + + for I:=T + 1 to SymbolTable.Card do + if (SymbolTable[I].Kind = KindTYPE_FIELD) and + (SymbolTable[I].Level = T) then + begin + if SymbolTable[I].Shift > PrevShift then + begin + PrevShift := SymbolTable[I].Shift; + Inc(result, SymbolTable[I].Size); + end; + end; + end; + typeARRAY: + begin + SymbolTable.GetArrayTypeInfo(T, TRange, TElem); + + if SymbolTable[TRange].Completed and SymbolTable[TElem].Completed then + begin + B1 := SymbolTable.GetLowBoundRec(TRange).Value; + B2 := SymbolTable.GetHighBoundRec(TRange).Value; + + result := SymbolTable[TElem].Size * (B2 - B1 + 1); + end; + end; + else + begin + if FinalTypeId < Types.Count then + result := Types.GetSize(FinalTypeId) + else + TBaseSymbolTable(s_table).RaiseError(errInternalError, []); + end; + end; + end + else + begin + end; + end; + end; + end; +end; + + +//var +// temp: Integer; +begin + if Kind <> KindTYPE then + TBaseSymbolTable(s_table).RaiseError(errInternalError, []); + if FinalTypeId <> typeCLASS then + TBaseSymbolTable(s_table).RaiseError(errInternalError, []); + if Host then + begin + result := 0; + Exit; + end; + + result := _Size; + + if AncestorId = 0 then + Exit; + + if GetSymbolRec(AncestorId).Host then + Exit; + + Inc(result, GetSymbolRec(AncestorId).GetSizeOfScriptClassFields); +end; + +function TSymbolRec.GetSizeOfHostClassFields(P: Pointer): Integer; +begin + Result := 0; + if Kind <> KindTYPE then + TBaseSymbolTable(s_table).RaiseError(errInternalError, []); + if FinalTypeId <> typeCLASS then + TBaseSymbolTable(s_table).RaiseError(errInternalError, []); + if Host then + begin + if PClass = nil then + PClass := GetClass(Name); + if PClass = nil then + begin + if P <> nil then + if Assigned(TBaseRunner(P).OnMapTableClassRef) then + begin + TBaseRunner(P).OnMapTableClassRef(TBaseRunner(P).Owner, + FullName, true, PClass); + if PClass = nil then + TBaseRunner(P).RaiseError(errUnresolvedClassReference, [FullName]) + else + result := PClass.InstanceSize; + Exit; + end; + + if PClass = nil then + begin + TBaseSymbolTable(s_table).RaiseError(errInternalError, []); + result := 0; + end; + end + else + result := PClass.InstanceSize; + end + else + result := GetSymbolRec(AncestorId).GetSizeOfHostClassFields(P); +end; + +function TSymbolRec.GetSizeOfAllClassFields(P: Pointer): Integer; +begin + result := GetSizeOfHostClassFields(P) + GetSizeOfScriptClassFields; +end; + +procedure TSymbolRec.SetIsSharedMethod(value: Boolean); +begin + fIsSharedMethod := value; +end; + +function TSymbolRec.GetIsVirtual: Boolean; +begin + result := (CallMode <> cmNONE) and (CallMode <> cmSTATIC); +end; + +procedure TSymbolRec.SetByRef(value: Boolean); +begin + fByRef := value; +end; + +procedure TSymbolRec.SetByRefEx(value: Boolean); +begin + fByRefEx := value; +end; + + +{ +function TSymbolRec.GetFullName: String; +begin + if Level = 0 then + result := Name + else + result := TBaseSymbolTable(s_table)[Level].GetFullName + '.' + Name; +end; +} + +function TSymbolRec.GetFullName: String; +var + L: Integer; +begin + result := Name; + L := Level; + while L <> 0 do + with TBaseSymbolTable(s_table)[L] do + begin + result := Name + '.' + result; + L := Level; + end; +end; + +function TSymbolRec.IsPacked: Boolean; +begin + result := fDefaultAlignment <= 1; +end; + + +const + FLAG_fIsConst: Cardinal = 1 shl 0; + FLAG_fMustBeAllocated: Cardinal = 1 shl 1; + FLAG_fIsDefault: Cardinal = 1 shl 2; + FLAG_fIsSharedMethod: Cardinal = 1 shl 3; + FLAG_fTypedConst: Cardinal = 1 shl 4; + FLAG_fByRef: Cardinal = 1 shl 5; + FLAG_fByRefEx: Cardinal = 1 shl 6; + FLAG_fIsJavaScriptClass: Cardinal = 1 shl 7; + FLAG_fIsFakeMethod: Cardinal = 1 shl 8; + FLAG_Host: Cardinal = 1 shl 9; + FLAG_Param: Cardinal = 1 shl 10; + FLAG_Optional: Cardinal = 1 shl 11; + FLAG_Completed: Cardinal = 1 shl 12; + FLAG_IsForward: Cardinal = 1 shl 13; + FLAG_fIsOpenArray: Cardinal = 1 shl 14; + FLAG_fIsExternal: Cardinal = 1 shl 15; + FLAG_fInImplementation: Cardinal = 1 shl 16; + FLAG_fIsDeprecated: Cardinal = 1 shl 17; + FLAG_fIsDRTTI: Cardinal = 1 shl 18; + FLAG_fNoRelocate: Cardinal = 1 shl 19; + FLAG_fIsFinal: Cardinal = 1 shl 20; + FLAG_fIsAbstract: Cardinal = 1 shl 21; + FLAG_fIsGeneric: Cardinal = 1 shl 22; + FLAG_fIsDummyType: Cardinal = 1 shl 23; + FLAG_fIsJSFunction: Cardinal = 1 shl 24; + FLAG_fIsOut: Cardinal = 1 shl 25; + FLAG_fRunnerParameter: Cardinal = 1 shl 26; + FLAG_fNoGUID: Cardinal = 1 shl 27; + +type + TSaveRec = packed record + fFinSize: Integer; + fTypeID: Integer; + fShift: Integer; + fUnionId: Integer; + fClassIndex: Integer; + fAncestorId: Integer; + fReadId: Integer; + fWriteId: Integer; + fPosition: Integer; + Id: Integer; + Level: Integer; + OwnerId: Integer; + fPatternId: Integer; + + fVarCount: Int64; + + fCount: SmallInt; + fMethodIndex: SmallInt; + fNegativeMethodIndex: SmallInt; + fOverCount: SmallInt; + fPropIndex: SmallInt; + + fDynamicMethodIndex: SmallInt; + + CallConv: Byte; + fKind: Byte; + fRegister: Byte; + fVis: TClassVisibility; + fCallMode: Byte; + fDefaultAlignment: Byte; + + FLAGS: Cardinal; + end; + +procedure PackRec(S: TSymbolRec; var R: TSaveRec); +begin + R.fFinSize := S.fFinSize; + R.fTypeID := S.fTypeID; + R.fShift := S.fShift; + R.fUnionId := S.fUnionId; + R.fClassIndex := S.fClassIndex; + R.fAncestorId := S.fAncestorId; + R.fReadId := S.fReadId; + R.fWriteId := S.fWriteId; + R.fPosition := S.fPosition; + R.Id := S.Id; + R.Level := S.Level; + R.OwnerId := S.OwnerId; + R.fPatternId := S.fPatternId; + + R.fVarCount := S.fVarCount; + + R.fCount := S.fCount; + R.fMethodIndex := S.fMethodIndex; + R.fNegativeMethodIndex := S.fNegativeMethodIndex; + R.fOverCount := S.fOverCount; + R.fPropIndex := S.fPropIndex; + R.fDynamicMethodIndex := S.fDynamicMethodIndex; + + R.CallConv := S.CallConv; + R.fKind := S.fKind; + R.fRegister := S.fRegister; + R.fVis := S.fVis; + R.fCallMode := S.fCallMode; + R.fDefaultAlignment := S.fDefaultAlignment; + + R.FLAGS := 0; + if S.fIsConst then + R.FLAGS := R.FLAGS or FLAG_fIsConst; + if S.fMustBeAllocated then + R.FLAGS := R.FLAGS or FLAG_fMustBeAllocated; + if S.fIsDefault then + R.FLAGS := R.FLAGS or FLAG_fIsDefault; + if S.fIsSharedMethod then + R.FLAGS := R.FLAGS or FLAG_fIsSharedMethod; + if S.fTypedConst then + R.FLAGS := R.FLAGS or FLAG_fTypedConst; + if S.fByRef then + R.FLAGS := R.FLAGS or FLAG_fByRef; + if S.fByRefEx then + R.FLAGS := R.FLAGS or FLAG_fByRefEx; + if S.fIsJavaScriptClass then + R.FLAGS := R.FLAGS or FLAG_fIsJavaScriptClass; + if S.fIsFakeMethod then + R.FLAGS := R.FLAGS or FLAG_fIsFakeMethod; + if S.Host then + R.FLAGS := R.FLAGS or FLAG_Host; + if S.Param then + R.FLAGS := R.FLAGS or FLAG_Param; + if S.Optional then + R.FLAGS := R.FLAGS or FLAG_Optional; + if S.Completed then + R.FLAGS := R.FLAGS or FLAG_Completed; + if S.IsForward then + R.FLAGS := R.FLAGS or FLAG_IsForward; + if S.fIsOpenArray then + R.FLAGS := R.FLAGS or FLAG_fIsOpenArray; + if S.fIsExternal then + R.FLAGS := R.FLAGS or FLAG_fIsExternal; + if S.fInImplementation then + R.FLAGS := R.FLAGS or FLAG_fInImplementation; + if S.fIsDeprecated then + R.FLAGS := R.FLAGS or FLAG_fIsDeprecated; + if S.fIsDRTTI then + R.FLAGS := R.FLAGS or FLAG_fIsDRTTI; + if S.fNoRelocate then + R.FLAGS := R.FLAGS or FLAG_fNoRelocate; + if S.fIsFinal then + R.FLAGS := R.FLAGS or FLAG_fIsFinal; + if S.fIsAbstract then + R.FLAGS := R.FLAGS or FLAG_fIsAbstract; + if S.fIsDummyType then + R.FLAGS := R.FLAGS or FLAG_fIsDummyType; + if S.fIsJSFunction then + R.FLAGS := R.FLAGS or FLAG_fIsJSFunction; + if S.fIsOut then + R.FLAGS := R.FLAGS or FLAG_fIsOut; + if S.fRunnerParameter then + R.FLAGS := R.FLAGS or FLAG_fRunnerParameter; + if S.fNoGUID then + R.FLAGS := R.FLAGS or FLAG_fNoGUID; +end; + +procedure UnpackRec(const S: TSaveRec; R: TSymbolRec); +begin + R.fFinSize := S.fFinSize; + R.fTypeID := S.fTypeID; + R.fShift := S.fShift; + R.fUnionId := S.fUnionId; + R.fClassIndex := S.fClassIndex; + R.fAncestorId := S.fAncestorId; + R.fReadId := S.fReadId; + R.fWriteId := S.fWriteId; + R.fPosition := S.fPosition; + R.Id := S.Id; + R.Level := S.Level; + R.OwnerId := S.OwnerId; + R.fPatternId := S.fPatternId; + + R.fVarCount := S.fVarCount; + + R.fCount := S.fCount; + R.fMethodIndex := S.fMethodIndex; + R.fNegativeMethodIndex := S.fNegativeMethodIndex; + R.fOverCount := S.fOverCount; + R.fPropIndex := S.fPropIndex; + R.fDynamicMethodIndex := S.fDynamicMethodIndex; + + R.CallConv := S.CallConv; + R.fKind := S.fKind; + R.fRegister := S.fRegister; + R.fVis := S.fVis; + R.fCallMode := S.fCallMode; + R.fDefaultAlignment := S.fDefaultAlignment; + + R.fIsConst := (S.FLAGS and FLAG_fIsConst) > 0; + R.fMustBeAllocated := (S.FLAGS and FLAG_fMustBeAllocated) > 0; + R.fIsDefault := (S.FLAGS and FLAG_fIsDefault) > 0; + R.fIsSharedMethod := (S.FLAGS and FLAG_fIsSharedMethod) > 0; + R.fTypedConst := (S.FLAGS and FLAG_fTypedConst) > 0; + R.fByRef := (S.FLAGS and FLAG_fByRef) > 0; + R.fByRefEx := (S.FLAGS and FLAG_fByRefEx) > 0; + R.fIsJavaScriptClass := (S.FLAGS and FLAG_fIsJavaScriptClass) > 0; + R.fIsFakeMethod := (S.FLAGS and FLAG_fIsFakeMethod) > 0; + R.Host := (S.FLAGS and FLAG_Host) > 0; + R.Param := (S.FLAGS and FLAG_Param) > 0; + R.Optional := (S.FLAGS and FLAG_Optional) > 0; + R.Completed := (S.FLAGS and FLAG_Completed) > 0; + R.IsForward := (S.FLAGS and FLAG_IsForward) > 0; + R.fIsOpenArray := (S.FLAGS and FLAG_fIsOpenArray) > 0; + R.fIsExternal := (S.FLAGS and FLAG_fIsExternal) > 0; + R.fInImplementation := (S.FLAGS and FLAG_fInImplementation) > 0; + R.fIsDeprecated := (S.FLAGS and FLAG_fIsDeprecated) > 0; + R.fIsDRTTI := (S.FLAGS and FLAG_fIsDRTTI) > 0; + R.fNoRelocate := (S.FLAGS and FLAG_fNoRelocate) > 0; + R.fIsFinal := (S.FLAGS and FLAG_fIsFinal) > 0; + R.fIsAbstract := (S.FLAGS and FLAG_fIsAbstract) > 0; + R.fIsDummyType := (S.FLAGS and FLAG_fIsDummyType) > 0; + R.fIsJSFunction := (S.FLAGS and FLAG_fIsJSFunction) > 0; + R.fIsOut := (S.FLAGS and FLAG_fIsOut) > 0; + R.fRunnerParameter := (S.FLAGS and FLAG_fRunnerParameter) > 0; + R.fNoGUID := (S.FLAGS and FLAG_fNoGUID) > 0; +end; + +procedure TSymbolRec.SaveToStream(S: TWriter); +var + K: Integer; + R: TSaveRec; +begin + PackRec(Self, R); + S.Write(R, SizeOf(R)); + + S.WriteString(fName); + + if fSupportedInterfaces = nil then + begin + K := -1; + S.Write(K, SizeOf(K)); + end + else + begin + K := fSupportedInterfaces.Count; + S.Write(K, SizeOf(K)); + fSupportedInterfaces.SaveToStream(S); + end; + + SaveVariantToStream(fValue, S); +end; + +procedure TSymbolRec.LoadFromStream(S: TReader); +var + K: Integer; + R: TSaveRec; +begin + S.Read(R, SizeOf(R)); + UnpackRec(R, Self); + + fName := S.ReadString; + + S.Read(K, SizeOf(K)); + if K >= 0 then + begin + fSupportedInterfaces := TGuidList.Create; + fSupportedInterfaces.LoadFromStream(S); + end + else + fSupportedInterfaces := nil; + + fValue := LoadVariantFromStream(S, s_table); + + Address := nil; + PClass := nil; +end; + +procedure TSymbolRec.Update; +var + HashArray: THashArray; +begin + HashArray := TBaseSymbolTable(s_table).HashArray; + Id := TBaseSymbolTable(s_table).Card; + + if HashArray <> nil then + HashArray.AddName(fName, Id); +end; + +function TSymbolRec.GetHeight: Integer; +begin + result := 0; + if Level = 0 then + Exit; + if not (TBaseSymbolTable(s_table)[Level].Kind in kindSUBS) then + Exit; + result := 1 + TBaseSymbolTable(s_table)[Level].GetHeight; +end; + +function TSymbolRec.IsSubPartOfEventType: Boolean; +var + SymbolTable: TBaseSymbolTable; + I: Integer; + RI: TSymbolRec; +begin + result := false; + + if Kind <> KindSUB then + Exit; + + SymbolTable := TBaseSymbolTable(s_table); + for I:=Id - 1 to Id + 30 do + begin + if I > SymbolTable.Card then + Exit; + RI := SymbolTable[I]; + if RI.Kind = KindTYPE then + if RI.FinalTypeId = typeEVENT then + if RI.PatternId = Id then + begin + result := true; + Exit; + end; + end; +end; + +function TSymbolRec.IsSubPartOfProcType: Boolean; +var + SymbolTable: TBaseSymbolTable; + I: Integer; + RI: TSymbolRec; +begin + result := false; + + if Kind <> KindSUB then + Exit; + + SymbolTable := TBaseSymbolTable(s_table); + for I:=Id - 1 to Id + 30 do + begin + if I > SymbolTable.Card then + Exit; + RI := SymbolTable[I]; + if RI.Kind = KindTYPE then + if RI.FinalTypeId = typePROC then + if RI.PatternId = Id then + begin + result := true; + Exit; + end; + end; +end; + +procedure TSymbolRec.SetTypedConst(value: Boolean); +begin + fTypedConst := value; +end; + +function TSymbolRec.GetNameEx: String; +begin + result := Name; +{$IFNDEF PAXARM} + if result = '' then + if Kind = KindTYPE then + if FinalTypeId = typeSHORTSTRING then + result := 'String[' + IntToStr(Count) + ']'; +{$ENDIF} +end; + +procedure TSymbolRec.SetPatternId(value: Integer); +begin + if value = typeWIDECHAR then + begin + if Kind = KindTYPE then + if FinalTypeId = typeSET then +{$IFDEF PAXARM} + value := typeWIDECHAR; +{$ELSE} + value := typeANSICHAR; +{$ENDIF} + end; + fPatternId := value; +end; + +function TSymbolRec.GetIsPublished: Boolean; +begin + result := (vis = cvPublished); +end; + +procedure TSymbolRec.SetIsPublished(value: Boolean); +begin + if value then + vis := cvPublished; +end; + +procedure TSymbolRec.SetIsOpenArray(value: Boolean); +begin + fIsOpenArray := value; +end; + +function TSymbolRec.GetNamespaceId: Integer; +begin + result := 0; + if Level > 0 then + begin + if GetSymbolRec(Level).Kind = kindNAMESPACE then + begin + result := Level; + Exit; + end + else + result := GetSymbolRec(Level).GetNamespaceId; + end +end; + +procedure TSymbolRec.SetCount(value: Integer); +begin + fCount := value; +end; + +function TSymbolRec.IsFWArrayVar: Boolean; +var + T, TA: Integer; +begin + result := (Kind = KindVAR); + if not result then + Exit; + result := false; + T := TerminalTypeId; + if T = 0 then + Exit; + if T = H_TFW_Array then + begin + result := true; + Exit; + end; + while GetSymbolRec(T).FinalTypeId = typeCLASS do + begin + TA := GetSymbolRec(T).AncestorId; + if TA = 0 then + Exit; + if TA = H_TFW_Array then + begin + result := true; + Exit; + end; + T := TA; + end; +end; + +function TSymbolRec.HasFrameworkType: Boolean; +var + T: Integer; +begin + result := false; + if FinalTypeId <> typeCLASS then + Exit; + T := TerminalTypeId; + if T = H_TFW_Object then + begin + result := true; + Exit; + end; + result := GetSymbolRec(T).Inherits(H_TFW_Object); +end; + +function TSymbolRec.GetIsGeneric: Boolean; +begin + result := PosCh('<', Name) > 0; +end; + +procedure TSymbolRec.SetRegister(value: Integer); +begin + fRegister := value; +end; + +procedure TSymbolRec.SetMethodIndex(value: Integer); +begin + fMethodIndex := value; +end; + +procedure TSymbolRec.SetOverCount(value: Byte); +begin + fOverCount := value; +end; + +end. diff --git a/Sources/PAXCOMP_SYMBOL_TABLE.pas b/Sources/PAXCOMP_SYMBOL_TABLE.pas new file mode 100644 index 0000000..189eee3 --- /dev/null +++ b/Sources/PAXCOMP_SYMBOL_TABLE.pas @@ -0,0 +1,2342 @@ +//////////////////////////////////////////////////////////////////////////// +// PaxCompiler +// Site: http://www.paxcompiler.com +// Author: Alexander Baranovsky (paxscript@gmail.com) +// ======================================================================== +// Copyright (c) Alexander Baranovsky, 2006-2014. All rights reserved. +// Code Version: 4.2 +// ======================================================================== +// Unit: PAXCOMP_SYMBOL_TABLE.pas +// ======================================================================== +//////////////////////////////////////////////////////////////////////////// + +{$I PaxCompiler.def} +unit PAXCOMP_SYMBOL_TABLE; +interface +uses {$I uses.def} + TypInfo, + SysUtils, + Classes, + PAXCOMP_CONSTANTS, + PAXCOMP_TYPES, + PAXCOMP_SYS, + PAXCOMP_VAROBJECT, + PAXCOMP_BASESYMBOL_TABLE, + PAXCOMP_LOCALSYMBOL_TABLE, + PAXCOMP_SYMBOL_REC, + PAXCOMP_OFFSET, + PAXCOMP_MAP, + PAXCOMP_STDLIB; + +type + + TSymbolTable = class(TLocalSymbolTable) + private + kernel: Pointer; + public + InCode: array of Boolean; + CompileCard: Integer; + LinkCard: Integer; + IsExtraTable: Boolean; + constructor Create(i_kernel: Pointer); + procedure Reset; override; + procedure ResetCompilation; + procedure SetShifts(prog: Pointer); + procedure RaiseError(const Message: string; params: array of const); + procedure CreateOffsets(JS1, JS2: Integer); + function GetValueAsString(P: Pointer; + StackFrameNumber: Integer; + Id: Integer; + TypeMapRec: TTypeMapRec = nil; + BriefCls: Boolean = false): String; override; + function GetSizeOfParams(SubId: Integer): Integer; + end; + +implementation + +uses + PAXCOMP_BYTECODE, + PAXCOMP_BASERUNNER, + PAXCOMP_KERNEL; + +// TSymbolTable ---------------------------------------------------------------- + +constructor TSymbolTable.Create(i_kernel: Pointer); +begin + inherited Create(TKernel(i_kernel).GT); + Self.kernel := i_kernel; + IsExtraTable := false; +end; + +procedure TSymbolTable.Reset; +begin + inherited; + ExternList.Clear; + CompileCard := Card; + LinkCard := Card; +end; + +procedure TSymbolTable.ResetCompilation; +var + I, Id: Integer; + S: String; +begin + while Card > CompileCard do + begin + S := Records[Card].Name; + Id := Records[Card].Id; + HashArray.DeleteName(S, Id); + + I := Card - FirstLocalId - 1; +{$IFDEF ARC} + A[I] := nil; +{$ELSE} + TSymbolRec(A[I]).Free; +{$ENDIF} + A.Delete(I); + + Dec(Card); + end; + + if TypeHelpers <> nil then + begin + FreeAndNil(TypeHelpers); + TypeHelpers := GlobalST.TypeHelpers.Clone; + end; +end; + +procedure TSymbolTable.SetShifts(prog: Pointer); + + procedure SetInCode; + var + Code: TCode; + I, Id: Integer; + begin + InCode := nil; + SetLength(InCode, Card + Card); + Code := TKernel(kernel).Code; + + for I := 1 to StdCard do + InCode[I] := true; + + for I:= 1 to Code.Card do + begin + + Id := Code[I].Arg1; + if Id > 0 then + if Id <= Card then + InCode[Id] := true; + + Id := Code[I].Arg2; + if Id > 0 then + if Id <= Card then + InCode[Id] := true; + + Id := Code[I].Res; + if Id > 0 then + if Id <= Card then + InCode[Id] := true; + + end; + end; + + + procedure ProcessType(T: Integer); forward; + + procedure ProcessRecordType(T: Integer); + var + J, J1, FT, FT1, S, CurrAlign, DefAlign, VJ, VK, VS: Integer; + VarPathList: TVarPathList; + Path: TVarPath; + RJ: TSymbolRec; + begin + if Records[T].Host then + Exit; + + if Records[T].TypeID = typeALIAS then + T := Records[T].PatternId; + + VarPathList := TVarPathList.Create; + + try + + for J:=T + 1 to Card do + begin + RJ := Records[J]; + + if RJ.Kind = KindSUB then + if RJ.Level <> T then + break; + + if (RJ.Kind = KindTYPE_FIELD) and (RJ.Level = T) then + if RJ.VarCount > 0 then + VarPathList.Add(J, RJ.VarCount); + end; + + S := 0; + if Records[T].IsPacked then + begin + if VarPathList.Count = 0 then + begin + for J:=T + 1 to Card do + begin + RJ := Records[J]; + + if RJ.Kind = KindSUB then + if RJ.Level <> T then + break; + + if (RJ.Kind = KindTYPE_FIELD) and (RJ.Level = T) then + begin + RJ.Shift := S; + ProcessType(RJ.TypeId); + Inc(S, RJ.Size); + end; + end; + end // VarCnt = 0 + else + begin + for J:=T + 1 to Card do + begin + RJ := Records[J]; + + if RJ.Kind = KindSUB then + if RJ.Level <> T then + break; + + if (RJ.Kind = KindTYPE_FIELD) and (RJ.Level = T) then + begin + if RJ.VarCount > 0 then + break; + + RJ.Shift := S; + ProcessType(RJ.TypeId); + Inc(S, RJ.Size); + end; + end; + + // process variant part of record + + VS := S; + + for VK :=0 to VarPathList.Count - 1 do + begin + Path := VarPathList[VK]; + + S := VS; + for VJ := 0 to Path.Count - 1 do + begin + J := Path[VJ].Id; + + RJ := Records[J]; + + RJ.Shift := S; + ProcessType(RJ.TypeId); + Inc(S, RJ.Size); + end; + end; + end; + end + else + begin + DefAlign := Records[T].DefaultAlignment; + + if VarPathList.Count = 0 then + begin + J1 := -1; + + for J:=T + 1 to Card do + begin + RJ := Records[J]; + + if RJ.Kind = KindSUB then + if RJ.Level <> T then + break; + + if (RJ.Kind = KindTYPE_FIELD) and (RJ.Level = T) then + begin + CurrAlign := GetAlignmentSize(RJ.TypeId, DefAlign); + + if J1 > 0 then + begin + FT1 := Records[J-1].FinalTypeId; + FT := RJ.FinalTypeId; + if FT = FT1 then + begin + CurrAlign := 1; + J1 := -1; + end + else + J1 := J; + end + else + J1 := J; + + if CurrAlign > 1 then + while S mod CurrAlign <> 0 do + Inc(S); + + RJ.Shift := S; + ProcessType(RJ.TypeId); + Inc(S, RJ.Size); + end; + end; + + end // VarCnt = 0 + else + begin // VarCnt > 0 + J1 := -1; + + for J:=T + 1 to Card do + begin + RJ := Records[J]; + + if RJ.Kind = KindSUB then + if RJ.Level <> T then + break; + + if (RJ.Kind = KindTYPE_FIELD) and (RJ.Level = T) then + begin + if RJ.VarCount > 0 then + break; + + CurrAlign := GetAlignmentSize(RJ.TypeId, DefAlign); + + if J1 > 0 then + begin + FT1 := Records[J-1].FinalTypeId; + FT := RJ.FinalTypeId; + if FT = FT1 then + begin + CurrAlign := 1; + J1 := -1; + end + else + J1 := J; + end + else + J1 := J; + + if CurrAlign > 1 then + while S mod CurrAlign <> 0 do + Inc(S); + + RJ.Shift := S; + ProcessType(RJ.TypeId); + Inc(S, RJ.Size); + end; + end; + + // process variant part of record + + VS := S; + + for VK :=0 to VarPathList.Count - 1 do + begin + S := VS; + Path := VarPathList[VK]; + for VJ := 0 to Path.Count - 1 do + begin + J := Path[VJ].Id; + + RJ := Records[J]; + + CurrAlign := GetAlignmentSize(RJ.TypeId, DefAlign); + + if J1 > 0 then + begin + FT1 := Records[J-1].FinalTypeId; + FT := RJ.FinalTypeId; + if FT = FT1 then + begin + CurrAlign := 1; + J1 := -1; + end + else + J1 := J; + end + else + J1 := J; + + if CurrAlign > 1 then + while S mod CurrAlign <> 0 do + Inc(S); + + RJ.Shift := S; + ProcessType(RJ.TypeId); + Inc(S, RJ.Size); + end; + end; + end; // VarCnt > 0 + end; + + finally + FreeAndNil(VarPathList); + end; + end; + + procedure ProcessClassType(T: Integer); + var + J, S, AncestorId: Integer; + RJ: TSymbolRec; + begin + if Records[T].Host then + Exit; + + if Records[T].TypeID = typeALIAS then + T := Records[T].PatternId; + + AncestorId := Records[T].AncestorId; + if AncestorId = 0 then + S := 0 + else + begin + if not Records[AncestorId].Completed then + begin + ProcessClassType(AncestorId); + Records[AncestorId].Completed := true; + end; + S := Records[AncestorId].GetSizeOfAllClassFields(prog); + end; + + if Records[T].IsPacked then + begin + for J:=T + 1 to Card do + begin + RJ := Records[J]; + if (RJ.Kind = KindTYPE_FIELD) and (RJ.Level = T) then + begin + RJ.Shift := S; + ProcessType(RJ.TypeId); + Inc(S, RJ.Size); + end; + end; + end + else + RaiseError(errInternalError, []); + end; + + procedure ProcessArrayType(T: Integer); + var + J, PatternId: Integer; + RJ: TSymbolRec; + begin + for J:=T + 1 to Card do + begin + RJ := Records[J]; + if RJ.Level = T then + begin + if RJ.Kind in [KindLABEL, KindNONE] then + continue; + + if RJ.Kind <> KindTYPE then + RaiseError(errInternalError, []); + + if RJ.TypeID = typeALIAS then + begin + PatternId := RJ.PatternId; + ProcessType(PatternId); + end + else + ProcessType(J); + end; + end; + end; + + procedure ProcessType(T: Integer); + begin + if Records[T].Kind <> kindTYPE then + RaiseError(errInternalError, []); + + T := Records[T].TerminalTypeId; + + if Records[T].Completed then + Exit; + + Records[T].Completed := true; + + case Records[T].FinalTypeId of + typeRECORD: ProcessRecordType(T); + typeCLASS: ProcessClassType(T); + + typeBOOLEAN, +{$IFNDEF PAXARM} + typeANSICHAR, + typeANSISTRING, + typeWIDESTRING, + typeSHORTSTRING, +{$ENDIF} + typeBYTE, typeWORD, + typeINTEGER, typeDOUBLE, + typeSINGLE, typeEXTENDED, typeCURRENCY, + typeCLASSREF, typeWIDECHAR, + typeVARIANT, typeOLEVARIANT, + typeDYNARRAY, typeOPENARRAY, + typeINT64, typeUINT64, typeINTERFACE, typeCARDINAL, + typeSMALLINT, typeSHORTINT, typeBYTEBOOL, typeWORDBOOL, typeLONGBOOL, + typeENUM, typePOINTER, typePROC, typeEVENT, + typeSET: begin end; + + typeTYPEPARAM: begin end; + typeHELPER: begin end; + + typeARRAY: ProcessArrayType(T); + typeALIAS: ProcessType(Records[T].PatternID); + else + RaiseError(errInternalError, []); + end; + + // Records[T].Completed := true; + end; + +var + I, J, OwnerId, PatternId, ArrayTypeId, RangeTypeId, ElemTypeId: Integer; + S, SP, SL, H1, TypeID, SZ, RegCount, NP, K, FT: Integer; + ExtraParamNeeded, IsMethod: Boolean; + RI, RJ: TSymbolRec; + RI_FinalTypeId: Integer; + K1, K2, KK: Integer; + RI_Kind: Integer; + KK1, KK2: Integer; + LL: TIntegerList; + RSPOffset, SubRSPSize: Integer; +begin + KK1 := 1; + KK2 := 2; + if IsExtraTable then + begin + KK1 := 3; + KK2 := 3; + end; + LL := TIntegerList.Create; + + if LinkCard > 0 then + LastShiftValue := GetDataSize(LinkCard) + else + LastShiftValue := GetDataSize(LinkCard); + + S := LastShiftValue; + + SetInCode; + + for KK := KK1 to KK2 do + begin + + if KK = 1 then + begin + K1 := ResultId + 1; + K2 := GlobalST.Card; + end + else if KK = 2 then + begin + K1 := FirstLocalId + 1; + K2 := Card; + end + else // KK = 3 + begin + K1 := LinkCard; + K2 := Card; + end; + + for I := K1 to K2 do + begin + RI := Records[I]; + + RI_Kind := RI.Kind; + + if RI_Kind = kindPROP then + continue; + + if KK = 1 then + if (RI.Shift <> 0) and (not RI.Host) then + begin + if RI_Kind = KindCONST then + begin +{$IFNDEF PAXARM} + if RI.HasPAnsiCharType then + begin + if InCode[I] then + TKernel(kernel).Code.Add(OP_INIT_PANSICHAR_LITERAL, I, 0, 0, 0, true, PASCAL_LANGUAGE, 0, -1); + end + else +{$ENDIF} + if RI.HasPWideCharType then + begin + if InCode[I] then + TKernel(kernel).Code.Add(OP_INIT_PWIDECHAR_LITERAL, I, 0, 0, 0, true, PASCAL_LANGUAGE, 0, -1); + end; + end; + + continue; + end; + + if KK = 2 then + if I <= LinkCard then + if (RI.Shift <> 0) and (not RI.Host) then + begin + if RI_Kind = KindCONST then + begin +{$IFNDEF PAXARM} + if RI.HasPAnsiCharType then + begin + if InCode[I] then + TKernel(kernel).Code.Add(OP_INIT_PANSICHAR_LITERAL, I, 0, 0, 0, true, PASCAL_LANGUAGE, 0, -1); + end + else +{$ENDIF} + if RI.HasPWideCharType then + begin + if InCode[I] then + TKernel(kernel).Code.Add(OP_INIT_PWIDECHAR_LITERAL, I, 0, 0, 0, true, PASCAL_LANGUAGE, 0, -1); + end; + end; + + continue; + end; + + if RI.UnionId <> 0 then + begin + RI.Shift := Records[RI.UnionId].Shift; + if RI.UnionId > I then + LL.Add(I); + continue; + end; + + RI_FinalTypeId := RI.FinalTypeId; + + if RI.Host then + begin + case RI_Kind of + kindSUB, KindCONSTRUCTOR, KindDESTRUCTOR: + begin + if RI.CallConv = cc64 then + begin + NP := RI.Count; + + if NP = 0 then + continue; + + RegCount := 0; + RSPOffset := $20; + + if RI.ExtraParamNeeded then + Inc(RegCount); + if (RI.IsMethod or RI.IsSubPartOfEventType) and (RI.CallMode <> cmSTATIC) then + Inc(RegCount); + + if I = JS_AlertId then + if RI.Name = 'alert' then + Inc(RegCount); + + for J:=I + 1 to GetParamId(I, NP - 1) do + begin + RJ := Records[J]; + + if RJ.Level <> I then + break; + if RJ.Param then + begin + FT := RJ.FinalTypeId; + + if FT in RealTypes then + begin + Inc(RegCount); + + case RegCount of + 1: RJ.XMMReg := _XMM0; + 2: RJ.XMMReg := _XMM1; + 3: RJ.XMMReg := _XMM2; + 4: RJ.XMMReg := _XMM3; + else + begin + RJ.RSPOffset := RSPOffset; + Inc(RSPOffset, 8); + end; + end; + continue; + end; + + if FT in [typeRECORD, typeARRAY] then + begin + if RJ.Size > 4 then + RJ.ByRefEx := true; + end; + + if RJ.ByRef or RJ.ByRefEx + or + ( + (RJ.Size <= SizeOfPointer) and (not (FT in RealTypes)) + ) + or + (FT in [ +{$IFNDEF PAXARM} + typeSHORTSTRING, +{$ENDIF} + typeVARIANT, typeOLEVARIANT, typeEVENT, typeSET]) + then + begin + Inc(RegCount); + + if RI_Kind = KindCONSTRUCTOR then + begin + if Records[RI.Level].FinalTypeId = typeRECORD then + case RegCount of + 1: RJ.Register := _EDX; + 2: RJ.Register := _R8; + 3: RJ.Register := _R9; + else + begin + RJ.RSPOffset := RSPOffset; + Inc(RSPOffset, 8); + end; + end + else + case RegCount of + 1: RJ.Register := _R8; + 2: RJ.Register := _R9; + else + begin + RJ.RSPOffset := RSPOffset; + Inc(RSPOffset, 8); + end; + end; + end + else + case RegCount of + 1: RJ.Register := _ECX; + 2: RJ.Register := _EDX; + 3: RJ.Register := _R8; + 4: RJ.Register := _R9; + else + begin + RJ.RSPOffset := RSPOffset; + Inc(RSPOffset, 8); + end; + end; + + if FT in [typeDYNARRAY, typeOPENARRAY] then + if RJ.IsOpenArray then + begin + Inc(RegCount); + Inc(RSPOffset, 8); + end; + end; + end; + end; + end // cc64 + else if RI.CallConv = ccREGISTER then + begin + NP := RI.Count; + + if NP = 0 then + continue; + + RegCount := 0; + for J:=I + 1 to GetParamId(I, NP - 1) do + begin + RJ := Records[J]; + + if RJ.Level <> I then + break; + if RJ.Param then + begin + FT := RJ.FinalTypeId; + if FT in [typeRECORD, typeARRAY] then + begin + if RJ.Size > 4 then + RJ.ByRefEx := true; + end; + + if RJ.ByRef or RJ.ByRefEx + or + ( + (RJ.Size <= 4) and (FT <> typeSINGLE) + ) + or + (FT in [ +{$IFNDEF PAXARM} + typeSHORTSTRING, +{$ENDIF} + typeVARIANT, typeOLEVARIANT, typeEVENT, typeSET]) + then + begin + Inc(RegCount); + + if RI_Kind = KindCONSTRUCTOR then + begin + if Records[RI.Level].FinalTypeId = typeRECORD then + case RegCount of + 1: RJ.Register := _EDX; + 2: RJ.Register := _ECX; + end + else + case RegCount of + 1: RJ.Register := _ECX; + end; + end + else + if (RI.IsMethod or RI.IsSubPartOfEventType) and + (RI.CallMode <> cmSTATIC) then + case RegCount of + 1: RJ.Register := _EDX; + 2: RJ.Register := _ECX; + end + else + case RegCount of + 1: RJ.Register := _EAX; + 2: RJ.Register := _EDX; + 3: RJ.Register := _ECX; + end; + + if FT in [typeDYNARRAY, typeOPENARRAY] then + if RJ.IsOpenArray then + Inc(RegCount); + end; + end; + end; + end // ccREGISTER + else + if RI.CallConv = ccMSFASTCALL then + begin + NP := RI.Count; + + if NP = 0 then + continue; + + RegCount := 1; + for J:=I + 1 to GetParamId(I, NP - 1) do + begin + RJ := Records[J]; + + if RJ.Level <> I then + break; + + if RJ.Param then + begin + if RJ.ByRef + or + ( + (RJ.Size <= 4) and (RJ.FinalTypeId <> typeSINGLE) + ) + or + (RJ.FinalTypeId in [ +{$IFNDEF PAXARM} + typeSHORTSTRING, +{$ENDIF} + typeVARIANT, typeOLEVARIANT]) + then + begin + Inc(RegCount); + + if RI_Kind = KindCONSTRUCTOR then + case RegCount of + 1: RJ.Register := _ECX; + end + else + if (RI.IsMethod) and (RI.CallMode <> cmSTATIC) then + case RegCount of + 1: RJ.Register := _ECX; + end + else + case RegCount of + 2: RJ.Register := _ECX; + 3: RJ.Register := _EDX; + end; + + if RJ.FinalTypeId in [typeDYNARRAY, typeOPENARRAY] then + if RJ.IsOpenArray then + Inc(RegCount); + end; + end; + end; + end; // ccMS_FASTCALL + end; // kindSUB, KindCONSTRUCTOR, KindDESTRUCTOR (HOST) + KindTYPE: + begin + RI.Completed := true; + end; + end // case + end + else // not host + case RI_Kind of + kindVAR: + begin + if RI.Param then + begin + // already done + end + else if RI.Local then + begin + // already done + end + else // global + begin + if RI.InternalField then + begin + OwnerId := RI.OwnerId; + TypeId := Records[OwnerId].FinalTypeId; + case TypeId of + typeRECORD: + begin + PatternId := RI.PatternId; + RI.Shift := Records[OwnerId].Shift + Records[PatternId].Shift; + end; + typeARRAY: + begin + ArrayTypeId := Records[OwnerId].TerminalTypeId; + + GetArrayTypeInfo(ArrayTypeId, RangeTypeId, ElemTypeId); + H1 := GetLowBoundRec(RangeTypeId).Value; + + RI.Shift := Records[OwnerId].Shift + + Records[ElemTypeId].Size * (RI.Value - H1); + end; + else + begin + RI.Kind := kindNONE; + RI.Name := ''; + RI.OwnerId := 0; + continue; + +// RaiseError(errInternalError, []); + end; + end; + end + else + begin + TypeId := RI.TypeId; + + if TypeId = 0 then + RI.Kind := kindNONE + else + begin + ProcessType(TypeId); + RI.Shift := S; + Inc(S, RI.Size); + end; + end; + end; + end; + kindCONST: + begin + if RI_FinalTypeId = typeDOUBLE then + begin + RI.Shift := S; + Inc(S, SizeOf(Double)); + end + else if RI_FinalTypeId = typeSINGLE then + begin + RI.Shift := S; + Inc(S, SizeOf(Single)); + end + else if RI_FinalTypeId = typeEXTENDED then + begin + RI.Shift := S; + Inc(S, SizeOf(Extended)); + end + else if RI_FinalTypeId = typeCURRENCY then + begin + RI.Shift := S; + Inc(S, SizeOf(Currency)); + end + else if RI_FinalTypeId in INT64Types then + begin + RI.Shift := S; + Inc(S, SizeOf(Int64)); + end + else if RI_FinalTypeId = typeRECORD then + begin + RI.Shift := S; + Inc(S, RI.Size); + end + else if RI_FinalTypeId = typeARRAY then + begin + RI.Shift := S; + Inc(S, RI.Size); + end + else if RI_FinalTypeId in VariantTypes then + begin + RI.Shift := S; + Inc(S, SizeOf(Variant)); + end + else if RI_FinalTypeId = typeSET then + begin + RI.Shift := S; + ProcessType(RI.TypeId); + Inc(S, RI.Size); + end +{$IFNDEF PAXARM} + else if RI.HasPAnsiCharType then + begin + RI.Shift := S; + + Inc(S, SizeOfPointer); // pointer to string literal + Inc(S, SizeOfPointer); // ref counter + Inc(S, SizeOfPointer); // length + + if InCode[I] then + TKernel(kernel).Code.Add(OP_INIT_PANSICHAR_LITERAL, I, 0, 0, 0, true, PASCAL_LANGUAGE, 0, -1); + + // reserve place for literal + Inc(S, Length(RI.Value) + 1); + end +{$ENDIF} + else if RI.HasPWideCharType then + begin + RI.Shift := S; + + Inc(S, SizeOfPointer); // pointer to string literal + Inc(S, SizeOfPointer); // length + + if InCode[I] then + TKernel(kernel).Code.Add(OP_INIT_PWIDECHAR_LITERAL, I, 0, 0, 0, true, PASCAL_LANGUAGE, 0, -1); + + // reserve place for literal + Inc(S, Length(RI.Value) * 2 + 2); + end + else + begin + if RI.MustBeAllocated then + begin + RI.Shift := S; + Inc(S, RI.Size); + end; + end; + end; + + kindSUB, KindCONSTRUCTOR, KindDESTRUCTOR: + begin + RI.Shift := S; + Inc(S, SizeOfPointer); + + SP := 8 + 3 * 4; + SL := 0; + + ExtraParamNeeded := RI.ExtraParamNeeded; + + IsMethod := (Records[GetSelfId(I)].Name <> '') and + (Records[I].CallMode <> cmSTATIC); + + if ExtraParamNeeded then + if RI.CallConv in [ccSTDCALL, ccSAFECALL, ccCDECL] then + Inc(SP, 4); + + if RI.CallConv in [ccSTDCALL, ccSAFECALL, ccCDECL] then + begin + for J:=I + 1 to Card do + begin + if ExtraParamNeeded then + begin + if J = GetResultId(I) then + continue; + end; + + RJ := Records[J]; + + if RJ.Level <> I then + continue; + + if RJ.UnionId <> 0 then + begin + RJ.Shift := Records[RJ.UnionId].Shift; + if RI.UnionId > I then + LL.Add(I); + continue; + end; + + if RJ.Param then + begin + RJ.Shift := SP; + + if RJ.FinalTypeId in [typeDYNARRAY, typeOPENARRAY] then + if RJ.IsOpenArray then + Inc(SP, 4); + +// RJ.Shift := SP; + + FT := RJ.FinalTypeId; + + if FT in [typeRECORD, typeARRAY] then + begin + if RJ.IsConst then + if RJ.Size > 4 then + RJ.ByRefEx := true; + end; + + case FT of +{$IFNDEF PAXARM} + typeSHORTSTRING: RJ.ByRefEx := true; +{$ENDIF} + typeVARIANT, typeOLEVARIANT: RJ.ByRefEx := true; + end; + + if RJ.ByRef or RJ.ByRefEx then + Inc(SP, SizeOfPointer) + else + begin + TypeId := RJ.TypeId; + if not Records[TypeId].Completed then + ProcessType(TypeId); + + SZ := RJ.Size; + + while SZ mod 4 <> 0 do + Inc(SZ); + + Inc(SP, SZ); + end; + end + else if RJ.Local then + begin + TypeId := RJ.TypeId; + if not Records[TypeId].Completed then + ProcessType(TypeId); + + if RJ.FinalTypeId = typeSET then + Dec(SL, SizeOf(TByteSet)) + else + Dec(SL, MPtr(RJ.Size)); + RJ.Shift := SL; + end + else if RJ.InternalField then + begin + OwnerId := RJ.OwnerId; + TypeId := Records[OwnerId].FinalTypeId; + case TypeId of + typeRECORD: + begin + PatternId := RJ.PatternId; + RJ.Shift := Records[OwnerId].Shift + Records[PatternId].Shift; + end; + typeARRAY: + begin + ArrayTypeId := Records[OwnerId].TerminalTypeId; + GetArrayTypeInfo(ArrayTypeId, RangeTypeId, ElemTypeId); + H1 := GetLowBoundRec(RangeTypeId).Value; + RJ.Shift := Records[OwnerId].Shift + + Records[ElemTypeId].Size * (RJ.Value - H1); + end; + else + RaiseError(errInternalError, []); + end; + end + else if RJ.Kind = KindTYPE then + ProcessType(J); + end; // for + + if ExtraParamNeeded then + begin + J := GetResultId(I); + + TypeId := Records[J].TypeId; + if not Records[TypeId].Completed then + ProcessType(TypeId); + + Records[J].Shift := 8 + 3 * 4; + Records[J].ByRef := true; + end; // J-loop + + if RI.CallConv = ccSAFECALL then + begin + J := GetResultId(I); + + RJ := Records[J]; + + TypeId := RJ.TypeId; + if not Records[TypeId].Completed then + ProcessType(TypeId); + + RJ.Shift := GetSizeOfParams(I) + 4; + RJ.ByRef := true; + end; + + end // of ccSTDCALL, ccCDECL ccSAFECALL + else if RI.CallConv = ccPASCAL then + begin + if IsMethod then + Inc(SP, 4); + + for J:=Card downto I + 1 do + begin + if ExtraParamNeeded then + begin + if J = GetResultId(I) then + continue; + end; + + if IsMethod then + begin + if J = GetSelfId(I) then + continue; + end; + + RJ := Records[J]; + + if RJ.Level <> I then + continue; + + if RJ.UnionId <> 0 then + begin + RJ.Shift := Records[RJ.UnionId].Shift; + if RI.UnionId > I then + LL.Add(I); + continue; + end; + + if RJ.Param then + begin + RJ.Shift := SP; + + FT := RJ.FinalTypeId; + if FT in [typeRECORD, typeARRAY] then + begin + if RJ.IsConst then + if RJ.Size > 4 then + RJ.ByRefEx := true; + end; + + if FT in [ +{$IFNDEF PAXARM} + typeSHORTSTRING, +{$ENDIF} + typeVARIANT, typeOLEVARIANT] then + RJ.ByRefEx := true; + + if RJ.ByRef or RJ.ByRefEx then + Inc(SP, SizeOfPointer) + else + begin + + TypeId := RJ.TypeId; + + if not Records[TypeId].Completed then + ProcessType(TypeId); + + SZ := RJ.Size; + + if RJ.FinalTypeId in [typeDYNARRAY, typeOPENARRAY] then + if RJ.IsOpenArray then + Inc(SP, 4); + + while SZ mod 4 <> 0 do + Inc(SZ); + + Inc(SP, SZ); + end; + end + else if RJ.Local then + begin + TypeId := RJ.TypeId; + if not Records[TypeId].Completed then + ProcessType(TypeId); + + if RJ.FinalTypeId = typeSET then + Dec(SL, SizeOf(TByteSet)) + else + Dec(SL, MPtr(RJ.Size)); + RJ.Shift := SL; + end + else if RJ.InternalField then + begin + continue; + end + else if RJ.Kind = KindTYPE then + ProcessType(J); + end; // for loop - J + + for J:=Card downto I + 1 do + begin + RJ := Records[J]; + if RJ.InternalField then + begin + OwnerId := RJ.OwnerId; + TypeId := Records[OwnerId].FinalTypeId; + case TypeId of + typeRECORD: + begin + PatternId := RJ.PatternId; + RJ.Shift := Records[OwnerId].Shift + Records[PatternId].Shift; + end; + typeARRAY: + begin + ArrayTypeId := Records[OwnerId].TerminalTypeId; + GetArrayTypeInfo(ArrayTypeId, RangeTypeId, ElemTypeId); + H1 := GetLowBoundRec(RangeTypeId).Value; + RJ.Shift := Records[OwnerId].Shift + + Records[ElemTypeId].Size * (RJ.Value - H1); + end; + else + RaiseError(errInternalError, []); + end; + end + end; + + if IsMethod then + begin + J := GetSelfId(I); + Records[J].Shift := 8; + end; + + if ExtraParamNeeded then + begin + J := GetResultId(I); + + RJ := Records[J]; + + TypeId := RJ.TypeId; + if not Records[TypeId].Completed then + ProcessType(TypeId); + + if IsMethod then + RJ.Shift := 12 + else + RJ.Shift := 8; + + RJ.ByRef := true; + end; + + end // ccPASCAL + else if RI.CallConv = ccREGISTER then + begin + RegCount := 0; + + if RI.IsMethod or RI.IsSubPartOfEventType or + RI.IsConstructor or RI.IsDestructor then + if RI.CallMode <> cmSTATIC then + begin + J := GetSelfId(I); + Records[J].Register := _EAX; + Inc(RegCount); + + if RI.IsConstructor then //!! + begin + if Records[RI.Level].FinalTypeId <> typeRECORD then + Inc(RegCount); + end; + + Dec(SL, 4); + Records[J].Shift := SL; + end; + + for NP := 0 to RI.Count - 1 do + begin + J := GetParamId(I, NP); + + RJ := Records[J]; + + FT := RJ.FinalTypeId; + + if FT in [typeRECORD, typeARRAY] then + if RJ.Size > 4 then + RJ.ByRefEx := true; + + if RJ.ByRef or RJ.ByRefEx + or + ( + (RJ.Size <= 4) and (FT <> typeSINGLE) + ) + or + (FT in [ +{$IFNDEF PAXARM} + typeSHORTSTRING, +{$ENDIF} + typeVARIANT, typeOLEVARIANT]) + then + begin + + if FT in [ +{$IFNDEF PAXARM} + typeSHORTSTRING, +{$ENDIF} + typeVARIANT, typeOLEVARIANT] then + RJ.ByRefEx := true; + + Inc(RegCount); + + case RegCount of + 1: RJ.Register := _EAX; + 2: RJ.Register := _EDX; + 3: RJ.Register := _ECX; + end; + + if RegCount <= 3 then + begin + Dec(SL, 4); + RJ.Shift := SL; + end; + + if FT in [typeDYNARRAY, typeOPENARRAY] then + if RJ.IsOpenArray then + begin + Inc(RegCount); + end; + + end; + end; // set register params + + K := I + 1; + + if ExtraParamNeeded then + begin + Inc(K); + + J := GetResultId(I); + + RJ := Records[J]; + + TypeId := RJ.TypeId; + if not Records[TypeId].Completed then + ProcessType(TypeId); + + if RegCount >= 3 then + begin + RJ.Shift := SP; + RJ.ByRef := true; + Inc(SP, 4); + end + else + begin + Inc(RegCount); + case RegCount of + 1: RJ.Register := _EAX; + 2: RJ.Register := _EDX; + 3: RJ.Register := _ECX; + end; + Dec(SL, 4); + RJ.Shift := SL; + end; + + RJ.ByRef := true; + end; + + for J:=Card downto K do + begin + RJ := Records[J]; + + if RJ.Level <> I then + continue; + + if RJ.Register > 0 then + continue; + + if RJ.UnionId <> 0 then + begin + RJ.Shift := Records[RJ.UnionId].Shift; + if RI.UnionId > I then + LL.Add(I); + continue; + end; + + if RJ.Param then + begin + if RJ.FinalTypeId in [typeDYNARRAY, typeOPENARRAY] then + if RJ.IsOpenArray then + Inc(SP, 4); + + RJ.Shift := SP; + + if RJ.FinalTypeId in + [ +{$IFNDEF PAXARM} + typeSHORTSTRING, +{$ENDIF} + typeVARIANT, typeOLEVARIANT] then + RJ.ByRefEx := true; + + if RJ.ByRef or RJ.ByRefEx then + Inc(SP, SizeOfPointer) + else + begin + TypeId := RJ.TypeId; + if not Records[TypeId].Completed then + ProcessType(TypeId); + + SZ := RJ.Size; + + while SZ mod 4 <> 0 do + Inc(SZ); + + Inc(SP, SZ); + end; + end + else if RJ.Local then + begin + TypeId := RJ.TypeId; + if not Records[TypeId].Completed then + ProcessType(TypeId); + + if RJ.FinalTypeId = typeSET then + Dec(SL, SizeOf(TByteSet)) + else + Dec(SL, MPtr(RJ.Size)); + RJ.Shift := SL; + end + else if RJ.InternalField then + begin + continue; // later + end + else if RJ.Kind = KindTYPE then + ProcessType(J); + end; // for + + + for J:=Card downto K do + begin + RJ := Records[J]; + + if RJ.Level <> I then + continue; + + if RJ.Register > 0 then + continue; + + if RJ.InternalField then + begin + OwnerId := RJ.OwnerId; + TypeId := Records[OwnerId].FinalTypeId; + case TypeId of + typeRECORD: + begin + PatternId := RJ.PatternId; + RJ.Shift := Records[OwnerId].Shift + Records[PatternId].Shift; + end; + typeARRAY: + begin + ArrayTypeId := Records[OwnerId].TerminalTypeId; + GetArrayTypeInfo(ArrayTypeId, RangeTypeId, ElemTypeId); + H1 := GetLowBoundRec(RangeTypeId).Value; + Records[J].Shift := Records[OwnerId].Shift + + Records[ElemTypeId].Size * (RJ.Value - H1); + end; + else + begin + RJ.Kind := kindNONE; + RJ.Name := ''; + RJ.OwnerId := 0; + continue; + + // RaiseError(errInternalError, []); + end; + end; + end; + end; // for + + end // ccREGISTER + + else if RI.CallConv = cc64 then + begin + RegCount := 0; + RSPOffset := $20; + + SL := $100; + + if RI.IsMethod or + RI.IsSubPartOfEventType or + RI.IsJSFunction or + RI.IsConstructor or RI.IsDestructor then + if RI.CallMode <> cmSTATIC then + begin + Inc(RegCount); + + J := GetSelfId(I); + RJ := Records[J]; + case RegCount of + 1: RJ.Register := _ECX; + 2: RJ.Register := _EDX; + else + RaiseError(errInternalError, []); + end; + + if RI.IsConstructor then //!! + begin + if Records[RI.Level].FinalTypeId <> typeRECORD then + begin + J := GetDL_Id(I); + Records[J].Shift := SL; + Inc(SL, 8); + + Inc(RegCount); + end; + end; + end; + + if ExtraParamNeeded then + begin + J := GetResultId(I); + RJ := Records[J]; + + TypeId := RJ.TypeId; + if not Records[TypeId].Completed then + ProcessType(TypeId); + + Inc(RegCount); + case RegCount of + 1: RJ.Register := _ECX; + 2: RJ.Register := _EDX; + else + RaiseError(errInternalError, []); + end; + + RJ.ByRef := true; + end; + + if RI.IsNestedSub and (not RI.IsJSFunction) then + begin + J := GetRBP_Id(I); + Records[J].Shift := SL; + Inc(SL, 8); + Inc(RegCount); + end; + + // set params + + for NP := 0 to RI.Count - 1 do + begin + J := GetParamId(I, NP); + + RJ := Records[J]; + if not Records[RJ.TypeId].Completed then + ProcessType(RJ.TypeId); + + FT := RJ.FinalTypeId; + + if FT in [typeRECORD, typeARRAY] then + if RJ.Size > 4 then + RJ.ByRefEx := true; + + if (FT in RealTypes) and (not (RJ.ByRef or RJ.ByRefEx)) then + begin + Inc(RegCount); + case RegCount of + 1: RJ.XMMReg := _XMM0; + 2: RJ.XMMReg := _XMM1; + 3: RJ.XMMReg := _XMM2; + 4: RJ.XMMReg := _XMM3; + else + begin + RJ.RSPOffset := RSPOffset; + Inc(RSPOffset, 8); + end; + end; + end + else if RJ.ByRef or RJ.ByRefEx + or + ( + (RJ.Size <= SizeOfPointer) and (not (FT in RealTypes)) + ) + or + (FT in [ +{$IFNDEF PAXARM} + typeSHORTSTRING, +{$ENDIF} + typeVARIANT, typeOLEVARIANT, typeEVENT, typeSET]) + then + begin + if FT in [ +{$IFNDEF PAXARM} + typeSHORTSTRING, +{$ENDIF} + typeVARIANT, typeOLEVARIANT] then + RJ.ByRefEx := true; + + Inc(RegCount); + + case RegCount of + 1: RJ.Register := _ECX; + 2: RJ.Register := _EDX; + 3: RJ.Register := _R8; + 4: RJ.Register := _R9; + else + begin + RJ.RSPOffset := RSPOffset; + Inc(RSPOffset, 8); + end; + end; + + if FT in [typeDYNARRAY, typeOPENARRAY] then + if RJ.IsOpenArray then + begin + Inc(RegCount); + end; + end + else + begin + RJ.RSPOffset := RSPOffset; + Inc(RSPOffset, 8); + end; + end; // set register params + + K := I + 1; + + for J:=Card downto K do + begin + RJ := Records[J]; + + if RJ.Level <> I then + continue; + if RJ.Param then + continue; + + if RJ.Local then + begin + TypeId := RJ.TypeId; + if not Records[TypeId].Completed then + ProcessType(TypeId); + end; + end; + + SubRSPSize := GetSubRSPSize(I); + SP := SubRSPSize + $10 + 24; + + J := GetResultId(I); + RJ := Records[J]; + case RJ.Register of + _ECX: RJ.Shift := SP; + _EDX: RJ.Shift := SP + 8; + else + begin + RJ.Shift := SL; + Inc(SL, 8); + end; + end; + + J := GetSelfId(I); + RJ := Records[J]; + case RJ.Register of + _ECX: RJ.Shift := SP; + _EDX: RJ.Shift := SP + 8; + end; + + K := J + 1; + + for NP := 0 to RI.Count - 1 do + begin + J := GetParamId(I, NP); + RJ := Records[J]; + if RJ.Register = _ECX then + RJ.Shift := SP + else if RJ.Register = _EDX then + RJ.Shift := SP + 8 + else if RJ.Register = _R8 then + RJ.Shift := SP + 16 + else if RJ.Register = _R9 then + RJ.Shift := SP + 24 + else if RJ.XMMReg = _XMM0 then + RJ.Shift := SP + else if RJ.XMMReg = _XMM1 then + RJ.Shift := SP + 8 + else if RJ.XMMReg = _XMM2 then + RJ.Shift := SP + 16 + else if RJ.XMMReg = _XMM3 then + RJ.Shift := SP + 24 + else + RJ.Shift := SP + RJ.RSPOffset; + end; + + for J:=K to Card do + begin + RJ := Records[J]; + + if RJ.Level <> I then + continue; + if RJ.Param then + continue; + + if RJ.UnionId <> 0 then + begin + RJ.Shift := Records[RJ.UnionId].Shift; + if RI.UnionId > I then + LL.Add(I); + continue; + end; + + if RJ.Local then + begin + RJ.Shift := SL; + Inc(SL, MPtr(RJ.Size)); + end + else if RJ.InternalField then + begin + OwnerId := RJ.OwnerId; + TypeId := Records[OwnerId].FinalTypeId; + case TypeId of + typeRECORD: + begin + PatternId := RJ.PatternId; + RJ.Shift := Records[OwnerId].Shift + Records[PatternId].Shift; + end; + typeARRAY: + begin + ArrayTypeId := Records[OwnerId].TerminalTypeId; + GetArrayTypeInfo(ArrayTypeId, RangeTypeId, ElemTypeId); + H1 := GetLowBoundRec(RangeTypeId).Value; + Records[J].Shift := Records[OwnerId].Shift + + Records[ElemTypeId].Size * (RJ.Value - H1); + end; + else + begin + RJ.Kind := kindNONE; + RJ.Name := ''; + RJ.OwnerId := 0; + continue; + end; + end; + end + else if RJ.Kind = KindTYPE then + ProcessType(J); + end; // for + end // cc64 + + else if RI.CallConv = ccMSFASTCALL then + begin + RegCount := 1; + + { + if Records[I].IsMethod or Records[I].IsConstructor or Records[I].IsDestructor then + begin + J := GetSelfId(I); + Records[J].Register := _EAX; + Inc(RegCount); + + Dec(SL, 4); + Records[J].Shift := SL; + end; + } + + for NP := 0 to RI.Count - 1 do + begin + J := GetParamId(I, NP); + + RJ := Records[J]; + + FT := RJ.FinalTypeId; + if FT in [typeRECORD, typeARRAY] then + begin + if RJ.IsConst then + if RJ.Size > 4 then + RJ.ByRefEx := true; + end; + + if RJ.ByRef or RJ.ByRefEx + or + ( + (RJ.Size <= 4) and (FT <> typeSINGLE) + ) + or + (FT in [ +{$IFNDEF PAXARM} + typeSHORTSTRING, +{$ENDIF} + typeVARIANT, typeOLEVARIANT]) + then + begin + + if FT in [ +{$IFNDEF PAXARM} + typeSHORTSTRING, +{$ENDIF} + typeVARIANT, typeOLEVARIANT] then + RJ.ByRefEx := true; + + Inc(RegCount); + + case RegCount of + 2: RJ.Register := _ECX; + 3: RJ.Register := _EDX; + end; + + Dec(SL, 4); + RJ.Shift := SL; + + end; + end; // set register params + + K := I + 1; + + if ExtraParamNeeded then + begin + Inc(K); + + J := GetResultId(I); + + RJ := Records[J]; + + TypeId := RJ.TypeId; + if not Records[TypeId].Completed then + ProcessType(TypeId); + + if RegCount >= 3 then + begin + RJ.Shift := 8; + RJ.ByRef := true; + end + else + begin + Inc(RegCount); + case RegCount of + 2: RJ.Register := _ECX; + 3: RJ.Register := _EDX; + end; + Dec(SL, 4); + RJ.Shift := SL; + end; + + RJ.ByRef := true; + end + else + begin + J := GetResultId(I); + Records[J].ByRef := false; + end; + + for J:=Card downto K do + begin + RJ := Records[J]; + + if RJ.Level <> I then + continue; + + if RJ.Register > 0 then + continue; + + if RJ.UnionId <> 0 then + begin + RJ.Shift := Records[RJ.UnionId].Shift; + if RI.UnionId > I then + LL.Add(I); + continue; + end; + + if RJ.Param then + begin + if RJ.FinalTypeId in [typeDYNARRAY, typeOPENARRAY] then + if RJ.IsOpenArray then + Inc(SP, 4); + + RJ.Shift := SP; + + if RJ.FinalTypeId in + [ +{$IFNDEF PAXARM} + typeSHORTSTRING, +{$ENDIF} + typeVARIANT, typeOLEVARIANT] then + RJ.ByRefEx := true; + + if RJ.ByRef or RJ.ByRefEx then + Inc(SP, SizeOfPointer) + else + begin + TypeId := RJ.TypeId; + if not Records[TypeId].Completed then + ProcessType(TypeId); + + SZ := RJ.Size; + + while SZ mod 4 <> 0 do + Inc(SZ); + + Inc(SP, SZ); + end; + end + else if RJ.Local then + begin + TypeId := RJ.TypeId; + if not Records[TypeId].Completed then + ProcessType(TypeId); + + if RJ.FinalTypeId = typeSET then + Dec(SL, SizeOf(TByteSet)) + else + Dec(SL, MPtr(RJ.Size)); + RJ.Shift := SL; + end + else if RJ.InternalField then + begin + continue; + end + else if Records[J].Kind = KindTYPE then + ProcessType(J); + end; // for + + for J:=Card downto K do + begin + RJ := Records[J]; + + if RJ.Level <> I then + continue; + + if RJ.Register > 0 then + continue; + + if RJ.InternalField then + begin + OwnerId := RJ.OwnerId; + TypeId := Records[OwnerId].FinalTypeId; + case TypeId of + typeRECORD: + begin + PatternId := Records[J].PatternId; + RJ.Shift := Records[OwnerId].Shift + Records[PatternId].Shift; + end; + typeARRAY: + begin + ArrayTypeId := Records[OwnerId].TerminalTypeId; + GetArrayTypeInfo(ArrayTypeId, RangeTypeId, ElemTypeId); + H1 := GetLowBoundRec(RangeTypeId).Value; + Records[J].Shift := Records[OwnerId].Shift + + Records[ElemTypeId].Size * (RJ.Value - H1); + end; + else + RaiseError(errInternalError, []); + end; + end; + end; // for + + end // ccMS_FASTCALL + else + RaiseError(errInternalError, []); + + end; // KindSUB, KindCONSTRUCTOR, KindDESTRUCTOR (Script) + kindTYPE: + ProcessType(I); + end; + end; // loop - I + end; // loop KK + + for J := 0 to LL.Count - 1 do + begin + I := LL[J]; + RI := Records[I]; + RI.Shift := Records[RI.UnionId].Shift; + end; + + FreeAndNil(LL); +end; + +procedure TSymbolTable.RaiseError(const Message: string; params: array of Const); +begin + TKernel(kernel).RaiseError(Message, params); +end; + +procedure TSymbolTable.CreateOffsets(JS1, JS2: Integer); +var + KK, K1, K2, I, S, SZ, OwnerId, OwnerOffset, D, L: Integer; + RI: TSymbolRec; + OffsetList: TOffsetList; + SignClassHeader: Boolean; + Id_GetOLEProperty, Id_SetOLEProperty: Integer; + HostMapTable: TMapTable; + Id: Integer; + ClassLst, SubLst: TIntegerList; + InCodeClass: Boolean; + MapRec: TMapRec; +begin + HostMapTable := TKernel(kernel).prog.HostMapTable; + ClassLst := TIntegerList.Create; + SubLst := TIntegerList.Create; + + for I := 0 to HostMapTable.Count - 1 do + case HostMapTable[I].Kind of + KindTYPE: + begin + Id := LookupFullName(HostMapTable[I].FullName, true); + if Id > 0 then + if Records[Id].FinalTypeId = typeCLASS then + ClassLst.Add(Id); + end; + KindSUB, KindCONSTRUCTOR, KindDESTRUCTOR: + begin + MapRec := HostMapTable[I]; + Id := MapRec.SubDesc.SId; + if Id > 0 then + SubLst.Add(Id); + end; + end; + + try + + Id_GetOLEProperty := Lookup(_strGetOLEProperty, 0, false); + Id_SetOLEProperty := Lookup(_strSetOLEProperty, 0, false); + + OffsetList := TKernel(kernel).OffsetList; + + SignClassHeader := false; + InCodeClass := false; + + S := StdSize; + + OffsetList.Clear; + OffsetList.InitSize := S; + + for I:= JS1 to JS2 do + if (I > 0) and (I < System.Length(InCode)) then + InCode[I] := true; + + I := Id_GetOLEProperty; + if (I > 0) and (I < System.Length(InCode)) then + InCode[I] := true; + SubLst.Add(I); + + I := Id_SetOLEProperty; + if (I > 0) and (I < System.Length(InCode)) then + InCode[I] := true; + SubLst.Add(I); + + for KK := 1 to 2 do + begin + if KK = 1 then + begin + K1 := StdCard; + K2 := GlobalST.Card; + end + else + begin + K1 := FirstLocalId + 1; + K2 := Card; + end; + + I := K1 - 1; + repeat + Inc(I); + if I > K2 then + break; + + RI := Records[I]; + + if RI.Host then + begin + if RI.Kind = KindTYPE then + if RI.FinalTypeId = typeCLASS then + begin + SignClassHeader := true; + InCodeClass := ClassLst.IndexOf(I) >= 0; + + if InCodeClass then + InCode[I] := true; + end; + + if RI.Kind = kindTYPE then + if RI.TypeID = typeINTERFACE then + if InCode[I] then + begin + InCode[I + 1] := true; + InCode[I + 2] := true; + end; + end; + + if SignClassHeader and InCodeClass then + InCode[I] := true; + + if RI.Kind = kindEND_CLASS_HEADER then + begin + SignClassHeader := false; + InCodeClass := false; + continue; + end; + + if I > CompileCard then + begin + InCode[I] := true; + if SignClassHeader and (not InCodeClass) then + InCode[I] := false; + end; + + if InCode[I] then + if (RI.Shift > 0) and + (RI.Kind in (KindSUBS + [KindVAR, KindCONST])) then + begin + if RI.Param or RI.Local or RI.LocalInternalField then + continue; + + if RI.UnionId > 0 then + continue; + + SZ := 0; + + if RI.Host then + begin + L := RI.Level; + if RI.Kind in KindSUBS then + if not (RI.IsSubPartOfEventType or RI.IsSubPartOfProcType) then + if (L = 0) or (Records[L].FinalTypeId <> typeINTERFACE) then + begin + if SubLst.IndexOf(I) = -1 then + begin + InCode[I] := false; + InCode[I+1] := false; + InCode[I+2] := false; + Inc(I, 2); + continue; + end; + end; + SZ := SizeOfPointer; + end +{$IFNDEF PAXARM} + else if RI.HasPAnsiCharType then + begin + SZ := 0; + Inc(SZ, SizeOfPointer); // pointer to string literal + Inc(SZ, SizeOfPointer); // ref counter + Inc(SZ, SizeOfPointer); // length + // reserve place for literal + Inc(SZ, Length(RI.Value) + 1); + end +{$ENDIF} + else if RI.HasPWideCharType then + begin + SZ := 0; + Inc(SZ, SizeOfPointer); // pointer to string literal + Inc(SZ, SizeOfPointer); // length + // reserve place for literal + Inc(SZ, Length(RI.Value) * 2 + 2); + end + else + SZ := RI.Size; + + if RI.InternalField then + begin + SZ := 0; + OwnerId := RI.OwnerId; + D := RI.Shift - Records[OwnerId].Shift; + OwnerOffset := TKernel(kernel).GetOffset(Records[OwnerId]); + OffsetList.Add(I, RI.Shift, OwnerOffset + D, SZ); + continue; + end; + + SZ := MPtr(SZ); + + OffsetList.Add(I, RI.Shift, S, SZ); + Inc(S, SZ); + end; + until false; + end; + + finally + FreeAndNil(ClassLst); + FreeAndNil(SubLst); + end; +end; + +function TSymbolTable.GetValueAsString(P: Pointer; + StackFrameNumber: Integer; + Id: Integer; + TypeMapRec: TTypeMapRec = nil; + BriefCls: Boolean = false): String; +var + Address: Pointer; + TypeId: Integer; + Code: TCode; + N: Integer; +begin + result := '???'; + + if not Records[Id].Host then + if Records[Id].Param then + if Records[Id].ByRef then + begin + Code := TKernel(kernel).Code; + N := TBaseRunner(P).CurrN; + if Code.ParamHasBeenChanged(N, Id) then + Exit; + end; + + Address := GetFinalAddress(P, StackFrameNumber, Id); + TypeId := Self[Id].TerminalTypeId; + + if Address = nil then + Exit; + + result := GetStrVal(Address, TypeId, TypeMapRec, BriefCls); +end; + +function TSymbolTable.GetSizeOfParams(SubId: Integer): Integer; +var + I, J, SZ, RegCount: Integer; + R: TSymbolRec; + FinTypeId: Integer; + MaxRegCount: Integer; +begin + if Records[SubId].CallConv = cc64 then + MaxRegCount := 4 + else + MaxRegCount := 3; + + result := 0; + RegCount := 0; + + if Records[SubId].IsMethod then + begin + if Records[SubId].CallConv in [ccREGISTER, ccMSFASTCALL, cc64] then + Inc(RegCount) + else + Inc(result, 4); + end; + + for J:=0 to Records[SubId].Count - 1 do + begin + I := GetParamId(SubId, J); + R := Records[I]; + + if Records[SubId].CallConv in [ccREGISTER, ccMSFASTCALL, cc64] then + begin + if R.Register > 0 then + begin + Inc(RegCount); + + if R.FinalTypeId in [typeDYNARRAY, typeOPENARRAY] then + if R.IsOpenArray then + begin + Inc(RegCount); + + if RegCount > MaxRegCount then + Inc(result, 4); + end; + + continue; + end; + end; + + if R.ByRef or R.ByRefEx then + Inc(result, SizeOfPointer) + else + begin + SZ := R.Size; + + FinTypeId := R.FinalTypeId; + + if FinTypeId = typeEXTENDED then + if TKernel(kernel).TargetPlatform in [tpOSX32, tpIOSSim] then + SZ := 16; + + if FinTypeId in [typeDYNARRAY, typeOPENARRAY] then + if R.IsOpenArray then + Inc(SZ, 4); + + while SZ mod 4 <> 0 do + Inc(SZ); + + Inc(result, SZ); + end; + end; + + result := Abs(result); + + if Records[SubId].ExtraParamNeeded then + begin + if Records[SubId].CallConv in [ccREGISTER, cc64] then + begin + if RegCount >= MaxRegCount then + Inc(result, 4); + end + else + Inc(result, 4); + end; + + if Records[SubId].CallConv = ccSAFECALL then + Inc(result, 4); +end; + + +end. + diff --git a/Sources/PAXCOMP_SYS.pas b/Sources/PAXCOMP_SYS.pas new file mode 100644 index 0000000..5373d0e --- /dev/null +++ b/Sources/PAXCOMP_SYS.pas @@ -0,0 +1,6117 @@ +//////////////////////////////////////////////////////////////////////////// +// PaxCompiler +// Site: http://www.paxcompiler.com +// Author: Alexander Baranovsky (paxscript@gmail.com) +// ======================================================================== +// Copyright (c) Alexander Baranovsky, 2006-2014. All rights reserved. +// Code Version: 4.2 +// ======================================================================== +// Unit: PAXCOMP_SYS.pas +// ======================================================================== +//////////////////////////////////////////////////////////////////////////// + +{$I PaxCompiler.def} + +{$O-} +{$Q-} +{$R-} + +unit PAXCOMP_SYS; +interface +uses {$I uses.def} + TypInfo, + SysUtils, + Classes, + PaxInfos, + PAXCOMP_TYPES, + PAXCOMP_CONSTANTS; + +{$IFDEF VARIANTS} +type + UInt64 = Int64; + PBoolean = ^Boolean; +{$ELSE} +type + UInt64 = Int64; + IInterface = IUnknown; + PBoolean = ^Boolean; + PInteger = ^Integer; + PWord = ^Word; +{$ENDIF} + PIUnknown = ^IUnknown; + +{$IFNDEF VARIANTS} +const + varShortInt = $0010; + varWord = $0012; + varLongWord = $0013; +{$ENDIF} + +{$IFDEF UNIX} +const + MEM_COMMIT = 0; + PAGE_EXECUTE_READWRITE = 0; +{$ENDIF} + +const + FirstCompiledScriptVersion = 102; +var + FirstLocalId: Integer = 1000000; + + StreamVersion: Integer = 137; + CompiledScriptVersion: Integer = 128; + + StdCard: Integer = 0; + StdSize: Integer = 0; +const + MaxPublishedProps = 50; // importer only + varUString = $0102; { Unicode string 258 } {not OLE compatible} + + MinDouble = 4.9406564584124654418e-324; + MaxDouble = 1.7976931348623157081e+308; + +{$IFDEF VARIANTS} + IntegerVariantTypes = [varByte, varSmallInt, varInteger, varWord, varLongWord, varInt64]; +{$ELSE} + IntegerVariantTypes = [varByte, varSmallInt, varInteger]; +{$ENDIF} + + NaN = 0.0 / 0.0; + {$EXTERNALSYM NaN} + {$HPPEMIT 'static const Extended NaN = 0.0 / 0.0 ; // UW 2013-08-13 emit} + Infinity = 1.0 / 0.0; + {$EXTERNALSYM Infinity} + {$HPPEMIT 'static const Extended Infinity = 1.0 / 0.0; // UW 2013-08-13 emit} + NegInfinity = -1.0 / 0.0; + {$EXTERNALSYM NegInfinity} + {$HPPEMIT 'static const Extended NegInfinity = -1.0 / 0.0; // UW 2013-08-13 emit} + + SecsPerHour = 60 * 60; + SecsPerDay = SecsPerHour * 24; + MSecsPerDay = SecsPerDay * 1000; + MSecsPerHour = SecsPerHour * 1000; + +{$IFDEF MACOS32} + varClass = varError; + varPointer = $15; +{$ELSE} + {$IFDEF LINUX} + varClass = varError; + varPointer = $15; + {$ELSE} + {$IFDEF PAXARM_DEVICE} + varClass = varError; + varPointer = varAny; + {$ELSE} + varClass = $0E; + varPointer = varAny; + {$ENDIF} + {$ENDIF} +{$ENDIF} + + H_SelfPtr: Integer = 32; + + H_ExceptionPtr_64 = 40; + H_ByteCodePtr_64 = 48; + H_Flag_64 = 56; + H_SkipPop_64 = 64; + FirstShiftValue_64 = 141; + + H_ExceptionPtr_32 = 36; + H_ByteCodePtr_32 = 40; + H_Flag_32 = 44; + H_SkipPop_32 = 48; + FirstShiftValue_32 = 105; +type + TPortDir = (portNone, portPlatform, portDeprecated, portLibrary); + + TRecord4 = record + x: longInt; + end; + + TRecord8 = record + x1, x2: longInt; + end; + + TRecord12 = record + x1, x2, x3: longInt; + end; + + TArray4 = array[0..0] of longInt; + TArray8 = array[0..1] of longInt; + TArray12 = array[0..2] of longInt; + + TRange1 = 0..31; + TSet1 = set of TRange1; + TRange2 = 0..63; + TSet2 = set of TRange2; + TRange4 = 0..127; + TSet4 = set of TRange4; + TRange8 = 0..255; + TSet8 = set of TRange8; + +{$IFNDEF PAXARM} + DynarrayChar = array of AnsiChar; + DynarrayString = array of AnsiString; + DynarrayWideString = array of WideString; +{$ENDIF} + + DynarrayInteger = array of Integer; + DynarrayWord = array of Word; + DynarrayCardinal = array of Cardinal; + DynarrayBoolean = array of Boolean; + DynarrayByte = array of Byte; + DynarrayWideChar = array of WideChar; + DynarrayShortString = array of ShortString; + DynarrayUnicString = array of UnicString; + DynarrayDouble = array of Double; + DynarraySingle = array of Single; + DynarrayExtended = array of Extended; + DynarrayCurrency = array of Currency; + DynarrayVariant = array of Variant; + DynarrayTVarRec = array of TVarRec; + +{$IFNDEF PAXARM} + DynarrayChar2 = array of array of AnsiChar; + DynarrayString2 = array of array of AnsiString; + DynarrayWideString2 = array of array of WideString; +{$ENDIF} + + DynarrayInteger2 = array of array of Integer; + DynarrayWord2 = array of array of Word; + DynarrayCardinal2 = array of array of Cardinal; + DynarrayBoolean2 = array of array of Boolean; + DynarrayByte2 = array of array of Byte; + DynarrayWideChar2 = array of array of WideChar; + DynarrayShortString2 = array of array of ShortString; + DynarrayUnicString2 = array of array of UnicString; + DynarrayPointer2 = array of array of Pointer; + DynarrayDouble2 = array of array of Double; + DynarraySingle2 = array of array of Single; + DynarrayExtended2 = array of array of Extended; + DynarrayCurrency2 = array of array of Currency; + DynarrayVariant2 = array of array of Variant; + DynarrayTVarRec2 = array of array of TVarRec; + +{$IFNDEF PAXARM} + DynarrayChar3 = array of array of array of AnsiChar; + DynarrayString3 = array of array of array of AnsiString; + DynarrayWideString3 = array of array of array of WideString; +{$ENDIF} + + DynarrayInteger3 = array of array of array of Integer; + DynarrayWord3 = array of array of array of Word; + DynarrayCardinal3 = array of array of array of Cardinal; + DynarrayBoolean3 = array of array of array of Boolean; + DynarrayByte3 = array of array of array of Byte; + DynarrayWideChar3 = array of array of array of WideChar; + DynarrayShortString3 = array of array of array of ShortString; + DynarrayUnicString3 = array of array of array of UnicString; + DynarrayPointer3 = array of array of array of Pointer; + DynarrayDouble3 = array of array of array of Double; + DynarraySingle3 = array of array of array of Single; + DynarrayExtended3 = array of array of array of Extended; + DynarrayCurrency3 = array of array of array of Currency; + DynarrayVariant3 = array of array of array of Variant; + DynarrayTVarRec3 = array of array of array of TVarRec; + + PObject = ^TObject; + + TJS_Record = record + H_JS_Object: Integer; + H_JS_Boolean: Integer; + H_JS_String: Integer; + H_JS_Number: Integer; + H_JS_Date: Integer; + H_JS_Function: Integer; + H_JS_Array: Integer; + H_JS_RegExp: Integer; + H_JS_Math: Integer; + H_JS_Error: Integer; + + Id_JS_Object: Integer; + Id_JS_Boolean: Integer; + Id_JS_String: Integer; + Id_JS_Number: Integer; + Id_JS_Date: Integer; + Id_JS_Function: Integer; + Id_JS_Array: Integer; + Id_JS_RegExp: Integer; + Id_JS_Math: Integer; + Id_JS_Error: Integer; + end; +var + H_ExceptionPtr: Integer = H_ExceptionPtr_32; + H_ByteCodePtr: Integer = H_ByteCodePtr_32; + H_Flag: Integer = H_Flag_32; + H_SkipPop: Integer = H_SkipPop_32; +{$IFDEF PAXARM} + FirstShiftValue: Integer = 102; +{$ELSE} + FirstShiftValue: Integer = FirstShiftValue_32; +{$ENDIF} + +const + H_InitOnly = 4; + H_BodyOnly = 8; + + kindNONE = 0; + kindVAR = 1; + kindCONST = 2; + kindSUB = 3; + kindPARAM = 4; + kindTYPE = 5; + kindTYPE_FIELD = 6; + kindLABEL = 7; + kindNAMESPACE = 8; + kindCONSTRUCTOR = 9; + kindDESTRUCTOR = 10; + kindPROP = 11; + kindEND_CLASS_HEADER = 12; + + KindSubs = [KindSUB, KindCONSTRUCTOR, KindDESTRUCTOR]; + + UnsignedIntegerTypes = [typeBYTE, typeWORD, typeCARDINAL]; + + IntegerTypes = [typeBYTE, typeWORD, typeINTEGER, typeINT64, typeUINT64, + typeCARDINAL, typeSMALLINT, typeSHORTINT]; + Int64Types = [typeINT64, typeUINT64]; + VariantTypes = [typeVARIANT, typeOLEVARIANT]; +{$IFDEF PAXARM} + CharTypes = [typeWIDECHAR]; + StringTypes = [typeUNICSTRING]; + DynamicTypes = [typeUNICSTRING] + + VariantTypes + +{$IFDEF ARC} + [typeCLASS] + +{$ENDIF} + [typeDYNARRAY, typeINTERFACE]; +{$ELSE} + CharTypes = [typeANSICHAR, typeWIDECHAR]; + StringTypes = [typeANSISTRING, typeSHORTSTRING, typeWIDESTRING, typeUNICSTRING]; + DynamicTypes = [typeANSISTRING, typeWIDESTRING, typeUNICSTRING] + VariantTypes + [typeDYNARRAY, typeINTERFACE]; +{$ENDIF} + BooleanTypes = [typeBOOLEAN, typeWORDBOOL, typeLONGBOOL, typeBYTEBOOL]; + OrdinalTypes = IntegerTypes + CharTypes + BooleanTypes + [typeENUM]; + RealTypes = [typeSINGLE, typeDOUBLE, typeEXTENDED]; + NumberTypes = IntegerTypes + RealTypes + [typeCURRENCY]; + StandardTypes = OrdinalTypes + RealTypes + StringTypes + VariantTypes; + +var + OP_NOP, + OP_SEPARATOR, + OP_ADD_COMMENT, + OP_STMT, + OP_SET_CODE_LINE, + + OP_BEGIN_TEXT, + OP_END_TEXT, + + OP_BEGIN_LOOP, + OP_EPILOGUE_LOOP, + OP_END_LOOP, + + OP_ADD_MESSAGE, + + OP_OPTION_EXPLICIT, + OP_INIT_FWARRAY, + + OP_CHECK_FINAL, + + OP_BEGIN_NAMESPACE, + OP_END_NAMESPACE, + + OP_BEGIN_TYPE, + OP_END_TYPE, + + OP_BEGIN_CLASS_TYPE, + OP_END_CLASS_TYPE, + + OP_BEGIN_CLASSREF_TYPE, + OP_END_CLASSREF_TYPE, + + OP_BEGIN_HELPER_TYPE, + OP_END_HELPER_TYPE, + + OP_BEGIN_INTERFACE_TYPE, + OP_END_INTERFACE_TYPE, + + OP_BEGIN_RECORD_TYPE, + OP_END_RECORD_TYPE, + + OP_BEGIN_ARRAY_TYPE, + OP_END_ARRAY_TYPE, + + OP_BEGIN_DYNARRAY_TYPE, + OP_END_DYNARRAY_TYPE, + + OP_BEGIN_SUBRANGE_TYPE, + OP_END_SUBRANGE_TYPE, + + OP_BEGIN_ENUM_TYPE, + OP_END_ENUM_TYPE, + + OP_BEGIN_SET_TYPE, + OP_END_SET_TYPE, + + OP_BEGIN_POINTER_TYPE, + OP_END_POINTER_TYPE, + + OP_BEGIN_PROC_TYPE, + OP_END_PROC_TYPE, + +{$IFNDEF PAXARM} + OP_BEGIN_SHORTSTRING_TYPE, + OP_END_SHORTSTRING_TYPE, +{$ENDIF} + + OP_BEGIN_ALIAS_TYPE, + OP_END_ALIAS_TYPE, + + OP_BEGIN_CONST, + OP_END_CONST, + + OP_BEGIN_VAR, + OP_END_VAR, + + OP_GET_NEXTJSPROP, // js only + OP_CLEAR_REFERENCES, // js only + + OP_BEGIN_LIBRARY, + OP_BEGIN_EXPORT, + OP_BEGIN_MODULE, + OP_END_MODULE, + OP_BEGIN_INCLUDED_FILE, + OP_END_INCLUDED_FILE, + OP_END_INTERFACE_SECTION, + OP_END_IMPORT, + OP_BEGIN_INITIALIZATION, + OP_END_INITIALIZATION, + OP_BEGIN_FINALIZATION, + OP_END_FINALIZATION, + + OP_EXTRA_BYTECODE, + + OP_WARNINGS_ON, + OP_WARNINGS_OFF, + + OP_FRAMEWORK_ON, + OP_FRAMEWORK_OFF, + + OP_TRY_ON, + OP_TRY_OFF, + OP_FINALLY, + OP_EXCEPT, + OP_EXCEPT_SEH, + OP_EXCEPT_ON, + OP_RAISE, + OP_COND_RAISE, + OP_BEGIN_EXCEPT_BLOCK, + OP_END_EXCEPT_BLOCK, + + OP_OVERFLOW_CHECK, + + OP_PAUSE, + OP_CHECK_PAUSE, + OP_CHECK_PAUSE_LIGHT, + OP_HALT, + + OP_EMIT_OFF, + OP_EMIT_ON, + + OP_BEGIN_USING, + OP_END_USING, + + OP_BEGIN_BLOCK, + OP_END_BLOCK, + + OP_EVAL, + OP_EVAL_OUTER, + + OP_EVAL_INHERITED, + OP_EVAL_CONSTRUCTOR, + OP_UPDATE_INSTANCE, + OP_ADJUST_INSTANCE, + OP_CLEAR_EDX, + OP_IMPLEMENTS, + OP_MYCLASS, + OP_MYBASE, + + OP_LOAD_PROC, + + OP_CHECK_OVERRIDE, + + OP_EXIT, + OP_GO, + OP_GO_1, + OP_GO_2, + OP_GO_3, + OP_GO_TRUE, + OP_GO_FALSE, + OP_GO_TRUE_BOOL, + OP_GO_FALSE_BOOL, + OP_GO_DL, + OP_CALL_INHERITED, + OP_CALL, + OP_BEGIN_CALL, + OP_CALL_DEFAULT_CONSTRUCTOR, + OP_CHECK_SUB_CALL, + OP_BEGIN_VCALL, + OP_VCALL, + OP_PUSH, + OP_PUSH_INSTANCE, + OP_PUSH_CLASSREF, + OP_PUSH_CONTEXT, + OP_POP_CONTEXT, + OP_FIND_CONTEXT, + OP_FIND_JS_FUNC, + OP_LABEL, + + OP_SAVE_EDX, + OP_RESTORE_EDX, + + OP_TYPE_CAST, + + OP_DECLARE_MEMBER, + + OP_DECL_SUB, + OP_BEGIN_SUB, + OP_DECLARE_LOCAL_VAR, + OP_DECLARE_TEMP_VAR, + OP_DESTROY_LOCAL_VAR, + OP_INIT_SUB, + OP_JUMP_SUB, + OP_END_SUB, + OP_FIN_SUB, + OP_EPILOGUE_SUB, + + OP_BEGIN_GLOBAL_BLOCK, + OP_EPILOGUE_GLOBAL_BLOCK, + OP_EPILOGUE_GLOBAL_BLOCK2, + OP_END_GLOBAL_BLOCK, + + OP_ABSOLUTE, + + OP_ASSIGN_TYPE, + OP_DETERMINE_TYPE, + OP_ASSIGN_THE_SAME_TYPE, + OP_ASSIGN_TYPE_ALIAS, + OP_ASSIGN_LAMBDA_TYPES, + + OP_BEGIN_WITH, + OP_END_WITH, + + OP_BEGIN_INIT_CONST, + OP_END_INIT_CONST, + + OP_CREATE_POINTER_TYPE, + OP_CREATE_CLASSREF_TYPE, + OP_ADDRESS, + OP_TERMINAL, + OP_ADDRESS_PROG, + OP_ASSIGN_PROG, + + OP_CREATE_DYNAMIC_ARRAY_TYPE, + + OP_CREATE_SHORTSTRING_TYPE, + + OP_SET_INCLUDE, + OP_SET_INCLUDE_INTERVAL, + OP_SET_EXCLUDE, + + OP_LVALUE, + OP_POSTFIX_EXPRESSION, + + OP_ASSIGN, + OP_ASSIGN_CONST, + OP_ASSIGN_ENUM, + OP_CHECK_SUBRANGE_TYPE, + + OP_INC, + OP_DEC, + OP_PRED, + OP_SUCC, + OP_ORD, + OP_CHR, + OP_STR, + OP_LOW, + OP_HIGH, + + OP_SET_LENGTH, + + OP_SET_LENGTH_EX, + OP_PUSH_LENGTH, + + OP_DYNARRAY_ASSIGN, + OP_DYNARRAY_CLR, + OP_DYNARRAY_HIGH, + OP_CREATE_EMPTY_DYNARRAY, + + OP_SHORTSTRING_HIGH, + + OP_EXPORTS, + + OP_PLUS, + OP_MINUS, + OP_MULT, + OP_DIV, + OP_IDIV, + OP_MOD, + OP_SHL, + OP_SHR, + + OP_NEG, + OP_POSITIVE, + OP_ABS, + + OP_EQ, + OP_NE, + OP_LT, + OP_LE, + OP_GT, + OP_GE, + + OP_CLASSNAME, + + OP_GET_PROG, + + OP_IS, + OP_AS, + OP_TYPEINFO, + OP_ADD_TYPEINFO, + OP_INSTANCE_OF, + + OP_AND, + OP_OR, + OP_XOR, + OP_NOT, + + OP_RET, + + OP_FIELD, + OP_ELEM, + + OP_ITEM, + OP_RECORD_ITEM, + + OP_PRINT, + OP_PRINT_EX, + + OP_PRINT_KWD, + OP_PRINTLN_KWD, + +{$IFNDEF PAXARM} + OP_INIT_PANSICHAR_LITERAL, +{$ENDIF} + OP_INIT_PWIDECHAR_LITERAL, + OP_SIZEOF, + + OP_SET_READ_ID, + OP_SET_WRITE_ID, + + OP_OLE_GET, + OP_OLE_SET, + OP_OLE_VALUE, + OP_OLE_PARAM, + + OP_PARAM_CHANGED, + + OP_ONCREATE_OBJECT, + OP_ON_AFTER_OBJECT_CREATION, + OP_CREATE_OBJECT, + OP_DESTROY_OBJECT, + OP_GET_VMT_ADDRESS, + OP_ADD_ANCESTOR, + OP_ADD_INTERFACE, + OP_ADD_METHOD_INDEX, + OP_ASSIGNED, + + OP_ONCREATE_HOST_OBJECT, + OP_ONDESTROY_HOST_OBJECT, + + OP_BEFORE_CALL_HOST, + OP_AFTER_CALL_HOST, + + OP_SAVE_REGS, + OP_RESTORE_REGS, + + OP_ERR_ABSTRACT, + OP_UPDATE_DEFAULT_CONSTRUCTOR, + OP_FIND_CONSTRUCTOR, + + OP_BEGIN_CRT_JS_FUNC_OBJECT, + OP_END_CRT_JS_FUNC_OBJECT, + + OP_TO_JS_OBJECT, + OP_JS_TYPEOF, + OP_JS_VOID, + OP_JS_DELETE, + + OP_TO_FW_OBJECT, + + // for-in statement + OP_GET_ENUMERATOR, + OP_MOVE_NEXT, + OP_CURRENT, + OP_LOCK_VARRAY, + OP_UNLOCK_VARRAY, + + OP_DUMMY + : Integer; + +// detailed operators +var + OP_VAR_FROM_TVALUE, + + OP_CURRENCY_FROM_INT64, + OP_CURRENCY_FROM_UINT64, + OP_CURRENCY_FROM_INT, + OP_CURRENCY_FROM_REAL, + + OP_INT_TO_DOUBLE, + OP_INT64_TO_DOUBLE, + OP_UINT64_TO_DOUBLE, + + OP_INT_TO_SINGLE, + OP_INT64_TO_SINGLE, + OP_UINT64_TO_SINGLE, + + OP_INT_TO_EXTENDED, + OP_INT64_TO_EXTENDED, + OP_UINT64_TO_EXTENDED, + + OP_INT_TO_INT64, + OP_BYTE_TO_INT64, + OP_WORD_TO_INT64, + OP_CARDINAL_TO_INT64, + OP_SMALLINT_TO_INT64, + OP_SHORTINT_TO_INT64, + + OP_INT_FROM_INT64, + OP_BYTE_FROM_INT64, + OP_WORD_FROM_INT64, + OP_CARDINAL_FROM_INT64, + OP_SMALLINT_FROM_INT64, + OP_SHORTINT_FROM_INT64, + + OP_INT_TO_UINT64, + OP_BYTE_TO_UINT64, + OP_WORD_TO_UINT64, + OP_CARDINAL_TO_UINT64, + OP_SMALLINT_TO_UINT64, + OP_SHORTINT_TO_UINT64, + + OP_INT_FROM_UINT64, + OP_BYTE_FROM_UINT64, + OP_WORD_FROM_UINT64, + OP_CARDINAL_FROM_UINT64, + OP_SMALLINT_FROM_UINT64, + OP_SHORTINT_FROM_UINT64, + + OP_MULT_INT64, + OP_IDIV_INT64, + OP_MOD_INT64, + OP_SHL_INT64, + OP_SHR_INT64, + + OP_CURRENCY_TO_EXTENDED, + OP_CURRENCY_TO_SINGLE, + OP_CURRENCY_TO_DOUBLE, + + OP_DOUBLE_TO_SINGLE, + OP_DOUBLE_TO_EXTENDED, + + OP_SINGLE_TO_DOUBLE, + OP_SINGLE_TO_EXTENDED, + + OP_EXTENDED_TO_DOUBLE, + OP_EXTENDED_TO_SINGLE, + + OP_ASSIGN_BYTE_I, + OP_ASSIGN_BYTE_M, + OP_ASSIGN_WORD_I, + OP_ASSIGN_WORD_M, + OP_ASSIGN_CARDINAL_I, + OP_ASSIGN_CARDINAL_M, + OP_ASSIGN_SMALLINT_I, + OP_ASSIGN_SMALLINT_M, + OP_ASSIGN_SHORTINT_I, + OP_ASSIGN_SHORTINT_M, + OP_ASSIGN_INT_I, + OP_ASSIGN_INT_M, + OP_ASSIGN_DOUBLE, + OP_ASSIGN_CURRENCY, + OP_ASSIGN_EVENT, + OP_ASSIGN_SINGLE, + OP_ASSIGN_EXTENDED, +{$IFNDEF PAXARM} + OP_ASSIGN_PANSICHAR, +{$ENDIF} + OP_ASSIGN_PWIDECHAR, + OP_ASSIGN_INT64, + OP_ASSIGN_UINT64, + OP_ASSIGN_INTERFACE, + + OP_CREATE_EVENT, + +{$IFNDEF PAXARM} + OP_ASSIGN_ANSISTRING, + OP_ASSIGN_SHORTSTRING, + OP_ASSIGN_WIDESTRING, +{$ENDIF} + OP_ASSIGN_UNICSTRING, + OP_ASSIGN_VARIANT, + OP_ASSIGN_OLEVARIANT, + + OP_ASSIGN_CLASS, + + OP_ASSIGN_SHIFT, + + OP_ASSIGN_TVarRec, + + OP_ASSIGN_RECORD, + OP_ASSIGN_ARRAY, + +{$IFNDEF PAXARM} + OP_ANSISTRING_FROM_PANSICHAR, + OP_ANSISTRING_FROM_PWIDECHAR, + OP_ANSISTRING_FROM_ANSICHAR, + OP_ADD_ANSISTRING, + OP_ADD_SHORTSTRING, + OP_ADD_WIDESTRING, +{$ENDIF} + OP_ADD_UNICSTRING, + + OP_ADD_STRING, + +{$IFNDEF PAXARM} + OP_ANSISTRING_CLR, + OP_WIDESTRING_CLR, +{$ENDIF} + OP_UNICSTRING_CLR, + OP_INTERFACE_CLR, + OP_CLASS_CLR, // js only + + OP_EQ_STRUCT, + OP_NE_STRUCT, + +{$IFNDEF PAXARM} + OP_EQ_ANSISTRING, + OP_NE_ANSISTRING, + + OP_GT_ANSISTRING, + OP_GE_ANSISTRING, + OP_LT_ANSISTRING, + OP_LE_ANSISTRING, + + OP_GT_SHORTSTRING, + OP_GE_SHORTSTRING, + OP_LT_SHORTSTRING, + OP_LE_SHORTSTRING, + + OP_GT_WIDESTRING, + OP_GE_WIDESTRING, + OP_LT_WIDESTRING, + OP_LE_WIDESTRING, +{$ENDIF} + OP_GT_UNICSTRING, + OP_GE_UNICSTRING, + OP_LT_UNICSTRING, + OP_LE_UNICSTRING, + +{$IFNDEF PAXARM} + OP_EQ_SHORTSTRING, + OP_EQ_WIDESTRING, +{$ENDIF} + OP_EQ_UNICSTRING, +{$IFNDEF PAXARM} + OP_NE_SHORTSTRING, + OP_NE_WIDESTRING, +{$ENDIF} + OP_NE_UNICSTRING, + + OP_STRUCTURE_CLR, + OP_STRUCTURE_ADDREF, + OP_ADDREF, + +{$IFNDEF PAXARM} + OP_SHORTSTRING_FROM_PANSICHAR_LITERAL, + OP_SHORTSTRING_FROM_PWIDECHAR_LITERAL, + OP_SHORTSTRING_FROM_ANSICHAR, + OP_SHORTSTRING_FROM_WIDECHAR, + OP_SHORTSTRING_FROM_ANSISTRING, + OP_SHORTSTRING_FROM_WIDESTRING, + OP_UNICSTRING_FROM_WIDESTRING, + OP_SHORTSTRING_FROM_UNICSTRING, + OP_ANSISTRING_FROM_SHORTSTRING, + + OP_WIDESTRING_FROM_PANSICHAR_LITERAL, + OP_WIDESTRING_FROM_PWIDECHAR_LITERAL, + OP_WIDESTRING_FROM_ANSICHAR, + OP_WIDESTRING_FROM_WIDECHAR, + OP_ANSISTRING_FROM_WIDECHAR, + OP_WIDESTRING_FROM_WIDECHAR_LITERAL, + OP_WIDESTRING_FROM_ANSISTRING, + OP_UNICSTRING_FROM_ANSISTRING, + OP_WIDESTRING_FROM_SHORTSTRING, + OP_WIDESTRING_FROM_UNICSTRING, + OP_UNICSTRING_FROM_SHORTSTRING, + OP_ANSISTRING_FROM_WIDESTRING, + OP_ANSISTRING_FROM_UNICSTRING, + + OP_UNICSTRING_FROM_PANSICHAR_LITERAL, + OP_UNICSTRING_FROM_ANSICHAR, +{$ENDIF} + OP_UNICSTRING_FROM_PWIDECHAR_LITERAL, + OP_UNICSTRING_FROM_WIDECHAR, + OP_UNICSTRING_FROM_WIDECHAR_LITERAL, + + OP_VARIANT_FROM_CLASS, // JS only + OP_VARIANT_FROM_POINTER, // JS only + OP_CLASS_FROM_VARIANT, // JS only + + OP_INTERFACE_FROM_CLASS, + OP_INTERFACE_CAST, + +{$IFNDEF PAXARM} + OP_VARIANT_FROM_PANSICHAR_LITERAL, + OP_VARIANT_FROM_ANSISTRING, + OP_VARIANT_FROM_WIDESTRING, + OP_VARIANT_FROM_SHORTSTRING, + OP_VARIANT_FROM_ANSICHAR, +{$ENDIF} + OP_VARIANT_FROM_PWIDECHAR_LITERAL, + OP_VARIANT_FROM_UNICSTRING, + OP_VARIANT_FROM_WIDECHAR, + OP_VARIANT_FROM_WIDECHAR_LITERAL, + OP_VARIANT_FROM_INT, + OP_VARIANT_FROM_INT64, + OP_VARIANT_FROM_BYTE, + OP_VARIANT_FROM_BOOL, + OP_VARIANT_FROM_WORD, + OP_VARIANT_FROM_CARDINAL, + OP_VARIANT_FROM_SMALLINT, + OP_VARIANT_FROM_SHORTINT, + OP_VARIANT_FROM_DOUBLE, + OP_VARIANT_FROM_CURRENCY, + OP_VARIANT_FROM_SINGLE, + OP_VARIANT_FROM_EXTENDED, + OP_VARIANT_FROM_INTERFACE, + + OP_OLEVARIANT_FROM_VARIANT, +{$IFNDEF PAXARM} + OP_OLEVARIANT_FROM_PANSICHAR_LITERAL, + OP_OLEVARIANT_FROM_ANSISTRING, + OP_OLEVARIANT_FROM_WIDESTRING, + OP_OLEVARIANT_FROM_SHORTSTRING, + OP_OLEVARIANT_FROM_ANSICHAR, +{$ENDIF} + OP_OLEVARIANT_FROM_PWIDECHAR_LITERAL, + OP_OLEVARIANT_FROM_UNICSTRING, + OP_OLEVARIANT_FROM_WIDECHAR, + OP_OLEVARIANT_FROM_WIDECHAR_LITERAL, + OP_OLEVARIANT_FROM_INT, + OP_OLEVARIANT_FROM_INT64, + OP_OLEVARIANT_FROM_BYTE, + OP_OLEVARIANT_FROM_BOOL, + OP_OLEVARIANT_FROM_WORD, + OP_OLEVARIANT_FROM_CARDINAL, + OP_OLEVARIANT_FROM_SMALLINT, + OP_OLEVARIANT_FROM_SHORTINT, + OP_OLEVARIANT_FROM_DOUBLE, + OP_OLEVARIANT_FROM_CURRENCY, + OP_OLEVARIANT_FROM_SINGLE, + OP_OLEVARIANT_FROM_EXTENDED, + OP_OLEVARIANT_FROM_INTERFACE, +{$IFNDEF PAXARM} + OP_ANSISTRING_FROM_INT, // JS only + OP_ANSISTRING_FROM_DOUBLE, // JS only + OP_ANSISTRING_FROM_SINGLE, // JS only + OP_ANSISTRING_FROM_EXTENDED, // JS only + OP_ANSISTRING_FROM_BOOLEAN, // JS only +{$ENDIF} + OP_UNICSTRING_FROM_INT, // JS only + OP_UNICSTRING_FROM_DOUBLE, // JS only + OP_UNICSTRING_FROM_SINGLE, // JS only + OP_UNICSTRING_FROM_EXTENDED, // JS only + OP_UNICSTRING_FROM_BOOLEAN, // JS only + + OP_JS_FUNC_OBJ_FROM_VARIANT, // JS only + +{$IFNDEF PAXARM} + OP_ANSICHAR_FROM_VARIANT, + OP_ANSISTRING_FROM_VARIANT, + OP_WIDESTRING_FROM_VARIANT, + OP_SHORTSTRING_FROM_VARIANT, +{$ENDIF} + OP_WIDECHAR_FROM_VARIANT, + OP_UNICSTRING_FROM_VARIANT, + OP_DOUBLE_FROM_VARIANT, + OP_CURRENCY_FROM_VARIANT, + OP_SINGLE_FROM_VARIANT, + OP_EXTENDED_FROM_VARIANT, + OP_INT64_FROM_VARIANT, + OP_UINT64_FROM_VARIANT, + OP_INT_FROM_VARIANT, + OP_BYTE_FROM_VARIANT, + OP_WORD_FROM_VARIANT, + OP_CARDINAL_FROM_VARIANT, + OP_BOOL_FROM_VARIANT, + OP_BYTEBOOL_FROM_VARIANT, + OP_WORDBOOL_FROM_VARIANT, + OP_LONGBOOL_FROM_VARIANT, + OP_SMALLINT_FROM_VARIANT, + OP_SHORTINT_FROM_VARIANT, + OP_BOOL_FROM_BYTEBOOL, + OP_BOOL_FROM_WORDBOOL, + OP_BOOL_FROM_LONGBOOL, + + OP_NOT_BOOL, + OP_NOT_BYTEBOOL, + OP_NOT_WORDBOOL, + OP_NOT_LONGBOOL, + + OP_NOT_VARIANT, + OP_NEG_VARIANT, + OP_ADD_VARIANT, + OP_SUB_VARIANT, + OP_MULT_VARIANT, + OP_DIV_VARIANT, + OP_IDIV_VARIANT, + OP_MOD_VARIANT, + OP_SHL_VARIANT, + OP_SHR_VARIANT, + OP_AND_VARIANT, + OP_OR_VARIANT, + OP_XOR_VARIANT, + OP_LT_VARIANT, + OP_LE_VARIANT, + OP_GT_VARIANT, + OP_GE_VARIANT, + OP_EQ_VARIANT, + OP_NE_VARIANT, + + OP_EQ_EVENT, + OP_NE_EVENT, + + OP_VARIANT_CLR, + OP_VARARRAY_GET, + OP_VARARRAY_PUT, + OP_VARARRAY_IDX, + + OP_ADD_INT_MI, + OP_ADD_INT_MM, + + OP_SUB_INT_MI, + OP_SUB_INT_MM, + + OP_IMUL_INT_MI, + OP_IMUL_INT_MM, + + OP_IDIV_INT_MI, + OP_IDIV_INT_MM, + OP_IDIV_INT_IM, + + OP_MOD_INT_MI, + OP_MOD_INT_MM, + OP_MOD_INT_IM, + + OP_SHL_INT_MI, + OP_SHL_INT_MM, + OP_SHL_INT_IM, + + OP_SHR_INT_MI, + OP_SHR_INT_MM, + OP_SHR_INT_IM, + + OP_AND_INT_MI, + OP_AND_INT_MM, + + OP_OR_INT_MI, + OP_OR_INT_MM, + + OP_XOR_INT_MI, + OP_XOR_INT_MM, + + OP_NEG_INT, + OP_NEG_INT64, + OP_NEG_UINT64, + + OP_ABS_INT, + OP_ABS_INT64, + OP_ABS_DOUBLE, + OP_ABS_SINGLE, + OP_ABS_EXTENDED, + OP_ABS_CURRENCY, + OP_ABS_VARIANT, + + OP_LT_INT_MI, + OP_LT_INT_MM, + + OP_LE_INT_MI, + OP_LE_INT_MM, + + OP_GT_INT_MI, + OP_GT_INT_MM, + + OP_GE_INT_MI, + OP_GE_INT_MM, + + OP_EQ_INT_MI, + OP_EQ_INT_MM, + + OP_NE_INT_MI, + OP_NE_INT_MM, + + OP_ADD_INT64, + OP_SUB_INT64, + OP_AND_INT64, + OP_OR_INT64, + OP_XOR_INT64, + + OP_ADD_UINT64, + OP_SUB_UINT64, + OP_AND_UINT64, + OP_OR_UINT64, + OP_XOR_UINT64, + + OP_LT_INT64, + OP_LE_INT64, + OP_GT_INT64, + OP_GE_INT64, + OP_EQ_INT64, + OP_NE_INT64, + + OP_LT_UINT64, + OP_LE_UINT64, + OP_GT_UINT64, + OP_GE_UINT64, + + OP_ADD_CURRENCY, + OP_SUB_CURRENCY, + OP_MUL_CURRENCY, + OP_DIV_CURRENCY, + + OP_LT_CURRENCY, + OP_LE_CURRENCY, + OP_GT_CURRENCY, + OP_GE_CURRENCY, + OP_EQ_CURRENCY, + OP_NE_CURRENCY, + + OP_ADD_DOUBLE, + OP_SUB_DOUBLE, + OP_MUL_DOUBLE, + OP_DIV_DOUBLE, + + OP_NEG_DOUBLE, + OP_NEG_CURRENCY, + + OP_LT_DOUBLE, + OP_LE_DOUBLE, + OP_GT_DOUBLE, + OP_GE_DOUBLE, + OP_EQ_DOUBLE, + OP_NE_DOUBLE, + + OP_ADD_SINGLE, + OP_SUB_SINGLE, + OP_MUL_SINGLE, + OP_DIV_SINGLE, + + OP_NEG_SINGLE, + + OP_LT_SINGLE, + OP_LE_SINGLE, + OP_GT_SINGLE, + OP_GE_SINGLE, + OP_EQ_SINGLE, + OP_NE_SINGLE, + + OP_ADD_EXTENDED, + OP_SUB_EXTENDED, + OP_MUL_EXTENDED, + OP_DIV_EXTENDED, + + OP_NEG_EXTENDED, + + OP_LT_EXTENDED, + OP_LE_EXTENDED, + OP_GT_EXTENDED, + OP_GE_EXTENDED, + OP_EQ_EXTENDED, + OP_NE_EXTENDED, + + OP_PUSH_EBP, + OP_POP, + + OP_PUSH_PROG, + OP_PUSH_ADDRESS, + OP_PUSH_STRUCTURE, + OP_PUSH_SET, + + OP_PUSH_BYTE_IMM, + OP_PUSH_BYTE, + OP_PUSH_WORD_IMM, + OP_PUSH_WORD, + OP_PUSH_CARDINAL_IMM, + OP_PUSH_CARDINAL, + OP_PUSH_SMALLINT_IMM, + OP_PUSH_SMALLINT, + OP_PUSH_SHORTINT_IMM, + OP_PUSH_SHORTINT, + OP_PUSH_INT_IMM, + OP_PUSH_INT, + OP_PUSH_PTR, + OP_PUSH_DOUBLE, + OP_PUSH_CURRENCY, + OP_PUSH_SINGLE, + OP_PUSH_EXTENDED, +{$IFNDEF PAXARM} + OP_PUSH_ANSISTRING, + OP_PUSH_SHORTSTRING, + OP_PUSH_WIDESTRING, + OP_PUSH_PANSICHAR_IMM, +{$ENDIF} + OP_PUSH_UNICSTRING, + OP_PUSH_PWIDECHAR_IMM, + OP_PUSH_INST, + OP_PUSH_CLSREF, + OP_PUSH_DYNARRAY, + OP_PUSH_OPENARRAY, + OP_PUSH_INT64, + OP_PUSH_DATA, + OP_PUSH_EVENT, + + OP_SET_ASSIGN, + OP_SET_COUNTER_ASSIGN, + OP_SET_UNION, + OP_SET_DIFFERENCE, + OP_SET_INTERSECTION, + OP_SET_SUBSET, + OP_SET_SUPERSET, + OP_SET_EQUALITY, + OP_SET_INEQUALITY, + OP_SET_MEMBERSHIP, + + OP_GET_COMPONENT, + + OP_DETERMINE_PROP, + + OP_GET_DRTTI_PROP, + OP_SET_DRTTI_PROP, +{$IFNDEF PAXARM} + OP_GET_ANSISTR_PROP, + OP_SET_ANSISTR_PROP, + + OP_GET_WIDESTR_PROP, + OP_SET_WIDESTR_PROP, +{$ENDIF} + OP_GET_UNICSTR_PROP, + OP_SET_UNICSTR_PROP, + + OP_GET_ORD_PROP, + OP_SET_ORD_PROP, + + OP_GET_INTERFACE_PROP, + OP_SET_INTERFACE_PROP, + + OP_GET_SET_PROP, + OP_SET_SET_PROP, + + OP_GET_FLOAT_PROP, + OP_SET_FLOAT_PROP, + + OP_GET_VARIANT_PROP, + OP_SET_VARIANT_PROP, + + OP_GET_INT64_PROP, + OP_SET_INT64_PROP, + + OP_GET_EVENT_PROP, + OP_SET_EVENT_PROP, + OP_SET_EVENT_PROP2, + OP_CREATE_METHOD + + : Integer; + + ASM_NOP, + ASM_WAIT, + ASM_CLC, + ASM_PUSHFD, + ASM_POPFD, + ASM_XCHG, + + ASM_MOV, + ASM_LEA, + ASM_TEST, + + ASM_ADD, + ASM_ADC, + ASM_SBB, + ASM_NEG, + ASM_NOT, + ASM_SUB, + + ASM_MUL, + ASM_IMUL, + ASM_DIV, + ASM_IDIV, + ASM_XOR, + ASM_AND, + ASM_OR, + ASM_SHL, + ASM_SHR, + + ASM_CDQ, + + ASM_CALL, + ASM_RET, + ASM_PUSH, + ASM_POP, + ASM_JMP, + + ASM_INC, + ASM_DEC, + + ASM_JNO, + ASM_JNC, + ASM_JZ, + ASM_JNZ, + ASM_JBE, + ASM_JNLE, + + ASM_FLD, + ASM_FILD, + ASM_FISTP, + ASM_FSTP, + ASM_FADD, + ASM_FSUB, + ASM_FMUL, + ASM_FDIV, + ASM_FCOMP, + ASM_FCOMPP, + ASM_FSTSV, + ASM_SAHF, + ASM_FCHS, + ASM_FABS, + + ASM_SETL, + ASM_SETLE, + ASM_SETNLE, + ASM_SETNL, + + ASM_SETB, + ASM_SETBE, + ASM_SETNBE, + ASM_SETNB, + ASM_SETZ, + ASM_SETNZ, + + ASM_CMP, + + ASM_REP_MOVSB, + ASM_REP_MOVSD, + + ASM_MOVSD, + ASM_MOVSS, + ASM_CVTSD2SS, + ASM_CVTSS2SD + + : Integer; + +type + PExcFrame = ^TExcFrame; + TExcFrame = record + next: PExcFrame; + desc: Pointer; + hEBP: Integer; + case Integer of + 0: ( ); + 1: ( ConstructedObject: Pointer ); + 2: ( SelfOfMethod: Pointer ); + end; + +const + HOST_EXC_FRAME_SIZE = SizeOf(TExcFrame); + +type + TParserNotifyEvent = procedure(Sender: TObject) of object; + TParserIdentEvent = procedure(Sender: TObject; + const IdentName: String; Id: Integer) of object; + TParserIdentEventEx = procedure(Sender: TObject; + const IdentName: String; Id: Integer; const Declaration: String) of object; + TParserNamedValueEvent = procedure(Sender: TObject; + const IdentName: String; Id: Integer; const Value: Variant; + const Declaration: String) of object; + TParserTypedIdentEvent = procedure(Sender: TObject; + const IdentName: String; Id: Integer; const TypeName: String; + const Declaration: String) of object; + TParserVariantRecordFieldEvent = procedure(Sender: TObject; + const IdentName: String; Id: Integer; const TypeName: String; VarCount: Int64; + const Declaration: String) of object; + TParserNamedTypedValueEvent = procedure(Sender: TObject; + const IdentName: String; Id: Integer; const TypeName: String; + const DefaultValue: String; + const Declaration: String) of object; + TParserDeclarationEvent = procedure(Sender: TObject; + const IdentName: String; Id: Integer; const Declaration: String) of object; + TParserArrayTypeEvent = procedure(Sender: TObject; + const IdentName: String; Id: Integer; + Ranges: TStringList; + const ElemTypeName: String) of object; + + TPauseNotifyEvent = procedure (Sender: TObject; + const ModuleName: String; SourceLineNumber: Integer) of object; + + THaltNotifyEvent = procedure (Sender: TObject; ExitCode: Integer; + const ModuleName: String; SourceLineNumber: Integer) of object; + + TErrNotifyEvent = procedure (Sender: TObject; E: Exception; + const ModuleName: String; SourceLineNumber: Integer) of object; + + TLoadProcEvent = procedure (Sender: TObject; + const ProcName, DllName: String; var Address: Pointer) of object; + + TObjectNotifyEvent = procedure (Sender: TObject; + Instance: TObject) of object; + TIdNotifyEvent = procedure (Sender: TObject; + Id: Integer) of object; + TClassNotifyEvent = procedure (Sender: TObject; + C: TClass) of object; + + TMapTableNamespaceEvent = procedure (Sender: TObject; + const FullName: String; + Global: Boolean) of object; + TMapTableVarAddressEvent = procedure (Sender: TObject; + const FullName: String; Global: Boolean; var Address: Pointer) of object; + TMapTableProcAddressEvent = procedure (Sender: TObject; + const FullName: String; OverCount: Byte; + Global: Boolean; var Address: Pointer) of object; + TMapTableClassRefEvent = procedure (Sender: TObject; + const FullName: String; Global: Boolean; var ClassRef: TClass) of object; + + TPrintEvent = procedure (Sender: TObject; + const Text: String) of object; + TPrintExEvent = procedure (Sender: TObject; + Address: Pointer; + Kind: Integer; + FT: Integer; + L1, L2: Integer) of object; + + TPrintClassTypeFieldEvent = procedure (Sender: TObject; + const Infos: TPrintClassTypeFieldInfo) + of object; + TPrintClassTypePropEvent = procedure (Sender: TObject; + const Infos: TPrintClassTypePropInfo) + of object; + + TCustomExceptionHelperEvent = procedure (Sender: TObject; + RaisedException, DestException: Exception) + of object; + + TStreamEvent = procedure (Sender: TObject; Stream: TStream) of object; + TProcNotifyEvent = procedure (Sender: TObject; + const FullName: String; OverCount: Byte) of object; + + + TVirtualObjectMethodCallEvent = procedure(Sender: TObject; const ObjectName, + PropName: String; const Params: array of Variant; var result: Variant) of object; + TVirtualObjectPutPropertyEvent = procedure(Sender: TObject; const ObjectName, + PropName: String; const Params: array of Variant; const value: Variant) of object; + + PPaxExcFrame = ^TPaxExcFrame; + TPaxExcFrame = record + next: PPaxExcFrame; //0 + desc: Pointer; //4 + hEBP: Integer; //8 + SelfOfMethod: Pointer;//12 + Prog: Pointer; //16 + TryBlockNumber: Integer; //20 + Magic: Integer; //24 + hESP: Integer; //28 + end; // size of = 32 + +type + TIsJSType = function (T: Integer; P: Pointer): Boolean; + +function _IsJSType(T: Integer; P: Pointer): Boolean; +var + IsJSType: TIsJSType = {$IFDEF FPC}@{$ENDIF}_IsJSType; + +type + TTryKind = (tryExcept, tryFinally); + + TSavePCUEvent = procedure (Sender: TObject; const UnitName: String; var result: TStream) + of object; + TLoadPCUEvent = procedure (Sender: TObject; const UnitName: String; var result: TStream) + of object; + TSavePCUFinishedEvent = procedure(Sender: TObject; const UnitName: String; var Stream : TStream) of object; // jason + TLoadPCUFinishedEvent = procedure (Sender: TObject; const UnitName: String; var Stream : TStream) of object; // jason + + TExceptionClass = class of Exception; + + PPointer = ^Pointer; + + TClassVisibility = (cvNone, cvPrivate, cvProtected, cvPublic, cvPublished, + cvStrictPrivate, cvStrictProtected); + TMemberVisibilitySet = set of TClassVisibility; + + TBytes = array[0..1000000000] of Byte; + PBytes = ^TBytes; + + TIntegers = array[0..100000] of Integer; + PIntegers = ^ TIntegers; + TPointers = array[0..100000] of Pointer; + PPointers = ^ TPointers; + + PByteSet = ^TByteSet; + TByteSet = set of Byte; + + TTokenClass = (tcNone, tcSeparator, tcKeyword, tcIdentifier, + tcBooleanConst, tcCharConst, tcPCharConst, tcIntegerConst, + tcDoubleConst, tcNumCharConst, tcVariantConst, + tcSpecial, tcHtmlStringConst); + + TParamData = record + Flags: TParamFlags; + ParamName, TypeName: ShortString; + end; + PParamData = ^TParamData; + +function MPtr(X: Integer): Integer; +function StrEql(const S1, S2: String): Boolean; +function ShiftPointer(P: Pointer; L: Integer): Pointer; +function AlignLeft(const S: String; L: Integer): String; +function ByteToHex(B: Byte): String; +function IsShortInt(I: Integer): Boolean; + +function NativeAddress(P: Pointer): Boolean; + +function IsEmpty(const V: Variant): Boolean; + +function InterfaceRefCount(I: Pointer): Integer; +function StrRefCountPtr(S: Pointer): Pointer; +function StrRefCount(S: Pointer): Integer; +function StrSizePtr(S: Pointer): Pointer; +function StrSize(S: Pointer): Integer; + +function InterfaceRTTIMethodCount(pti: PTypeInfo): Word; +function HasInterfaceRTTIMethod(pti: PTypeInfo): Boolean; + +function ExtractNames(const S: String): TStringList; + +type + TIntegerDynArray = array of Integer; + +procedure SaveIntDynarrayToStream(const A: TIntegerDynArray; P: TStream); +function LoadIntDynarrayFromStream(P: TStream): TIntegerDynArray; + +function SaveStringListToStream(L: TStringList; P: TStream): Integer; +function LoadStringListFromStream(L: TStringList; P: TStream): Integer; + +procedure SaveStringToStream(const S: String; P: TStream); +function LoadStringFromStream(P: TStream): String; + +{$IFNDEF PAXARM} +procedure SaveWideStringToStream(const S: WideString; P: TStream); +function LoadWideStringFromStream(P: TStream): WideString; +{$ENDIF} + +procedure SaveShortStringToStream(const S: ShortString; P: TStream); +function LoadShortStringFromStream(P: TStream): ShortString; + +procedure SaveVariantToStream(const Value: Variant; S: TStream); +function LoadVariantFromStream(S: TStream): Variant; + +procedure SaveIntegerToStream(Value: Integer; S: TStream); +function LoadIntegerFromStream(S: TStream): Integer; + +function Int32ToByteSet(value: Integer): TByteSet; +function ByteSetToInt32(value: TByteSet): Integer; +function ByteSetToString(value: TByteSet; + FinTypeId: Integer; + EnumNames: TStringList = nil): String; + +function Norm(const S: String; L: Integer): String; + +function HashNumber(const S: String): Integer; +function VariantToDate(const V: Variant): TDateTime; +function VariantIsString(const V: Variant): Boolean; + +function RemoveWhiteSpaces(const S: String): String; +function Space(K: Integer): String; +function PosCh(ch: Char; const S: String): Integer; +function LastPosCh(ch: Char; const S: String): Integer; +function CountCh(ch: Char; const S: String): Integer; +function ReplaceCh(Source, Dest: Char; const S: String): String; +function RemoveCh(Ch: Char; const S: String): String; +function RemoveChars(C: TByteSet; const S: String): String; +function RemoveLeftChars(C: TByteSet; const S: String): String; +function RemoveLeftChars1(C: TByteSet; const S: String): String; +function RemoveRightChars1(C: TByteSet; const S: String): String; +function RemoveRightChars(C: TByteSet; const S: String): String; +function RemoveBorderChars(C: TByteSet; const S: String): String; +function IsPositiveInt(S: PChar): Boolean; + +function GuidsAreEqual(const G1, G2: TGUID): Boolean; +function ExtractName(const S: String): String; +function ExtractFullName(const S: String): String; +function ExtractClassName(const S: String): String; +function ExtractOwner(const S: String): String; +function ExtractFullOwner(const S: String): String; + +function ChCount(const S: String; Ch: Char): Integer; +function IsPaxFrame: Boolean; + +{$IFNDEF UNIX} +{$IFNDEF PAXARM} +function CLSIDFromString(psz: PWideString; out clsid: TGUID): HResult; stdcall; +{$ENDIF} +{$ENDIF} + +var + Types: TStdTypeList; + Kinds: TStringList; + Operators: TStringList; + + AsmOperators: TStringList; + DynDestrList: TIntegerList; + PushOperators: TIntegerList; + +function IsDynDestr(OP: Integer): Boolean; +procedure ErrMessageBox(const S: String); + +function GetImplementorOfInterface(const I: IUnknown): TObject; +function IsValidName(const S: String): Boolean; +function IsDigit(C: Char): Boolean; +function IsAlpha(C: Char): Boolean; +function ByteInSet(B: Char; const S: TByteSet): Boolean; +function Subst(const S, X, Y: String): String; + +type + PClass = ^TClass; + PSafeCallException = function (Self: TObject; ExceptObject: + TObject; ExceptAddr: Pointer): HResult; + PAfterConstruction = procedure (Self: TObject); + PBeforeDestruction = procedure (Self: TObject); + PDispatch = procedure (Self: TObject; var Message); + PDefaultHandler = procedure (Self: TObject; var Message); + PNewInstance = function (Self: TClass) : TObject; + PFreeInstance = procedure (Self: TObject); + PDestroy = procedure (Self: TObject; OuterMost: ShortInt); + PVmt = ^TVmt; + +{$IFNDEF FPC} + TVmt = packed record + Buff: array[0..300] of Byte; + end; +{$ENDIF} + + PDmtIndexList = ^TDmtIndexList; + TDmtIndexList = array[0..High(Word)-1] of SmallInt; + PDmtMethodList = ^TDmtMethodList; + TDmtMethodList = array[0..High(Word)-1] of Pointer; + PDmtTable = ^TDmtTable; + TDmtTable = packed record + Count: word; + IndexList: TDmtIndexList; + MethodList : TDmtMethodList; + end; +const + FPC_VIRTUAL_OFFSET = SizeOf(TVMT); + +function GetVmtFromClass(AClass: TClass): PVmt; +function GetVmtFromObject(Instance: TObject): PVmt; +function GetClassFromVMT(Vmt: PVmt): TClass; +function GetDestructorAddress(AClass: TClass): Pointer; +function GetDmtFromClass(AClass: TClass): PDmtTable; +function GetDynamicMethodIndex(AClass: TClass; I: integer): integer; +function GetDynamicMethodIndexByAddress(AClass: TClass; Address: Pointer): integer; +procedure SetDynamicMethodIndex(AClass: TClass; I: Integer; value: SmallInt); +function GetDynamicMethodAddress(AClass: TClass; I: integer): Pointer; +procedure SetDynamicMethodAddress(AClass: TClass; I: Integer; value: Pointer); + + +const + MaxVirtuals = 999; +type + PPointerArray = ^TPointerArray; + TPointerArray = array[0..MaxVirtuals] of pointer; + + PPaxInfo = ^TPaxInfo; + TPaxInfo = packed record + PaxSignature: TPaxSignature; + Prog: Pointer; + ClassIndex: Integer; + OldWndProc: Pointer; + ClassFactoryRec: Pointer; + end; + + PPaxClassRec = ^TPaxClassRec; + TPaxClassRec = packed record + PaxInfo: TPaxInfo; + VMT: TVMT; + UserDefinedVirtuals: TPointerArray; + end; + +function GetRBPPtr: Pointer; +function IsDelphiClass(Address: Pointer): Boolean; +function GetPaxInfo(C: TClass): PPaxInfo; +function GetUnitName(C: TClass): String; +function IsPaxObject(X: TObject): Boolean; +function IsPaxClass(C: TClass): Boolean; +function GetHostParentClass(C: TClass): TClass; +function GetVArray(C: TClass): PPointerArray; + +function GetIntResultType(T1, T2: Integer): Integer; + +type + PVmtMethod = ^TVmtMethod; + PVmtMethodTable = ^TVmtMethodTable; + +{$IFDEF FPC} + TVmtMethodCount = Cardinal; + + TVmtMethod = packed record + MethName: PShortString; + MethAddr: Pointer; + end; + + TVmtMethodTable = packed record + Count: TVmtMethodCount; + MethList: array[0..300] of TVmtMethod; + end; + +{$ELSE} + {$IFDEF PAX64} + TVmtMethod = packed record + Size: Word; + Address: Pointer; + Name: ShortString; + // nameLen: Byte; + { nameChars[nameLen]: _AnsiChr } + end; + {$ELSE} + TVmtMethod = packed record + Size: Word; + Address: Pointer; + Name: ShortString; + end; + {$ENDIF} + + TVmtMethodCount = Word; + +{$IFDEF PAXARM} +const + MaxListSize = 1024 * SizeOf(Pointer); +type +{$ENDIF} + + TVmtMethodTable = packed record + Count: TVmtMethodCount; + Methods: array[0..MaxInt div 16] of Byte; + { Methods: array[1..Count] of TVmtMethod; } + end; + +{$ENDIF} + + PFieldClassTable = ^TFieldClassTable; + TFieldClassTable = packed record + Count: Smallint; +{$IFDEF FPC} + Classes: array [0..8191] of TClass; +{$ELSE} + Classes: array [0..8191] of ^TPersistentClass; +{$ENDIF} + end; + + PVmtField = ^TVmtField; + TVmtField = packed record + Offset: Cardinal; { Offset of field in the class data. } + ClassIndex: Word; { Index in the FieldClassTable. } + Name: ShortString; + end; + + PFieldTable = ^TVmtFieldTable; + + PVmtFieldTable = ^TVmtFieldTable; + TVmtFieldTable = packed record + Count: Word; +{$IFDEF ARC} + FieldClassTable: PFieldClassTable; +{$ELSE} + FieldClassTable: {$ifdef WIN32} PFieldClassTable {$else} Word {$endif}; +{$ENDIF} + Fields: packed array[0..MaxInt div 16] of Byte; + { Fields: packed array [1..Count] of TVmtField; } + end; + +function GetMethodSize(PMethod: PVmtMethod): Cardinal; +function GetMethodTable(AClass: TClass): PVmtMethodTable; +function GetFieldSize(PField: PVmtField): Cardinal; +function GetFieldTable(AClass: TClass): PVmtFieldTable; +function GetFieldClassTableSize(FieldClassTable: PFieldClassTable): Integer; +function CreateFieldClassTable(InitCount: SmallInt): PFieldClassTable; +procedure DestroyFieldClassTable(FieldClassTable: PFieldClassTable); +function CreateInterfaceTable(EntryCount: Integer): PInterfaceTable; +function AddEntryToInterfaceTable(P: PInterfaceTable; + var GUID: TGUID; + Address: Pointer; + Offset: Integer): PInterfaceEntry; +procedure DestroyInterfaceTable(P: PInterfaceTable); + + + +{$IFNDEF VARIANTS} +function StringToGUID(const S: string): TGUID; +function GUIDToString(const GUID: TGUID): string; +{$ENDIF} + +function LoadText(const FileName: String): String; + +function BinSearch(List: TIntegerList; const Key: Integer): Integer; +function GetVisibility(value: TClassVisibility): TMemberVisibility; +function ScalarValueToString(Address: Pointer; T: Integer): String; + +procedure RaiseNotImpl; +procedure RIE; +procedure DumpSEH2(I: Integer); +function GetPrevHandler(EstablisherFrame: PPaxExcFrame): Pointer; + +function BoolToStr(B: Boolean): String; +function NormR(const S: String; K: Integer): String; overload; +function NormR(I, K: Integer): String; overload; +function NormR(B: Boolean; K: Integer): String; overload; +function NormL(const S: String; K: Integer): String; overload; +function NormL(I, K: Integer): String; overload; +function NormL(B: Boolean; K: Integer): String; overload; + +function FindNextVirtualMethodAddress(C: TClass; PrevAddress: Pointer): Pointer; +function VirtualMethodIndex(AClass: TClass; A: Pointer): Integer; +function GetVirtualMethodCount(AClass: TClass): Integer; +function GetVirtualMethod(AClass: TClass; const Index: Integer): Pointer; +function GetVirtualMethodOffset(AClass: TClass; Address: Pointer): Integer; + +function VmtSelfPtrSlot(C: PVMT): PPointer; +function VmtIntfTableSlot(C: PVMT): PPointer; +function VmtAutoTableSlot(C: PVMT): PPointer; +function VmtInitTableSlot(C: PVMT): PPointer; +function VmtTypeInfoSlot(C: PVMT): PPointer; +function VmtFieldTableSlot(C: PVMT): PPointer; +function VmtMethodTableSlot(C: PVMT): PPointer; +function VmtDynamicTableSlot(C: PVMT): PPointer; +function VmtClassNameSlot(C: PVMT): PPointer; +function VmtInstanceSizeSlot(C: PVMT): PPointer; +function VmtParentSlot(C: PVMT): PPointer; +{$IFDEF UNIC} +function VmtEqualsSlot(C: PVMT): PPointer; +function VmtGetHashCodeSlot(C: PVMT): PPointer; +function VmtToStringSlot(C: PVMT): PPointer; +{$ENDIF} +function VmtSafeCallExceptionSlot(C: PVMT): PPointer; +function VmtAfterConstructionSlot(C: PVMT): PPointer; +function VmtBeforeDestructionSlot(C: PVMT): PPointer; +function VmtDispatchSlot(C: PVMT): PPointer; +function VmtDefaultHandlerSlot(C: PVMT): PPointer; +function VmtNewInstanceSlot(C: PVMT): PPointer; +function VmtFreeInstanceSlot(C: PVMT): PPointer; +function VmtDestroySlot(C: PVMT): PPointer; +{$IFDEF ARC} +function Vmt__ObjAddRefSlot(C: PVMT): PPointer; +function Vmt__ObjReleaseSlot(C: PVMT): PPointer; +{$ENDIF} + +function DupException(E: Exception): Exception; +function DupWorkException(E: Exception): Exception; +procedure DuplicateException(var Result: Exception; const E: Exception); +procedure DuplicateWorkException(var Result: Exception; const E: Exception); + +type + TPaxValue = record + case Byte of + typeEXTENDED: (VExtended: Extended; VType: Byte); + typeSINGLE: (VSingle: Single); + typeDOUBLE: (VDouble: Double); + typeCURRENCY: (VCurrency: Currency); + typeSET: (VSet: Integer); + typeENUM: (VEnum: Byte); + typePROC: (VProc: Pointer); + typeEVENT: (VEvent: TMethod); + typePOINTER: (VPointer: Pointer); + typeCLASS: (VObject: Pointer); + typeCLASSREF: (VClass: TClass); + typeBYTE: (VByte: Byte); + typeSMALLINT: (VSmallInt: SmallInt); + typeSHORTINT: (VShortInt: ShortInt); + typeWORD: (VWord: Word); + typeCARDINAL: (VCardinal: Cardinal); + typeINTEGER: (VInteger: Integer); + typeINT64: (VInt64: Int64); + typeUINT64: (VUInt64: UInt64); + typeBOOLEAN: (VBoolean: Boolean); + typeBYTEBOOL: (VByteBool: ByteBool); + typeWORDBOOL: (VWordBool: WordBool); + typeLONGBOOL: (VLongBool: LongBool); +{$IFNDEF PAXARM} + typeANSICHAR: (VAnsiChar: AnsiChar); + typeWIDESTRING: (VWideString: PWideString); + typeANSISTRING: (VAnsiString: PAnsiString); + typeSHORTSTRING: (VShortString: PShortString); +{$ENDIF} + typeWIDECHAR: (VWideChar: WideChar); + typeUNICSTRING: (VUnicString: PUnicString); + typeINTERFACE: (VInterface: Pointer); + typeVARIANT: (VVariant: PVariant); + typeOLEVARIANT: (VOleVariant: POleVariant); + typeARRAY: (VArray: Pointer); + typeRECORD: (VRecord: Pointer); + typeDYNARRAY: (VDynarray: Pointer); + end; + +function VariantToPaxValue(const V: Variant; FinTypeId: Integer): TPaxValue; +function AddressOfPaxValue(const P: TPaxValue): Pointer; +procedure DisposePaxValue(var P: TPaxValue); + +{$IFNDEF PAX64} +{$IFNDEF PAXARM_DEVICE} +procedure ProcessRet32(R_AX: Integer; //eax + R_DX: Integer; //edx + RetSize: Integer; //ecx + R_BP: Pointer); +{$ENDIF} +{$ENDIF} +procedure LoadDouble(P: Pointer); +procedure LoadSingle(P: Pointer); +procedure LoadExtended(P: Pointer); +procedure LoadCurrency(P: Pointer); +{$IFDEF PAX64} +procedure AssignDouble0(P: Pointer); +procedure AssignSingle0(P: Pointer); +procedure AssignExtended0(P: Pointer); +procedure AssignDouble1(P: Pointer); +procedure AssignSingle1(P: Pointer); +procedure AssignExtended1(P: Pointer); +procedure AssignDouble2(P: Pointer); +procedure AssignSingle2(P: Pointer); +procedure AssignExtended2(P: Pointer); +procedure AssignDouble3(P: Pointer); +procedure AssignSingle3(P: Pointer); +procedure AssignExtended3(P: Pointer); +procedure AssignCurrency(P: Pointer); +{$ENDIF} + +function GetAbstractMethodIndex(C: TClass; AbstractMethodCount: Integer; + i_Address: Pointer = nil): Integer; +function GetSystemVMTOffset(A: Pointer): Integer; +function GetAbstractMethodCount(C: TClass): Integer; + +procedure PShortStringFromString(Dest: PShortString; const Source: String); +function StringFromPShortString(S: PShortString): String; +function PTIName(P: PTypeInfo): String; + +{$IFDEF PAXARM} +function SLow(const S: string): Integer; +function SHigh(const S: string): Integer; +{$ELSE} +function SLow(const S: string): Integer; overload; +function SHigh(const S: string): Integer; overload; +{$IFDEF UNIC} +function SLow(const S: AnsiString): Integer; overload; +function SHigh(const S: AnsiString): Integer; overload; +{$ENDIF} +{$ENDIF} + +function SCopy(const S: String; Index, Length: Integer): String; +procedure SDelete(var S: String; Index, Length: Integer); +procedure SInsert(const Substr: String; var Dest: String; Index: Integer); + +function GetAddressGetCallerEIP: Pointer; assembler; + +function R1(sz: Integer): Integer; +function R2(sz: Integer): Integer; +function R3(sz: Integer): Integer; + +implementation + +function R1(sz: Integer): Integer; +begin + if sz = 0 then + result := 0 + else + begin + sz := sz - 4; + sz := sz div 16; + sz := sz + 1; + result := sz * 16; + end; +end; + +function R2(sz: Integer): Integer; +begin + sz := sz mod 16; + if sz = 0 then + result := 0 + else + result := 16 - sz; +end; + +function R3(sz: Integer): Integer; +var + I: Integer; +begin + if sz = 0 then + result := $0c + else + begin + sz := sz div 4; + result := $0c; + for I := 0 to sz - 1 do + if I mod 4 = 0 then + Inc(result, 16); + end; +end; + +{$IFDEF GE_DXE4} +function SLow(const S: string): Integer; +begin + Result := Low(S); +end; + +function SHigh(const S: string): Integer; +begin + Result := High(S); +end; + + + +{$IFNDEF PAXARM} +function SLow(const S: AnsiString): Integer; +begin + Result := Low(S); +end; + +function SHigh(const S: AnsiString): Integer; +begin + Result := High(S); +end; +{$ENDIF} + + + +{$ELSE} +function SLow(const S: string): Integer; +begin + Result := 1; +end; + +function SHigh(const S: string): Integer; +begin + Result := Length(S); +end; + +{$IFDEF UNIC} +function SLow(const S: AnsiString): Integer; +begin + Result := 1; +end; + +function SHigh(const S: AnsiString): Integer; +begin + Result := Length(S); +end; +{$ENDIF} + +{$ENDIF} + +function SCopy(const S: String; Index, Length: Integer): String; +begin +{$IFDEF SZERO} +// result := Copy(S, Index + 1, Length); + result := S.Substring(Index, Length); +{$ELSE} + result := Copy(S, Index, Length); +{$ENDIF} +end; + +procedure SDelete(var S: String; Index, Length: Integer); +begin +{$IFDEF SZERO} + S := S.Remove(Index, Length); +{$ELSE} + Delete(S, Index, Length); +{$ENDIF} +end; + +procedure SInsert(const Substr: String; var Dest: String; Index: Integer); +begin +{$IFDEF SZERO} + Dest := Dest.Insert(Index, Substr); +{$ELSE} + Insert(Substr, Dest, Index); +{$ENDIF} +end; + +{$IFDEF PAXARM} +{ +procedure PShortStringFromString(Dest: PShortString; const Source: String); +var + I: Cardinal; + B: array of Byte; + P: Pointer; +begin + SetLength(B, Length(Source) + 2); + UTF8Encode(Source, B); + Dec(B[0]); + P := @B[0]; + Move(P^, Dest^, Length(Source) + 1); +end; +} +procedure PShortStringFromString(Dest: PShortString; const Source: String); +var + L: Integer; + I: Byte; + C: Char; + B: SysUtils.TBytes; +begin + L := Length(Source); + if L > 255 then + raise Exception.Create('Strings longer than 255 characters cannot be converted'); + SetLength(B, L); + Dest^[0] := L; + B := TEncoding.Ansi.GetBytes(Source); + Move(B[0], Dest^[1], L); +end; + +{$ELSE} +procedure PShortStringFromString(Dest: PShortString; const Source: String); +begin + Dest^ := ShortString(Source); +end; +{$ENDIF} + +{$IFDEF PAXARM} +function StringFromPShortString2(S: PShortString): String; +var + fa: TTypeInfoFieldAccessor; +begin + fa.SetData(PByte(S)); + result := fa.ToString; +end; + +function StringFromPShortString(S: PShortString): String; +var + B: SysUtils.TBytes; + L: Byte; +begin + Result := ''; + L := S^[0]; + SetLength(B, L); + Move(S^[1], B[0], L); + Result := TEncoding.Ansi.GetString(B); +end; +{$ELSE} +function StringFromPShortString(S: PShortString): String; +begin + result := String(S^); +end; +{$ENDIF} + +function PTIName(P: PTypeInfo): String; +begin +{$IFDEF PAXARM} + result := P^.NameFld.ToString; +{$ELSE} + result := String(P^.Name); +{$ENDIF} +end; + +type + TDummyClass = class + procedure P; virtual; abstract; + end; + +function GetAbstractMethodAddress: Pointer; +begin + result := GetVArray(TDummyClass)^[0]; +end; + +function GetAbstractMethodCount(C: TClass): Integer; +var + Z, CurrA: Pointer; + P: PPointerArray; + I: Integer; +begin + result := 0; + Z := GetAbstractMethodAddress; + P := GetVArray(C); + for I:=0 to MaxVirtuals do + begin + CurrA := P^[I]; + if CurrA = Z then + Inc(result) + else if CurrA = nil then + Exit; + end; +end; + +function GetAbstractMethodIndex(C: TClass; AbstractMethodCount: Integer; + i_Address: Pointer = nil): Integer; +var + P: PPointerArray; + I, K: Integer; + CurrA: Pointer; + Z: Pointer; +begin + result := -1; + if i_Address = nil then + Z := GetAbstractMethodAddress + else + Z := i_Address; + P := GetVArray(C); + if C = TObject then + K := 0 + else + K := - GetAbstractMethodCount(C.ClassParent); + for I:=0 to MaxVirtuals do + begin + CurrA := P^[I]; + if CurrA = Z then + begin + Inc(K); + if K = AbstractMethodCount then + begin + result := I; + Exit; + end; + end + else if CurrA = nil then + Exit; + end; +end; + +{$IFDEF PAXARM} +function GetAddressGetCallerEIP: Pointer; +begin + result := nil; +end; +{$ELSE} +{$IFDEF MACOS} +function GetAddressGetCallerEIP: Pointer; assembler; +asm + lea eax, SysInit.@GetCallerEIP +end; +{$ELSE} +{$IFDEF PAX64} +function GetDummyCallerEIP: Pointer; assembler; +asm + mov rax, [rsp] +end; +function GetAddressGetCallerEIP: Pointer; assembler; +asm + lea rax, GetDummyCallerEIP +end; +{$ELSE} +function GetDummyCallerEIP: Pointer; assembler; +asm + mov eax, [esp] +end; +function GetAddressGetCallerEIP: Pointer; assembler; +asm + lea eax, GetDummyCallerEIP +end; +{$ENDIF} +{$ENDIF} +{$ENDIF} + +{$IFNDEF PAX64} //--------------------------------- + +{$IFDEF UNIX} +procedure ProcessRet32(R_AX: Integer; //eax + R_DX: Integer; //edx + RetSize: Integer; //ecx + R_BP: Pointer); +asm + mov esp, R_BP + pop ebp + + cmp ecx, 0 + jz @@L + + mov edx, dword ptr [esp] + + @@loop: + add esp, 4 + sub ecx, 4 + jnz @@loop + + mov dword ptr [esp], edx + +@@L: + + pop ecx + jmp ecx +end; +{$ENDIF} + + +{$IFDEF MACOS} + +{$IFNDEF PAXARM_DEVICE} +procedure ProcessRet32(R_AX: Integer; //eax + R_DX: Integer; //edx + RetSize: Integer; //ecx + R_BP: Pointer); +asm + mov esp, R_BP + pop ebp + + cmp ecx, 0 + jz @@L + + mov edx, dword ptr [esp] + + @@loop: + add esp, 4 + sub ecx, 4 + jnz @@loop + + mov dword ptr [esp], edx + +@@L: + + pop ecx + jmp ecx +end; +{$ENDIF} // MACOS +{$ENDIF} + +{$IFDEF MSWINDOWS} + +{$IFDEF FPC} +{$O-} +procedure ProcessRet32(R_AX: Integer; //eax + R_DX: Integer; //edx + RetSize: Integer; //ecx + R_BP: Pointer); +asm + mov edi, R_BP + + mov esp, edi + pop ebp + + cmp ecx, 0 + jz @@L + + mov esi, dword ptr [esp] + + @@loop: + pop edi + sub ecx, 4 + jnz @@loop + + mov dword ptr [esp], esi + +@@L: + + pop edi + jmp edi +end; +{$ELSE} +procedure ProcessRet32(R_AX: Integer; //eax + R_DX: Integer; //edx + RetSize: Integer; //ecx + R_BP: Pointer); +asm + mov ebx, R_BP + + mov esp, ebx + pop ebp + + cmp ecx, 0 + jz @@L + + mov esi, dword ptr [esp] + + @@loop: + pop ebx + sub ecx, 4 + jnz @@loop + + mov dword ptr [esp], esi + +@@L: + + pop ebx + jmp ebx +end; +{$ENDIF} +{$ENDIF} + +{$ENDIF} // NOT PAX64 ------------------------------ + +{$IFDEF PAX64} +procedure LoadDouble(P: Pointer); assembler; +asm + MOV RAX, P + MOVSD XMM0, QWORD PTR [RAX] +end; + +procedure LoadSingle(P: Pointer); assembler; +asm + MOV RAX, P + CVTSD2SS XMM0, QWORD PTR [RAX] +end; + +procedure LoadExtended(P: Pointer); assembler; +asm + MOV RAX, P + MOVSD XMM0, QWORD PTR [RAX] +end; + +procedure LoadCurrency(P: Pointer); assembler; +asm + Mov RAX, P + MOV RAX, [RAX] +end; + +procedure AssignDouble0(P: Pointer); assembler; +asm + MOV RAX, P + MOVSD QWORD PTR [RAX], XMM0 +end; + +procedure AssignSingle0(P: Pointer); assembler; +asm + MOV RAX, P + MOVSS DWORD PTR [RAX], XMM0 +end; + +procedure AssignExtended0(P: Pointer); assembler; +asm + MOV RAX, P + MOVSD QWORD PTR [RAX], XMM0 +end; + +procedure AssignDouble1(P: Pointer); assembler; +asm + MOV RAX, P + MOVSD QWORD PTR [RAX], XMM1 +end; + +procedure AssignSingle1(P: Pointer); assembler; +asm + MOV RAX, P + MOVSS DWORD PTR [RAX], XMM1 +end; + +procedure AssignExtended1(P: Pointer); assembler; +asm + MOV RAX, P + MOVSD QWORD PTR [RAX], XMM1 +end; + +procedure AssignDouble2(P: Pointer); assembler; +asm + MOV RAX, P + MOVSD QWORD PTR [RAX], XMM2 +end; + +procedure AssignSingle2(P: Pointer); assembler; +asm + MOV RAX, P + MOVSS DWORD PTR [RAX], XMM2 +end; + +procedure AssignExtended2(P: Pointer); assembler; +asm + MOV RAX, P + MOVSD QWORD PTR [RAX], XMM2 +end; + +procedure AssignDouble3(P: Pointer); assembler; +asm + MOV RAX, P + MOVSD QWORD PTR [RAX], XMM3 +end; + +procedure AssignSingle3(P: Pointer); assembler; +asm + MOV RAX, P + MOVSS DWORD PTR [RAX], XMM3 +end; + +procedure AssignExtended3(P: Pointer); assembler; +asm + MOV RAX, P + MOVSD QWORD PTR [RAX], XMM3 +end; + +procedure AssignCurrency(P: Pointer); assembler; +asm + Mov RAX, P + MOV [RAX], RAX +end; + +{$ELSE} + +{$IFDEF PAXARM_DEVICE} +procedure LoadDouble(P: Pointer); +begin + RIE; +end; + +procedure LoadSingle(P: Pointer); +begin + RIE; +end; + +procedure LoadExtended(P: Pointer); +begin + RIE; +end; + +procedure LoadCurrency(P: Pointer); +begin + RIE; +end; +{$ELSE} +procedure LoadDouble(P: Pointer); assembler; +asm + Mov EAX, P + FLD QWORD PTR [EAX] +end; + +procedure LoadSingle(P: Pointer); assembler; +asm + Mov EAX, P + FLD DWORD PTR [EAX] +end; + +procedure LoadExtended(P: Pointer); assembler; +asm + Mov EAX, P + FLD TBYTE PTR [EAX] +end; + +procedure LoadCurrency(P: Pointer); assembler; +asm + Mov EAX, P + FILD QWORD PTR [EAX] +end; +{$ENDIF} +{$ENDIF} + +function VariantToPaxValue(const V: Variant; FinTypeId: Integer): TPaxValue; +begin + result.VType := FinTypeId; + case FinTypeId of + typeEXTENDED: result.VExtended := V; + typeSINGLE: result.VSingle := V; + typeDOUBLE: result.VDouble := V; + typeCURRENCY: result.VCurrency := V; + typeSET: result.VSet := TVarData(V).VInteger; + typeENUM: result.VEnum := TVarData(V).VInteger; + typePROC: result.VProc := Pointer(TVarData(V).VInteger); +// typeEVENT: (VEvent: TMethod); + typePOINTER: result.VPointer := Pointer(TVarData(V).VInteger); + typeCLASS: result.VObject := TObject(TVarData(V).VInteger); + typeCLASSREF: result.VClass := TClass(Pointer(TVarData(V).VInteger)); + typeBYTE: result.VByte := V; + typeSMALLINT: result.VSmallInt := V; + typeSHORTINT: result.VShortInt := V; + typeWORD: result.VWord := V; + typeCARDINAL: result.VCardinal := V; + typeINTEGER: result.VInteger := V; +{$IFDEF VARIANTS} + typeINT64: result.VInt64 := V; + typeUINT64: result.VUInt64 := V; +{$ELSE} + typeINT64: result.VInt64 := Integer(V); + typeUINT64: result.VUInt64 := Cardinal(V); +{$ENDIF} + typeBOOLEAN: result.VBoolean := V; + typeBYTEBOOL: result.VByteBool := ByteBool(TVarData(V).VInteger); + typeWORDBOOL: result.VWordBool := V; + typeLONGBOOL: result.VLongBool := V; +{$IFNDEF PAXARM} + typeANSICHAR: result.VAnsiChar := AnsiChar(TVarData(V).VInteger); + typeSHORTSTRING: result.VShortString^ := ShortString(V); + typeANSISTRING: + begin + New(result.VAnsiString); + result.VAnsiString^ := AnsiString(V); + end; + typeWIDESTRING: + begin + New(result.VWideString); + result.VWideString^ := V; + end; +{$ENDIF} + typeWIDECHAR: result.VWideChar := WideChar(TVarData(V).VInteger); + typeUNICSTRING: + begin + New(result.VUnicString); + result.VUnicString^ := V; + end; + typeINTERFACE: Pointer(result.VInterface) := Pointer(TVarData(V).VInteger); + typeVARIANT: + begin + New(result.VVariant); + result.VVariant^ := V; + end; + typeOLEVARIANT: + begin + New(result.VOleVariant); + result.VOleVariant^ := V; + end; + typeARRAY: result.VArray := Pointer(TVarData(V).VInteger); + typeRECORD: result.VRecord := Pointer(TVarData(V).VInteger); + typeDYNARRAY: result.VDynarray := Pointer(TVarData(V).VInteger); + end; +end; + +function AddressOfPaxValue(const P: TPaxValue): Pointer; +begin + result := nil; + case P.VType of + typeEXTENDED: result := @P.VExtended; + typeSINGLE: result := @P.VSingle; + typeDOUBLE: result := @P.VDouble; + typeCURRENCY: result := @P.VCurrency; + typeSET: result := @P.VSet; + typeENUM: result := @P.VEnum; + typePROC: result := @P.VProc; + typeEVENT: result := @P.VEvent; + typePOINTER: result := @P.VPointer; + typeCLASS: result := @P.VObject; + typeCLASSREF: result := @P.VClass; + typeBYTE: result := @P.VByte; + typeSMALLINT: result := @P.VSmallInt; + typeSHORTINT: result := @P.VShortInt; + typeWORD: result := @P.VWord; + typeCARDINAL: result := @P.VCardinal; + typeINTEGER: result := @P.VInteger; + typeINT64: result := @P.VInt64; + typeUINT64: result := @P.VUInt64; + typeBOOLEAN: result := @P.VBoolean; + typeBYTEBOOL: result := @P.VByteBool; + typeWORDBOOL: result := @P.VWordBool; + typeLONGBOOL: result := @P.VLongBool; +{$IFNDEF PAXARM} + typeANSICHAR: result := @P.VAnsiChar; + typeANSISTRING: result := P.VAnsiString; + typeWIDESTRING: result := P.VWideString; + typeSHORTSTRING: result := P.VShortString; +{$ENDIF} + typeWIDECHAR: result := @P.VWideChar; + typeUNICSTRING: result := P.VUnicString; + typeINTERFACE: result := @P.VInterface; + typeVARIANT: result := P.VVariant; + typeOLEVARIANT: result := P.VOleVariant; + typeARRAY: result := P.VArray; + typeRECORD: result := P.VRecord; + typeDYNARRAY: result := @P.VDynarray; + end; +end; + +procedure DisposePaxValue(var P: TPaxValue); +begin + case P.VType of + typeUNICSTRING: + if P.VUnicString <> nil then + Dispose(P.VUnicString); +{$IFNDEF PAXARM} + typeSHORTSTRING: + if P.VShortString <> nil then + Dispose(P.VShortString); + typeANSISTRING: + if P.VAnsiString <> nil then + Dispose(P.VAnsiString); + typeWIDESTRING: + if P.VWideString <> nil then + Dispose(P.VWideString); +{$ENDIF} + typeVARIANT: + if P.VVariant <> nil then + Dispose(P.VVariant); + typeOLEVARIANT: + if P.VOleVariant <> nil then + Dispose(P.VOleVariant); + end; +end; + +function DupException(E: Exception): Exception; +var + C: TExceptionClass; +begin + Pointer(C) := Pointer(E.ClassType); + result := C.Create(E.Message); + if E is PaxExitException then + (result as PaxExitException).Mode := (E as PaxExitException).Mode; +end; + +function DupWorkException(E: Exception): Exception; +begin + result := TWorkException.Create(E.Message); +end; + +procedure DuplicateException(var Result: Exception; const E: Exception); +begin + if Assigned(result) then + FreeAndNil(result); + result := DupException(E); +end; + +procedure DuplicateWorkException(var Result: Exception; const E: Exception); +begin + if Assigned(result) then + FreeAndNil(result); + result := DupWorkException(E); +end; + +function ClassFromPVMT(V: PVMT): Pointer; +begin + result := Pointer(IntPax(V) + SizeOf(TVMT)); +end; + +function ClassOffset(V: PVMT): IntPax; +begin +{$IFDEF FPC} + result := IntPax(V); +{$ELSE} + result := IntPax(V) + SizeOf(TVMT); +{$ENDIF} +end; + +function VmtSelfPtrSlot(C: PVMT): PPointer; +begin +{$IFDEF FPC} + result := nil; +{$ELSE} + result := Pointer(ClassOffset(C) + vmtSelfPtr); +{$ENDIF} +end; + +function VmtIntfTableSlot(C: PVMT): PPointer; +begin + result := Pointer(ClassOffset(C) + vmtIntfTable); +end; + +function VmtAutoTableSlot(C: PVMT): PPointer; +begin + result := Pointer(ClassOffset(C) + vmtAutoTable); +end; + +function VmtInitTableSlot(C: PVMT): PPointer; +begin + result := Pointer(ClassOffset(C) + vmtInitTable); +end; + +function VmtTypeInfoSlot(C: PVMT): PPointer; +begin + result := Pointer(ClassOffset(C) + vmtTypeInfo); +end; + +function VmtFieldTableSlot(C: PVMT): PPointer; +begin + result := Pointer(ClassOffset(C) + vmtFieldTable); +end; + +function VmtMethodTableSlot(C: PVMT): PPointer; +begin + result := Pointer(ClassOffset(C) + vmtMethodTable); +end; + +function VmtDynamicTableSlot(C: PVMT): PPointer; +begin + result := Pointer(ClassOffset(C) + vmtDynamicTable); +end; + +function VmtClassNameSlot(C: PVMT): PPointer; +begin + result := Pointer(ClassOffset(C) + vmtClassName); +end; + +function VmtInstanceSizeSlot(C: PVMT): PPointer; +begin + result := Pointer(ClassOffset(C) + vmtInstanceSize); +end; + +function VmtParentSlot(C: PVMT): PPointer; +begin + result := Pointer(ClassOffset(C) + vmtParent); +end; + +{$IFDEF UNIC} + +{$IFDEF PAXARM} +function VmtEqualsSlot(C: PVMT): PPointer; +begin + result := Pointer(ClassOffset(C) + + GetSystemVMTOffset(@TObject.Equals)); +end; + +function VmtGetHashCodeSlot(C: PVMT): PPointer; +begin + result := Pointer(ClassOffset(C) + + GetSystemVMTOffset(@TObject.GetHashCode)); +end; + +function VmtToStringSlot(C: PVMT): PPointer; +begin + result := Pointer(ClassOffset(C) + + GetSystemVMTOffset(@TObject.ToString)); +end; + +{$ELSE} +function GetSystemVMTOffset_Equals: IntPax; assembler; +asm +{$IFDEF PAX64} + mov rax, VMTOFFSET TObject.Equals +{$ELSE} + mov eax, VMTOFFSET TObject.Equals +{$ENDIF} +end; + +function VmtEqualsSlot(C: PVMT): PPointer; +begin + result := Pointer(ClassOffset(C) + + GetSystemVMTOffset_Equals); +end; + +function GetSystemVMTOffset_GetHashCode: IntPax; assembler; +asm +{$IFDEF PAX64} + mov rax, VMTOFFSET TObject.GetHashCode +{$ELSE} + mov eax, VMTOFFSET TObject.GetHashCode +{$ENDIF} +end; + +function VmtGetHashCodeSlot(C: PVMT): PPointer; +begin + result := Pointer(ClassOffset(C) + + GetSystemVMTOffset_GetHashCode); +end; + +function GetSystemVMTOffset_ToString: IntPax; assembler; +asm +{$IFDEF PAX64} + mov rax, VMTOFFSET TObject.ToString +{$ELSE} + mov eax, VMTOFFSET TObject.ToString +{$ENDIF} +end; + +function VmtToStringSlot(C: PVMT): PPointer; +begin + result := Pointer(ClassOffset(C) + + GetSystemVMTOffset_ToString); +end; +{$ENDIF} // NOT PAXARM +{$ENDIF} // UNIC + +{$IFDEF PAXARM} + +function VmtSafeCallExceptionSlot(C: PVMT): PPointer; +begin + result := Pointer(ClassOffset(C) + + GetSystemVMTOffset(@TObject.SafeCallException)); +end; + +function VmtAfterConstructionSlot(C: PVMT): PPointer; +begin + result := Pointer(ClassOffset(C) + + GetSystemVMTOffset(@TObject.AfterConstruction)); +end; + +function VmtBeforeDestructionSlot(C: PVMT): PPointer; +begin + result := Pointer(ClassOffset(C) + + GetSystemVMTOffset(@TObject.BeforeDestruction)); +end; + +function VmtDispatchSlot(C: PVMT): PPointer; +begin + result := Pointer(ClassOffset(C) + + GetSystemVMTOffset(@TObject.Dispatch)); +end; + +function VmtDefaultHandlerSlot(C: PVMT): PPointer; +begin + result := Pointer(ClassOffset(C) + + GetSystemVMTOffset(@TObject.DefaultHandler)); +end; + +function VmtNewInstanceSlot(C: PVMT): PPointer; +begin + result := Pointer(ClassOffset(C) + + GetSystemVMTOffset(@TObject.NewInstance)); +end; + +function VmtFreeInstanceSlot(C: PVMT): PPointer; +begin + result := Pointer(ClassOffset(C) + + GetSystemVMTOffset(@TObject.FreeInstance)); +end; + +{$IFDEF ARC} +function Vmt__ObjAddRefSlot(C: PVMT): PPointer; +begin + result := Pointer(ClassOffset(C) + + GetSystemVMTOffset(@TObject.__ObjAddRef)); +end; + +function Vmt__ObjReleaseSlot(C: PVMT): PPointer; +begin + result := Pointer(ClassOffset(C) + + GetSystemVMTOffset(@TObject.__ObjRelease)); +end; +{$ENDIF} + +type + TMyObject = class(TObject); + +function VmtDestroySlot(C: PVMT): PPointer; +begin + result := Pointer(ClassOffset(C) + + GetSystemVMTOffset(@TMyObject.Destroy)); +end; + +{$ELSE} + +function GetSystemVMTOffset_SafeCallException: IntPax; assembler; +asm +{$IFDEF PAX64} + mov rax, VMTOFFSET TObject.SafeCallException +{$ELSE} + {$IFDEF VARIANTS} + mov eax, VMTOFFSET TObject.SafeCallException + {$ELSE} + mov eax, vmtSafeCallException + {$ENDIF} +{$ENDIF} +end; + +function VmtSafeCallExceptionSlot(C: PVMT): PPointer; +begin + result := Pointer(ClassOffset(C) + + GetSystemVMTOffset_SafeCallException); +end; + +function GetSystemVMTOffset_AfterConstruction: IntPax; assembler; +asm +{$IFDEF PAX64} + mov rax, VMTOFFSET TObject.AfterConstruction +{$ELSE} + {$IFDEF VARIANTS} + mov eax, VMTOFFSET TObject.AfterConstruction + {$ELSE} + mov eax, vmtAfterConstruction + {$ENDIF} +{$ENDIF} +end; + +function VmtAfterConstructionSlot(C: PVMT): PPointer; +begin + result := Pointer(ClassOffset(C) + + GetSystemVMTOffset_AfterConstruction); +end; + +function GetSystemVMTOffset_BeforeDestruction: IntPax; assembler; +asm +{$IFDEF PAX64} + mov rax, VMTOFFSET TObject.BeforeDestruction +{$ELSE} + {$IFDEF VARIANTS} + + mov eax, VMTOFFSET TObject.BeforeDestruction + {$ELSE} + mov eax, vmtBeforeDestruction + {$ENDIF} +{$ENDIF} +end; + +function VmtBeforeDestructionSlot(C: PVMT): PPointer; +begin + result := Pointer(ClassOffset(C) + + GetSystemVMTOffset_BeforeDestruction); +end; + + +{$IFDEF LINUX} +function VmtDispatchSlot(C: PVMT): PPointer; +begin + result := nil; //Pointer(ClassOffset(C) + GetSystemVMTOffset(@TObject.Dispatch)); +end; +{$ELSE} +function GetSystemVMTOffset_Dispatch: IntPax; assembler; +asm +{$IFDEF PAX64} + mov rax, VMTOFFSET TObject.Dispatch +{$ELSE} + {$IFDEF VARIANTS} + mov eax, VMTOFFSET TObject.Dispatch + {$ELSE} + mov eax, vmtDispatch + {$ENDIF} +{$ENDIF} +end; + +function VmtDispatchSlot(C: PVMT): PPointer; +begin + result := Pointer(ClassOffset(C) + + GetSystemVMTOffset_Dispatch); +end; + +{$ENDIF} + + +function GetSystemVMTOffset_DefaultHandler: IntPax; assembler; +asm +{$IFDEF PAX64} + mov rax, VMTOFFSET TObject.DefaultHandler +{$ELSE} + {$IFDEF VARIANTS} + mov eax, VMTOFFSET TObject.DefaultHandler + {$ELSE} + mov eax, vmtDefaultHandler + {$ENDIF} +{$ENDIF} +end; + +function VmtDefaultHandlerSlot(C: PVMT): PPointer; +begin + result := Pointer(ClassOffset(C) + + GetSystemVMTOffset_DefaultHandler); +end; + +function GetSystemVMTOffset_NewInstance: IntPax; assembler; +asm +{$IFDEF PAX64} + mov rax, VMTOFFSET TObject.NewInstance +{$ELSE} + {$IFDEF VARIANTS} + mov eax, VMTOFFSET TObject.NewInstance + {$ELSE} + mov eax, vmtNewInstance + {$ENDIF} +{$ENDIF} +end; + +function VmtNewInstanceSlot(C: PVMT): PPointer; +begin + result := Pointer(ClassOffset(C) + + GetSystemVMTOffset_NewInstance); +end; + +function GetSystemVMTOffset_FreeInstance: IntPax; assembler; +asm +{$IFDEF PAX64} + mov rax, VMTOFFSET TObject.FreeInstance +{$ELSE} + {$IFDEF VARIANTS} + mov eax, VMTOFFSET TObject.FreeInstance + {$ELSE} + mov eax, vmtFreeInstance + {$ENDIF} +{$ENDIF} +end; + +function VmtFreeInstanceSlot(C: PVMT): PPointer; +begin + result := Pointer(ClassOffset(C) + + GetSystemVMTOffset_FreeInstance); +end; + +function GetSystemVMTOffset_Destroy: IntPax; assembler; +asm +{$IFDEF PAX64} + mov rax, VMTOFFSET TObject.Destroy +{$ELSE} + {$IFDEF VARIANTS} + mov eax, VMTOFFSET TObject.Destroy + {$ELSE} + mov eax, vmtDestroy + {$ENDIF} +{$ENDIF} +end; + +function VmtDestroySlot(C: PVMT): PPointer; +begin + result := Pointer(ClassOffset(C) + + GetSystemVMTOffset_Destroy); +end; +{$ENDIF} // NOT PAXARM + +function GetSystemVMTOffset(A: Pointer): Integer; +var + P: Pointer; +begin + P := Pointer(TObject); + Result := 0; + repeat + if Pointer(P^) = A then + Exit + else + begin + P := ShiftPointer(P, - SizeOf(Pointer)); + Dec(Result, SizeOf(Pointer)); + end; + until False; +end; + +function FindNextVirtualMethodAddress(C: TClass; PrevAddress: Pointer): Pointer; +var + MethodIndex: Integer; + P: PPointerArray; +begin + P := GetVArray(C); + MethodIndex := VirtualMethodIndex(C, PrevAddress); + if MethodIndex = -1 then + result := nil + else + result := P^[MethodIndex + 1]; +end; + +function VirtualMethodIndex(AClass: TClass; A: Pointer): Integer; +const + VMTPackageJump : word = $25FF; +var + I: Integer; + CurrA: Pointer; + P: PPointerArray; +begin + result := -1; + if A = nil then + Exit; + + P := GetVArray(AClass); + + if {ModuleIsPackage and} (A <> nil) and (PWord (A)^ = VMTPackageJump) + then A := PPointer (PPointer (Integer (A) + sizeof (VMTPackageJump))^)^; + + for I:=0 to MaxVirtuals do + begin + CurrA := P^[I]; + if CurrA = A then + begin + result := I; + Exit; + end + else if CurrA = nil then + Exit; + end; +end; + +function GetVirtualMethodCount(AClass: TClass): Integer; +var + P: PPointerArray; + I: Integer; +begin + P := GetVArray(AClass); + result := 0; + for I:=0 to MaxVirtuals do + if P^[I] <> nil then + Inc(result) + else + break; +end; + +function GetVirtualMethod(AClass: TClass; const Index: Integer): Pointer; +var + P: Pointer; +begin + P := GetVArray(AClass); + Result := PPointer(Integer(P) + Index * SizeOf(Pointer))^; +end; + +function GetVirtualMethodOffset(AClass: TClass; Address: Pointer): Integer; +var + I: Integer; + P: Pointer; +begin + for I:=0 to GetVirtualMethodCount(AClass) - 1 do + begin + P := GetVirtualMethod(AClass, I); + if P = Address then + begin + result := I * 4; + Exit; + end; + end; + result := -1; +end; + + +function BoolToStr(B: Boolean): String; +begin + if B then result := 'true' else result := 'false'; +end; + +function NormR(const S: String; K: Integer): String; overload; +begin + if Length(S) > K then + result := SCopy(S, SLow(S), K) + else + begin + result := S; + while Length(result) < K do + result := result + ' '; + end; +end; + +function NormR(I, K: Integer): String; overload; +begin + result := NormR(IntToStr(I), K); +end; + +function NormR(B: Boolean; K: Integer): String; overload; +begin + result := NormR(BoolToStr(B), K); +end; + +function NormL(const S: String; K: Integer): String; overload; +begin + if Length(S) > K then + result := SCopy(S, SLow(S), K) + else + begin + result := S; + while Length(result) < K do + result := ' ' + result; + end; +end; + +function NormL(I, K: Integer): String; overload; +begin + result := NormL(IntToStr(I), K); +end; + +function NormL(B: Boolean; K: Integer): String; overload; +begin + result := NormL(BoolToStr(B), K); +end; + +{$IFDEF PAXARM} +procedure DumpSEH2(I: Integer); +begin + RaiseNotImpl; +end; +function GetPrevHandler(EstablisherFrame: PPaxExcFrame): Pointer; +begin + result := nil; + RaiseNotImpl; +end; +{$ELSE} + +{$IFDEF PAX64} +procedure DumpSEH2(I: Integer); +begin + RaiseNotImpl; +end; +function GetPrevHandler(EstablisherFrame: PPaxExcFrame): Pointer; +begin + result := nil; + RaiseNotImpl; +end; +{$ELSE} +function GetPrevHandler(EstablisherFrame: PPaxExcFrame): Pointer; +var + P: PExcFrame; +begin + result := nil; + asm + mov eax, fs:[0] + mov P, eax + end; + repeat + if Integer(P) = Integer(EstablisherFrame) then + Exit + else + begin + result := P.desc; + P := P.next; + end; + until false; +end; + +procedure DumpSEH2(I: Integer); +var + P: PPaxExcFrame; + S: String; + L: TStringList; + + procedure More; + begin + P := P.next; + S := Format('%x', [Integer(P.desc)]) + ' ' + Format('%x', [Integer(P.hEBP)]); + if PAX_SEH = P^.Magic then + S := S + ' ' + 'PAX'; + + L.Add(S); + end; +begin + L := TStringList.Create; + asm + mov eax, fs:[0] + mov P, eax + end; + S := Format('%x', [Integer(P.desc)]); + L.Add(S); + + More; + More; + More; + More; + More; + More; + More; + + L.SaveToFile('seh' + IntToStr(I) + '.txt'); + FreeAndNil(L); +end; +{$ENDIF} +{$ENDIF} + +function ScalarValueToString(Address: Pointer; T: Integer): String; +begin + result := ''; + case T of + typeBYTE: result := IntToStr(Byte(Address^)); + typeSMALLINT: result := IntToStr(SmallInt(Address^)); + typeSHORTINT: result := IntToStr(ShortInt(Address^)); + typeWORD: result := IntToStr(Word(Address^)); + typeCARDINAL: result := IntToStr(Cardinal(Address^)); + typeINTEGER: result := IntToStr(Integer(Address^)); +{$IFNDEF PAXARM} + typeANSICHAR: result := '' + AnsiChar(Address^) + ''; + typeSHORTSTRING: result := String('' + ShortString(Address^) + ''); + typeANSISTRING: result := String('' + AnsiString(Address^) + ''); + typeWIDESTRING: result := '' + WideString(Address^) + ''; +{$ENDIF} + typeWIDECHAR: result := '' + WideChar(Address^) + ''; + + typeBOOLEAN: if Boolean(Address^) then + result := 'true' else result := 'false'; + typeBYTEBOOL: if ByteBool(Address^) then + result := 'true' else result := 'false'; + typeWORDBOOL: if WordBool(Address^) then + result := 'true' else result := 'false'; + typeLONGBOOL: if LongBool(Address^) then + result := 'true' else result := 'false'; + + typeSINGLE: result := FloatToStr(Single(Address^)); + typeDOUBLE: result := FloatToStr(Double(Address^)); + typeEXTENDED: result := FloatToStr(Extended(Address^)); + typeCURRENCY: result := FloatToStr(Currency(Address^)); + + typeUNICSTRING: result := '' + UnicString(Address^) + ''; + + typePOINTER: result := Format('%x', [Cardinal(Address^)]); + + typeVARIANT: result := VarToStr(Variant(Address^)); + typeOLEVARIANT: result := VarToStr(OleVariant(Address^)); + end; +end; + +function GetDmtFromClass(AClass: TClass): PDmtTable; +begin + result := PDmtTable(ShiftPointer(Pointer(AClass), vmtDynamicTable)^); +end; + +function GetDynamicMethodIndex(AClass: TClass; I: integer): integer; +var + Dmt: PDmtTable; +begin + Dmt := GetDmtFromClass(AClass); + if Assigned(Dmt) and (I < Dmt.Count) then + Result := Dmt.IndexList[I] + else + Result := -1; +end; + +procedure SetDynamicMethodIndex(AClass: TClass; I: Integer; value: SmallInt); +var + Dmt: PDmtTable; +begin + Dmt := GetDmtFromClass(AClass); + if Assigned(Dmt) and (I < Dmt.Count) then + Dmt.IndexList[I] := value; +end; + +function GetDynamicMethodIndexByAddress(AClass: TClass; Address: Pointer): Integer; +var + Dmt: PDmtTable; + DmtMethodList: PDmtMethodList; + I: Integer; +begin + result := 0; + Dmt := GetDmtFromClass(AClass); + if Assigned(Dmt) then + begin + DmtMethodList := @Dmt^.IndexList[Dmt^.Count]; + for I := 0 to Dmt^.Count - 1 do + if DmtMethodList[I] = Address then + begin + result := Dmt^.IndexList[I]; + Exit; + end; + end; +end; + +function GetDynamicMethodAddress(AClass: TClass; I: integer): Pointer; +var + Dmt: PDmtTable; + DmtMethodList: PDmtMethodList; +begin + Dmt := GetDmtFromClass(AClass); + if Assigned(Dmt) and (I < Dmt.Count) then + begin + DmtMethodList := @Dmt.IndexList[Dmt.Count]; + Result := DmtMethodList[I]; + end + else + Result := nil; +end; + +procedure SetDynamicMethodAddress(AClass: TClass; I: Integer; value: Pointer); +var + Dmt: PDmtTable; + DmtMethodList: PDmtMethodList; +begin + Dmt := GetDmtFromClass(AClass); + if Assigned(Dmt) and (I < Dmt.Count) then + begin + DmtMethodList := @Dmt.IndexList[Dmt.Count]; + DmtMethodList[I] := value; + end; +end; + +function BinSearch(List: TIntegerList; const Key: Integer): Integer; +var + First: Integer; + Last: Integer; + Pivot: Integer; + Found: Boolean; +begin + First := 0; + Last := List.Count - 1; + Found := False; + Result := -1; + + while (First <= Last) and (not Found) do + begin + Pivot := (First + Last) div 2; + if List[Pivot] = Key then + begin + Found := True; + Result := Pivot; + end + else if List[Pivot] > Key then + Last := Pivot - 1 + else + First := Pivot + 1; + end; +end; + +{$IFNDEF VARIANTS} +function StringToGUID(const S: string): TGUID; + + procedure InvalidGUID; + begin + raise Exception.Create(errSyntaxError); + end; + + function HexChar(c: Char): Byte; + begin + case c of + '0'..'9': Result := Byte(c) - Byte('0'); + 'a'..'f': Result := (Byte(c) - Byte('a')) + 10; + 'A'..'F': Result := (Byte(c) - Byte('A')) + 10; + else + InvalidGUID; + Result := 0; + end; + end; + + function HexByte(p: PChar): Char; + begin + Result := Char((HexChar(p[0]) shl 4) + HexChar(p[1])); + end; + +var + i: Integer; + src, dest: PChar; +begin + if ((Length(S) <> 38) or (s[1] <> '{')) then InvalidGUID; + dest := @Result; + src := PChar(s); + Inc(src); + for i := 0 to 3 do + dest[i] := HexByte(src+(3-i)*2); + Inc(src, 8); + Inc(dest, 4); + if src[0] <> '-' then InvalidGUID; + Inc(src); + for i := 0 to 1 do + begin + dest^ := HexByte(src+2); + Inc(dest); + dest^ := HexByte(src); + Inc(dest); + Inc(src, 4); + if src[0] <> '-' then InvalidGUID; + inc(src); + end; + dest^ := HexByte(src); + Inc(dest); + Inc(src, 2); + dest^ := HexByte(src); + Inc(dest); + Inc(src, 2); + if src[0] <> '-' then InvalidGUID; + Inc(src); + for i := 0 to 5 do + begin + dest^ := HexByte(src); + Inc(dest); + Inc(src, 2); + end; +end; + +function GUIDToString(const GUID: TGUID): string; +begin + SetLength(Result, 38); + StrLFmt(PChar(Result), 38,'{%.8x-%.4x-%.4x-%.2x%.2x-%.2x%.2x%.2x%.2x%.2x%.2x}', // do not localize + [GUID.D1, GUID.D2, GUID.D3, GUID.D4[0], GUID.D4[1], GUID.D4[2], GUID.D4[3], + GUID.D4[4], GUID.D4[5], GUID.D4[6], GUID.D4[7]]); +end; +{$ENDIF} + +function CreateFieldClassTable(InitCount: SmallInt): PFieldClassTable; +var + SZ: Integer; +begin + SZ := SizeOf(SmallInt) + InitCount * SizeOf(Pointer); + result := AllocMem(SZ); + result^.Count := InitCount; +end; + +procedure DestroyFieldClassTable(FieldClassTable: PFieldClassTable); +var + SZ: Integer; +begin + SZ := GetFieldClassTableSize(FieldClassTable); + FreeMem(FieldClassTable, SZ); +end; + +function GetFieldClassTableSize(FieldClassTable: PFieldClassTable): Integer; +begin + result := SizeOf(FieldClassTable^.Count) + + FieldClassTable^.Count * SizeOf(Pointer); +end; + +{$IFDEF PAXARM} +function GetFieldTable(AClass: TClass): PVmtFieldTable; +begin + result := Pointer(ShiftPointer(Pointer(AClass), vmtFieldTable)^); +end; + +function GetMethodTable(AClass: TClass): PVmtMethodTable; +begin + result := Pointer(ShiftPointer(Pointer(AClass), vmtMethodTable)^); +end; + +{$ELSE} + +{$IFDEF PAX64} +function GetFieldTable(AClass: TClass): PVmtFieldTable; assembler; +asm + MOV RAX, [RAX].vmtFieldTable +end; + +function GetMethodTable(AClass: TClass): PVmtMethodTable; assembler; +asm + MOV RAX, [RAX].vmtMethodTable +end; +{$ELSE} +function GetFieldTable(AClass: TClass): PVmtFieldTable; assembler; +asm + MOV EAX, [EAX].vmtFieldTable +end; + +function GetMethodTable(AClass: TClass): PVmtMethodTable; assembler; +asm + MOV EAX, [EAX].vmtMethodTable +end; +{$ENDIF} +{$ENDIF} + + +function GetMethodSize(PMethod: PVmtMethod): Cardinal; +begin +{$IFDEF FPC} + result := SizeOf(TVmtMethod); +{$ELSE} + {$IFDEF PAX64} + Result := PMethod^.Size; + {$ELSE} + {$ifdef WIN32} + Result := PMethod^.Size; + {$else} + Result := PMethod^.Size; +// Result := SizeOf(Pointer) + Length(PMethod^.Name) + 1; + {$endif} + {$ENDIF} +{$ENDIF} +end; + +function CreateInterfaceTable(EntryCount: Integer): PInterfaceTable; +var + SZ: Integer; +begin + SZ := SizeOf(Integer) + EntryCount * SizeOf(TInterfaceEntry); + result := AllocMem(SZ); +end; + +function AddEntryToInterfaceTable(P: PInterfaceTable; + var GUID: TGUID; + Address: Pointer; + Offset: Integer): PInterfaceEntry; +begin + with P^.Entries[P^.EntryCount] do + begin +{$IFDEF FPC} + IID := @GUID; +{$ELSE} + IID := GUID; +{$ENDIF} + VTable := Address; + IOffset := Offset; + end; + result := @ P^.Entries[P^.EntryCount]; + Inc(P^.EntryCount); +end; + +procedure DestroyInterfaceTable(P: PInterfaceTable); +var + SZ: Integer; +begin + SZ := SizeOf(Integer) + P^.EntryCount * SizeOf(TInterfaceEntry); + FreeMem(P, SZ); +end; + +function GetFieldSize(PField: PVmtField): Cardinal; +begin + Result := SizeOf(PField^.Offset) + SizeOf(PField^.ClassIndex) + +{$IFDEF ARC} + PField^.Name[0] + 1; +{$ELSE} + Length(PField^.Name) + 1; +{$ENDIF} +end; + +function IsDynDestr(OP: Integer): Boolean; +begin + result := DynDestrList.IndexOf(OP) <> -1; +end; + +function GetVArray(C: TClass): PPointerArray; +begin + result := PPointerArray(C); + {$IFDEF FPC} + result := ShiftPointer(result, FPC_VIRTUAL_OFFSET); + {$ENDIF} +end; + +{$IFDEF PAXARM} +function IsDelphiClass(Address: Pointer): Boolean; +begin + result := Address = Pointer(ShiftPointer(Address, vmtSelfPtr)^); +end; +{$ELSE} + +{$IFDEF FPC} +function IsDelphiClass(Address: Pointer): Boolean; +begin + result := not NativeAddress(Pointer(Address^)); // instance size for class +end; +{$ELSE} +function IsDelphiClass(Address: Pointer): Boolean; assembler; +asm + CMP Address, Address.vmtSelfPtr + JNZ @False + MOV Result, True + JMP @Exit +@False: + MOV Result, False +@Exit: +end; +{$ENDIF} +{$ENDIF} + +{$IFDEF PAXARM} +function GetUnitName(C: TClass): String; +begin + RaiseNotImpl; +end; +{$ELSE} +function GetUnitName(C: TClass): String; +var + pti: PTypeInfo; + ptd: PTypeData; +begin + pti := C.ClassInfo; + ptd := GetTypeData(pti); + result := String(ptd^.UnitName); +end; +{$ENDIF} + +{$IFDEF PAXARM_DEVICE} +function GetRBPPtr: Pointer; +begin +end; +{$ELSE} + +{$IFDEF PAX64} +function GetRBPPtr: Pointer; assembler; +{$IFDEF FPC} +nostackframe; +{$ENDIF} +asm + mov rax, rbp +end; +{$ELSE} +function GetRBPPtr: Pointer; assembler; +{$IFDEF FPC} +nostackframe; +{$ENDIF} +asm + mov eax, ebp +end; +{$ENDIF} +{$ENDIF} + +function GetPaxInfo(C: TClass): PPaxInfo; +var + P: Pointer; +begin + result := nil; + if C = nil then + Exit; + P := GetVMTFromClass(C); + P := ShiftPointer(P, - SizeOf(TPaxInfo)); + +{$IFDEF ARC} + if CompareMem(P, @strPaxSignature, PaxSignatureLength) then + result := P; +{$ELSE} + if Byte(P^) = PaxSignatureLength then + if PShortString(P)^ = strPaxSignature then + result := P; +{$ENDIF} +end; + +function IsPaxObject(X: TObject): Boolean; +begin + if X = nil then + begin + result := false; + Exit; + end; + + result := IsPaxClass(X.ClassType); +end; + +function IsPaxClass(C: TClass): Boolean; +begin + if C = nil then + begin + result := false; + Exit; + end; + + result := GetPaxInfo(C) <> nil; +end; + +function GetHostParentClass(C: TClass): TClass; +begin + result := C.ClassParent; + if not IsPaxClass(result) then + Exit + else + result := GetHostParentClass(result); +end; + +function GetVmtFromClass(AClass: TClass): PVmt; +begin + if AClass = nil then + begin + result := nil; + Exit; + end; + + Result := PVmt(AClass); + +{$IFDEF FPC} + Exit; +{$ENDIF} +{$IFDEF PAX64} + result := ShiftPointer(result, - SizeOf(TVMT)); +{$ELSE} + Dec(Result); +{$ENDIF} +end; + +function GetDestructorAddress(AClass: TClass): Pointer; +begin + result := ShiftPointer(AClass, - SizeOf(Pointer)); + result := Pointer(result^); +end; + +function GetVmtFromObject(Instance: TObject): PVmt; +begin + Result := GetVmtFromClass(Instance.ClassType); +end; + +function GetClassFromVMT(Vmt: PVmt): TClass; +begin + if Vmt = nil then + begin + result := nil; + Exit; + end; + {$IFDEF FPC} + result := TClass(Vmt); + Exit; + {$ENDIF} + + Inc(Vmt); + result := TClass(Vmt); +end; + +function ChCount(const S: String; Ch: Char): Integer; +var + I: Integer; +begin + result := 0; + for I:=SLow(S) to SHigh(S) do + if S[I] = Ch then + Inc(result); +end; + +function GetIntResultType(T1, T2: Integer): Integer; +begin + result := typeINTEGER; + if not ((T1 in IntegerTypes) and (T2 in IntegerTypes)) then + raise Exception.Create(errInternalError); + if (T1 in UnsignedIntegerTypes) or (T2 in UnsignedIntegerTypes) then + result := typeCARDINAL; + if (T1 = typeINT64) or (T2 = typeINT64) then + result := typeINT64; +end; + +function GetImplementorOfInterface(const I: IUnknown): TObject; +{ TODO -cDOC : Original code by Hallvard Vassbotn } +{ TODO -cTesting : Check the implemetation for any further version of compiler } +const + AddByte = $04244483; // opcode for ADD DWORD PTR [ESP+4], Shortint + AddLong = $04244481; // opcode for ADD DWORD PTR [ESP+4], Longint +type + PAdjustSelfThunk = ^TAdjustSelfThunk; + TAdjustSelfThunk = packed record + case AddInstruction: Longint of + AddByte: (AdjustmentByte: ShortInt); + AddLong: (AdjustmentLong: Longint); + end; + PInterfaceMT = ^TInterfaceMT; + TInterfaceMT = packed record + QueryInterfaceThunk: PAdjustSelfThunk; + end; + TInterfaceRef = ^PInterfaceMT; +var + QueryInterfaceThunk: PAdjustSelfThunk; +begin + try + Result := Pointer(I); + if Assigned(Result) then + begin + QueryInterfaceThunk := TInterfaceRef(I)^.QueryInterfaceThunk; + case QueryInterfaceThunk.AddInstruction of + AddByte: + Inc(PChar(Result), QueryInterfaceThunk.AdjustmentByte); + AddLong: + Inc(PChar(Result), QueryInterfaceThunk.AdjustmentLong); + else + Result := nil; + end; + end; + except + Result := nil; + end; +end; + +function ByteInSet(B: Char; const S: TByteSet): Boolean; +begin + Result := Ord(B) in S; +end; + +function IsValidName(const S: String): Boolean; +var + I: Integer; +begin + result := false; + if S = '' then + Exit; + if not IsAlpha(S[1]) then + Exit; + for I := SLow(S) to SHigh(S) do + if not (IsAlpha(S[I]) or IsDigit(S[I])) then + Exit; + result := true; +end; + +function IsDigit(C: Char): Boolean; +begin + result := (C >= '0') and (C <='9'); +end; + +function IsAlpha(C: Char): Boolean; +begin + result := ((C >= 'a') and (C <='z')) or + ((C >= 'A') and (C <='Z')) or + (C = '_'); +end; + +function Subst(const S, X, Y: String): String; +var + I, K: Integer; + C: Char; + L, LX, LY: Integer; + Q: String; +begin + result := S; + LX := Length(X); + LY := Length(Y); + I := 1; + while I <= Length(result) do + begin + C := result[I]; + L := Length(result); + while not IsAlpha(C) do + begin + Inc(I); + if I >= L then + Exit; + C := result[I]; + end; + + K := I + LX - 1; + if K > L then + Exit; + if K = L then + begin + Q := Copy(result, I, LX); + if StrEql(Q, X) then + begin + Delete(result, I, LX); + Insert(Y, result, I); + end; + Exit; + end; + + // K < L + + C := result[K + 1]; + if not (IsAlpha(C) or IsDigit(C)) then + begin + Q := SCopy(result, I, LX); + if StrEql(Q, X) then + begin + SDelete(result, I, LX); + SInsert(Y, result, I); + Inc(I, LY - LX + 1); + end + else + begin + C := result[I]; + L := Length(result); + while IsAlpha(C) or IsDigit(C) do + begin + Inc(I); + if I >= L then + Exit; + C := result[I]; + end; + end; + end + else + begin + C := result[I]; + L := Length(result); + while IsAlpha(C) or IsDigit(C) do + begin + Inc(I); + if I >= L then + Exit; + C := result[I]; + end; + end; + end; +end; + + +{$IFDEF PAXARM} +function IsPaxFrame: Boolean; +begin + result := false; + RIE; +end; +{$ELSE} +{$IFDEF PAX64} +function IsPaxFrame: Boolean; +begin + result := false; + RaiseNotImpl; +end; +{$ELSE} +function IsPaxFrame: Boolean; +var + EstablisherFrame: PPaxExcFrame; + K: Integer; +begin + result := false; + asm + mov eax, fs:[0] + mov EstablisherFrame, eax + end; + K := 0; + while EstablisherFrame^.Magic <> PAX_SEH do + begin + EstablisherFrame := EstablisherFrame^.Next; + Inc(K); + if K = 5 then + Exit; + end; + result := true; +end; +{$ENDIF} +{$ENDIF} + +procedure ErrMessageBox(const S: String); +begin +{$IFDEF CONSOLE} + writeln(S); + Exit; +{$ELSE} + +{$IFDEF LINUX} + ShowMessage(S); +{$ELSE} + {$IFDEF PAX64} + MessageBox(GetActiveWindow(), PChar(S), PChar('paxCompiler'), MB_ICONEXCLAMATION or MB_OK); + {$ELSE} + {$IFDEF MACOS32} + ShowMessage(S); + {$ELSE} + {$IFDEF PAXARM} + {$IFDEF PAXARM_DEVICE} + RIE; + {$ELSE} + ShowMessage(S); + {$ENDIF} + {$ELSE} + {$IFNDEF UNIX} + MessageBox(GetActiveWindow(), PChar(S), PChar('paxCompiler'), MB_ICONEXCLAMATION or MB_OK); + {$ENDIF} + {$ENDIF} + {$ENDIF} + {$ENDIF} +{$ENDIF} +{$ENDIF} +end; + +function IsPositiveInt(S: PChar): Boolean; +var + N: Byte; + c: Char; +begin + if S^ = #0 then + begin + result := false; + Exit; + end; + + result := true; + + repeat + c := S^; + + if c = #0 then + Exit; + + N := Ord(c); + + if N < Ord('0') then + begin + result := false; + Exit; + end; + + if N > Ord('9') then + begin + result := false; + Exit; + end; + + Inc(S); + + until false; +end; + +function HashNumber(const S: String): Integer; +var + I, J: Integer; + c: Char; +begin + if S = '' then + begin + raise Exception.Create(errInternalError); + end; + + I := 0; + for J:=SLow(S) to SHigh(S) do + begin + c := UpCase(S[J]); + I := I shl 1; + I := I xor ord(c); + end; + if I < 0 then I := - I; + result := I mod MaxHash; +end; + +{$IFNDEF UNIX} +{$IFNDEF PAXARM} +{$IFDEF LINUX} +function CLSIDFromString(psz: PWideString; out clsid: TGUID): HResult; stdcall; +begin + RaiseNotImpl; +end; +{$ELSE} +function CLSIDFromString; external 'ole32.dll' name 'CLSIDFromString'; +{$ENDIF} +{$ENDIF} +{$ENDIF} + +function GuidsAreEqual(const G1, G2: TGUID): Boolean; +begin +{$IFDEF VARIANTS} + result := SysUtils.IsEqualGUID(G1, G2); +{$ELSE} + result := CompareMem(@G1, @G2, SizeOf(TGUID)); +{$ENDIF} +end; + +function Norm(const S: String; L: Integer): String; +begin + result := SCopy(S, SLow(S), L); + while Length(result) < L do + result := ' ' + result; +end; + +function Int32ToByteSet(value: Integer): TByteSet; +begin + result := []; + Move(value, result, 4); +end; + +function ByteSetToInt32(value: TByteSet): Integer; +begin + Move(value, result, 4); +end; + +function ByteSetToString(value: TByteSet; + FinTypeId: Integer; + EnumNames: TStringList = nil): String; +var + I, B1, B2: Integer; + X: Boolean; +label + L; +begin + result := '['; + X := true; + B1 := -1; + B2 := -1; + for I:= 0 to 255 do + if I in value then + begin + if X then + begin + B1 := I; + B2 := I; + X := false; + end + else + begin + B2 := I; + end; + + if I = 255 then + goto L; + end + else if B1 >= 0 then + begin +L: + if B2 - B1 = 0 then + case FinTypeId of +{$IFNDEF PAXARM} + typeANSICHAR: + result := result + '''' + Chr(B1) + ''''; +{$ENDIF} + typeBOOLEAN: + if B1 = 0 then + result := result + 'false' + else + result := result + 'true'; + typeENUM: + begin + if EnumNames = nil then + result := result + IntToStr(B1) + else + result := result + EnumNames[B1]; + end + else + result := result + IntToStr(B1); + end + else + case FinTypeId of +{$IFNDEF PAXARM} + typeANSICHAR: + result := result + '''' + Chr(B1) + '''' + '..' + + '''' + Chr(B2) + ''''; +{$ENDIF} + typeBOOLEAN: + result := result + 'false..true'; + else + result := result + IntToStr(B1) + '..' + IntToStr(B2); + end; + + B1 := -1; + X := true; + result := result + ','; + + end; + + if result[Length(result)] = ',' then + result[Length(result)] := ']' + else + result := result + ']'; +end; + +procedure SaveIntDynarrayToStream(const A: TIntegerDynArray; P: TStream); +var + I, K: Integer; +begin + K := System.Length(A); + P.Write(K, SizeOf(Integer)); + for I := 0 to K - 1 do + P.Write(A[I], SizeOf(A[I])); +end; + +function LoadIntDynarrayFromStream(P: TStream): TIntegerDynArray; +var + I, K: Integer; +begin + P.Read(K, SizeOf(Integer)); + SetLength(result, K); + for I := 0 to K - 1 do + P.Read(result[I], SizeOf(result[I])); +end; + +{$IFDEF UNIC} +function SaveStringListToStream(L: TStringList; P: TStream): Integer; +var + I, K: Integer; +begin + K := L.Count; + P.Write(K, 4); + result := 4; + for I:=0 to L.Count - 1 do + begin + SaveStringToStream(L[I], P); + Inc(result, 4 + Length(L[I]) * SizeOf(Char)); + end; +end; + +function LoadStringListFromStream(L: TStringList; P: TStream): Integer; +var + I, K: Integer; + S: String; +begin + P.Read(K, 4); + result := 4; + for I:=0 to K - 1 do + begin + S := LoadStringFromStream(P); + L.Add(S); + Inc(result, 4 + Length(S) * SizeOf(Char)); + end; +end; +{$ELSE} +function SaveStringListToStream(L: TStringList; P: TStream): Integer; +var + I, K: Integer; + S: ShortString; +begin + result := 0; + K := L.Count; + P.Write(K, 4); + Inc(result, 4); + for I:=0 to L.Count - 1 do + begin + S := L[I]; + K := Length(S); + P.Write(K, 4); + P.Write(S[1], Length(S)); + Inc(result, Length(S) + 4); + end; +end; + +function LoadStringListFromStream(L: TStringList; P: TStream): Integer; +var + I, K, Count: Integer; + S: ShortString; +begin + result := 0; + P.Read(Count, 4); + Inc(result, 4); + for I:=0 to Count - 1 do + begin + P.Read(K, 4); + P.Read(S[1], K); + S[0] := AnsiChar(Chr(K)); + L.Add(S); + Inc(result, Length(S) + 4); + end; +end; +{$ENDIF} + +procedure SaveShortStringToStream(const S: ShortString; P: TStream); +begin +{$IFDEF ARC} + P.Write(S[0], S[0] + 1); +{$ELSE} + P.Write(S[0], Length(S) + 1); +{$ENDIF} +end; + +function LoadShortStringFromStream(P: TStream): ShortString; +var + L: Byte; +begin + P.Read(L, SizeOf(Byte)); + P.Read(result[1], L); +{$IFDEF ARC} + result[0] := L; +{$ELSE} + result[0] := AnsiChar(Chr(L)); +{$ENDIF} +end; + +procedure SaveStringToStream(const S: String; P: TStream); +var + K: Integer; +begin + K := Length(S); + P.Write(K, 4); + if K > 0 then + P.Write(Pointer(S)^, K * SizeOf(Char)); +end; + +function LoadStringFromStream(P: TStream): String; +var + K: Integer; +begin + P.Read(K, 4); + SetLength(result, K); + if K > 0 then + P.Read(Pointer(result)^, K * SizeOf(Char)); +end; + +{$IFNDEF PAXARM} +procedure SaveWideStringToStream(const S: WideString; P: TStream); +var + K: Integer; +begin + K := Length(S); + P.Write(K, 4); + if K > 0 then + P.Write(Pointer(S)^, K * 2); +end; + +function LoadWideStringFromStream(P: TStream): WideString; +var + K: Integer; +begin + P.Read(K, 4); + SetLength(result, K); + if K > 0 then + P.Read(Pointer(result)^, K * 2); +end; +{$ENDIF} + +procedure SaveVariantToStream(const Value: Variant; S: TStream); +var + VType: Integer; +begin + VType := VarType(Value); + SaveIntegerToStream(VType, S); + case VType of + varString: + SaveStringToStream(Value, S); +{$IFDEF UNIC} + varUString: + SaveStringToStream(Value, S); +{$ENDIF} +{$IFNDEF PAXARM} + varOleStr: + SaveWideStringToStream(Value, S); +{$ENDIF} + else + S.Write(Value, SizeOf(Variant)); + end; +end; + +function LoadVariantFromStream(S: TStream): Variant; +var + VType: Integer; +begin + VType := LoadIntegerFromStream(S); + case VType of + varString: + result := LoadStringFromStream(S); +{$IFDEF UNIC} + varUString: + result := LoadStringFromStream(S); +{$ENDIF} +{$IFNDEF PAXARM} + varOleStr: + result := LoadWideStringFromStream(S); +{$ENDIF} + else + S.ReadBuffer(result, SizeOf(Variant)); + end; +end; + +function VariantIsString(const V: Variant): Boolean; +begin + if TVarData(V).VType = varOleStr then + result := true +{$IFDEF UNIC} + else if TVarData(V).VType = varUString then + result := true +{$ENDIF} + else if TVarData(V).VType = varString then + result := true + else + result := false; +end; + +function VariantToDate(const V: Variant): TDateTime; +begin +{$IFDEF VARIANTS} + result := Variants.VarToDateTime(V); +{$ELSE} + result := V; +{$ENDIF} +end; + +procedure SaveIntegerToStream(Value: Integer; S: TStream); +begin + S.Write(Value, SizeOf(Integer)); +end; + +function LoadIntegerFromStream(S: TStream): Integer; +begin + S.Read(result, SizeOf(Integer)); +end; + +function IsEmpty(const V: Variant): Boolean; +begin + result := VarType(V) = varEmpty; +end; + +function MPtr(X: Integer): Integer; +begin + result := X; + while result mod SizeOf(Pointer) <> 0 do Inc(result); +end; + +function StrEql(const S1, S2: String): Boolean; +begin + result := CompareText(S1, S2) = 0; +end; + +{$IFNDEF PAXARM} +function Text(const source: AnsiString): TStringList; +var + I, L, Start: Integer; + S: String; +begin + result := TStringList.Create; + L := Length(source); + I := 1; + Start := I; + repeat + if source[I] = #13 then + begin + Inc(I); + if I <= L then + begin + if source[I] = #10 then + begin + S := String(Copy(Source, Start, I - Start - 1)); + result.Add(S); + Inc(I); + if I > L then + break; + Start := I; + end + end + else + break; + end + else if source[I] = #10 then + begin + S := String(Copy(Source, Start, I - Start - 1)); + result.Add(S); + Inc(I); + Start := I; + if I > L then + break; + end + else + begin + Inc(I); + if I > L then + begin + S := String(Copy(Source, Start, I - Start - 1)); + result.Add(S); + break; + end; + end; + until false; +end; +{$ENDIF} + +function ExtractName(const S: String): String; +var + I, L: Integer; +begin + L := SHigh(S); + for I:= SHigh(S) downto SLow(S) do + if ByteInSet(S[I], [Ord('.'), Ord('/'), Ord('\')]) then + begin + result := SCopy(S, I + 1, L - I); + Exit; + end; + result := S; +end; + +function ExtractFullName(const S: String): String; +var + I, L: Integer; +begin + L := SHigh(S); + for I:= SLow(S) to L do + if S[I] = '.' then + begin + result := SCopy(S, I + 1, L - I); + Exit; + end; + result := S; +end; + +function ExtractFullOwner(const S: String): String; +var + I, L, K: Integer; + C: Char; +begin + K := 0; + L := SHigh(S); + for I:= L downto SLow(S) do + begin + C := S[I]; + case C of + '>': Inc(K); + '<': Dec(K); + '.': + if K = 0 then + begin + result := SCopy(S, SLow(S), I - SLow(S)); + Exit; + end; + end; + end; + result := ''; +end; + +function ExtractClassName(const S: String): String; +var + I, L, K1, K2: Integer; +begin + L := SHigh(S); + result := ''; + + if L = 0 then + Exit; + + K1 := 0; + K2 := 0; + + for I:= L downto SLow(S) do + if S[I] = '.' then + if K2 = 0 then + K2 := I + else + begin + K1 := I; + result := SCopy(S, K1 + 1, K2 - K1 - 1); + Exit; + end; + result := SCopy(S, K1 + SLow(S), K2 - K1 - SLow(S)); +end; + +function ExtractOwner(const S: String): String; +var + P: Integer; +begin + result := ''; + P := PosCh('.', S); + if P > 0 then + result := SCopy(S, SLow(S), P - SLow(S)); +end; + +function NativeAddress(P: Pointer): Boolean; +begin + result := Abs(IntPax(P)) > 65535; +end; + + +function ShiftPointer(P: Pointer; L: Integer): Pointer; +begin + result := Pointer(IntPax(P) + L); +end; + +function AlignLeft(const S: String; L: Integer): String; +begin + result := S; + while Length(result) < L do + result := result + ' '; +end; + +function ByteToHex(B: Byte): String; +begin + result := Format('%x', [B]); + if Length(result) = 1 then + result := '0' + result; +end; + +function IsShortInt(I: Integer): Boolean; +begin + result := Abs(I) <= 127; +end; + +function InterfaceRTTIMethodCount(pti: PTypeInfo): Word; +var + ptd: PTypeData; + P: Pointer; +begin + ptd := GetTypeData(pti); + P := @ ptd^.IntfUnit; + P := ShiftPointer(P, Length(StringFromPShortString(@ptd^.IntfUnit)) + 1); + Result := Word(P^); + if result = $FFFF then + result := 0; +end; + +function HasInterfaceRTTIMethod(pti: PTypeInfo): Boolean; +var + ptd: PTypeData; + P: Pointer; + W: Word; +begin + ptd := GetTypeData(pti); + P := @ ptd^.IntfUnit; + P := ShiftPointer(P, Length(StringFromPShortString(@ptd^.IntfUnit)) + 1 + SizeOf(Word)); + W := Word(P^); + if W = $FFFF then + result := false + else + result := true; +end; + +function InterfaceRefCount(I: Pointer): Integer; +begin + result := IInterface(I)._AddRef - 1; + IInterface(I)._Release; +end; + +function StrRefCountPtr(S: Pointer): Pointer; +begin + if S <> nil then + result := Pointer(Integer(Pointer(S)) - 8) + else + result := nil; +end; + +function StrRefCount(S: Pointer): Integer; +begin + result := Integer(StrRefCountPtr(S)^); +end; + +function StrSizePtr(S: Pointer): Pointer; +begin + if S <> nil then + result := Pointer(Integer(Pointer(S)) - 4) + else + result := nil; +end; + +function StrSize(S: Pointer): Integer; +begin + result := Integer(StrSizePtr(S)^); +end; + +function Space(K: Integer): String; +var + I: Integer; +begin + result := ''; + for I := 1 to K do + result := result + ' '; +end; + +function RemoveWhiteSpaces(const S: String): String; +var + I: Integer; + ch: Char; +begin + result := ''; + for I:=SLow(S) to SHigh(S) do + begin + ch := S[I]; + if not ByteInSet(ch, WhiteSpaces) then + result := result + ch; + end; +end; + +function RemoveChars(C: TByteSet; const S: String): String; +var + I: Integer; + ch: Char; +begin + result := ''; + for I:=SLow(S) to SHigh(S) do + begin + ch := S[I]; + if not ByteInSet(ch, C) then + result := result + ch; + end; +end; + +function RemoveLeftChars(C: TByteSet; const S: String): String; +var + I: Integer; + ch: Char; + b, bb: Boolean; +begin + result := ''; + bb := true; + for I:=SLow(S) to SHigh(S) do + begin + ch := S[I]; + + b := ByteInSet(ch, C); + + if b and bb then + continue; + + bb := false; + result := result + ch; + end; +end; + +function RemoveRightChars(C: TByteSet; const S: String): String; +var + I: Integer; + ch: Char; + b, bb: Boolean; +begin + result := ''; + bb := true; + for I:=SHigh(S) downto SLow(S) do + begin + ch := S[I]; + b := ByteInSet(ch, C); + if b and bb then + continue; + bb := false; + result := ch + result; + end; +end; + +function RemoveLeftChars1(C: TByteSet; const S: String): String; +var + I: Integer; + ch: Char; + b, bb: Boolean; +begin + result := ''; + bb := true; + for I:=SLow(S) to SHigh(S) do + begin + ch := S[I]; + + b := ByteInSet(ch, C); + + if b and bb then + continue + else if b then + break; + + bb := false; + result := result + ch; + end; +end; + +function RemoveRightChars1(C: TByteSet; const S: String): String; +var + I: Integer; + ch: Char; + b, bb: Boolean; +begin + result := ''; + bb := true; + for I:=SHigh(S) downto SLow(S) do + begin + ch := S[I]; + + b := ByteInSet(ch, C); + + if b and bb then + continue + else if b then + break; + + bb := false; + result := result + ch; + end; +end; + +function RemoveBorderChars(C: TByteSet; const S: String): String; +begin + result := RemoveRightChars(C, S); + result := RemoveLeftChars(C, result); +end; + +function PosCh(ch: Char; const S: String): Integer; +var + I: Integer; +begin + result := 0; + for I:=SLow(S) to SHigh(S) do + if S[I] = ch then + begin + result := I; + Exit; + end; +end; + +function LastPosCh(ch: Char; const S: String): Integer; +var + I: Integer; +begin + result := 0; + for I:=SHigh(S) downto SLow(S) do + if S[I] = ch then + begin + result := I; + Exit; + end; +end; + +function CountCh(ch: Char; const S: String): Integer; +var + I: Integer; +begin + result := 0; + for I:=SLow(S) to SHigh(S) do + if S[I] = ch then + Inc(result); +end; + +function RemoveCh(Ch: Char; const S: String): String; +var + I: Integer; +begin + result := ''; + for I:=SLow(S) to SHigh(S) do + if S[I] <> Ch then + result := result + S[I]; +end; + +function ReplaceCh(Source, Dest: Char; const S: String): String; +var + I: Integer; +begin + result := S; + for I := SLow(result) to SHigh(result) do + if result[I] = Source then + result[I] := Dest; +end; + +function LoadText(const FileName: String): String; +var + L: TStringList; +begin + L := TStringList.Create; + try + L.LoadFromFile(FileName); + result := L.Text; + finally + FreeAndNil(L); + end; +end; + +function _IsJSType(T: Integer; P: Pointer): Boolean; +begin + result := false; +end; + +function GetVisibility(value: TClassVisibility): TMemberVisibility; +begin + result := mvPublic; + case value of + cvNone, cvPrivate: result := mvPrivate; + cvProtected: result := mvProtected; + cvPublic: result := mvPublic; + cvPublished: result := mvPublished; + end; +end; + +function ExtractNames(const S: String): TStringList; +var + R: String; + P: Integer; +begin + result := TStringList.Create; + R := S; + repeat + P := PosCh('.', R); + if P = 0 then + begin + result.Add(R); + Exit; + end; + result.Add(SCopy(R, SLow(S), P - SLow(S))); + SDelete(R, SLow(R), P + 1 - SLow(R)); + until false; +end; + +procedure RaiseNotImpl; +begin + raise Exception.Create(errNotImplementedYet); +end; + +procedure RIE; +begin + raise Exception.Create(errInternalError); +end; + +initialization + + Types := TStdTypeList.Create; + with Types do + begin + Add('', 0); + Add('Void', SizeOf(Pointer)); + Add('Boolean', SizeOf(Boolean)); + Add('Byte', SizeOf(Byte)); +{$IFDEF PAXARM} + Add('Char', SizeOf(Char)); + {$ELSE} + Add('Char', SizeOf(AnsiChar)); +{$ENDIF} + Add('String', SizeOf(Pointer)); + Add('Word', SizeOf(Word)); + Add('Integer', SizeOf(Integer)); + Add('Double', SizeOf(Double)); + Add('Pointer', SizeOf(Pointer)); + Add('#RECORD', 0); + Add('#ARRAY', 0); + Add('#ALIAS', 0); + Add('#ENUM', SizeOf(Byte)); + Add('#PROC', SizeOf(Pointer)); + Add('#SET', 32); + Add('ShortString', 256); + Add('Single', SizeOf(Single)); + Add('Extended', SizeOf(Extended)); + Add('#CLASS', SizeOf(Pointer)); + Add('#CLASSREF', SizeOf(Pointer)); + Add('WideChar', SizeOf(WideChar)); +{$IFDEF PAXARM} + Add('WideString', SizeOf(Pointer)); +{$ELSE} + Add('WideString', SizeOf(WideString)); +{$ENDIF} + Add('Variant', SizeOf(Variant)); + Add('#DYNARRAY', SizeOf(Pointer)); + Add('Int64', SizeOf(Int64)); + Add('#INTERFACE', SizeOf(Pointer)); + Add('Cardinal', SizeOf(Cardinal)); + Add('#EVENT', SizeOf(TMethod)); + Add('Currency', SizeOf(Currency)); + Add('SmallInt', SizeOf(SmallInt)); + Add('ShortInt', SizeOf(ShortInt)); + Add('WordBool', SizeOf(WordBool)); + Add('LongBool', SizeOf(LongBool)); + Add('ByteBool', SizeOf(ByteBool)); + Add('OleVariant', SizeOf(OleVariant)); + Add('UnicodeString', SizeOf(UnicString)); + Add('#OPENARRAY', SizeOf(Pointer)); + Add('#TYPEPARAM', 0); + Add('UInt64', SizeOf(Int64)); + Add('#VOBJECT', SizeOf(VARIANT)); + Add('#HELPER', SizeOf(Pointer)); + end; + + Kinds := TStringList.Create; + with Kinds do + begin + Add(''); + Add('VAR'); + Add('CONST'); + Add('SUB'); + Add('PARAM'); + Add('TYPE'); + Add('T FIELD'); + Add('LABEL'); + Add('NAMESP'); + Add('CONSTR'); + Add('DESTR'); + Add('PROP'); + Add('END CH'); + end; + + Operators := TStringList.Create; + with Operators do + begin + OP_NOP := - Add('NOP'); + OP_SEPARATOR := - Add('SEPARATOR'); + OP_ADD_COMMENT := - Add('COMMENT'); + OP_STMT := - Add('STMT'); + OP_SET_CODE_LINE := - Add('SCL'); + + OP_BEGIN_TEXT := - Add('BEGIN TEXT'); + OP_END_TEXT := - Add('END TEXT'); + + OP_BEGIN_LOOP := - Add('BEGIN LOOP'); + OP_EPILOGUE_LOOP := - Add('EPILOGUE LOOP'); + OP_END_LOOP := - Add('END LOOP'); + + OP_OPTION_EXPLICIT := - Add('EXPLICIT'); + OP_INIT_FWARRAY := - Add('INIT FWARRAY'); + + OP_CHECK_FINAL := - Add('CHECK FINAL'); + + OP_BEGIN_NAMESPACE := - Add('BEGIN NAMESPACE'); + OP_END_NAMESPACE := - Add('END NAMESPACE'); + + OP_BEGIN_TYPE := - Add('BEGIN TYPE'); + OP_END_TYPE := - Add('END TYPE'); + + OP_BEGIN_CLASS_TYPE := - Add('BEGIN CLASS TYPE'); + OP_END_CLASS_TYPE := - Add('END CLASS TYPE'); + + OP_BEGIN_CLASSREF_TYPE := - Add('BEGIN CLASSREF TYPE'); + OP_END_CLASSREF_TYPE := - Add('END CLASSREF TYPE'); + + OP_BEGIN_HELPER_TYPE := - Add('BEGIN HELPER TYPE'); + OP_END_HELPER_TYPE := - Add('END HELPER TYPE'); + + OP_BEGIN_INTERFACE_TYPE := - Add('BEGIN INTERFACE TYPE'); + OP_END_INTERFACE_TYPE := - Add('END INTERFACE TYPE'); + + OP_BEGIN_RECORD_TYPE := - Add('BEGIN RECORD TYPE'); + OP_END_RECORD_TYPE := - Add('END RECORD TYPE'); + + OP_BEGIN_ARRAY_TYPE := - Add('BEGIN ARRAY TYPE'); + OP_END_ARRAY_TYPE := - Add('END ARRAY TYPE'); + + OP_BEGIN_DYNARRAY_TYPE := - Add('BEGIN DYNARRAY TYPE'); + OP_END_DYNARRAY_TYPE := - Add('END DYNARRAY TYPE'); + + OP_BEGIN_SUBRANGE_TYPE := - Add('BEGIN SUBRANGE TYPE'); + OP_END_SUBRANGE_TYPE := - Add('END SUBRANGE TYPE'); + + OP_BEGIN_ENUM_TYPE := - Add('BEGIN ENUM TYPE'); + OP_END_ENUM_TYPE := - Add('END ENUM TYPE'); + + OP_BEGIN_SET_TYPE := - Add('BEGIN SET TYPE'); + OP_END_SET_TYPE := - Add('END SET TYPE'); + + OP_BEGIN_POINTER_TYPE := - Add('BEGIN POINTER TYPE'); + OP_END_POINTER_TYPE := - Add('END POINTER TYPE'); + + OP_BEGIN_PROC_TYPE := - Add('BEGIN PROC TYPE'); + OP_END_PROC_TYPE := - Add('END PROC TYPE'); + + OP_BEGIN_ALIAS_TYPE := - Add('BEGIN ALIAS TYPE'); + OP_END_ALIAS_TYPE := - Add('END ALIAS TYPE'); + +{$IFNDEF PAXARM} + OP_BEGIN_SHORTSTRING_TYPE := - Add('BEGIN SHORTSTRING TYPE'); + OP_END_SHORTSTRING_TYPE := - Add('END SHORTSTRING TYPE'); +{$ENDIF} + + OP_BEGIN_CONST := - Add('BEGIN CONST'); + OP_END_CONST := - Add('END CONST'); + + OP_BEGIN_VAR := - Add('BEGIN VAR'); + OP_END_VAR := - Add('END VAR'); + + OP_GET_NEXTJSPROP := - Add('GET NEXTJSPROP'); + OP_CLEAR_REFERENCES := - Add('CLEAR REFERENCES'); + + OP_BEGIN_LIBRARY := - Add('BEGIN LIBRARY'); + OP_BEGIN_EXPORT := - Add('BEGIN EXPORT'); + OP_BEGIN_MODULE := - Add('BEGIN MODULE'); + OP_END_MODULE := - Add('END MODULE'); + OP_BEGIN_INCLUDED_FILE := - Add('BEGIN INCLUDED FILE'); + OP_END_INCLUDED_FILE := - Add('END INCLUDED FILE'); + OP_END_INTERFACE_SECTION := - Add('END INTERFACE SECTION'); + OP_END_IMPORT := - Add('END IMPORT'); + OP_BEGIN_INITIALIZATION := - Add('BEGIN INITIALIZATION'); + OP_END_INITIALIZATION := - Add('END INITIALIZATION'); + OP_BEGIN_FINALIZATION := - Add('BEGIN FINALIZATION'); + OP_END_FINALIZATION := - Add('END FINALIZATION'); + + OP_EXTRA_BYTECODE := - Add('EXTRA BYTECODE'); + + OP_WARNINGS_ON := - Add('WARNINGS ON'); + OP_WARNINGS_OFF := - Add('WARNINGS OFF'); + + OP_FRAMEWORK_ON := - Add('FRAMEWORK ON'); + OP_FRAMEWORK_OFF := - Add('FRAMEWORK OFF'); + + OP_TRY_ON := - Add('TRY ON'); + OP_TRY_OFF := - Add('TRY OFF'); + OP_FINALLY := - Add('FINALLY'); + OP_EXCEPT := - Add('EXCEPT'); + OP_EXCEPT_SEH := - Add('EXCEPT SEH'); + OP_EXCEPT_ON := - Add('EXCEPT ON'); + OP_RAISE := - Add('RAISE'); + OP_COND_RAISE := - Add('COND RAISE'); + OP_BEGIN_EXCEPT_BLOCK := - Add('BEGIN EXCEPT BLOCK'); + OP_END_EXCEPT_BLOCK := - Add('END EXCEPT BLOCK'); + + OP_OVERFLOW_CHECK := - Add('OVERFLOW CHECK'); + + OP_PAUSE := - Add('PAUSE'); + OP_CHECK_PAUSE := - Add('CHECK PAUSE'); + OP_CHECK_PAUSE_LIGHT := - Add('CHECK PAUSE LIGHT'); + OP_HALT := - Add('HALT'); + + OP_EMIT_OFF := - Add('EMIT OFF'); + OP_EMIT_ON := - Add('EMIT ON'); + + OP_BEGIN_USING := - Add('BEGIN USING'); + OP_END_USING := - Add('END USING'); + + OP_BEGIN_BLOCK := - Add('BEGIN BLOCK'); + OP_END_BLOCK := - Add('END BLOCK'); + + OP_EVAL := - Add('EVAL'); + OP_EVAL_OUTER := - Add('EVAL OUTER'); + + OP_EVAL_INHERITED := - Add('EVAL INHERITED'); + OP_EVAL_CONSTRUCTOR := - Add('EVAL CONSTRUCTOR'); + OP_UPDATE_INSTANCE := - Add('UPDATE INSTANCE'); + OP_ADJUST_INSTANCE := - Add('ADJUST INSTANCE'); + OP_CLEAR_EDX := - Add('CLEAR EDX'); + OP_IMPLEMENTS := - Add('IMPLEMENTS'); + + OP_MYCLASS := - Add('MYCLASS'); + OP_MYBASE := - Add('MYBASE'); + + OP_LOAD_PROC := - Add('LOAD PROC'); + + OP_CHECK_OVERRIDE := - Add('CHECK OVERRIDE'); + + OP_EXIT := - Add('EXIT'); + OP_GO := - Add('GO'); + OP_GO_1 := - Add('GO 1'); + OP_GO_2 := - Add('GO 2'); + OP_GO_3 := - Add('GO 3'); + OP_GO_TRUE := - Add('GO TRUE'); + OP_GO_FALSE := - Add('GO FALSE'); + OP_GO_TRUE_BOOL := - Add('GO TRUE BOOL'); + OP_GO_FALSE_BOOL := - Add('GO FALSE BOOL'); + OP_GO_DL := - Add('GO DL'); + OP_CALL_INHERITED := - Add('CALL INHERITED'); + OP_BEGIN_CALL := - Add('BEGIN CALL'); + OP_CALL := - Add('CALL'); + OP_CALL_DEFAULT_CONSTRUCTOR := - Add('CALL DEFAULT CONSTRUCTOR'); + OP_CHECK_SUB_CALL := - Add('CHECK SUB CALL'); + OP_BEGIN_VCALL := - Add('BEGIN VCALL'); + OP_VCALL := - Add('VCALL'); + OP_PUSH := - Add('PUSH'); + OP_PUSH_INSTANCE := - Add('PUSH INSTANCE'); + OP_PUSH_CLASSREF := - Add('PUSH CLASSREF'); + OP_PUSH_CONTEXT := - Add('PUSH CONTEXT'); + OP_POP_CONTEXT := - Add('POP CONTEXT'); + OP_FIND_CONTEXT := - Add('FIND CONTEXT'); + OP_FIND_JS_FUNC := - Add('FIND JS FUNC'); + OP_LABEL := - Add('LABEL'); + OP_TYPE_CAST := - Add('TYPE CAST'); + OP_DECL_SUB := - Add('DECL SUB'); + OP_DECLARE_MEMBER := - Add('DECLARE MEMBER'); + OP_BEGIN_SUB := - Add('BEGIN SUB'); + OP_DECLARE_LOCAL_VAR := - Add('DECLARE LOCAL VAR'); + OP_DECLARE_TEMP_VAR := - Add('DECLARE TEMP VAR'); + OP_DESTROY_LOCAL_VAR := - Add('DESTROY LOCAL VAR'); + OP_INIT_SUB := - Add('INIT SUB'); + OP_JUMP_SUB := - Add('JUMP SUB'); + OP_END_SUB := - Add('END SUB'); + OP_FIN_SUB := - Add('FIN SUB'); + OP_EPILOGUE_SUB := - Add('EPILOGUE SUB'); + + OP_BEGIN_GLOBAL_BLOCK := - Add('BEGIN GLOBAL BLOCK'); + OP_EPILOGUE_GLOBAL_BLOCK := - Add('EPILOGUE_GLOBAL_BLOCK'); + OP_EPILOGUE_GLOBAL_BLOCK2 := - Add('EPILOGUE_GLOBAL_BLOCK2'); + OP_END_GLOBAL_BLOCK := - Add('END GLOBAL BLOCK'); + + OP_ABSOLUTE := - Add('ABSOLUTE'); + + OP_ASSIGN_TYPE := - Add('ASSIGN TYPE'); + OP_DETERMINE_TYPE := - Add('DETERMINE TYPE'); + OP_ASSIGN_THE_SAME_TYPE := - Add('ASSIGN THE SAME TYPE'); + OP_ASSIGN_TYPE_ALIAS := - Add('ASSIGN TYPE ALIAS'); + OP_ASSIGN_LAMBDA_TYPES := - Add('ASSIGN LAMBDA TYPES'); + + OP_SAVE_EDX := - Add('SAVE EDX'); + OP_RESTORE_EDX := - Add('RESTORE EDX'); + + OP_BEGIN_WITH := - Add('BEGIN WITH'); + OP_END_WITH := - Add('END WITH'); + + OP_BEGIN_INIT_CONST := - Add('BEGIN INIT CONST'); + OP_END_INIT_CONST := - Add('END INIT CONST'); + + OP_CREATE_POINTER_TYPE := - Add('CREATE POINTER TYPE'); + OP_CREATE_CLASSREF_TYPE := - Add('CREATE CLASSREF TYPE'); + OP_ADDRESS := - Add('ADDRESS'); + OP_TERMINAL := - Add('TERMINAL'); + OP_ADDRESS_PROG := - Add('ADDRESS PROG'); + OP_ASSIGN_PROG := - Add('ASSIGN PROG'); + + OP_LVALUE := - Add('LVALUE'); + OP_POSTFIX_EXPRESSION := - Add('POSTFIX EXPRESSION'); + + OP_ASSIGN := - Add(':='); + OP_ASSIGN_CONST := - Add(':= (const)'); + OP_ASSIGN_ENUM := - Add(':= (enum)'); + OP_CHECK_SUBRANGE_TYPE := - Add('CHECK SUBRANGE TYPE'); + + OP_CREATE_DYNAMIC_ARRAY_TYPE := - Add('CREATE DYNARRAY TYPE'); + + OP_CREATE_SHORTSTRING_TYPE := - Add('CREATE SHORTSTRING TYPE'); + + OP_INC := - Add('INC'); + OP_DEC := - Add('DEC'); + OP_PRED := - Add('PRED'); + OP_SUCC := - Add('SUCC'); + OP_ORD := - Add('ORD'); + OP_CHR := - Add('CHR'); + OP_STR := - Add('STR'); + OP_LOW := - Add('LOW'); + OP_HIGH := - Add('HIGH'); + + OP_SET_LENGTH := - Add('SET LENGTH'); + OP_SET_LENGTH_EX := - Add('SET LENGTH EX'); + OP_PUSH_LENGTH := - Add('PUSH LENGTH'); + OP_DYNARRAY_ASSIGN := - Add(':= (dynarray)'); + OP_DYNARRAY_CLR := - Add('CLR (dynarray)'); + OP_DYNARRAY_HIGH := - Add('HIGH (dynarray)'); + OP_CREATE_EMPTY_DYNARRAY := - Add('CREATE EMPTY dynarray'); + + OP_SHORTSTRING_HIGH := - Add('HIGH (shortstring)'); + + OP_EXPORTS := - Add('EXPORTS'); + + OP_PLUS := - Add('+'); + OP_MINUS := - Add('-'); + OP_MULT := - Add('*'); + OP_DIV := - Add('/'); + OP_IDIV := - Add('DIV'); + OP_MOD := - Add('MOD'); + OP_SHL := - Add('SHL'); + OP_SHR := - Add('SHR'); + + OP_AND := - Add('AND'); + OP_OR := - Add('OR'); + OP_XOR := - Add('XOR'); + OP_NOT := - Add('NOT'); + + OP_NEG := - Add('NEG'); + OP_POSITIVE := - Add('POSITIVE'); + OP_ABS := - Add('ABS'); + + OP_EQ := - Add('='); + OP_NE := - Add('<>'); + OP_GT := - Add('>'); + OP_GE := - Add('>='); + OP_LT := - Add('<'); + OP_LE := - Add('<='); + + OP_CLASSNAME := - Add('CLASSNAME'); + + OP_GET_PROG := - Add('GET_PROG'); + + OP_IS := - Add('IS'); + OP_AS := - Add('AS'); + OP_TYPEINFO := - Add('TYPEINFO'); + OP_ADD_TYPEINFO := - Add('ADD_TYPEINFO'); + OP_INSTANCE_OF := - Add('INSTANCE OF'); + + OP_RET := - Add('RET'); + + OP_VAR_FROM_TVALUE := - Add('VAR FROM TVALUE'); + + OP_CURRENCY_FROM_INT64 := - Add('CURRENCY FROM INT64'); + OP_CURRENCY_FROM_UINT64 := - Add('CURRENCY FROM UINT64'); + OP_CURRENCY_FROM_INT := - Add('CURRENCY FROM INT'); + OP_CURRENCY_FROM_REAL := - Add('CURRENCY FROM REAL'); + + OP_INT_TO_DOUBLE := - Add('INT TO DOUBLE'); + OP_INT64_TO_DOUBLE := - Add('INT64 TO DOUBLE'); + OP_UINT64_TO_DOUBLE := - Add('UINT64 TO DOUBLE'); + + OP_INT_TO_SINGLE := - Add('INT TO SINGLE'); + OP_INT64_TO_SINGLE := - Add('INT64 TO SINGLE'); + OP_UINT64_TO_SINGLE := - Add('UINT64 TO SINGLE'); + + OP_INT_TO_EXTENDED := - Add('INT TO EXTENDED'); + OP_INT64_TO_EXTENDED := - Add('INT64 TO EXTENDED'); + OP_UINT64_TO_EXTENDED := - Add('UINT64 TO EXTENDED'); + + OP_INT_TO_INT64 := - Add('INT TO INT64'); + OP_BYTE_TO_INT64 := - Add('BYTE TO INT64'); + OP_WORD_TO_INT64 := - Add('WORD TO INT64'); + OP_CARDINAL_TO_INT64 := - Add('CARDINAL TO INT64'); + OP_SMALLINT_TO_INT64 := - Add('SMALLINT TO INT64'); + OP_SHORTINT_TO_INT64 := - Add('SHORTINT TO INT64'); + + OP_INT_FROM_INT64 := - Add('INT FROM INT64'); + OP_BYTE_FROM_INT64 := - Add('BYTE FROM INT64'); + OP_WORD_FROM_INT64 := - Add('WORD FROM INT64'); + OP_CARDINAL_FROM_INT64 := - Add('CARDINAL FROM INT64'); + OP_SMALLINT_FROM_INT64 := - Add('SMALLINT FROM INT64'); + OP_SHORTINT_FROM_INT64 := - Add('SHORTINT FROM INT64'); + + OP_INT_TO_UINT64 := - Add('INT TO UINT64'); + OP_BYTE_TO_UINT64 := - Add('BYTE TO UINT64'); + OP_WORD_TO_UINT64 := - Add('WORD TO UINT64'); + OP_CARDINAL_TO_UINT64 := - Add('CARDINAL TO UINT64'); + OP_SMALLINT_TO_UINT64 := - Add('SMALLINT TO UINT64'); + OP_SHORTINT_TO_UINT64 := - Add('SHORTINT TO UINT64'); + + OP_INT_FROM_UINT64 := - Add('INT FROM UINT64'); + OP_BYTE_FROM_UINT64 := - Add('BYTE FROM UINT64'); + OP_WORD_FROM_UINT64 := - Add('WORD FROM UINT64'); + OP_CARDINAL_FROM_UINT64 := - Add('CARDINAL FROM UINT64'); + OP_SMALLINT_FROM_UINT64 := - Add('SMALLINT FROM UINT64'); + OP_SHORTINT_FROM_UINT64 := - Add('SHORTINT FROM UINT64'); + + OP_CURRENCY_TO_EXTENDED := - Add('CURRENCY TO EXTENDED'); + OP_CURRENCY_TO_SINGLE := - Add('CURRENCY TO SINGLE'); + OP_DOUBLE_TO_SINGLE := - Add('DOUBLE TO SINGLE'); + OP_DOUBLE_TO_EXTENDED := - Add('DOUBLE TO EXTENDED'); + OP_SINGLE_TO_DOUBLE := - Add('SINGLE TO DOUBLE'); + OP_CURRENCY_TO_DOUBLE := - Add('CURRENCY TO DOUBLE'); + OP_SINGLE_TO_EXTENDED := - Add('SINGLE TO EXTENDED'); + OP_EXTENDED_TO_DOUBLE := - Add('EXTENDED TO DOUBLE'); + OP_EXTENDED_TO_SINGLE := - Add('EXTENDED TO SINGLE'); + + OP_PUSH_EBP := -Add('push ebp'); + OP_POP := -Add('pop'); + + OP_FIELD := - Add('FIELD'); + OP_ELEM := - Add('ELEM'); + + OP_ITEM := - Add('ITEM'); + OP_RECORD_ITEM := - Add('RECORD ITEM'); + + OP_PRINT := - Add('PRINT'); + OP_PRINT_EX := - Add('PRINT_EX'); + + OP_PRINT_KWD := - Add('PRINT KWD'); + OP_PRINTLN_KWD := - Add('PRINTLN KWD'); + + OP_SET_INCLUDE := - Add('SET INCLUDE'); + OP_SET_INCLUDE_INTERVAL := - Add('SET INCLUDE INTERVAL'); + OP_SET_EXCLUDE := - Add('SET EXCLUDE'); + OP_SET_MEMBERSHIP := -Add('SET MEMBERSHIP'); +{$IFNDEF PAXARM} + OP_INIT_PANSICHAR_LITERAL := - Add('INIT PANSICHAR LITERAL'); +{$ENDIF} + OP_INIT_PWIDECHAR_LITERAL := - Add('INIT PWIDECHAR LITERAL'); + + OP_SIZEOF := - Add('SIZEOF'); + + OP_SET_READ_ID := - Add('SET READ ID'); + OP_SET_WRITE_ID := - Add('SET WRITE ID'); + + OP_OLE_GET := - Add('OLE_GET'); + OP_OLE_SET := - Add('OLE_SET'); + OP_OLE_VALUE := - Add('OLE_VALUE'); + OP_OLE_PARAM := - Add('OLE_PARAM'); + + OP_PARAM_CHANGED := - Add('PARAM_CHANGED'); + + OP_ONCREATE_OBJECT := - Add('ON CREATE OBJECT'); + OP_ON_AFTER_OBJECT_CREATION := - Add('ON AFTER OBJECT CREATION'); + OP_CREATE_OBJECT := - Add('CREATE OBJECT'); + OP_DESTROY_OBJECT := - Add('DESTROY OBJECT'); + OP_GET_VMT_ADDRESS := - Add('GET VMT ADDRESS'); + OP_ADD_ANCESTOR := - Add('ADD ANCESTOR'); + OP_ADD_INTERFACE := - Add('ADD INTERFACE'); + OP_ADD_METHOD_INDEX := - Add('ADD METHOD INDEX'); + OP_ASSIGNED := - Add('ASSIGNED'); + + OP_ONCREATE_HOST_OBJECT := - Add('ON CREATE HOST_OBJECT'); + OP_ONDESTROY_HOST_OBJECT := - Add('ON DESTROY HOST OBJECT'); + + OP_BEFORE_CALL_HOST := - Add('ON BEFORE CALL HOST'); + OP_AFTER_CALL_HOST := - Add('ON AFTER CALL HOST'); + + OP_SET_SET_PROP := -Add('SET SET PROP'); + OP_SET_ORD_PROP := -Add('SET ORD PROP'); + OP_SET_INTERFACE_PROP := -Add('SET INTERFACE PROP'); +{$IFNDEF PAXARM} + OP_SET_ANSISTR_PROP := -Add('SET ANSISTR PROP'); + OP_SET_WIDESTR_PROP := -Add('SET WIDESTR PROP'); +{$ENDIF} + OP_SET_UNICSTR_PROP := -Add('SET UNICSTR PROP'); + OP_SET_FLOAT_PROP := -Add('SET FLOAT PROP'); + OP_SET_VARIANT_PROP := -Add('SET VARIANT PROP'); + OP_SET_INT64_PROP := -Add('SET INT64 PROP'); + + OP_SET_EVENT_PROP := -Add('SET EVENT PROP'); + OP_SET_EVENT_PROP2 := -Add('SET EVENT PROP2'); + + OP_VARARRAY_GET := -Add('VARARRAY GET'); + OP_VARARRAY_PUT := -Add('VARARRAY PUT'); + OP_VARARRAY_IDX := -Add('VARARRAY IDX'); + + OP_SAVE_REGS := - Add('SAVE REGS'); + OP_RESTORE_REGS := - Add('RESTORE REGS'); + + OP_ERR_ABSTRACT := - Add('ERR ABSTRACT'); + OP_UPDATE_DEFAULT_CONSTRUCTOR := - Add('UPDATE DEFAULT CONSTRUCTOR'); + OP_FIND_CONSTRUCTOR := - Add('FIND CONSTRUCTOR'); + + OP_BEGIN_CRT_JS_FUNC_OBJECT := - Add('BEGIN_CRT_JS_FUNC_OBJECT'); + OP_END_CRT_JS_FUNC_OBJECT := - Add('END_CRT_JS_FUNC_OBJECT'); + + OP_TO_JS_OBJECT := - Add('TO_JS_OBJECT'); + OP_JS_TYPEOF := - Add('JS_TYPEOF'); + OP_JS_VOID := - Add('JS_VOID'); + OP_JS_DELETE := - Add('JS_DELETE'); + + OP_TO_FW_OBJECT := - Add('TO_FW_OBJECT'); + + OP_ASSIGN_SHIFT := -Add('ASSIGN SHIFT'); + + OP_ASSIGN_INT_M := -Add(':= (integer, m)'); + + OP_CREATE_METHOD := -Add('CREATE METHOD'); + + OP_GET_ENUMERATOR := -Add('GET ENUMERATOR'); + OP_MOVE_NEXT := -Add('MOVE NEXT'); + OP_CURRENT := -Add('CURRENT'); + OP_LOCK_VARRAY := -Add('LOCK VARRAY'); + OP_UNLOCK_VARRAY := -Add('UNLOCK VARRAY'); + +/////////////////// DETAILED OPERATORS ///////////////////////////////// + +// OP_DUMMY := - Add('DUMMY'); + + OP_ASSIGN_BYTE_I := -Add(':= (byte, i)'); + OP_ASSIGN_BYTE_M := -Add(':= (byte, m)'); + OP_ASSIGN_WORD_I := -Add(':= (word, i)'); + OP_ASSIGN_WORD_M := -Add(':= (word, m)'); + OP_ASSIGN_CARDINAL_I := -Add(':= (cardinal, i)'); + OP_ASSIGN_CARDINAL_M := -Add(':= (cardinal, m)'); + OP_ASSIGN_SMALLINT_I := -Add(':= (smallint, i)'); + OP_ASSIGN_SMALLINT_M := -Add(':= (smallint, m)'); + OP_ASSIGN_SHORTINT_I := -Add(':= (shortint, i)'); + OP_ASSIGN_SHORTINT_M := -Add(':= (shortint, m)'); + OP_ASSIGN_INT_I := -Add(':= (integer, i)'); +// OP_ASSIGN_INT_M := -Add(':= (integer, m)'); + OP_ASSIGN_DOUBLE := -Add(':= (double)'); + OP_ASSIGN_CURRENCY := -Add(':= (currency)'); + OP_ASSIGN_EVENT := -Add(':= (event)'); + OP_ASSIGN_SINGLE := -Add(':= (single)'); + OP_ASSIGN_EXTENDED := -Add(':= (extended)'); +{$IFNDEF PAXARM} + OP_ASSIGN_PANSICHAR := -Add(':= (pansichar)'); +{$ENDIF} + OP_ASSIGN_PWIDECHAR := -Add(':= (pwidechar)'); + OP_ASSIGN_INT64 := -Add(':= (int64)'); + OP_ASSIGN_UINT64 := -Add(':= (uint64)'); + OP_ASSIGN_INTERFACE := -Add(':= (interface)'); + + OP_CREATE_EVENT := -Add('create event'); + + OP_MULT_INT64 := -Add('* (int64)'); + OP_IDIV_INT64 := -Add('div (int64)'); + OP_MOD_INT64 := -Add('mod (int64)'); + OP_SHL_INT64 := -Add('shl (int64)'); + OP_SHR_INT64 := -Add('shr (int64)'); + +{$IFNDEF PAXARM} + OP_ANSISTRING_FROM_PANSICHAR := -Add('ANSISTRING FROM PANSICHAR'); + OP_ANSISTRING_FROM_PWIDECHAR := -Add('ANSISTRING FROM PWIDECHAR'); + OP_ANSISTRING_FROM_ANSICHAR := -Add('ANSISTRING FROM ANSICHAR'); + OP_ASSIGN_ANSISTRING := -Add(':= (ansistring)'); + OP_ASSIGN_SHORTSTRING := -Add(':= (shortstring)'); + OP_ASSIGN_WIDESTRING := -Add(':= (widestring)'); +{$ENDIF} + OP_ASSIGN_UNICSTRING := -Add(':= (unicstring)'); + OP_ASSIGN_VARIANT := -Add(':= (variant)'); + OP_ASSIGN_OLEVARIANT := -Add(':= (olevariant)'); + + OP_ASSIGN_CLASS := -Add(':= (class)'); + + OP_ASSIGN_TVarRec := -Add(':= (TVarRec)'); + + OP_ASSIGN_RECORD := -Add(':= (record)'); + OP_ASSIGN_ARRAY := -Add(':= (array)'); +{$IFNDEF PAXARM} + OP_SHORTSTRING_FROM_PANSICHAR_LITERAL := -Add('SHORTSTRING FROM PANSICHAR LITERAL'); + OP_SHORTSTRING_FROM_PWIDECHAR_LITERAL := -Add('SHORTSTRING FROM PWIDECHAR LITERAL'); + OP_SHORTSTRING_FROM_ANSICHAR := -Add('SHORTSTRING FROM ANSICHAR'); + OP_SHORTSTRING_FROM_WIDECHAR := -Add('SHORTSTRING FROM WIDECHAR'); + OP_SHORTSTRING_FROM_ANSISTRING := -Add('SHORTSTRING FROM ANSISTRING'); + OP_SHORTSTRING_FROM_WIDESTRING := -Add('SHORTSTRING FROM WIDESTRING'); + OP_UNICSTRING_FROM_WIDESTRING := -Add('UNICSTRING FROM WIDESTRING'); + OP_SHORTSTRING_FROM_UNICSTRING := -Add('SHORTSTRING FROM UNICSTRING'); + OP_ANSISTRING_FROM_SHORTSTRING := -Add('ANSISTRING FROM SHORTSTRING'); + + OP_WIDESTRING_FROM_PANSICHAR_LITERAL := -Add('WIDESTRING FROM PANSICHAR LITERAL'); + OP_WIDESTRING_FROM_PWIDECHAR_LITERAL := -Add('WIDESTRING FROM PWIDECHAR LITERAL'); + OP_WIDESTRING_FROM_ANSICHAR := -Add('WIDESTRING FROM ANSICHAR'); + OP_WIDESTRING_FROM_WIDECHAR := -Add('WIDESTRING FROM WIDECHAR'); + OP_ANSISTRING_FROM_WIDECHAR := -Add('ANSISTRING FROM WIDECHAR'); + OP_WIDESTRING_FROM_WIDECHAR_LITERAL := -Add('WIDESTRING FROM WIDECHAR LITERAL'); + OP_WIDESTRING_FROM_ANSISTRING := -Add('WIDESTRING FROM ANSISTRING'); + OP_UNICSTRING_FROM_ANSISTRING := -Add('UNICSTRING FROM ANSISTRING'); + OP_WIDESTRING_FROM_SHORTSTRING := -Add('WIDESTRING FROM SHORTSTRING'); + OP_WIDESTRING_FROM_UNICSTRING := -Add('WIDESTRING FROM UNICSTRING'); + OP_UNICSTRING_FROM_SHORTSTRING := -Add('UNICSTRING FROM SHORTSTRING'); + OP_ANSISTRING_FROM_WIDESTRING := -Add('ANSISTRING FROM WIDESTRING'); + OP_ANSISTRING_FROM_UNICSTRING := -Add('ANSISTRING FROM UNICSTRING'); + + OP_UNICSTRING_FROM_PANSICHAR_LITERAL := -Add('UNICSTRING FROM PANSICHAR LITERAL'); + OP_UNICSTRING_FROM_ANSICHAR := -Add('UNICSTRING FROM ANSICHAR'); +{$ENDIF} + OP_UNICSTRING_FROM_PWIDECHAR_LITERAL := -Add('UNICSTRING FROM PWIDECHAR LITERAL'); + OP_UNICSTRING_FROM_WIDECHAR := -Add('UNICSTRING FROM WIDECHAR'); + OP_UNICSTRING_FROM_WIDECHAR_LITERAL := -Add('UNICSTRING FROM WIDECHAR LITERAL'); + + OP_VARIANT_FROM_CLASS := -Add('VARIANT FROM CLASS'); // JS only + OP_VARIANT_FROM_POINTER := -Add('VARIANT FROM POINTER'); // JS only + OP_CLASS_FROM_VARIANT := -Add('CLASS FROM VARIANT'); // JS only + + OP_INTERFACE_FROM_CLASS := -Add('INTERFACE FROM CLASS'); + OP_INTERFACE_CAST := -Add('INTERFACE CAST'); +{$IFNDEF PAXARM} + OP_VARIANT_FROM_PANSICHAR_LITERAL := -Add('VARIANT FROM PANSICHAR LITERAL'); + OP_VARIANT_FROM_ANSISTRING := -Add('VARIANT FROM ANSISTRING'); + OP_VARIANT_FROM_WIDESTRING := -Add('VARIANT FROM WIDESTRING'); + OP_VARIANT_FROM_SHORTSTRING := -Add('VARIANT FROM SHORTSTRING'); + OP_VARIANT_FROM_ANSICHAR := -Add('VARIANT FROM ANSICHAR'); +{$ENDIF} + OP_VARIANT_FROM_UNICSTRING := -Add('VARIANT FROM UNICSTRING'); + OP_VARIANT_FROM_PWIDECHAR_LITERAL := -Add('VARIANT FROM PWIDECHAR LITERAL'); + OP_VARIANT_FROM_WIDECHAR := -Add('VARIANT FROM WIDECHAR'); + OP_VARIANT_FROM_WIDECHAR_LITERAL := -Add('VARIANT FROM WIDECHAR LITERAL'); + OP_VARIANT_FROM_INT := -Add('VARIANT FROM INT'); + OP_VARIANT_FROM_INT64 := -Add('VARIANT FROM INT64'); + OP_VARIANT_FROM_BYTE := -Add('VARIANT FROM BYTE'); + OP_VARIANT_FROM_BOOL := -Add('VARIANT FROM BOOL'); + OP_VARIANT_FROM_WORD := -Add('VARIANT FROM WORD'); + OP_VARIANT_FROM_CARDINAL := -Add('VARIANT FROM CARDINAL'); + OP_VARIANT_FROM_SMALLINT := -Add('VARIANT FROM SMALLINT'); + OP_VARIANT_FROM_SHORTINT := -Add('VARIANT FROM SHORTINT'); + OP_VARIANT_FROM_DOUBLE := -Add('VARIANT FROM DOUBLE'); + OP_VARIANT_FROM_CURRENCY := -Add('VARIANT FROM CURRENCY'); + OP_VARIANT_FROM_SINGLE := -Add('VARIANT FROM SINGLE'); + OP_VARIANT_FROM_EXTENDED := -Add('VARIANT FROM EXTENDED'); + OP_VARIANT_FROM_INTERFACE := -Add('VARIANT FROM INTERFACE'); + + OP_OLEVARIANT_FROM_VARIANT := -Add('OLEVARIANT FROM VARIANT'); +{$IFNDEF PAXARM} + OP_OLEVARIANT_FROM_PANSICHAR_LITERAL := -Add('OLEVARIANT FROM PANSICHAR LITERAL'); + OP_OLEVARIANT_FROM_ANSISTRING := -Add('OLEVARIANT FROM ANSISTRING'); + OP_OLEVARIANT_FROM_WIDESTRING := -Add('OLEVARIANT FROM WIDESTRING'); + OP_OLEVARIANT_FROM_UNICSTRING := -Add('OLEVARIANT FROM UNICSTRING'); + OP_OLEVARIANT_FROM_SHORTSTRING := -Add('OLEVARIANT FROM SHORTSTRING'); + OP_OLEVARIANT_FROM_ANSICHAR := -Add('OLEVARIANT FROM ANSICHAR'); +{$ENDIF} + OP_OLEVARIANT_FROM_PWIDECHAR_LITERAL := -Add('OLEVARIANT FROM PWIDECHAR LITERAL'); + OP_OLEVARIANT_FROM_WIDECHAR := -Add('OLEVARIANT FROM WIDECHAR'); + OP_OLEVARIANT_FROM_WIDECHAR_LITERAL := -Add('OLEVARIANT FROM WIDECHAR LITERAL'); + OP_OLEVARIANT_FROM_INT := -Add('OLEVARIANT FROM INT'); + OP_OLEVARIANT_FROM_INT64 := -Add('OLEVARIANT FROM INT64'); + OP_OLEVARIANT_FROM_BYTE := -Add('OLEVARIANT FROM BYTE'); + OP_OLEVARIANT_FROM_BOOL := -Add('OLEVARIANT FROM BOOL'); + OP_OLEVARIANT_FROM_WORD := -Add('OLEVARIANT FROM WORD'); + OP_OLEVARIANT_FROM_CARDINAL := -Add('OLEVARIANT FROM CARDINAL'); + OP_OLEVARIANT_FROM_SMALLINT := -Add('OLEVARIANT FROM SMALLINT'); + OP_OLEVARIANT_FROM_SHORTINT := -Add('OLEVARIANT FROM SHORTINT'); + OP_OLEVARIANT_FROM_DOUBLE := -Add('OLEVARIANT FROM DOUBLE'); + OP_OLEVARIANT_FROM_CURRENCY := -Add('OLEVARIANT FROM CURRENCY'); + OP_OLEVARIANT_FROM_SINGLE := -Add('OLEVARIANT FROM SINGLE'); + OP_OLEVARIANT_FROM_EXTENDED := -Add('OLEVARIANT FROM EXTENDED'); + OP_OLEVARIANT_FROM_INTERFACE := -Add('OLEVARIANT FROM INTERFACE'); +{$IFNDEF PAXARM} + OP_ANSISTRING_FROM_INT := -Add('ANSISTRING FROM INT'); // JS only + OP_ANSISTRING_FROM_DOUBLE := -Add('ANSISTRING FROM DOUBLE'); // JS only + OP_ANSISTRING_FROM_SINGLE := -Add('ANSISTRING FROM SINGLE'); // JS only + OP_ANSISTRING_FROM_EXTENDED := -Add('ANSISTRING FROM EXTENDED'); // JS only + OP_ANSISTRING_FROM_BOOLEAN := -Add('ANSISTRING FROM BOOLEAN'); // JS only +{$ENDIF} + OP_UNICSTRING_FROM_INT := -Add('UNICSTRING FROM INT'); // JS only + OP_UNICSTRING_FROM_DOUBLE := -Add('UNICSTRING FROM DOUBLE'); // JS only + OP_UNICSTRING_FROM_SINGLE := -Add('UNICSTRING FROM SINGLE'); // JS only + OP_UNICSTRING_FROM_EXTENDED := -Add('UNICSTRING FROM EXTENDED'); // JS only + OP_UNICSTRING_FROM_BOOLEAN := -Add('UNICSTRING FROM BOOLEAN'); // JS only + + + OP_JS_FUNC_OBJ_FROM_VARIANT := -Add('JS FUNC OBJ FROM VARIANT'); // JS only +{$IFNDEF PAXARM} + OP_ANSICHAR_FROM_VARIANT := -Add('ANSICHAR FROM VARIANT'); + OP_ANSISTRING_FROM_VARIANT := -Add('ANSISTRING FROM VARIANT'); + OP_WIDESTRING_FROM_VARIANT := -Add('WIDESTRING FROM VARIANT'); + OP_SHORTSTRING_FROM_VARIANT := -Add('SHORTSTRING FROM VARIANT'); +{$ENDIF} + OP_UNICSTRING_FROM_VARIANT := -Add('UNICSTRING FROM VARIANT'); + OP_WIDECHAR_FROM_VARIANT := -Add('WIDECHAR FROM VARIANT'); + OP_DOUBLE_FROM_VARIANT := -Add('DOUBLE FROM VARIANT'); + OP_CURRENCY_FROM_VARIANT := -Add('CURRENCY FROM VARIANT'); + OP_SINGLE_FROM_VARIANT := -Add('SINGLE FROM VARIANT'); + OP_EXTENDED_FROM_VARIANT := -Add('EXTENDED FROM VARIANT'); + OP_INT64_FROM_VARIANT := -Add('INT64 FROM VARIANT'); + OP_UINT64_FROM_VARIANT := -Add('UINT64 FROM VARIANT'); + OP_INT_FROM_VARIANT := -Add('INT FROM VARIANT'); + OP_BYTE_FROM_VARIANT := -Add('BYTE FROM VARIANT'); + OP_WORD_FROM_VARIANT := -Add('WORD FROM VARIANT'); + OP_CARDINAL_FROM_VARIANT := -Add('CARDINAL FROM VARIANT'); + OP_BOOL_FROM_VARIANT := -Add('BOOL FROM VARIANT'); + OP_BYTEBOOL_FROM_VARIANT := -Add('BYTEBOOL FROM VARIANT'); + OP_WORDBOOL_FROM_VARIANT := -Add('WORDBOOL FROM VARIANT'); + OP_LONGBOOL_FROM_VARIANT := -Add('LONGBOOL FROM VARIANT'); + OP_SMALLINT_FROM_VARIANT := -Add('SMALLINT FROM VARIANT'); + OP_SHORTINT_FROM_VARIANT := -Add('SHORTINT FROM VARIANT'); + + OP_BOOL_FROM_BYTEBOOL := -Add('BOOL FROM BYTEBOOL'); + OP_BOOL_FROM_WORDBOOL := -Add('BOOL FROM WORDBOOL'); + OP_BOOL_FROM_LONGBOOL := -Add('BOOL FROM LONGBOOL'); + + OP_NOT_BOOL := -Add('not (boolean)'); + OP_NOT_BYTEBOOL := -Add('not (bytebool)'); + OP_NOT_WORDBOOL := -Add('not (wordbool)'); + OP_NOT_LONGBOOL := -Add('not (longbool)'); + + OP_NOT_VARIANT := -Add('not (variant)'); + OP_NEG_VARIANT := -Add('neg (variant)'); + OP_ADD_VARIANT := -Add('+ (variant)'); + OP_SUB_VARIANT := -Add('- (variant)'); + OP_MULT_VARIANT := -Add('* (variant)'); + OP_DIV_VARIANT := -Add('/ (variant)'); + OP_IDIV_VARIANT := -Add('div (variant)'); + OP_MOD_VARIANT := -Add('mod (variant)'); + OP_SHL_VARIANT := -Add('shl (variant)'); + OP_SHR_VARIANT := -Add('shr (variant)'); + OP_AND_VARIANT := -Add('and (variant)'); + OP_OR_VARIANT := -Add('or (variant)'); + OP_XOR_VARIANT := -Add('xor (variant)'); + OP_LT_VARIANT := -Add('< (variant)'); + OP_LE_VARIANT := -Add('<= (variant)'); + OP_GT_VARIANT := -Add('> (variant)'); + OP_GE_VARIANT := -Add('>= (variant)'); + OP_EQ_VARIANT := -Add('= (variant)'); + OP_NE_VARIANT := -Add('<> (variant)'); + + OP_EQ_EVENT := -Add('= (event)'); + OP_NE_EVENT := -Add('<> (event)'); + + OP_VARIANT_CLR := -Add('VARIANT CLR'); +{$IFNDEF PAXARM} + OP_ADD_ANSISTRING := -Add('+ (ansistring)'); + OP_ADD_SHORTSTRING := -Add('+ (shortstring)'); + OP_ADD_WIDESTRING := -Add('+ (widestring)'); +{$ENDIF} + OP_ADD_UNICSTRING := -Add('+ (unicstring)'); + + OP_EQ_STRUCT := -Add('= (struct)'); + OP_NE_STRUCT := -Add('<> (struct)'); +{$IFNDEF PAXARM} + OP_EQ_ANSISTRING := -Add('= (ansistring)'); + OP_EQ_SHORTSTRING := -Add('= (shortstring)'); + OP_EQ_WIDESTRING := -Add('= (widestring)'); +{$ENDIF} + OP_EQ_UNICSTRING := -Add('= (unicstring)'); +{$IFNDEF PAXARM} + OP_NE_ANSISTRING := -Add('<> (ansistring)'); + OP_NE_SHORTSTRING := -Add('<> (shortstring)'); + OP_NE_WIDESTRING := -Add('<> (widestring)'); +{$ENDIF} + OP_NE_UNICSTRING := -Add('<> (unicstring)'); + +{$IFNDEF PAXARM} + OP_GT_ANSISTRING := -Add('> (ansistring)'); + OP_GE_ANSISTRING := -Add('>= (ansistring)'); + OP_LT_ANSISTRING := -Add('< (ansistring)'); + OP_LE_ANSISTRING := -Add('<= (ansistring)'); + + OP_GT_SHORTSTRING := -Add('> (shortstring)'); + OP_GE_SHORTSTRING := -Add('>= (shortstring)'); + OP_LT_SHORTSTRING := -Add('< (shortstring)'); + OP_LE_SHORTSTRING := -Add('<= (shortstring)'); + + OP_GT_WIDESTRING := -Add('> (widestring)'); + OP_GE_WIDESTRING := -Add('>= (widestring)'); + OP_LT_WIDESTRING := -Add('< (widestring)'); + OP_LE_WIDESTRING := -Add('<= (widestring)'); +{$ENDIF} + OP_GT_UNICSTRING := -Add('> (unicstring)'); + OP_GE_UNICSTRING := -Add('>= (unicstring)'); + OP_LT_UNICSTRING := -Add('< (unicstring)'); + OP_LE_UNICSTRING := -Add('<= (unicstring)'); + +{$IFNDEF PAXARM} + OP_ANSISTRING_CLR := -Add('ANSISTRING CLR'); + OP_WIDESTRING_CLR := -Add('WIDESTRING CLR'); +{$ENDIF} + OP_UNICSTRING_CLR := -Add('UNICSTRING CLR'); + OP_STRUCTURE_CLR := -Add('STRUCTURE CLR'); + OP_INTERFACE_CLR := -Add('INTERFACE CLR'); + OP_CLASS_CLR := -Add('CLASS CLR'); + + OP_STRUCTURE_ADDREF := -Add('STRUCTURE ADDREF'); + OP_ADDREF := -Add('ADDREF'); + + OP_ADD_INT_MI := -Add('+ (integer, mi)'); + OP_ADD_INT_MM := -Add('+ (integer, mm)'); + + OP_SUB_INT_MI := -Add('- (integer, mi)'); + OP_SUB_INT_MM := -Add('- (integer, mm)'); + + OP_IMUL_INT_MI := -Add('imul (integer, mi)'); + OP_IMUL_INT_MM := -Add('imul (integer, mm)'); + + OP_IDIV_INT_MI := -Add('idiv (integer, mi)'); + OP_IDIV_INT_MM := -Add('idiv (integer, mm)'); + OP_IDIV_INT_IM := -Add('idiv (integer, im)'); + + OP_MOD_INT_MI := -Add('mod (integer, mi)'); + OP_MOD_INT_MM := -Add('mod (integer, mm)'); + OP_MOD_INT_IM := -Add('mod (integer, im)'); + + OP_SHL_INT_MI := -Add('shl (integer, mi)'); + OP_SHL_INT_MM := -Add('shl (integer, mm)'); + OP_SHL_INT_IM := -Add('shl (integer, im)'); + + OP_SHR_INT_MI := -Add('shr (integer, mi)'); + OP_SHR_INT_MM := -Add('shr (integer, mm)'); + OP_SHR_INT_IM := -Add('shr (integer, im)'); + + OP_AND_INT_MI := -Add('and (integer, mi)'); + OP_AND_INT_MM := -Add('and (integer, mm)'); + + OP_OR_INT_MI := -Add('or (integer, mi)'); + OP_OR_INT_MM := -Add('or (integer, mm)'); + + OP_XOR_INT_MI := -Add('xor (integer, mi)'); + OP_XOR_INT_MM := -Add('xor (integer, mm)'); + + OP_NEG_INT := -Add('NEG (integer)'); + OP_NEG_INT64 := -Add('NEG64 (integer)'); + OP_NEG_UINT64 := -Add('NEGU64 (integer)'); + + OP_ABS_INT := -Add('ABS (integer)'); + OP_ABS_INT64 := -Add('ABS (int64)'); + OP_ABS_DOUBLE := -Add('ABS (double)'); + OP_ABS_SINGLE := -Add('ABS (single)'); + OP_ABS_EXTENDED := -Add('ABS (extended)'); + OP_ABS_CURRENCY := -Add('ABS (currency)'); + OP_ABS_VARIANT := -Add('ABS (variant)'); + + OP_LT_INT_MI := -Add('< (integer, mi)'); + OP_LT_INT_MM := -Add('< (integer, mm)'); + + OP_LE_INT_MI := -Add('<= (integer, mi)'); + OP_LE_INT_MM := -Add('<= (integer, mm)'); + + OP_GT_INT_MI := -Add('> (integer, mi)'); + OP_GT_INT_MM := -Add('> (integer, mm)'); + + OP_GE_INT_MI := -Add('>= (integer, mi)'); + OP_GE_INT_MM := -Add('>= (integer, mm)'); + + OP_EQ_INT_MI := -Add('= (integer, mi)'); + OP_EQ_INT_MM := -Add('= (integer, mm)'); + + OP_NE_INT_MI := -Add('<> (integer, mi)'); + OP_NE_INT_MM := -Add('<> (integer, mm)'); + + OP_ADD_INT64 := -Add('+ (int64)'); + OP_SUB_INT64 := -Add('- (int64)'); + OP_AND_INT64 := -Add('AND (int64)'); + OP_OR_INT64 := -Add('OR (int64)'); + OP_XOR_INT64 := -Add('XOR (int64)'); + + OP_ADD_UINT64 := -Add('+ (uint64)'); + OP_SUB_UINT64 := -Add('- (uint64)'); + OP_AND_UINT64 := -Add('AND (uint64)'); + OP_OR_UINT64 := -Add('OR (uint64)'); + OP_XOR_UINT64 := -Add('XOR (uint64)'); + + OP_LT_INT64 := -Add('< (int64)'); + OP_LE_INT64 := -Add('<= (int64)'); + OP_GT_INT64 := -Add('> (int64)'); + OP_GE_INT64 := -Add('>= (int64)'); + OP_EQ_INT64 := -Add('= (int64)'); + OP_NE_INT64 := -Add('<> (int64)'); + + OP_LT_UINT64 := -Add('< (uint64)'); + OP_LE_UINT64 := -Add('<= (uint64)'); + OP_GT_UINT64 := -Add('> (uint64)'); + OP_GE_UINT64 := -Add('>= (uint64)'); + + OP_ADD_CURRENCY := -Add('+ (currency)'); + OP_SUB_CURRENCY := -Add('- (currency)'); + OP_MUL_CURRENCY := -Add('* (currency)'); + OP_DIV_CURRENCY := -Add('/ (currency)'); + + OP_LT_CURRENCY := -Add('< (currency)'); + OP_LE_CURRENCY := -Add('<= (currency)'); + OP_GT_CURRENCY := -Add('> (currency)'); + OP_GE_CURRENCY := -Add('>= (currency)'); + OP_EQ_CURRENCY := -Add('= (currency)'); + OP_NE_CURRENCY := -Add('<> (currency)'); + + OP_ADD_DOUBLE := -Add('+ (double)'); + OP_SUB_DOUBLE := -Add('- (double)'); + OP_MUL_DOUBLE := -Add('* (double)'); + OP_DIV_DOUBLE := -Add('/ (double)'); + + OP_NEG_DOUBLE := -Add('NEG (double)'); + OP_NEG_CURRENCY := -Add('NEG (currency)'); + + OP_LT_DOUBLE := -Add('< (double)'); + OP_LE_DOUBLE := -Add('<= (double)'); + OP_GT_DOUBLE := -Add('> (double)'); + OP_GE_DOUBLE := -Add('>= (double)'); + OP_EQ_DOUBLE := -Add('= (double)'); + OP_NE_DOUBLE := -Add('<> (double)'); + + OP_ADD_SINGLE := -Add('+ (single)'); + OP_SUB_SINGLE := -Add('- (single)'); + OP_MUL_SINGLE := -Add('* (single)'); + OP_DIV_SINGLE := -Add('/ (single)'); + + OP_NEG_SINGLE := -Add('NEG (single)'); + + OP_LT_SINGLE := -Add('< (single)'); + OP_LE_SINGLE := -Add('<= (single)'); + OP_GT_SINGLE := -Add('> (single)'); + OP_GE_SINGLE := -Add('>= (single)'); + OP_EQ_SINGLE := -Add('= (single)'); + OP_NE_SINGLE := -Add('<> (single)'); + + OP_ADD_EXTENDED := -Add('+ (extended)'); + OP_SUB_EXTENDED := -Add('- (EXTENDED)'); + OP_MUL_EXTENDED := -Add('* (EXTENDED)'); + OP_DIV_EXTENDED := -Add('/ (EXTENDED)'); + + OP_NEG_EXTENDED := -Add('NEG (EXTENDED)'); + + OP_LT_EXTENDED := -Add('< (EXTENDED)'); + OP_LE_EXTENDED := -Add('<= (EXTENDED)'); + OP_GT_EXTENDED := -Add('> (EXTENDED)'); + OP_GE_EXTENDED := -Add('>= (EXTENDED)'); + OP_EQ_EXTENDED := -Add('= (EXTENDED)'); + OP_NE_EXTENDED := -Add('<> (EXTENDED)'); + + OP_PUSH_PROG := -Add('push prog'); + OP_PUSH_ADDRESS := -Add('push address'); + OP_PUSH_STRUCTURE := -Add('push struct'); + OP_PUSH_SET := -Add('push set'); + + OP_PUSH_BYTE_IMM := -Add('push (byte i)'); + OP_PUSH_BYTE := -Add('push (byte)'); + OP_PUSH_WORD_IMM := -Add('push (word i)'); + OP_PUSH_WORD := -Add('push (word)'); + OP_PUSH_CARDINAL_IMM := -Add('push (cardinal i)'); + OP_PUSH_CARDINAL := -Add('push (cardinal)'); + OP_PUSH_SMALLINT_IMM := -Add('push (smallint i)'); + OP_PUSH_SMALLINT := -Add('push (smallint)'); + OP_PUSH_SHORTINT_IMM := -Add('push (shortint i)'); + OP_PUSH_SHORTINT := -Add('push (shortint)'); + OP_PUSH_INT_IMM := -Add('push (int i)'); + OP_PUSH_INT := -Add('push (int)'); + OP_PUSH_PTR := -Add('push (ptr)'); + + OP_PUSH_DOUBLE := -Add('push (double)'); + OP_PUSH_CURRENCY := -Add('push (currency)'); + OP_PUSH_SINGLE := -Add('push (single)'); + OP_PUSH_EXTENDED := -Add('push (extended)'); + + OP_PUSH_INT64 := -Add('push (int64)'); + OP_PUSH_DATA := -Add('push (data)'); + OP_PUSH_EVENT := -Add('push (event)'); +{$IFNDEF PAXARM} + OP_PUSH_ANSISTRING := -Add('push (ansistring)'); + OP_PUSH_SHORTSTRING := -Add('push (shortstring)'); + OP_PUSH_WIDESTRING := -Add('push (widestring)'); + OP_PUSH_PANSICHAR_IMM := -Add('push (pansichar i)'); +{$ENDIF} + OP_PUSH_PWIDECHAR_IMM := -Add('push (pwidechar i)'); + OP_PUSH_UNICSTRING := -Add('push (unicstring)'); + OP_PUSH_INST := -Add('push inst'); + OP_PUSH_CLSREF := -Add('push clsref'); + OP_PUSH_DYNARRAY := -Add('push dynarray'); + OP_PUSH_OPENARRAY := -Add('push openarray'); + + OP_SET_ASSIGN := -Add('SET ASSIGN'); + OP_SET_COUNTER_ASSIGN := -Add('SET COUNTER ASSIGN'); + OP_SET_UNION := -Add('SET UNION'); + OP_SET_DIFFERENCE := -Add('SET DIFFERENCE'); + OP_SET_INTERSECTION := -Add('SET INTERSECTION'); + OP_SET_SUBSET := -Add('SET SUBSET'); + OP_SET_SUPERSET := -Add('SET SUPERSET'); + OP_SET_EQUALITY := -Add('SET EQUALITY'); + OP_SET_INEQUALITY := -Add('SET INEQUALITY'); + + OP_DETERMINE_PROP := -Add('DETERMINE PROP'); + + OP_GET_COMPONENT := -Add('GET COMPONENT'); + + OP_GET_DRTTI_PROP := -Add('GET DRTTI PROP'); + OP_SET_DRTTI_PROP := -Add('SET DRTTI PROP'); +{$IFNDEF PAXARM} + OP_GET_ANSISTR_PROP := -Add('GET ANSISTR PROP'); + OP_GET_WIDESTR_PROP := -Add('GET WIDESTR PROP'); +{$ENDIF} + OP_GET_UNICSTR_PROP := -Add('GET UNICSTR PROP'); + OP_GET_ORD_PROP := -Add('GET ORD PROP'); + OP_GET_SET_PROP := -Add('GET SET PROP'); + OP_GET_INTERFACE_PROP := -Add('GET INTERFACE PROP'); + OP_GET_FLOAT_PROP := -Add('GET FLOAT PROP'); + OP_GET_VARIANT_PROP := -Add('GET VARIANT PROP'); + OP_GET_INT64_PROP := -Add('GET INT64 PROP'); + OP_GET_EVENT_PROP := -Add('GET EVENT PROP'); + +{$IFDEF UNIC} + OP_ADD_STRING := OP_ADD_UNICSTRING; +{$ELSE} + OP_ADD_STRING := OP_ADD_ANSISTRING; +{$ENDIF} + OP_ADD_MESSAGE := - Add('ADD MESSAGE'); + + OP_DUMMY := - Add('DUMMY'); + + if IsDump then + SaveToFile(DUMP_PATH + 'operators.txt'); + end; + + PushOperators := TIntegerList.Create; + with PushOperators do + begin + Add(OP_PUSH_ADDRESS); + Add(OP_PUSH_STRUCTURE); + Add(OP_PUSH_SET); + + Add(OP_PUSH_BYTE_IMM); + Add(OP_PUSH_BYTE); + Add(OP_PUSH_WORD_IMM); + Add(OP_PUSH_WORD); + Add(OP_PUSH_CARDINAL_IMM); + Add(OP_PUSH_CARDINAL); + Add(OP_PUSH_SMALLINT_IMM); + Add(OP_PUSH_SMALLINT); + Add(OP_PUSH_SHORTINT_IMM); + Add(OP_PUSH_SHORTINT); + Add(OP_PUSH_INT_IMM); + Add(OP_PUSH_INT); + + Add(OP_PUSH_DOUBLE); + Add(OP_PUSH_CURRENCY); + Add(OP_PUSH_SINGLE); + Add(OP_PUSH_EXTENDED); + + Add(OP_PUSH_INT64); + Add(OP_PUSH_DATA); + Add(OP_PUSH_EVENT); +{$IFNDEF PAXARM} + Add(OP_PUSH_ANSISTRING); + Add(OP_PUSH_SHORTSTRING); + Add(OP_PUSH_WIDESTRING); + Add(OP_PUSH_PANSICHAR_IMM); +{$ENDIF} + Add(OP_PUSH_UNICSTRING); + Add(OP_PUSH_PWIDECHAR_IMM); +// Add(OP_PUSH_INST); +// Add(OP_PUSH_CLSREF); + Add(OP_PUSH_DYNARRAY); + Add(OP_PUSH_OPENARRAY); + end; + + AsmOperators := TStringList.Create; + with AsmOperators do + begin + ASM_NOP := Add('NOP'); + ASM_WAIT := Add('WAIT'); + ASM_CLC := Add('CLC'); + ASM_PUSHFD := Add('PUSHFD'); + ASM_POPFD := Add('POPFD'); + + ASM_XCHG := Add('XCHG'); + + ASM_MOV := Add('MOV'); + ASM_LEA := Add('LEA'); + ASM_TEST := Add('TEST'); + + ASM_ADD := Add('ADD'); + ASM_ADC := Add('ADC'); + ASM_SBB := Add('SBB'); + ASM_NEG := Add('NEG'); + ASM_NOT := Add('NOT'); + ASM_SUB := Add('SUB'); + ASM_MUL := Add('MUL'); + ASM_IMUL := Add('IMUL'); + ASM_DIV := Add('DIV'); + ASM_IDIV := Add('IDIV'); + ASM_XOR := Add('XOR'); + ASM_AND := Add('AND'); + ASM_OR := Add('OR'); + ASM_SHL := Add('SHL'); + ASM_SHR := Add('SHR'); + + ASM_CDQ := Add('CDQ'); + + ASM_CALL := Add('CALL'); + ASM_RET := Add('RET'); + ASM_PUSH := Add('PUSH'); + ASM_POP := Add('POP'); + ASM_JMP := Add('JMP'); + + ASM_JNO := Add('JNO'); + ASM_JNC := Add('JNC'); + ASM_JZ := Add('JZ'); + ASM_JNZ := Add('JNZ'); + ASM_JBE := Add('JBE'); + ASM_JNLE:= Add('JNLE'); + + ASM_FLD := Add('FLD'); + ASM_FILD := Add('FILD'); + ASM_FISTP := Add('FISTP'); + ASM_FSTP := Add('FSTP'); + ASM_FADD := Add('FADD'); + ASM_FSUB := Add('FSUB'); + ASM_FMUL := Add('FMUL'); + ASM_FDIV := Add('FDIV'); + ASM_FCOMP := Add('FCOMP'); + ASM_FCOMPP := Add('FCOMPP'); + ASM_FSTSV := Add('FSTSV'); + ASM_SAHF := Add('SAHF'); + ASM_FCHS := Add('FCHS'); + ASM_FABS := Add('FABS'); + + ASM_SETL := Add('SETL'); // < + ASM_SETLE := Add('SETLE'); // <= + ASM_SETNLE := Add('SETNLE'); // > + ASM_SETNL := Add('SETNL'); // >= + + ASM_SETB := Add('SETB'); // < + ASM_SETBE := Add('SETBE'); // <= + ASM_SETNBE := Add('SETNBE'); // > + ASM_SETNB := Add('SETNB'); // >= + ASM_SETZ := Add('SETZ'); // = + ASM_SETNZ := Add('SETNZ'); // = + + ASM_CMP := Add('CMP'); + + ASM_REP_MOVSB := Add('REP MOVSB'); + ASM_REP_MOVSD := Add('REP MOVSD'); + + ASM_MOVSD := Add('MOVSD'); + ASM_MOVSS := Add('MOVSS'); + ASM_CVTSD2SS := Add('CVTSD2SS'); + ASM_CVTSS2SD := Add('CVTSS2SD'); + + ASM_INC := Add('INC'); + ASM_DEC := Add('DEC'); + end; + + DynDestrList := TIntegerList.Create; + with DynDestrList do + begin +{$IFNDEF PAXARM} + Add(OP_ANSISTRING_CLR); + Add(OP_WIDESTRING_CLR); +{$ENDIF} + Add(OP_VARIANT_CLR); + Add(OP_UNICSTRING_CLR); + Add(OP_INTERFACE_CLR); + Add(OP_DYNARRAY_CLR); + Add(OP_STRUCTURE_CLR); + end; + +finalization + + FreeAndNil(Types); + FreeAndNil(Kinds); + FreeAndNil(Operators); + FreeAndNil(AsmOperators); + FreeAndNil(DynDestrList); + FreeAndNil(PushOperators); +end. + + + + + + + + + + + + + + + + + + + + diff --git a/Sources/PAXCOMP_TRYLST.pas b/Sources/PAXCOMP_TRYLST.pas new file mode 100644 index 0000000..d8a815a --- /dev/null +++ b/Sources/PAXCOMP_TRYLST.pas @@ -0,0 +1,147 @@ +//////////////////////////////////////////////////////////////////////////// +// PaxCompiler +// Site: http://www.paxcompiler.com +// Author: Alexander Baranovsky (paxscript@gmail.com) +// ======================================================================== +// Copyright (c) Alexander Baranovsky, 2006-2014. All rights reserved. +// Code Version: 4.2 +// ======================================================================== +// Unit: PAXCOMP_TRYLST.pas +// ======================================================================== +//////////////////////////////////////////////////////////////////////////// + +{$I PaxCompiler.def} +unit PAXCOMP_TRYLST; +interface + +uses {$I uses.def} + SysUtils, + Classes, + PAXCOMP_CONSTANTS, + PAXCOMP_TYPES, + PAXCOMP_SYS, + PAXCOMP_PAUSE; + +type + TTryRec = class(TPauseRec) + private + public + TryKind: TTryKind; + ExceptOnInfo: TAssocIntegers; + Level: Integer; + + BreakOffset: Integer; + ContinueOffset: Integer; + N: Integer; // not saved into stream + constructor Create; + destructor Destroy; override; + procedure SaveToStream(S: TStream); + procedure LoadFromStream(S: TStream); + function Clone: TTryRec; + end; + + TTryList = class(TTypedList) + private + function GetRecord(I: Integer): TTryRec; + public + procedure SaveToStream(S: TStream); + procedure LoadFromStream(S: TStream); + function Add: TTryRec; + property Records[I: Integer]: TTryRec read GetRecord; default; + end; + +implementation + +//----------- TTryRec ---------------------------------------------------------- + +constructor TTryRec.Create; +begin + inherited; + ExceptOnInfo := TAssocIntegers.Create; +end; + +destructor TTryRec.Destroy; +begin + FreeAndNil(ExceptOnInfo); + inherited; +end; + +procedure TTryRec.SaveToStream(S: TStream); +begin + S.Write(TryKind, SizeOf(TryKind)); + S.Write(ProgOffset, SizeOf(ProgOffset)); + S.Write(Level, SizeOf(Level)); + S.Write(BreakOffset, SizeOf(BreakOffset)); + S.Write(ContinueOffset, SizeOf(ContinueOffset)); + ExceptOnInfo.SaveToStream(S); +end; + +procedure TTryRec.LoadFromStream(S: TStream); +begin + S.Read(TryKind, SizeOf(TryKind)); + S.Read(ProgOffset, SizeOf(ProgOffset)); + S.Read(Level, SizeOf(Level)); + S.Read(BreakOffset, SizeOf(BreakOffset)); + S.Read(ContinueOffset, SizeOf(ContinueOffset)); + ExceptOnInfo.LoadFromStream(S); +end; + +function TTryRec.Clone: TTryRec; +begin + result := TTryRec.Create; + + result.TryKind := TryKind; + result.Level := Level; + result.N := N; + + FreeAndNil(result.ExceptOnInfo); + result.ExceptOnInfo := ExceptOnInfo.Clone; +// TPauseRec + + result._EBP := _EBP; + result._ESP := _ESP; + result.ESP0 := ESP0; + result.ProgOffset := ProgOffset; + result.StackFrame := StackFrame; + result.StackFrameSize := StackFrameSize; +end; + +//----------- TTryList --------------------------------------------------------- + +function TTryList.Add: TTryRec; +begin + result := TTryRec.Create; + L.Add(result); +end; + +function TTryList.GetRecord(I: Integer): TTryRec; +begin + result := TTryRec(L[I]); +end; + +procedure TTryList.SaveToStream(S: TStream); +var + I, K: Integer; +begin + K := Count; + S.Write(K, SizeOf(Integer)); + for I:=0 to K - 1 do + Records[I].SaveToStream(S); +end; + +procedure TTryList.LoadFromStream(S: TStream); +var + I, K: Integer; + R: TTryRec; +begin + Clear; + + S.Read(K, SizeOf(Integer)); + for I:=0 to K - 1 do + begin + R := Add; + R.LoadFromStream(S); + end; +end; + +end. diff --git a/Sources/PAXCOMP_TYPEINFO.pas b/Sources/PAXCOMP_TYPEINFO.pas new file mode 100644 index 0000000..3e88e32 --- /dev/null +++ b/Sources/PAXCOMP_TYPEINFO.pas @@ -0,0 +1,2472 @@ +//////////////////////////////////////////////////////////////////////////// +// PaxCompiler +// Site: http://www.paxcompiler.com +// Author: Alexander Baranovsky (paxscript@gmail.com) +// ======================================================================== +// Copyright (c) Alexander Baranovsky, 2006-2014. All rights reserved. +// Code Version: 4.2 +// ======================================================================== +// Unit: PAXCOMP_TYPEINFO.pas +// ======================================================================== +//////////////////////////////////////////////////////////////////////////// + +{$I PaxCompiler.def} +unit PAXCOMP_TYPEINFO; +interface + +uses {$I uses.def} + TypInfo, + SysUtils, + Classes, + PAXCOMP_CONSTANTS, + PAXCOMP_TYPES, + PAXCOMP_SYS, + PAXCOMP_MAP, + PAXCOMP_CLASSFACT, + PAXCOMP_GENERIC; + +type + TParamData = record + Flags: TParamFlags; + ParamName: ShortString; + TypeName: ShortString; + end; + + TTypeInfoContainer = class; + TTypeDataContainer = class; + TClassTypeDataContainer = class; + TMethodTypeDataContainer = class; + + TFieldDataContainer = class + private + procedure SaveToStream(S: TStream); + procedure LoadFromStream(S: TStream); + public + Id: Integer; // not saved to stream + Offset: Cardinal; { Offset of field in the class data. } + ClassIndex: Word; { Index in the FieldClassTable. } + Name: ShortString; + FullFieldTypeName: String; + // PCU only + FinalFieldTypeId: Byte; + Vis: TClassVisibility; + end; + + TFieldListContainer = class(TTypedList) + private + function GetRecord(I: Integer): TFieldDataContainer; + public + function Add: TFieldDataContainer; + procedure SaveToStream(S: TStream); + procedure LoadFromStream(S: TStream); + property Records[I: Integer]: TFieldDataContainer read GetRecord; default; + end; + + TAnotherPropRec = class //PCU only + public + Vis: TClassVisibility; + PropName: String; + ParamNames: TStringList; + ParamTypes: TStringList; + PropType: String; + ReadName: String; + WriteName: String; + IsDefault: Boolean; + constructor Create; + destructor Destroy; override; + procedure SaveToStream(S: TStream); + procedure LoadFromStream(S: TStream); + end; + + TAnotherPropList = class(TTypedList) + private + function GetRecord(I: Integer): TAnotherPropRec; + public + function Add: TAnotherPropRec; + procedure SaveToStream(S: TStream); + procedure LoadFromStream(S: TStream); + property Records[I: Integer]: TAnotherPropRec read GetRecord; default; + end; + + TPropDataContainer = class + private + Owner: TTypeDataContainer; + function GetCount: Integer; + function GetSize: Integer; + public + PropData: TPropData; + PropList: array of TPropInfo; + PropTypeIds: array of Integer; + ReadNames: TStringList; + WriteNames: TStringList; + PropTypeNames: TStringList; + constructor Create(AOwner: TTypeDataContainer); + destructor Destroy; override; + procedure SaveToStream(S: TStream); + procedure SaveToBuff(S: TStream); + procedure LoadFromStream(S: TStream); + property Count: Integer read GetCount; + property Size: Integer read GetSize; + end; + + TParamListContainer = class + private + Owner: TMethodTypeDataContainer; + function GetCount: Integer; + function GetSize: Integer; + public + ParamList: array of TParamData; + constructor Create(AOwner: TMethodTypeDataContainer); + destructor Destroy; override; + procedure SaveToStream(S: TStream); + procedure SaveToBuff(S: TStream); + procedure LoadFromStream(S: TStream); + property Count: Integer read GetCount; + property Size: Integer read GetSize; + end; + +{$ifdef Ver360} // Delphi 12 Athens + TTypeDataXil = packed record + function NameListFld: TTypeInfoFieldAccessor; inline; + function UnitNameFld: TTypeInfoFieldAccessor; inline; + function IntfUnitFld: TTypeInfoFieldAccessor; inline; + function DynUnitNameFld: TTypeInfoFieldAccessor; inline; + + function PropData: PPropData; inline; + function IntfMethods: PIntfMethodTable; inline; + + function DynArrElType: PPTypeInfo; inline; + function DynArrAttrData: PAttrData; inline; + + case TTypeKind of + tkUnknown: (); + tkUString, +{$IFNDEF NEXTGEN} + tkWString, +{$ENDIF !NEXTGEN} + tkVariant: (AttrData: TAttrData); + tkLString: ( + CodePage: Word + {LStrAttrData: TAttrData}); + tkInteger, tkChar, tkEnumeration, tkSet, tkWChar: ( + OrdType: TOrdType; + case TTypeKind of + tkInteger, tkChar, tkEnumeration, tkWChar: ( + + MinValue: Integer; + MaxValue: Integer; + case TTypeKind of + tkInteger, tkChar, tkWChar: ( + {OrdAttrData: TAttrData}); + tkEnumeration: ( + BaseType: PPTypeInfo; + NameList: TSymbolName; + {EnumUnitName: TSymbolName; + EnumAttrData: TAttrData})); + tkSet: ( + CompType: PPTypeInfo + {SetAttrData: TAttrData})); + tkFloat: ( + FloatType: TFloatType + {FloatAttrData: TAttrData}); +{$IFNDEF NEXTGEN} + tkString: ( + MaxLength: Byte + {StrAttrData: TAttrData}); +{$ENDIF !NEXTGEN} + tkClass: ( + ClassType: TClass; // most data for instance types is in VMT offsets + ParentInfo: PPTypeInfo; + PropCount: SmallInt; // total properties inc. ancestors + UnitName: TSymbolName; + {PropData: TPropData; + PropDataEx: TPropDataEx; + ClassAttrData: TAttrData; + ArrayPropCount: Word; + ArrayPropData: array[1..ArrayPropCount] of TArrayPropInfo;}); + tkMethod: ( + MethodKind: TMethodKind; // only mkFunction or mkProcedure + ParamCount: Byte; +{$IFNDEF NEXTGEN} + ParamList: array[0..1023] of AnsiChar +{$ELSE NEXTGEN} + ParamList: array[0..1023] of Byte +{$ENDIF NEXTGEN} + {ParamList: array[1..ParamCount] of + record + Flags: TParamFlags; + ParamName: ShortString; + TypeName: ShortString; + end; + ResultType: ShortString; // only if MethodKind = mkFunction + ResultTypeRef: PPTypeInfo; // only if MethodKind = mkFunction + CC: TCallConv; + ParamTypeRefs: array[1..ParamCount] of PPTypeInfo; + MethSig: PProcedureSignature; + MethAttrData: TAttrData}); + tkProcedure: ( + ProcSig: PProcedureSignature; + ProcAttrData: TAttrData;); + tkInterface: ( + IntfParent : PPTypeInfo; { ancestor } + IntfFlags : TIntfFlagsBase; + Guid : TGUID; + IntfUnit : TSymbolName + {IntfMethods: TIntfMethodTable; + IntfAttrData: TAttrData;}); + tkInt64: ( + MinInt64Value, MaxInt64Value: Int64; + Int64AttrData: TAttrData;); + tkDynArray: ( + + elSize: Integer; + elType: PPTypeInfo; // nil if type does not require cleanup + varType: Integer; // Ole Automation varType equivalent + elType2: PPTypeInfo; // independent of cleanup + DynUnitName: TSymbolName; + {DynArrElType: PPTypeInfo; // actual element type, even if dynamic array + DynArrAttrData: TAttrData}); + tkRecord: ( + RecSize: Integer; + ManagedFldCount: Integer; + {ManagedFields: array[0..ManagedFldCnt - 1] of TManagedField; + NumOps: Byte; + RecOps: array[1..NumOps] of Pointer; + RecFldCnt: Integer; + RecFields: array[1..RecFldCnt] of TRecordTypeField; + RecAttrData: TAttrData; + RecMethCnt: Word; + RecMeths: array[1..RecMethCnt] of TRecordTypeMethod}); + tkClassRef: ( + InstanceType: PPTypeInfo; + ClassRefAttrData: TAttrData;); + tkPointer: ( + RefType: PPTypeInfo; + PtrAttrData: TAttrData); + tkArray: ( + ArrayData: TArrayTypeData; + {ArrAttrData: TAttrData}); + end; +{$endif} + + TTypeDataContainer = class + private + Owner: TTypeInfoContainer; + function GetTypeDataSize: Integer; virtual; //save to buff + function GetSize: Integer; virtual; // save to stream + public +{$ifdef Ver360} // Delphi 12 Athens + TypeData: TTypeDataXil; +{$else} + TypeData: TTypeData; +{$endif} + constructor Create(AOwner: TTypeInfoContainer); + destructor Destroy; override; + procedure SaveToStream(S: TStream); virtual; + procedure SaveToBuff(S: TStream); virtual; + procedure LoadFromStream(S: TStream); virtual; + property TypeDataSize: Integer read GetTypeDataSize; + property Size: Integer read GetSize; + end; + + TMethodTypeDataContainer = class(TTypeDataContainer) + private + function GetTypeDataSize: Integer; override; + function GetSize: Integer; override; + public + MethodKind: TMethodKind; + ParamCount: Byte; + ParamListContainer: TParamListContainer; + // extra data + ResultType: ShortString; + OwnerTypeName: String; + MethodTableIndex: Integer; + ResultTypeId: Integer; + CallConv: Byte; + OverCount: Byte; + Address: Pointer; // not saved to stream + constructor Create(AOwner: TTypeInfoContainer); + destructor Destroy; override; + procedure SaveToStream(S: TStream); override; + procedure SaveToBuff(S: TStream); override; + procedure LoadFromStream(S: TStream); override; + end; + + TClassTypeDataContainer = class(TTypeDataContainer) + private + function GetTypeDataSize: Integer; override; + function GetSize: Integer; override; + public + // info about published members + PropDataContainer: TPropDataContainer; + MethodTableCount: Integer; + MethodTableSize: Integer; + FieldTableCount: Integer; + FieldTableSize: Integer; + FullParentName: String; + FieldListContainer: TFieldListContainer; + + // PCU only + AnotherFieldListContainer: TFieldListContainer; + AnotherPropList: TAnotherPropList; + SupportedInterfaces: TStringList; + + constructor Create(AOwner: TTypeInfoContainer); + destructor Destroy; override; + procedure SaveToStream(S: TStream); override; + procedure SaveToBuff(S: TStream); override; + procedure LoadFromStream(S: TStream); override; + end; + + TInterfaceTypeDataContainer = class(TTypeDataContainer) + private + function GetTypeDataSize: Integer; override; + function GetSize: Integer; override; + public + PropDataContainer: TPropDataContainer; + FullParentName: String; + GUID: TGUID; + SubDescList: TSubDescList; + constructor Create(AOwner: TTypeInfoContainer); + destructor Destroy; override; + procedure SaveToStream(S: TStream); override; + procedure SaveToBuff(S: TStream); override; + procedure LoadFromStream(S: TStream); override; + end; + + TSetTypeDataContainer = class(TTypeDataContainer) + private + function GetSize: Integer; override; + public + FullCompName: String; + procedure SaveToStream(S: TStream); override; + procedure SaveToBuff(S: TStream); override; + procedure LoadFromStream(S: TStream); override; + end; + + TEnumTypeDataContainer = class(TTypeDataContainer) + private + function GetTypeDataSize: Integer; override; + function GetSize: Integer; override; + public + NameList: array of ShortString; + EnumUnitName: ShortString; + + //pcu only + ValueList: array of Integer; + procedure SaveToStream(S: TStream); override; + procedure SaveToBuff(S: TStream); override; + procedure LoadFromStream(S: TStream); override; + end; + + TArrayTypeDataContainer = class(TTypeDataContainer) + public + FullRangeTypeName: String; + FullElemTypeName: String; + B1: Integer; + B2: Integer; + FinRangeTypeId: Integer; + procedure SaveToStream(S: TStream); override; + procedure SaveToBuff(S: TStream); override; + procedure LoadFromStream(S: TStream); override; + end; + + TRecordTypeDataContainer = class(TTypeDataContainer) + private + function GetSize: Integer; override; + public + IsPacked: Boolean; + FieldListContainer: TFieldListContainer; + constructor Create(AOwner: TTypeInfoContainer); + destructor Destroy; override; + procedure SaveToStream(S: TStream); override; + procedure SaveToBuff(S: TStream); override; + procedure LoadFromStream(S: TStream); override; + end; + + TAliasTypeDataContainer = class(TTypeDataContainer) + public + FullSourceTypeName: String; + procedure SaveToStream(S: TStream); override; + procedure LoadFromStream(S: TStream); override; + end; + + TPointerTypeDataContainer = class(TTypeDataContainer) + public + FullOriginTypeName: String; + procedure SaveToStream(S: TStream); override; + procedure LoadFromStream(S: TStream); override; + end; + + TClassRefTypeDataContainer = class(TTypeDataContainer) + public + FullOriginTypeName: String; + procedure SaveToStream(S: TStream); override; + procedure LoadFromStream(S: TStream); override; + end; + + TDynArrayTypeDataContainer = class(TTypeDataContainer) + public + FullElementTypeName: String; + procedure SaveToStream(S: TStream); override; + procedure LoadFromStream(S: TStream); override; + end; + + TProceduralTypeDataContainer = class(TTypeDataContainer) + public + SubDesc: TSubDesc; + constructor Create(AOwner: TTypeInfoContainer); + destructor Destroy; override; + procedure SaveToStream(S: TStream); override; + procedure LoadFromStream(S: TStream); override; + end; + +{$IFDEF PAXARM} + TTypeInfoBuff = record + Kind: TTypeKind; + Name: ShortString; + end; +{$ELSE} + TTypeInfoBuff = TTypeInfo; +{$ENDIF} + + TTypeInfoContainer = class + private + Buff: Pointer; + Buff4: Pointer; + Processed: Boolean; + function GetSize: Integer; + function GetPosTypeData: Integer; + function GetStreamSize: Integer; + function GetIsGeneric: Boolean; + public + TypeInfo: TTypeInfoBuff; + TypeDataContainer: TTypeDataContainer; + FullName: String; + FinTypeId: Byte; + GenericTypeContainer: TGenericTypeContainer; + + constructor Create(AFinTypeId: Integer); + destructor Destroy; override; + procedure SaveToStream(S: TStream); + procedure SaveToBuff(S: TStream); + procedure LoadFromStream(S: TStream; + FinTypeId: Byte); + procedure RaiseError(const Message: string; params: array of Const); + property Size: Integer read GetSize; + property PosTypeData: Integer read GetPosTypeData; + property TypeInfoPtr: Pointer read Buff4; + property IsGeneric: Boolean read GetIsGeneric; + end; + + TSetTypeInfoContainer = class(TTypeInfoContainer) + public + constructor Create(const AName: String); + end; + + TEnumTypeInfoContainer = class(TTypeInfoContainer) + public + constructor Create(const AName: String); + end; + + TClassTypeInfoContainer = class(TTypeInfoContainer) + public + constructor Create(const AName: String); + end; + + TMethodTypeInfoContainer = class(TTypeInfoContainer) + public + constructor Create(const AName: String); + end; + + TInterfaceTypeInfoContainer = class(TTypeInfoContainer) + public + constructor Create(const AName: String); + end; + + TArrayTypeInfoContainer = class(TTypeInfoContainer) + public + constructor Create(const AName: String); + end; + + TRecordTypeInfoContainer = class(TTypeInfoContainer) + public + constructor Create(const AName: String); + end; + + TAliasTypeInfoContainer = class(TTypeInfoContainer) + public + constructor Create(const AName: String); + end; + + TPointerTypeInfoContainer = class(TTypeInfoContainer) + public + constructor Create(const AName: String); + end; + + TClassRefTypeInfoContainer = class(TTypeInfoContainer) + public + constructor Create(const AName: String); + end; + + TDynArrayTypeInfoContainer = class(TTypeInfoContainer) + public + constructor Create(const AName: String); + end; + + TProceduralTypeInfoContainer = class(TTypeInfoContainer) + public + constructor Create(const AName: String); + end; + + TPaxTypeInfoList = class(TTypedList) + private + function GetRecord(I: Integer): TTypeInfoContainer; + procedure RaiseError(const Message: string; params: array of Const); + public + destructor Destroy; override; + procedure Add(Rec: TTypeInfoContainer); + function IndexOf(const FullName: String): Integer; + function LookupFullName(const FullName: String): TTypeInfoContainer; + procedure CopyToBuff; + procedure SaveToStream(S: TStream); + procedure LoadFromStream(S: TStream); + procedure AddToProgram(AProg: Pointer); + function FindMethodFullName(Address: Pointer): String; + function Processed: Boolean; + property Records[I: Integer]: TTypeInfoContainer read GetRecord; default; + end; + +function FinTypeToTypeKind(FinTypeId: Integer): TTypeKind; +function GetClassTypeInfoContainer(X: TObject): TClassTypeInfoContainer; +function PtiToFinType(Pti: PTypeInfo): Integer; + +implementation + +uses + PAXCOMP_CLASSLST, + PAXCOMP_STDLIB, + PAXCOMP_BASERUNNER; + +{$ifdef Ver360} // Delphi 12 Athens +{ TTypeDataXil } + +function TTypeDataXil.NameListFld: TTypeInfoFieldAccessor; +begin + Result.SetData(@NameList); +end; + +function TTypeDataXil.UnitNameFld: TTypeInfoFieldAccessor; +begin + Result.SetData(@UnitName); +end; + +function TTypeDataXil.IntfUnitFld: TTypeInfoFieldAccessor; +begin + Result.SetData(@IntfUnit); +end; + +function TTypeDataXil.DynUnitNameFld: TTypeInfoFieldAccessor; +begin + Result.SetData(@DynUnitName); +end; + +function TTypeDataXil.PropData: PPropData; +begin + Result := PPropData(UnitNameFld.Tail) +end; + +function TTypeDataXil.IntfMethods: PIntfMethodTable; +begin + Result := PIntfMethodTable(IntfUnitFld.Tail); +end; + +function TTypeDataXil.DynArrElType: PPTypeInfo; +type + PPPTypeInfo = ^PPTypeInfo; +begin + Result := PPPTypeInfo(DynUnitNameFld.Tail)^; +end; + +function TTypeDataXil.DynArrAttrData: PAttrData; +begin + Result := PAttrData(Self.DynUnitNameFld.Tail + SizeOf(PPTypeInfo)); +end; +{$endif} + +function FinTypeToTypeKind(FinTypeId: Integer): TTypeKind; +begin + result := tkUnknown; + case FinTypeId of + +{$IFNDEF PAXARM} + typeWIDESTRING: result := tkWString; + typeANSISTRING: result := tkLString; + typeANSICHAR: result := tkChar; + typeSHORTSTRING: result := tkString; +{$ENDIF} + +{$IFDEF UNIC} + typeUNICSTRING: result := tkUString; +{$ENDIF} + typeVARIANT, typeOLEVARIANT: result := tkVariant; + typeINTEGER, typeBYTE, typeWORD, typeCARDINAL, + typeSMALLINT, typeSHORTINT: result := tkInteger; + typeENUM, typeBOOLEAN, typeBYTEBOOL, typeWORDBOOL, typeLONGBOOL: result := tkEnumeration; + typeSET: result := tkSet; + typeWIDECHAR: result := tkWChar; + typeSINGLE, typeDOUBLE, typeEXTENDED, typeCURRENCY: result := tkFloat; + typeEVENT: result := tkMethod; + typeCLASS: result := tkClass; + typeINT64: result := tkInt64; + typeDYNARRAY: result := tkDynArray; + typeINTERFACE: result := tkInterface; + typeRECORD: result := tkRecord; + typeARRAY: result := tkArray; + end; +end; + +function PtiToFinType(Pti: PTypeInfo): Integer; +begin + result := 0; + case Pti^.Kind of + tkInteger: + case GetTypeData(pti).OrdType of + otSByte: result := typeSMALLINT; + otUByte: result := typeBYTE; + otSWord: result := typeSHORTINT; + otUWord: result := typeWORD; + otSLong: result := typeINTEGER; + otULong: result := typeCARDINAL; + end; + tkChar: + result := typeCHAR; + tkWChar: + result := typeWIDECHAR; +{$IFNDEF PAXARM} + tkString: + result := typeSHORTSTRING; + tkLString: + result := typeANSISTRING; + tkWString: + result := typeWIDESTRING; +{$ENDIF} +{$IFDEF UNIC} + tkUString: + result := typeUNICSTRING; +{$ENDIF} + tkFloat: + case GetTypeData(pti)^.FloatType of + ftSingle: result := typeSINGLE; + ftDouble: result := typeDOUBLE; + ftExtended: result := typeEXTENDED; + ftComp: result := 0; + ftCurr: result := typeCURRENCY; + end; +{$IFDEF UNIC} + tkPointer: + result := typePOINTER; +{$ENDIF} + tkClass: + result := typeCLASS; +{$IFDEF UNIC} + tkClassRef: + result := typeCLASSREF; + tkProcedure: + result := typePROC; +{$ENDIF} + tkMethod: + result := typeEVENT; + tkInterface: + result := typeINTERFACE; + tkInt64: + result := typeINT64; + tkEnumeration: + result := typeENUM; + tkVariant: + result := typeVARIANT; + end; +end; + +// TAnotherPropRec ------------------------------------------------------------- + +constructor TAnotherPropRec.Create; +begin + inherited; + ParamNames := TStringList.Create; + ParamTypes := TStringList.Create; +end; + +destructor TAnotherPropRec.Destroy; +begin + FreeAndNil(ParamNames); + FreeAndNil(ParamTypes); + inherited; +end; + +procedure TAnotherPropRec.SaveToStream(S: TStream); +begin + S.Write(Vis, SizeOf(Vis)); + SaveStringToStream(PropName, S); + SaveStringListToStream(ParamNames, S); + SaveStringListToStream(ParamTypes, S); + SaveStringToStream(PropType, S); + SaveStringToStream(ReadName, S); + SaveStringToStream(WriteName, S); + S.Write(IsDefault, SizeOf(IsDefault)); +end; + +procedure TAnotherPropRec.LoadFromStream(S: TStream); +begin + S.Read(Vis, SizeOf(Vis)); + PropName := LoadStringFromStream(S); + LoadStringListFromStream(ParamNames, S); + LoadStringListFromStream(ParamTypes, S); + PropType := LoadStringFromStream(S); + ReadName := LoadStringFromStream(S); + WriteName := LoadStringFromStream(S); + S.Read(IsDefault, SizeOf(IsDefault)); +end; + +// TAnotherPropList ------------------------------------------------------------ + +function TAnotherPropList.GetRecord(I: Integer): TAnotherPropRec; +begin + result := TAnotherPropRec(L[I]); +end; + +function TAnotherPropList.Add: TAnotherPropRec; +begin + result := TAnotherPropRec.Create; + L.Add(result); +end; + +procedure TAnotherPropList.SaveToStream(S: TStream); +var + I, K: Integer; +begin + K := Count; + S.Write(K, SizeOf(K)); + for I := 0 to K - 1 do + Records[I].SaveToStream(S); +end; + +procedure TAnotherPropList.LoadFromStream(S: TStream); +var + I, K: Integer; + R: TAnotherPropRec; +begin + S.Read(K, SizeOf(K)); + for I := 0 to K - 1 do + begin + R := Add; + R.LoadFromStream(S); + end; +end; + +// TFieldDataContainer --------------------------------------------------------- + +procedure TFieldDataContainer.SaveToStream(S: TStream); +begin + S.Write(Offset, SizeOf(Offset)); + S.Write(ClassIndex, SizeOf(ClassIndex)); + SaveShortStringToStream(Name, S); + SaveStringToStream(FullFieldTypeName, S); + S.Write(Vis, SizeOf(Vis)); +{$IFDEF PCU_EX} + S.Write(FinalFieldTypeId, SizeOf(FinalFieldTypeId)); +{$ENDIF} +end; + +procedure TFieldDataContainer.LoadFromStream(S: TStream); +begin + S.Read(Offset, SizeOf(Offset)); + S.Read(ClassIndex, SizeOf(ClassIndex)); + Name := LoadShortStringFromStream(S); + FullFieldTypeName := LoadStringFromStream(S); + S.Read(Vis, SizeOf(Vis)); +{$IFDEF PCU_EX} + S.Read(FinalFieldTypeId, SizeOf(FinalFieldTypeId)); +{$ENDIF} +end; + +// TFieldListContainer --------------------------------------------------------- + +function TFieldListContainer.GetRecord(I: Integer): TFieldDataContainer; +begin + result := TFieldDataContainer(L[I]); +end; + +function TFieldListContainer.Add: TFieldDataContainer; +begin + result := TFieldDataContainer.Create; + L.Add(result); +end; + +procedure TFieldListContainer.SaveToStream(S: TStream); +var + I, K: Integer; +begin + K := Count; + S.Write(K, SizeOf(K)); + for I := 0 to K - 1 do + Records[I].SaveToStream(S); +end; + +procedure TFieldListContainer.LoadFromStream(S: TStream); +var + I, K: Integer; + R: TFieldDataContainer; +begin + S.Read(K, SizeOf(K)); + for I := 0 to K - 1 do + begin + R := Add; + R.LoadFromStream(S); + end; +end; + +// TParamListContainer --------------------------------------------------------- + +constructor TParamListContainer.Create(AOwner: TMethodTypeDataContainer); +begin + inherited Create; + Owner := AOwner; +end; + +destructor TParamListContainer.Destroy; +begin + inherited; +end; + +function TParamListContainer.GetCount: Integer; +begin + result := System.Length(ParamList); +end; + +function TParamListContainer.GetSize: Integer; +var + I: Integer; +begin + result := 0; + for I := 0 to Count - 1 do + begin + Inc(result, SizeOf(ParamList[I].Flags)); + Inc(result, Length(ParamList[I].ParamName) + 1); + Inc(result, Length(ParamList[I].TypeName) + 1); + end; +end; + +procedure TParamListContainer.SaveToStream(S: TStream); +var + I, K: Integer; +begin + K := Count; + S.Write(K, SizeOf(Integer)); + for I := 0 to Count - 1 do + with ParamList[I] do + begin + S.Write(Flags, SizeOf(Flags)); + SaveShortStringToStream(ParamName, S); + SaveShortStringToStream(TypeName, S); + end; +end; + +procedure TParamListContainer.SaveToBuff(S: TStream); +var + I: Integer; +begin + for I := 0 to Count - 1 do + with ParamList[I] do + begin + S.Write(Flags, SizeOf(Flags)); + SaveShortStringToStream(ParamName, S); + SaveShortStringToStream(TypeName, S); + end; +end; + +procedure TParamListContainer.LoadFromStream(S: TStream); +var + I, K: Integer; +begin + S.Read(K, SizeOf(Integer)); + SetLength(ParamList, K); + for I := 0 to Count - 1 do + with ParamList[I] do + begin + S.Read(Flags, SizeOf(Flags)); + ParamName := LoadShortStringFromStream(S); + TypeName := LoadShortStringFromStream(S); + end; +end; + +// TPropDataContainer ------------------------------------------------------- + +constructor TPropDataContainer.Create(AOwner: TTypeDataContainer); +begin + Owner := AOwner; + ReadNames := TStringList.Create; + WriteNames := TStringList.Create; + PropTypeNames := TStringList.Create; + inherited Create; +end; + +function PropInfoSize(const PropInfo: TPropInfo): Integer; +begin +{$IFDEF PAXARM} + result := SizeOf(TPropInfo) - SizeOf(ShortString) + + {$IFDEF ARC} + PropInfo.Name + 1; + {$ELSE} + Length(PropInfo.Name) + 1; + {$ENDIF} +{$ELSE} + result := SizeOf(TPropInfo) - SizeOf(ShortString) + + Length(PropInfo.Name) + 1; +{$ENDIF} +end; + +destructor TPropDataContainer.Destroy; +begin + FreeAndNil(ReadNames); + FreeAndNil(WriteNames); + FreeAndNil(PropTypeNames); + inherited; +end; + +function TPropDataContainer.GetCount: Integer; +begin + result := PropData.PropCount; +end; + +function TPropDataContainer.GetSize: Integer; +var + I: Integer; +begin + result := SizeOf(TPropData); + for I := 0 to Count - 1 do + Inc(result, PropInfoSize(PropList[I])); +{$IFDEF DRTTI} + Inc(result, SizeOf(TPropDataEx)); +{$ELSE} + {$IFDEF DPULSAR} + Inc(result, SizeOf(TPropInfoEx)); + {$ENDIF} +{$ENDIF} +end; + +procedure TPropDataContainer.SaveToStream(S: TStream); +var + I, SZ: Integer; +begin + S.Write(PropData, SizeOf(TPropData)); + for I := 0 to Count - 1 do + begin + SZ := PropInfoSize(PropList[I]); + S.Write(SZ, SizeOf(Integer)); + S.Write(PropList[I], SZ); + end; + SaveStringListToStream(ReadNames, S); + SaveStringListToStream(WriteNames, S); + SaveStringListToStream(PropTypeNames, S); + for I := 0 to Count - 1 do + S.Write(PropTypeIds[I], SizeOf(PropTypeIds[I])); +end; + +procedure TPropDataContainer.SaveToBuff(S: TStream); +var + I: Integer; +{$IFDEF DRTTI} + PropEx: TPropDataEx; +{$ELSE} + {$IFDEF DPULSAR} + PropEx: TPropDataEx; + {$ENDIF} +{$ENDIF} +begin + S.Write(PropData, SizeOf(TPropData)); + for I := 0 to Count - 1 do + S.Write(PropList[I], PropInfoSize(PropList[I])); + +{$IFDEF DRTTI} + FillChar(PropEx, SizeOf(PropEx), #0); + S.Write(PropEx, SizeOf(TPropDataEx)); +{$ELSE} + {$IFDEF DPULSAR} + FillChar(PropEx, SizeOf(PropEx), #0); + S.Write(PropEx, SizeOf(TPropDataEx)); + {$ENDIF} +{$ENDIF} +end; + +procedure TPropDataContainer.LoadFromStream(S: TStream); +var + I, SZ: Integer; +begin + S.Read(PropData, SizeOf(TPropData)); + SetLength(PropList, PropData.PropCount); + for I := 0 to PropData.PropCount - 1 do + begin + S.Read(SZ, SizeOf(Integer)); + S.Read(PropList[I], SZ); + end; + LoadStringListFromStream(ReadNames, S); + LoadStringListFromStream(WriteNames, S); + LoadStringListFromStream(PropTypeNames, S); + SetLength(PropTypeIds, PropData.PropCount); + for I := 0 to PropData.PropCount - 1 do + S.Read(PropTypeIds[I], SizeOf(PropTypeIds)); +end; + +// TTypeDataContainer ------------------------------------------------------- + +constructor TTypeDataContainer.Create(AOwner: TTypeInfoContainer); +begin + Owner := AOwner; + inherited Create; +end; + +destructor TTypeDataContainer.Destroy; +begin + inherited; +end; + +function TTypeDataContainer.GetTypeDataSize: Integer; +begin + result := SizeOf(TypeData); +end; + +function TTypeDataContainer.GetSize: Integer; +begin + result := SizeOf(TypeData); +end; + +procedure TTypeDataContainer.SaveToStream(S: TStream); +begin + S.Write(TypeData, 16); +end; + +procedure TTypeDataContainer.SaveToBuff(S: TStream); +begin + S.Write(TypeData, SizeOf(TypeData)); +end; + +procedure TTypeDataContainer.LoadFromStream(S: TStream); +begin + FillChar(TypeData, SizeOf(TypeData), 0); + S.Read(TypeData, 16); +end; + +// TMethodTypeDataContainer ---------------------------------------------------- + +constructor TMethodTypeDataContainer.Create(AOwner: TTypeInfoContainer); +begin + inherited; + ParamListContainer := TParamListContainer.Create(Self); +end; + +destructor TMethodTypeDataContainer.Destroy; +begin + FreeAndNil(ParamListContainer); + inherited; +end; + +function TMethodTypeDataContainer.GetTypeDataSize: Integer; +begin + result := SizeOf(MethodKind) + SizeOf(ParamCount); +end; + +function TMethodTypeDataContainer.GetSize: Integer; +begin + result := TypeDataSize + ParamListContainer.Size + + Length(ResultType) + 1; +end; + +procedure TMethodTypeDataContainer.SaveToStream(S: TStream); +begin + S.Write(MethodKind, SizeOf(MethodKind)); + S.Write(ParamCount, SizeOf(ParamCount)); + ParamListContainer.SaveToStream(S); + SaveShortStringToStream(ResultType, S); + SaveStringToStream(OwnerTypeName, S); + S.Write(MethodTableIndex, SizeOf(MethodTableIndex)); + S.Write(ResultTypeId, SizeOf(ResultTypeId)); + S.Write(CallConv, SizeOf(CallConv)); + S.Write(OverCount, SizeOf(OverCount)); +end; + +procedure TMethodTypeDataContainer.SaveToBuff(S: TStream); +begin + S.Write(MethodKind, SizeOf(MethodKind)); + S.Write(ParamCount, SizeOf(ParamCount)); + ParamListContainer.SaveToBuff(S); + SaveShortStringToStream(ResultType, S); +end; + +procedure TMethodTypeDataContainer.LoadFromStream(S: TStream); +begin + S.Read(MethodKind, SizeOf(MethodKind)); + S.Read(ParamCount, SizeOf(ParamCount)); + ParamListContainer.LoadFromStream(S); + ResultType := LoadShortStringFromStream(S); + OwnerTypeName := LoadStringFromStream(S); + S.Read(MethodTableIndex, SizeOf(MethodTableIndex)); + S.Read(ResultTypeId, SizeOf(ResultTypeId)); + S.Read(CallConv, SizeOf(CallConv)); + S.Read(OverCount, SizeOf(OverCount)); +end; + +// TClassTypeDataContainer ----------------------------------------------------- + +constructor TClassTypeDataContainer.Create(AOwner: TTypeInfoContainer); +begin + inherited; + + PropDataContainer := TPropDataContainer.Create(Self); + FieldListContainer := TFieldListContainer.Create; + + AnotherFieldListContainer := TFieldListContainer.Create; + AnotherPropList := TAnotherPropList.Create; + SupportedInterfaces := TStringList.Create; + +end; + +destructor TClassTypeDataContainer.Destroy; +begin + FreeAndNil(PropDataContainer); + FreeAndNil(FieldListContainer); + + FreeAndNil(AnotherFieldListContainer); + FreeAndNil(AnotherPropList); + FreeAndNil(SupportedInterfaces); + + inherited; +end; + +function TClassTypeDataContainer.GetTypeDataSize: Integer; +begin +{$IFDEF PAXARM} + result := SizeOf(TypeData.ClassType) + + SizeOf(TypeData.ParentInfo) + + SizeOf(TypeData.PropCount) + + {$IFDEF ARC} + TypeData.UnitName + 1; + {$ELSE} + Length(TypeData.UnitName) + 1; + {$ENDIF} +{$ELSE} + result := SizeOf(TypeData.ClassType) + + SizeOf(TypeData.ParentInfo) + + SizeOf(TypeData.PropCount) + + Length(TypeData.UnitName) + 1; +{$ENDIF} +end; + +function TClassTypeDataContainer.GetSize: Integer; +begin + result := TypeDataSize + + PropDataContainer.Size; +end; + +procedure TClassTypeDataContainer.SaveToStream(S: TStream); +var + K: Integer; +begin + K := TypeDataSize; + S.Write(K, SizeOf(K)); + S.Write(TypeData, TypeDataSize); + PropDataContainer.SaveToStream(S); + S.Write(MethodTableCount, SizeOf(MethodTableCount)); + S.Write(MethodTableSize, SizeOf(MethodTableSize)); + S.Write(FieldTableCount, SizeOf(FieldTableCount)); + S.Write(FieldTableSize, SizeOf(FieldTableSize)); + SaveStringToStream(FullParentName, S); + FieldListContainer.SaveToStream(S); + AnotherFieldListContainer.SaveToStream(S); + AnotherPropList.SaveToStream(S); + SaveStringListToStream(SupportedInterfaces, S); +end; + +procedure TClassTypeDataContainer.SaveToBuff(S: TStream); +begin + S.Write(TypeData, TypeDataSize); + PropDataContainer.SaveToBuff(S); +end; + +procedure TClassTypeDataContainer.LoadFromStream(S: TStream); +var + K: Integer; +begin + S.Read(K, SizeOf(K)); + S.Read(TypeData, K); + PropDataContainer.LoadFromStream(S); + S.Read(MethodTableCount, SizeOf(MethodTableCount)); + S.Read(MethodTableSize, SizeOf(MethodTableSize)); + S.Read(FieldTableCount, SizeOf(FieldTableCount)); + S.Read(FieldTableSize, SizeOf(FieldTableSize)); + FullParentName := LoadStringFromStream(S); + FieldListContainer.LoadFromStream(S); + AnotherFieldListContainer.LoadFromStream(S); + AnotherPropList.LoadFromStream(S); + LoadStringListFromStream(SupportedInterfaces, S); +end; + +// TSetTypeDataContainer ------------------------------------------------- + +function TSetTypeDataContainer.GetSize: Integer; +begin + result := SizeOf(TypeData); +end; + +procedure TSetTypeDataContainer.SaveToStream(S: TStream); +begin + inherited; + SaveStringToStream(FullCompName, S); +end; + +procedure TSetTypeDataContainer.SaveToBuff(S: TStream); +begin + S.Write(TypeData, SizeOf(TypeData)); +end; + +procedure TSetTypeDataContainer.LoadFromStream(S: TStream); +begin + inherited; + FullCompName := LoadStringFromStream(S); +end; + + +// TEnumTypeDataContainer ------------------------------------------------------ + +function TEnumTypeDataContainer.GetTypeDataSize: Integer; +begin + result := SizeOf(TOrdType) + + SizeOf(Longint) + // min value + SizeOf(Longint) + // max value + SizeOf(Pointer); // base type +end; + +function TEnumTypeDataContainer.GetSize: Integer; +begin + result := GetTypeDataSize; + +{ + for I := 0 to Length(NameList) - 1 do + Inc(result, Length(NameList[I]) + 1); +} + Inc(result, 256); + + Inc(result, Length(EnumUnitName) + 1); +end; + +procedure TEnumTypeDataContainer.SaveToStream(S: TStream); +var + I, K: Integer; +begin + S.Write(TypeData, GetTypeDataSize); + K := System.Length(NameList); + S.Write(K, SizeOf(K)); + for I := 0 to K - 1 do + SaveShortStringToStream(NameList[I], S); + SaveShortStringToStream(EnumUnitName, S); + for I := 0 to K - 1 do + S.Write(ValueList[I], SizeOf(ValueList[I])); +end; + +procedure TEnumTypeDataContainer.SaveToBuff(S: TStream); +var + I, K, Z: Integer; + B: Byte; +begin + S.Write(TypeData, GetTypeDataSize); + K := System.Length(NameList); + Z := 0; + for I := 0 to K - 1 do + begin + SaveShortStringToStream(NameList[I], S); + Inc(z, Length(NameList[I]) + 1); + end; + B := 0; + while Z < 256 do + begin + Inc(Z); + S.Write(B, 1); + end; + SaveShortStringToStream(EnumUnitName, S); +end; + +procedure TEnumTypeDataContainer.LoadFromStream(S: TStream); +var + I, K: Integer; +begin + S.Read(TypeData, GetTypeDataSize); + S.Read(K, SizeOf(K)); + SetLength(NameList, K); + for I := 0 to K - 1 do + NameList[I] := LoadShortStringFromStream(S); + EnumUnitName := LoadShortStringFromStream(S); + SetLength(ValueList, K); + for I := 0 to K - 1 do + S.Read(ValueList[I], SizeOf(ValueList[I])); +end; + +// TInterfaceTypeDataContainer ------------------------------------------------- + +constructor TInterfaceTypeDataContainer.Create(AOwner: TTypeInfoContainer); +begin + inherited; + PropDataContainer := TPropDataContainer.Create(Self); + SubDescList := TSubDescList.Create; +end; + +destructor TInterfaceTypeDataContainer.Destroy; +begin + FreeAndNil(PropDataContainer); + FreeAndNil(SubDescList); + inherited; +end; + +function TInterfaceTypeDataContainer.GetTypeDataSize: Integer; +begin +{$IFDEF PAXARM} + result := SizeOf(TypeData.IntfParent) + + SizeOf(TypeData.IntfFlags) + + SizeOf(TypeData.Guid) + + {$IFDEF ARC} + TypeData.IntfUnit + 1; + {$ELSE} + Length(TypeData.IntfUnit) + 1; + {$ENDIF} +{$ELSE} + result := SizeOf(TypeData.IntfParent) + + SizeOf(TypeData.IntfFlags) + + SizeOf(TypeData.Guid) + + Length(TypeData.IntfUnit) + 1; +{$ENDIF} +end; + +function TInterfaceTypeDataContainer.GetSize: Integer; +begin + result := TypeDataSize + + PropDataContainer.Size; +end; + +procedure TInterfaceTypeDataContainer.SaveToStream(S: TStream); +var + K: Integer; +begin + K := TypeDataSize; + S.Write(K, SizeOf(K)); + S.Write(TypeData, TypeDataSize); + PropDataContainer.SaveToStream(S); + SaveStringToStream(FullParentName, S); + SubDescList.SaveToStream(S); + S.Write(GUID, SizeOf(GUID)); +end; + +procedure TInterfaceTypeDataContainer.SaveToBuff(S: TStream); +begin + S.Write(TypeData, TypeDataSize); + PropDataContainer.SaveToBuff(S); +end; + +procedure TInterfaceTypeDataContainer.LoadFromStream(S: TStream); +var + K: Integer; +begin + S.Read(K, SizeOf(K)); + S.Read(TypeData, K); + PropDataContainer.LoadFromStream(S); + FullParentName := LoadStringFromStream(S); + SubDescList.LoadFromStream(S); + S.Read(GUID, SizeOf(GUID)); +end; + +// TArrayTypeDataContainer ----------------------------------------------------- + +procedure TArrayTypeDataContainer.SaveToStream(S: TStream); +begin + inherited; + SaveStringToStream(FullRangeTypeName, S); + SaveStringToStream(FullElemTypeName, S); + S.Write(B1, SizeOf(B1)); + S.Write(B2, SizeOf(B2)); + S.Write(FinRangeTypeId, SizeOf(FinRangeTypeId)); +end; + +procedure TArrayTypeDataContainer.SaveToBuff(S: TStream); +begin + S.Write(TypeData, SizeOf(TypeData)); +end; + +procedure TArrayTypeDataContainer.LoadFromStream(S: TStream); +begin + inherited; + FullRangeTypeName := LoadStringFromStream(S); + FullElemTypeName := LoadStringFromStream(S); + S.Read(B1, SizeOf(B1)); + S.Read(B2, SizeOf(B2)); + S.Read(FinRangeTypeId, SizeOf(FinRangeTypeId)); +end; + +// TRecordTypeDataContainer ---------------------------------------------------- + +constructor TRecordTypeDataContainer.Create(AOwner: TTypeInfoContainer); +begin + inherited; + FieldListContainer := TFieldListContainer.Create; +end; + +destructor TRecordTypeDataContainer.Destroy; +begin + FreeAndNil(FieldListContainer); + inherited; +end; + +function TRecordTypeDataContainer.GetSize: Integer; +begin + result := SizeOf(TypeData); +end; + +procedure TRecordTypeDataContainer.SaveToStream(S: TStream); +begin + inherited; + S.Write(IsPacked, SizeOf(IsPacked)); + FieldListContainer.SaveToStream(S); +end; + +procedure TRecordTypeDataContainer.SaveToBuff(S: TStream); +begin + S.Write(TypeData, SizeOf(TypeData)); +end; + +procedure TRecordTypeDataContainer.LoadFromStream(S: TStream); +begin + inherited; + S.Read(IsPacked, SizeOf(IsPacked)); + FieldListContainer.LoadFromStream(S); +end; + +// TAliasTypeDataContainer ----------------------------------------------------- + +procedure TAliasTypeDataContainer.SaveToStream(S: TStream); +begin + inherited; + SaveStringToStream(FullSourceTypeName, S); +end; + +procedure TAliasTypeDataContainer.LoadFromStream(S: TStream); +begin + inherited; + FullSourceTypeName := LoadStringFromStream(S); +end; + +// TPointerTypeDataContainer --------------------------------------------------- + +procedure TPointerTypeDataContainer.SaveToStream(S: TStream); +begin + inherited; + SaveStringToStream(FullOriginTypeName, S); +end; + +procedure TPointerTypeDataContainer.LoadFromStream(S: TStream); +begin + inherited; + FullOriginTypeName := LoadStringFromStream(S); +end; + +// TClassRefTypeDataContainer -------------------------------------------------- + +procedure TClassRefTypeDataContainer.SaveToStream(S: TStream); +begin + inherited; + SaveStringToStream(FullOriginTypeName, S); +end; + +procedure TClassRefTypeDataContainer.LoadFromStream(S: TStream); +begin + inherited; + FullOriginTypeName := LoadStringFromStream(S); +end; + +// TDynArrayTypeDataContainer -------------------------------------------------- + +procedure TDynArrayTypeDataContainer.SaveToStream(S: TStream); +begin + inherited; + SaveStringToStream(FullElementTypeName, S); +end; + +procedure TDynArrayTypeDataContainer.LoadFromStream(S: TStream); +begin + inherited; + FullElementTypeName := LoadStringFromStream(S); +end; + +// TProceduralTypeDataContainer ------------------------------------------------ + +constructor TProceduralTypeDataContainer.Create(AOwner: TTypeInfoContainer); +begin + inherited; + SubDesc := TSubDesc.Create; +end; + +destructor TProceduralTypeDataContainer.Destroy; +begin + FreeAndNil(SubDesc); + inherited; +end; + +procedure TProceduralTypeDataContainer.SaveToStream(S: TStream); +begin + inherited; + SubDesc.SaveToStream(S); +end; + +procedure TProceduralTypeDataContainer.LoadFromStream(S: TStream); +begin + inherited; + SubDesc.LoadFromStream(S); +end; + +// TEnumTypeInfoContainer ------------------------------------------------------ + +constructor TEnumTypeInfoContainer.Create(const AName: String); +begin + inherited Create(0); + TypeInfo.Kind := tkEnumeration; + PShortStringFromString(PShortString(@TypeInfo.Name), AName); + FreeAndNil(TypeDataContainer); + TypeDataContainer := TEnumTypeDataContainer.Create(Self); + FinTypeId := typeENUM; +end; + +// TSetTypeInfoContainer ----------------------------------------------------- + +constructor TSetTypeInfoContainer.Create(const AName: String); +begin + inherited Create(0); + TypeInfo.Kind := tkSet; + PShortStringFromString(PShortString(@TypeInfo.Name), AName); + FreeAndNil(TypeDataContainer); + TypeDataContainer := TSetTypeDataContainer.Create(Self); + FinTypeId := typeSET; +end; + +// TClassTypeInfoContainer ----------------------------------------------------- + +constructor TClassTypeInfoContainer.Create(const AName: String); +begin + inherited Create(0); + TypeInfo.Kind := tkClass; + PShortStringFromString(PShortString(@TypeInfo.Name), AName); + FreeAndNil(TypeDataContainer); + TypeDataContainer := TClassTypeDataContainer.Create(Self); + FinTypeId := typeCLASS; +end; + +// TInterfaceTypeInfoContainer ----------------------------------------------------- + +constructor TInterfaceTypeInfoContainer.Create(const AName: String); +begin + inherited Create(0); + TypeInfo.Kind := tkInterface; + PShortStringFromString(PShortString(@TypeInfo.Name), AName); + FreeAndNil(TypeDataContainer); + TypeDataContainer := TInterfaceTypeDataContainer.Create(Self); + FinTypeId := typeINTERFACE; +end; + +// TMethodTypeInfoContainer ----------------------------------------------------- + +constructor TMethodTypeInfoContainer.Create(const AName: String); +begin + inherited Create(0); + TypeInfo.Kind := tkMethod; + PShortStringFromString(PShortString(@TypeInfo.Name), AName); + FreeAndNil(TypeDataContainer); + TypeDataContainer := TMethodTypeDataContainer.Create(Self); + FinTypeId := typeEVENT; +end; + +// TArrayTypeInfoContainer ----------------------------------------------------- + +constructor TArrayTypeInfoContainer.Create(const AName: String); +begin + inherited Create(0); + TypeInfo.Kind := tkArray; + PShortStringFromString(PShortString(@TypeInfo.Name), AName); + FreeAndNil(TypeDataContainer); + TypeDataContainer := TArrayTypeDataContainer.Create(Self); + FinTypeId := typeARRAY; +end; + +// TRecordTypeInfoContainer ---------------------------------------------------- + +constructor TRecordTypeInfoContainer.Create(const AName: String); +begin + inherited Create(0); + TypeInfo.Kind := tkRecord; + PShortStringFromString(PShortString(@TypeInfo.Name), AName); + FreeAndNil(TypeDataContainer); + TypeDataContainer := TRecordTypeDataContainer.Create(Self); + FinTypeId := typeRECORD; +end; + +// TAliasTypeInfoContainer ----------------------------------------------------- + +constructor TAliasTypeInfoContainer.Create(const AName: String); +begin + inherited Create(0); + TypeInfo.Kind := tkUnknown; + PShortStringFromString(PShortString(@TypeInfo.Name), AName); + FreeAndNil(TypeDataContainer); + TypeDataContainer := TAliasTypeDataContainer.Create(Self); + FinTypeId := typeALIAS; +end; + +// TPointerTypeInfoContainer --------------------------------------------------- + +constructor TPointerTypeInfoContainer.Create(const AName: String); +begin + inherited Create(0); + TypeInfo.Kind := tkUnknown; + PShortStringFromString(PShortString(@TypeInfo.Name), AName); + FreeAndNil(TypeDataContainer); + TypeDataContainer := TPointerTypeDataContainer.Create(Self); + FinTypeId := typePOINTER; +end; + +// TClassRefTypeInfoContainer -------------------------------------------------- + +constructor TClassRefTypeInfoContainer.Create(const AName: String); +begin + inherited Create(0); + TypeInfo.Kind := tkUnknown; + PShortStringFromString(PShortString(@TypeInfo.Name), AName); + FreeAndNil(TypeDataContainer); + TypeDataContainer := TClassRefTypeDataContainer.Create(Self); + FinTypeId := typeCLASSREF; +end; + +// TDynArrayTypeInfoContainer -------------------------------------------------- + +constructor TDynArrayTypeInfoContainer.Create(const AName: String); +begin + inherited Create(0); + TypeInfo.Kind := tkDynArray; + PShortStringFromString(PShortString(@TypeInfo.Name), AName); + FreeAndNil(TypeDataContainer); + TypeDataContainer := TDynArrayTypeDataContainer.Create(Self); + FinTypeId := typeDYNARRAY; +end; + +// TProceduralTypeInfoContainer ------------------------------------------------ + +constructor TProceduralTypeInfoContainer.Create(const AName: String); +begin + inherited Create(0); + TypeInfo.Kind := tkUnknown; + PShortStringFromString(PShortString(@TypeInfo.Name), AName); + FreeAndNil(TypeDataContainer); + TypeDataContainer := TProceduralTypeDataContainer.Create(Self); + FinTypeId := typePROC; +end; + +// TTypeInfoContainer ------------------------------------------------------- + +constructor TTypeInfoContainer.Create(AFinTypeId: Integer); +begin + inherited Create; + TypeDataContainer := TTypeDataContainer.Create(Self); + FinTypeId := AFinTypeId; + GenericTypeContainer := TGenericTypeContainer.Create; +end; + +destructor TTypeInfoContainer.Destroy; +begin + if Assigned(Buff) then + FreeMem(Buff, Size); + FreeAndNil(TypeDataContainer); + FreeAndNil(GenericTypeContainer); + + inherited; +end; + +function TTypeInfoContainer.GetIsGeneric: Boolean; +begin + result := GenericTypeContainer.Definition <> ''; +end; + +function TTypeInfoContainer.GetSize: Integer; +begin +{$IFDEF ARC} + result := SizeOf(TTypeKind) + TypeInfo.Name[0] + 1 + + TypeDataContainer.Size; +{$ELSE} + result := SizeOf(TTypeKind) + Length(TypeInfo.Name) + 1 + + TypeDataContainer.Size; +{$ENDIF} +end; + +function TTypeInfoContainer.GetPosTypeData: Integer; +begin +{$IFDEF ARC} + result := SizeOf(TTypeKind) + TypeInfo.Name[0] + 1; +{$ELSE} + result := SizeOf(TTypeKind) + Length(TypeInfo.Name) + 1; +{$ENDIF} +end; + +function TTypeInfoContainer.GetStreamSize: Integer; +var + M: TMemoryStream; +begin + M := TMemoryStream.Create; + try + SaveToStream(M); + result := M.Size; + finally + FreeAndNil(M); + end; +end; + +procedure TTypeInfoContainer.SaveToStream(S: TStream); +begin + S.Write(TypeInfo.Kind, SizeOf(TTypeKind)); + SaveShortStringToStream(PShortString(@TypeInfo.Name)^, S); + TypeDataContainer.SaveToStream(S); + SaveStringToStream(FullName, S); + GenericTypeContainer.SaveToStream(S); +end; + +procedure TTypeInfoContainer.SaveToBuff(S: TStream); +begin + S.Write(TypeInfo.Kind, SizeOf(TTypeKind)); + SaveShortStringToStream(PShortString(@TypeInfo.Name)^, S); + TypeDataContainer.SaveToBuff(S); +end; + +procedure TTypeInfoContainer.LoadFromStream(S: TStream; + FinTypeId: Byte); +begin + S.Read(TypeInfo.Kind, SizeOf(TTypeKind)); + _ShortStringAssign(LoadShortStringFromStream(S), 255, PShortString(@TypeInfo.Name)); + + FreeAndNil(TypeDataContainer); + + case FinTypeId of + typeCLASS: TypeDataContainer := TClassTypeDataContainer.Create(Self); + typeINTERFACE: TypeDataContainer := TInterfaceTypeDataContainer.Create(Self); + typeEVENT: TypeDataContainer := TMethodTypeDataContainer.Create(Self); + typeSET: TypeDataContainer := TSetTypeDataContainer.Create(Self); + typeENUM: TypeDataContainer := TEnumTypeDataContainer.Create(Self); + typeARRAY: TypeDataContainer := TArrayTypeDataContainer.Create(Self); + typeRECORD: TypeDataContainer := TRecordTypeDataContainer.Create(Self); + typeALIAS: TypeDataContainer := TAliasTypeDataContainer.Create(Self); + typePOINTER: TypeDataContainer := TPointerTypeDataContainer.Create(Self); + typeCLASSREF: TypeDataContainer := TClassRefTypeDataContainer.Create(Self); + typeDYNARRAY: TypeDataContainer := TDynArrayTypeDataContainer.Create(Self); + typePROC: TypeDataContainer := TProceduralTypeDataContainer.Create(Self); + else + TypeDataContainer := TTypeDataContainer.Create(Self); + end; + + TypeDataContainer.LoadFromStream(S); + FullName := LoadStringFromStream(S); + GenericTypeContainer.LoadFromStream(S); +end; + +procedure TTypeInfoContainer.RaiseError(const Message: string; params: array of Const); +begin + raise Exception.Create(Format(Message, params)); +end; + +// TPaxTypeInfoList ------------------------------------------------------------ + +destructor TPaxTypeInfoList.Destroy; +begin + inherited; +end; + +function TPaxTypeInfoList.GetRecord(I: Integer): TTypeInfoContainer; +begin + result := TTypeInfoContainer(L[I]); +end; + +procedure TPaxTypeInfoList.Add(Rec: TTypeInfoContainer); +begin + L.Add(Rec); +end; + +procedure TPaxTypeInfoList.SaveToStream(S: TStream); +var + I, K: Integer; +begin + K := Count; + S.Write(K, SizeOf(Integer)); + for I:=0 to K - 1 do + begin + S.Write(Records[I].FinTypeId, SizeOf(Records[I].FinTypeId)); + Records[I].SaveToStream(S); + end; +end; + +procedure TPaxTypeInfoList.LoadFromStream(S: TStream); +var + I, K: Integer; + R: TTypeInfoContainer; + FinTypeId: Byte; +begin + Clear; + + S.Read(K, SizeOf(Integer)); + for I:=0 to K - 1 do + begin + S.Read(FinTypeId, SizeOf(Byte)); + + case FinTypeId of + typeCLASS: R := TClassTypeInfoContainer.Create(''); + typeINTERFACE: R := TInterfaceTypeInfoContainer.Create(''); + typeEVENT: R := TMethodTypeInfoContainer.Create(''); + typeSET: R := TSetTypeInfoContainer.Create(''); + typeENUM: R := TEnumTypeInfoContainer.Create(''); + typeARRAY: R := TArrayTypeInfoContainer.Create(''); + typeRECORD: R := TRecordTypeInfoContainer.Create(''); + typeALIAS: R := TAliasTypeInfoContainer.Create(''); + typePOINTER: R := TPointerTypeInfoContainer.Create(''); + typeCLASSREF: R := TClassRefTypeInfoContainer.Create(''); + typeDYNARRAY: R := TDynArrayTypeInfoContainer.Create(''); + typePROC: R := TProceduralTypeInfoContainer.Create(''); + else + R := TTypeInfoContainer.Create(FinTypeId); + end; + + R.LoadFromStream(S, FinTypeId); + + Add(R); + end; +end; + +function TPaxTypeInfoList.LookupFullName(const FullName: String): TTypeInfoContainer; +var + I: Integer; +begin + result := nil; + for I := 0 to Count - 1 do + if StrEql(FullName, String(Records[I].FullName)) then + begin + result := Records[I]; + Exit; + end; +end; + +function TPaxTypeInfoList.IndexOf(const FullName: String): Integer; +var + I: Integer; +begin + result := -1; + for I := 0 to Count - 1 do + if StrEql(FullName, String(Records[I].FullName)) then + begin + result := I; + Exit; + end; +end; + +procedure TPaxTypeInfoList.CopyToBuff; +var + S: TMemoryStream; + I, SZ, StreamSize, K: Integer; +begin + for I := 0 to Count - 1 do + begin + SZ := Records[I].Size; + StreamSize := Records[I].GetStreamSize; + + K := SizeOf(Integer) + SZ + + SizeOf(Integer) + StreamSize; + + Records[I].Buff := AllocMem(K); + Records[I].Buff4 := ShiftPointer(Records[I].Buff, 4); + + S := TMemoryStream.Create; + try + S.Write(SZ, SizeOf(Integer)); + Records[I].SaveToBuff(S); + + S.Write(StreamSize, SizeOf(Integer)); + Records[I].SaveToStream(S); + + S.Position := 0; + S.Read(Records[I].Buff^, K); + + finally + FreeAndNil(S); + end; + end; +end; + +procedure TPaxTypeInfoList.AddToProgram(AProg: Pointer); +var + ClassFactory: TPaxClassFactory; + I, J, JJ: Integer; + P: Pointer; + R: TPaxClassFactoryRec; + C: TClass; + ptd: PTypeData; + pti, pti_parent: PTypeInfo; + Record_Parent, Record_Temp: TTypeInfoContainer; + PropDataContainer: TPropDataContainer; + Prog: TBaseRunner; + FullName: String; + ppi: PPropInfo; + Z, ZZ: Integer; + + ClassTypeInfoContainer: TClassTypeInfoContainer; + ClassTypeDataContainer: TClassTypeDataContainer; + + MethodTypeInfoContainer: TMethodTypeInfoContainer; + MethodTypeDataContainer: TMethodTypeDataContainer; + + InterfaceTypeDataContainer: TInterfaceTypeDataContainer; + SetTypeDataContainer: TSetTypeDataContainer; + + MethodTableIndex: Integer; + PMethod: PVmtMethod; + + FieldListContainer: TFieldListContainer; + PField: PVmtField; + ClassRec: TClassRec; + RI: TTypeInfoContainer; + ParentPropCount: Integer; + MR, SomeMR: TMapRec; + FileName, ProcName: String; + DestProg: Pointer; +begin + Prog := TBaseRunner(AProg); + ClassFactory := Prog.ProgClassFactory; + + CopyToBuff; + + for I:=0 to Count - 1 do + Records[I].Processed := false; + + repeat + + for I:=0 to Count - 1 do + begin + RI := Records[I]; + if RI.Processed then + continue; + + pti := RI.Buff4; + + case RI.TypeInfo.Kind of + tkEnumeration: + begin + ptd := ShiftPointer(pti, RI.PosTypeData); +{$IFDEF FPC} + ptd^.BaseType := RI.Buff4; +{$ELSE} + ptd^.BaseType := @ RI.Buff4; +{$ENDIF} + + RI.Processed := true; + end; + tkSet: + begin + RI.Processed := true; + + ptd := ShiftPointer(pti, RI.PosTypeData); + + SetTypeDataContainer := RI.TypeDataContainer as + TSetTypeDataContainer; + + Record_Temp := LookupFullName(SetTypeDataContainer.FullCompName); + if Record_Temp = nil then + ptd^.CompType := nil + else +{$IFDEF FPC} + ptd^.CompType := Record_Temp.buff4; +{$ELSE} + ptd^.CompType := @ Record_Temp.buff4; +{$ENDIF} + + end; + tkMethod: + begin + RI.Processed := true; + + MethodTypeInfoContainer := TMethodTypeInfoContainer(RI); + MethodTypeDataContainer := TMethodTypeDataContainer(MethodTypeInfoContainer.TypeDataContainer); + if MethodTypeDataContainer.OwnerTypeName = '' then + continue; + + Record_Temp := LookupFullName(MethodTypeDataContainer.OwnerTypeName); + if Record_Temp = nil then + RaiseError(errInternalError, []); + R := ClassFactory.FindRecordByFullName(MethodTypeDataContainer.OwnerTypeName); + if R = nil then + RaiseError(errInternalError, []); + + ClassTypeInfoContainer := Record_Temp as + TClassTypeInfoContainer; + ClassTypeDataContainer := Record_Temp.TypeDataContainer as + TClassTypeDataContainer; + + if R.MethodTableSize = 0 then + begin + R.MethodTableSize := ClassTypeDataContainer.MethodTableSize; + vmtMethodTableSlot(R.VMTPtr)^ := AllocMem(R.MethodTableSize); + PVmtMethodTable(vmtMethodTableSlot(R.VMTPtr)^)^.Count := + ClassTypeDataContainer.MethodTableCount; + end; + PMethod := ShiftPointer(vmtMethodTableSlot(R.VMTPtr)^, + SizeOf(TVmtMethodCount)); + + MethodTableIndex := MethodTypeDataContainer.MethodTableIndex; + + for J := 0 to MethodTableIndex - 1 do + PMethod := ShiftPointer(PMethod, GetMethodSize(PMethod)); + +{$IFDEF FPC} + PMethod^.MethName := @ MethodTypeInfoContainer.TypeInfo.Name; + FullName := MethodTypeDataContainer.OwnerTypeName + '.' + + String(PMethod^.MethName^); + PMethod^.MethAddr := Prog.GetAddress(FullName, MR); + + DestProg := Prog; + if PMethod^.MethAddr = nil then + begin + FileName := ExtractOwner(FullName) + '.' + PCU_FILE_EXT; + ProcName := Copy(FullName, PosCh('.', FullName) + 1, Length(FullName)); + PMethod^.MethAddr := Prog.LoadAddressEx(FileName, ProcName, false, + MethodTypeDataContainer.OverCount, SomeMR, DestProg); + end; + TBaseRunner(DestProg).WrapMethodAddress(PMethod^.MethAddr); + MethodTypeDataContainer.Address := PMethod^.MethAddr; +{$ELSE} + _ShortStringAssign(PShortString(@MethodTypeInfoContainer.TypeInfo.Name)^, + 255, + PShortString(@PMethod^.Name)); + FullName := MethodTypeDataContainer.OwnerTypeName + '.' + + StringFromPShortString(PShortString(@PMethod^.Name)); + PMethod^.Address := Prog.GetAddress(FullName, MR); + DestProg := Prog; + if PMethod^.Address = nil then + begin + FileName := ExtractOwner(FullName) + '.' + PCU_FILE_EXT; + ProcName := Copy(FullName, PosCh('.', FullName) + 1, Length(FullName)); + PMethod^.Address := Prog.LoadAddressEx(FileName, ProcName, false, + MethodTypeDataContainer.OverCount, SomeMR, DestProg); + end; + + TBaseRunner(DestProg).WrapMethodAddress(PMethod^.Address); + + {$ifdef PAX64} + PMethod^.Size := SizeOf(Word) + + SizeOf(Pointer) + + Length(PMethod^.Name) + 1; + {$endif} + + {$ifdef WIN32} + PMethod^.Size := SizeOf(Word) + + SizeOf(Pointer) + + Length(PMethod^.Name) + 1; + {$endif} + + {$ifdef MACOS} + PMethod^.Size := SizeOf(Word) + + SizeOf(Pointer) + + Length(PMethod^.Name) + 1; + {$endif} + + {$ifdef ARC} + PMethod^.Size := SizeOf(Word) + + SizeOf(Pointer) + + PMethod^.Name[0] + 1; + {$ENDIF} + + MethodTypeDataContainer.Address := PMethod^.Address; +{$ENDIF} + end; + tkInterface: + begin + RI.Processed := true; + + ptd := ShiftPointer(pti, RI.PosTypeData); + + InterfaceTypeDataContainer := RI.TypeDataContainer as + TInterfaceTypeDataContainer; + + Record_Parent := LookupFullName(InterfaceTypeDataContainer.FullParentName); + if Record_Parent = nil then + ptd^.IntfParent := nil + else +{$IFDEF FPC} + ptd^.IntfParent := Record_Parent.buff4; +{$ELSE} + ptd^.IntfParent := @ Record_Parent.buff4; +{$ENDIF} + + Z := RI.TypeDataContainer.TypeDataSize + + SizeOf(TPropData); + + PropDataContainer := InterfaceTypeDataContainer.PropDataContainer; + + for J := 0 to PropDataContainer.Count - 1 do + begin + ZZ := 0; + if J > 0 then + for JJ := 0 to J - 1 do + Inc(ZZ, PropInfoSize(PropDataContainer.PropList[JJ])); + + ppi := ShiftPointer(ptd, Z + ZZ); + + ppi^.NameIndex := J; + + Record_Temp := LookupFullName(PropDataContainer.PropTypeNames[J]); + if Record_Temp = nil then + begin + ppi^.PropType := nil; + end + else + {$IFDEF FPC} + ppi^.PropType := Record_Temp.Buff4; + {$ELSE} + ppi^.PropType := PPTypeInfo(@Record_Temp.Buff4); + {$ENDIF} + end; + end; + tkClass: + begin + R := ClassFactory.FindRecordByFullName(String(RI.FullName)); + + if R = nil then + RaiseError(errInternalError, []); + + ClassTypeInfoContainer := RI as + TClassTypeInfoContainer; + ClassTypeDataContainer := RI.TypeDataContainer as + TClassTypeDataContainer; + +// R.VMTPtr^.DynamicTable := Prog.MessageList.CreateDmtTable(ExtractName(RI.FullName), +// R.DmtTableSize); + ClassRec := Prog.ClassList.Lookup(String(RI.FullName)); + if ClassRec <> nil then + begin + if ClassRec.IntfList.Count > 0 then + begin + R.IntfTableSize := ClassRec.GetIntfTableSize; + vmtIntfTableSlot(R.VMTPtr)^ := AllocMem(R.IntfTableSize); + with PInterfaceTable(vmtIntfTableSlot(R.VMTPtr)^)^ do + begin + EntryCount := ClassRec.IntfList.Count; + for J := 0 to EntryCount - 1 do + begin +{$IFDEF FPC} + Entries[J].IID := @ ClassRec.IntfList[J].GUID; +{$ELSE} + Entries[J].IID := ClassRec.IntfList[J].GUID; +{$ENDIF} + Entries[J].VTable := ClassRec.IntfList[J].Buff; + Entries[J].IOffset := ClassRec.GetIntfOffset(ClassRec.IntfList[J].GUID); + end; + end; + end; + end; + + if ClassTypeDataContainer.FieldTableCount > 0 then + begin + if R.FieldClassTable = nil then + R.FieldClassTable := + CreateFieldClassTable(ClassTypeDataContainer.FieldTableCount); + + if R.FieldTableSize = 0 then + begin + R.FieldTableSize := ClassTypeDataContainer.FieldTableSize; + vmtFieldTableSlot(R.VMTPtr)^ := AllocMem(R.FieldTableSize); + end; + + FieldListContainer := + ClassTypeDataContainer.FieldListContainer; + + PVmtFieldTable(vmtFieldTableSlot(R.VMTPtr)^)^.Count := + FieldListContainer.Count; + + {$IFDEF ARC} + P := ShiftPointer(vmtFieldTableSlot(R.VMTPtr)^, + SizeOf(Word)); + Pointer(P^) := R.FieldClassTable; + PField := ShiftPointer(vmtFieldTableSlot(R.VMTPtr)^, + SizeOf(Word) + SizeOf(Pointer)); + {$ELSE} + + {$IFDEF PAX64} + P := ShiftPointer(vmtFieldTableSlot(R.VMTPtr)^, + SizeOf(Word)); + Pointer(P^) := R.FieldClassTable; + PField := ShiftPointer(vmtFieldTableSlot(R.VMTPtr)^, + SizeOf(Word) + SizeOf(Pointer)); + {$ELSE} + {$ifdef WIN32} + P := ShiftPointer(vmtFieldTableSlot(R.VMTPtr)^, + SizeOf(Word)); + Pointer(P^) := R.FieldClassTable; + PField := ShiftPointer(vmtFieldTableSlot(R.VMTPtr)^, + SizeOf(Word) + SizeOf(Pointer)); + {$else} + PField := ShiftPointer(vmtFieldTableSlot(R.VMTPtr)^, + SizeOf(Word) + SizeOf(Word)); + {$endif} + {$ENDIF} + + {$ENDIF} + + for J := 0 to FieldListContainer.Count - 1 do + begin + // set up PField + + PField^.Name := FieldListContainer[J].Name; + PField^.Offset := FieldListContainer[J].Offset; + PField^.ClassIndex := J; + + ClassRec := Prog.ClassList.Lookup(FieldListContainer[J].FullFieldTypeName); + if ClassRec <> nil then + begin + if ClassRec.Host then +{$IFDEF FPC} + R.FieldClassTable^.Classes[J] := ClassRec.PClass; +{$ELSE} + R.FieldClassTable^.Classes[J] := @ ClassRec.PClass; +{$ENDIF} + end; + + PField := ShiftPointer(PField, GetFieldSize(PField)); + end; + end; + + vmtTypeInfoSlot(R.VMTPtr)^ := pti; + {$IFDEF FPC} + C := TClass(R.VMTPtr); + {$ELSE} + C := vmtSelfPtrSlot(R.VMTPtr)^; + {$ENDIF} + ptd := ShiftPointer(pti, RI.PosTypeData); + ptd^.ClassType := C; + + pti_parent := nil; + + C := C.ClassParent; + if IsPaxClass(C) then + begin + Record_Parent := LookupFullName(ClassTypeDataContainer.FullParentName); + if Record_Parent <> nil then + if not Record_Parent.Processed then + continue; + + if Record_Parent = nil then + begin + ClassRec := Prog.ClassList.Lookup(ClassTypeDataContainer.FullParentName); + if ClassRec = nil then + RaiseError(errInternalError, []); + pti_parent := C.ClassInfo; + end + else + pti_parent := Record_Parent.buff4; + end + else + begin + if Assigned(C) then + pti_parent := C.ClassInfo; + end; + + RI.Processed := true; + + R.pti_parent := pti_parent; +{$IFDEF FPC} + ptd^.ParentInfo := R.pti_parent; +{$ELSE} + ptd^.ParentInfo := @ R.pti_parent; +{$ENDIF} + ptd^.PropCount := RI.TypeDataContainer.TypeData.PropCount; + ptd^.UnitName := RI.TypeDataContainer.TypeData.UnitName; + + Z := RI.TypeDataContainer.TypeDataSize + + SizeOf(TPropData); + + PropDataContainer := + TClassTypeDataContainer(RI.TypeDataContainer).PropDataContainer; + + if pti_parent <> nil then + ParentPropCount := GetTypeData(pti_parent)^.PropCount + else + ParentPropCount := 0; + + Inc(ptd^.PropCount, ParentPropCount); + + for J := 0 to PropDataContainer.Count - 1 do + begin + ZZ := 0; + if J > 0 then + for JJ := 0 to J - 1 do + Inc(ZZ, PropInfoSize(PropDataContainer.PropList[JJ])); + + ppi := ShiftPointer(ptd, Z + ZZ); + + ppi^.NameIndex := J + ParentPropCount; + + Record_Temp := LookupFullName(PropDataContainer.PropTypeNames[J]); + if Record_Temp = nil then + begin +// ClassRec := Prog.ClassList.Lookup(String(ClassTypeDataContainer.FullParentName)); + ClassRec := Prog.ClassList.Lookup(PropDataContainer.PropTypeNames[J]); + if ClassRec = nil then + RaiseError(errInternalError, []); + ClassRec.PClass_pti := ClassRec.PClass.ClassInfo; +{$IFDEF FPC} + ppi^.PropType := ClassRec.PClass_pti; +{$ELSE} + ppi^.PropType := @ ClassRec.PClass_pti; +{$ENDIF} + end + else + {$IFDEF FPC} + ppi^.PropType := Record_Temp.Buff4; + {$ELSE} + ppi^.PropType := PPTypeInfo(@Record_Temp.Buff4); + {$ENDIF} + + FullName := PropDataContainer.ReadNames[J]; + if Length(FullName) > 0 then + begin + DestProg := Prog; + ppi^.GetProc := Prog.GetAddress(FullName, MR); + if ppi^.GetProc = nil then + begin + FileName := ExtractOwner(FullName) + '.' + PCU_FILE_EXT; + ProcName := Copy(FullName, PosCh('.', FullName) + 1, Length(FullName)); + ppi^.GetProc := Prog.LoadAddressEx(FileName, ProcName, false, 0, SomeMR, DestProg); + end; + TBaseRunner(DestProg).WrapMethodAddress(ppi^.GetProc); + end; + FullName := PropDataContainer.WriteNames[J]; + if Length(FullName) > 0 then + begin + DestProg := Prog; + ppi^.SetProc := Prog.GetAddress(FullName, MR); + if ppi^.SetProc = nil then + begin + FileName := ExtractOwner(FullName) + '.' + PCU_FILE_EXT; + ProcName := Copy(FullName, PosCh('.', FullName) + 1, Length(FullName)); + ppi^.SetProc := Prog.LoadAddressEx(FileName, ProcName, false, 0, SomeMR, DestProg); + end; + TBaseRunner(DestProg).WrapMethodAddress(ppi^.SetProc); + end; + + ppi^.Index := Integer($80000000); // no index + end; + end; // tkClass + else + begin + RI.Processed := true; + end; + end; // case + end; // i-loop + + until Processed; +end; + +function TPaxTypeInfoList.Processed: Boolean; +var + I: Integer; +begin + result := true; + for I := 0 to Count - 1 do + if not Records[I].Processed then + begin + result := false; + Exit; + end; +end; + +function TPaxTypeInfoList.FindMethodFullName(Address: Pointer): String; +var + I: Integer; + MethodTypeDataContainer: TMethodTypeDataContainer; +begin + result := ''; + + for I := 0 to Count - 1 do + if Records[I].TypeInfo.Kind = tkMethod then + begin + MethodTypeDataContainer := Records[I].TypeDataContainer as + TMethodTypeDataContainer; + if MethodTypeDataContainer.Address = Address then + begin + result := String(Records[I].FullName); + Exit; + end; + end; +end; + +procedure TPaxTypeInfoList.RaiseError(const Message: string; params: array of Const); +begin + raise Exception.Create(Format(Message, params)); +end; + +function GetClassTypeInfoContainer(X: TObject): TClassTypeInfoContainer; +var + pti: PTypeInfo; + P: Pointer; + sz, StreamSize: Integer; + M: TMemoryStream; +begin + result := nil; + pti := X.ClassInfo; + if pti = nil then + Exit; + if not IsPaxObject(X) then + Exit; + P := ShiftPointer(pti, - SizeOf(Integer)); + sz := Integer(p^); + P := ShiftPointer(pti, sz); + StreamSize := Integer(P^); + P := ShiftPointer(P, SizeOf(Integer)); // p points to stream + M := TMemoryStream.Create; + try + M.Write(P^, StreamSize); + M.Position := 0; + result := TClassTypeInfoContainer.Create(X.ClassName); + result.LoadFromStream(M, typeCLASS); + finally + FreeAndNil(M); + end; +end; + +function GetTypeInfoContainer(pti: PTypeInfo): TTypeInfoContainer; +var + P: Pointer; + sz, StreamSize: Integer; + M: TMemoryStream; +begin + result := nil; + P := ShiftPointer(pti, - SizeOf(Integer)); + sz := Integer(p^); + P := ShiftPointer(pti, sz); + StreamSize := Integer(P^); + P := ShiftPointer(P, SizeOf(Integer)); // p points to stream + M := TMemoryStream.Create; + try + M.Write(P^, StreamSize); + M.Position := 0; +// result := TTypeInfoContainer.Create; +// result.LoadFromStream(M, typeCLASS); + finally + FreeAndNil(M); + end; +end; + + +end. diff --git a/Sources/PAXCOMP_TYPES.pas b/Sources/PAXCOMP_TYPES.pas new file mode 100644 index 0000000..9db6b22 --- /dev/null +++ b/Sources/PAXCOMP_TYPES.pas @@ -0,0 +1,2137 @@ +//////////////////////////////////////////////////////////////////////////// +// PaxCompiler +// Site: http://www.paxcompiler.com +// Author: Alexander Baranovsky (paxscript@gmail.com) +// ======================================================================== +// Copyright (c) Alexander Baranovsky, 2006-2014. All rights reserved. +// Code Version: 4.2 +// ======================================================================== +// Unit: PAXCOMP_TYPES.pas +// ======================================================================== +//////////////////////////////////////////////////////////////////////////// + +{$I PaxCompiler.def} + +unit PAXCOMP_TYPES; +interface +uses {$I uses.def} + SysUtils, + Classes, + PAXCOMP_CONSTANTS; +type + TPauseException = class(EAbort) + public + constructor Create; + end; + + THaltException = class(EAbort) + public + ExitCode: Integer; + constructor Create(i_ExitCode: Integer); + end; + + TWorkException = class(EAbort) + end; + + PaxCompilerException = class(Exception) + end; + + PaxCancelException = class(EAbort) + end; + + TExitMode = (emExit, emBreak, emContinue); + + PaxExitException = class(EAbort) + public + Mode: TExitMode; + end; + +{$IFDEF ARC} + TPtrList = class(TList); +{$ELSE} + TPtrList = TList; +{$ENDIF} + + TTypedList = class + private + function GetCount: Integer; + function GetLast: TObject; + protected +{$IFDEF ARC} + L: TList; +{$ELSE} + L: TList; +{$ENDIF} + public + constructor Create; + destructor Destroy; override; + procedure Clear; virtual; + procedure RemoveAt(I: Integer); virtual; + procedure InsertAt(I: Integer; X: TObject); + procedure RemoveTop; + procedure Remove(X: TObject); + function IndexOf(P: Pointer): Integer; + property Count: Integer read GetCount; + property Last: TObject read GetLast; + end; + + TIntegerList = class + private +{$IFDEF ARC} + fItems: TList; +{$ELSE} + fItems: TList; +{$ENDIF} + fDupNo: Boolean; + function GetItem(I: Integer): Integer; + procedure SetItem(I: Integer; value: Integer); + function GetCount: Integer; + public + constructor Create(DupNo: Boolean = false); + destructor Destroy; override; + procedure Clear; + function Add(value: Integer): Integer; + procedure Insert(I: Integer; value: Integer); + function IndexOf(value: Integer): Integer; + function LastIndexOf(value: Integer): Integer; + procedure RemoveAt(I: Integer); + procedure DeleteValue(value: Integer); + function Top: Integer; + procedure SaveToStream(S: TStream); + procedure LoadFromStream(S: TStream); + function SaveToPtr(P: Pointer): Integer; + function LoadFromPtr(P: Pointer): Integer; + procedure SaveToWriter(S: TWriter); + procedure LoadFromReader(S: TReader); + function Clone: TIntegerList; + function BinSearch(const Key: Integer): Integer; + procedure QuickSort; overload; + procedure QuickSort(Start, Stop: Integer); overload; + property Count: Integer read GetCount; + property Items[I: Integer]: Integer read GetItem write SetItem; default; + property Last: Integer read Top; + end; + + TIntegerStack = class(TIntegerList) + public + procedure Push(value: Integer); + function Pop: Integer; + function Depth(value: Integer): Integer; + end; + + TAssocIntegers = class + private + function GetCount: Integer; + public + Keys, Values: TIntegerList; + constructor Create; + destructor Destroy; override; + procedure Clear; + procedure Add(Key, Value: Integer); + procedure SaveToStream(S: TStream); + procedure LoadFromStream(S: TStream); + function SaveToPtr(P: Pointer): Integer; + function LoadFromPtr(P: Pointer): Integer; + function Clone: TAssocIntegers; + procedure RemoveAt(I: Integer); + function IndexOf(K, V: Integer): Integer; + function Inside(c: Integer): Boolean; + property Count: Integer read GetCount; + end; + + TAssocStrings = class + private + function GetCount: Integer; + function GetValue(const Key: String): String; + procedure SetValue(const Key, Value: String); + public + Keys, Values: TStringList; + constructor Create; + destructor Destroy; override; + procedure Clear; + procedure Add(const Key, Value: String); + procedure RemoveAt(I: Integer); + property Count: Integer read GetCount; + property ValueByKey[const S: String]: String + read GetValue write SetValue; default; + end; + + TStringObjectList = class(TStringList) + private + procedure ClearObjects; + public + procedure Clear; override; + destructor Destroy; override; + end; + + TAnonymContextRec = class + public + SubId: Integer; + BindList: TIntegerList; + constructor Create; + destructor Destroy; override; + end; + + TAnonymContextStack = class(TTypedList) + private + function GetRecord(I: Integer): TAnonymContextRec; + function GetTop: TAnonymContextRec; + public + function Push(SubId: Integer): TAnonymContextRec; + procedure Pop; + property Top: TAnonymContextRec read GetTop; + property Records[I: Integer]: TAnonymContextRec read GetRecord; default; + end; + + TMessageRec = class + public + msg_id: Cardinal; + FullName: String; + Class_Name: String; + Address: Pointer; + procedure SaveToStream(S: TStream); + procedure LoadFromStream(S: TStream); + end; + + TMessageList = class(TTypedList) + private + function GetRecord(I: Integer): TMessageRec; + public + function IndexOf(const FullName: String): Integer; + function AddRecord: TMessageRec; + procedure SaveToStream(S: TStream); + procedure LoadFromStream(S: TStream); + function CreateDmtTable(const AClassName: String; var Size: Integer): Pointer; + property Records[I: Integer]: TMessageRec read GetRecord; default; + end; + + TActualParamRec = class + public + SubId: Integer; + Params: TPtrList; + constructor Create; + destructor Destroy; override; + end; + + TActualParamList = class(TTypedList) + private + function GetRecord(I: Integer): TActualParamRec; + public + function Add(SubId: Integer; Param: Pointer): TActualParamRec; + function Find(SubId: Integer): TActualParamRec; + procedure Remove(SubId: Integer); + property Records[I: Integer]: TActualParamRec read GetRecord; default; + end; + + TExportRec = class + public + Offset: Cardinal; // prog + Name: String; // prog + + Address: Cardinal; // pe + NameAddress: Cardinal; // pe + Ordinal: Word; // pe + procedure SaveToStream(S: TStream); + procedure LoadFromStream(S: TStream); + end; + + TExportList = class(TTypedList) + private + function GetRecord(I: Integer): TExportRec; + public + function Add: TExportRec; + procedure SaveToStream(S: TStream); + procedure LoadFromStream(S: TStream); + property Records[I: Integer]: TExportRec read GetRecord; default; + end; + + TStreamRec = class + public + UnitName: String; + Stream: TMemoryStream; + constructor Create; + destructor Destroy;override; + end; + + TStreamList = class(TTypedList) + private + function GetRecord(I: Integer): TStreamRec; + public + function IndexOf(const UnitName: String): Integer; + procedure AddFromStream(S: TStream; const FileName: String); + procedure AddFromFile(const FileName: String); + property Records[I: Integer]: TStreamRec read GetRecord; default; + end; + + TUpStringList = class(TStringList) + public + function IndexOf(const S: String): Integer; override; + end; + + TUndeclaredTypeRec = class + public + Id, ErrorIndex: Integer; + end; + + TUndeclaredTypeList = class(TStringList) + procedure Reset; + end; + + TUndeclaredIdentRec = class + public + Id: Integer; + ErrorIndex: Integer; + end; + + TUndeclaredIdentList = class(TStringList) + procedure Reset; + end; + + THashArray = class + private + function GetMaxId: Integer; + public + A: array[0..MaxHash] of TIntegerList; + constructor Create; + destructor Destroy; override; + procedure AddName(const S: String; Id: Integer); + procedure DeleteName(const S: String; Id: Integer); + procedure Clear; + function Clone: THashArray; + function GetList(const S: String): TIntegerList; + procedure SaveToStream(S: TWriter); + procedure LoadFromStream(S: TReader); + property MaxId: Integer read GetMaxId; + end; + + TFastStringList = class + private + L: TStringList; + X: THashArray; + public + constructor Create; + destructor Destroy; override; + procedure Clear; + function Add(const S: String): Integer; + function IndexOfEx(const S: String; Upcase: Boolean): Integer; + property StringList: TStringList read L; + end; + + TExternRecKind = (erNone, erLevel, erTypeId, + erOwnerId, erPatternId, + erAncestorId, erReadId, erWriteId, + ePropertyInBaseClassId, + erGUID); + + TExternRec = class + public + Id: Integer; + FullName: String; + RecKind: TExternRecKind; + procedure SaveToStream(S: TWriter); + procedure LoadFromStream(S: TReader); + end; + + TExternList = class(TTypedList) + private + function GetRecord(I: Integer): TExternRec; + public + function Add(Id: Integer; const FullName: String; + RecKind: TExternRecKind): TExternRec; + function Clone: TExternList; + procedure SaveToStream(S: TWriter); + procedure LoadFromStream(S: TReader); + property Records[I: Integer]: TExternRec read GetRecord; default; + end; + + TCheckProc = function (const TypeName: String; Data: Pointer; + errKind: TExternRecKind): Boolean; + + TSomeTypeRec = class + public + Name: String; + Id: Integer; + procedure SaveToStream(S: TWriter); + procedure LoadFromStream(S: TReader); + end; + + TSomeTypeList = class(TTypedList) + private + function GetRecord(I: Integer): TSomeTypeRec; + public + function Add(const Name: String; Id: Integer): TSomeTypeRec; + function Clone: TSomeTypeList; + function IndexOf(const Name: String): Integer; + procedure SaveToStream(S: TWriter); + procedure LoadFromStream(S: TReader); + property Records[I: Integer]: TSomeTypeRec read GetRecord; default; + end; + + TVarPathRec = class + public + Id: Integer; + VarCount: Int64; + end; + + TVarPath = class(TTypedList) + private + function GetItem(I: Integer): TVarPathRec; + public + function Add(Id: Integer; VarCount: Int64): TVarPathRec; + function IndexOf(VarCount: Int64): Integer; + function LastIndexOf(VarCount: Int64): Integer; + property Items[I: Integer]: TVarPathRec read GetItem; default; + end; + + TVarPathList = class(TTypedList) + private + function GetPath(I: Integer): TVarPath; + public + function AddPath: TVarPath; + procedure Add(Id: Integer; VarCount: Int64); + function GetLevel(VarCount: Int64): Integer; + property Pathes[I: Integer]: TVarPath read GetPath; default; + end; + + TGuidRec = class + public + GUID: TGUID; + Id: Integer; + Name: String; + GuidIndex: Integer; + procedure SaveToStream(S: TWriter); + procedure LoadFromStream(S: TReader); + end; + + TGuidList = class(TTypedList) + private + function GetRecord(I: Integer): TGuidRec; + public + function Add(const GUID: TGUID; Id: Integer; + const Name: String): TGuidRec; + function Clone: TGuidList; + function IndexOf(const GUID: TGUID): Integer; + function GetGuidByID(Id: Integer): TGUID; + function HasId(Id: Integer): Boolean; + procedure SaveToStream(S: TWriter); + procedure LoadFromStream(S: TReader); + property Records[I: Integer]: TGuidRec read GetRecord; default; + end; + + TStdTypeRec = class + public + Name: String; + TypeID: Integer; + Size: Integer; + NativeName: String; + end; + + TStdTypeList = class(TTypedList) + private + fPAX64: Boolean; + function GetRecord(I: Integer): TStdTypeRec; + public + constructor Create; + function Add(const TypeName: String; Size: Integer): Integer; + function IndexOf(const S: String): Integer; + function GetSize(TypeID: Integer): Integer; + property Records[I: Integer]: TStdTypeRec read GetRecord; default; + property PAX64: Boolean read fPAX64 write fPAX64; + end; + + TAssocStringInt = class + private + function GetCount: Integer; + public + Keys: TStringList; + Values: TIntegerList; + constructor Create; + destructor Destroy; override; + procedure Clear; + procedure Add(const Key: String); + procedure AddValue(const Key: String; Value: Integer); + procedure RemoveAt(I: Integer); + procedure Pack; + property Count: Integer read GetCount; + end; + + TMacroRec = class + public + S1, S2: String; + Params: TStringList; + constructor Create; + destructor Destroy; override; + end; + + TMacroList = class(TTypedList) + private + function GetRecord(I: Integer): TMacroRec; + public + function Add(const S1, S2: String; Params: TStrings): TMacroRec; + function IndexOf(const S1: String): Integer; + property Records[I: Integer]: TMacroRec read GetRecord; default; + end; + +implementation + +uses + PAXCOMP_SYS; + + // TAssocStringInt ------------------------------------------------------------- + +constructor TAssocStringInt.Create; +begin + inherited; + Keys := TStringList.Create; + Values := TIntegerList.Create; +end; + +destructor TAssocStringInt.Destroy; +begin + FreeAndNil(Keys); + FreeAndNil(Values); + inherited; +end; + +procedure TAssocStringInt.RemoveAt(I: Integer); +begin + Keys.Delete(I); + Values.RemoveAt(I); +end; + +procedure TAssocStringInt.Clear; +begin + Keys.Clear; + Values.Clear; +end; + +function TAssocStringInt.GetCount: Integer; +begin + result := Keys.Count; +end; + +procedure TAssocStringInt.Add(const Key: String); +begin + AddValue(Key, 0); +end; + +procedure TAssocStringInt.AddValue(const Key: String; Value: Integer); +begin + Keys.Add(Key); + Values.Add(Value); +end; + +procedure TAssocStringInt.Pack; +var + I: Integer; +begin + for I := 0 to Count - 1 do +{$IFDEF ARC} + begin + end; +{$ELSE} + Keys.Objects[I] := Pointer(Values[I]); +{$ENDIF} +end; + +// TTypedList ------------------------------------------------------------------ + +constructor TTypedList.Create; +begin + inherited; +{$IFDEF ARC} + L := TList.Create; +{$ELSE} + L := TList.Create; +{$ENDIF} +end; + +destructor TTypedList.Destroy; +begin + Clear; + L.Free; + inherited; +end; + +function TTypedList.GetCount: Integer; +begin + result := L.Count; +end; + +procedure TTypedList.Clear; +var + I: Integer; +begin + for I:=0 to L.Count - 1 do +{$IFDEF ARC} + L[I] := nil; +{$ELSE} + TObject(L[I]).Free; +{$ENDIF} + L.Clear; +end; + +function TTypedList.IndexOf(P: Pointer): Integer; +begin + result := L.IndexOf(P); +end; + +function TTypedList.GetLast: TObject; +begin + result := TObject(L[Count - 1]); +end; + +procedure TTypedList.RemoveAt(I: Integer); +begin +{$IFDEF ARC} + L[I] := nil; +{$ELSE} + TObject(L[I]).Free; +{$ENDIF} + L.Delete(I); +end; + +procedure TTypedList.InsertAt(I: Integer; X: TObject); +begin + L.Insert(I, X); +end; + +procedure TTypedList.Remove(X: TObject); +var + I: Integer; +begin + I := IndexOf(X); + if I >= 0 then + RemoveAt(I); +end; + +procedure TTypedList.RemoveTop; +begin +{$IFDEF ARC} + L[Count - 1] := nil; +{$ELSE} + TObject(L[Count - 1]).Free; +{$ENDIF} + L.Delete(Count - 1); +end; + +//-- TIntegerList -------------------------------------------------------------- + +constructor TIntegerList.Create(DupNo: Boolean = false); +begin + inherited Create; +{$IFDEF ARC} + fItems := TList.Create; +{$ELSE} + fItems := TList.Create; +{$ENDIF} + fDupNo := DupNo; +end; + +destructor TIntegerList.Destroy; +begin + fItems.Free; + inherited; +end; + +function TIntegerList.Clone: TIntegerList; +var + I: Integer; +begin + result := TIntegerList.Create; + for I:=0 to Count - 1 do + result.Add(Items[I]); +end; + +procedure TIntegerList.Clear; +begin + fItems.Clear; +end; + +function TIntegerList.GetCount: Integer; +begin + result := fItems.Count; +end; + +function TIntegerList.GetItem(I: Integer): Integer; +begin + result := Integer(fItems[I]); +end; + +procedure TIntegerList.SetItem(I: Integer; value: Integer); +begin + fItems[I] := Pointer(value); +end; + +function TIntegerList.Add(value: Integer): Integer; +begin + if fDupNo then + begin + result := IndexOf(value); + if result >= 0 then + Exit; + end; + result := fItems.Add(Pointer(value)); +end; + +procedure TIntegerList.Insert(I: Integer; value: Integer); +begin + if fDupNo then + if IndexOf(value) >= 0 then + Exit; + fItems.Insert(I, Pointer(value)); +end; + +procedure TIntegerList.RemoveAt(I: Integer); +begin + fItems.Delete(I); +end; + +procedure TIntegerList.DeleteValue(value: Integer); +var + I: Integer; +begin + I := IndexOf(value); + if I >= 0 then + fItems.Delete(I); +end; + +function TIntegerList.IndexOf(value: Integer): Integer; +begin + result := fItems.IndexOf(Pointer(value)); +end; + +function TIntegerList.LastIndexOf(value: Integer): Integer; +var + I: Integer; +begin + result := -1; + for I := Count - 1 downto 0 do + if fItems[I] = Pointer(value) then + begin + result := I; + Exit; + end; +end; + +function TIntegerList.Top: Integer; +begin + if Count = 0 then + RIE; + result := Items[Count - 1]; +end; + +function TIntegerList.BinSearch(const Key: Integer): Integer; +var + First: Integer; + Last: Integer; + Pivot: Integer; + Found: Boolean; +begin + First := 0; + Last := Count - 1; + Found := False; + Result := -1; + + while (First <= Last) and (not Found) do + begin + Pivot := (First + Last) div 2; + if Integer(fItems[Pivot]) = Key then + begin + Found := True; + Result := Pivot; + end + else if Integer(fItems[Pivot]) > Key then + Last := Pivot - 1 + else + First := Pivot + 1; + end; +end; + +procedure TIntegerList.QuickSort; +begin + QuickSort(0, Count - 1); +end; + +procedure TIntegerList.QuickSort(Start, Stop: Integer); +var + Left: Integer; + Right: Integer; + Mid: Integer; + Pivot: Integer; + Temp: Pointer; +begin + Left := Start; + Right := Stop; + Mid := (Start + Stop) div 2; + + Pivot := Integer(fItems[mid]); + repeat + while Integer(fItems[Left]) < Pivot do Inc(Left); + while Pivot < Integer(fItems[Right]) do Dec(Right); + if Left <= Right then + begin + Temp := fItems[Left]; + fItems[Left] := fItems[Right]; // Swops the two Strings + fItems[Right] := Temp; + Inc(Left); + Dec(Right); + end; + until Left > Right; + + if Start < Right then QuickSort(Start, Right); // Uses + if Left < Stop then QuickSort(Left, Stop); // Recursion +end; + +procedure TIntegerList.SaveToStream(S: TStream); +var + I, K: Integer; + A: array of Integer; + P: Pointer; +begin + K := Count; + SaveIntegerToStream(K, S); + if K = 0 then + Exit; + SetLength(A, K); + for I:=0 to K - 1 do + A[I] := Integer(fItems[I]); + P := @A[0]; + S.Write(P^, K * SizeOf(Integer)); +end; + +procedure TIntegerList.LoadFromStream(S: TStream); +var + I, K: Integer; + A: array of Integer; + P: Pointer; +begin + Clear; + K := LoadIntegerFromStream(S); + if K = 0 then + Exit; + SetLength(A, K); + P := @A[0]; + S.Read(P^, K * SizeOf(Integer)); + for I:=0 to K - 1 do + Add(A[I]); +end; + +function TIntegerList.SaveToPtr(P: Pointer): Integer; +var + I, K: Integer; +begin + K := Count; + Move(K, P^, 4); + P := ShiftPointer(P, 4); + for I:=0 to Count - 1 do + begin + K := Integer(fItems[I]); + Move(K, P^, 4); + P := ShiftPointer(P, 4); + end; + + result := (Count * 4) + 4; +end; + +function TIntegerList.LoadFromPtr(P: Pointer): Integer; +var + I, K, Z: Integer; +begin + Move(P^, K, 4); + P := ShiftPointer(P, 4); + for I:=0 to K - 1 do + begin + Move(P^, Z, 4); + P := ShiftPointer(P, 4); + Add(Z); + end; + + result := (Count * 4) + 4; +end; + +procedure TIntegerList.SaveToWriter(S: TWriter); +var + I: Integer; +begin + S.WriteInteger(Count); + for I:=0 to Count - 1 do + S.WriteInteger(Integer(fItems[I])); +end; + +procedure TIntegerList.LoadFromReader(S: TReader); +var + I, K: Integer; +begin + Clear; + K := S.ReadInteger(); + for I:=0 to K - 1 do + Add(S.ReadInteger()); +end; + +//-- TIntegerStack ------------------------------------------------------------- + +procedure TIntegerStack.Push(value: Integer); +begin + Add(value); +end; + +function TIntegerStack.Pop: Integer; +begin + result := Items[Count - 1]; + fItems.Delete(Count - 1); +end; + +function TIntegerStack.Depth(value: Integer): Integer; +var + I: Integer; +begin + result := -1; + for I:=Count - 1 downto 0 do + begin + Inc(result); + if Items[I] = value then + Exit; + end; + raise Exception.Create(errInternalError); +end; + +// TAssocIntegers -------------------------------------------------------------- + +constructor TAssocIntegers.Create; +begin + inherited; + Keys := TIntegerList.Create; + Values := TIntegerList.Create; +end; + +destructor TAssocIntegers.Destroy; +begin + Keys.Free; + Values.Free; + inherited; +end; + +function TAssocIntegers.Inside(c: Integer): Boolean; +var + I: Integer; +begin + result := false; + for I := 0 to Count - 1 do + if (c >= Keys[I]) and (c <= Values[I]) then + begin + result := true; + Exit; + end; +end; + +function TAssocIntegers.IndexOf(K, V: Integer): Integer; +var + I: Integer; +begin + result := -1; + for I := 0 to Count - 1 do + if (Keys[I] = K) and (Values[I] = V) then + begin + result := I; + Exit; + end; +end; + +procedure TAssocIntegers.RemoveAt(I: Integer); +begin + Keys.RemoveAt(I); + Values.RemoveAt(I); +end; + +procedure TAssocIntegers.Clear; +begin + Keys.Clear; + Values.Clear; +end; + +function TAssocIntegers.Clone: TAssocIntegers; +begin + result := TAssocIntegers.Create; + + result.Keys.Free; + result.Keys := Keys.Clone; + + result.Values.Free; + result.Values := Values.Clone; +end; + +procedure TAssocIntegers.SaveToStream(S: TStream); +begin + Keys.SaveToStream(S); + Values.SaveToStream(S); +end; + +procedure TAssocIntegers.LoadFromStream(S: TStream); +begin + Keys.LoadFromStream(S); + Values.LoadFromStream(S); +end; + +function TAssocIntegers.SaveToPtr(P: Pointer): Integer; +begin + result := Keys.SaveToPtr(P); + P := ShiftPointer(P, result); + Inc(result, Values.SaveToPtr(P)); +end; + +function TAssocIntegers.LoadFromPtr(P: Pointer): Integer; +begin + result := Keys.LoadFromPtr(P); + P := ShiftPointer(P, result); + Inc(result, Values.LoadFromPtr(P)); +end; + +function TAssocIntegers.GetCount: Integer; +begin + result := Keys.Count; +end; + +procedure TAssocIntegers.Add(Key, Value: Integer); +begin + Keys.Add(Key); + Values.Add(Value); +end; + +// TAssocStrings --------------------------------------------------------------- + +constructor TAssocStrings.Create; +begin + inherited; + Keys := TStringList.Create; + Values := TStringList.Create; +end; + +destructor TAssocStrings.Destroy; +begin + Keys.Free; + Values.Free; + inherited; +end; + +function TAssocStrings.GetValue(const Key: String): String; +var + I: Integer; +begin + I := Keys.IndexOf(Key); + if I >= 0 then + result := Values[I] + else + result := ''; +end; + +procedure TAssocStrings.SetValue(const Key, Value: String); +var + I: Integer; +begin + I := Keys.IndexOf(Key); + if I >= 0 then + Values[I] := Value + else + Add(Key, Value); +end; + +procedure TAssocStrings.RemoveAt(I: Integer); +begin + Keys.Delete(I); + Values.Delete(I); +end; + +procedure TAssocStrings.Clear; +begin + Keys.Clear; + Values.Clear; +end; + +function TAssocStrings.GetCount: Integer; +begin + result := Keys.Count; +end; + +procedure TAssocStrings.Add(const Key, Value: String); +begin + Keys.Add(Key); + Values.Add(Value); +end; + +//-- TPauseException ----------------------------------------------------------- + +constructor TPauseException.Create; +begin + inherited Create(''); +end; + +//-- THaltException ------------------------------------------------------------ + +constructor THaltException.Create(i_ExitCode: Integer); +begin + inherited Create(''); + ExitCode := i_ExitCode; +end; + +procedure TStringObjectList.ClearObjects; +var + I: Integer; +begin + for I := 0 to Count - 1 do + if Objects[I] <> nil then + begin +{$IFDEF ARC} + Objects[I] := nil; +{$ELSE} + Objects[I].Free; +{$ENDIF} + Objects[I] := nil; + end; +end; + +procedure TStringObjectList.Clear; +begin + ClearObjects; + inherited; +end; + +destructor TStringObjectList.Destroy; +begin + ClearObjects; + inherited; +end; + +constructor TAnonymContextRec.Create; +begin + inherited; + BindList := TIntegerList.Create; +end; + +destructor TAnonymContextRec.Destroy; +begin + BindList.Free; + inherited; +end; + +function TAnonymContextStack.GetRecord(I: Integer): TAnonymContextRec; +begin + result := TAnonymContextRec(L[I]); +end; + +function TAnonymContextStack.GetTop: TAnonymContextRec; +begin + result := Records[Count - 1]; +end; + +function TAnonymContextStack.Push(SubId: Integer): TAnonymContextRec; +begin + result := TAnonymContextRec.Create; + result.SubId := SubId; + L.Add(result); +end; + +procedure TAnonymContextStack.Pop; +begin + RemoveAt(Count - 1); +end; + +procedure TMessageRec.SaveToStream(S: TStream); +begin + S.Write(msg_id, SizeOf(msg_id)); + SaveStringToStream(FullName, S); +end; + +procedure TMessageRec.LoadFromStream(S: TStream); +begin + S.Read(msg_id, SizeOf(msg_id)); + FullName := LoadStringFromStream(S); +end; + +function TMessageList.IndexOf(const FullName: String): Integer; +var + I: Integer; +begin + result := -1; + for I := 0 to Count - 1 do + if Records[I].FullName = FullName then + begin + result := I; + Exit; + end; +end; + +function TMessageList.AddRecord: TMessageRec; +begin + result := TMessageRec.Create; + L.Add(result); +end; + +function TMessageList.GetRecord(I: Integer): TMessageRec; +begin + result := TMessageRec(L[I]); +end; + +procedure TMessageList.SaveToStream(S: TStream); +var + I, K: Integer; +begin + K := Count; + S.Write(K, SizeOf(K)); + for I := 0 to K - 1 do + Records[I].SaveToStream(S); +end; + +procedure TMessageList.LoadFromStream(S: TStream); +var + I, K: Integer; +begin + S.Read(K, SizeOf(K)); + for I := 0 to K - 1 do + AddRecord.LoadFromStream(S); +end; + +function TMessageList.CreateDmtTable(const AClassName: String; var Size: Integer): Pointer; +var + I, K: Integer; + DmtMethodList: PDmtMethodList; +begin + K := 0; + for I := 0 to Count - 1 do + if StrEql(Records[I].Class_Name, AClassName) then + begin + Inc(K); + end; + if K = 0 then + result := nil + else + begin + Size := SizeOf(Word) + + K * SizeOf(SmallInt) + + K * SizeOf(Pointer); + result := AllocMem(Size); + PDmtTable(result)^.Count := K; + DmtMethodList := @PDmtTable(result)^.IndexList[K]; + K := 0; + for I := 0 to Count - 1 do + if StrEql(Records[I].Class_Name, AClassName) then + begin + PDmtTable(result)^.IndexList[K] := Records[I].msg_id; + DmtMethodList[K] := Records[I].Address; + Inc(K); + end; + end; +end; + +constructor TActualParamRec.Create; +begin + inherited; + Params := TPtrList.Create; +end; + +destructor TActualParamRec.Destroy; +begin + Params.Free; + inherited; +end; + +function TActualParamList.GetRecord(I: Integer): TActualParamRec; +begin + result := TActualParamRec(L[I]); +end; + +function TActualParamList.Add(SubId: Integer; Param: Pointer): TActualParamRec; +begin + result := Find(SubId); + if result = nil then + begin + result := TActualParamRec.Create; + result.SubId := SubId; + L.Add(result); + end; + result.Params.Add(Param); +end; + +function TActualParamList.Find(SubId: Integer): TActualParamRec; +var + I: Integer; +begin + result := nil; + for I := Count - 1 downto 0 do + if Records[I].SubId = SubId then + begin + result := Records[I]; + Exit; + end; +end; + +procedure TActualParamList.Remove(SubId: Integer); +var + I: Integer; +begin + for I := Count - 1 downto 0 do + if Records[I].SubId = SubId then + begin + RemoveAt(I); + Exit; + end; +end; + +procedure TExportRec.SaveToStream(S: TStream); +begin + SaveStringToStream(Name, S); + S.Write(Offset, SizeOf(Offset)); +end; + +procedure TExportRec.LoadFromStream(S: TStream); +begin + Name := LoadStringFromStream(S); + S.Read(Offset, SizeOf(Offset)); +end; + +function TExportList.GetRecord(I: Integer): TExportRec; +begin + result := TExportRec(L[I]); +end; + +function TExportList.Add: TExportRec; +begin + result := TExportRec.Create; + L.Add(result); + result.Ordinal := Count; +end; + +procedure TExportList.SaveToStream(S: TStream); +var + I, K: Integer; +begin + K := Count; + S.Write(K, SizeOf(K)); + for I := 0 to K - 1 do + Records[I].SaveToStream(S); +end; + +procedure TExportList.LoadFromStream(S: TStream); +var + I, K: Integer; +begin + S.Read(K, SizeOf(K)); + for I := 0 to K - 1 do + Add.LoadFromStream(S); +end; + +constructor TStreamRec.Create; +begin + inherited; + Stream := TMemoryStream.Create; +end; + +destructor TStreamRec.Destroy; +begin + inherited; + Stream.Free; +end; + +function TStreamList.GetRecord(I: Integer): TStreamRec; +begin + result := TStreamRec(L[I]); +end; + +function TStreamList.IndexOf(const UnitName: String): Integer; +var + I: Integer; +begin + result := -1; + for I := 0 to Count - 1 do + if StrEql(UnitName, Records[I].UnitName) then + begin + result := I; + Exit; + end; +end; + +procedure TStreamList.AddFromStream(S: TStream; const FileName: String); +var + UnitName: String; + R: TStreamRec; +begin + UnitName := ExtractFullOwner(FileName); + if IndexOf(UnitName) <> -1 then + Exit; + R := TStreamRec.Create; + R.UnitName := UnitName; + R.Stream.LoadFromStream(S); + L.Add(R); +end; + +procedure TStreamList.AddFromFile(const FileName: String); +var + UnitName: String; + R: TStreamRec; +begin + UnitName := ExtractFullOwner(FileName); + if IndexOf(UnitName) <> -1 then + Exit; + R := TStreamRec.Create; + R.UnitName := UnitName; + R.Stream.LoadFromFile(FileName); + L.Add(R); +end; + +// TUpStringList --------------------------------------------------------------- + +function TUpStringList.IndexOf(const S: String): Integer; +var + I: Integer; +begin + result := -1; + for I := 0 to Count - 1 do + if StrEql(Strings[I], S) then + begin + result := I; + Exit; + end; +end; + +// TUndeclaredTypeList --------------------------------------------------------- + +procedure TUndeclaredTypeList.Reset; +var + I: Integer; +begin + for I:= 0 to Count - 1 do +{$IFDEF ARC} + Objects[I] := nil; +{$ELSE} + Objects[I].Free; +{$ENDIF} + Clear; +end; + +// TUndeclaredIdentList -------------------------------------------------------- + +procedure TUndeclaredIdentList.Reset; +var + I: Integer; +begin + for I:= 0 to Count - 1 do +{$IFDEF ARC} + Objects[I] := nil; +{$ELSE} + Objects[I].Free; +{$ENDIF} + Clear; +end; + +constructor THashArray.Create; +var + I: Integer; +begin + for I:=0 to MaxHash do + A[I] := TIntegerList.Create; +end; + +procedure THashArray.SaveToStream(S: TWriter); +var + I: Integer; +begin + for I:=0 to MaxHash do + A[I].SaveToWriter(S); +end; + +procedure THashArray.LoadFromStream(S: TReader); +var + I: Integer; +begin + for I:=0 to MaxHash do + A[I].LoadFromReader(S); +end; + +procedure THashArray.Clear; +var + I: Integer; +begin + for I:=0 to MaxHash do + A[I].Clear; +end; + +destructor THashArray.Destroy; +var + I: Integer; +begin + for I:=0 to MaxHash do + A[I].Free; +end; + +function THashArray.GetList(const S: String): TIntegerList; +var + H: Integer; +begin + H := HashNumber(S); + result := A[H]; +end; + +function THashArray.GetMaxId: Integer; +var + I, J: Integer; +begin + result := 0; + for I:=0 to MaxHash do + for J := 0 to A[I].Count - 1 do + if A[I][J] > result then + result := A[I][J]; +end; + +procedure THashArray.AddName(const S: String; Id: Integer); +var + H: Integer; +begin + if S = '' then + Exit; + H := HashNumber(S); + with A[H] do + Add(Id); +end; + +procedure THashArray.DeleteName(const S: String; Id: Integer); +var + H: Integer; +begin + if S = '' then + Exit; + H := HashNumber(S); + with A[H] do + DeleteValue(Id); +end; + +function THashArray.Clone: THashArray; +var + I, J: Integer; +begin + result := THashArray.Create; + for I:=0 to MaxHash do + begin + for J:=0 to A[I].Count - 1 do + result.A[I].Add(A[I][J]); + end; +end; + +// TFastStringList ------------------------------------------------------------- + +constructor TFastStringList.Create; +begin + inherited; + L := TStringList.Create; + X := THashArray.Create; +end; + +destructor TFastStringList.Destroy; +begin + L.Free; + X.Free; + inherited; +end; + +procedure TFastStringList.Clear; +begin + L.Clear; + X.Clear; +end; + +function TFastStringList.Add(const S: String): Integer; +var + H: Integer; +begin + H := HashNumber(S); + result := L.Add(S); + X.A[H].Add(result); +end; + +function TFastStringList.IndexOfEx(const S: String; Upcase: Boolean): Integer; +var + I, J: Integer; + List: TIntegerList; +begin + result := -1; + + List := X.GetList(S); + + for I := 0 to List.Count - 1 do + begin + J := List[I]; + if Upcase then + begin + if StrEql(L[J], S) then + begin + result := J; + Exit; + end; + end + else + begin + if L[J] = S then + begin + result := J; + Exit; + end; + end; + end; +end; + +// TExternRec ------------------------------------------------------------------ + +procedure TExternRec.SaveToStream(S: TWriter); +begin + S.WriteInteger(id); + S.WriteString(FullName); + S.Write(RecKind, SizeOf(RecKind)); +end; + +procedure TExternRec.LoadFromStream(S: TReader); +begin + Id := S.ReadInteger; + FullName := S.ReadString; + S.Read(RecKind, SizeOf(RecKind)); +end; + +// TExternList ----------------------------------------------------------------- + +function TExternList.Clone: TExternList; +var + I: Integer; +begin + result := TExternList.Create; + for I:=0 to Count - 1 do + with Records[I] do + begin + result.Add(Id, FullName, RecKind); + end; +end; + +function TExternList.GetRecord(I: Integer): TExternRec; +begin + result := TExternRec(L[I]); +end; + +function TExternList.Add(Id: Integer; const FullName: String; + RecKind: TExternRecKind): TExternRec; +begin + result := TExternRec.Create; + result.Id := Id; + result.FullName := FullName; + result.RecKind := RecKind; + L.Add(result); +end; + +procedure TExternList.SaveToStream(S: TWriter); +var + I: Integer; +begin + S.WriteInteger(Count); + for I := 0 to Count - 1 do + Records[I].SaveToStream(S); +end; + +procedure TExternList.LoadFromStream(S: TReader); +var + I, K: Integer; + R: TExternRec; +begin + K := S.ReadInteger; + for I := 0 to K - 1 do + begin + R := TExternRec.Create; + R.LoadFromStream(S); + L.Add(R); + end; +end; + +// TSomeTypeRec ---------------------------------------------------------------- + +procedure TSomeTypeRec.SaveToStream(S: TWriter); +begin + S.WriteString(Name); + S.WriteInteger(Id); +end; + +procedure TSomeTypeRec.LoadFromStream(S: TReader); +begin + Name := S.ReadString(); + Id := S.ReadInteger(); +end; + +// TSomeTypeList --------------------------------------------------------------- + +function TSomeTypeList.GetRecord(I: Integer): TSomeTypeRec; +begin + result := TSomeTypeRec(L[I]); +end; + +function TSomeTypeList.Add(const Name: String; Id: Integer): TSomeTypeRec; +begin + result := TSomeTypeRec.Create; + result.Name := Name; + result.Id := Id; + L.Add(result); +end; + +function TSomeTypeList.Clone: TSomeTypeList; +var + I: Integer; +begin + result := TSomeTypeList.Create; + for I := 0 to Count - 1 do + result.Add(Records[I].Name, Records[I].Id); +end; + +function TSomeTypeList.IndexOf(const Name: String): Integer; +var + I: Integer; +begin + result := -1; + for I := 0 to Count - 1 do + if StrEql(Records[I].Name, Name) then + begin + result := I; + Exit; + end; +end; + +procedure TSomeTypeList.SaveToStream(S: TWriter); +var + I, K: Integer; +begin + K := Count; + S.WriteInteger(K); + for I := 0 to K - 1 do + Records[I].SaveToStream(S); +end; + +procedure TSomeTypeList.LoadFromStream(S: TReader); +var + I, K: Integer; + R: TSomeTypeRec; +begin + K := S.ReadInteger(); + for I := 0 to K - 1 do + begin + R := TSomeTypeRec.Create; + R.LoadFromStream(S); + L.Add(R); + end; +end; + +// TVarPath -------------------------------------------------------------------- + +function TVarPath.GetItem(I: Integer): TVarPathRec; +begin + result := TVarPathRec(L[I]); +end; + +function TVarPath.Add(Id: Integer; VarCount: Int64): TVarPathRec; +begin + result := TVarPathRec.Create; + result.Id := Id; + result.VarCount := VarCount; + L.Add(result); +end; + +function TVarPath.IndexOf(VarCount: Int64): Integer; +var + I: Integer; +begin + result := -1; + for I := 0 to Count - 1 do + if Items[I].VarCount = VarCount then + begin + result := I; + Exit; + end; +end; + +function TVarPath.LastIndexOf(VarCount: Int64): Integer; +var + I: Integer; +begin + result := -1; + for I := Count - 1 downto 0 do + if Items[I].VarCount = VarCount then + begin + result := I; + Exit; + end; +end; + +// TVarPathList ---------------------------------------------------------------- + +function TVarPathList.GetPath(I: Integer): TVarPath; +begin + result := TVarPath(L[I]); +end; + +function TVarPathList.AddPath: TVarPath; +begin + result := TVarPath.Create; + L.Add(result); +end; + +function TVarPathList.GetLevel(VarCount: Int64): Integer; +begin + if VarCount < 100 then + result := 1 + else if VarCount < 10000 then + result := 2 + else if VarCount < 1000000 then + result := 3 + else if VarCount < 100000000 then + result := 4 + else if VarCount < 10000000000 then + result := 5 + else if VarCount < 1000000000000 then + result := 6 + else if VarCount < 100000000000000 then + result := 7 + else + raise PaxCompilerException.Create(errTooManyNestedCaseBlocks); +end; + +procedure TVarPathList.Add(Id: Integer; VarCount: Int64); +var + I, J, Idx: Integer; + Path: TVarPath; + Level: Integer; + ParentVarCount: Integer; + R: TVarPathRec; + new_path: Boolean; +begin + if Count = 0 then + begin + Path := AddPath; + Path.Add(Id, VarCount); + Exit; + end; + + for I := 0 to Count - 1 do + begin + Path := Pathes[I]; + Idx := Path.IndexOf(VarCount); + if Idx >= 0 then + begin + Path.Add(Id, VarCount); + Exit; + end; + end; + + Level := GetLevel(VarCount); + + if Level = 1 then + begin + Path := AddPath; + Path.Add(Id, VarCount); + Exit; + end; + + case Level of + 2: + begin + ParentVarCount := VarCount mod 100; + new_path := VarCount div 100 > 1; + end; + 3: + begin + ParentVarCount := VarCount mod 10000; + new_path := VarCount div 10000 > 1; + end; + 4: + begin + ParentVarCount := VarCount mod 1000000; + new_path := VarCount div 1000000 > 1; + end; + 5: + begin + ParentVarCount := VarCount mod 100000000; + new_path := VarCount div 100000000 > 1; + end; + 6: + begin + ParentVarCount := VarCount mod 10000000000; + new_path := VarCount div 10000000000 > 1; + end; + 7: + begin + ParentVarCount := VarCount mod 1000000000000; + new_path := VarCount div 1000000000000 > 1; + end + else + raise PaxCompilerException.Create(errTooManyNestedCaseBlocks); + end; + + for I := Count - 1 downto 0 do + begin + Idx := Pathes[I].LastIndexOf(ParentVarCount); + if Idx >= 0 then + begin + if new_path then + begin + Path := AddPath; + for J := 0 to Idx do + begin + R := Pathes[I][J]; + Path.Add(R.Id, R.VarCount); + end; + Path.Add(Id, VarCount); + end + else + begin + Path := Pathes[I]; + Path.Add(Id, VarCount); + end; + + Exit; + end; + end; + + Path := AddPath; + Path.Add(Id, VarCount); +end; + +procedure TGuidRec.SaveToStream(S: TWriter); +begin + S.Write(Id, SizeOf(Id)); + S.Write(Guid, SizeOf(Guid)); + S.WriteString(Name); +end; + +procedure TGuidRec.LoadFromStream(S: TReader); +begin + S.Read(Id, SizeOf(Id)); + S.Read(Guid, SizeOf(Guid)); + Name := S.ReadString; +end; + +function TGuidList.Add(const GUID: TGUID; Id: Integer; + const Name: String): TGuidRec; +var + I: Integer; +begin + I := IndexOf(GUID); + if I >= 0 then + begin + result := Records[I]; + Exit; + end; + + result := TGuidRec.Create; + L.Add(result); + result.GUID := GUID; + result.Name := Name; + result.GuidIndex := L.Count - 1; + result.Id := Id; +end; + +function TGuidList.Clone: TGuidList; +var + I: Integer; +begin + result := TGuidList.Create; + for I := 0 to Count - 1 do + result.Add(Records[I].GUID, Records[I].Id, Records[I].Name); +end; + +function TGuidList.IndexOf(const GUID: TGUID): Integer; +var + I: Integer; +begin + result := -1; + for I := 0 to Count - 1 do + if GuidsAreEqual(Records[I].GUID, GUID) then + begin + result := I; + Exit; + end; +end; + +function TGuidList.GetGuidByID(Id: Integer): TGUID; +var + I: Integer; +begin + for I := 0 to Count - 1 do + if Records[I].Id = Id then + begin + result := Records[I].GUID; + Exit; + end; + result := IUnknown; +end; + +function TGuidList.HasId(Id: Integer): Boolean; +var + I: Integer; +begin + for I := 0 to Count - 1 do + if Records[I].Id = Id then + begin + result := true; + Exit; + end; + result := false; +end; + +procedure TGuidList.SaveToStream(S: TWriter); +var + I, K: Integer; +begin + K := Count; + S.Write(K, SizeOf(K)); + for I := 0 to K - 1 do + Records[I].SaveToStream(S); +end; + +procedure TGuidList.LoadFromStream(S: TReader); +var + I, K: Integer; + R: TGuidRec; +begin + Clear; + S.Read(K, SizeOf(K)); + for I := 0 to K - 1 do + begin + R := TGuidRec.Create; + R.LoadFromStream(S); + Add(R.GUID, R.Id, R.Name); + R.Free; + end; +end; + +function TGuidList.GetRecord(I: Integer): TGuidRec; +begin + result := TGuidRec(L[I]); +end; + +constructor TStdTypeList.Create; +begin + inherited; +{$IFDEF PAX64} + fPAX64 := true; + H_ExceptionPtr := H_ExceptionPtr_64; + H_ByteCodePtr := H_ByteCodePtr_64; + H_Flag := H_Flag_64; + H_SkipPop := H_SkipPop_64; + FirstShiftValue := FirstShiftValue_64; +{$ENDIF} +end; + +function TStdTypeList.IndexOf(const S: String): Integer; +var + I: Integer; + Q: String; +begin + Q := UpperCase(S); + for I:=0 to Count - 1 do + if Records[I].Name = Q then + begin + result := I; + Exit; + end; + result := -1; +end; + +function TStdTypeList.GetRecord(I: Integer): TStdTypeRec; +begin +{$IFNDEF PAXARM} + if I = typePANSICHAR then + I := typePOINTER + else +{$ENDIF} + if I = typePWIDECHAR then + I := typePOINTER + else if I = typePVOID then + I := typePOINTER; + result := TStdTypeRec(L[I]); +end; + +function TStdTypeList.Add(const TypeName: String; Size: Integer): Integer; +var + R: TStdTypeRec; +begin + R := TStdTypeRec.Create; + R.TypeID := L.Count; + R.Size := Size; + R.Name := UpperCase(TypeName); + R.NativeName := TypeName; + result := R.TypeID; + L.Add(R); +end; + +function TStdTypeList.GetSize(TypeID: Integer): Integer; +begin + result := Records[TypeID].Size; + if PAX64 then + begin + if TypeID in [ +{$IFNDEF PAXARM} + typeANSISTRING, + typeWIDESTRING, + typeUNICSTRING, + typePANSICHAR, +{$ENDIF} + typePOINTER, + typeCLASS, + typeCLASSREF, + typePROC, + typeDYNARRAY, + typeOPENARRAY, + typePWIDECHAR, + typePVOID, + typeINTERFACE] then + result := 8 + else if typeID = typeEVENT then + result := 16 + else if typeID in [typeVARIANT, typeOLEVARIANT] then + result := 24; + end; +end; + +constructor TMacroRec.Create; +begin + inherited; + Params := TStringList.Create; +end; + +destructor TMacroRec.Destroy; +begin + FreeAndNil(Params); + inherited; +end; + +function TMacroList.GetRecord(I: Integer): TMacroRec; +begin + result := TMacroRec(L[I]); +end; + +function TMacroList.Add(const S1, S2: String; Params: TStrings): TMacroRec; +var + I: Integer; +begin + result := TMacroRec.Create; + result.S1 := S1; + result.S2 := S2; + for I := 0 to Params.Count - 1 do + result.Params.Add(Params[I]); + L.Add(result); +end; + +function TMacroList.IndexOf(const S1: String): Integer; +var + I: Integer; +begin + result := -1; + for I := 0 to Count - 1 do + if Records[I].S1 = S1 then + begin + result := I; + Exit; + end; +end; + +end. diff --git a/Sources/PAXCOMP_VAROBJECT.pas b/Sources/PAXCOMP_VAROBJECT.pas new file mode 100644 index 0000000..c6ecdbd --- /dev/null +++ b/Sources/PAXCOMP_VAROBJECT.pas @@ -0,0 +1,519 @@ +//////////////////////////////////////////////////////////////////////////// +// PaxCompiler +// Site: http://www.paxcompiler.com +// Author: Alexander Baranovsky (paxscript@gmail.com) +// ======================================================================== +// Copyright (c) Alexander Baranovsky, 2006-2014. All rights reserved. +// Code Version: 4.2 +// ======================================================================== +// Unit: PAXCOMP_VAROBJECT.pas +// ======================================================================== +//////////////////////////////////////////////////////////////////////////// + +{$I PaxCompiler.def} +unit PAXCOMP_VAROBJECT; +interface +uses {$I uses.def} + SysUtils, + Classes, + PAXCOMP_CONSTANTS, + PAXCOMP_TYPES, + PAXCOMP_SYS; +const +// varObject = varAny; +{$IFDEF MACOS} + varObject = $15; +{$ELSE} + varObject = $000E; +{$ENDIF} +type + TVarObjectKind = (voNone, voSet, voSimple, voArray); + + TVarObject = class + private + stable: Pointer; + voKind: TVarObjectKind; + public + constructor Create(i_stable: Pointer); + function ToStr: String; virtual; abstract; + procedure SaveToStream(S: TWriter); virtual; abstract; + procedure LoadFromStream(S: TReader); virtual; abstract; + end; + + TSetObject = class(TVarObject) + private + fValue: TByteSet; + TypeId: Integer; + TypeBaseId: Integer; + public + constructor Create(i_stable: Pointer; + const Value: TByteSet; + i_TypeId: Integer; + i_TypeBaseId: Integer); + constructor CreateSimple(i_stable: Pointer); + function ToStr: String; override; + function Clone: TVarObject; + procedure SaveToStream(S: TWriter); override; + procedure LoadFromStream(S: TReader); override; + property Value: TByteSet read fValue write fValue; + end; + + TSimpleObject = class(TVarObject) + private + fValue: Variant; + fName: String; + public + constructor Create(i_stable: Pointer; + const Value: Variant; const i_Name: String); + constructor CreateSimple(i_stable: Pointer); + function ToStr: String; override; + procedure SaveToStream(S: TWriter); override; + procedure LoadFromStream(S: TReader); override; + property Value: Variant read fValue write fValue; + property Name: String read fName; + end; + + TArrObject = class(TVarObject) + private +{$IFDEF ARC} + L: TList; +{$ELSE} + L: TList; +{$ENDIF} + function GetItem(I: Integer): TVarObject; + public + constructor Create(i_stable: Pointer); + destructor Destroy; override; + function ToStr: String; override; + procedure Clear; + function Count: Integer; + procedure AddVarObject(X: TVarObject); + procedure SaveToStream(S: TWriter); override; + procedure LoadFromStream(S: TReader); override; + property Items[I: Integer]: TVarObject read GetItem; default; + end; + + TVarObjectList = class(TTypedList) + private + stable: Pointer; + function GetItem(I: Integer): TVarObject; + procedure AddVarObject(X: TVarObject); + public + constructor Create(i_stable: Pointer); + property Items[I: Integer]: TVarObject read GetItem; + end; + +function VariantToSetObject(const Value: Variant): TSetObject; +function IsVarObject(const V: Variant): boolean; +function VarObjectToVariant(const Value: TVarObject): Variant; +function VariantToVarObject(const Value: Variant): TVarObject; + +procedure SaveVariantToStream(const Value: Variant; S: TWriter); +function LoadVariantFromStream(S: TReader; stable: Pointer): Variant; +function VariantToString(FinTypeId: Integer; const V: Variant): String; + +implementation + +uses + PAXCOMP_BASESYMBOL_TABLE; + +procedure SaveVariantToStream(const Value: Variant; S: TWriter); +var + VType: Word; + VObject: TVarObject; +begin + VType := VarType(Value); + S.Write(VType, SizeOf(VType)); + case VType of + varString: S.WriteString(Value); +{$IFDEF PAXARM} + varOleStr: S.WriteString(Value); +{$ELSE} + varOleStr: S.WriteString(Value); +{$ENDIF} +{$IFDEF UNIC} + varUString: S.WriteString(Value); +{$ENDIF} + varObject: + begin + VObject := VariantToVarObject(Value); + S.Write(VObject.voKind, SizeOf(VObject.voKind)); + VObject.SaveToStream(S); + end; + else + S.Write(Value, SizeOf(Variant)); + end; +end; + +function LoadVariantFromStream(S: TReader; stable: Pointer): Variant; +var + VType: Word; + VObject: TVarObject; + voKind: TVarObjectKind; +begin + S.Read(VType, SizeOf(VType)); + case VType of + varString: result := S.ReadString; +{$IFDEF PAXARM} + varOleStr: result := S.ReadString; +{$ELSE} + varOleStr: result := S.ReadString; +{$ENDIF} +{$IFDEF UNIC} + varUString: result := S.ReadString; +{$ENDIF} + varObject: + begin + S.Read(voKind, SizeOf(voKind)); + case voKind of + voSet: VObject := TSetObject.CreateSimple(stable); + voSimple: VObject := TSimpleObject.CreateSimple(stable); + voArray: VObject := TArrObject.Create(stable); + else + raise Exception.Create(errInternalError); + end; + VObject.LoadFromStream(S); + result := VarObjectToVariant(VObject); + end + else + S.Read(result, SizeOf(Variant)); + end; +end; + +function IsVarObject(const V: Variant): boolean; +begin + result := VarType(V) = varObject; +end; + +function VarObjectToVariant(const Value: TVarObject): Variant; +begin + result := Integer(Value); + TVarData(result).VType := varObject; +end; + +function VariantToVarObject(const Value: Variant): TVarObject; +begin + if IsVarObject(Value) then + result := TVarObject(TVarData(Value).VInteger) + else + raise Exception.Create(errInternalError); +end; + +function VariantToSetObject(const Value: Variant): TSetObject; +begin + result := VariantToVarObject(Value) as TSetObject; +end; + +//---------- TVarObject -------------------------------------------------------- + +constructor TVarObject.Create(i_stable: Pointer); +begin + stable := i_stable; + voKind := voNone; + + if stable <> nil then + TBaseSymbolTable(stable).VarObjects.AddVarObject(Self); +end; + +//---------- TSetObject -------------------------------------------------------- + +constructor TSetObject.Create(i_stable: Pointer; const Value: TByteSet; + i_TypeId: Integer; i_TypeBaseId: Integer); +begin + inherited Create(i_stable); + fValue := Value; + TypeId := i_TypeId; + voKind := voSet; + TypeBaseId := I_TypeBaseId; +end; + +constructor TSetObject.CreateSimple(i_stable: Pointer); +begin + inherited Create(i_stable); + voKind := voSet; +end; + +function TSetObject.Clone: TVarObject; +begin + result := TSetObject.Create(stable, fValue, TypeId, TypeBaseId); +end; + +procedure TSetObject.SaveToStream(S: TWriter); +begin + S.Write(fValue, SizeOf(fValue)); + S.Write(TypeId, SizeOf(TypeId)); +end; + +procedure TSetObject.LoadFromStream(S: TReader); +begin + S.Read(fValue, SizeOf(fValue)); + S.Read(TypeId, SizeOf(TypeId)); +end; + +function TSetObject.ToStr: String; +var + S: TByteSet; + B1, B2: Integer; + I, J: Byte; + First: boolean; + FinType: Integer; + T: Integer; +begin + result := '[]'; + Exit; + + if stable <> nil then + begin + T := TBaseSymbolTable(stable).GetTypeBase(TypeId); + FinType := TBaseSymbolTable(stable)[T].FinalTypeId; + end + else + FinType := TypeBaseId; + + result := '['; + B1 := 0; + B2 := 0; + + S := fValue; + First := true; + + I := 0; + while I < 255 do + begin + if I in S then + begin + if First then + begin + B1 := I; + B2 := B1; + First := false; + end + else + Inc(B2); + end + else if not First then + begin + if B2 - B1 >= 1 then + begin + if FinType in CharTypes then + result := result + '''' + Chr(B1) + '''' + '..' + + '''' + Chr(B2) + '''' + else if FinType = typeENUM then + for J:=B1 to B2 do + begin +// result := result + GetName(T + J + 1); + if J < B2 then + result := result + ','; + end + else + result := result + IntToStr(B1) + '..' + IntToStr(B2); + end + else + begin + if FinType in CharTypes then + result := result + '''' + Chr(B1) + '''' + else if FinType = typeENUM then + begin +// result := result + GetName(T + B1 + 1) + end + else + result := result + IntToStr(B1); + end; + result := result + ','; + First := true; + end; + Inc(I); + end; + + if result[Length(result)] = ',' then + Delete(result, Length(result), 1); + + result := result + ']'; +end; + +//---------- TSimpleObject ----------------------------------------------------- + +constructor TSimpleObject.Create(i_stable: Pointer; + const Value: Variant; const i_Name: String); +begin + inherited Create(i_stable); + fValue := Value; + fName := i_Name; + voKind := voSimple; +end; + +constructor TSimpleObject.CreateSimple(i_stable: Pointer); +begin + inherited Create(i_stable); + voKind := voSimple; +end; + +function TSimpleObject.ToStr: String; +begin + result := VarToStr(Value); +end; + +procedure TSimpleObject.SaveToStream(S: TWriter); +begin + S.WriteString(fName); + SaveVariantToStream(fValue, S); +end; + +procedure TSimpleObject.LoadFromStream(S: TReader); +begin + fName := S.ReadString; + fValue := LoadVariantFromStream(S, stable); +end; + +//---------- TArrObject -------------------------------------------------------- + +constructor TArrObject.Create(i_stable: Pointer); +begin + inherited; +{$IFDEF ARC} + L := TList.Create; +{$ELSE} + L := TList.Create; +{$ENDIF} + voKind := voArray; +end; + +destructor TArrObject.Destroy; +begin + Clear; + FreeAndNil(L); + inherited; +end; + +procedure TArrObject.Clear; +var + I: Integer; +begin + for I:=0 to Count - 1 do +{$IFDEF ARC} + L[I] := nil; +{$ELSE} + TVarObject(L[I]).Free; +{$ENDIF} + L.Clear; +end; + +function TArrObject.GetItem(I: Integer): TVarObject; +begin + result := TVarObject(L[I]); +end; + +function TArrObject.Count: Integer; +begin + result := L.Count; +end; + +procedure TArrObject.AddVarObject(X: TVarObject); +begin + L.Add(X); +end; + +procedure TArrObject.SaveToStream(S: TWriter); +var + I, K: Integer; +begin + K := Count; + S.Write(K, SizeOf(K)); + for I := 0 to K - 1 do + begin + S.Write(Items[I].voKind, SizeOf(Items[I].voKind)); + Items[I].SaveToStream(S); + end; +end; + +procedure TArrObject.LoadFromStream(S: TReader); +var + I, K: Integer; + voKind: TVarObjectKind; + VObject: TVarObject; +begin + S.Read(K, SizeOf(K)); + for I := 0 to K - 1 do + begin + S.Read(voKind, SizeOf(voKind)); + case voKind of + voSet: VObject := TSetObject.CreateSimple(nil); + voSimple: VObject := TSimpleObject.CreateSimple(nil); + voArray: VObject := TArrObject.Create(nil); + else + raise Exception.Create(errInternalError); + end; + VObject.LoadFromStream(S); + AddVarObject(VObject); + end; +end; + +function TArrObject.ToStr: String; +var + I: Integer; +begin + result := '('; + for I:=0 to Count - 1 do + begin + result := result + Items[I].ToStr; + if I < Count - 1 then + result := result + ','; + end; + result := result + ')'; +end; + +//---------- TVarObjectList ---------------------------------------------------- + +constructor TVarObjectList.Create(i_stable: Pointer); +begin + inherited Create; + stable := i_stable; +end; + +function TVarObjectList.GetItem(I: Integer): TVarObject; +begin + result := TVarObject(L[I]); +end; + +procedure TVarObjectList.AddVarObject(X: TVarObject); +begin + L.Add(X); +end; + +function VariantToString(FinTypeId: Integer; const V: Variant): String; +var + B: Byte; +begin + if FinTypeId in BooleanTypes then + begin + if TVarData(V).VInteger = 0 then + result := 'false' + else + result := 'true'; + end + else + if FinTypeId in StringTypes then + begin + result := VarToStr(V); + result := '''' + result + ''''; + end + else + if FinTypeId in CharTypes then + begin + B := V; + result := Chr(B); + result := '''' + result + ''''; + end + else + if FinTypeId in VariantTypes then + begin + result := VarToStr(V); + if (VarType(V) = varString) or (varType(V) = varOleStr) then + result := '''' + result + ''''; + end + else + result := VarToStr(V); +end; + + +end. diff --git a/Sources/PAXINT_CALL.pas b/Sources/PAXINT_CALL.pas new file mode 100644 index 0000000..f6f5036 --- /dev/null +++ b/Sources/PAXINT_CALL.pas @@ -0,0 +1,145 @@ +//////////////////////////////////////////////////////////////////////////// +// PaxCompiler +// Site: http://www.paxcompiler.com +// Author: Alexander Baranovsky (paxscript@gmail.com) +// ======================================================================== +// Copyright (c) Alexander Baranovsky, 2006-2014. All rights reserved. +// Code Version: 4.2 +// ======================================================================== +// Unit: PAXINT_CALL.pas +// ======================================================================== +//////////////////////////////////////////////////////////////////////////// + +{$I PaxCompiler.def} +unit PAXINT_CALL; +interface +uses {$I uses.def} + PAXCOMP_CONSTANTS, + PAXCOMP_TYPES, + PAXCOMP_SYS, + PAXINT_SYS; +type + TIParamRec = record + Value: TPaxValue; + Address: Pointer; + Size: Integer; + end; + PIParamRec = ^TIParamRec; + + TICallRec = class + public + Runner: Pointer; + + ParamList: array[0..MAX_JS_PARAM] of TIParamRec; + NP: Integer; + + SubId: Integer; + Host: Boolean; + + ED: TISubExtraData; + + This: Pointer; + DL: Integer; + + ROffset: IntPax; + + // for host = false + LocalFrame: Pointer; + LocalSize: Integer; + NCall: Integer; + ResAddress: Pointer; + ResOffset: Integer; + ResByRef: Boolean; + PtrSize: Integer; + constructor Create; + destructor Destroy; override; + end; + + TICallStack = class(TTypedList) + private + function GetRecord(I: Integer): TICallRec; + function GetTop: TICallRec; + function GetPrev: TICallRec; + public + function AddRecord(Runner: Pointer): TICallRec; + function Pop: TICallRec; + function GetBySubId(SubId: Integer): TICallRec; + property Top: TICallRec read GetTop; + property Prev: TICallRec read GetPrev; + property Records[I: Integer]: TICallRec read GetRecord; default; + end; + +implementation + +constructor TICallRec.Create; +begin + inherited; +end; + +destructor TICallRec.Destroy; +var + I: Integer; +begin + for I := 0 to NP - 1 do + DisposePaxValue(ParamList[I].Value); + if LocalFrame <> nil then + FreeMem(LocalFrame, LocalSize + EXTRA_LOCAL_SIZE); + inherited; +end; + +function TICallStack.GetRecord(I: Integer): TICallRec; +begin + result := TICallRec(L[I]); +end; + +function TICallStack.AddRecord(Runner: Pointer): TICallRec; +begin + result := TICallRec.Create; + result.Runner := Runner; + L.Add(result); +end; + +function TICallStack.Pop: TICallRec; +begin +{$IFDEF ARC} + L[Count - 1] := nil; +{$ELSE} + Records[Count - 1].Free; +{$ENDIF} + L.Delete(Count - 1); + + if Count = 0 then + result := nil + else + result := Records[Count - 1]; +end; + +function TICallStack.GetTop: TICallRec; +begin + result := Records[Count - 1]; +end; + +function TICallStack.GetPrev: TICallRec; +begin + result := Records[Count - 2]; +end; + +function TICallStack.GetBySubId(SubId: Integer): TICallRec; +var + I: Integer; + R: TICallRec; +begin + result := nil; + for I := Count - 2 downto 0 do + begin + R := Records[I]; + if R.SubId = SubId then + begin + result := R; + Exit; + end; + end; +end; + + +end. diff --git a/Sources/PAXINT_CRT.pas b/Sources/PAXINT_CRT.pas new file mode 100644 index 0000000..d5223e6 --- /dev/null +++ b/Sources/PAXINT_CRT.pas @@ -0,0 +1,778 @@ +//////////////////////////////////////////////////////////////////////////// +// PaxCompiler +// Site: http://www.paxcompiler.com +// Author: Alexander Baranovsky (paxscript@gmail.com) +// ======================================================================== +// Copyright (c) Alexander Baranovsky, 2006-2014. All rights reserved. +// Code Version: 4.2 +// ======================================================================== +// Unit: PAXINT_CRT.pas +// ======================================================================== +//////////////////////////////////////////////////////////////////////////// + +{$I PaxCompiler.def} +unit PAXINT_CRT; +interface + +procedure EmitInterProc(akernel, aprog: Pointer; context: Pointer = nil); + +implementation + +uses + SysUtils, + PAXCOMP_CONSTANTS, + PAXCOMP_TYPES, + PAXCOMP_SYS, + PAXCOMP_KERNEL, + PAXCOMP_BYTECODE, + PAXCOMP_MAP, + PAXCOMP_CLASSLST, + PAXCOMP_CLASSFACT, + PAXCOMP_SYMBOL_REC, + PAXCOMP_SYMBOL_TABLE, + PAXCOMP_BASERUNNER, + PAXINT_SYS, + PAXINT_RUNNER; +type + TRunnerCreator = class + private + kernel: TKernel; + Code: TCode; + SymbolTable: TSymbolTable; + + Runner: TIRunner; + R: TIRunRec; + + IsEval: Boolean; + + constructor Create(akernel: Pointer; + aRunner: TIRunner); + destructor Destroy; override; + procedure CreateClassList; + procedure CreateArg(Id: Integer; var result: TIArg); + function LookupCodeRec(Op, Id: Integer): Integer; + procedure AddSubExtraData(I, SubId: Integer); + procedure AddEventExtraData(I, EventId: Integer); + procedure CreateRunner; + end; + +constructor TRunnerCreator.Create(akernel: Pointer; + aRunner: TIRunner); +begin + inherited Create; + + kernel := akernel; + Runner := aRunner; + + Code := Kernel.Code; + SymbolTable := Kernel.SymbolTable; +end; + +destructor TRunnerCreator.Destroy; +begin + inherited; +end; + +procedure TRunnerCreator.CreateClassList; +var + I, J, K, Id, IntfId, AncestorId, Offset: Integer; + JMP: IntPax; + InterfaceMethodIds, ClassMethodIds: TIntegerList; + IntfRec: TIntfRec; + ClassRec: TClassRec; + SZ: Integer; + temp: Boolean; + RR: TSymbolRec; + PaxInfo: PPaxInfo; + PaxFactoryRec: TPaxClassFactoryRec; + MapRec: TMapRec; +begin + Code.CreateMapping(Runner.ScriptMapTable, false, + Runner.HostMapTable, Runner.ScriptMapTable); + Runner.CreateMapOffsets; + for I := 1 to Code.Card do + if Code[I].Op = OP_INIT_SUB then + begin + Id := Code[I].Arg1; + SymbolTable[Id].Value := I; + MapRec := Runner.ScriptMapTable.LookupEx(SymbolTable[Id].FullName, + SymbolTable[Id].OverCount); + if MapRec <> nil then + begin + MapRec.Shift := I; + MapRec.Offset := I; + end; + end; + + if kernel.SignCompression then + SZ := kernel.OffsetList.GetSize + else + SZ := SymbolTable.GetDataSize + 4096; + + temp := Runner.UseMapping; + Runner.UseMapping := false; + Runner.Allocate(0, SZ); + Runner.UseMapping := temp; + + TKernel(kernel).AllocateConstants(Runner.ResultPtr); + + InterfaceMethodIds := TIntegerList.Create; + ClassMethodIds := TIntegerList.Create; + + try + + for I := FirstLocalId + 1 to SymbolTable.Card do + begin + if SymbolTable[I].Host then + begin + RR := SymbolTable[I]; + + if RR.Address <> nil then + begin + if not SymbolTable.InCode[I] then + continue; + + if not TKernel(kernel).ExistsOffset(RR) then + begin + continue; + end; + + offset := kernel.GetOffset(RR); + Runner.SetAddress(offset, RR.Address); + end + else if RR.ClassIndex <> -1 then + begin + RR := SymbolTable[I + 1]; // cls ref + J := RR.Value; + + if J = 0 then + begin + ClassRec := Runner.ClassList.Add(SymbolTable[I].FullName, SymbolTable[I].Host); + ClassRec.InstSize := SizeOf(Pointer); + end + else + begin + ClassRec := Runner.RegisterClass(TClass(Pointer(J)), SymbolTable[I].FullName, kernel.GetOffset(RR)); + ClassRec.InstSize := TClass(Pointer(J)).InstanceSize; + end; + ClassRec.ParentFullName := SymbolTable[SymbolTable[I].AncestorId].FullName; + end; + end + else if SymbolTable[I].ClassIndex >= 0 then + begin + ClassRec := Runner.ClassList.Add(SymbolTable[I].FullName, false); + ClassRec.Offset := kernel.GetOffset(SymbolTable[I + 1]); + ClassRec.SizeOfScriptClassFields := SymbolTable[I].GetSizeOfScriptClassFields; + ClassRec.PClass := TClass(IntPax(SymbolTable[I + 1].Value)); + ClassRec.ParentFullName := SymbolTable[SymbolTable[I].AncestorId].FullName; + + J := SymbolTable.FindDestructorId(I); + if J > 0 then + ClassRec.DestructorProgOffset := LookupCodeRec(OP_INIT_SUB, J); + + PaxInfo := GetPaxInfo(ClassRec.PClass); + if PaxInfo = nil then + kernel.RaiseError(errInternalError, []); + + if not IsEval then + begin + PaxInfo^.Prog := Runner; + PaxInfo^.ClassIndex := SymbolTable[I].ClassIndex; + end; + + PaxFactoryRec := Runner.ProgClassFactory.FindRecord(ClassRec.PClass); + if PaxFactoryRec = nil then + kernel.RaiseError(errInternalError, []); + + if SymbolTable[I].SupportedInterfaces = nil then + begin + ClassRec.InstSize := SymbolTable[I].GetSizeOfAllClassFields(Runner); + Inc(ClassRec.InstSize, SizeOf(Pointer)); // add monitor space + PaxFactoryRec.SetInstanceSize(ClassRec.InstSize); + continue; + end + else + begin + ClassRec.InstSize := SymbolTable[I].GetSizeOfAllClassFields(Runner) + + SymbolTable[I].SupportedInterfaces.Count * SizeOf(Pointer); + Inc(ClassRec.InstSize, SizeOf(Pointer)); // add monitor space + PaxFactoryRec.SetInstanceSize(ClassRec.InstSize); + end; + + if SymbolTable[I].SupportedInterfaces.Count = 0 then + continue; + + for J:=0 to SymbolTable[I].SupportedInterfaces.Count - 1 do + begin + Offset := - SymbolTable[I].GetSizeOfAllClassFields(nil) + + J * SizeOf(Pointer); + + InterfaceMethodIds.Clear; + ClassMethodIds.Clear; + IntfId := SymbolTable[I].SupportedInterfaces[J].Id; + SymbolTable.CreateInterfaceMethodList(I, IntfId, + InterfaceMethodIds, + ClassMethodIds); + IntfRec := ClassRec.IntfList.Add; + IntfRec.GUID := SymbolTable[I].SupportedInterfaces[J].GUID; + AncestorId := SymbolTable[I].AncestorId; + while not SymbolTable[AncestorId].Host do + AncestorId := SymbolTable[AncestorId].AncestorId; + + for K:=0 to ClassMethodIds.Count - 1 do + begin + Id := ClassMethodIds[K]; + TKernel(kernel).Code.Add(OP_JUMP_SUB, Id, + - Offset, K, 0, false, 0, 0, 0); + JMP := TKernel(kernel).Code.Card; + IntfRec.IntfMethods.AddMethod(SymbolTable[Id].FullName, JMP, Offset); + end; + end; + end; + end; + finally + FreeAndNil(InterfaceMethodIds); + FreeAndNil(ClassMethodIds); + end; + + kernel.CreateRTI(Runner); + + if not IsEval then + begin + TKernel(kernel).Code.CreateMethodEntryLists; + SymbolTable.ProcessClassFactory(kernel.ClassFactory, Runner); + kernel.ClassFactory.SetupStdVirtuals(Runner.ClassList, Runner.CodePtr); + Runner.SetupInterfaces(nil); + Runner.ProgTypeInfoList.AddToProgram(Runner); + end; +end; + +procedure TRunnerCreator.CreateArg(Id: Integer; var result: TIArg); +var + S: TSymbolRec; + PatternId: Integer; + P: Pointer; + V: Int64; +begin + S := SymbolTable[Id]; + + result.Id := Id; + result.Offset := Kernel.GetOffset(S); + result.Kind := S.Kind; + + result.ByRef := S.ByRef or S.ByRefEx or S.Host; + result.Local := S.Local or S.Param; + result.PtrSize := S.PtrSize; + result.FT := S.FinalTypeId; + + if IsEval then + result.Local := false; + + if result.Offset = 0 then + if S.Kind = KindCONST then + begin + result.Offset := Runner.DataSize; + Inc(Runner.fDataSize, result.PtrSize); + ReallocMem(Runner.Data, Runner.DataSize); + P := ShiftPointer(Runner.Data, result.Offset); +{$IFDEF VARIANTS} + V := S.Value; +{$ELSE} + V := Integer(S.Value); +{$ENDIF} + Move(V, P^, result.PtrSize); + result.ByRef := false; + end; + + if result.FT = typeSET then + result.PtrSize := SymbolTable.GetSizeOfSetType(S.TerminalTypeId) + else if result.FT = typeRECORD then + begin + if result.ByRef then + result.PtrSize := SizeOf(Pointer); + end; + + if result.FT = typePOINTER then + begin +{$IFNDEF PAXARM} + if S.HasPAnsiCharType then + result.FT := typePANSICHAR + else +{$ENDIF} + if S.HasPWideCharType then + result.FT := typePWIDECHAR; + end; + result.Level := S.Level; + + if S.OwnerId > 0 then + if S.Kind = KindVAR then + begin + PatternId := S.PatternId; // find id of pattern field + R.JMP := Kernel.GetOffset(SymbolTable[PatternId]); + + result.HasOwner := true; +// result.PtrSize := SizeOf(Pointer); + end; + + if result.ByRef and (not result.Local) and (not S.Host) then + result.HasOwner := true; +end; + +function TRunnerCreator.LookupCodeRec(Op, Id: Integer): Integer; +var + I: Integer; +begin + result := 0; + for I := 1 to Code.Card do + if Code[I].Arg1 = Id then + if Code[I].Op = Op then + begin + result := I; + Exit; + end; +end; + +procedure TRunnerCreator.AddSubExtraData(I, SubId: Integer); +var + SubExtraData: TISubExtraData; + K, J, ParamId, Level: Integer; +begin + R.ExtraDataIndex := Runner.ExtraDataList.IndexOf(SubId); + if R.ExtraDataIndex = -1 then + begin + SubExtraData := Runner.AddSubExtraData(I, SubId); + SubExtraData.FullName := SymbolTable[SubId].FullName; + SubExtraData.Kind := SymbolTable[SubId].Kind; + SubExtraData.Host := SymbolTable[SubId].Host; + SubExtraData.IsShared := SymbolTable[SubId].IsSharedMethod; + SubExtraData.IsFakeMethod := SymbolTable[SubId].IsFakeMethod; + SubExtraData.RunnerParam := SymbolTable[SubId].RunnerParameter; + SubExtraData.ExtraParamNeeded := SymbolTable[SubId].ExtraParamNeeded; + SubExtraData.Count := SymbolTable[SubId].Count; + SubExtraData.OverCount := SymbolTable[SubId].OverCount; + SubExtraData.CallConv := SymbolTable[SubId].CallConv; + SubExtraData.FT := SymbolTable[SubId].FinalTypeId; + SubExtraData.MethodIndex := SymbolTable[SubId].MethodIndex; + SubExtraData.PushProgRequired := SymbolTable[SubId].PushProgRequired; + Level := SymbolTable[SubId].Level; + SubExtraData.Level := Level; + + SubExtraData.CallMode := SymbolTable[SubId].CallMode; + + SubExtraData.IsInterfaceMethod := + (Level > 0) and + (SymbolTable[Level].Kind = KindTYPE) and + (SymbolTable[Level].FinalTypeId = typeINTERFACE); + SubExtraData.IsRecordMethod := + (Level > 0) and + (SymbolTable[Level].Kind = KindTYPE) and + (SymbolTable[Level].FinalTypeId = typeRECORD); + + if Level > 0 then + if SymbolTable[Level].Kind = KindTYPE then + if SymbolTable[Level].FinalTypeId = typeHELPER then + begin + K := SymbolTable[Level].PatternId; + if SymbolTable[K].FinalTypeId <> typeCLASS then + SubExtraData.IsRecordMethod := true; + end; + +{$IFDEF PAX64} + SubExtraData.LocalSize := SymbolTable.GetSubRSPSize(SubId); +{$ELSE} + SubExtraData.LocalSize := SymbolTable.GetSizeOfLocalsEx(SubId); +{$ENDIF} + + K := SubExtraData.Count; + SetLength(SubExtraData.ParamDescList, K); + for J := 0 to K - 1 do + begin + ParamId := SymbolTable.GetParamId(SubId, J); + SubExtraData.ParamDescList[J].Offset := + Kernel.GetOffset(SymbolTable[ParamId]); + SubExtraData.ParamDescList[J].ByRef := SymbolTable[ParamId].ByRef or + SymbolTable[ParamId].ByRefEx; + SubExtraData.ParamDescList[J].IsConst := SymbolTable[ParamId].IsConst; + SubExtraData.ParamDescList[J].FT := SymbolTable[ParamId].FinalTypeId; + SubExtraData.ParamDescList[J].PtrSize := SymbolTable[ParamId].PtrSize; + SubExtraData.ParamDescList[J].IsOpenArray := SymbolTable[ParamId].IsOpenArray; + SubExtraData.ParamDescList[J].Register := SymbolTable[ParamId].Register; + if SymbolTable[ParamId].XMMReg > 0 then + SubExtraData.ParamDescList[J].Register := SymbolTable[ParamId].XMMReg; + + if not SubExtraData.Host then + if SubExtraData.ParamDescList[J].IsOpenArray then + begin + ParamId := SymbolTable.GetOpenArrayHighId(ParamId); + SubExtraData.ParamDescList[J].HighOffset := + SymbolTable[ParamId].Shift; + end; + end; + ParamId := SymbolTable.GetResultId(SubId); + SubExtraData.ResRegister := SymbolTable[ParamId].Register; + SubExtraData.SizeOfParams := SymbolTable.GetSizeOfParams(SubId); + SubExtraData.ResSize := SymbolTable[ParamId].PtrSize; + SubExtraData.ResOffset := Kernel.GetOffset(SymbolTable[ParamId]); + SubExtraData.ResByRef := SymbolTable[ParamId].ByRef or + SymbolTable[ParamId].ByRefEx; + if not SubExtraData.Host then + SubExtraData.JMP := LookupCodeRec(OP_INIT_SUB, SubId); + end; + R.JMP := LookupCodeRec(OP_INIT_SUB, SubId); +end; + +procedure TRunnerCreator.AddEventExtraData(I, EventId: Integer); +var + EventExtraData: TIEventExtraData; + DataId, SubId: Integer; +begin + DataId := SymbolTable[EventId].OwnerId; + if SymbolTable[DataId].Kind = KindTYPE then + Inc(DataId); + + SubId := SymbolTable[EventId].PatternId; + AddSubExtraData(I, SubId); + EventExtraData := Runner.AddEventExtraData(I, EventId); + CreateArg(SubId, EventExtraData.CodeArg); + CreateArg(DataId, EventExtraData.DataArg); + EventExtraData.CodeArg.HasOwner := true; + EventExtraData.DataArg.HasOwner := true; +end; + +procedure TRunnerCreator.CreateRunner; +var + I, J,SubId, PropIndex, ClassId, Shift: Integer; + RI: TCodeRec; + ArrExtraData: TIArrExtraData; + StructExtraData: TIStructExtraData; + TypeId, FT, + ArrayTypeId, ElemTypeId, ElemFinalTypeId, RangeTypeId, H1, ElSize: Integer; +begin + kernel.Modules.Recalc; + CreateClassList; + + for I := 1 to Code.Card do + begin + Runner.N := I; + Code.N := I; + + RI := Code[I]; + R := Runner.AddRecord; + + R.Op := RI.Op; + if RI.IsInherited then + if RI.Op = OP_CALL then + R.Op := OP_CALL_INHERITED; + + R.Lang := RI.Language; + + if (R.Op = OP_GET_ORD_PROP) or +{$IFNDEF PAXARM} + (R.Op = OP_GET_ANSISTR_PROP) or + (R.Op = OP_GET_WIDESTR_PROP) or +{$ENDIF} + (R.Op = OP_GET_UNICSTR_PROP) or + (R.Op = OP_GET_INTERFACE_PROP) or + (R.Op = OP_GET_VARIANT_PROP) or + (R.Op = OP_GET_INT64_PROP) or + (R.Op = OP_GET_FLOAT_PROP) or + (R.Op = OP_GET_SET_PROP) or + (R.Op = OP_GET_EVENT_PROP) + or + (R.Op = OP_SET_ORD_PROP) or +{$IFNDEF PAXARM} + (R.Op = OP_SET_ANSISTR_PROP) or + (R.Op = OP_SET_WIDESTR_PROP) or +{$ENDIF} + (R.Op = OP_SET_UNICSTR_PROP) or + (R.Op = OP_SET_INTERFACE_PROP) or + (R.Op = OP_SET_VARIANT_PROP) or + (R.Op = OP_SET_INT64_PROP) or + (R.Op = OP_SET_FLOAT_PROP) or + (R.Op = OP_SET_SET_PROP) or + (R.Op = OP_SET_EVENT_PROP) or + (R.Op = OP_SET_EVENT_PROP2) + then + begin + PropIndex := SymbolTable[RI.Arg2].PropIndex; + ClassId := SymbolTable[RI.Arg1].TerminalHostClassId; + Shift := SymbolTable[ClassId + 1].Shift; + Inc(Shift, (PropIndex + 1) * SizeOf(Pointer)); + J := RI.Arg2; + repeat + Inc(J); + until SymbolTable[J].Shift = Shift; + + CreateArg(Code[I].Arg1, R.A1); + CreateArg(J, R.A2); + CreateArg(Code[I].Res, R.AR); + if R.Op = OP_SET_EVENT_PROP then + begin + AddEventExtraData(I, Code[I].Res); + end; + end + else if (R.Op = OP_GET_DRTTI_PROP) or + (R.Op = OP_SET_DRTTI_PROP) then + begin + PropIndex := SymbolTable[RI.Arg2].PropIndex; + ClassId := SymbolTable[RI.Arg1].TerminalHostClassId; + Shift := SymbolTable[ClassId + 1].Shift; + Inc(Shift, (PropIndex + 1) * SizeOf(Pointer)); + J := RI.Arg2; + repeat + Inc(J); + until SymbolTable[J].Shift = Shift; + CreateArg(Code[I].Arg1, R.A1); + CreateArg(J, R.A2); + CreateArg(Code[I].Res, R.AR); + end + else if R.Op = OP_STRUCTURE_CLR then + begin + J := Code[I].Arg1; + if SymbolTable[J].FinalTypeId = typeRECORD then + begin + TypeId := SymbolTable[J].TerminalTypeId; + J := SymbolTable.FindDestructorId(TypeId); + R.JMP := LookupCodeRec(OP_INIT_SUB, J); + + R.ExtraDataIndex := Runner.ExtraDataList.IndexOf(TypeId); + if R.ExtraDataIndex = -1 then + begin + StructExtraData := Runner.AddStructExtraData(I, TypeId); + FreeAndNil(StructExtraData.Types); + StructExtraData.FinTypes.Clear; + FreeAndNil(StructExtraData.Offsets); + StructExtraData.Offsets := SymbolTable.GetShiftsOfDynamicFields(TypeId); + StructExtraData.Types := SymbolTable.GetTypesOfDynamicFields(TypeId); + + for J := 0 to StructExtraData.Types.Count - 1 do + begin + TypeId := StructExtraData.Types[J]; + FT := SymbolTable[TypeId].FinalTypeId; + StructExtraData.FinTypes.Add(FT); + end; + end; + end + else + begin + TypeId := SymbolTable[J].TerminalTypeId; + StructExtraData := Runner.AddStructExtraData(I, TypeId); + FreeAndNil(StructExtraData.Types); + StructExtraData.FinTypes.Clear; + FreeAndNil(StructExtraData.Offsets); + StructExtraData.Offsets := SymbolTable.GetShiftsOfDynamicFields(TypeId); + StructExtraData.Types := SymbolTable.GetTypesOfDynamicFields(TypeId); + for J := 0 to StructExtraData.Types.Count - 1 do + begin + TypeId := StructExtraData.Types[J]; + FT := SymbolTable[TypeId].FinalTypeId; + StructExtraData.FinTypes.Add(FT); + end; + end; + CreateArg(Code[I].Arg1, R.A1); + end + else if (R.Op = OP_ELEM) or (R.Op = OP_SET_LENGTH_EX) or + (R.Op = OP_DYNARRAY_CLR) or (R.Op = OP_DYNARRAY_ASSIGN) or + (R.Op = OP_INIT_FWARRAY) then + begin + J := SymbolTable[Code[I].Arg1].FinalTypeId; + case J of + typeCLASS: + begin + J := SymbolTable[Code[I].Arg1].TerminalTypeId; + ArrayTypeId := SymbolTable[J].PatternId; + ElemTypeId := SymbolTable[ArrayTypeId].PatternId; + ElemFinalTypeId := SymbolTable[ElemTypeId].FinalTypeId; + ElSize := SymbolTable[ElemTypeId].Size; + R.ExtraDataIndex := Runner.ExtraDataList.IndexOf(ArrayTypeId); + if R.ExtraDataIndex = -1 then + begin + ArrExtraData := Runner.AddArrExtraData(I, ArrayTypeId); + ArrExtraData.ElSize := ElSize; + ArrExtraData.ElTypeId := ElemTypeId; + ArrExtraData.ElFinTypeId := ElemFinalTypeId; + end; + end; + typeARRAY: + begin + ArrayTypeId := SymbolTable[Code[I].Arg1].TerminalTypeId; + SymbolTable.GetArrayTypeInfo(ArrayTypeId, RangeTypeId, ElemTypeId); + H1 := SymbolTable.GetLowBoundRec(RangeTypeId).Value; + ElSize := SymbolTable[ElemTypeId].Size; + + R.ExtraDataIndex := Runner.ExtraDataList.IndexOf(ArrayTypeId); + if R.ExtraDataIndex = -1 then + begin + ArrExtraData := Runner.AddArrExtraData(I, ArrayTypeId); + ArrExtraData.ElSize := ElSize; + ArrExtraData.H1 := H1; + end; + end; + typeDYNARRAY, typeOPENARRAY: + begin + ArrayTypeId := SymbolTable[Code[I].Arg1].TerminalTypeId; + ElemTypeId := SymbolTable[ArrayTypeId].PatternId; + ElemFinalTypeId := SymbolTable[ElemTypeId].FinalTypeId; + ElSize := SymbolTable[ElemTypeId].Size; + + R.ExtraDataIndex := Runner.ExtraDataList.IndexOf(ArrayTypeId); + if R.ExtraDataIndex = -1 then + begin + ArrExtraData := Runner.AddArrExtraData(I, ArrayTypeId); + ArrExtraData.ElSize := ElSize; + ArrExtraData.ElTypeId := ElemTypeId; + ArrExtraData.ElFinTypeId := ElemFinalTypeId; + + if ElemFinalTypeId = typeDYNARRAY then + begin + ArrayTypeId := ElemTypeId; + if Runner.ExtraDataList.IndexOf(ArrayTypeId) = -1 then + begin + ElemTypeId := SymbolTable[ArrayTypeId].PatternId; + ElemFinalTypeId := SymbolTable[ElemTypeId].FinalTypeId; + ElSize := SymbolTable[ElemTypeId].Size; + ArrExtraData := Runner.AddArrExtraData(I, ArrayTypeId); + ArrExtraData.ElSize := ElSize; + ArrExtraData.ElTypeId := ElemTypeId; + ArrExtraData.ElFinTypeId := ElemFinalTypeId; + end; + end; + end; + end; + end; + CreateArg(Code[I].Arg1, R.A1); + CreateArg(Code[I].Arg2, R.A2); + CreateArg(Code[I].Res, R.AR); + end + else if R.Op = OP_GET_VMT_ADDRESS then + begin + R.ExtraDataIndex := Runner.ExtraDataList.IndexOf(Code[I].Arg2); + CreateArg(Code[I].Arg1, R.A1); + CreateArg(Code[I].Arg2, R.A2); + CreateArg(Code[I].Res, R.AR); + end + else if (R.Op = OP_BEGIN_CALL) or + (R.Op = OP_CALL) or + (R.Op = OP_CALL_INHERITED) or + (R.Op = OP_INIT_SUB) or + (R.Op = OP_JUMP_SUB) or + (R.Op = OP_LOAD_PROC) then + begin + SubId := Code[I].Arg1; + + CreateArg(SubId, R.A1); + CreateArg(Code[I].Res, R.AR); + + SubId := Code.GetTrueSubId; + + AddSubExtraData(I, SubId); + + if R.Op = OP_INIT_SUB then + begin + J := Code.GetCurrSelfId(I); + if J > 0 then + begin + CreateArg(J, R.A2); + Code[I].Arg2 := J; + end; + end + else if R.Op = OP_LOAD_PROC then + begin + CreateArg(Code[I].Arg2, R.A2); + end + else if R.Op = OP_JUMP_SUB then + begin + CreateArg(Code[I].Arg2, R.A2); + R.JMP := LookupCodeRec(OP_INIT_SUB, SubId); + end; + end + else if PushOperators.IndexOf(R.Op) >= 0 then + begin + CreateArg(Code[I].Arg1, R.A1); + begin + CreateArg(Code[I].Arg2, R.A2); + CreateArg(Code[I].Res, R.AR); + end; + end + else + begin + CreateArg(Code[I].Arg1, R.A1); + CreateArg(Code[I].Arg2, R.A2); + CreateArg(Code[I].Res, R.AR); + + if (R.Op = OP_GO) or + (R.Op = OP_GO_DL) or + (R.Op = OP_GO_FALSE) or + (R.Op = OP_GO_TRUE) then + begin + R.JMP := LookupCodeRec(OP_LABEL, Code[I].Arg1); + end + else if R.Op = OP_TRY_ON then + begin + R.AR.Id := Code.GetCurrSubId(I); + end + else if R.Op = OP_EXCEPT_ON then + begin + J := SymbolTable[Code[I].Res].TerminalTypeId; + R.JMP := SymbolTable[J].ClassIndex; + end + else if R.Op = OP_ADDRESS then + begin + if SymbolTable[Code[I].Arg1].Kind in KindSUBS then + if SymbolTable[Code[I].Arg1].Host = false then + R.JMP := LookupCodeRec(OP_INIT_SUB, Code[I].Arg1); + end + else if R.Op = OP_CREATE_EVENT then + begin + if SymbolTable[Code[I].Arg2].Kind in KindSUBS then + if SymbolTable[Code[I].Arg2].Host = false then + R.JMP := LookupCodeRec(OP_INIT_SUB, Code[I].Arg2); + end + else if R.Op = OP_CREATE_OBJECT then + begin + J := Code.GetCurrSelfId(I); + CreateArg(J, R.A2); + end + else if R.Op = OP_INTERFACE_FROM_CLASS then + begin + J := SymbolTable[Code[I].Arg1].TerminalTypeId + 1; + CreateArg(J, R.A1); + end + else if R.Op = OP_INTERFACE_CAST then + begin + J := SymbolTable[Code[I].Arg2].TerminalTypeId + 1; + CreateArg(J, R.A2); + end; + end; + end; + + Runner.CreateTryList; + Runner.SetGlobalAddresses; + Runner.InitStringLiterals; + + Runner.ExtraDataList.AttachRTTI; + + Runner.N := 1; +end; + +procedure EmitInterProc(akernel, aprog: Pointer; context: Pointer = nil); +var + runner: TIRunner; + RunnerCreator: TRunnerCreator; +begin + runner := TIRunner(aprog); + + RunnerCreator := TRunnerCreator.Create(akernel, runner); + RunnerCreator.IsEval := context <> nil; + try + RunnerCreator.CreateRunner; + if RunnerCreator.IsEval then + Dump_All(DUMP_PATH, akernel, nil, nil) + else + Dump_All(DUMP_PATH, akernel, aprog, nil); + finally + FreeAndNil(RunnerCreator); + end; +end; + +end. diff --git a/Sources/PAXINT_PROCS.pas b/Sources/PAXINT_PROCS.pas new file mode 100644 index 0000000..667b724 --- /dev/null +++ b/Sources/PAXINT_PROCS.pas @@ -0,0 +1,5601 @@ +//////////////////////////////////////////////////////////////////////////// +// PaxCompiler +// Site: http://www.paxcompiler.com +// Author: Alexander Baranovsky (paxscript@gmail.com) +// ======================================================================== +// Copyright (c) Alexander Baranovsky, 2006-2014. All rights reserved. +// Code Version: 4.2 +// ======================================================================== +// Unit: PAXINT_PROCS.pas +// ======================================================================== +//////////////////////////////////////////////////////////////////////////// + +{$I PaxCompiler.def} + +unit PAXINT_PROCS; +interface +uses + Classes, + PAXINT_RUNNER; + +procedure OperNop(var Runner: TIRunner); + +procedure _OP_LOAD_PROC(var Runner: TIRunner); +procedure _OP_ADD_MESSAGE(var Runner: TIRunner); +procedure _OP_VARARRAY_GET(var Runner: TIRunner); +procedure _OP_VARARRAY_PUT(var Runner: TIRunner); +procedure _OP_CLASSNAME(var Runner: TIRunner); +procedure _OP_PUSH_PTR(var Runner: TIRunner); +procedure _OP_GET_PROG(var Runner: TIRunner); +procedure _OP_ASSIGN_CLASS(var Runner: TIRunner); +procedure _OP_ASSIGN_EVENT(var Runner: TIRunner); +procedure _OP_CREATE_EVENT(var Runner: TIRunner); +procedure _OP_CREATE_METHOD(var Runner: TIRunner); +procedure _OP_PUSH_DATA(var Runner: TIRunner); +procedure _OP_ASSIGN_PWIDECHAR(var Runner: TIRunner); +procedure _OP_ASSIGN_UNICSTRING(var Runner: TIRunner); +// procedure _OP_PUSH_UNICSTRING = _OP_PUSH_INT + +procedure _OP_UNICSTRING_FROM_WIDECHAR(var Runner: TIRunner); +procedure _OP_UNICSTRING_FROM_PWIDECHAR(var Runner: TIRunner); +procedure _OP_UNICSTRING_FROM_VARIANT(var Runner: TIRunner); +procedure _OP_ADD_UNICSTRING(var Runner: TIRunner); +procedure _OP_GT_UNICSTRING(var Runner: TIRunner); +procedure _OP_GE_UNICSTRING(var Runner: TIRunner); +procedure _OP_LT_UNICSTRING(var Runner: TIRunner); +procedure _OP_LE_UNICSTRING(var Runner: TIRunner); +procedure _OP_EQ_UNICSTRING(var Runner: TIRunner); +procedure _OP_NE_UNICSTRING(var Runner: TIRunner); +procedure _OP_UNICSTRING_CLR(var Runner: TIRunner); + +procedure _OP_ASSIGN_INT(var Runner: TIRunner); + +procedure _OP_ADD_INT(var Runner: TIRunner); +procedure _OP_SUB_INT(var Runner: TIRunner); +procedure _OP_IMUL_INT(var Runner: TIRunner); +procedure _OP_IDIV_INT(var Runner: TIRunner); +procedure _OP_MOD_INT(var Runner: TIRunner); +procedure _OP_SHL_INT(var Runner: TIRunner); +procedure _OP_SHR_INT(var Runner: TIRunner); +procedure _OP_AND_INT(var Runner: TIRunner); +procedure _OP_OR_INT(var Runner: TIRunner); +procedure _OP_XOR_INT(var Runner: TIRunner); +procedure _OP_NEG_INT(var Runner: TIRunner); +procedure _OP_NOT(var Runner: TIRunner); +procedure _OP_NOT_BOOL(var Runner: TIRunner); +procedure _OP_NOT_BYTEBOOL(var Runner: TIRunner); +procedure _OP_NOT_WORDBOOL(var Runner: TIRunner); +procedure _OP_NOT_LONGBOOL(var Runner: TIRunner); +procedure _OP_ABS_INT(var Runner: TIRunner); +procedure _OP_GT_INT(var Runner: TIRunner); +procedure _OP_GE_INT(var Runner: TIRunner); +procedure _OP_LT_INT(var Runner: TIRunner); +procedure _OP_LE_INT(var Runner: TIRunner); +procedure _OP_EQ_INT(var Runner: TIRunner); +procedure _OP_NE_INT(var Runner: TIRunner); +procedure _OP_INT_TO_DOUBLE(var Runner: TIRunner); +procedure _OP_INT_TO_SINGLE(var Runner: TIRunner); +procedure _OP_INT_TO_EXTENDED(var Runner: TIRunner); +procedure _OP_INT_TO_INT64(var Runner: TIRunner); +procedure _OP_INT_FROM_INT64(var Runner: TIRunner); +procedure _OP_INT_TO_UINT64(var Runner: TIRunner); +procedure _OP_INT_FROM_UINT64(var Runner: TIRunner); + +procedure _OP_ASSIGN_INT64(var Runner: TIRunner); +// procedure _OP_PUSH_INT64 = _OP_PUSH_INT(var Runner: TIRunner); +procedure _OP_ADD_INT64(var Runner: TIRunner); +procedure _OP_SUB_INT64(var Runner: TIRunner); +procedure _OP_MULT_INT64(var Runner: TIRunner); +procedure _OP_IDIV_INT64(var Runner: TIRunner); +procedure _OP_MOD_INT64(var Runner: TIRunner); +procedure _OP_SHL_INT64(var Runner: TIRunner); +procedure _OP_SHR_INT64(var Runner: TIRunner); +procedure _OP_AND_INT64(var Runner: TIRunner); +procedure _OP_OR_INT64(var Runner: TIRunner); +procedure _OP_XOR_INT64(var Runner: TIRunner); +procedure _OP_NEG_INT64(var Runner: TIRunner); +procedure _OP_ABS_INT64(var Runner: TIRunner); +procedure _OP_GT_INT64(var Runner: TIRunner); +procedure _OP_GE_INT64(var Runner: TIRunner); +procedure _OP_LT_INT64(var Runner: TIRunner); +procedure _OP_LE_INT64(var Runner: TIRunner); +procedure _OP_EQ_INT64(var Runner: TIRunner); +procedure _OP_NE_INT64(var Runner: TIRunner); +procedure _OP_INT64_TO_DOUBLE(var Runner: TIRunner); +procedure _OP_INT64_TO_SINGLE(var Runner: TIRunner); +procedure _OP_INT64_TO_EXTENDED(var Runner: TIRunner); + +procedure _OP_ASSIGN_UINT64(var Runner: TIRunner); +// procedure _OP_PUSH_UINT64 = _OP_PUSH_INT(var Runner: TIRunner); +procedure _OP_ADD_UINT64(var Runner: TIRunner); +procedure _OP_SUB_UINT64(var Runner: TIRunner); +procedure _OP_AND_UINT64(var Runner: TIRunner); +procedure _OP_OR_UINT64(var Runner: TIRunner); +procedure _OP_XOR_UINT64(var Runner: TIRunner); +procedure _OP_GT_UINT64(var Runner: TIRunner); +procedure _OP_GE_UINT64(var Runner: TIRunner); +procedure _OP_LT_UINT64(var Runner: TIRunner); +procedure _OP_LE_UINT64(var Runner: TIRunner); +procedure _OP_UINT64_TO_DOUBLE(var Runner: TIRunner); +procedure _OP_UINT64_TO_SINGLE(var Runner: TIRunner); +procedure _OP_UINT64_TO_EXTENDED(var Runner: TIRunner); + +procedure _OP_ASSIGN_DOUBLE(var Runner: TIRunner); +procedure _OP_ADD_DOUBLE(var Runner: TIRunner); +procedure _OP_SUB_DOUBLE(var Runner: TIRunner); +procedure _OP_MUL_DOUBLE(var Runner: TIRunner); +procedure _OP_DIV_DOUBLE(var Runner: TIRunner); +procedure _OP_NEG_DOUBLE(var Runner: TIRunner); +procedure _OP_ABS_DOUBLE(var Runner: TIRunner); +procedure _OP_GT_DOUBLE(var Runner: TIRunner); +procedure _OP_GE_DOUBLE(var Runner: TIRunner); +procedure _OP_LT_DOUBLE(var Runner: TIRunner); +procedure _OP_LE_DOUBLE(var Runner: TIRunner); +procedure _OP_EQ_DOUBLE(var Runner: TIRunner); +procedure _OP_NE_DOUBLE(var Runner: TIRunner); +procedure _OP_DOUBLE_TO_SINGLE(var Runner: TIRunner); +procedure _OP_DOUBLE_TO_EXTENDED(var Runner: TIRunner); + +procedure _OP_ASSIGN_SINGLE(var Runner: TIRunner); +procedure _OP_ADD_SINGLE(var Runner: TIRunner); +procedure _OP_SUB_SINGLE(var Runner: TIRunner); +procedure _OP_MUL_SINGLE(var Runner: TIRunner); +procedure _OP_DIV_SINGLE(var Runner: TIRunner); +procedure _OP_NEG_SINGLE(var Runner: TIRunner); +procedure _OP_ABS_SINGLE(var Runner: TIRunner); +procedure _OP_GT_SINGLE(var Runner: TIRunner); +procedure _OP_GE_SINGLE(var Runner: TIRunner); +procedure _OP_LT_SINGLE(var Runner: TIRunner); +procedure _OP_LE_SINGLE(var Runner: TIRunner); +procedure _OP_EQ_SINGLE(var Runner: TIRunner); +procedure _OP_NE_SINGLE(var Runner: TIRunner); +procedure _OP_SINGLE_TO_DOUBLE(var Runner: TIRunner); +procedure _OP_SINGLE_TO_EXTENDED(var Runner: TIRunner); + +procedure _OP_ASSIGN_EXTENDED(var Runner: TIRunner); +procedure _OP_ADD_EXTENDED(var Runner: TIRunner); +procedure _OP_SUB_EXTENDED(var Runner: TIRunner); +procedure _OP_MUL_EXTENDED(var Runner: TIRunner); +procedure _OP_DIV_EXTENDED(var Runner: TIRunner); +procedure _OP_NEG_EXTENDED(var Runner: TIRunner); +procedure _OP_ABS_EXTENDED(var Runner: TIRunner); +procedure _OP_GT_EXTENDED(var Runner: TIRunner); +procedure _OP_GE_EXTENDED(var Runner: TIRunner); +procedure _OP_LT_EXTENDED(var Runner: TIRunner); +procedure _OP_LE_EXTENDED(var Runner: TIRunner); +procedure _OP_EQ_EXTENDED(var Runner: TIRunner); +procedure _OP_NE_EXTENDED(var Runner: TIRunner); +procedure _OP_EXTENDED_TO_DOUBLE(var Runner: TIRunner); +procedure _OP_EXTENDED_TO_SINGLE(var Runner: TIRunner); + +procedure _OP_ASSIGN_CURRENCY(var Runner: TIRunner); +procedure _OP_ADD_CURRENCY(var Runner: TIRunner); +procedure _OP_SUB_CURRENCY(var Runner: TIRunner); +procedure _OP_MUL_CURRENCY(var Runner: TIRunner); +procedure _OP_DIV_CURRENCY(var Runner: TIRunner); +procedure _OP_NEG_CURRENCY(var Runner: TIRunner); +procedure _OP_ABS_CURRENCY(var Runner: TIRunner); +procedure _OP_GT_CURRENCY(var Runner: TIRunner); +procedure _OP_GE_CURRENCY(var Runner: TIRunner); +procedure _OP_LT_CURRENCY(var Runner: TIRunner); +procedure _OP_LE_CURRENCY(var Runner: TIRunner); +procedure _OP_EQ_CURRENCY(var Runner: TIRunner); +procedure _OP_NE_CURRENCY(var Runner: TIRunner); +procedure _OP_CURRENCY_TO_DOUBLE(var Runner: TIRunner); +procedure _OP_CURRENCY_TO_SINGLE(var Runner: TIRunner); +procedure _OP_CURRENCY_TO_EXTENDED(var Runner: TIRunner); +procedure _OP_CURRENCY_FROM_INT64(var Runner: TIRunner); +procedure _OP_CURRENCY_FROM_UINT64(var Runner: TIRunner); +procedure _OP_CURRENCY_FROM_INT(var Runner: TIRunner); +procedure _OP_CURRENCY_FROM_REAL(var Runner: TIRunner); + +procedure _OP_ASSIGN_VARIANT(var Runner: TIRunner); + +procedure _OP_VARIANT_FROM_WIDECHAR(var Runner: TIRunner); +procedure _OP_VARIANT_FROM_PWIDECHAR(var Runner: TIRunner); +procedure _OP_VARIANT_FROM_UNICSTRING(var Runner: TIRunner); +procedure _OP_VARIANT_FROM_INT(var Runner: TIRunner); +procedure _OP_VARIANT_FROM_INT64(var Runner: TIRunner); +procedure _OP_VARIANT_FROM_REAL(var Runner: TIRunner); +procedure _OP_VARIANT_FROM_CURRENCY(var Runner: TIRunner); +procedure _OP_VARIANT_FROM_INTERFACE(var Runner: TIRunner); +procedure _OP_VARIANT_FROM_BOOL(var Runner: TIRunner); +procedure _OP_ADD_VARIANT(var Runner: TIRunner); +procedure _OP_SUB_VARIANT(var Runner: TIRunner); +procedure _OP_MULT_VARIANT(var Runner: TIRunner); +procedure _OP_DIV_VARIANT(var Runner: TIRunner); +procedure _OP_IDIV_VARIANT(var Runner: TIRunner); +procedure _OP_NEG_VARIANT(var Runner: TIRunner); +procedure _OP_NOT_VARIANT(var Runner: TIRunner); +procedure _OP_ABS_VARIANT(var Runner: TIRunner); +procedure _OP_GT_VARIANT(var Runner: TIRunner); +procedure _OP_GE_VARIANT(var Runner: TIRunner); +procedure _OP_LT_VARIANT(var Runner: TIRunner); +procedure _OP_LE_VARIANT(var Runner: TIRunner); +procedure _OP_EQ_VARIANT(var Runner: TIRunner); +procedure _OP_NE_VARIANT(var Runner: TIRunner); +procedure _OP_VARIANT_CLR(var Runner: TIRunner); + +procedure _OP_ASSIGN_OLEVARIANT(var Runner: TIRunner); +procedure _OP_OLEVARIANT_FROM_INTERFACE(var Runner: TIRunner); + +procedure _OP_X_FROM_VARIANT(var Runner: TIRunner); +procedure _OP_BOOL_FROM_INT(var Runner: TIRunner); + +procedure _OP_ASSIGN_INTERFACE(var Runner: TIRunner); +procedure _OP_INTERFACE_CLR(var Runner: TIRunner); +procedure _OP_INTERFACE_FROM_CLASS(var Runner: TIRunner); +procedure _OP_INTERFACE_CAST(var Runner: TIRunner); + +procedure _OP_ASSIGN_TVarRec(var Runner: TIRunner); +procedure _OP_ASSIGN_RECORD(var Runner: TIRunner); +procedure _OP_EQ_STRUCT(var Runner: TIRunner); +procedure _OP_NE_STRUCT(var Runner: TIRunner); +procedure _OP_STRUCTURE_CLR(var Runner: TIRunner); + +procedure _OP_DYNARRAY_ASSIGN(var Runner: TIRunner); +procedure _OP_DYNARRAY_CLR(var Runner: TIRunner); +procedure _OP_CREATE_EMPTY_DYNARRAY(var Runner: TIRunner); + +procedure _OP_SET_ASSIGN(var Runner: TIRunner); +procedure _OP_SET_COUNTER_ASSIGN(var Runner: TIRunner); +procedure _OP_SET_UNION(var Runner: TIRunner); +procedure _OP_SET_DIFFERENCE(var Runner: TIRunner); +procedure _OP_SET_INCLUDE(var Runner: TIRunner); +procedure _OP_SET_INCLUDE_INTERVAL(var Runner: TIRunner); +procedure _OP_SET_INTERSECTION(var Runner: TIRunner); +procedure _OP_SET_SUBSET(var Runner: TIRunner); +procedure _OP_SET_SUPERSET(var Runner: TIRunner); +procedure _OP_SET_EQUALITY(var Runner: TIRunner); +procedure _OP_SET_INEQUALITY(var Runner: TIRunner); +procedure _OP_SET_MEMBERSHIP(var Runner: TIRunner); + +procedure _OP_PRINT_EX(var Runner: TIRunner); +procedure _OP_BEGIN_CALL(var Runner: TIRunner); +procedure _OP_GET_VMT_ADDRESS(var Runner: TIRunner); +procedure _OP_ADDRESS(var Runner: TIRunner); +procedure _OP_TERMINAL(var Runner: TIRunner); +procedure _OP_TYPEINFO(var Runner: TIRunner); +procedure _OP_CALL(var Runner: TIRunner); +procedure _OP_INIT_SUB(var Runner: TIRunner); +procedure _OP_END_SUB(var Runner: TIRunner); +procedure _OP_SET_LENGTH(var Runner: TIRunner); +procedure _OP_PUSH_LENGTH(var Runner: TIRunner); +procedure _OP_SET_LENGTH_EX(var Runner: TIRunner); +procedure _OP_FIELD(var Runner: TIRunner); +procedure _OP_ELEM(var Runner: TIRunner); +procedure _OP_GET_COMPONENT(var Runner: TIRunner); +procedure _OP_INIT_FWARRAY(var Runner: TIRunner); +procedure _OP_GO_DL(var Runner: TIRunner); +procedure _OP_GO(var Runner: TIRunner); +procedure _OP_GO_FALSE(var Runner: TIRunner); +procedure _OP_GO_TRUE(var Runner: TIRunner); +procedure _OP_PUSH_INT(var Runner: TIRunner); +procedure _OP_PUSH_STRUCTURE(var Runner: TIRunner); +procedure _OP_PUSH_ADDRESS(var Runner: TIRunner); +procedure _OP_PUSH_INST(var Runner: TIRunner); +procedure _OP_PUSH_CLSREF(var Runner: TIRunner); +procedure _OP_CREATE_OBJECT(var Runner: TIRunner); +procedure _OP_ONCREATE_OBJECT(var Runner: TIRunner); +procedure _OP_ONCREATE_HOST_OBJECT(var Runner: TIRunner); +procedure _OP_ONAFTER_OBJECT_CREATION(var Runner: TIRunner); + +procedure _OP_BEFORE_CALL_HOST(var Runner: TIRunner); +procedure _OP_AFTER_CALL_HOST(var Runner: TIRunner); + +procedure _OP_CHECK_PAUSE(var Runner: TIRunner); +procedure _OP_PAUSE(var Runner: TIRunner); + +procedure _OP_GET_ORD_PROP(var Runner: TIRunner); +procedure _OP_GET_SET_PROP(var Runner: TIRunner); +procedure _OP_GET_UNICSTR_PROP(var Runner: TIRunner); +procedure _OP_GET_INTERFACE_PROP(var Runner: TIRunner); +procedure _OP_GET_VARIANT_PROP(var Runner: TIRunner); +procedure _OP_GET_INT64_PROP(var Runner: TIRunner); +procedure _OP_GET_FLOAT_PROP(var Runner: TIRunner); +procedure _OP_GET_EVENT_PROP(var Runner: TIRunner); + +procedure _OP_SET_ORD_PROP(var Runner: TIRunner); +procedure _OP_SET_SET_PROP(var Runner: TIRunner); + +procedure _OP_SET_UNICSTR_PROP(var Runner: TIRunner); +procedure _OP_SET_INTERFACE_PROP(var Runner: TIRunner); +procedure _OP_SET_VARIANT_PROP(var Runner: TIRunner); +procedure _OP_SET_INT64_PROP(var Runner: TIRunner); +procedure _OP_SET_FLOAT_PROP(var Runner: TIRunner); +procedure _OP_SET_EVENT_PROP(var Runner: TIRunner); +procedure _OP_SET_EVENT_PROP2(var Runner: TIRunner); + +procedure _OP_TRY_ON(var Runner: TIRunner); +procedure _OP_TRY_OFF(var Runner: TIRunner); +procedure _OP_BEGIN_EXCEPT_BLOCK(var Runner: TIRunner); +procedure _OP_END_EXCEPT_BLOCK(var Runner: TIRunner); +procedure _OP_COND_RAISE(var Runner: TIRunner); +procedure _OP_EXIT(var Runner: TIRunner); +procedure _OP_HALT(var Runner: TIRunner); +procedure _OP_RAISE(var Runner: TIRunner); + +// js only +procedure _OP_TO_JS_OBJECT(var Runner: TIRunner); +procedure _OP_JS_TYPEOF(var Runner: TIRunner); +procedure _OP_PUSH_CONTEXT(var Runner: TIRunner); +procedure _OP_POP_CONTEXT(var Runner: TIRunner); +procedure _OP_FIND_CONTEXT(var Runner: TIRunner); +procedure _OP_FIND_JS_FUNC(var Runner: TIRunner); +procedure _OP_JS_FUNC_OBJ_FROM_VARIANT(var Runner: TIRunner); +procedure _OP_ADDRESS_PROG(var Runner: TIRunner); +procedure _OP_ASSIGN_PROG(var Runner: TIRunner); +procedure _OP_GET_NEXTJSPROP(var Runner: TIRunner); +procedure _OP_CLEAR_REFERENCES(var Runner: TIRunner); +procedure _OP_CLASS_CLR(var Runner: TIRunner); +procedure _OP_VARIANT_FROM_CLASS(var Runner: TIRunner); +procedure _OP_VARIANT_FROM_POINTER(var Runner: TIRunner); +procedure _OP_CLASS_FROM_VARIANT(var Runner: TIRunner); + +procedure _OP_UNICSTRING_FROM_INT(var Runner: TIRunner); +procedure _OP_UNICSTRING_FROM_DOUBLE(var Runner: TIRunner); +procedure _OP_UNICSTRING_FROM_SINGLE(var Runner: TIRunner); +procedure _OP_UNICSTRING_FROM_EXTENDED(var Runner: TIRunner); +procedure _OP_UNICSTRING_FROM_BOOLEAN(var Runner: TIRunner); + +procedure _OP_OLE_SET(var Runner: TIRunner); +procedure _OP_OLE_GET(var Runner: TIRunner); +procedure _OP_OLE_PARAM(var Runner: TIRunner); + +{$ifdef DRTTI} +procedure _OP_VAR_FROM_TVALUE(var Runner: TIRunner); +procedure _OP_GET_DRTTI_PROP(var Runner: TIRunner); +procedure _OP_SET_DRTTI_PROP(var Runner: TIRunner); +{$endif} + +{$IFNDEF PAXARM} +procedure _OP_ASSIGN_PANSICHAR(var Runner: TIRunner); + +procedure _OP_UNICSTRING_FROM_ANSICHAR(var Runner: TIRunner); +procedure _OP_UNICSTRING_FROM_PANSICHAR(var Runner: TIRunner); +procedure _OP_UNICSTRING_FROM_WIDESTRING(var Runner: TIRunner); +procedure _OP_UNICSTRING_FROM_ANSISTRING(var Runner: TIRunner); +procedure _OP_UNICSTRING_FROM_SHORTSTRING(var Runner: TIRunner); + +procedure _OP_ASSIGN_ANSISTRING(var Runner: TIRunner); +// procedure _OP_PUSH_ANSISTRING = _OP_PUSH_INT +procedure _OP_ANSISTRING_FROM_ANSICHAR(var Runner: TIRunner); +procedure _OP_ANSISTRING_FROM_PANSICHAR(var Runner: TIRunner); +procedure _OP_ANSISTRING_FROM_WIDECHAR(var Runner: TIRunner); +procedure _OP_ANSISTRING_FROM_PWIDECHAR(var Runner: TIRunner); +procedure _OP_ANSISTRING_FROM_WIDESTRING(var Runner: TIRunner); +procedure _OP_ANSISTRING_FROM_UNICSTRING(var Runner: TIRunner); +procedure _OP_ANSISTRING_FROM_SHORTSTRING(var Runner: TIRunner); +procedure _OP_ANSISTRING_FROM_VARIANT(var Runner: TIRunner); +procedure _OP_ADD_ANSISTRING(var Runner: TIRunner); +procedure _OP_GT_ANSISTRING(var Runner: TIRunner); +procedure _OP_GE_ANSISTRING(var Runner: TIRunner); +procedure _OP_LT_ANSISTRING(var Runner: TIRunner); +procedure _OP_LE_ANSISTRING(var Runner: TIRunner); +procedure _OP_EQ_ANSISTRING(var Runner: TIRunner); +procedure _OP_NE_ANSISTRING(var Runner: TIRunner); +procedure _OP_ANSISTRING_CLR(var Runner: TIRunner); + +procedure _OP_ASSIGN_WIDESTRING(var Runner: TIRunner); +// procedure _OP_PUSH_WIDESTRING = _OP_PUSH_INT +procedure _OP_WIDESTRING_FROM_ANSICHAR(var Runner: TIRunner); +procedure _OP_WIDESTRING_FROM_PANSICHAR(var Runner: TIRunner); +procedure _OP_WIDESTRING_FROM_WIDECHAR(var Runner: TIRunner); +procedure _OP_WIDESTRING_FROM_PWIDECHAR(var Runner: TIRunner); +procedure _OP_WIDESTRING_FROM_UNICSTRING(var Runner: TIRunner); +procedure _OP_WIDESTRING_FROM_ANSISTRING(var Runner: TIRunner); +procedure _OP_WIDESTRING_FROM_SHORTSTRING(var Runner: TIRunner); +procedure _OP_WIDESTRING_FROM_VARIANT(var Runner: TIRunner); +procedure _OP_ADD_WIDESTRING(var Runner: TIRunner); +procedure _OP_GT_WIDESTRING(var Runner: TIRunner); +procedure _OP_GE_WIDESTRING(var Runner: TIRunner); +procedure _OP_LT_WIDESTRING(var Runner: TIRunner); +procedure _OP_LE_WIDESTRING(var Runner: TIRunner); +procedure _OP_EQ_WIDESTRING(var Runner: TIRunner); +procedure _OP_NE_WIDESTRING(var Runner: TIRunner); +procedure _OP_WIDESTRING_CLR(var Runner: TIRunner); + +procedure _OP_ASSIGN_SHORTSTRING(var Runner: TIRunner); +// procedure _OP_PUSH_SHORTSTRING = _OP_PUSH_ADDRESS +procedure _OP_SHORTSTRING_FROM_PANSICHAR(var Runner: TIRunner); +procedure _OP_SHORTSTRING_FROM_WIDECHAR(var Runner: TIRunner); +procedure _OP_SHORTSTRING_FROM_PWIDECHAR(var Runner: TIRunner); +procedure _OP_SHORTSTRING_FROM_ANSICHAR(var Runner: TIRunner); +procedure _OP_SHORTSTRING_FROM_UNICSTRING(var Runner: TIRunner); +procedure _OP_SHORTSTRING_FROM_ANSISTRING(var Runner: TIRunner); +procedure _OP_SHORTSTRING_FROM_WIDESTRING(var Runner: TIRunner); +procedure _OP_SHORTSTRING_FROM_VARIANT(var Runner: TIRunner); +procedure _OP_ADD_SHORTSTRING(var Runner: TIRunner); +procedure _OP_GT_SHORTSTRING(var Runner: TIRunner); +procedure _OP_GE_SHORTSTRING(var Runner: TIRunner); +procedure _OP_LT_SHORTSTRING(var Runner: TIRunner); +procedure _OP_LE_SHORTSTRING(var Runner: TIRunner); +procedure _OP_EQ_SHORTSTRING(var Runner: TIRunner); +procedure _OP_NE_SHORTSTRING(var Runner: TIRunner); + +procedure _OP_VARIANT_FROM_ANSICHAR(var Runner: TIRunner); +procedure _OP_VARIANT_FROM_PANSICHAR(var Runner: TIRunner); +procedure _OP_VARIANT_FROM_ANSISTRING(var Runner: TIRunner); +procedure _OP_VARIANT_FROM_WIDESTRING(var Runner: TIRunner); +procedure _OP_VARIANT_FROM_SHORTSTRING(var Runner: TIRunner); + +procedure _OP_GET_ANSISTR_PROP(var Runner: TIRunner); +procedure _OP_GET_WIDESTR_PROP(var Runner: TIRunner); + +procedure _OP_SET_ANSISTR_PROP(var Runner: TIRunner); +procedure _OP_SET_WIDESTR_PROP(var Runner: TIRunner); + +procedure _OP_ANSISTRING_FROM_INT(var Runner: TIRunner); +procedure _OP_ANSISTRING_FROM_DOUBLE(var Runner: TIRunner); +procedure _OP_ANSISTRING_FROM_SINGLE(var Runner: TIRunner); +procedure _OP_ANSISTRING_FROM_EXTENDED(var Runner: TIRunner); +procedure _OP_ANSISTRING_FROM_BOOLEAN(var Runner: TIRunner); + +{$ENDIF} + + +implementation + +uses +{$IFDEF VARIANTS} + Variants, +{$ENDIF} + SysUtils, + TypInfo, + PAXCOMP_CONSTANTS, + PAXCOMP_SYS, + PAXCOMP_TYPES, + PAXINT_SYS, + PAXINT_SEH, + PAXINT_CALL, + PAXCOMP_STDLIB, + PAXCOMP_BASESYMBOL_TABLE, + PAXCOMP_CLASSLST, + PAXCOMP_BASERUNNER, +{$IFDEF DRTTI} + RTTI, + PAXCOMP_2010REG, +{$ENDIF} +{$IFDEF PAXARM_DEVICE} + PAXCOMP_ARM, +{$ENDIF} + PAXCOMP_FRAMEWORK, + PaxInvoke, + PAXCOMP_JavaScript; + + +procedure OperNop(var Runner: TIRunner); +begin + Inc(Runner.N); +end; + +procedure _OP_LOAD_PROC(var Runner: TIRunner); +var + ExtraData: TISubExtraData; +begin with Runner do begin + ExtraData := ExtraDataList[RR.ExtraDataIndex] as TISubExtraData; + ExtraData.PCURunner := _LoadProc(Runner, + RR.A1.Offset, + PChar(LoadIntVal2), // proc name + PChar(LoadIntVal(RR.AR)), // dll name + ExtraData.OverCount); + Inc(N); +end; end; + +procedure _OP_ADD_MESSAGE(var Runner: TIRunner); +begin with Runner do begin + _AddMessage(Runner, LoadIntVal2, PChar(LoadIntVal(RR.AR))); + Inc(N); +end; end; + + +procedure _OP_VARARRAY_GET(var Runner: TIRunner); +var + V: Variant; +begin with Runner do begin + if (VarParamList.Count <> RR.A2.Id) or (RR.A2.Id > 3) then + RaiseError(errInternalError, []); + case RR.A2.Id of + 1: V := Variant(LoadAddress1^) [Variant(VarParamList[0]^)]; + 2: V := Variant(LoadAddress1^) [Variant(VarParamList[0]^), + Variant(VarParamList[1]^)]; + 3: V := Variant(LoadAddress1^) [Variant(VarParamList[0]^), + Variant(VarParamList[1]^), + Variant(VarParamList[2]^)]; + end; + Variant(LoadAddressR^) := V; + + VarParamList.Clear; + Inc(N); +end; end; + +procedure _OP_VARARRAY_PUT(var Runner: TIRunner); +var + V: Variant; +begin with Runner do begin + if (VarParamList.Count <> RR.A2.Id) or (RR.A2.Id > 3) then + RaiseError(errInternalError, []); + V := Variant(LoadAddressR^); + case RR.A2.Id of + 1: Variant(LoadAddress1^)[Variant(VarParamList[0]^)] := V; + 2: Variant(LoadAddress1^)[Variant(VarParamList[0]^), + Variant(VarParamList[1]^)] := V; + 3: Variant(LoadAddress1^)[Variant(VarParamList[0]^), + Variant(VarParamList[1]^), + Variant(VarParamList[2]^)] := V; + end; + + VarParamList.Clear; + Inc(N); +end; end; + +procedure _OP_PUSH_PTR(var Runner: TIRunner); +var + P: Pointer; + Index: Integer; + V: IntPax; + ParamRec: PIParamRec; +begin with Runner do begin + P := LoadAddress1; + Index := RR.A2.Id; + ParamRec := @ TopCallRec.ParamList[Index]; + if TopCallRec.Host then + begin + V := LoadIntVal1; + if not NativeAddress(Pointer(V)) then + begin + P := Pointer(V); + WrapGlobalAddress(P); + ParamRec^.Value.VPointer := P; + P := @ ParamRec^.Value.VPointer; + end; + end; + ParamRec^.Address := P; + Inc(N); +end; end; + +procedure _OP_GET_PROG(var Runner: TIRunner); +begin with Runner do begin + SaveIntVal(IntPax(Runner), RR.AR); + Inc(N); +end; end; + +procedure _OP_ASSIGN_CLASS(var Runner: TIRunner); +begin with Runner do begin + _ClassAssign(LoadAddressR, LoadAddress2); + Inc(N); +end; end; + +procedure _OP_ASSIGN_EVENT(var Runner: TIRunner); +begin with Runner do begin + TMethod(LoadAddress1^) := TMethod(LoadAddress2^); + Inc(N); +end; end; + +procedure _OP_CREATE_EVENT(var Runner: TIRunner); +var + M: TMethod; + P: Pointer; +begin with Runner do begin + M.Data := Pointer(LoadIntVal1); + + if RR.A2.Kind in KindSUBS then + begin + if RR.JMP > 0 then + P := Pointer(RR.JMP) + else + P := LoadAddress2; + end + else + P := LoadAddress2; + + M.Code := P; + + TMethod(LoadAddressR^) := M; + Inc(N); +end; end; + +procedure _OP_CREATE_METHOD(var Runner: TIRunner); +var + M: TMethod; +begin with Runner do begin + M.Data := Pointer(LoadIntVal1); + M.Code := Pointer(LoadIntVal2); + TMethod(LoadAddressR^) := M; + Inc(N); +end; end; + +procedure _OP_PUSH_DATA(var Runner: TIRunner); +var + P: Pointer; + Index: Integer; +begin with Runner do begin + P := ShiftPointer(LoadAddress1, SizeOf(Pointer)); + Index := RR.A2.Id; + if TopCallRec.ParamList[Index].Address <> nil then + TopCallRec.This := P + else + TopCallRec.ParamList[Index].Address := P; + Inc(N); +end; end; + + +procedure _OP_PUSH_ADDRESS(var Runner: TIRunner); +var + P: Pointer; + Index: Integer; +begin with Runner do begin + P := LoadAddress1; + if RR.AR.Id = 0 then + VarParamList.Add(P) + else + begin + Index := RR.A2.Id; + TopCallRec.ParamList[Index].Address := P; + end; + Inc(N); +end; end; + + +procedure _OP_PUSH_INST(var Runner: TIRunner); +var + P: Pointer; +begin with Runner do begin + if TopCallRec.ED.CallMode = cmSTATIC then + TopCallRec.This := nil + else if TopCallRec.ED.IsRecordMethod then + TopCallRec.This := LoadAddress1 + else + begin + P := Pointer(LoadIntVal1); + if TopCallRec.ED.IsShared then + begin + P := Pointer(P^); + {$IFDEF FPC} + P := ShiftPointer(P, FPC_VIRTUAL_OFFSET); + {$ENDIF} + TopCallRec.This := P; + end + else + TopCallRec.This := P; + end; + + if TopCallRec.ED.Kind = KindCONSTRUCTOR then + TopCallRec.DL := 0; + + Inc(N); +end; end; + + +procedure _OP_PUSH_CLSREF(var Runner: TIRunner); +begin with Runner do begin + TopCallRec.This := Pointer(LoadIntVal1); + if TopCallRec.ED.Kind = KindCONSTRUCTOR then + TopCallRec.DL := 1; + Inc(N); +end; end; + +procedure _OP_BEFORE_CALL_HOST(var Runner: TIRunner); +begin with Runner do begin + if Assigned(OnBeforeCallHost) then + OnBeforeCallHost(Owner, RR.A1.Id); + Inc(N); +end; end; + +procedure _OP_AFTER_CALL_HOST(var Runner: TIRunner); +begin with Runner do begin + if Assigned(OnAfterCallHost) then + OnAfterCallHost(Owner, RR.A1.Id); + Inc(N); +end; end; + +procedure _OP_ONCREATE_OBJECT(var Runner: TIRunner); +begin with Runner do begin + if Assigned(OnCreateObject) then + OnCreateObject(Owner, TObject(LoadIntVal1)); + Inc(N); +end; end; + +procedure _OP_ONCREATE_HOST_OBJECT(var Runner: TIRunner); +begin with Runner do begin + if Assigned(OnCreateHostObject) then + OnCreateHostObject(Owner, TObject(LoadIntVal1)); + Inc(N); +end; end; + +procedure _OP_ONAFTER_OBJECT_CREATION(var Runner: TIRunner); +begin with Runner do begin + _OnAfterObjectCreation(Runner, LoadAddress1); + Inc(N); +end; end; + +procedure _OP_ASSIGN_PWIDECHAR(var Runner: TIRunner); +begin + _OP_ASSIGN_INT(Runner); +end; + +// UnicodeString operators ----------------------------------------------------- + +procedure _OP_ASSIGN_UNICSTRING(var Runner: TIRunner); +var + Source, Dest: Pointer; +begin with Runner do begin + Source := LoadAddress2; + Dest := LoadAddressR; + UnicString(Dest^) := UnicString(Source^); + Inc(N); +end; end; + +procedure _OP_UNICSTRING_FROM_WIDECHAR(var Runner: TIRunner); +var + Source: WideChar; + Dest: Pointer; +begin with Runner do begin + Source := WideChar(LoadIntVal2); + Dest := LoadAddress1; + UnicString(Dest^) := UnicString(Source); + Inc(N); +end; end; + +procedure _OP_UNICSTRING_FROM_PWIDECHAR(var Runner: TIRunner); +var + Source: PWideChar; + Dest: Pointer; +begin with Runner do begin + Source := PWideChar(LoadIntVal2); + SaveIntVal(Integer(Source), RR.A1); +// Dest := LoadAddress1; +// UnicString(Dest^) := UnicString(Source); + + Inc(N); +end; end; + +procedure _OP_UNICSTRING_FROM_VARIANT(var Runner: TIRunner); +var + Source: Pointer; + Dest: Pointer; +begin with Runner do begin + Source := LoadAddress2; + Dest := LoadAddress1; + UnicString(Dest^) := Variant(Source^); + Inc(N); +end; end; + +procedure _OP_ADD_UNICSTRING(var Runner: TIRunner); +var + P1, P2, PR: Pointer; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + PR := LoadAddressR; + UnicString(PR^) := UnicString(P1^) + UnicString(P2^); + Inc(N); +end; end; + +procedure _OP_GT_UNICSTRING(var Runner: TIRunner); +var + P1, P2: Pointer; + B: Boolean; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + B := UnicString(P1^) > UnicString(P2^); + SaveIntVal(IntPax(B), RR.AR); + Inc(N); +end; end; + +procedure _OP_GE_UNICSTRING(var Runner: TIRunner); +var + P1, P2: Pointer; + B: Boolean; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + B := UnicString(P1^) >= UnicString(P2^); + SaveIntVal(IntPax(B), RR.AR); + Inc(N); +end; end; + +procedure _OP_LT_UNICSTRING(var Runner: TIRunner); +var + P1, P2: Pointer; + B: Boolean; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + B := UnicString(P1^) < UnicString(P2^); + SaveIntVal(IntPax(B), RR.AR); + Inc(N); +end; end; + +procedure _OP_LE_UNICSTRING(var Runner: TIRunner); +var + P1, P2: Pointer; + B: Boolean; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + B := UnicString(P1^) <= UnicString(P2^); + SaveIntVal(IntPax(B), RR.AR); + Inc(N); +end; end; + +procedure _OP_EQ_UNICSTRING(var Runner: TIRunner); +var + P1, P2: Pointer; + B: Boolean; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + B := UnicString(P1^) = UnicString(P2^); + SaveIntVal(IntPax(B), RR.AR); + Inc(N); +end; end; + +procedure _OP_NE_UNICSTRING(var Runner: TIRunner); +var + P1, P2: Pointer; + B: Boolean; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + B := UnicString(P1^) <> UnicString(P2^); + SaveIntVal(IntPax(B), RR.AR); + Inc(N); +end; end; + +procedure _OP_UNICSTRING_CLR(var Runner: TIRunner); +var + Dest: Pointer; +begin with Runner do begin + Dest := LoadAddress1; + UnicString(Dest^) := ''; + Inc(N); +end; end; + +// Integer operators ----------------------------------------------------------- + +procedure _OP_ASSIGN_INT(var Runner: TIRunner); +var + V: IntPax; +begin with Runner do begin + V := LoadIntVal2; + SaveIntVal(V, RR.A1); + Inc(N); +end; end; + +procedure _OP_ADD_INT(var Runner: TIRunner); +begin with Runner do begin + SaveIntVal(LoadIntVal1 + LoadIntVal2, RR.AR); + Inc(N); +end; end; + +procedure _OP_SUB_INT(var Runner: TIRunner); +begin with Runner do begin + SaveIntVal(LoadIntVal1 - LoadIntVal2, RR.AR); + Inc(N); +end; end; + +procedure _OP_IMUL_INT(var Runner: TIRunner); +begin with Runner do begin + SaveIntVal(LoadIntVal1 * LoadIntVal2, RR.AR); + Inc(N); +end; end; + +procedure _OP_IDIV_INT(var Runner: TIRunner); +begin with Runner do begin + SaveIntVal(LoadIntVal1 div LoadIntVal2, RR.AR); + Inc(N); +end; end; + +procedure _OP_MOD_INT(var Runner: TIRunner); +begin with Runner do begin + SaveIntVal(LoadIntVal1 mod LoadIntVal2, RR.AR); + Inc(N); +end; end; + +procedure _OP_SHL_INT(var Runner: TIRunner); +begin with Runner do begin + SaveIntVal(LoadIntVal1 shl LoadIntVal2, RR.AR); + Inc(N); +end; end; + +procedure _OP_SHR_INT(var Runner: TIRunner); +begin with Runner do begin + SaveIntVal(LoadIntVal1 shr LoadIntVal2, RR.AR); + Inc(N); +end; end; + +procedure _OP_AND_INT(var Runner: TIRunner); +begin with Runner do begin + SaveIntVal(LoadIntVal1 and LoadIntVal2, RR.AR); + Inc(N); +end; end; + +procedure _OP_OR_INT(var Runner: TIRunner); +begin with Runner do begin + SaveIntVal(LoadIntVal1 or LoadIntVal2, RR.AR); + Inc(N); +end; end; + +procedure _OP_XOR_INT(var Runner: TIRunner); +begin with Runner do begin + SaveIntVal(LoadIntVal1 xor LoadIntVal2, RR.AR); + Inc(N); +end; end; + +procedure _OP_NEG_INT(var Runner: TIRunner); +begin with Runner do begin + SaveIntVal(- LoadIntVal1, RR.AR); + Inc(N); +end; end; + +procedure _OP_NOT(var Runner: TIRunner); +begin with Runner do begin + SaveIntVal(IntPax(not LoadIntVal1), RR.AR); + Inc(N); +end; end; + +procedure _OP_NOT_BOOL(var Runner: TIRunner); +var + V: Boolean; +begin with Runner do begin + V := Boolean(LoadIntVal1); + SaveIntVal(IntPax(not V), RR.AR); + Inc(N); +end; end; + +procedure _OP_NOT_BYTEBOOL(var Runner: TIRunner); +var + V: ByteBool; +begin with Runner do begin + V := ByteBool(LoadIntVal1); + SaveIntVal(IntPax(not V), RR.AR); + Inc(N); +end; end; + +procedure _OP_NOT_WORDBOOL(var Runner: TIRunner); +var + V: WordBool; +begin with Runner do begin + V := WordBool(LoadIntVal1); + SaveIntVal(IntPax(not V), RR.AR); + Inc(N); +end; end; + +procedure _OP_NOT_LONGBOOL(var Runner: TIRunner); +var + V: LongBool; +begin with Runner do begin + V := LongBool(LoadIntVal1); + SaveIntVal(IntPax(not V), RR.AR); + Inc(N); +end; end; + +procedure _OP_ABS_INT(var Runner: TIRunner); +begin with Runner do begin + SaveIntVal(Abs(LoadIntVal1), RR.AR); + Inc(N); +end; end; + +procedure _OP_GT_INT(var Runner: TIRunner); +begin with Runner do begin + SaveIntVal(IntPax(LoadIntVal1 > LoadIntVal2), RR.AR); + Inc(N); +end; end; + +procedure _OP_GE_INT(var Runner: TIRunner); +begin with Runner do begin + SaveIntVal(IntPax(LoadIntVal1 >= LoadIntVal2), RR.AR); + Inc(N); +end; end; + +procedure _OP_LT_INT(var Runner: TIRunner); +begin with Runner do begin + SaveIntVal(IntPax(LoadIntVal1 < LoadIntVal2), RR.AR); + Inc(N); +end; end; + +procedure _OP_LE_INT(var Runner: TIRunner); +begin with Runner do begin + SaveIntVal(IntPax(LoadIntVal1 <= LoadIntVal2), RR.AR); + Inc(N); +end; end; + +procedure _OP_EQ_INT(var Runner: TIRunner); +begin with Runner do begin + SaveIntVal(IntPax(LoadIntVal1 = LoadIntVal2), RR.AR); + Inc(N); +end; end; + +procedure _OP_NE_INT(var Runner: TIRunner); +begin with Runner do begin + SaveIntVal(IntPax(LoadIntVal1 <> LoadIntVal2), RR.AR); + Inc(N); +end; end; + +procedure _OP_INT_TO_DOUBLE(var Runner: TIRunner); +var + Source: IntPax; + Dest: Pointer; +begin with Runner do begin + Source := LoadIntVal1; + Dest := LoadAddressR; + Double(Dest^) := Source; + Inc(N); +end; end; + +procedure _OP_INT_TO_SINGLE(var Runner: TIRunner); +var + Source: IntPax; + Dest: Pointer; +begin with Runner do begin + Source := LoadIntVal1; + Dest := LoadAddressR; + Single(Dest^) := Source; + Inc(N); +end; end; + +procedure _OP_INT_TO_EXTENDED(var Runner: TIRunner); +var + Source: IntPax; + Dest: Pointer; +begin with Runner do begin + Source := LoadIntVal1; + Dest := LoadAddressR; + Extended(Dest^) := Source; + Inc(N); +end; end; + +procedure _OP_INT_TO_INT64(var Runner: TIRunner); +var + Source: IntPax; + Dest: Pointer; +begin with Runner do begin + Source := LoadIntVal1; + Dest := LoadAddressR; + Int64(Dest^) := Source; + Inc(N); +end; end; + +procedure _OP_INT_FROM_INT64(var Runner: TIRunner); +var + Source: Pointer; +begin with Runner do begin + Source := LoadAddress2; + SaveIntVal(Int64(Source^), RR.A1); + Inc(N); +end; end; + +procedure _OP_INT_TO_UINT64(var Runner: TIRunner); +var + Source: IntPax; + Dest: Pointer; +begin with Runner do begin + Source := LoadIntVal1; + Dest := LoadAddressR; + UInt64(Dest^) := Source; + Inc(N); +end; end; + +procedure _OP_INT_FROM_UINT64(var Runner: TIRunner); +var + Source: Pointer; +begin with Runner do begin + Source := LoadAddress2; + SaveIntVal(UInt64(Source^), RR.A1); + Inc(N); +end; end; + +// Int64 operators ------------------------------------------------------------- + +procedure _OP_ASSIGN_INT64(var Runner: TIRunner); +var + P1, P2: Pointer; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + Int64(P1^) := Int64(P2^); + Inc(N); +end; end; + +procedure _OP_ADD_INT64(var Runner: TIRunner); +var + P1, P2, PR: Pointer; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + PR := LoadAddressR; + Int64(PR^) := Int64(P1^) + Int64(P2^); + Inc(N); +end; end; + +procedure _OP_SUB_INT64(var Runner: TIRunner); +var + P1, P2, PR: Pointer; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + PR := LoadAddressR; + Int64(PR^) := Int64(P1^) - Int64(P2^); + Inc(N); +end; end; + +procedure _OP_MULT_INT64(var Runner: TIRunner); +var + P1, P2, PR: Pointer; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + PR := LoadAddressR; + Int64(PR^) := Int64(P1^) * Int64(P2^); + Inc(N); +end; end; + +procedure _OP_IDIV_INT64(var Runner: TIRunner); +var + P1, P2, PR: Pointer; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + PR := LoadAddressR; + Int64(PR^) := Int64(P1^) div Int64(P2^); + Inc(N); +end; end; + +procedure _OP_MOD_INT64(var Runner: TIRunner); +var + P1, P2, PR: Pointer; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + PR := LoadAddressR; + Int64(PR^) := Int64(P1^) mod Int64(P2^); + Inc(N); +end; end; + +procedure _OP_SHL_INT64(var Runner: TIRunner); +var + P1, P2, PR: Pointer; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + PR := LoadAddressR; + Int64(PR^) := Int64(P1^) shl Int64(P2^); + Inc(N); +end; end; + +procedure _OP_SHR_INT64(var Runner: TIRunner); +var + P1, P2, PR: Pointer; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + PR := LoadAddressR; + Int64(PR^) := Int64(P1^) shr Int64(P2^); + Inc(N); +end; end; + +procedure _OP_AND_INT64(var Runner: TIRunner); +var + P1, P2, PR: Pointer; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + PR := LoadAddressR; + Int64(PR^) := Int64(P1^) and Int64(P2^); + Inc(N); +end; end; + +procedure _OP_OR_INT64(var Runner: TIRunner); +var + P1, P2, PR: Pointer; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + PR := LoadAddressR; + Int64(PR^) := Int64(P1^) or Int64(P2^); + Inc(N); +end; end; + +procedure _OP_XOR_INT64(var Runner: TIRunner); +var + P1, P2, PR: Pointer; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + PR := LoadAddressR; + Int64(PR^) := Int64(P1^) xor Int64(P2^); + Inc(N); +end; end; + +procedure _OP_NEG_INT64(var Runner: TIRunner); +var + P1, PR: Pointer; +begin with Runner do begin + P1 := LoadAddress1; + PR := LoadAddressR; + Int64(PR^) := - Int64(P1^); + Inc(N); +end; end; + +procedure _OP_ABS_INT64(var Runner: TIRunner); +var + P1, PR: Pointer; +begin with Runner do begin + P1 := LoadAddress1; + PR := LoadAddressR; + Int64(PR^) := Abs(Int64(P1^)); + Inc(N); +end; end; + +procedure _OP_GT_INT64(var Runner: TIRunner); +var + P1, P2: Pointer; + B: Boolean; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + B := Int64(P1^) > Int64(P2^); + SaveIntVal(IntPax(B), RR.AR); + Inc(N); +end; end; + +procedure _OP_GE_INT64(var Runner: TIRunner); +var + P1, P2: Pointer; + B: Boolean; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + B := Int64(P1^) >= Int64(P2^); + SaveIntVal(IntPax(B), RR.AR); + Inc(N); +end; end; + +procedure _OP_LT_INT64(var Runner: TIRunner); +var + P1, P2: Pointer; + B: Boolean; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + B := Int64(P1^) < Int64(P2^); + SaveIntVal(IntPax(B), RR.AR); + Inc(N); +end; end; + +procedure _OP_LE_INT64(var Runner: TIRunner); +var + P1, P2: Pointer; + B: Boolean; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + B := Int64(P1^) <= Int64(P2^); + SaveIntVal(IntPax(B), RR.AR); + Inc(N); +end; end; + +procedure _OP_EQ_INT64(var Runner: TIRunner); +var + P1, P2: Pointer; + B: Boolean; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + B := Int64(P1^) = Int64(P2^); + SaveIntVal(IntPax(B), RR.AR); + Inc(N); +end; end; + +procedure _OP_NE_INT64(var Runner: TIRunner); +var + P1, P2: Pointer; + B: Boolean; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + B := Int64(P1^) <> Int64(P2^); + SaveIntVal(IntPax(B), RR.AR); + Inc(N); +end; end; + +procedure _OP_INT64_TO_DOUBLE(var Runner: TIRunner); +var + Source, Dest: Pointer; +begin with Runner do begin + Source := LoadAddress1; + Dest := LoadAddressR; + Double(Dest^) := Int64(Source^); + Inc(N); +end; end; + +procedure _OP_INT64_TO_SINGLE(var Runner: TIRunner); +var + Source, Dest: Pointer; +begin with Runner do begin + Source := LoadAddress1; + Dest := LoadAddressR; + Single(Dest^) := Int64(Source^); + Inc(N); +end; end; + +procedure _OP_INT64_TO_EXTENDED(var Runner: TIRunner); +var + Source, Dest: Pointer; +begin with Runner do begin + Source := LoadAddress1; + Dest := LoadAddressR; + Extended(Dest^) := Int64(Source^); + Inc(N); +end; end; + +// UInt64 operators ------------------------------------------------------------ + +procedure _OP_ASSIGN_UINT64(var Runner: TIRunner); +var + P1, P2: Pointer; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + UInt64(P1^) := UInt64(P2^); + Inc(N); +end; end; + +procedure _OP_ADD_UINT64(var Runner: TIRunner); +var + P1, P2, PR: Pointer; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + PR := LoadAddressR; + UInt64(PR^) := UInt64(P1^) + UInt64(P2^); + Inc(N); +end; end; + +procedure _OP_SUB_UINT64(var Runner: TIRunner); +var + P1, P2, PR: Pointer; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + PR := LoadAddressR; + UInt64(PR^) := UInt64(P1^) - UInt64(P2^); + Inc(N); +end; end; + +procedure _OP_AND_UINT64(var Runner: TIRunner); +var + P1, P2, PR: Pointer; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + PR := LoadAddressR; + UInt64(PR^) := UInt64(P1^) and UInt64(P2^); + Inc(N); +end; end; + +procedure _OP_OR_UINT64(var Runner: TIRunner); +var + P1, P2, PR: Pointer; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + PR := LoadAddressR; + UInt64(PR^) := UInt64(P1^) or UInt64(P2^); + Inc(N); +end; end; + +procedure _OP_XOR_UINT64(var Runner: TIRunner); +var + P1, P2, PR: Pointer; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + PR := LoadAddressR; + UInt64(PR^) := UInt64(P1^) xor UInt64(P2^); + Inc(N); +end; end; + +procedure _OP_GT_UINT64(var Runner: TIRunner); +var + P1, P2: Pointer; + B: Boolean; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + B := UInt64(P1^) > UInt64(P2^); + SaveIntVal(IntPax(B), RR.AR); + Inc(N); +end; end; + +procedure _OP_GE_UINT64(var Runner: TIRunner); +var + P1, P2: Pointer; + B: Boolean; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + B := UInt64(P1^) >= UInt64(P2^); + SaveIntVal(IntPax(B), RR.AR); + Inc(N); +end; end; + +procedure _OP_LT_UINT64(var Runner: TIRunner); +var + P1, P2: Pointer; + B: Boolean; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + B := UInt64(P1^) < UInt64(P2^); + SaveIntVal(IntPax(B), RR.AR); + Inc(N); +end; end; + +procedure _OP_LE_UINT64(var Runner: TIRunner); +var + P1, P2: Pointer; + B: Boolean; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + B := UInt64(P1^) <= UInt64(P2^); + SaveIntVal(IntPax(B), RR.AR); + Inc(N); +end; end; + +procedure _OP_UINT64_TO_DOUBLE(var Runner: TIRunner); +var + Source, Dest: Pointer; +begin with Runner do begin + Source := LoadAddress1; + Dest := LoadAddressR; + Double(Dest^) := UInt64(Source^); + Inc(N); +end; end; + +procedure _OP_UINT64_TO_SINGLE(var Runner: TIRunner); +var + Source, Dest: Pointer; +begin with Runner do begin + Source := LoadAddress1; + Dest := LoadAddressR; + Single(Dest^) := UInt64(Source^); + Inc(N); +end; end; + +procedure _OP_UINT64_TO_EXTENDED(var Runner: TIRunner); +var + Source, Dest: Pointer; +begin with Runner do begin + Source := LoadAddress1; + Dest := LoadAddressR; + Extended(Dest^) := UInt64(Source^); + Inc(N); +end; end; + +// Double operators ------------------------------------------------------------ + +procedure _OP_ASSIGN_DOUBLE(var Runner: TIRunner); +var + P1, P2: Pointer; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + case RR.A2.FT of + typeDOUBLE: Double(P1^) := Double(P2^); + typeSINGLE: Double(P1^) := Single(P2^); + typeEXTENDED: Double(P1^) := Extended(P2^); + end; + Inc(N); +end; end; + +procedure _OP_ADD_DOUBLE(var Runner: TIRunner); +var + P1, P2, PR: Pointer; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + PR := LoadAddressR; + Double(PR^) := Double(P1^) + Double(P2^); + Inc(N); +end; end; + +procedure _OP_SUB_DOUBLE(var Runner: TIRunner); +var + P1, P2, PR: Pointer; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + PR := LoadAddressR; + Double(PR^) := Double(P1^) - Double(P2^); + Inc(N); +end; end; + +procedure _OP_MUL_DOUBLE(var Runner: TIRunner); +var + P1, P2, PR: Pointer; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + PR := LoadAddressR; + Double(PR^) := Double(P1^) * Double(P2^); + Inc(N); +end; end; + +procedure _OP_DIV_DOUBLE(var Runner: TIRunner); +var + P1, P2, PR: Pointer; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + PR := LoadAddressR; + Double(PR^) := Double(P1^) / Double(P2^); + Inc(N); +end; end; + +procedure _OP_NEG_DOUBLE(var Runner: TIRunner); +var + P1, PR: Pointer; +begin with Runner do begin + P1 := LoadAddress1; + PR := LoadAddressR; + Double(PR^) := - Double(P1^); + Inc(N); +end; end; + +procedure _OP_ABS_DOUBLE(var Runner: TIRunner); +var + P1, PR: Pointer; +begin with Runner do begin + P1 := LoadAddress1; + PR := LoadAddressR; + Double(PR^) := Abs(Double(P1^)); + Inc(N); +end; end; + +procedure _OP_GT_DOUBLE(var Runner: TIRunner); +var + P1, P2: Pointer; + B: Boolean; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + B := Double(P1^) > Double(P2^); + SaveIntVal(IntPax(B), RR.AR); + Inc(N); +end; end; + +procedure _OP_GE_DOUBLE(var Runner: TIRunner); +var + P1, P2: Pointer; + B: Boolean; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + B := Double(P1^) >= Double(P2^); + SaveIntVal(IntPax(B), RR.AR); + Inc(N); +end; end; + +procedure _OP_LT_DOUBLE(var Runner: TIRunner); +var + P1, P2: Pointer; + B: Boolean; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + B := Double(P1^) < Double(P2^); + SaveIntVal(IntPax(B), RR.AR); + Inc(N); +end; end; + +procedure _OP_LE_DOUBLE(var Runner: TIRunner); +var + P1, P2: Pointer; + B: Boolean; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + B := Double(P1^) <= Double(P2^); + SaveIntVal(IntPax(B), RR.AR); + Inc(N); +end; end; + +procedure _OP_EQ_DOUBLE(var Runner: TIRunner); +var + P1, P2: Pointer; + B: Boolean; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + B := Double(P1^) = Double(P2^); + SaveIntVal(IntPax(B), RR.AR); + Inc(N); +end; end; + +procedure _OP_NE_DOUBLE(var Runner: TIRunner); +var + P1, P2: Pointer; + B: Boolean; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + B := Double(P1^) <> Double(P2^); + SaveIntVal(IntPax(B), RR.AR); + Inc(N); +end; end; + +procedure _OP_DOUBLE_TO_SINGLE(var Runner: TIRunner); +var + Source, Dest: Pointer; +begin with Runner do begin + Source := LoadAddress1; + Dest := LoadAddressR; + Single(Dest^) := Double(Source^); + Inc(N); +end; end; + +procedure _OP_DOUBLE_TO_EXTENDED(var Runner: TIRunner); +var + Source, Dest: Pointer; +begin with Runner do begin + Source := LoadAddress1; + Dest := LoadAddressR; + Extended(Dest^) := Double(Source^); + Inc(N); +end; end; + +// Single operators ------------------------------------------------------------ + +procedure _OP_ASSIGN_SINGLE(var Runner: TIRunner); +var + P1, P2: Pointer; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + case RR.A2.FT of + typeDOUBLE: Single(P1^) := Double(P2^); + typeSINGLE: Single(P1^) := Single(P2^); + typeEXTENDED: Single(P1^) := Extended(P2^); + end; + Inc(N); +end; end; + +procedure _OP_ADD_SINGLE(var Runner: TIRunner); +var + P1, P2, PR: Pointer; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + PR := LoadAddressR; + Single(PR^) := Single(P1^) + Single(P2^); + Inc(N); +end; end; + +procedure _OP_SUB_SINGLE(var Runner: TIRunner); +var + P1, P2, PR: Pointer; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + PR := LoadAddressR; + Single(PR^) := Single(P1^) - Single(P2^); + Inc(N); +end; end; + +procedure _OP_MUL_SINGLE(var Runner: TIRunner); +var + P1, P2, PR: Pointer; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + PR := LoadAddressR; + Single(PR^) := Single(P1^) * Single(P2^); + Inc(N); +end; end; + +procedure _OP_DIV_SINGLE(var Runner: TIRunner); +var + P1, P2, PR: Pointer; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + PR := LoadAddressR; + Single(PR^) := Single(P1^) / Single(P2^); + Inc(N); +end; end; + +procedure _OP_NEG_SINGLE(var Runner: TIRunner); +var + P1, PR: Pointer; +begin with Runner do begin + P1 := LoadAddress1; + PR := LoadAddressR; + Single(PR^) := - Single(P1^); + Inc(N); +end; end; + +procedure _OP_ABS_SINGLE(var Runner: TIRunner); +var + P1, PR: Pointer; +begin with Runner do begin + P1 := LoadAddress1; + PR := LoadAddressR; + Single(PR^) := Abs(Single(P1^)); + Inc(N); +end; end; + +procedure _OP_GT_SINGLE(var Runner: TIRunner); +var + P1, P2: Pointer; + B: Boolean; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + B := Single(P1^) > Single(P2^); + SaveIntVal(IntPax(B), RR.AR); + Inc(N); +end; end; + +procedure _OP_GE_SINGLE(var Runner: TIRunner); +var + P1, P2: Pointer; + B: Boolean; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + B := Single(P1^) >= Single(P2^); + SaveIntVal(IntPax(B), RR.AR); + Inc(N); +end; end; + +procedure _OP_LT_SINGLE(var Runner: TIRunner); +var + P1, P2: Pointer; + B: Boolean; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + B := Single(P1^) < Single(P2^); + SaveIntVal(IntPax(B), RR.AR); + Inc(N); +end; end; + +procedure _OP_LE_SINGLE(var Runner: TIRunner); +var + P1, P2: Pointer; + B: Boolean; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + B := Single(P1^) <= Single(P2^); + SaveIntVal(IntPax(B), RR.AR); + Inc(N); +end; end; + +procedure _OP_EQ_SINGLE(var Runner: TIRunner); +var + P1, P2: Pointer; + B: Boolean; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + B := Single(P1^) = Single(P2^); + SaveIntVal(IntPax(B), RR.AR); + Inc(N); +end; end; + +procedure _OP_NE_SINGLE(var Runner: TIRunner); +var + P1, P2: Pointer; + B: Boolean; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + B := Single(P1^) <> Single(P2^); + SaveIntVal(IntPax(B), RR.AR); + Inc(N); +end; end; + +procedure _OP_SINGLE_TO_DOUBLE(var Runner: TIRunner); +var + Source, Dest: Pointer; +begin with Runner do begin + Source := LoadAddress1; + Dest := LoadAddressR; + Double(Dest^) := Single(Source^); + Inc(N); +end; end; + +procedure _OP_SINGLE_TO_EXTENDED(var Runner: TIRunner); +var + Source, Dest: Pointer; +begin with Runner do begin + Source := LoadAddress1; + Dest := LoadAddressR; + Extended(Dest^) := Single(Source^); + Inc(N); +end; end; + +// Extended operators ---------------------------------------------------------- + +procedure _OP_ASSIGN_EXTENDED(var Runner: TIRunner); +var + P1, P2: Pointer; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + case RR.A2.FT of + typeDOUBLE: Extended(P1^) := Double(P2^); + typeSINGLE: Extended(P1^) := Single(P2^); + typeEXTENDED: Extended(P1^) := Extended(P2^); + end; + Inc(N); +end; end; + +procedure _OP_ADD_EXTENDED(var Runner: TIRunner); +var + P1, P2, PR: Pointer; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + PR := LoadAddressR; + Extended(PR^) := Extended(P1^) + Extended(P2^); + Inc(N); +end; end; + +procedure _OP_SUB_EXTENDED(var Runner: TIRunner); +var + P1, P2, PR: Pointer; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + PR := LoadAddressR; + Extended(PR^) := Extended(P1^) - Extended(P2^); + Inc(N); +end; end; + +procedure _OP_MUL_EXTENDED(var Runner: TIRunner); +var + P1, P2, PR: Pointer; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + PR := LoadAddressR; + Extended(PR^) := Extended(P1^) * Extended(P2^); + Inc(N); +end; end; + +procedure _OP_DIV_EXTENDED(var Runner: TIRunner); +var + P1, P2, PR: Pointer; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + PR := LoadAddressR; + Extended(PR^) := Extended(P1^) / Extended(P2^); + Inc(N); +end; end; + +procedure _OP_NEG_EXTENDED(var Runner: TIRunner); +var + P1, PR: Pointer; +begin with Runner do begin + P1 := LoadAddress1; + PR := LoadAddressR; + Extended(PR^) := - Extended(P1^); + Inc(N); +end; end; + +procedure _OP_ABS_EXTENDED(var Runner: TIRunner); +var + P1, PR: Pointer; +begin with Runner do begin + P1 := LoadAddress1; + PR := LoadAddressR; + Extended(PR^) := Abs(Extended(P1^)); + Inc(N); +end; end; + +procedure _OP_GT_EXTENDED(var Runner: TIRunner); +var + P1, P2: Pointer; + B: Boolean; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + B := Extended(P1^) > Extended(P2^); + SaveIntVal(IntPax(B), RR.AR); + Inc(N); +end; end; + +procedure _OP_GE_EXTENDED(var Runner: TIRunner); +var + P1, P2: Pointer; + B: Boolean; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + B := Extended(P1^) >= Extended(P2^); + SaveIntVal(IntPax(B), RR.AR); + Inc(N); +end; end; + +procedure _OP_LT_EXTENDED(var Runner: TIRunner); +var + P1, P2: Pointer; + B: Boolean; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + B := Extended(P1^) < Extended(P2^); + SaveIntVal(IntPax(B), RR.AR); + Inc(N); +end; end; + +procedure _OP_LE_EXTENDED(var Runner: TIRunner); +var + P1, P2: Pointer; + B: Boolean; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + B := Extended(P1^) <= Extended(P2^); + SaveIntVal(IntPax(B), RR.AR); + Inc(N); +end; end; + +procedure _OP_EQ_EXTENDED(var Runner: TIRunner); +var + P1, P2: Pointer; + B: Boolean; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + B := Extended(P1^) = Extended(P2^); + SaveIntVal(IntPax(B), RR.AR); + Inc(N); +end; end; + +procedure _OP_NE_EXTENDED(var Runner: TIRunner); +var + P1, P2: Pointer; + B: Boolean; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + B := Extended(P1^) <> Extended(P2^); + SaveIntVal(IntPax(B), RR.AR); + Inc(N); +end; end; + +procedure _OP_EXTENDED_TO_DOUBLE(var Runner: TIRunner); +var + Source, Dest: Pointer; +begin with Runner do begin + Source := LoadAddress1; + Dest := LoadAddressR; + Double(Dest^) := Extended(Source^); + Inc(N); +end; end; + +procedure _OP_EXTENDED_TO_SINGLE(var Runner: TIRunner); +var + Source, Dest: Pointer; +begin with Runner do begin + Source := LoadAddress1; + Dest := LoadAddressR; + Single(Dest^) := Extended(Source^); + Inc(N); +end; end; + +// Currency operators ---------------------------------------------------------- + +procedure _OP_ASSIGN_CURRENCY(var Runner: TIRunner); +var + P1, P2: Pointer; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + Currency(P1^) := Currency(P2^); + Inc(N); +end; end; + +procedure _OP_ADD_CURRENCY(var Runner: TIRunner); +var + P1, P2, PR: Pointer; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + PR := LoadAddressR; + Currency(PR^) := Currency(P1^) + Currency(P2^); + Inc(N); +end; end; + +procedure _OP_SUB_CURRENCY(var Runner: TIRunner); +var + P1, P2, PR: Pointer; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + PR := LoadAddressR; + Currency(PR^) := Currency(P1^) - Currency(P2^); + Inc(N); +end; end; + +procedure _OP_MUL_CURRENCY(var Runner: TIRunner); +var + P1, P2, PR: Pointer; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + PR := LoadAddressR; + Currency(PR^) := Currency(P1^) * Currency(P2^); + Inc(N); +end; end; + +procedure _OP_DIV_CURRENCY(var Runner: TIRunner); +var + P1, P2, PR: Pointer; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + PR := LoadAddressR; + Currency(PR^) := Currency(P1^) / Currency(P2^); + Inc(N); +end; end; + +procedure _OP_NEG_CURRENCY(var Runner: TIRunner); +var + P1, PR: Pointer; +begin with Runner do begin + P1 := LoadAddress1; + PR := LoadAddressR; + Currency(PR^) := - Currency(P1^); + Inc(N); +end; end; + +procedure _OP_ABS_CURRENCY(var Runner: TIRunner); +var + P1, PR: Pointer; +begin with Runner do begin + P1 := LoadAddress1; + PR := LoadAddressR; + Currency(PR^) := Abs(Currency(P1^)); + Inc(N); +end; end; + +procedure _OP_GT_CURRENCY(var Runner: TIRunner); +var + P1, P2: Pointer; + B: Boolean; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + B := Currency(P1^) > Currency(P2^); + SaveIntVal(IntPax(B), RR.AR); + Inc(N); +end; end; + +procedure _OP_GE_CURRENCY(var Runner: TIRunner); +var + P1, P2: Pointer; + B: Boolean; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + B := Currency(P1^) >= Currency(P2^); + SaveIntVal(IntPax(B), RR.AR); + Inc(N); +end; end; + +procedure _OP_LT_CURRENCY(var Runner: TIRunner); +var + P1, P2: Pointer; + B: Boolean; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + B := Currency(P1^) < Currency(P2^); + SaveIntVal(IntPax(B), RR.AR); + Inc(N); +end; end; + +procedure _OP_LE_CURRENCY(var Runner: TIRunner); +var + P1, P2: Pointer; + B: Boolean; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + B := Currency(P1^) <= Currency(P2^); + SaveIntVal(IntPax(B), RR.AR); + Inc(N); +end; end; + +procedure _OP_EQ_CURRENCY(var Runner: TIRunner); +var + P1, P2: Pointer; + B: Boolean; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + B := Currency(P1^) = Currency(P2^); + SaveIntVal(IntPax(B), RR.AR); + Inc(N); +end; end; + +procedure _OP_NE_CURRENCY(var Runner: TIRunner); +var + P1, P2: Pointer; + B: Boolean; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + B := Currency(P1^) <> Currency(P2^); + SaveIntVal(IntPax(B), RR.AR); + Inc(N); +end; end; + +procedure _OP_CURRENCY_TO_DOUBLE(var Runner: TIRunner); +var + Source, Dest: Pointer; +begin with Runner do begin + Source := LoadAddress2; + Dest := LoadAddressR; + Double(Dest^) := Currency(Source^); + Inc(N); +end; end; + +procedure _OP_CURRENCY_TO_SINGLE(var Runner: TIRunner); +var + Source, Dest: Pointer; +begin with Runner do begin + Source := LoadAddress2; + Dest := LoadAddressR; + Single(Dest^) := Currency(Source^); + Inc(N); +end; end; + +procedure _OP_CURRENCY_TO_EXTENDED(var Runner: TIRunner); +var + Source, Dest: Pointer; +begin with Runner do begin + Source := LoadAddress2; + Dest := LoadAddressR; + Extended(Dest^) := Currency(Source^); + Inc(N); +end; end; + +procedure _OP_CURRENCY_FROM_INT64(var Runner: TIRunner); +var + Source, Dest: Pointer; +begin with Runner do begin + Source := LoadAddress2; + Dest := LoadAddressR; + Currency(Dest^) := Int64(Source^); + Inc(N); +end; end; + +procedure _OP_CURRENCY_FROM_UINT64(var Runner: TIRunner); +var + Source, Dest: Pointer; +begin with Runner do begin + Source := LoadAddress2; + Dest := LoadAddressR; + Currency(Dest^) := UInt64(Source^); + Inc(N); +end; end; + +procedure _OP_CURRENCY_FROM_INT(var Runner: TIRunner); +var + Source: IntPax; + Dest: Pointer; +begin with Runner do begin + Source := LoadIntVal2; + Dest := LoadAddressR; + Currency(Dest^) := Source; + Inc(N); +end; end; + +procedure _OP_CURRENCY_FROM_REAL(var Runner: TIRunner); +var + Source, Dest: Pointer; +begin with Runner do begin + Source := LoadAddress2; + Dest := LoadAddressR; + case RR.A2.FT of + typeDOUBLE: Currency(Dest^) := Double(Source^); + typeSINGLE: Currency(Dest^) := Single(Source^); + typeEXTENDED: Currency(Dest^) := Extended(Source^); + end; + Inc(N); +end; end; + +// Variant operators ----------------------------------------------------------- + +procedure _OP_ASSIGN_VARIANT(var Runner: TIRunner); +begin with Runner do begin + _VariantAssign(LoadAddress1, LoadAddress2); + Inc(N); +end; end; + +procedure _OP_VARIANT_FROM_WIDECHAR(var Runner: TIRunner); +begin with Runner do begin + _VariantFromWideChar(WideChar(LoadIntVal2), LoadAddress1); + Inc(N); +end; end; + +procedure _OP_VARIANT_FROM_PWIDECHAR(var Runner: TIRunner); +begin with Runner do begin + _VariantFromPWideChar(PWideChar(LoadIntVal2), LoadAddress1); + Inc(N); +end; end; + +procedure _OP_VARIANT_FROM_UNICSTRING(var Runner: TIRunner); +begin with Runner do begin + _VariantFromUnicString(LoadAddress1, LoadAddress2); + Inc(N); +end; end; + +procedure _OP_VARIANT_FROM_INT(var Runner: TIRunner); +begin with Runner do begin + _VariantFromInt(LoadIntVal2, LoadAddress1); + Inc(N); +end; end; + +procedure _OP_VARIANT_FROM_INT64(var Runner: TIRunner); +begin with Runner do begin + _VariantFromInt64(LoadAddress1, LoadAddress2); + Inc(N); +end; end; + +procedure _OP_VARIANT_FROM_REAL(var Runner: TIRunner); +var + Source: Pointer; + Dest: Pointer; +begin with Runner do begin + Source := LoadAddress2; + Dest := LoadAddress1; + case RR.A2.FT of + typeDOUBLE: _VariantFromDouble(Dest, Source); + typeSINGLE: _VariantFromSingle(Dest, Source); + typeEXTENDED: _VariantFromExtended(Dest, Source); + end; + Inc(N); +end; end; + +procedure _OP_VARIANT_FROM_CURRENCY(var Runner: TIRunner); +begin with Runner do begin + _VariantFromCurrency(LoadAddress1, LoadAddress2); + Inc(N); +end; end; + +procedure _OP_VARIANT_FROM_INTERFACE(var Runner: TIRunner); +begin with Runner do begin + _VariantFromInterface(IDispatch(LoadIntVal2), LoadAddress1); + Inc(N); +end; end; + +procedure _OP_VARIANT_FROM_BOOL(var Runner: TIRunner); +var + Source: Pointer; + Dest: Pointer; +begin with Runner do begin + Source := LoadAddress2; + Dest := LoadAddress1; + case RR.A2.FT of + typeBOOLEAN: _VariantFromBool(Boolean(Source^), Dest); + typeWORDBOOL: _VariantFromBool(WordBool(Source^), Dest); + typeLONGBOOL: _VariantFromBool(LongBool(Source^), Dest); + end; + Inc(N); +end; end; + +procedure _OP_ADD_VARIANT(var Runner: TIRunner); +begin with Runner do begin + _VariantAddition(RR.Lang, LoadAddress1, LoadAddress2, LoadAddressR); + Inc(N); +end; end; + +procedure _OP_SUB_VARIANT(var Runner: TIRunner); +begin with Runner do begin + _VariantSubtraction(RR.Lang, LoadAddress1, LoadAddress2, LoadAddressR); + Inc(N); +end; end; + +procedure _OP_MULT_VARIANT(var Runner: TIRunner); +begin with Runner do begin + _VariantMultiplication(RR.Lang, LoadAddress1, LoadAddress2, LoadAddressR); + Inc(N); +end; end; + +procedure _OP_DIV_VARIANT(var Runner: TIRunner); +begin with Runner do begin + _VariantDivision(RR.Lang, LoadAddress1, LoadAddress2, LoadAddressR); + Inc(N); +end; end; + +procedure _OP_IDIV_VARIANT(var Runner: TIRunner); +begin with Runner do begin + _VariantIDivision(RR.Lang, LoadAddress1, LoadAddress2, LoadAddressR); + Inc(N); +end; end; + +procedure _OP_NEG_VARIANT(var Runner: TIRunner); +var + P1, PR: Pointer; +begin with Runner do begin + P1 := LoadAddress1; + PR := LoadAddressR; + Variant(PR^) := - Variant(P1^); + Inc(N); +end; end; + +procedure _OP_NOT_VARIANT(var Runner: TIRunner); +var + P1, PR: Pointer; +begin with Runner do begin + P1 := LoadAddress1; + PR := LoadAddressR; + Variant(PR^) := not Variant(P1^); + Inc(N); +end; end; + +procedure _OP_ABS_VARIANT(var Runner: TIRunner); +var + P1, PR: Pointer; +begin with Runner do begin + P1 := LoadAddress1; + PR := LoadAddressR; + Variant(PR^) := Abs(Variant(P1^)); + Inc(N); +end; end; + +procedure _OP_GT_VARIANT(var Runner: TIRunner); +begin with Runner do begin + _VariantGreaterThan(RR.Lang, LoadAddress1, LoadAddress2, LoadAddressR); + Inc(N); +end; end; + +procedure _OP_GE_VARIANT(var Runner: TIRunner); +begin with Runner do begin + _VariantGreaterThanOrEqual(RR.Lang, LoadAddress1, LoadAddress2, LoadAddressR); + Inc(N); +end; end; + +procedure _OP_LT_VARIANT(var Runner: TIRunner); +begin with Runner do begin + _VariantLessThan(RR.Lang, LoadAddress1, LoadAddress2, LoadAddressR); + Inc(N); +end; end; + +procedure _OP_LE_VARIANT(var Runner: TIRunner); +begin with Runner do begin + _VariantLessThanOrEqual(RR.Lang, LoadAddress1, LoadAddress2, LoadAddressR); + Inc(N); +end; end; + +procedure _OP_EQ_VARIANT(var Runner: TIRunner); +begin with Runner do begin + _VariantEquality(RR.Lang, LoadAddress1, LoadAddress2, LoadAddressR); + Inc(N); +end; end; + +procedure _OP_NE_VARIANT(var Runner: TIRunner); +begin with Runner do begin + _VariantNotEquality(RR.Lang, LoadAddress1, LoadAddress2, LoadAddressR); + Inc(N); +end; end; + +procedure _OP_VARIANT_CLR(var Runner: TIRunner); +var + Dest: Pointer; +begin with Runner do begin + Dest := LoadAddress1; + VarClear(Variant(Dest^)); + Inc(N); +end; end; + +// Interface type -------------------------------------------------------------- + +procedure _OP_INTERFACE_FROM_CLASS(var Runner: TIRunner); +begin with Runner do begin + _InterfaceFromClass(LoadAddressR, LoadAddress1, LoadAddress2); + Inc(N); +end; end; + +procedure _OP_INTERFACE_CAST(var Runner: TIRunner); +begin with Runner do begin + _InterfaceCast(LoadAddressR, LoadAddress2, LoadAddress1); + Inc(N); +end; end; + +procedure _OP_INTERFACE_CLR(var Runner: TIRunner); +begin with Runner do begin + IUnknown(LoadAddress1^) := nil; + Inc(N); +end; end; + +// OleVariant operators ----------------------------------------------------------- + +procedure _OP_ASSIGN_OLEVARIANT(var Runner: TIRunner); +var + P1, P2: Pointer; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + OleVariant(P1^) := OleVariant(P2^); + Inc(N); +end; end; + +procedure _OP_OLEVARIANT_FROM_INTERFACE(var Runner: TIRunner); +var + Source: Pointer; + Dest: Pointer; +begin with Runner do begin + Source := LoadAddress2; + Dest := LoadAddress1; + OleVariant(Dest^) := IInterface(Source^); + Inc(N); +end; end; + +// Interface operators --------------------------------------------------------- + +procedure _OP_ASSIGN_INTERFACE(var Runner: TIRunner); +var + P1, P2: Pointer; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + IInterface(P1^) := IInterface(P2^); + Inc(N); +end; end; + +procedure _OP_ASSIGN_TVarRec(var Runner: TIRunner); +var + Source: Pointer; + Dest: PVarRec; + FT: Integer; +begin with Runner do begin + Source := LoadAddress2; + Dest := LoadAddress1; + FT := RR.A2.FT; + _AssignTVarRec(nil, Source, Dest^, FT); + Inc(N); +end; end; + +procedure _OP_ASSIGN_RECORD(var Runner: TIRunner); +var + Source, Dest: Pointer; + Size: Integer; +begin with Runner do begin + Source := LoadAddress2; + Dest := LoadAddress1; + Size := RR.A2.PtrSize; + Move(Source^, Dest^, Size); + Inc(N); +end; end; + +procedure _OP_EQ_STRUCT(var Runner: TIRunner); +var + P1, P2: Pointer; + B: Boolean; +begin with Runner do begin + if RR.A1.PtrSize <> RR.A2.PtrSize then + SaveIntVal(IntPax(false), RR.AR) + else + begin + P1 := LoadAddress1; + P2 := LoadAddress2; + B := CompareMem(P1, P2, RR.A1.PtrSize); + SaveIntVal(IntPax(B), RR.AR); + end; + Inc(N); +end; end; + +procedure _OP_NE_STRUCT(var Runner: TIRunner); +var + P1, P2: Pointer; + B: Boolean; +begin with Runner do begin + if RR.A1.PtrSize <> RR.A2.PtrSize then + SaveIntVal(IntPax(true), RR.AR) + else + begin + P1 := LoadAddress1; + P2 := LoadAddress2; + B := CompareMem(P1, P2, RR.A1.PtrSize); + SaveIntVal(IntPax(not B), RR.AR); + end; + Inc(N); +end; end; + +procedure _OP_DYNARRAY_ASSIGN(var Runner: TIRunner); +var + Source, Dest: Pointer; + FinalTypeID, TypeID, ElSize, + FinalTypeID2, TypeID2, ElSize2: Integer; + ExtraData: TIArrExtraData; + BaseExtraData: TIBaseExtraData; +begin with Runner do begin + ExtraData := ExtraDataList[RR.ExtraDataIndex] as TIArrExtraData; + TypeId := ExtraData.ElTypeId; + FinalTypeId := ExtraData.ElFinTypeId; + ElSize := ExtraData.ElSize; + + FinalTypeID2 := 0; + TypeID2 := 0; + ElSize2 := 0; + if FinalTypeId = typeDYNARRAY then + begin + BaseExtraData := ExtraDataList.Find(TypeId); + if BaseExtraData <> nil then + begin + ExtraData := BaseExtraData as TIArrExtraData; + + TypeId2 := ExtraData.ElTypeId; + FinalTypeId2 := ExtraData.ElFinTypeId; + ElSize2 := ExtraData.ElSize; + end; + end; + + Source := Pointer(LoadAddress2^); + Dest := Pointer(LoadAddress1^); + _DynarrayAssign(Source, Dest, FinalTypeID, TypeID, ElSize, + FinalTypeID2, TypeID2, ElSize2); + SaveIntVal(IntPax(Dest), RR.A1); + Inc(N); +end; end; + +procedure _OP_DYNARRAY_CLR(var Runner: TIRunner); +var + P: Pointer; + FinalTypeID, TypeID, ElSize, + FinalTypeID2, TypeID2, ElSize2: Integer; + ExtraData: TIArrExtraData; + BaseExtraData: TIBaseExtraData; +begin with Runner do begin + ExtraData := ExtraDataList[RR.ExtraDataIndex] as TIArrExtraData; + TypeId := ExtraData.ElTypeId; + FinalTypeId := ExtraData.ElFinTypeId; + ElSize := ExtraData.ElSize; + + FinalTypeID2 := 0; + TypeID2 := 0; + ElSize2 := 0; + if FinalTypeId = typeDYNARRAY then + begin + BaseExtraData := ExtraDataList.Find(TypeId); + if BaseExtraData <> nil then + begin + ExtraData := BaseExtraData as TIArrExtraData; + + TypeId2 := ExtraData.ElTypeId; + FinalTypeId2 := ExtraData.ElFinTypeId; + ElSize2 := ExtraData.ElSize; + end; + end; + + P := Pointer(LoadAddress1^); + _DynarrayClr(P, FinalTypeID, TypeID, ElSize, + FinalTypeID2, TypeID2, ElSize2); + Inc(N); +end; end; + +procedure _OP_CREATE_EMPTY_DYNARRAY(var Runner: TIRunner); +begin with Runner do begin + _CreateEmptyDynarray(Pointer(LoadAddress1^)); + Inc(N); +end; end; + +// Set types ------------------------------------------------------------------- + +procedure _OP_SET_ASSIGN(var Runner: TIRunner); +var + P1, P2: Pointer; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + Move(P2^, P1^, RR.A1.PtrSize); + Inc(N); +end; end; + +procedure _OP_SET_COUNTER_ASSIGN(var Runner: TIRunner); +begin with Runner do begin + SaveIntVal(RR.A2.PtrSize * 8, RR.A1); + Inc(N); +end; end; + +procedure _OP_SET_UNION(var Runner: TIRunner); +var + P1, P2, PR: Pointer; + L: Integer; + Res: TByteSet; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + PR := LoadAddressR; + if RR.A2.PtrSize < RR.A1.PtrSize then + L := RR.A2.PtrSize + else + L := RR.A1.PtrSize; + Res := UpdateSet(TByteSet(P1^), L) + UpdateSet(TByteSet(P2^), L); + Move(Res, PR^, L); + Inc(N); +end; end; + +procedure _OP_SET_DIFFERENCE(var Runner: TIRunner); +var + P1, P2, PR: Pointer; + L: Integer; + Res: TByteSet; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + PR := LoadAddressR; + if RR.A2.PtrSize < RR.A1.PtrSize then + L := RR.A2.PtrSize + else + L := RR.A1.PtrSize; + Res := UpdateSet(TByteSet(P1^), L) - UpdateSet(TByteSet(P2^), L); + Move(Res, PR^, L); + Inc(N); +end; end; + +procedure _OP_SET_INCLUDE(var Runner: TIRunner); +begin with Runner do begin + _SetInclude(PByteSet(LoadAddress1), LoadIntVal2); + Inc(N); +end; end; + +procedure _OP_SET_INCLUDE_INTERVAL(var Runner: TIRunner); +begin with Runner do begin + _SetIncludeInterval(PByteSet(LoadAddress1), LoadIntVal2, LoadIntVal(RR.AR)); + Inc(N); +end; end; + +procedure _OP_SET_INTERSECTION(var Runner: TIRunner); +var + P1, P2, PR: Pointer; + L: Integer; + Res: TByteSet; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + PR := LoadAddressR; + if RR.A2.PtrSize < RR.A1.PtrSize then + L := RR.A2.PtrSize + else + L := RR.A1.PtrSize; + Res := UpdateSet(TByteSet(P1^), L) * UpdateSet(TByteSet(P2^), L); + Move(Res, PR^, L); + Inc(N); +end; end; + +procedure _OP_SET_SUBSET(var Runner: TIRunner); +var + P1, P2: Pointer; + L: Integer; + B: Boolean; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + if RR.A2.PtrSize < RR.A1.PtrSize then + L := RR.A2.PtrSize + else + L := RR.A1.PtrSize; + B := UpdateSet(TByteSet(P1^), L) <= UpdateSet(TByteSet(P2^), L); + SaveIntVal(IntPax(B), RR.AR); + Inc(N); +end; end; + +procedure _OP_SET_SUPERSET(var Runner: TIRunner); +var + P1, P2: Pointer; + L: Integer; + B: Boolean; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + if RR.A2.PtrSize < RR.A1.PtrSize then + L := RR.A2.PtrSize + else + L := RR.A1.PtrSize; + B := UpdateSet(TByteSet(P1^), L) >= UpdateSet(TByteSet(P2^), L); + SaveIntVal(IntPax(B), RR.AR); + Inc(N); +end; end; + +procedure _OP_SET_EQUALITY(var Runner: TIRunner); +var + P1, P2: Pointer; + L: Integer; + B: Boolean; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + if RR.A2.PtrSize < RR.A1.PtrSize then + L := RR.A2.PtrSize + else + L := RR.A1.PtrSize; + B := UpdateSet(TByteSet(P1^), L) = UpdateSet(TByteSet(P2^), L); + SaveIntVal(IntPax(B), RR.AR); + Inc(N); +end; end; + +procedure _OP_SET_INEQUALITY(var Runner: TIRunner); +var + P1, P2: Pointer; + L: Integer; + B: Boolean; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + if RR.A2.PtrSize < RR.A1.PtrSize then + L := RR.A2.PtrSize + else + L := RR.A1.PtrSize; + B := UpdateSet(TByteSet(P1^), L) <> UpdateSet(TByteSet(P2^), L); + SaveIntVal(IntPax(B), RR.AR); + Inc(N); +end; end; + +procedure _OP_SET_MEMBERSHIP(var Runner: TIRunner); +var + P1: Pointer; + value: Integer; + B: Boolean; +begin with Runner do begin + P1 := LoadAddress2; + value := LoadIntVal1; + B := value in TByteSet(P1^); + SaveIntVal(IntPax(B), RR.AR); + Inc(N); +end; end; + +procedure _OP_PRINT_EX(var Runner: TIRunner); +var + P: Pointer; +begin with Runner do begin + P := LoadAddress1; + _PrintEx(Runner, P, KindVAR, RR.A1.FT, 0, 0); + Inc(N); +end; end; + +procedure _OP_GO(var Runner: TIRunner); +begin with Runner do begin + N := RR.JMP; +end; end; + +procedure _OP_GO_DL(var Runner: TIRunner); +begin with Runner do begin + if TopCallRec.DL = 0 then + N := RR.JMP + else + Inc(N); +end; end; + +procedure _OP_GO_FALSE(var Runner: TIRunner); +var + V: IntPax; +begin with Runner do begin + V := LoadIntVal2; + if V = 0 then + N := RR.JMP + else + Inc(N); +end; end; + +procedure _OP_GO_TRUE(var Runner: TIRunner); +var + V: IntPax; +begin with Runner do begin + V := LoadIntVal2; + if V <> 0 then + N := RR.JMP + else + Inc(N); +end; end; + +procedure _OP_BEGIN_CALL(var Runner: TIRunner); +var + ExtraData: TISubExtraData; +begin with Runner do begin + ExtraData := ExtraDataList[RR.ExtraDataIndex] as TISubExtraData; + + TopCallRec := RootCallStack.AddRecord(Runner); + TopCallRec.SubId := ExtraData.Id; + TopCallRec.NP := ExtraData.Count; + + if TopCallRec.SubId = JS_FunctionCallId then + TopCallRec.NP := MAX_JS_PARAM; + + TopCallRec.ED := ExtraData; + + TopCallRec.Host := ExtraData.Host; + + Inc(N); +end; end; + +procedure _OP_GET_VMT_ADDRESS(var Runner: TIRunner); +var + P: Pointer; + ExtraData: TISubExtraData; + C: TClass; + PaxInfo: PPaxInfo; + ClassRec: TClassRec; + DP: TBaseRunner; + MethodIndex: Integer; +begin with Runner do begin + ExtraData := ExtraDataList[RR.ExtraDataIndex] as TISubExtraData; + MethodIndex := ExtraData.MethodIndex; + + P := Pointer(LoadIntVal1); + if RR.A1.FT <> typeCLASSREF then + P := Pointer(P^); + + P := GetVArray(TClass(P)); + + C := P; + if IsPaxClass(C) then + begin + PaxInfo := GetPaxInfo(C); + DP := PaxInfo^.Prog; + ClassRec := DP.ClassList[PaxInfo^.ClassIndex]; + P := Pointer(ClassRec.VirtualMethodEntryList[MethodIndex]); + if P = nil then + begin + P := C; + P := ShiftPointer(P, (MethodIndex - 1) * SizeOf(Pointer)); + P := Pointer(P^); + end; + end + else + begin + P := ShiftPointer(P, (MethodIndex - 1) * SizeOf(Pointer)); + P := Pointer(P^); + end; + SavePointer(P, RR.AR); + Inc(N); +end; end; + +procedure _OP_ADDRESS(var Runner: TIRunner); +var + P: Pointer; +begin with Runner do begin + if RR.A1.Kind in KindSUBS then + begin + if RR.JMP > 0 then + P := Pointer(RR.JMP) + else + P := LoadAddress1; + end + else + P := LoadAddress1; + SaveIntVal(IntPax(P), RR.AR); + Inc(N); +end; end; + +procedure _OP_TYPEINFO(var Runner: TIRunner); +var + pti: PTypeInfo; +begin with Runner do begin + _TypeInfo(Runner, PChar(LoadIntVal2), pti); + SaveIntVal(IntPax(pti), RR.AR); + Inc(N); +end; end; + +procedure _OP_TERMINAL(var Runner: TIRunner); +var + P: Pointer; +begin with Runner do begin + P := Pointer(LoadIntVal1); + SavePointer(P, RR.AR); + Inc(N); +end; end; + +{$IFDEF PAX64} +procedure AssignR15(P: Pointer); assembler; +asm + mov R15, P +end; +{$ENDIF} + +procedure _OP_OLE_GET(var Runner: TIRunner); +var + I, NP, VT: Integer; + ParamRec: TActualParamRec; +{$IFNDEF PAXARM_DEVICE} + Invoke: TPaxInvoke; +{$ENDIF} + P: Pointer; + b: Boolean; + Q, VObject, result: PVariant; + S: String; + E: Extended; + X, Y: TJS_Object; + PropName: PChar; + ExtraData: TISubExtraData; +begin with Runner do begin + ParamRec := OleParamList.Find(RR.A2.Id); + if ParamRec <> nil then + NP := ParamRec.Params.Count + else + NP := 0; + VObject := LoadAddress1; + result := LoadAddressR; + PropName := PChar(LoadIntVal2); + + try + b := JS_IsObject(VObject^); + if not b then + begin + VT := VarType(VObject^); + case VT of + varUString, varString, varOleStr: + begin + S := VObject^; + _JS_ToObject(Runner, @S, typeSTRING, VObject); + b := JS_IsObject(VObject^); + end; + varSmallInt, varInteger, varByte, varShortInt, + varWord, varLongWord: + begin + I := VObject^; + _JS_ToObject(Runner, @I, typeINTEGER, VObject); + b := JS_IsObject(VObject^); + end; + varSingle, varDouble, varCurrency: + begin + E:= VObject^; + _JS_ToObject(Runner, @E, typeEXTENDED, VObject); + b := JS_IsObject(VObject^); + end; + end; + end; + + if b then + begin + case NP of + 0: + begin + X := TJS_Object(TVarData(VObject^).VInteger); + result^ := X.GetProperty(PropName); + + if JS_IsObject(result^) then + begin + Y := TJS_Object(TVarData(result^).VInteger); + if Y is TJS_Function then + (Y as TJS_Function).__this := X; + end; + Exit; + end; + else + begin + X := TJS_Object(TVarData(VObject^).VInteger); + Y := X.GetPropertyAsObject(PropName); + + if Y is TJS_Function then + begin + P := (Y as TJS_Function).InternalFuncAddr; + (Y as TJS_Function).__this := X; + + if NativeAddress(P) then + begin +{$IFNDEF PAXARM_DEVICE} + Invoke := TPaxInvoke.Create(nil); + try + Invoke.Address := P; + Invoke.This := X; + for I := 0 to NP - 1 do + Invoke.AddArgAsPointer(ParamRec.Params[I]); + Invoke.SetResultAsVariant(result); + Invoke.CallConv := ccSTDCALL; + Invoke.CallHost; + finally + FreeAndNil(Invoke); + end; +{$ENDIF} + end + else + begin + TopCallRec := RootCallStack.AddRecord(Runner); + TopCallRec.NCall := N; + + N := IntPax(P); + + ExtraData := ExtraDataList[Records[N].ExtraDataIndex] as TISubExtraData; + + TopCallRec.Host := false; + TopCallRec.SubId := ExtraData.Id; + TopCallRec.NP := ExtraData.Count; + + TopCallRec.ED := ExtraData; + + if RR.AR.Id <> 0 then + begin + TopCallRec.ResAddress := result; + TopCallRec.PtrSize := SizeOf(Variant); + end; + + for I := 0 to TopCallRec.NP - 1 do + begin + if I < NP then + TopCallRec.ParamList[I].Address := ParamRec.Params[I] + else + TopCallRec.ParamList[I].Address := @dummy_params[I]; + end; + + Dec(N); + end; + + Exit; + end + else if NP = 1 then + begin + Q := ParamRec.Params[0]; + VT := TVarData(Q^).VType; + if VT = varString then + result^ := Y.GetProperty(PChar(TVarData(Q^).VString)) + else if VT in VarIntTypes then + result^ := Y.GetArrProperty(TVarData(Q^).VInteger) + else + result^ := Y.GetVarProperty(JS_ToString(Q^)); + end; + end; + end; + + Exit; + end; + + {$IFDEF PAX64} + if ParamRec <> nil then + AssignR15(ParamRec.Params); + GetOlePropProc(VObject^, PropName, result^, NP); + Exit; + {$ENDIF} + + P := @ GetOlePropProc; + if P = nil then + Exit; +{$IFNDEF PAXARM_DEVICE} + Invoke := TPaxInvoke.Create(nil); + try + Invoke.Address := P; + Invoke.AddArgAsPointer(VObject); + Invoke.AddArgAsPointer(Pointer(PropName)); + Invoke.AddArgAsPointer(result); + Invoke.AddArgAsInteger(NP); + for I := 0 to NP - 1 do + Invoke.AddArgAsPointer(ParamRec.Params[I]); + Invoke.CallConv := ccSTDCALL; + Invoke.CallHost; + finally + FreeAndNil(Invoke); + end; +{$ENDIF} + finally + if ParamRec <> nil then + OleParamList.Remove(RR.A2.Id); + Inc(N); + end; +end; end; + +procedure _OP_OLE_PARAM(var Runner: TIRunner); +begin with Runner do begin + OleParamList.Add(RR.AR.Id, LoadAddress1); + Inc(N); +end; end; + +procedure _OP_OLE_SET(var Runner: TIRunner); +var + I, NP, VT: Integer; + ParamRec: TActualParamRec; +{$IFNDEF PAXARM_DEVICE} + Invoke: TPaxInvoke; +{$ENDIF} + P: Pointer; + Q, VObject, value: PVariant; + PropName: PChar; + X: TJS_Object; +begin with Runner do begin + ParamRec := OleParamList.Find(RR.A2.Id); + if ParamRec <> nil then + NP := ParamRec.Params.Count + else + NP := 0; + VObject := LoadAddress1; + value := LoadAddressR; + PropName := PChar(LoadIntVal2); + + try + if JS_IsObject(VObject^) then + begin + case NP of + 0: + begin + X := TJS_Object(TVarData(VObject^).VInteger); + X.PutProperty(PropName, value^); + end; + 1: + begin + Q := ParamRec.Params[0]; + X := TJS_Object(TVarData(VObject^).VInteger); + X := X.GetPropertyAsObject(PropName); + VT := TVarData(Q^).VType; + if VT = varString then + X.PutProperty(PChar(TVarData(Q^).VString), Value^) + else if VT in VarIntTypes then + X.PutArrProperty(TVarData(Q^).VInteger, Value^) + else + X.PutVarProperty(JS_ToString(Variant(Q^)), Value^); + end; + end; + Exit; + end; + + P := @ PutOlePropProc; + if P = nil then + Exit; + + {$IFDEF PAX64} + if ParamRec <> nil then + AssignR15(ParamRec.Params); + PutOlePropProc(VObject^, PropName, value^, NP); + Exit; + {$ENDIF} + +{$IFNDEF PAXARM_DEVICE} + Invoke := TPaxInvoke.Create(nil); + try + Invoke.Address := P; + Invoke.AddArgAsPointer(VObject); + Invoke.AddArgAsPointer(Pointer(PropName)); + Invoke.AddArgAsPointer(value); + Invoke.AddArgAsInteger(NP); + for I := 0 to NP - 1 do + Invoke.AddArgAsPointer(ParamRec.Params[I]); + Invoke.CallConv := ccSTDCALL; + Invoke.CallHost; + finally + FreeAndNil(Invoke); + end; +{$ENDIF} + + finally + if ParamRec <> nil then + OleParamList.Remove(RR.A2.Id); + Inc(N); + end; +end; end; + +procedure _OP_CALL(var Runner: TIRunner); + + function TypeIdToPTI(T, Size: Integer): PTypeInfo; + begin + result := nil; + case T of + typeWIDECHAR: result := TypeInfo(Char); + typeBOOLEAN: result := TypeInfo(Boolean); + typeBYTEBOOL: result := TypeInfo(ByteBool); + typeWORDBOOL: result := TypeInfo(WordBool); + typeLONGBOOL: result := TypeInfo(LongBool); + typeBYTE: result := TypeInfo(Byte); + typeSMALLINT: result := TypeInfo(SmallInt); + typeSHORTINT: result := TypeInfo(ShortInt); + typeWORD: result := TypeInfo(Word); + typeCARDINAL: result := TypeInfo(Cardinal); + typeINTEGER: result := TypeInfo(Integer); + typeINT64: result := TypeInfo(Int64); + typeUINT64: result := TypeInfo(UInt64); + typeSINGLE: result := TypeInfo(Single); + typeDOUBLE: result := TypeInfo(Double); + typeEXTENDED: result := TypeInfo(Extended); + typeCURRENCY: result := TypeInfo(Currency); + typeSTRING: result := TypeInfo(String); + typeVARIANT: result := TypeInfo(Variant); + typeOLEVARIANT: result := TypeInfo(OleVariant); +{$IFDEF DRTTI} + typePOINTER: result := TypeInfo(Pointer); + typePROC: result := TypeInfo(Pointer); + typeEVENT: result := TypeInfo(TNotifyEvent); + typeDYNARRAY, typeOPENARRAY: result := TypeInfo(DynarrayInteger); + typeRECORD: + if Size <= 4 then + result := TypeInfo(TRecord4) + else + result := TypeInfo(TRecord8); + typeARRAY: + if Size <= 4 then + result := TypeInfo(TArray4) + else + result := TypeInfo(TArray8); + typeSET: + case Size of + 1: result := TypeInfo(TSet1); + 2: result := TypeInfo(TSet2); + 4: result := TypeInfo(TSet4); + 8: result := TypeInfo(TSet8); + end; + typeCLASSREF: result := TypeInfo(TClass); +{$ENDIF} + typeCLASS: result := TypeInfo(TObject); + typeINTERFACE: result := TypeInfo(IUnknown); + typeENUM: result := TypeInfo(Byte); + end; + end; +var +{$IFDEF PAXARM_DEVICE} + V: TValue; + Args: TArray; + ByRefs: TArray; + pti: PTypeInfo; + cc: TCallConv; + VDouble: Double; + IsConstructor, + IsStatic: Boolean; + K: Integer; +{$ELSE} + Invoke: TPaxInvoke; +{$ENDIF} + I, H: Integer; + PParamDescRec: PIParamDescRec; + P, Q: Pointer; + ExtraData: TISubExtraData; + Dest, Address: Pointer; + b1, b2: Boolean; + SubId, MethodIndex: Integer; +{$IFNDEF PAXARM} + SS: ShortString; + S: String; +{$ENDIF} + ResRunner: TIRunner; +begin with Runner do begin + ExtraData := ExtraDataList[RR.ExtraDataIndex] as TISubExtraData; + TopCallRec.NCall := N; + + if RR.A1.Id = JS_FunctionCallId then + begin + CallJavaScriptFunction; + Exit; + end; + + b1 := false; + b2 := false; + + if RR.A1.Kind in KindSUBS then + begin + if ExtraData.IsInterfaceMethod then + begin + +//{$IFDEF RNLD} + if ExtraData.Host then + Address := LoadAddress1 + else + Address := nil; + + if Address = nil then +//{$ENDIF} + + begin + MethodIndex := ExtraData.MethodIndex; + + P := TopCallRec.This; + P := Pointer(P^); + // address of interface table + Q := ShiftPointer(P, (MethodIndex - 1) * SizeOf(Pointer)); + Address := Pointer(Q^); + + if NativeAddress(Address) then + begin + b1 := true; + b2 := false; + end; + end; + end + else + Address := LoadAddress1; + end + else + begin + Address := Pointer(LoadIntVal1); + if not NativeAddress(Address) then + begin + I := Abs(IntPax(Address)); + if ExtraData.PCURunner = nil then + begin + SubId := Records[I].A1.Id; + RR.ExtraDataIndex := ExtraDataList.IndexOf(SubId); + ExtraData := ExtraDataList[RR.ExtraDataIndex] as TISubExtraData; + TopCallRec.SubId := SubId; + RR.JMP := I; + end; + b2 := true; + end + else + b1 := true; + end; + + if ExtraData.CallMode = cmSTATIC then + TopCallRec.This := nil; + + UpdateAddress(Address, Pointer(2)); + + if (ExtraData.Host or b1) and (not b2) then + begin +{$IFDEF PAXARM_DEVICE} + + if TopCallRec.This = nil then + begin + SetLength(Args, TopCallRec.NP); + SetLength(ByRefs, TopCallRec.NP); + + for I := 0 to TopCallRec.NP - 1 do + begin + PParamDescRec := @ExtraData.ParamDescList[I]; + P := TopCallRec.ParamList[I].Address; + pti := TypeIdToPTI(PParamDescRec^.FT, PParamDescRec^.PtrSize); + TValue.Make(P, pti, Args[I]); + ByRefs[I] := PParamDescRec^.ByRef; + end; + + pti := TypeIdToPTI(TopCallRec.ED.FT, TopCallRec.ED.ResSize); + + cc := ccReg; + case TopCallRec.ED.CallConv of + ccSTDCALL: cc := TypInfo.ccStdCall; + ccCDECL: cc := TypInfo.ccCdecl; + ccPASCAL: cc := TypInfo.ccPascal; + ccSAFECALL: cc := TypInfo.ccSafeCall; + end; + + V := PAXCOMP_ARM.Invoke( Address, + Args, + ByRefs, + ccReg, + Pti, + true, + false); + + + for I := 0 to TopCallRec.NP - 1 do + begin + PParamDescRec := @ExtraData.ParamDescList[I]; + if PParamDescRec^.ByRef then + begin + P := TopCallRec.ParamList[I].Address; + _VarFromTValue(@Args[I], PParamDescRec^.FT, P); + end; + end; + + if RR.AR.Id <> 0 then + begin + P := LoadAddressR; + _VarFromTValue(@V, TopCallRec.ED.FT, P); + end; + + N := TopCallRec.NCall + 1; + TopCallRec := RootCallStack.Pop; + + Exit; + end + else + begin + if RR.A1.Id = Id_TObject_ClassName then + begin + P := LoadAddressR; + if Dest <> nil then + String(P^) := TObject(TopCallRec.This).ClassName; + N := TopCallRec.NCall + 1; + TopCallRec := RootCallStack.Pop; + Exit; + end; + + IsConstructor := ExtraData.Kind = KindCONSTRUCTOR; + IsStatic := ExtraData.CallMode = cmSTATIC; + + if IsConstructor then + begin + K := 2; + + SetLength(Args, TopCallRec.NP + K); + SetLength(ByRefs, TopCallRec.NP + K); + + if Records[N].Op = OP_CALL_INHERITED then + begin + Args[0] := TObject(TopCallRec.This); + Args[1] := 0; + end + else + begin + Args[0] := TopCallRec.This; + Args[1] := 1; + end; + end + else + begin + K := 1; + + SetLength(Args, TopCallRec.NP + K); + SetLength(ByRefs, TopCallRec.NP + K); + + if ExtraData.IsShared then + Args[0] := TopCallRec.This + else + begin + if ExtraData.IsInterfaceMethod then + Args[0] := TopCallRec.This + else if ExtraData.IsRecordMethod then + Args[0] := TopCallRec.This + else + Args[0] := TObject(TopCallRec.This); + end; + end; + + for I := 0 to TopCallRec.NP - 1 do + begin + PParamDescRec := @ExtraData.ParamDescList[I]; + P := TopCallRec.ParamList[I].Address; + pti := TypeIdToPTI(PParamDescRec^.FT, PParamDescRec^.PtrSize); + TValue.Make(P, pti, Args[I+K]); + ByRefs[I+K] := PParamDescRec^.ByRef; + end; + + pti := TypeIdToPTI(TopCallRec.ED.FT, TopCallRec.ED.ResSize); + + cc := ccReg; + case TopCallRec.ED.CallConv of + ccSTDCALL: cc := TypInfo.ccStdCall; + ccCDECL: cc := TypInfo.ccCdecl; + ccPASCAL: cc := TypInfo.ccPascal; + ccSAFECALL: cc := TypInfo.ccSafeCall; + end; + + V := PAXCOMP_ARM.Invoke( Address, + Args, + ByRefs, + ccReg, + Pti, + IsStatic, + IsConstructor); + + if ExtraData.Kind = KindDESTRUCTOR then + FillChar(Args[0], SizeOf(Args[0]), 0); + + for I := 0 to TopCallRec.NP - 1 do + begin + PParamDescRec := @ExtraData.ParamDescList[I]; + if PParamDescRec^.ByRef then + begin + P := TopCallRec.ParamList[I].Address; + _VarFromTValue(@Args[I+K], PParamDescRec^.FT, P); + end; + end; + + if RR.AR.Id <> 0 then + if TopCallRec.ED.FT <> typeVOID then + begin + P := LoadAddressR; + _VarFromTValue(@V, TopCallRec.ED.FT, P); + end; + + N := TopCallRec.NCall + 1; + TopCallRec := RootCallStack.Pop; + + Exit; + end; + +{$ELSE} + + if N = 1485 then + N := N; + + Invoke := TPaxInvoke.Create(nil); + Invoke.Fake := ExtraData.IsFakeMethod; + if ExtraData.RunnerParam then + Invoke.base_invoke.RunnerParam := Runner.Owner; + + try + if ExtraData.Kind = KindCONSTRUCTOR then + begin + Invoke.base_invoke.IsConstructor := true; +{$IFDEF FPC} + if Records[N].Op = OP_CALL_INHERITED then + begin + Invoke.AddArgAsPointer(TopCallRec.This); + Invoke.AddArgAsPointer(0); + TopCallRec.This:= nil; + end + else + Invoke.AddArgAsInteger(0); +{$ELSE} + if Records[N].Op = OP_CALL_INHERITED then + Invoke.AddArgAsInteger(0) + else + Invoke.AddArgAsInteger(1); +{$ENDIF} + end; + + if TopCallRec.ED.PushProgRequired then + Invoke.AddArgAsObject(Runner); + + for I := 0 to TopCallRec.NP - 1 do + begin + PParamDescRec := @ExtraData.ParamDescList[I]; + + P := TopCallRec.ParamList[I].Address; + if PParamDescRec^.ByRef then + begin + Invoke.AddArgAsPointer(P); + end + else + case PParamDescRec^.FT of +{$IFNDEF PAXARM} + typeANSICHAR: Invoke.AddArgAsByte(Byte(P^)); + typeANSISTRING: Invoke.AddArgAsAnsiString(AnsiString(P^)); + typeWIDESTRING: Invoke.AddArgAsWideString(WideString(P^)); + typeSHORTSTRING: Invoke.AddArgAsShortString(ShortString(P^)); +{$ENDIF} + typeWIDECHAR: Invoke.AddArgAsWord(Word(P^)); + typeENUM: Invoke.AddArgAsByte(Byte(P^)); + typeBOOLEAN: Invoke.AddArgAsBoolean(Boolean(P^)); + typeWORDBOOL: Invoke.AddArgAsWord(Word(P^)); + typeLONGBOOL: Invoke.AddArgAsCardinal(Cardinal(P^)); + typeBYTE: Invoke.AddArgAsByte(Byte(P^)); + typeWORD: Invoke.AddArgAsWord(Word(P^)); + typeSHORTINT: Invoke.AddArgAsShortInt(ShortInt(P^)); + typeSMALLINT: Invoke.AddArgAsSmallInt(SmallInt(P^)); + typeCARDINAL: Invoke.AddArgAsCardinal(Cardinal(P^)); + typeINTEGER: Invoke.AddArgAsInteger(Integer(P^)); + typeINT64: Invoke.AddArgAsInt64(Int64(P^)); + typeUINT64: Invoke.AddArgAsUInt64(UInt64(P^)); + typeCLASS: Invoke.AddArgAsObject(TObject(P^)); + typeCLASSREF: Invoke.AddArgAsClassRef(TClass(P^)); + typePOINTER: Invoke.AddArgAsPointer(Pointer(P^)); + typePROC: Invoke.AddArgAsPointer(Pointer(P^)); + typeEVENT: Invoke.AddArgAsEvent(TMethod(P^)); +{$IFDEF UNIC} + typeUNICSTRING: Invoke.AddArgAsUnicString(UnicString(P^)); +{$ENDIF} + typeVARIANT: Invoke.AddArgAsVariant(Variant(P^)); + typeOLEVARIANT: Invoke.AddArgAsVariant(Variant(P^)); + typeDOUBLE: Invoke.AddArgAsDouble(Double(P^)); + typeSINGLE: Invoke.AddArgAsSingle(Single(P^)); + typeEXTENDED: Invoke.AddArgAsExtended(Extended(P^)); + typeCURRENCY: Invoke.AddArgAsCurrency(Currency(P^)); + typeINTERFACE: Invoke.AddArgAsInterface(IInterface(P^)); + typeRECORD, typeARRAY: + begin + Invoke.AddArgAsRecord(P, TopCallRec.ParamList[I].Size); + end; + typeDYNARRAY, typeOPENARRAY: + begin + Invoke.AddArgAsPointer(Pointer(P^)); + if ExtraData.ParamDescList[I].IsOpenArray then + begin + H := _DynarrayLength(Pointer(P^)) - 1; + Invoke.AddArgAsInteger(H); + end; + end; + end; + end; + Invoke.This := TopCallRec.This; + Invoke.CallConv := TopCallRec.ED.CallConv; + + Dest := LoadAddressR; + + if ExtraData.Kind = KindCONSTRUCTOR then + Invoke.SetResultAsObject + else + begin + case TopCallRec.ED.FT of + typeBYTE, typeBOOLEAN, +{$IFNDEF PAXARM} + typeANSICHAR, +{$ENDIF} + typeBYTEBOOL: Invoke.SetResultAsByte; + typeWORD, typeWIDECHAR, typeWORDBOOL: Invoke.SetResultAsWord; + typeCARDINAL, typeLONGBOOL: Invoke.SetResultAsCardinal; + typeSMALLINT: Invoke.SetResultAsSmallInt; + typeSHORTINT: Invoke.SetResultAsShortInt; + typeINTEGER: Invoke.SetResultAsInteger; + typeINT64: Invoke.SetResultAsInt64; + typeUINT64: Invoke.SetResultAsUInt64; +// typeSET: Invoke.SetResultAsSet; +{$IFDEF ARC} + typeCLASS: Invoke.SetResultAsObject(Dest); +{$ELSE} + typeCLASS: Invoke.SetResultAsObject; +{$ENDIF} + typeCLASSREF: Invoke.SetResultAsClassRef; + typePOINTER, typePROC: Invoke.SetResultAsPointer; +{$IFNDEF PAXARM} + typeANSISTRING: Invoke.SetResultAsAnsiString(Dest); + typeWIDESTRING: Invoke.SetResultAsWideString(Dest); + typeSHORTSTRING: Invoke.SetResultAsShortString(Dest); +{$ENDIF} + typeUNICSTRING: Invoke.SetResultAsUnicodeString(Dest); + typeVARIANT: Invoke.SetResultAsVariant(Dest); + typeOLEVARIANT: Invoke.SetResultAsVariant(Dest); + typeDOUBLE: Invoke.SetResultAsDouble; + typeSINGLE: Invoke.SetResultAsSingle; + typeEXTENDED: Invoke.SetResultAsExtended; + typeCURRENCY: Invoke.SetResultAsCurrency; + typeDYNARRAY, typeOPENARRAY: Invoke.SetResultAsDynArray(Dest); + typeINTERFACE: Invoke.SetResultAsInterface(Dest); + typeEVENT: Invoke.SetResultAsEvent(Dest); + typeRECORD: Invoke.SetResultAsRecord(RR.AR.PtrSize, Dest); + typeARRAY: Invoke.SetResultAsArray(RR.AR.PtrSize, Dest); + end; + end; + + P := nil; + if RR.A1.Id = Id_TObject_ClassName then + begin +{$IFDEF PAXARM} + if Dest <> nil then + String(Dest^) := TObject(TopCallRec.This).ClassName; +{$ELSE} + if Dest <> nil then + begin + S := TObject(TopCallRec.This).ClassName; + SS := ShortString(S); + ShortString(Dest^) := SS; + end; +{$ENDIF} + end + else + begin + Invoke.Address := Address; + Invoke.CallHost; + P := Invoke.GetResultPtr; + end; + + if RR.AR.Id <> 0 then + begin + if ExtraData.Kind = KindCONSTRUCTOR then + begin + SaveIntVal(IntPax(P^), RR.AR); + end + else + begin + Dest := LoadAddressR; + case TopCallRec.ED.FT of + typeDOUBLE: + Double(Dest^) := Double(P^); + typeSINGLE: + Single(Dest^) := Single(P^); + typeEXTENDED: + Extended(Dest^) := Extended(P^); + typeCURRENCY: + Currency(Dest^) := Currency(P^); + typeEVENT: + TMethod(Dest^) := TMethod(P^); + else + if TopCallRec.ED.FT in IntTypes then + begin + Move(P^, Dest^, TopCallRec.ED.ResSize); + end; + end; + end; + end; + + finally + N := TopCallRec.NCall + 1; + + FreeAndNil(Invoke); + TopCallRec := RootCallStack.Pop; + end; +{$ENDIF} + end + else + begin + TopCallRec.Host := false; + + if RR.AR.Id > 0 then + begin + TopCallRec.ResAddress := LoadAddressR; + TopCallRec.PtrSize := RR.AR.PtrSize; + end; + if ExtraData.PCURunner <> nil then + begin + TopCallRec.NCall := N; + + ResRunner := TIRunner(ExtraData.PCURunner); + + if not NativeAddress(Address) then + ResRunner.N := Abs(IntPax(Address)) + else + ResRunner.N := IntPax(Address^); + + TopCallRec.SubId := ResRunner[ResRunner.N].A1.Id; + ResRunner.TopCallRec := TopCallRec; + + Runner := ResRunner; + end + else + begin + N := RR.JMP; + end; + end; +end; end; + +procedure _OP_INIT_SUB(var Runner: TIRunner); +var + I: Integer; + PParamDescRec: PIParamDescRec; + Offset: Integer; + PtrSize, H: Integer; + P, DestPtr: Pointer; + ExtraData: TISubExtraData; +begin with Runner do begin + ExtraData := ExtraDataList[RR.ExtraDataIndex] as TISubExtraData; + TopCallRec.ResOffset := ExtraData.ResOffset; + TopCallRec.ResByRef := ExtraData.ResByRef; + TopCallRec.LocalSize := ExtraData.LocalSize; + TopCallRec.LocalFrame := AllocMem(TopCallRec.LocalSize + EXTRA_LOCAL_SIZE); + +{$IFDEF PAX64} + TopCallRec.ROffset := IntPax(TopCallRec.LocalFrame); +{$ELSE} + TopCallRec.ROffset := IntPax(TopCallRec.LocalFrame) + + TopCallRec.LocalSize; +{$ENDIF} + + for I := 0 to TopCallRec.NP - 1 do + begin + PParamDescRec := @ExtraData.ParamDescList[I]; + Offset := PParamDescRec^.Offset; + P := TopCallRec.ParamList[I].Address; + + DestPtr := Pointer(TopCallRec.ROffset + Offset); + + if PParamDescRec^.ByRef then + Pointer(DestPtr^) := P + else + begin + if PParamDescRec^.FT in IntTypes then + begin + PtrSize := PParamDescRec^.PtrSize; + Move(P^, DestPtr^, PtrSize); + end + else + case PParamDescRec^.FT of + typeDYNARRAY, typeOPENARRAY, typeINTERFACE, typePROC, typeCLASS: + begin + Pointer(DestPtr^) := Pointer(P^); + if PParamDescRec^.IsOpenArray then + begin + H := _DynarrayLength(Pointer(P^)) - 1; + DestPtr := Pointer(TopCallRec.ROffset + PParamDescRec^.HighOffset); + Integer(DestPtr^) := H; + end; + end; +{$IFNDEF PAXARM} + typeANSISTRING: Pointer(DestPtr^) := + Pointer(P^); + typeWIDESTRING: Pointer(DestPtr^) := + Pointer(P^); + typeSHORTSTRING: ShortString(DestPtr^) := + ShortString(P^); +{$ENDIF} + typeUNICSTRING: Pointer(DestPtr^) := Pointer(P^); + typeSINGLE: Single(DestPtr^) := Single(P^); + typeDOUBLE: Double(DestPtr^) := Double(P^); + typeEXTENDED: Extended(DestPtr^) := Extended(P^); + typeCURRENCY: Currency(DestPtr^) := Currency(P^); + typeVARIANT: _VariantAssign(P, DestPtr); + typeOLEVARIANT: OleVariant(DestPtr^) := OleVariant(P^); + typeEVENT: TMethod(DestPtr^) := TMethod(P^); + end; + end; + end; + + if TopCallRec.ResByRef then + begin + P := Pointer(TopCallRec.ROffset + TopCallRec.ResOffset); + Pointer(P^) := TopCallRec.ResAddress; + end; + + if RR.A2.Id > 0 then + SavePointer(TopCallRec.This, RR.A2); + Inc(N); +end; end; + +procedure _OP_END_SUB(var Runner: TIRunner); +var + P, Q: Pointer; +begin with Runner do begin + Runner := TopCallRec.Runner; + Runner.N := TopCallRec.NCall + 1; + + if not TopCallRec.ResByRef then + begin + P := Pointer(TopCallRec.ROffset + TopCallRec.ResOffset); + Q := TopCallRec.ResAddress; + if TopCallRec.ED.FT in IntTypes then + begin + Move(P^, Q^, TopCallRec.PtrSize); + end +{$IFDEF ARC} + else if TopCallRec.ED.Kind = KindCONSTRUCTOR then + begin + if Q <> nil then + begin + TObject(Q^) := TObject(P^); + TObject(P^) := nil; + end; + end +{$ENDIF} + else + begin + case TopCallRec.ED.FT of + typeSINGLE: Single(Q^) := Single(P^); + typeDOUBLE: Double(Q^) := Double(P^); + typeEXTENDED: Extended(Q^) := Extended(P^); + typeCURRENCY: Currency(Q^) := Currency(P^); + end; + end; + end; + + Runner.TopCallRec := RootCallStack.Pop; +end; end; + +procedure _OP_PUSH_INT(var Runner: TIRunner); +var + P: Pointer; + Index: Integer; +begin with Runner do begin + P := LoadAddress1; + Index := RR.A2.Id; + TopCallRec.ParamList[Index].Address := P; + Inc(N); +end; end; + +procedure _OP_PUSH_STRUCTURE(var Runner: TIRunner); +var + P: Pointer; + Index: Integer; +begin with Runner do begin + P := LoadAddress1; + Index := RR.A2.Id; + TopCallRec.ParamList[Index].Address := P; + TopCallRec.ParamList[Index].Size := RR.A1.PtrSize; + Inc(N); +end; end; + +procedure _OP_SET_LENGTH(var Runner: TIRunner); +var + P: Pointer; + L: Integer; +begin with Runner do begin + P := LoadAddress1; + L := LoadIntVal2; + case RR.A1.FT of +{$IFNDEF PAXARM} + typeANSISTRING: SetLength(AnsiString(P^), L); + typeWIDESTRING: SetLength(WideString(P^), L); + typeSHORTSTRING: SetLength(ShortString(P^), L); +{$ENDIF} + typeUNICSTRING: SetLength(UnicString(P^), L); + typeVARIANT: Variant(P^) := VarArrayCreate([0, L - 1], varVariant); + typeOLEVARIANT: Variant(P^) := VarArrayCreate([0, L - 1], varVariant); + end; + Inc(N); +end; end; + +procedure _OP_PUSH_LENGTH(var Runner: TIRunner); +begin with Runner do begin + LengthList.Add(LoadIntVal1); + Inc(N); +end; end; + +procedure _OP_SET_LENGTH_EX(var Runner: TIRunner); +var + K: Integer; + P: Pointer; + A: TFW_Array; + ExtraData: TIArrExtraData; +begin with Runner do begin + K := RR.A2.Id; + P := LoadAddress1; + + if K <> LengthList.Count then + RaiseError(errInternalError, []); + + case RR.A1.FT of + typeVARIANT: + case K of + 1: _SetVariantLength(Variant(P^), varVariant, LengthList[0]); + 2: _SetVariantLength2(Variant(P^), varVariant, + LengthList[0], LengthList[1]); + 3: _SetVariantLength3(Variant(P^), varVariant, + LengthList[0], LengthList[1], LengthList[2]); + else + RaiseError(errInternalError, []); + end; + typeCLASS: + begin + ExtraData := ExtraDataList[RR.ExtraDataIndex] as TIArrExtraData; + A := TFW_Array(P^); + case K of + 1: _DynarraySetLength(A.P, LengthList[0], + ExtraData.ElFinTypeId, ExtraData.ElTypeId, ExtraData.ElSize); + 2: _DynarraySetLength2(A.P, LengthList[0], LengthList[1], + ExtraData.ElFinTypeId, ExtraData.ElTypeId, ExtraData.ElSize); + 3: _DynarraySetLength3(A.P, LengthList[0], LengthList[1], LengthList[2], + ExtraData.ElFinTypeId, ExtraData.ElTypeId, ExtraData.ElSize); + else + RaiseError(errInternalError, []); + end; + end; + typeDYNARRAY, typeOPENARRAY: + begin + ExtraData := ExtraDataList[RR.ExtraDataIndex] as TIArrExtraData; + case K of + 1: _DynarraySetLength(P, LengthList[0], + ExtraData.ElFinTypeId, ExtraData.ElTypeId, ExtraData.ElSize); + 2: _DynarraySetLength2(P, LengthList[0], LengthList[1], + ExtraData.ElFinTypeId, ExtraData.ElTypeId, ExtraData.ElSize); + 3: _DynarraySetLength3(P, LengthList[0], LengthList[1], LengthList[2], + ExtraData.ElFinTypeId, ExtraData.ElTypeId, ExtraData.ElSize); + else + RaiseError(errInternalError, []); + end; + end; + end; + LengthList.Clear; + Inc(N); +end; end; + +procedure _OP_FIELD(var Runner: TIRunner); +var + P: Pointer; +begin with Runner do begin + P := LoadAddress1; + if RR.A1.FT = typeCLASS then + P := Pointer(P^); + P := ShiftPointer(P, RR.JMP); + + SavePointer(P, RR.AR); + + Inc(N); +end; end; + +procedure _OP_GET_COMPONENT(var Runner: TIRunner); +begin with Runner do begin + _GetComponent(TComponent(LoadIntVal1), RR.A2.Id, TComponent(LoadAddressR^)); + + Inc(N); +end; end; + +procedure _OP_INIT_FWARRAY(var Runner: TIRunner); +var + ExtraData: TIArrExtraData; +begin with Runner do begin + ExtraData := ExtraDataList[RR.ExtraDataIndex] as TIArrExtraData; + _InitFWArray(Runner, TFW_Array(LoadIntVal1), + RR.A2.Id, + ExtraData.ElFinTypeId, + ExtraData.ElTypeId, + ExtraData.ElSize, + RR.AR.Id); + Inc(N); +end; end; + +procedure _OP_ELEM(var Runner: TIRunner); +var + P: Pointer; + Index: IntPax; + ExtraData: TIArrExtraData; + H1: Integer; + A: TFW_Array; +begin with Runner do begin + P := LoadAddress1; + Index := LoadIntVal2; + + case RR.A1.FT of + typeCLASS: + begin + A := TFW_Array(P^); + ExtraData := ExtraDataList[RR.ExtraDataIndex] as TIArrExtraData; + P := ShiftPointer(A.P, Index * ExtraData.ElSize); + end; + typeARRAY: + begin + ExtraData := ExtraDataList[RR.ExtraDataIndex] as TIArrExtraData; + H1 := ExtraData.H1; + P := ShiftPointer(P, (Index - H1) * ExtraData.ElSize); + end; + typeDYNARRAY, typeOPENARRAY: + begin + ExtraData := ExtraDataList[RR.ExtraDataIndex] as TIArrExtraData; + P := Pointer(P^); + P := ShiftPointer(P, Index * ExtraData.ElSize); + end; + typeUNICSTRING: + begin + P := Pointer(P^); + P := ShiftPointer(P, (Index - 1) * SizeOf(WideChar)); + end; +{$IFNDEF PAXARM} + typeSHORTSTRING: + begin + P := ShiftPointer(P, Index * SizeOf(AnsiChar)); + end; + typeWIDESTRING: + begin + P := Pointer(P^); + P := ShiftPointer(P, (Index - 1) * SizeOf(WideChar)); + end; + typeANSISTRING: + begin + P := Pointer(P^); + P := ShiftPointer(P, (Index - 1) * SizeOf(AnsiChar)); + end; +{$ENDIF} + end; + SavePointer(P, RR.AR); + + Inc(N); +end; end; + +{$ifdef DRTTI} +procedure _OP_VAR_FROM_TVALUE(var Runner: TIRunner); +var + Source, Dest: Pointer; + FT: Integer; +begin with Runner do begin + Source := LoadAddress2; + Dest := LoadAddress1; + FT := RR.A2.FT; + _VarFromTValue(Source, FT, Dest); + + Inc(N); +end; end; + +procedure _OP_GET_DRTTI_PROP(var Runner: TIRunner); +var + X: TObject; + P: TRTTIProperty; + FT: Integer; + presult: Pointer; + ExtendedVal: Extended; + V: TValue; +begin with Runner do begin + X := TObject(LoadIntVal1); + P := TRTTIProperty(LoadIntVal2); + presult := LoadAddressR; + + FT := RR.AR.FT; + + if FT in INT64Types then + _GetDRTTIInt64Property(p, X, Int64(presult^)) + else if FT in IntegerTypes then + _GetDRTTIIntegerProperty(p, X, Integer(presult^)) + else if FT in StringTypes then + _GetDRTTIStringProperty(p, X, String(presult^)) + else if FT in RealTypes then + case FT of + typeSINGLE: + begin + _GetDRTTIExtendedProperty(p, X, ExtendedVal); + PSingle(presult)^ := ExtendedVal; + end; + typeDOUBLE: + begin + _GetDRTTIExtendedProperty(p, X, ExtendedVal); + PDouble(presult)^ := ExtendedVal; + end; + typeEXTENDED: _GetDRTTIExtendedProperty(p, X, Extended(presult^)); + end + else if FT in VariantTypes then + begin + FillChar(presult^, SizeOf(Variant), 0); + _GetDRTTIVariantProperty(p, X, Variant(presult^)); + end + else + begin + V := p.GetValue(X); + Move(V, presult^, SizeOf(TValue)); + end; + + Inc(N); +end; end; + +procedure _OP_SET_DRTTI_PROP(var Runner: TIRunner); +var + X: TObject; + P: TRTTIProperty; +begin with Runner do begin + X := TObject(LoadIntVal1); + P := TRTTIProperty(LoadIntVal2); + _SetDRTTIProperty(p, x, LoadAddressR); + Inc(N); +end; end; +{$endif} + +procedure _OP_GET_ORD_PROP(var Runner: TIRunner); +var + Instance: TObject; + PropInfo: PPropInfo; + result: IntPax; +begin with Runner do begin + Instance := TObject(LoadIntVal1); + PropInfo := PPropInfo(LoadIntVal2); + result := GetOrdProp(Instance, PropInfo); + SaveIntVal(result, RR.AR); + Inc(N); +end; end; + +procedure _OP_GET_SET_PROP(var Runner: TIRunner); +var + Instance: TObject; + PropInfo: PPropInfo; + result: IntPax; + P: Pointer; +begin with Runner do begin + Instance := TObject(LoadIntVal1); + PropInfo := PPropInfo(LoadIntVal2); + P := LoadAddressR; + result := GetOrdProp(Instance, PropInfo); + TByteSet(P^) := Int32ToByteSet(result); + Inc(N); +end; end; + +procedure _OP_GET_UNICSTR_PROP(var Runner: TIRunner); +var + Instance: TObject; + PropInfo: PPropInfo; + P: Pointer; +begin with Runner do begin + Instance := TObject(LoadIntVal1); + PropInfo := PPropInfo(LoadIntVal2); + P := LoadAddressR; + {$IFDEF UNIC} +{$IFDEF PAXARM} + UnicString(P^) := GetStrProp(Instance, PropInfo); +{$ELSE} + UnicString(P^) := GetUnicodeStrProp(Instance, PropInfo); +{$ENDIF} + {$ELSE} + {$IFDEF VARIANTS} + UnicString(P^) := GetWideStrProp(Instance, PropInfo); + {$ENDIF} + {$ENDIF} + Inc(N); +end; end; + +procedure _OP_GET_INTERFACE_PROP(var Runner: TIRunner); +var + Instance: TObject; + PropInfo: PPropInfo; + P: Pointer; +begin with Runner do begin + Instance := TObject(LoadIntVal1); + PropInfo := PPropInfo(LoadIntVal2); + P := LoadAddressR; +{$IFDEF VARIANTS} + IInterface(P^) := GetInterfaceProp(Instance, PropInfo); +{$ENDIF} + Inc(N); +end; end; + +procedure _OP_GET_VARIANT_PROP(var Runner: TIRunner); +var + Instance: TObject; + PropInfo: PPropInfo; + P: Pointer; +begin with Runner do begin + Instance := TObject(LoadIntVal1); + PropInfo := PPropInfo(LoadIntVal2); + P := LoadAddressR; + Variant(P^) := GetVariantProp(Instance, PropInfo); + Inc(N); +end; end; + +procedure _OP_GET_INT64_PROP(var Runner: TIRunner); +var + Instance: TObject; + PropInfo: PPropInfo; + P: Pointer; +begin with Runner do begin + Instance := TObject(LoadIntVal1); + PropInfo := PPropInfo(LoadIntVal2); + P := LoadAddressR; + Int64(P^) := GetInt64Prop(Instance, PropInfo); + Inc(N); +end; end; + +procedure _OP_GET_FLOAT_PROP(var Runner: TIRunner); +var + Instance: TObject; + PropInfo: PPropInfo; + P: Pointer; +begin with Runner do begin + Instance := TObject(LoadIntVal1); + PropInfo := PPropInfo(LoadIntVal2); + P := LoadAddressR; + Extended(P^) := GetFloatProp(Instance, PropInfo); + Inc(N); +end; end; + +procedure _OP_GET_EVENT_PROP(var Runner: TIRunner); +var + Instance: TObject; + PropInfo: PPropInfo; + P: Pointer; +begin with Runner do begin + Instance := TObject(LoadIntVal1); + PropInfo := PPropInfo(LoadIntVal2); + P := LoadAddressR; + TMethod(P^) := GetMethodProp(Instance, PropInfo); + Inc(N); +end; end; + +procedure _OP_SET_SET_PROP(var Runner: TIRunner); +var + Instance: TObject; + PropInfo: PPropInfo; + value: IntPax; + P: Pointer; +begin with Runner do begin + Instance := TObject(LoadIntVal1); + PropInfo := PPropInfo(LoadIntVal2); + P := LoadAddressR; + value := ByteSetToInt32(TByteSet(P^)); + SetOrdProp(Instance, PropInfo, value); + Inc(N); +end; end; + +procedure _OP_SET_ORD_PROP(var Runner: TIRunner); +var + Instance: TObject; + PropInfo: PPropInfo; + value: IntPax; +begin with Runner do begin + Instance := TObject(LoadIntVal1); + PropInfo := PPropInfo(LoadIntVal2); + value := LoadIntVal(RR.AR); + SetOrdProp(Instance, PropInfo, value); + Inc(N); +end; end; + +procedure _OP_SET_UNICSTR_PROP(var Runner: TIRunner); +var + Instance: TObject; + PropInfo: PPropInfo; + P: Pointer; +begin with Runner do begin + Instance := TObject(LoadIntVal1); + PropInfo := PPropInfo(LoadIntVal2); + P := LoadAddressR; +{$IFDEF UNIC} +{$IFDEF PAXARM} + SetStrProp(Instance, PropInfo, UnicString(P^)); +{$ELSE} + SetUnicodeStrProp(Instance, PropInfo, UnicString(P^)); +{$ENDIF} +{$ELSE} + {$IFDEF VARIANTS} + SetWideStrProp(Instance, PropInfo, UnicString(P^)); + {$ENDIF} +{$ENDIF} + + Inc(N); +end; end; + +procedure _OP_SET_INTERFACE_PROP(var Runner: TIRunner); +var + Instance: TObject; + PropInfo: PPropInfo; + P: Pointer; +begin with Runner do begin + Instance := TObject(LoadIntVal1); + PropInfo := PPropInfo(LoadIntVal2); + P := LoadAddressR; +{$IFDEF VARIANTS} + SetInterfaceProp(Instance, PropInfo, IInterface(P^)); +{$ENDIF} + Inc(N); +end; end; + +procedure _OP_SET_VARIANT_PROP(var Runner: TIRunner); +var + Instance: TObject; + PropInfo: PPropInfo; + P: Pointer; +begin with Runner do begin + Instance := TObject(LoadIntVal1); + PropInfo := PPropInfo(LoadIntVal2); + P := LoadAddressR; + SetVariantProp(Instance, PropInfo, Variant(P^)); + Inc(N); +end; end; + +procedure _OP_SET_INT64_PROP(var Runner: TIRunner); +var + Instance: TObject; + PropInfo: PPropInfo; + P: Pointer; +begin with Runner do begin + Instance := TObject(LoadIntVal1); + PropInfo := PPropInfo(LoadIntVal2); + P := LoadAddressR; + SetInt64Prop(Instance, PropInfo, Int64(P^)); + Inc(N); +end; end; + +procedure _OP_SET_FLOAT_PROP(var Runner: TIRunner); +var + Instance: TObject; + PropInfo: PPropInfo; + P: Pointer; +begin with Runner do begin + Instance := TObject(LoadIntVal1); + PropInfo := PPropInfo(LoadIntVal2); + P := LoadAddressR; + SetFloatProp(Instance, PropInfo, Extended(P^)); + Inc(N); +end; end; + +procedure _OP_SET_EVENT_PROP(var Runner: TIRunner); +var + Instance: TObject; + PropInfo: PPropInfo; + M: TMethod; + EventExtraData: TIEventExtraData; + SubExtraData: TISubExtraData; +begin with Runner do begin + EventExtraData := ExtraDataList[RR.ExtraDataIndex] as TIEventExtraData; + SubExtraData := ExtraDataList.Find(EventExtraData.CodeArg.Id) as TISubExtraData; + + Instance := TObject(LoadIntVal1); + PropInfo := PPropInfo(LoadIntVal2); + + if EventExtraData.DataArg.Id = 0 then + M.Data := nil + else + M.Data := Pointer(LoadIntVal(EventExtraData.DataArg)); + + if M.Data = nil then + begin + M.Code := nil; + end + else if SubExtraData.Host then + begin + M.Code := GetGlobalAddress(EventExtraData.CodeArg); + end + else + begin + M.Code := Pointer(SubExtraData.JMP); + WrapMethodAddress(M.Code); + end; + + SetMethodProp(Instance, PropInfo, M); + Inc(N); +end; end; + +procedure _OP_SET_EVENT_PROP2(var Runner: TIRunner); +var + Instance: TObject; + PropInfo: PPropInfo; + M: TMethod; +begin with Runner do begin + Instance := TObject(LoadIntVal1); + PropInfo := PPropInfo(LoadIntVal2); + M := TMethod(LoadAddressR^); + WrapMethodAddress(M.Code); + SetMethodProp(Instance, PropInfo, M); + Inc(N); +end; end; + +procedure _OP_TRY_ON(var Runner: TIRunner); +begin with Runner do begin + RootTryStack.Push(Runner, RR.A1.Id, RR.AR.Id); + Inc(N); +end; end; + +procedure _OP_TRY_OFF(var Runner: TIRunner); +begin with Runner do begin + RootTryStack.Pop; + Inc(N); +end; end; + +procedure _OP_BEGIN_EXCEPT_BLOCK(var Runner: TIRunner); +begin with Runner do begin + ProcessingExceptBlock := true; + Inc(N); +end; end; + +procedure _OP_END_EXCEPT_BLOCK(var Runner: TIRunner); +begin with Runner do begin + ClearCurrException; + ProcessingExceptBlock := false; + Inc(N); +end; end; + +procedure _OP_COND_RAISE(var Runner: TIRunner); +var + LastCondRaise: Integer; + IsExit: Byte; + em: TExitMode; +begin with Runner do begin + if ProcessingExceptBlock then + Exit; + + LastCondRaise := RR.A2.Id; + if CurrException <> nil then + begin + if CurrException is PaxExitException then + begin + em := (CurrException as PaxExitException).Mode; + IsExit := 1; + if em = emBreak then + begin + IsExit := 2; + RootTryStack.Pop; + end; + if em = emContinue then + begin + IsExit := 3; + RootTryStack.Pop; + end; + SaveIntVal(IsExit, RR.AR); + if LastCondRaise = 1 then + begin + ClearCurrException; + Inc(N); + Exit; + end; + end; + + RootTryStack.Pop; + raise DupException(CurrException); + end; + Inc(N); +end; end; + +procedure _OP_EXIT(var Runner: TIRunner); +var + E: PaxExitException; + I: Integer; + TryRec: TITryRec; +begin with Runner do begin + E := PaxExitException.Create(''); + E.Mode := TExitMode(RR.A2.Id); + ExitLevelId := RR.AR.Id; + while RootTryStack.Count > 0 do + begin + I := RootTryStack.Top.TryBlockNumber; + TryRec := TryList[I]; + if TryRec.TryKind = tryFinally then + break + else + RootTryStack.Pop; + end; + raise E; +end; end; + +procedure _OP_HALT(var Runner: TIRunner); +begin with Runner do begin + _Halt(Runner, LoadIntVal1); + Inc(N); +end; end; + +procedure _OP_RAISE(var Runner: TIRunner); +var + E: Exception; + RaiseMode: Integer; +begin with Runner do begin + E := nil; + if RR.A1.Id > 0 then + E := Exception(LoadIntVal1); + RaiseMode := RR.A2.Id; + + if RaiseMode <> 0 then + if RootTryStack.Count > 0 then + RootTryStack.Pop; + + if E <> nil then + raise E + else + begin + E := DupException(CurrException); + raise E; + end; +end; end; + +procedure _OP_TO_JS_OBJECT(var Runner: TIRunner); +begin with Runner do begin + _JS_ToObject(Runner, LoadAddress1, + RR.A1.FT, + LoadAddressR); + Inc(N); +end; end; + +procedure _OP_JS_TYPEOF(var Runner: TIRunner); +begin with Runner do begin + _JS_TypeOf(LoadAddress1, LoadAddressR); + Inc(N); +end; end; + +procedure _OP_PUSH_CONTEXT(var Runner: TIRunner); +begin with Runner do begin + _PushContext(Runner, LoadAddress1); + Inc(N); +end; end; + +procedure _OP_POP_CONTEXT(var Runner: TIRunner); +begin with Runner do begin + _PopContext(Runner); + Inc(N); +end; end; + +procedure _OP_FIND_CONTEXT(var Runner: TIRunner); +begin with Runner do begin + _FindContext(Runner, PChar(LoadIntVal1), + LoadAddress2, + RR.A2.FT, + LoadAddressR); + Inc(N); +end; end; + +procedure _OP_FIND_JS_FUNC(var Runner: TIRunner); +begin with Runner do begin + _FindFunc(Runner, PChar(LoadIntVal1), + LoadAddress2, + LoadAddressR); + Inc(N); +end; end; + +procedure _OP_JS_FUNC_OBJ_FROM_VARIANT(var Runner: TIRunner); +begin with Runner do begin + _FuncObjFromVariant(LoadAddress1, LoadAddressR); + Inc(N); +end; end; + +procedure _OP_ADDRESS_PROG(var Runner: TIRunner); +var + P: Pointer; +begin with Runner do begin + P := ShiftPointer(DataPtr, H_SelfPtr); + SaveIntVal(IntPax(P), RR.AR); + Inc(N); +end; end; + +procedure _OP_ASSIGN_PROG(var Runner: TIRunner); +var + X: TJS_Object; +begin with Runner do begin + X := TJS_Object(LoadIntVal(RR.AR)); + _AssignProg(X, Runner); + Inc(N); +end; end; + +procedure _OP_GET_NEXTJSPROP(var Runner: TIRunner); +begin with Runner do begin + _JS_GetNextProp(LoadAddress1, LoadAddress2, LoadAddressR); + Inc(N); +end; end; + +procedure _OP_CLEAR_REFERENCES(var Runner: TIRunner); +begin with Runner do begin + _ClearReferences(Runner); + Inc(N); +end; end; + +procedure _OP_CLASS_CLR(var Runner: TIRunner); +begin with Runner do begin + _ClassClr(LoadAddress1); + Inc(N); +end; end; + +procedure _OP_VARIANT_FROM_CLASS(var Runner: TIRunner); +begin with Runner do begin + _VariantFromClass(LoadAddress1, LoadAddress2); + Inc(N); +end; end; + +procedure _OP_VARIANT_FROM_POINTER(var Runner: TIRunner); +begin with Runner do begin + _VariantFromPointer(LoadAddress1, LoadAddress2); + Inc(N); +end; end; + +procedure _OP_CLASS_FROM_VARIANT(var Runner: TIRunner); +begin with Runner do begin + _ClassFromVariant(LoadAddressR, LoadAddress2); + Inc(N); +end; end; + +procedure _OP_UNICSTRING_FROM_INT(var Runner: TIRunner); +begin with Runner do begin + UnicString(LoadAddressR^) := IntToStr(LoadIntVal2); + Inc(N); +end; end; + +procedure _OP_UNICSTRING_FROM_DOUBLE(var Runner: TIRunner); +begin with Runner do begin + UnicString(LoadAddressR^) := FloatToStr(Double(LoadAddress2^)); + Inc(N); +end; end; + +procedure _OP_UNICSTRING_FROM_SINGLE(var Runner: TIRunner); +begin with Runner do begin + UnicString(LoadAddressR^) := FloatToStr(Single(LoadAddress2^)); + Inc(N); +end; end; + +procedure _OP_UNICSTRING_FROM_EXTENDED(var Runner: TIRunner); +begin with Runner do begin + UnicString(LoadAddressR^) := FloatToStr(Extended(LoadAddress2^)); + Inc(N); +end; end; + +procedure _OP_UNICSTRING_FROM_BOOLEAN(var Runner: TIRunner); +begin with Runner do begin + UnicString(LoadAddressR^) := BoolToStr(Boolean(LoadAddress2^)); + Inc(N); +end; end; + +procedure _OP_PAUSE(var Runner: TIRunner); +begin with Runner do begin + if Assigned(OnPauseUpdated) then + begin + GetRootProg.PausedPCU := Runner; + try + OnPauseUpdated(RootOwner, GetModuleName, GetSourceLine); + finally + DiscardPause; + RootInitCallStackCount := RootCallStack.Count; + end; + Inc(N); + Exit; + end; + RootExceptionIsAvailableForHostApplication := false; + raise TPauseException.Create; +end; end; + +procedure _OP_CHECK_PAUSE(var Runner: TIRunner); +var + SourceLine, ModuleIndex: Integer; + HasBP: Boolean; +begin with Runner do begin + SourceLine := GetSourceLine; + ModuleIndex := GetModuleIndex; + + HasBP := + RunTimeModuleList.BreakpointList.IndexOf(ModuleIndex, SourceLine) >= 0; + + if HasBP then + Pause + else + begin + if RunMode = rmRUN then + begin + end + else if RunMode = rmTRACE_INTO then + Pause + else if RunMode = rmNEXT_SOURCE_LINE then + Pause + else if RunMode = rmSTEP_OVER then + begin + if RootInitCallStackCount >= RootCallStack.Count then + Pause; + end else if RunMode = rmRUN_TO_CURSOR then + begin + if RunTimeModuleList.TempBreakpoint.SourceLine = SourceLine then + if RunTimeModuleList.TempBreakpoint.ModuleIndex = ModuleIndex then + Pause; + end; + end; + + if fPaused then + begin + if Assigned(OnPauseUpdated) then + begin + GetRootProg.PausedPCU := Runner; + try + OnPauseUpdated(RootOwner, GetModuleName, GetSourceLine); + finally + DiscardPause; + RootInitCallStackCount := RootCallStack.Count; + end; + Inc(N); + Exit; + end; + RootExceptionIsAvailableForHostApplication := false; + raise TPauseException.Create; + end; + + Inc(N); +end; end; + +{$IFNDEF PAXARM} +procedure _OP_UNICSTRING_FROM_ANSICHAR(var Runner: TIRunner); +var + Source: AnsiChar; + Dest: Pointer; +begin with Runner do begin + Source := AnsiChar(LoadIntVal2); + Dest := LoadAddress1; + UnicString(Dest^) := UnicString(AnsiString(Source)); + Inc(N); +end; end; + +procedure _OP_UNICSTRING_FROM_PANSICHAR(var Runner: TIRunner); +var + Source: PAnsiChar; + Dest: Pointer; +begin with Runner do begin + Source := PAnsiChar(LoadIntVal2); + Dest := LoadAddress1; + UnicString(Dest^) := UnicString(AnsiString(Source)); + Inc(N); +end; end; + +procedure _OP_UNICSTRING_FROM_WIDESTRING(var Runner: TIRunner); +var + Source: Pointer; + Dest: Pointer; +begin with Runner do begin + Source := LoadAddress2; + Dest := LoadAddress1; + UnicString(Dest^) := WideString(Source^); + Inc(N); +end; end; + +procedure _OP_UNICSTRING_FROM_ANSISTRING(var Runner: TIRunner); +var + Source: Pointer; + Dest: Pointer; +begin with Runner do begin + Source := LoadAddress2; + Dest := LoadAddress1; + UnicString(Dest^) := UnicString(AnsiString(Source^)); + Inc(N); +end; end; + +procedure _OP_UNICSTRING_FROM_SHORTSTRING(var Runner: TIRunner); +var + Source: Pointer; + Dest: Pointer; +begin with Runner do begin + Source := LoadAddress2; + Dest := LoadAddress1; + UnicString(Dest^) := UnicString(ShortString(Source^)); + Inc(N); +end; end; + +procedure _OP_ASSIGN_PANSICHAR(var Runner: TIRunner); +begin + _OP_ASSIGN_INT(Runner); +end; + +// AnsiString operators -------------------------------------------------------- + +procedure _OP_ASSIGN_ANSISTRING(var Runner: TIRunner); +var + Source, Dest: Pointer; +begin with Runner do begin + Source := LoadAddress2; + Dest := LoadAddressR; + AnsiString(Dest^) := AnsiString(Source^); + Inc(N); +end; end; + +procedure _OP_ANSISTRING_FROM_ANSICHAR(var Runner: TIRunner); +var + Source: AnsiChar; + Dest: Pointer; +begin with Runner do begin + Source := AnsiChar(LoadIntVal2); + Dest := LoadAddress1; + AnsiString(Dest^) := AnsiString(Source); + Inc(N); +end; end; + +procedure _OP_ANSISTRING_FROM_PANSICHAR(var Runner: TIRunner); +var + Source: PAnsiChar; + Dest: Pointer; +begin with Runner do begin + Source := PAnsiChar(LoadIntVal2); + Dest := LoadAddress1; + AnsiString(Dest^) := AnsiString(Source); + Inc(N); +end; end; + +procedure _OP_ANSISTRING_FROM_WIDECHAR(var Runner: TIRunner); +var + Source: WideChar; + Dest: Pointer; +begin with Runner do begin + Source := WideChar(LoadIntVal2); + Dest := LoadAddress1; + AnsiString(Dest^) := AnsiString(Source); + Inc(N); +end; end; + +procedure _OP_ANSISTRING_FROM_PWIDECHAR(var Runner: TIRunner); +var + Source: PWideChar; + Dest: Pointer; +begin with Runner do begin + Source := PWideChar(LoadIntVal2); + Dest := LoadAddress1; + AnsiString(Dest^) := AnsiString(Source); + Inc(N); +end; end; + +procedure _OP_ANSISTRING_FROM_WIDESTRING(var Runner: TIRunner); +var + Source: Pointer; + Dest: Pointer; +begin with Runner do begin + Source := LoadAddress2; + Dest := LoadAddress1; + AnsiString(Dest^) := AnsiString(WideString(Source^)); + Inc(N); +end; end; + +procedure _OP_ANSISTRING_FROM_UNICSTRING(var Runner: TIRunner); +var + Source: Pointer; + Dest: Pointer; +begin with Runner do begin + Source := LoadAddress2; + Dest := LoadAddress1; + AnsiString(Dest^) := AnsiString(UnicString(Source^)); + Inc(N); +end; end; + +procedure _OP_ANSISTRING_FROM_SHORTSTRING(var Runner: TIRunner); +var + Source: Pointer; + Dest: Pointer; +begin with Runner do begin + Source := LoadAddress2; + Dest := LoadAddress1; + AnsiString(Dest^) := ShortString(Source^); + Inc(N); +end; end; + +procedure _OP_ANSISTRING_FROM_VARIANT(var Runner: TIRunner); +var + Source: Pointer; + Dest: Pointer; +begin with Runner do begin + Source := LoadAddress2; + Dest := LoadAddress1; + AnsiString(Dest^) := AnsiString(Variant(Source^)); + Inc(N); +end; end; + +procedure _OP_ADD_ANSISTRING(var Runner: TIRunner); +var + P1, P2, PR: Pointer; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + PR := LoadAddressR; + AnsiString(PR^) := AnsiString(P1^) + AnsiString(P2^); + Inc(N); +end; end; + +procedure _OP_GT_ANSISTRING(var Runner: TIRunner); +var + P1, P2: Pointer; + B: Boolean; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + B := AnsiString(P1^) > AnsiString(P2^); + SaveIntVal(IntPax(B), RR.AR); + Inc(N); +end; end; + +procedure _OP_GE_ANSISTRING(var Runner: TIRunner); +var + P1, P2: Pointer; + B: Boolean; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + B := AnsiString(P1^) >= AnsiString(P2^); + SaveIntVal(IntPax(B), RR.AR); + Inc(N); +end; end; + +procedure _OP_LT_ANSISTRING(var Runner: TIRunner); +var + P1, P2: Pointer; + B: Boolean; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + B := AnsiString(P1^) < AnsiString(P2^); + SaveIntVal(IntPax(B), RR.AR); + Inc(N); +end; end; + +procedure _OP_LE_ANSISTRING(var Runner: TIRunner); +var + P1, P2: Pointer; + B: Boolean; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + B := AnsiString(P1^) <= AnsiString(P2^); + SaveIntVal(IntPax(B), RR.AR); + Inc(N); +end; end; + +procedure _OP_EQ_ANSISTRING(var Runner: TIRunner); +var + P1, P2: Pointer; + B: Boolean; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + B := AnsiString(P1^) = AnsiString(P2^); + SaveIntVal(IntPax(B), RR.AR); + Inc(N); +end; end; + +procedure _OP_NE_ANSISTRING(var Runner: TIRunner); +var + P1, P2: Pointer; + B: Boolean; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + B := AnsiString(P1^) <> AnsiString(P2^); + SaveIntVal(IntPax(B), RR.AR); + Inc(N); +end; end; + +procedure _OP_ANSISTRING_CLR(var Runner: TIRunner); +var + Dest: Pointer; +begin with Runner do begin + Dest := LoadAddress1; + AnsiString(Dest^) := ''; + Inc(N); +end; end; + +// WideString operators -------------------------------------------------------- + +procedure _OP_ASSIGN_WIDESTRING(var Runner: TIRunner); +var + Source, Dest: Pointer; +begin with Runner do begin + Source := LoadAddress2; + Dest := LoadAddressR; + WideString(Dest^) := WideString(Source^); + Inc(N); +end; end; + +procedure _OP_WIDESTRING_FROM_ANSICHAR(var Runner: TIRunner); +var + Source: AnsiChar; + Dest: Pointer; +begin with Runner do begin + Source := AnsiChar(LoadIntVal2); + Dest := LoadAddress1; + WideString(Dest^) := WideString(AnsiString(Source)); + Inc(N); +end; end; + +procedure _OP_WIDESTRING_FROM_PANSICHAR(var Runner: TIRunner); +var + Source: PAnsiChar; + Dest: Pointer; +begin with Runner do begin + Source := PAnsiChar(LoadIntVal2); + Dest := LoadAddress1; + WideString(Dest^) := WideString(AnsiString(Source)); + Inc(N); +end; end; + +procedure _OP_WIDESTRING_FROM_WIDECHAR(var Runner: TIRunner); +var + Source: WideChar; + Dest: Pointer; +begin with Runner do begin + Source := WideChar(LoadIntVal2); + Dest := LoadAddress1; + WideString(Dest^) := WideString(Source); + Inc(N); +end; end; + +procedure _OP_WIDESTRING_FROM_PWIDECHAR(var Runner: TIRunner); +var + Source: PWideChar; + Dest: Pointer; +begin with Runner do begin + Source := PWideChar(LoadIntVal2); + Dest := LoadAddress1; + WideString(Dest^) := WideString(Source); + Inc(N); +end; end; + +procedure _OP_WIDESTRING_FROM_ANSISTRING(var Runner: TIRunner); +var + Source: Pointer; + Dest: Pointer; +begin with Runner do begin + Source := LoadAddress2; + Dest := LoadAddress1; + WideString(Dest^) := WideString(AnsiString(Source^)); + Inc(N); +end; end; + +procedure _OP_WIDESTRING_FROM_UNICSTRING(var Runner: TIRunner); +var + Source: Pointer; + Dest: Pointer; +begin with Runner do begin + Source := LoadAddress2; + Dest := LoadAddress1; + WideString(Dest^) := UnicString(Source^); + Inc(N); +end; end; + +procedure _OP_WIDESTRING_FROM_SHORTSTRING(var Runner: TIRunner); +var + Source: Pointer; + Dest: Pointer; +begin with Runner do begin + Source := LoadAddress2; + Dest := LoadAddress1; + WideString(Dest^) := WideString(ShortString(Source^)); + Inc(N); +end; end; + +procedure _OP_WIDESTRING_FROM_VARIANT(var Runner: TIRunner); +var + Source: Pointer; + Dest: Pointer; +begin with Runner do begin + Source := LoadAddress2; + Dest := LoadAddress1; + WideString(Dest^) := Variant(Source^); + Inc(N); +end; end; + +procedure _OP_ADD_WIDESTRING(var Runner: TIRunner); +var + P1, P2, PR: Pointer; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + PR := LoadAddressR; + WideString(PR^) := WideString(P1^) + WideString(P2^); + Inc(N); +end; end; + +procedure _OP_GT_WIDESTRING(var Runner: TIRunner); +var + P1, P2: Pointer; + B: Boolean; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + B := WideString(P1^) > WideString(P2^); + SaveIntVal(IntPax(B), RR.AR); + Inc(N); +end; end; + +procedure _OP_GE_WIDESTRING(var Runner: TIRunner); +var + P1, P2: Pointer; + B: Boolean; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + B := WideString(P1^) >= WideString(P2^); + SaveIntVal(IntPax(B), RR.AR); + Inc(N); +end; end; + +procedure _OP_LT_WIDESTRING(var Runner: TIRunner); +var + P1, P2: Pointer; + B: Boolean; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + B := WideString(P1^) < WideString(P2^); + SaveIntVal(IntPax(B), RR.AR); + Inc(N); +end; end; + +procedure _OP_LE_WIDESTRING(var Runner: TIRunner); +var + P1, P2: Pointer; + B: Boolean; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + B := WideString(P1^) <= WideString(P2^); + SaveIntVal(IntPax(B), RR.AR); + Inc(N); +end; end; + +procedure _OP_EQ_WIDESTRING(var Runner: TIRunner); +var + P1, P2: Pointer; + B: Boolean; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + B := WideString(P1^) = WideString(P2^); + SaveIntVal(IntPax(B), RR.AR); + Inc(N); +end; end; + +procedure _OP_NE_WIDESTRING(var Runner: TIRunner); +var + P1, P2: Pointer; + B: Boolean; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + B := WideString(P1^) <> WideString(P2^); + SaveIntVal(IntPax(B), RR.AR); + Inc(N); +end; end; + +procedure _OP_WIDESTRING_CLR(var Runner: TIRunner); +var + Dest: Pointer; +begin with Runner do begin + Dest := LoadAddress1; + WideString(Dest^) := ''; + Inc(N); +end; end; + +// ShortString operators ------------------------------------------------------- + +procedure _OP_ASSIGN_SHORTSTRING(var Runner: TIRunner); +var + Source, Dest: Pointer; +begin with Runner do begin + Source := LoadAddress2; + Dest := LoadAddressR; + ShortString(Dest^) := ShortString(Source^); + Inc(N); +end; end; + +procedure _OP_SHORTSTRING_FROM_ANSICHAR(var Runner: TIRunner); +var + Source: AnsiChar; + Dest: Pointer; +begin with Runner do begin + Source := AnsiChar(LoadIntVal2); + Dest := LoadAddress1; + ShortString(Dest^) := AnsiString(Source); + Inc(N); +end; end; + +procedure _OP_SHORTSTRING_FROM_PANSICHAR(var Runner: TIRunner); +var + Source: PAnsiChar; + Dest: Pointer; +begin with Runner do begin + Source := PAnsiChar(LoadIntVal2); + Dest := LoadAddress1; + ShortString(Dest^) := ShortString(AnsiString(Source)); + Inc(N); +end; end; + +procedure _OP_SHORTSTRING_FROM_WIDECHAR(var Runner: TIRunner); +var + Source: AnsiChar; + Dest: Pointer; +begin with Runner do begin + Source := AnsiChar(WideChar(LoadIntVal2)); + Dest := LoadAddress1; + ShortString(Dest^) := ShortString(Source); + Inc(N); +end; end; + +procedure _OP_SHORTSTRING_FROM_PWIDECHAR(var Runner: TIRunner); +var + Source: PWideChar; + Dest: Pointer; +begin with Runner do begin + Source := PWideChar(LoadIntVal2); + Dest := LoadAddress1; + ShortString(Dest^) := ShortString(WideString(Source)); + Inc(N); +end; end; + +procedure _OP_SHORTSTRING_FROM_ANSISTRING(var Runner: TIRunner); +var + Source: Pointer; + Dest: Pointer; +begin with Runner do begin + Source := LoadAddress2; + Dest := LoadAddress1; + ShortString(Dest^) := AnsiString(Source^); + Inc(N); +end; end; + +procedure _OP_SHORTSTRING_FROM_UNICSTRING(var Runner: TIRunner); +var + Source: Pointer; + Dest: Pointer; +begin with Runner do begin + Source := LoadAddress2; + Dest := LoadAddress1; + ShortString(Dest^) := ShortString(UnicString(Source^)); + Inc(N); +end; end; + +procedure _OP_SHORTSTRING_FROM_WIDESTRING(var Runner: TIRunner); +var + Source: Pointer; + Dest: Pointer; +begin with Runner do begin + Source := LoadAddress2; + Dest := LoadAddress1; + ShortString(Dest^) := ShortString(WideString(Source^)); + Inc(N); +end; end; + +procedure _OP_SHORTSTRING_FROM_VARIANT(var Runner: TIRunner); +var + Source: Pointer; + Dest: Pointer; +begin with Runner do begin + Source := LoadAddress2; + Dest := LoadAddress1; + ShortString(Dest^) := ShortString(Variant(Source^)); + Inc(N); +end; end; + +procedure _OP_ADD_SHORTSTRING(var Runner: TIRunner); +var + P1, P2, PR: Pointer; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + PR := LoadAddressR; + ShortString(PR^) := ShortString(P1^) + ShortString(P2^); + Inc(N); +end; end; + +procedure _OP_GT_SHORTSTRING(var Runner: TIRunner); +var + P1, P2: Pointer; + B: Boolean; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + B := ShortString(P1^) > ShortString(P2^); + SaveIntVal(IntPax(B), RR.AR); + Inc(N); +end; end; + +procedure _OP_GE_SHORTSTRING(var Runner: TIRunner); +var + P1, P2: Pointer; + B: Boolean; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + B := ShortString(P1^) >= ShortString(P2^); + SaveIntVal(IntPax(B), RR.AR); + Inc(N); +end; end; + +procedure _OP_LT_SHORTSTRING(var Runner: TIRunner); +var + P1, P2: Pointer; + B: Boolean; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + B := ShortString(P1^) < ShortString(P2^); + SaveIntVal(IntPax(B), RR.AR); + Inc(N); +end; end; + +procedure _OP_LE_SHORTSTRING(var Runner: TIRunner); +var + P1, P2: Pointer; + B: Boolean; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + B := ShortString(P1^) <= ShortString(P2^); + SaveIntVal(IntPax(B), RR.AR); + Inc(N); +end; end; + +procedure _OP_EQ_SHORTSTRING(var Runner: TIRunner); +var + P1, P2: Pointer; + B: Boolean; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + B := ShortString(P1^) = ShortString(P2^); + SaveIntVal(IntPax(B), RR.AR); + Inc(N); +end; end; + +procedure _OP_NE_SHORTSTRING(var Runner: TIRunner); +var + P1, P2: Pointer; + B: Boolean; +begin with Runner do begin + P1 := LoadAddress1; + P2 := LoadAddress2; + B := ShortString(P1^) <> ShortString(P2^); + SaveIntVal(IntPax(B), RR.AR); + Inc(N); +end; end; + +procedure _OP_VARIANT_FROM_ANSICHAR(var Runner: TIRunner); +begin with Runner do begin + _VariantFromAnsiChar(AnsiChar(LoadIntVal2), LoadAddress1); + Inc(N); +end; end; + +procedure _OP_VARIANT_FROM_PANSICHAR(var Runner: TIRunner); +begin with Runner do begin + _VariantFromPAnsiChar(PAnsiChar(LoadIntVal2), LoadAddress1); + Inc(N); +end; end; + +procedure _OP_VARIANT_FROM_ANSISTRING(var Runner: TIRunner); +begin with Runner do begin + _VariantFromAnsiString(LoadAddress1, LoadAddress2); + Inc(N); +end; end; + +procedure _OP_VARIANT_FROM_WIDESTRING(var Runner: TIRunner); +begin with Runner do begin + _VariantFromWideString(LoadAddress1, LoadAddress2); + Inc(N); +end; end; + +procedure _OP_VARIANT_FROM_SHORTSTRING(var Runner: TIRunner); +begin with Runner do begin + _VariantFromShortString(LoadAddress1, LoadAddress2); + Inc(N); +end; end; + +procedure _OP_GET_ANSISTR_PROP(var Runner: TIRunner); +var + Instance: TObject; + PropInfo: PPropInfo; + P: Pointer; +begin with Runner do begin + Instance := TObject(LoadIntVal1); + PropInfo := PPropInfo(LoadIntVal2); + P := LoadAddressR; +{$IFDEF UNIC} + AnsiString(P^) := GetAnsiStrProp(Instance, PropInfo); +{$ELSE} + AnsiString(P^) := GetStrProp(Instance, PropInfo); +{$ENDIF} + + Inc(N); +end; end; + +procedure _OP_GET_WIDESTR_PROP(var Runner: TIRunner); +var + Instance: TObject; + PropInfo: PPropInfo; + P: Pointer; +begin with Runner do begin + Instance := TObject(LoadIntVal1); + PropInfo := PPropInfo(LoadIntVal2); + P := LoadAddressR; +{$IFDEF VARIANTS} + WideString(P^) := GetWideStrProp(Instance, PropInfo); +{$ENDIF} + Inc(N); +end; end; + +procedure _OP_SET_ANSISTR_PROP(var Runner: TIRunner); +var + Instance: TObject; + PropInfo: PPropInfo; + P: Pointer; +begin with Runner do begin + Instance := TObject(LoadIntVal1); + PropInfo := PPropInfo(LoadIntVal2); + P := LoadAddressR; +{$IFDEF UNIC} + SetAnsiStrProp(Instance, PropInfo, AnsiString(P^)); +{$ELSE} + SetStrProp(Instance, PropInfo, AnsiString(P^)); +{$ENDIF} + + Inc(N); +end; end; + +procedure _OP_SET_WIDESTR_PROP(var Runner: TIRunner); +var + Instance: TObject; + PropInfo: PPropInfo; + P: Pointer; +begin with Runner do begin + Instance := TObject(LoadIntVal1); + PropInfo := PPropInfo(LoadIntVal2); + P := LoadAddressR; +{$IFDEF VARIANTS} + SetWideStrProp(Instance, PropInfo, WideString(P^)); +{$ENDIF} + Inc(N); +end; end; + +procedure _OP_ANSISTRING_FROM_INT(var Runner: TIRunner); +begin with Runner do begin + AnsiString(LoadAddressR^) := AnsiString(IntToStr(LoadIntVal2)); + Inc(N); +end; end; + +procedure _OP_ANSISTRING_FROM_DOUBLE(var Runner: TIRunner); +begin with Runner do begin + AnsiString(LoadAddressR^) := AnsiString(FloatToStr(Double(LoadAddress2^))); + Inc(N); +end; end; + +procedure _OP_ANSISTRING_FROM_SINGLE(var Runner: TIRunner); +begin with Runner do begin + AnsiString(LoadAddressR^) := AnsiString(FloatToStr(Single(LoadAddress2^))); + Inc(N); +end; end; + +procedure _OP_ANSISTRING_FROM_EXTENDED(var Runner: TIRunner); +begin with Runner do begin + AnsiString(LoadAddressR^) := AnsiString(FloatToStr(Extended(LoadAddress2^))); + Inc(N); +end; end; + +procedure _OP_ANSISTRING_FROM_BOOLEAN(var Runner: TIRunner); +begin with Runner do begin + AnsiString(LoadAddressR^) := AnsiString(BoolToStr(Boolean(LoadAddress2^))); + Inc(N); +end; end; + +{$ENDIF} // NOT PAXARM + +procedure _OP_CLASSNAME(var Runner: TIRunner); +var + P: Pointer; + S: String; +begin with Runner do begin + P := Pointer(LoadIntVal1); +{$IFDEF PAXARM} + if IsDelphiClass(P) then + String(LoadAddressR^) := TClass(P).ClassName + else + String(LoadAddressR^) := TObject(P).ClassName; +{$ELSE} + if IsDelphiClass(P) then + S := TClass(P).ClassName + else + S := TObject(P).ClassName; + ShortString(LoadAddressR^) := ShortString(S); +{$ENDIF} + Inc(N); +end; end; + +procedure _OP_X_FROM_VARIANT(var Runner: TIRunner); +var + Source: Pointer; + Dest: Pointer; + V: Variant; +begin with Runner do begin + Source := LoadAddress2; + Dest := LoadAddressR; + V := Variant(Source^); + case RR.AR.FT of + typeBOOLEAN: Boolean(Dest^) := V; + typeWORDBOOL: WordBool(Dest^) := V; + typeLONGBOOL: LongBool(Dest^) := V; + typeWIDECHAR: WideChar(Dest^) := WideChar(TVarData(V).VInteger); +{$IFNDEF PAXARM} + typeANSICHAR: AnsiChar(Dest^) := AnsiChar(TVarData(V).VInteger); + typeANSISTRING: AnsiString(Dest^) := AnsiString(V); + typeWIDESTRING: WideString(Dest^) := V; + typeSHORTSTRING: ShortString(Dest^) := ShortString(V); +{$ENDIF} + typeUNICSTRING: UnicString(Dest^) := V; + typeINTEGER: Integer(Dest^) := V; + typeCARDINAL: Cardinal(Dest^) := V; + typeWORD: Word(Dest^) := V; + typeBYTE: Byte(Dest^) := V; + typeENUM: Byte(Dest^) := V; + typeSMALLINT: SmallInt(Dest^) := V; + typeSHORTINT: ShortInt(Dest^) := V; +{$IFDEF VARIANTS} + typeINT64: Int64(Dest^) := V; + typeUINT64: UInt64(Dest^) := V; +{$ELSE} + typeINT64: Int64(Dest^) := Integer(V); + typeUINT64: UInt64(Dest^) := Cardinal(V); +{$ENDIF} + typeDOUBLE: Double(Dest^) := V; + typeSINGLE: Single(Dest^) := V; + typeEXTENDED: Extended(Dest^) := V; + typeCURRENCY: Currency(Dest^) := V; + typeINTERFACE: IInterface(Dest^) := V; + end; + Inc(N); +end; end; + +procedure _OP_BOOL_FROM_INT(var Runner: TIRunner); +begin with Runner do begin + if LoadIntVal2 <> 0 then + SaveIntVal(1, RR.AR) + else + SaveIntVal(0, RR.AR); + Inc(N); +end; end; + +procedure _OP_CREATE_OBJECT(var Runner: TIRunner); +var + C: TClass; + X: TObject; +begin with Runner do begin + C := TClass(LoadIntVal2); +{$IFDEF ARC} + X := C.InitInstance(AllocMem(C.InstanceSize)); + X.__ObjAddRef; + SaveIntVal(IntPax(X), RR.AR); +{$ELSE} + X := C.NewInstance; + SaveIntVal(IntPax(X), RR.AR); +{$ENDIF} + TopCallRec.ResOffset := RR.AR.Offset; + Inc(N); +end; end; + +procedure _OP_STRUCTURE_CLR(var Runner: TIRunner); +var + StructExtraData: TIStructExtraData; + P, Q: Pointer; + I, FT, Offset: Integer; +begin with Runner do begin + StructExtraData := ExtraDataList[RR.ExtraDataIndex] as TIStructExtraData; + P := LoadAddress1; + + if RR.JMP > 0 then + InvokeDestructor(P, RR.JMP); + + for I := 0 to StructExtraData.FinTypes.Count - 1 do + begin + FT := StructExtraData.FinTypes[I]; + Offset := StructExtraData.Offsets[I]; + Q := ShiftPointer(P, Offset); + case FT of +{$IFNDEF PAXARM} + typeANSISTRING: AnsiString(Q^) := ''; + typeWIDESTRING: WideString(Q^) := ''; +{$ENDIF} + typeUNICSTRING: UnicString(Q^) := ''; + typeVARIANT, typeOLEVARIANT: VarClear(Variant(Q^)); + typeINTERFACE: IUnknown(Q^) := nil; + typeCLASS: _ClassClr(Q); + end; + end; + Inc(N); +end; end; + + +end. + + diff --git a/Sources/PAXINT_RUNNER.pas b/Sources/PAXINT_RUNNER.pas new file mode 100644 index 0000000..f07d4a7 --- /dev/null +++ b/Sources/PAXINT_RUNNER.pas @@ -0,0 +1,2460 @@ +//////////////////////////////////////////////////////////////////////////// +// PaxCompiler +// Site: http://www.paxcompiler.com +// Author: Alexander Baranovsky (paxscript@gmail.com) +// ======================================================================== +// Copyright (c) Alexander Baranovsky, 2006-2014. All rights reserved. +// Code Version: 4.2 +// ======================================================================== +// Unit: PAXINT_RUNNER.pas +// ======================================================================== +//////////////////////////////////////////////////////////////////////////// + +{$I PaxCompiler.def} + +//{$DEFINE FMX} + +unit PAXINT_RUNNER; +{$O-} +interface +uses {$I uses.def} + Classes, + SysUtils, + TypInfo, + PAXCOMP_CONSTANTS, + PAXCOMP_TYPES, + PAXCOMP_SYS, + PAXCOMP_MAP, + PAXCOMP_CLASSLST, + PAXCOMP_CLASSFACT, + PAXCOMP_BASERUNNER, + + PaxInvoke, + + PAXINT_SYS, + PAXINT_SEH, + PAXINT_CALL; +type + TIRunner = class; + + TIRunRec = class + public + Op: SmallInt; + A1: TIArg; + A2: TIArg; + AR: TIArg; + JMP: Integer; + ExtraDataIndex: SmallInt; + Lang: Byte; + constructor Create; + destructor Destroy; override; + procedure SaveToStream(S: TStream); + procedure LoadFromStream(S: TStream); + end; + + TIProc = procedure (var Runner: TIRunner); + + TIRunner = class(TBaseRunner) + private +{$IFDEF ARC} + A: TList; +{$ELSE} + A: TList; +{$ENDIF} + ProcList: array of TIProc; + + fCallStack: TICallStack; + fTryStack: TITryStack; + fOuterMostStack: TIntegerStack; + + function GetUnhandled: Boolean; + function GetRootOuterMostStack: TIntegerStack; + function GetRootRunner: TIRunner; + function GetRootCallStack: TICallStack; + function GetRootTryStack: TITryStack; + procedure RaiseError(const Message: string; params: array of Const); + function GetRecord(I: Integer): TIRunRec; + procedure SaveCodeToStream(S: TStream); + procedure LoadCodeFromStream(S: TStream); + function GetCard: Integer; + function GetLocalAddress(PA: TIArg): Pointer; overload; + function LoadAddress(const Arg: TIArg): Pointer; + public + ProcessingExceptBlock: Boolean; + RR: TIRunRec; + N: Integer; + ExtraDataList: TIExtraDataList; +{$IFDEF ARC} + VarParamList: TList; +{$ELSE} + VarParamList: TList; +{$ENDIF} + TopCallRec: TICallRec; + OleParamList: TActualParamList; + LengthList: TIntegerList; + dummy_params: array[0..MAX_JS_PARAM] of Variant; + ExitLevelId: Integer; + TryList: TITryList; + fPaused: Boolean; + constructor Create; override; + destructor Destroy; override; + function AddRecord: TIRunRec; + function GetDestructorAddress: Pointer; override; + function NeedAllocAll: Boolean; override; + procedure Reset; override; + procedure Deallocate; + function GetProgramSize: Integer; override; + function GetParamAddress(Offset: Integer): Pointer; overload; override; + function GetLocalAddress(Offset: Integer): Pointer; overload; override; + function GetParamAddress(StackFrameNumber, Offset: Integer): Pointer; overload; override; + function GetLocalAddress(StackFrameNumber, Offset: Integer): Pointer; overload; override; + function AddSubExtraData(I: Integer; Id: Integer): TISubExtraData; + function AddArrExtraData(I: Integer; Id: Integer): TIArrExtraData; + function AddStructExtraData(I: Integer; Id: Integer): TIStructExtraData; + function AddEventExtraData(I: Integer; Id: Integer): TIEventExtraData; + procedure SaveToStream(S: TStream); override; + procedure LoadFromStream(S: TStream); override; + function GetCallStackCount: Integer; override; + function GetCallStackItem(I: Integer): Integer; override; + function GetCallStackLineNumber(I: Integer): Integer; override; + function GetCallStackModuleName(I: Integer): String; override; + function GetCallStackModuleIndex(I: Integer): Integer; override; + procedure SetGlobalAddresses; + function GetGlobalAddress(PA: TIArg): Pointer; + procedure InitStringLiterals; + procedure CreateTryList; + procedure Run; override; + procedure RunInternal; override; + procedure RunInitialization; override; + procedure RunFinalization; override; + procedure RunExceptInitialization; override; + procedure ResetRun; override; + procedure CallJavaScriptFunction; + function CallFunc(const FullName: String; + This: Pointer; + const ParamList: array of OleVariant; + OverCount: Integer = 0): OleVariant; override; + function CallByteCode(InitN: Integer; + This: Pointer; + R_AX, R_CX, R_DX, R_8, R_9: IntPax; + StackPtr: Pointer; + ResultPtr: Pointer; + var FT: Integer): Integer; override; +{$IFDEF DRTTI} + procedure CallRTTIMethod(Address: Pointer); +{$ENDIF} + function LoadAddress1: Pointer; + function LoadAddress2: Pointer; + function LoadAddressR: Pointer; + function LoadIntVal(const Arg: TIArg): IntPax; + function LoadIntVal1: IntPax; + function LoadIntVal2: IntPax; + procedure SaveIntVal(value: IntPax; var Arg: TIArg); + procedure SavePointer(value: Pointer; var Arg: TIArg); + + function IsPaused: Boolean; override; + procedure Pause; override; + procedure DiscardPause; override; + procedure RemovePause; override; + function GetByteCodeLine: Integer; override; + procedure UpdateAddress(var Address: Pointer; Data: Pointer); + procedure InvokeDestructor(This: Pointer; InitN: Integer); + function GetInterfaceToObjectOffset(JumpN: Integer): Integer; override; + function GetReturnFinalTypeId(InitSubN: Integer): Integer; override; +{$IFNDEF PAXARM_DEVICE} + procedure SetEntryPoint(EntryPoint: TPaxInvoke); override; + procedure ResetEntryPoint(EntryPoint: TPaxInvoke); override; +{$ENDIF} + + property Card: Integer read GetCard; + property RootRunner: TIRunner read GetRootRunner; + property RootCallStack: TICallStack read GetRootCallStack; + property RootTryStack: TITryStack read GetRootTryStack; + property RootOuterMostStack: TIntegerStack read GetRootOuterMostStack; + property Unhandled: Boolean read GetUnhandled; + property Records[I: Integer]: TIRunRec read GetRecord; default; + end; + +implementation + +uses + PAXCOMP_STDLIB, +{$IFDEF DRTTI} + RTTI, + PAXCOMP_2010REG, +{$ENDIF} + PAXCOMP_BASESYMBOL_TABLE, + PAXCOMP_LOCALSYMBOL_TABLE, + PAXCOMP_JavaScript, + PAXCOMP_FRAMEWORK, + PAXINT_PROCS; + +procedure RunLoop(Self: TIRunner); forward; + +constructor TIRunRec.Create; +begin + inherited; +end; + +destructor TIRunRec.Destroy; +begin + inherited; +end; + +procedure TIRunRec.SaveToStream(S: TStream); +begin + S.Write(Op, SizeOf(Op)); + SaveArg(A1, S); + SaveArg(A2, S); + SaveArg(AR, S); + S.Write(ExtraDataIndex, SizeOf(ExtraDataIndex)); + S.Write(JMP, SizeOf(JMP)); + S.Write(Lang, SizeOf(Lang)); +end; + +procedure TIRunRec.LoadFromStream(S: TStream); +begin + S.Read(Op, SizeOf(Op)); + LoadArg(A1, S); + LoadArg(A2, S); + LoadArg(AR, S); + S.Read(ExtraDataIndex, SizeOf(ExtraDataIndex)); + S.Read(JMP, SizeOf(JMP)); + S.Read(Lang, SizeOf(Lang)); +end; + +constructor TIRunner.Create; +var + I: Integer; +begin + inherited; + CurrProg := Self; + +{$IFDEF ARC} + A := TList.Create; + VarParamList := TList.Create; +{$ELSE} + A := TList.Create; + VarParamList := TList.Create; +{$ENDIF} + AddRecord; + + OleParamList := TActualParamList.Create; + LengthList := TIntegerList.Create; + fCallStack := TICallStack.Create; + ExtraDataList := TIExtraDataList.Create(Self); + TryList := TITryList.Create; + fTryStack := TITryStack.Create; + fOuterMostStack := TIntegerStack.Create; + + SetLength(ProcList, 1000); + + for I:=0 to System.Length(ProcList) - 1 do + ProcList[I] := OperNop; + + ProcList[- OP_VARARRAY_GET] := _OP_VARARRAY_GET; + ProcList[- OP_VARARRAY_PUT] := _OP_VARARRAY_PUT; + ProcList[- OP_CLASSNAME] := _OP_CLASSNAME; + ProcList[- OP_PUSH_PTR] := _OP_PUSH_PTR; + ProcList[- OP_GET_PROG] := _OP_GET_PROG; + ProcList[- OP_ASSIGN_CLASS] := _OP_ASSIGN_CLASS; + ProcList[- OP_ASSIGN_EVENT] := _OP_ASSIGN_EVENT; + ProcList[- OP_CREATE_EVENT] := _OP_CREATE_EVENT; + ProcList[- OP_CREATE_METHOD] := _OP_CREATE_METHOD; + + ProcList[- OP_ASSIGN_PWIDECHAR] := _OP_ASSIGN_PWIDECHAR; +{$IFNDEF PAXARM} + ProcList[- OP_ASSIGN_PANSICHAR] := _OP_ASSIGN_PANSICHAR; + ProcList[- OP_PUSH_PANSICHAR_IMM] := _OP_PUSH_INT; +{$ENDIF} + ProcList[- OP_PUSH_PWIDECHAR_IMM] := _OP_PUSH_INT; + + ProcList[- OP_ASSIGN_UNICSTRING] := _OP_ASSIGN_UNICSTRING; + ProcList[- OP_PUSH_UNICSTRING] := _OP_PUSH_INT; + +{$IFNDEF PAXARM} + ProcList[- OP_UNICSTRING_FROM_ANSICHAR] := _OP_UNICSTRING_FROM_ANSICHAR; + ProcList[- OP_UNICSTRING_FROM_PANSICHAR_LITERAL] := _OP_UNICSTRING_FROM_PANSICHAR; + ProcList[- OP_UNICSTRING_FROM_WIDESTRING] := _OP_UNICSTRING_FROM_WIDESTRING; + ProcList[- OP_UNICSTRING_FROM_ANSISTRING] := _OP_UNICSTRING_FROM_ANSISTRING; + ProcList[- OP_UNICSTRING_FROM_SHORTSTRING] := _OP_UNICSTRING_FROM_SHORTSTRING; +{$ENDIF} + + ProcList[- OP_UNICSTRING_FROM_WIDECHAR] := _OP_UNICSTRING_FROM_WIDECHAR; + ProcList[- OP_UNICSTRING_FROM_WIDECHAR_LITERAL] := _OP_UNICSTRING_FROM_WIDECHAR; + ProcList[- OP_UNICSTRING_FROM_PWIDECHAR_LITERAL] := _OP_UNICSTRING_FROM_PWIDECHAR; + ProcList[- OP_UNICSTRING_FROM_VARIANT] := _OP_UNICSTRING_FROM_VARIANT; + ProcList[- OP_ADD_UNICSTRING] := _OP_ADD_UNICSTRING; + ProcList[- OP_GT_UNICSTRING] := _OP_GT_UNICSTRING; + ProcList[- OP_GE_UNICSTRING] := _OP_GE_UNICSTRING; + ProcList[- OP_LT_UNICSTRING] := _OP_LT_UNICSTRING; + ProcList[- OP_LE_UNICSTRING] := _OP_LE_UNICSTRING; + ProcList[- OP_EQ_UNICSTRING] := _OP_EQ_UNICSTRING; + ProcList[- OP_NE_UNICSTRING] := _OP_NE_UNICSTRING; + ProcList[- OP_UNICSTRING_CLR] := _OP_UNICSTRING_CLR; + +{$IFNDEF PAXARM} + ProcList[- OP_ASSIGN_ANSISTRING] := _OP_ASSIGN_ANSISTRING; + ProcList[- OP_PUSH_ANSISTRING] := _OP_PUSH_INT; + ProcList[- OP_ANSISTRING_FROM_ANSICHAR] := _OP_ANSISTRING_FROM_ANSICHAR; + ProcList[- OP_ANSISTRING_FROM_PANSICHAR] := _OP_ANSISTRING_FROM_PANSICHAR; + ProcList[- OP_ANSISTRING_FROM_WIDECHAR] := _OP_ANSISTRING_FROM_WIDECHAR; + ProcList[- OP_ANSISTRING_FROM_PWIDECHAR] := _OP_ANSISTRING_FROM_PWIDECHAR; + ProcList[- OP_ANSISTRING_FROM_WIDESTRING] := _OP_ANSISTRING_FROM_WIDESTRING; + ProcList[- OP_ANSISTRING_FROM_UNICSTRING] := _OP_ANSISTRING_FROM_UNICSTRING; + ProcList[- OP_ANSISTRING_FROM_SHORTSTRING] := _OP_ANSISTRING_FROM_SHORTSTRING; + ProcList[- OP_ANSISTRING_FROM_VARIANT] := _OP_ANSISTRING_FROM_VARIANT; + ProcList[- OP_ADD_ANSISTRING] := _OP_ADD_ANSISTRING; + ProcList[- OP_GT_ANSISTRING] := _OP_GT_ANSISTRING; + ProcList[- OP_GE_ANSISTRING] := _OP_GE_ANSISTRING; + ProcList[- OP_LT_ANSISTRING] := _OP_LT_ANSISTRING; + ProcList[- OP_LE_ANSISTRING] := _OP_LE_ANSISTRING; + ProcList[- OP_EQ_ANSISTRING] := _OP_EQ_ANSISTRING; + ProcList[- OP_NE_ANSISTRING] := _OP_NE_ANSISTRING; + ProcList[- OP_ANSISTRING_CLR] := _OP_ANSISTRING_CLR; + + ProcList[- OP_ASSIGN_WIDESTRING] := _OP_ASSIGN_WIDESTRING; + ProcList[- OP_PUSH_WIDESTRING] := _OP_PUSH_INT; + ProcList[- OP_WIDESTRING_FROM_ANSICHAR] := _OP_WIDESTRING_FROM_ANSICHAR; + ProcList[- OP_WIDESTRING_FROM_PANSICHAR_LITERAL] := _OP_WIDESTRING_FROM_PANSICHAR; + ProcList[- OP_WIDESTRING_FROM_WIDECHAR_LITERAL] := _OP_WIDESTRING_FROM_WIDECHAR; + ProcList[- OP_WIDESTRING_FROM_WIDECHAR] := _OP_WIDESTRING_FROM_WIDECHAR; + ProcList[- OP_WIDESTRING_FROM_PWIDECHAR_LITERAL] := _OP_WIDESTRING_FROM_PWIDECHAR; + ProcList[- OP_WIDESTRING_FROM_UNICSTRING] := _OP_WIDESTRING_FROM_UNICSTRING; + ProcList[- OP_WIDESTRING_FROM_ANSISTRING] := _OP_WIDESTRING_FROM_ANSISTRING; + ProcList[- OP_WIDESTRING_FROM_SHORTSTRING] := _OP_WIDESTRING_FROM_SHORTSTRING; + ProcList[- OP_WIDESTRING_FROM_VARIANT] := _OP_WIDESTRING_FROM_VARIANT; + ProcList[- OP_ADD_WIDESTRING] := _OP_ADD_WIDESTRING; + ProcList[- OP_GT_WIDESTRING] := _OP_GT_WIDESTRING; + ProcList[- OP_GE_WIDESTRING] := _OP_GE_WIDESTRING; + ProcList[- OP_LT_WIDESTRING] := _OP_LT_WIDESTRING; + ProcList[- OP_LE_WIDESTRING] := _OP_LE_WIDESTRING; + ProcList[- OP_EQ_WIDESTRING] := _OP_EQ_WIDESTRING; + ProcList[- OP_NE_WIDESTRING] := _OP_NE_WIDESTRING; + ProcList[- OP_WIDESTRING_CLR] := _OP_WIDESTRING_CLR; + + ProcList[- OP_ASSIGN_SHORTSTRING] := _OP_ASSIGN_SHORTSTRING; + ProcList[- OP_PUSH_SHORTSTRING] := _OP_PUSH_ADDRESS; + ProcList[- OP_SHORTSTRING_FROM_ANSICHAR] := _OP_SHORTSTRING_FROM_ANSICHAR; + ProcList[- OP_SHORTSTRING_FROM_PANSICHAR_LITERAL] := _OP_SHORTSTRING_FROM_PANSICHAR; + ProcList[- OP_SHORTSTRING_FROM_WIDECHAR] := _OP_SHORTSTRING_FROM_WIDECHAR; + ProcList[- OP_SHORTSTRING_FROM_PWIDECHAR_LITERAL] := _OP_SHORTSTRING_FROM_PWIDECHAR; + ProcList[- OP_SHORTSTRING_FROM_UNICSTRING] := _OP_SHORTSTRING_FROM_UNICSTRING; + ProcList[- OP_SHORTSTRING_FROM_ANSISTRING] := _OP_SHORTSTRING_FROM_ANSISTRING; + ProcList[- OP_SHORTSTRING_FROM_WIDESTRING] := _OP_SHORTSTRING_FROM_WIDESTRING; + ProcList[- OP_SHORTSTRING_FROM_VARIANT] := _OP_SHORTSTRING_FROM_VARIANT; + ProcList[- OP_ADD_SHORTSTRING] := _OP_ADD_SHORTSTRING; + ProcList[- OP_GT_SHORTSTRING] := _OP_GT_SHORTSTRING; + ProcList[- OP_GE_SHORTSTRING] := _OP_GE_SHORTSTRING; + ProcList[- OP_LT_SHORTSTRING] := _OP_LT_SHORTSTRING; + ProcList[- OP_LE_SHORTSTRING] := _OP_LE_SHORTSTRING; + ProcList[- OP_EQ_SHORTSTRING] := _OP_EQ_SHORTSTRING; + ProcList[- OP_NE_SHORTSTRING] := _OP_NE_SHORTSTRING; +{$ENDIF} + + ProcList[- OP_ASSIGN_INT_I] := _OP_ASSIGN_INT; + ProcList[- OP_ASSIGN_INT_M] := _OP_ASSIGN_INT; + ProcList[- OP_ASSIGN_BYTE_I] := _OP_ASSIGN_INT; + ProcList[- OP_ASSIGN_BYTE_M] := _OP_ASSIGN_INT; + ProcList[- OP_ASSIGN_WORD_I] := _OP_ASSIGN_INT; + ProcList[- OP_ASSIGN_WORD_M] := _OP_ASSIGN_INT; + ProcList[- OP_ASSIGN_CARDINAL_I] := _OP_ASSIGN_INT; + ProcList[- OP_ASSIGN_CARDINAL_M] := _OP_ASSIGN_INT; + ProcList[- OP_ASSIGN_SHORTINT_I] := _OP_ASSIGN_INT; + ProcList[- OP_ASSIGN_SHORTINT_M] := _OP_ASSIGN_INT; + ProcList[- OP_ASSIGN_SMALLINT_I] := _OP_ASSIGN_INT; + ProcList[- OP_ASSIGN_SMALLINT_M] := _OP_ASSIGN_INT; + + ProcList[- OP_PUSH_INT] := _OP_PUSH_INT; + ProcList[- OP_PUSH_INT_IMM] := _OP_PUSH_INT; + ProcList[- OP_PUSH_BYTE_IMM] := _OP_PUSH_INT; + ProcList[- OP_PUSH_BYTE] := _OP_PUSH_INT; + ProcList[- OP_PUSH_WORD_IMM] := _OP_PUSH_INT; + ProcList[- OP_PUSH_WORD] := _OP_PUSH_INT; + ProcList[- OP_PUSH_CARDINAL_IMM] := _OP_PUSH_INT; + ProcList[- OP_PUSH_CARDINAL] := _OP_PUSH_INT; + ProcList[- OP_PUSH_SMALLINT_IMM] := _OP_PUSH_INT; + ProcList[- OP_PUSH_SMALLINT] := _OP_PUSH_INT; + ProcList[- OP_PUSH_SHORTINT_IMM] := _OP_PUSH_INT; + ProcList[- OP_PUSH_SHORTINT] := _OP_PUSH_INT; + + ProcList[- OP_ADD_INT_MI] := _OP_ADD_INT; + ProcList[- OP_ADD_INT_MM] := _OP_ADD_INT; + ProcList[- OP_SUB_INT_MI] := _OP_SUB_INT; + ProcList[- OP_SUB_INT_MM] := _OP_SUB_INT; + ProcList[- OP_IMUL_INT_MI] := _OP_IMUL_INT; + ProcList[- OP_IMUL_INT_MM] := _OP_IMUL_INT; + ProcList[- OP_IDIV_INT_MI] := _OP_IDIV_INT; + ProcList[- OP_IDIV_INT_MM] := _OP_IDIV_INT; + ProcList[- OP_IDIV_INT_IM] := _OP_IDIV_INT; + ProcList[- OP_MOD_INT_MI] := _OP_MOD_INT; + ProcList[- OP_MOD_INT_MM] := _OP_MOD_INT; + ProcList[- OP_MOD_INT_IM] := _OP_MOD_INT; + ProcList[- OP_SHL_INT_MI] := _OP_SHL_INT; + ProcList[- OP_SHL_INT_MM] := _OP_SHL_INT; + ProcList[- OP_SHL_INT_IM] := _OP_SHL_INT; + ProcList[- OP_SHR_INT_MI] := _OP_SHR_INT; + ProcList[- OP_SHR_INT_MM] := _OP_SHR_INT; + ProcList[- OP_SHR_INT_IM] := _OP_SHR_INT; + ProcList[- OP_AND_INT_MI] := _OP_AND_INT; + ProcList[- OP_AND_INT_MM] := _OP_AND_INT; + ProcList[- OP_OR_INT_MI] := _OP_OR_INT; + ProcList[- OP_OR_INT_MM] := _OP_OR_INT; + ProcList[- OP_XOR_INT_MI] := _OP_XOR_INT; + ProcList[- OP_XOR_INT_MM] := _OP_XOR_INT; + ProcList[- OP_NEG_INT] := _OP_NEG_INT; + ProcList[- OP_NOT] := _OP_NOT; + ProcList[- OP_NOT_BOOL] := _OP_NOT_BOOL; + ProcList[- OP_NOT_BYTEBOOL] := _OP_NOT_BYTEBOOL; + ProcList[- OP_NOT_WORDBOOL] := _OP_NOT_WORDBOOL; + ProcList[- OP_NOT_LONGBOOL] := _OP_NOT_LONGBOOL; + ProcList[- OP_ABS_INT] := _OP_ABS_INT; + ProcList[- OP_GT_INT_MI] := _OP_GT_INT; + ProcList[- OP_GT_INT_MM] := _OP_GT_INT; + ProcList[- OP_GE_INT_MI] := _OP_GE_INT; + ProcList[- OP_GE_INT_MM] := _OP_GE_INT; + ProcList[- OP_LT_INT_MI] := _OP_LT_INT; + ProcList[- OP_LT_INT_MM] := _OP_LT_INT; + ProcList[- OP_LE_INT_MI] := _OP_LE_INT; + ProcList[- OP_LE_INT_MM] := _OP_LE_INT; + ProcList[- OP_EQ_INT_MI] := _OP_EQ_INT; + ProcList[- OP_EQ_INT_MM] := _OP_EQ_INT; + ProcList[- OP_NE_INT_MI] := _OP_NE_INT; + ProcList[- OP_NE_INT_MM] := _OP_NE_INT; + ProcList[- OP_INT_TO_DOUBLE] := _OP_INT_TO_DOUBLE; + ProcList[- OP_INT_TO_SINGLE] := _OP_INT_TO_SINGLE; + ProcList[- OP_INT_TO_EXTENDED] := _OP_INT_TO_EXTENDED; + ProcList[- OP_INT_TO_INT64] := _OP_INT_TO_INT64; + ProcList[- OP_BYTE_TO_INT64] := _OP_INT_TO_INT64; + ProcList[- OP_WORD_TO_INT64] := _OP_INT_TO_INT64; + ProcList[- OP_CARDINAL_TO_INT64] := _OP_INT_TO_INT64; + ProcList[- OP_SMALLINT_TO_INT64] := _OP_INT_TO_INT64; + ProcList[- OP_SHORTINT_TO_INT64] := _OP_INT_TO_INT64; + ProcList[- OP_INT_FROM_INT64] := _OP_INT_FROM_INT64; + ProcList[- OP_BYTE_FROM_INT64] := _OP_INT_FROM_INT64; + ProcList[- OP_WORD_FROM_INT64] := _OP_INT_FROM_INT64; + ProcList[- OP_CARDINAL_FROM_INT64] := _OP_INT_FROM_INT64; + ProcList[- OP_SMALLINT_FROM_INT64] := _OP_INT_FROM_INT64; + ProcList[- OP_SHORTINT_FROM_INT64] := _OP_INT_FROM_INT64; + ProcList[- OP_INT_TO_UINT64] := _OP_INT_TO_UINT64; + ProcList[- OP_BYTE_TO_UINT64] := _OP_INT_TO_UINT64; + ProcList[- OP_WORD_TO_UINT64] := _OP_INT_TO_UINT64; + ProcList[- OP_CARDINAL_TO_UINT64] := _OP_INT_TO_UINT64; + ProcList[- OP_SMALLINT_TO_UINT64] := _OP_INT_TO_UINT64; + ProcList[- OP_SHORTINT_TO_UINT64] := _OP_INT_TO_UINT64; + ProcList[- OP_INT_FROM_UINT64] := _OP_INT_FROM_UINT64; + ProcList[- OP_BYTE_FROM_UINT64] := _OP_INT_FROM_UINT64; + ProcList[- OP_WORD_FROM_UINT64] := _OP_INT_FROM_UINT64; + ProcList[- OP_CARDINAL_FROM_UINT64] := _OP_INT_FROM_UINT64; + ProcList[- OP_SMALLINT_FROM_UINT64] := _OP_INT_FROM_UINT64; + ProcList[- OP_SHORTINT_FROM_UINT64] := _OP_INT_FROM_UINT64; + + ProcList[- OP_ASSIGN_INT64] := _OP_ASSIGN_INT64; + ProcList[- OP_PUSH_INT64] := _OP_PUSH_INT; + ProcList[- OP_ADD_INT64] := _OP_ADD_INT64; + ProcList[- OP_SUB_INT64] := _OP_SUB_INT64; + ProcList[- OP_MULT_INT64] := _OP_MULT_INT64; + ProcList[- OP_IDIV_INT64] := _OP_IDIV_INT64; + ProcList[- OP_MOD_INT64] := _OP_MOD_INT64; + ProcList[- OP_SHL_INT64] := _OP_SHL_INT64; + ProcList[- OP_SHR_INT64] := _OP_SHR_INT64; + ProcList[- OP_AND_INT64] := _OP_AND_INT64; + ProcList[- OP_OR_INT64] := _OP_OR_INT64; + ProcList[- OP_XOR_INT64] := _OP_XOR_INT64; + ProcList[- OP_NEG_INT64] := _OP_NEG_INT64; + ProcList[- OP_ABS_INT64] := _OP_ABS_INT64; + ProcList[- OP_GT_INT64] := _OP_GT_INT64; + ProcList[- OP_GE_INT64] := _OP_GE_INT64; + ProcList[- OP_LT_INT64] := _OP_LT_INT64; + ProcList[- OP_LE_INT64] := _OP_LE_INT64; + ProcList[- OP_EQ_INT64] := _OP_EQ_INT64; + ProcList[- OP_NE_INT64] := _OP_NE_INT64; + ProcList[- OP_INT64_TO_DOUBLE] := _OP_INT64_TO_DOUBLE; + ProcList[- OP_INT64_TO_SINGLE] := _OP_INT64_TO_SINGLE; + ProcList[- OP_INT64_TO_EXTENDED] := _OP_INT64_TO_EXTENDED; + + ProcList[- OP_ASSIGN_UINT64] := _OP_ASSIGN_UINT64; + ProcList[- OP_ADD_UINT64] := _OP_ADD_UINT64; + ProcList[- OP_SUB_UINT64] := _OP_SUB_UINT64; + ProcList[- OP_AND_UINT64] := _OP_AND_UINT64; + ProcList[- OP_OR_UINT64] := _OP_OR_UINT64; + ProcList[- OP_XOR_UINT64] := _OP_XOR_UINT64; + ProcList[- OP_GT_UINT64] := _OP_GT_UINT64; + ProcList[- OP_GE_UINT64] := _OP_GE_UINT64; + ProcList[- OP_LT_UINT64] := _OP_LT_UINT64; + ProcList[- OP_LE_UINT64] := _OP_LE_UINT64; + ProcList[- OP_UINT64_TO_DOUBLE] := _OP_UINT64_TO_DOUBLE; + ProcList[- OP_UINT64_TO_SINGLE] := _OP_UINT64_TO_SINGLE; + ProcList[- OP_UINT64_TO_EXTENDED] := _OP_UINT64_TO_EXTENDED; + + ProcList[- OP_ASSIGN_DOUBLE] := _OP_ASSIGN_DOUBLE; + ProcList[- OP_PUSH_DOUBLE] := _OP_PUSH_INT; + ProcList[- OP_ADD_DOUBLE] := _OP_ADD_DOUBLE; + ProcList[- OP_SUB_DOUBLE] := _OP_SUB_DOUBLE; + ProcList[- OP_MUL_DOUBLE] := _OP_MUL_DOUBLE; + ProcList[- OP_DIV_DOUBLE] := _OP_DIV_DOUBLE; + ProcList[- OP_NEG_DOUBLE] := _OP_NEG_DOUBLE; + ProcList[- OP_ABS_DOUBLE] := _OP_ABS_DOUBLE; + ProcList[- OP_GT_DOUBLE] := _OP_GT_DOUBLE; + ProcList[- OP_GE_DOUBLE] := _OP_GE_DOUBLE; + ProcList[- OP_LT_DOUBLE] := _OP_LT_DOUBLE; + ProcList[- OP_LE_DOUBLE] := _OP_LE_DOUBLE; + ProcList[- OP_EQ_DOUBLE] := _OP_EQ_DOUBLE; + ProcList[- OP_NE_DOUBLE] := _OP_NE_DOUBLE; + ProcList[- OP_DOUBLE_TO_SINGLE] := _OP_DOUBLE_TO_SINGLE; + ProcList[- OP_DOUBLE_TO_EXTENDED] := _OP_DOUBLE_TO_EXTENDED; + + ProcList[- OP_ASSIGN_SINGLE] := _OP_ASSIGN_SINGLE; + ProcList[- OP_PUSH_SINGLE] := _OP_PUSH_INT; + ProcList[- OP_ADD_SINGLE] := _OP_ADD_SINGLE; + ProcList[- OP_SUB_SINGLE] := _OP_SUB_SINGLE; + ProcList[- OP_MUL_SINGLE] := _OP_MUL_SINGLE; + ProcList[- OP_DIV_SINGLE] := _OP_DIV_SINGLE; + ProcList[- OP_NEG_SINGLE] := _OP_NEG_SINGLE; + ProcList[- OP_ABS_SINGLE] := _OP_ABS_SINGLE; + ProcList[- OP_GT_SINGLE] := _OP_GT_SINGLE; + ProcList[- OP_GE_SINGLE] := _OP_GE_SINGLE; + ProcList[- OP_LT_SINGLE] := _OP_LT_SINGLE; + ProcList[- OP_LE_SINGLE] := _OP_LE_SINGLE; + ProcList[- OP_EQ_SINGLE] := _OP_EQ_SINGLE; + ProcList[- OP_NE_SINGLE] := _OP_NE_SINGLE; + ProcList[- OP_SINGLE_TO_DOUBLE] := _OP_SINGLE_TO_DOUBLE; + ProcList[- OP_SINGLE_TO_EXTENDED] := _OP_SINGLE_TO_EXTENDED; + + ProcList[- OP_ASSIGN_EXTENDED] := _OP_ASSIGN_EXTENDED; + ProcList[- OP_PUSH_EXTENDED] := _OP_PUSH_INT; + ProcList[- OP_ADD_EXTENDED] := _OP_ADD_EXTENDED; + ProcList[- OP_SUB_EXTENDED] := _OP_SUB_EXTENDED; + ProcList[- OP_MUL_EXTENDED] := _OP_MUL_EXTENDED; + ProcList[- OP_DIV_EXTENDED] := _OP_DIV_EXTENDED; + ProcList[- OP_NEG_EXTENDED] := _OP_NEG_EXTENDED; + ProcList[- OP_ABS_EXTENDED] := _OP_ABS_EXTENDED; + ProcList[- OP_GT_EXTENDED] := _OP_GT_EXTENDED; + ProcList[- OP_GE_EXTENDED] := _OP_GE_EXTENDED; + ProcList[- OP_LT_EXTENDED] := _OP_LT_EXTENDED; + ProcList[- OP_LE_EXTENDED] := _OP_LE_EXTENDED; + ProcList[- OP_EQ_EXTENDED] := _OP_EQ_EXTENDED; + ProcList[- OP_NE_EXTENDED] := _OP_NE_EXTENDED; + ProcList[- OP_EXTENDED_TO_DOUBLE] := _OP_EXTENDED_TO_DOUBLE; + ProcList[- OP_EXTENDED_TO_SINGLE] := _OP_EXTENDED_TO_SINGLE; + + ProcList[- OP_ASSIGN_CURRENCY] := _OP_ASSIGN_CURRENCY; + ProcList[- OP_PUSH_CURRENCY] := _OP_PUSH_INT; + ProcList[- OP_ADD_CURRENCY] := _OP_ADD_CURRENCY; + ProcList[- OP_SUB_CURRENCY] := _OP_SUB_CURRENCY; + ProcList[- OP_MUL_CURRENCY] := _OP_MUL_CURRENCY; + ProcList[- OP_DIV_CURRENCY] := _OP_DIV_CURRENCY; + ProcList[- OP_NEG_CURRENCY] := _OP_NEG_CURRENCY; + ProcList[- OP_ABS_CURRENCY] := _OP_ABS_CURRENCY; + ProcList[- OP_GT_CURRENCY] := _OP_GT_CURRENCY; + ProcList[- OP_GE_CURRENCY] := _OP_GE_CURRENCY; + ProcList[- OP_LT_CURRENCY] := _OP_LT_CURRENCY; + ProcList[- OP_LE_CURRENCY] := _OP_LE_CURRENCY; + ProcList[- OP_EQ_CURRENCY] := _OP_EQ_CURRENCY; + ProcList[- OP_NE_CURRENCY] := _OP_NE_CURRENCY; + ProcList[- OP_CURRENCY_TO_DOUBLE] := _OP_CURRENCY_TO_DOUBLE; + ProcList[- OP_CURRENCY_TO_SINGLE] := _OP_CURRENCY_TO_SINGLE; + ProcList[- OP_CURRENCY_TO_EXTENDED] := _OP_CURRENCY_TO_EXTENDED; + ProcList[- OP_CURRENCY_FROM_INT64] := _OP_CURRENCY_FROM_INT64; + ProcList[- OP_CURRENCY_FROM_UINT64] := _OP_CURRENCY_FROM_UINT64; + ProcList[- OP_CURRENCY_FROM_INT] := _OP_CURRENCY_FROM_INT; + ProcList[- OP_CURRENCY_FROM_REAL] := _OP_CURRENCY_FROM_REAL; + + ProcList[- OP_ASSIGN_VARIANT] := _OP_ASSIGN_VARIANT; +{$IFNDEF PAXARM} + ProcList[- OP_VARIANT_FROM_ANSICHAR] := _OP_VARIANT_FROM_ANSICHAR; + ProcList[- OP_VARIANT_FROM_PANSICHAR_LITERAL] := _OP_VARIANT_FROM_PANSICHAR; + ProcList[- OP_VARIANT_FROM_ANSISTRING] := _OP_VARIANT_FROM_ANSISTRING; + ProcList[- OP_VARIANT_FROM_WIDESTRING] := _OP_VARIANT_FROM_WIDESTRING; + ProcList[- OP_VARIANT_FROM_SHORTSTRING] := _OP_VARIANT_FROM_SHORTSTRING; +{$ENDIF} + ProcList[- OP_VARIANT_FROM_PWIDECHAR_LITERAL] := _OP_VARIANT_FROM_PWIDECHAR; + ProcList[- OP_VARIANT_FROM_UNICSTRING] := _OP_VARIANT_FROM_UNICSTRING; + ProcList[- OP_VARIANT_FROM_WIDECHAR] := _OP_VARIANT_FROM_WIDECHAR; + ProcList[- OP_VARIANT_FROM_WIDECHAR_LITERAL] := _OP_VARIANT_FROM_WIDECHAR; + ProcList[- OP_VARIANT_FROM_INT] := _OP_VARIANT_FROM_INT; + ProcList[- OP_VARIANT_FROM_CARDINAL] := _OP_VARIANT_FROM_INT; + ProcList[- OP_VARIANT_FROM_WORD] := _OP_VARIANT_FROM_INT; + ProcList[- OP_VARIANT_FROM_BYTE] := _OP_VARIANT_FROM_INT; + ProcList[- OP_VARIANT_FROM_SHORTINT] := _OP_VARIANT_FROM_INT; + ProcList[- OP_VARIANT_FROM_SMALLINT] := _OP_VARIANT_FROM_INT; + ProcList[- OP_VARIANT_FROM_INT64] := _OP_VARIANT_FROM_INT64; + ProcList[- OP_VARIANT_FROM_DOUBLE] := _OP_VARIANT_FROM_REAL; + ProcList[- OP_VARIANT_FROM_SINGLE] := _OP_VARIANT_FROM_REAL; + ProcList[- OP_VARIANT_FROM_EXTENDED] := _OP_VARIANT_FROM_REAL; + ProcList[- OP_VARIANT_FROM_CURRENCY] := _OP_VARIANT_FROM_CURRENCY; + ProcList[- OP_VARIANT_FROM_INTERFACE] := _OP_VARIANT_FROM_INTERFACE; + ProcList[- OP_VARIANT_FROM_BOOL] := _OP_VARIANT_FROM_BOOL; + ProcList[- OP_ADD_VARIANT] := _OP_ADD_VARIANT; + ProcList[- OP_SUB_VARIANT] := _OP_SUB_VARIANT; + ProcList[- OP_MULT_VARIANT] := _OP_MULT_VARIANT; + ProcList[- OP_DIV_VARIANT] := _OP_DIV_VARIANT; + ProcList[- OP_IDIV_VARIANT] := _OP_IDIV_VARIANT; + ProcList[- OP_NEG_VARIANT] := _OP_NEG_VARIANT; + ProcList[- OP_NOT_VARIANT] := _OP_NOT_VARIANT; + ProcList[- OP_ABS_VARIANT] := _OP_ABS_VARIANT; + ProcList[- OP_GT_VARIANT] := _OP_GT_VARIANT; + ProcList[- OP_GE_VARIANT] := _OP_GE_VARIANT; + ProcList[- OP_LT_VARIANT] := _OP_LT_VARIANT; + ProcList[- OP_LE_VARIANT] := _OP_LE_VARIANT; + ProcList[- OP_EQ_VARIANT] := _OP_EQ_VARIANT; + ProcList[- OP_NE_VARIANT] := _OP_NE_VARIANT; + ProcList[- OP_VARIANT_CLR] := _OP_VARIANT_CLR; + + ProcList[- OP_ASSIGN_OLEVARIANT] := _OP_ASSIGN_OLEVARIANT; + ProcList[- OP_OLEVARIANT_FROM_VARIANT] := _OP_ASSIGN_OLEVARIANT; +{$IFNDEF PAXARM} + ProcList[- OP_OLEVARIANT_FROM_ANSICHAR] := _OP_VARIANT_FROM_ANSICHAR; + ProcList[- OP_OLEVARIANT_FROM_PANSICHAR_LITERAL] := _OP_VARIANT_FROM_PANSICHAR; + ProcList[- OP_OLEVARIANT_FROM_ANSISTRING] := _OP_VARIANT_FROM_ANSISTRING; + ProcList[- OP_OLEVARIANT_FROM_WIDESTRING] := _OP_VARIANT_FROM_WIDESTRING; + ProcList[- OP_OLEVARIANT_FROM_SHORTSTRING] := _OP_VARIANT_FROM_SHORTSTRING; +{$ENDIF} + ProcList[- OP_OLEVARIANT_FROM_PWIDECHAR_LITERAL] := _OP_VARIANT_FROM_PWIDECHAR; + ProcList[- OP_OLEVARIANT_FROM_UNICSTRING] := _OP_VARIANT_FROM_UNICSTRING; + ProcList[- OP_OLEVARIANT_FROM_WIDECHAR] := _OP_VARIANT_FROM_WIDECHAR; + ProcList[- OP_OLEVARIANT_FROM_WIDECHAR_LITERAL] := _OP_VARIANT_FROM_WIDECHAR; + ProcList[- OP_OLEVARIANT_FROM_INT] := _OP_VARIANT_FROM_INT; + ProcList[- OP_OLEVARIANT_FROM_CARDINAL] := _OP_VARIANT_FROM_INT; + ProcList[- OP_OLEVARIANT_FROM_WORD] := _OP_VARIANT_FROM_INT; + ProcList[- OP_OLEVARIANT_FROM_BYTE] := _OP_VARIANT_FROM_INT; + ProcList[- OP_OLEVARIANT_FROM_SHORTINT] := _OP_VARIANT_FROM_INT; + ProcList[- OP_OLEVARIANT_FROM_SMALLINT] := _OP_VARIANT_FROM_INT; + ProcList[- OP_OLEVARIANT_FROM_INT64] := _OP_VARIANT_FROM_INT64; + ProcList[- OP_OLEVARIANT_FROM_DOUBLE] := _OP_VARIANT_FROM_REAL; + ProcList[- OP_OLEVARIANT_FROM_SINGLE] := _OP_VARIANT_FROM_REAL; + ProcList[- OP_OLEVARIANT_FROM_EXTENDED] := _OP_VARIANT_FROM_REAL; + ProcList[- OP_OLEVARIANT_FROM_CURRENCY] := _OP_VARIANT_FROM_CURRENCY; + ProcList[- OP_OLEVARIANT_FROM_INTERFACE] := _OP_OLEVARIANT_FROM_INTERFACE; + ProcList[- OP_OLEVARIANT_FROM_BOOL] := _OP_VARIANT_FROM_BOOL; + + ProcList[- OP_WIDECHAR_FROM_VARIANT] := _OP_X_FROM_VARIANT; +{$IFNDEF PAXARM} + ProcList[- OP_ANSICHAR_FROM_VARIANT] := _OP_X_FROM_VARIANT; + ProcList[- OP_ANSISTRING_FROM_VARIANT] := _OP_X_FROM_VARIANT; + ProcList[- OP_WIDESTRING_FROM_VARIANT] := _OP_X_FROM_VARIANT; + ProcList[- OP_UNICSTRING_FROM_VARIANT] := _OP_X_FROM_VARIANT; + ProcList[- OP_SHORTSTRING_FROM_VARIANT] := _OP_X_FROM_VARIANT; +{$ENDIF} + ProcList[- OP_DOUBLE_FROM_VARIANT] := _OP_X_FROM_VARIANT; + ProcList[- OP_CURRENCY_FROM_VARIANT] := _OP_X_FROM_VARIANT; + ProcList[- OP_SINGLE_FROM_VARIANT] := _OP_X_FROM_VARIANT; + ProcList[- OP_EXTENDED_FROM_VARIANT] := _OP_X_FROM_VARIANT; + ProcList[- OP_INT64_FROM_VARIANT] := _OP_X_FROM_VARIANT; + ProcList[- OP_UINT64_FROM_VARIANT] := _OP_X_FROM_VARIANT; + ProcList[- OP_INT_FROM_VARIANT] := _OP_X_FROM_VARIANT; + ProcList[- OP_BYTE_FROM_VARIANT] := _OP_X_FROM_VARIANT; + ProcList[- OP_WORD_FROM_VARIANT] := _OP_X_FROM_VARIANT; + ProcList[- OP_CARDINAL_FROM_VARIANT] := _OP_X_FROM_VARIANT; + ProcList[- OP_BOOL_FROM_VARIANT] := _OP_X_FROM_VARIANT; + ProcList[- OP_BYTEBOOL_FROM_VARIANT] := _OP_X_FROM_VARIANT; + ProcList[- OP_WORDBOOL_FROM_VARIANT] := _OP_X_FROM_VARIANT; + ProcList[- OP_LONGBOOL_FROM_VARIANT] := _OP_X_FROM_VARIANT; + ProcList[- OP_SMALLINT_FROM_VARIANT] := _OP_X_FROM_VARIANT; + ProcList[- OP_SHORTINT_FROM_VARIANT] := _OP_X_FROM_VARIANT; + + ProcList[- OP_BOOL_FROM_BYTEBOOL] := _OP_BOOL_FROM_INT; + ProcList[- OP_BOOL_FROM_WORDBOOL] := _OP_BOOL_FROM_INT; + ProcList[- OP_BOOL_FROM_LONGBOOL] := _OP_BOOL_FROM_INT; + + ProcList[- OP_ASSIGN_INTERFACE] := _OP_ASSIGN_INTERFACE; + ProcList[- OP_INTERFACE_CLR] := _OP_INTERFACE_CLR; + ProcList[- OP_INTERFACE_FROM_CLASS] := _OP_INTERFACE_FROM_CLASS; + ProcList[- OP_INTERFACE_CAST] := _OP_INTERFACE_CAST; + + ProcList[- OP_ASSIGN_TVarRec] := _OP_ASSIGN_TVarRec; + + ProcList[- OP_ASSIGN_RECORD] := _OP_ASSIGN_RECORD; + ProcList[- OP_PUSH_STRUCTURE] := _OP_PUSH_STRUCTURE; + ProcList[- OP_EQ_STRUCT] := _OP_EQ_STRUCT; + ProcList[- OP_NE_STRUCT] := _OP_NE_STRUCT; + ProcList[- OP_STRUCTURE_CLR] := _OP_STRUCTURE_CLR; +// ProcList[- OP_STRUCTURE_ADDREF] := _OP_STRUCTURE_ADDREF; + + ProcList[- OP_ASSIGN_ARRAY] := _OP_ASSIGN_RECORD; + + ProcList[- OP_PUSH_DATA] := _OP_PUSH_DATA; + ProcList[- OP_PUSH_EVENT] := _OP_PUSH_INT; + + ProcList[- OP_EQ_EVENT] := _OP_EQ_STRUCT; + ProcList[- OP_NE_EVENT] := _OP_NE_STRUCT; + + ProcList[- OP_DYNARRAY_ASSIGN] := _OP_DYNARRAY_ASSIGN; + ProcList[- OP_PUSH_DYNARRAY] := _OP_PUSH_INT; + ProcList[- OP_PUSH_OPENARRAY] := _OP_PUSH_INT; + ProcList[- OP_DYNARRAY_CLR] := _OP_DYNARRAY_CLR; + ProcList[- OP_CREATE_EMPTY_DYNARRAY] := _OP_CREATE_EMPTY_DYNARRAY; + + ProcList[- OP_SET_ASSIGN] := _OP_SET_ASSIGN; + ProcList[- OP_SET_COUNTER_ASSIGN] := _OP_SET_COUNTER_ASSIGN; + ProcList[- OP_PUSH_SET] := _OP_PUSH_INT; + ProcList[- OP_SET_UNION] := _OP_SET_UNION; + ProcList[- OP_SET_DIFFERENCE] := _OP_SET_DIFFERENCE; + ProcList[- OP_SET_INTERSECTION] := _OP_SET_INTERSECTION; + ProcList[- OP_SET_INCLUDE] := _OP_SET_INCLUDE; + ProcList[- OP_SET_INCLUDE_INTERVAL] := _OP_SET_INCLUDE_INTERVAL; + ProcList[- OP_SET_SUBSET] := _OP_SET_SUBSET; + ProcList[- OP_SET_SUPERSET] := _OP_SET_SUPERSET; + ProcList[- OP_SET_EQUALITY] := _OP_SET_EQUALITY; + ProcList[- OP_SET_INEQUALITY] := _OP_SET_INEQUALITY; + ProcList[- OP_SET_MEMBERSHIP] := _OP_SET_MEMBERSHIP; + + ProcList[- OP_PRINT_EX] := _OP_PRINT_EX; + ProcList[- OP_GO_DL] := _OP_GO_DL; + ProcList[- OP_GO] := _OP_GO; + ProcList[- OP_GO_FALSE] := _OP_GO_FALSE; + ProcList[- OP_GO_TRUE] := _OP_GO_TRUE; + ProcList[- OP_BEGIN_CALL] := _OP_BEGIN_CALL; + ProcList[- OP_GET_VMT_ADDRESS] := _OP_GET_VMT_ADDRESS; + ProcList[- OP_ADDRESS] := _OP_ADDRESS; + ProcList[- OP_TERMINAL] := _OP_TERMINAL; + ProcList[- OP_TYPEINFO] := _OP_TYPEINFO; + ProcList[- OP_CALL] := _OP_CALL; + ProcList[- OP_CALL_INHERITED] := _OP_CALL; + ProcList[- OP_INIT_SUB] := _OP_INIT_SUB; + ProcList[- OP_END_SUB] := _OP_END_SUB; + ProcList[- OP_SET_LENGTH] := _OP_SET_LENGTH; + ProcList[- OP_PUSH_LENGTH] := _OP_PUSH_LENGTH; + ProcList[- OP_SET_LENGTH_EX] := _OP_SET_LENGTH_EX; + ProcList[- OP_FIELD] := _OP_FIELD; + ProcList[- OP_ELEM] := _OP_ELEM; + ProcList[- OP_GET_COMPONENT] := _OP_GET_COMPONENT; + ProcList[- OP_INIT_FWARRAY] := _OP_INIT_FWARRAY; + ProcList[- OP_PUSH_ADDRESS] := _OP_PUSH_ADDRESS; + ProcList[- OP_PUSH_INST] := _OP_PUSH_INST; + ProcList[- OP_PUSH_CLSREF] := _OP_PUSH_CLSREF; + ProcList[- OP_CREATE_OBJECT] := _OP_CREATE_OBJECT; + ProcList[- OP_ONCREATE_OBJECT] := _OP_ONCREATE_OBJECT; + ProcList[- OP_ONCREATE_HOST_OBJECT] := _OP_ONCREATE_HOST_OBJECT; + ProcList[- OP_ON_AFTER_OBJECT_CREATION] := _OP_ONAFTER_OBJECT_CREATION; + + ProcList[- OP_BEFORE_CALL_HOST] := _OP_BEFORE_CALL_HOST; + ProcList[- OP_AFTER_CALL_HOST] := _OP_AFTER_CALL_HOST; + + ProcList[- OP_CHECK_PAUSE] := _OP_CHECK_PAUSE; + ProcList[- OP_PAUSE] := _OP_PAUSE; + + +{$ifdef DRTTI} + ProcList[- OP_VAR_FROM_TVALUE] := _OP_VAR_FROM_TVALUE; + ProcList[- OP_GET_DRTTI_PROP] := _OP_GET_DRTTI_PROP; + ProcList[- OP_SET_DRTTI_PROP] := _OP_SET_DRTTI_PROP; +{$endif} + + ProcList[- OP_GET_ORD_PROP] := _OP_GET_ORD_PROP; +{$IFNDEF PAXARM} + ProcList[- OP_GET_ANSISTR_PROP] := _OP_GET_ANSISTR_PROP; + ProcList[- OP_GET_WIDESTR_PROP] := _OP_GET_WIDESTR_PROP; +{$ENDIF} + ProcList[- OP_GET_UNICSTR_PROP] := _OP_GET_UNICSTR_PROP; + ProcList[- OP_GET_INTERFACE_PROP] := _OP_GET_INTERFACE_PROP; + ProcList[- OP_GET_VARIANT_PROP] := _OP_GET_VARIANT_PROP; + ProcList[- OP_GET_INT64_PROP] := _OP_GET_INT64_PROP; + ProcList[- OP_GET_FLOAT_PROP] := _OP_GET_FLOAT_PROP; + ProcList[- OP_GET_EVENT_PROP] := _OP_GET_EVENT_PROP; + ProcList[- OP_GET_SET_PROP] := _OP_GET_SET_PROP; + + ProcList[- OP_SET_ORD_PROP] := _OP_SET_ORD_PROP; +{$IFNDEF PAXARM} + ProcList[- OP_SET_ANSISTR_PROP] := _OP_SET_ANSISTR_PROP; + ProcList[- OP_SET_WIDESTR_PROP] := _OP_SET_WIDESTR_PROP; +{$ENDIF} + ProcList[- OP_SET_UNICSTR_PROP] := _OP_SET_UNICSTR_PROP; + ProcList[- OP_SET_INTERFACE_PROP] := _OP_SET_INTERFACE_PROP; + ProcList[- OP_SET_VARIANT_PROP] := _OP_SET_VARIANT_PROP; + ProcList[- OP_SET_INT64_PROP] := _OP_SET_INT64_PROP; + ProcList[- OP_SET_FLOAT_PROP] := _OP_SET_FLOAT_PROP; + ProcList[- OP_SET_EVENT_PROP] := _OP_SET_EVENT_PROP; + ProcList[- OP_SET_EVENT_PROP2] := _OP_SET_EVENT_PROP2; + ProcList[- OP_SET_SET_PROP] := _OP_SET_SET_PROP; + + ProcList[- OP_TRY_ON] := _OP_TRY_ON; + ProcList[- OP_TRY_OFF] := _OP_TRY_OFF; + ProcList[- OP_BEGIN_EXCEPT_BLOCK] := _OP_BEGIN_EXCEPT_BLOCK; + ProcList[- OP_END_EXCEPT_BLOCK] := _OP_END_EXCEPT_BLOCK; + ProcList[- OP_COND_RAISE] := _OP_COND_RAISE; + ProcList[- OP_EXIT] := _OP_EXIT; + ProcList[- OP_HALT] := _OP_HALT; + ProcList[- OP_RAISE] := _OP_RAISE; + + ProcList[- OP_TO_JS_OBJECT] := _OP_TO_JS_OBJECT; + ProcList[- OP_JS_TYPEOF] := _OP_JS_TYPEOF; + ProcList[- OP_PUSH_CONTEXT] := _OP_PUSH_CONTEXT; + ProcList[- OP_POP_CONTEXT] := _OP_POP_CONTEXT; + ProcList[- OP_FIND_CONTEXT] := _OP_FIND_CONTEXT; + ProcList[- OP_FIND_JS_FUNC] := _OP_FIND_JS_FUNC; + ProcList[- OP_JS_FUNC_OBJ_FROM_VARIANT] := _OP_JS_FUNC_OBJ_FROM_VARIANT; + ProcList[- OP_ADDRESS_PROG] := _OP_ADDRESS_PROG; + ProcList[- OP_ASSIGN_PROG] := _OP_ASSIGN_PROG; + ProcList[- OP_GET_NEXTJSPROP] := _OP_GET_NEXTJSPROP; + ProcList[- OP_CLEAR_REFERENCES] := _OP_CLEAR_REFERENCES; + ProcList[- OP_CLASS_CLR] := _OP_CLASS_CLR; + ProcList[- OP_VARIANT_FROM_CLASS] := _OP_VARIANT_FROM_CLASS; + ProcList[- OP_VARIANT_FROM_POINTER] := _OP_VARIANT_FROM_POINTER; + ProcList[- OP_CLASS_FROM_VARIANT] := _OP_CLASS_FROM_VARIANT; +{$IFNDEF PAXARM} + ProcList[- OP_ANSISTRING_FROM_INT] := _OP_ANSISTRING_FROM_INT; + ProcList[- OP_ANSISTRING_FROM_DOUBLE] := _OP_ANSISTRING_FROM_DOUBLE; + ProcList[- OP_ANSISTRING_FROM_SINGLE] := _OP_ANSISTRING_FROM_SINGLE; + ProcList[- OP_ANSISTRING_FROM_EXTENDED] := _OP_ANSISTRING_FROM_EXTENDED; + ProcList[- OP_ANSISTRING_FROM_BOOLEAN] := _OP_ANSISTRING_FROM_BOOLEAN; +{$ENDIF} + ProcList[- OP_UNICSTRING_FROM_INT] := _OP_UNICSTRING_FROM_INT; + ProcList[- OP_UNICSTRING_FROM_DOUBLE] := _OP_UNICSTRING_FROM_DOUBLE; + ProcList[- OP_UNICSTRING_FROM_SINGLE] := _OP_UNICSTRING_FROM_SINGLE; + ProcList[- OP_UNICSTRING_FROM_EXTENDED] := _OP_UNICSTRING_FROM_EXTENDED; + ProcList[- OP_UNICSTRING_FROM_BOOLEAN] := _OP_UNICSTRING_FROM_BOOLEAN; + + ProcList[- OP_OLE_SET] := _OP_OLE_SET; + ProcList[- OP_OLE_GET] := _OP_OLE_GET; + ProcList[- OP_OLE_PARAM] := _OP_OLE_PARAM; + + N := 1; +end; + +destructor TIRunner.Destroy; +var + I: Integer; +begin + for I := 0 to A.Count - 1 do +{$IFDEF ARC} + A[I] := nil; +{$ELSE} + TIRunRec(A[I]).Free; +{$ENDIF} + FreeAndNil(A); + + if Assigned(fCurrException) then + FreeAndNil(fCurrException); + + FreeAndNil(OleParamList); + FreeAndNil(VarParamList); + FreeAndNil(LengthList); + FreeAndNil(fCallStack); + FreeAndNil(fOuterMostStack); + FreeAndNil(ExtraDataList); + FreeAndNil(TryList); + FreeAndNil(fTryStack); + + Deallocate; + + inherited; +end; + +procedure TIRunner.Reset; +var + I: Integer; +begin + inherited; + + for I := 0 to A.Count - 1 do +{$IFDEF ARC} + A[I] := nil; +{$ELSE} + TIRunRec(A[I]).Free; +{$ENDIF} + A.Clear; + AddRecord; + + OleParamList.Clear; + VarParamList.Clear; + LengthList.Clear; + fCallStack.Clear; + fOuterMostStack.Clear; + ExtraDataList.Reset; + TryList.Clear; + fTryStack.Clear; + + fPaused := false; +end; + +function TIRunner.NeedAllocAll: Boolean; +begin + result := true; +end; + +procedure TIRunner.Deallocate; +begin + if DataPtr <> nil then + if DataSize > 0 then + begin + FreeMem(DataPtr, DataSize); + Data := nil; + DataSize := 0; + end; +end; + +function TIRunner.GetProgramSize: Integer; +begin + result := GetImageSize; +end; + +function TIRunner.GetRootRunner: TIRunner; +begin + result := TIRunner(GetRootProg); +end; + +function TIRunner.GetRootCallStack: TICallStack; +begin + result := RootRunner.fCallStack; +end; + +function TIRunner.GetRootOuterMostStack: TIntegerStack; +begin + result := RootRunner.fOuterMostStack; +end; + +function TIRunner.GetRootTryStack: TITryStack; +begin + result := RootRunner.fTryStack; +end; + +function TIRunner.GetParamAddress(Offset: Integer): Pointer; +var + R: TICallRec; +begin + R := RootCallStack.Top; + result := Pointer(R.ROffset + Offset); +end; + +function TIRunner.GetLocalAddress(Offset: Integer): Pointer; +var + R: TICallRec; +begin + R := RootCallStack.Top; + result := Pointer(R.ROffset + Offset); +end; + +function TIRunner.GetParamAddress(StackFrameNumber, Offset: Integer): Pointer; +var + R: TICallRec; +begin + R := RootCallStack[StackFrameNumber]; + result := Pointer(R.ROffset + Offset); +end; + +function TIRunner.GetLocalAddress(StackFrameNumber, Offset: Integer): Pointer; +var + R: TICallRec; +begin + R := RootCallStack[StackFrameNumber]; + result := Pointer(R.ROffset + Offset); +end; + +function TIRunner.AddSubExtraData(I: Integer; Id: Integer): TISubExtraData; +begin + result := ExtraDataList.AddSubRecord(Id); + Records[I].ExtraDataIndex := ExtraDataList.Count - 1; +end; + +function TIRunner.AddArrExtraData(I: Integer; Id: Integer): TIArrExtraData; +begin + result := ExtraDataList.AddArrRecord(Id); + Records[I].ExtraDataIndex := ExtraDataList.Count - 1; +end; + +function TIRunner.AddStructExtraData(I: Integer; Id: Integer): TIStructExtraData; +begin + result := ExtraDataList.AddStructRecord(Id); + Records[I].ExtraDataIndex := ExtraDataList.Count - 1; +end; + +function TIRunner.AddEventExtraData(I: Integer; Id: Integer): TIEventExtraData; +begin + result := ExtraDataList.AddEventRecord(Id); + Records[I].ExtraDataIndex := ExtraDataList.Count - 1; +end; + +procedure TIRunner.RaiseError(const Message: string; params: array of Const); +begin + raise Exception.Create(Format(Message, params)) +end; + +function TIRunner.GetCard: Integer; +begin + result := A.Count - 1; +end; + +function TIRunner.AddRecord: TIRunRec; +begin + result := TIRunRec.Create; + A.Add(result); +end; + +function TIRunner.GetRecord(I: Integer): TIRunRec; +begin + result := TIRunRec(A[I]); +end; + +procedure TIRunner.SaveCodeToStream(S: TStream); +var + I, K: Integer; +begin + K := Card; + S.Write(K, SizeOf(K)); + for I := 1 to K do + Records[I].SaveToStream(S); + ExtraDataList.SaveToStream(S); + SaveIntDynarrayToStream(ByteCodeGlobalEntryList, S); +end; + +procedure TIRunner.LoadCodeFromStream(S: TStream); +var + I, K: Integer; + R: TIRunRec; +begin + S.Read(K, SizeOf(K)); + for I := 1 to K do + begin + R := AddRecord; + R.LoadFromStream(S); + end; + ExtraDataList.LoadFromStream(S); + ByteCodeGlobalEntryList := LoadIntDynarrayFromStream(S); +end; + +procedure TIRunner.SaveToStream(S: TStream); +var + StartSize, EndSize, StartPos, EndPos, StreamSize: Integer; + CustomDataSize, CustomDataSizePos, temp: Integer; + ST: String; +begin + StartSize := S.Size; + StartPos := S.Position; + + S.Write(StreamSize, SizeOf(Integer)); + S.Write(CompiledScriptVersion, SizeOf(CompiledScriptVersion)); + +{$IFNDEF PAXARM} + ST := TIRunner.ClassName; + SaveShortStringToStream(ShortString(ST), S); +{$ENDIF} + + CustomDataSize := 0; + CustomDataSizePos := S.Position; + S.Write(CustomDataSize, SizeOf(Integer)); + if Assigned(OnSaveToStream) and IsRootProg then + begin + OnSaveToStream(Owner, S); + CustomDataSize := S.Position - CustomDataSizePos - 4; + if CustomDataSize > 0 then + begin + temp := S.Position; + S.Position := CustomDataSizePos; + S.Write(CustomDataSize, SizeOf(Integer)); + S.Position := temp; + end + else + begin + CustomDataSize := 0; + S.Position := CustomDataSizePos; + S.Write(CustomDataSize, SizeOf(Integer)); + end; + end; + + S.Write(DataSize, SizeOf(Integer)); + S.Write(fCodeSize, SizeOf(Integer)); + + fImageDataPtr := S.Position - StartPos; + + S.Write(Data^, DataSize); + + SaveCodeToStream(S); + + S.Write(JS_Record, SizeOf(JS_Record)); + + S.Write(ModeSEH, SizeOf(ModeSEH)); + S.Write(PAX64, SizeOf(PAX64)); + + S.Write(PCULang, SizeOf(PCULang)); + + ClassList.SaveToStream(S); + RunTimeModuleList.SaveToStream(S); + TryList.SaveToStream(S); + + HostMapTable.SaveToStream(S); + ScriptMapTable.SaveToStream(S); + OffsetList.SaveToStream(S); + ExportList.SaveToStream(S); + MessageList.SaveToStream(S); + ProgTypeInfoList.SaveToStream(S); + + ProgList.SaveToStream(S); + + EndSize := S.Size; + EndPos := S.Position; + StreamSize := EndSize - StartSize; + S.Position := StartPos; + S.Write(StreamSize, SizeOf(Integer)); + S.Position := EndPos; +end; + +procedure TIRunner.LoadFromStream(S: TStream); +var + Version: Integer; + K: Integer; + CustomDataSize, temp: Integer; + P: Pointer; +{$IFNDEF PAXARM} + SS: ShortString; + {$ENDIF} +begin + Deallocate; + S.Read(K, SizeOf(Integer)); + S.Read(Version, SizeOf(CompiledScriptVersion)); + if Version <> CompiledScriptVersion then + RaiseError(errIncorrectCompiledScriptVersion, []); + +{$IFNDEF PAXARM} + SS := LoadShortStringFromStream(S); + if not StrEql(String(SS), TIRunner.ClassName) then + RaiseError(errIncorrectCompiledScriptVersion, []); +{$ENDIF} + + S.Read(CustomDataSize, SizeOf(Integer)); + if Assigned(OnLoadFromStream) and IsRootProg then + begin + temp := S.Position; + OnLoadFromStream(Owner, S); + if S.Position - temp <> CustomDataSize then + RaiseError(errIncorrectCustomDataSize, []); + end + else + if CustomDataSize > 0 then + begin + P := AllocMem(CustomDataSize); + try + S.Read(P^, CustomDataSize); + finally + FreeMem(P, CustomDataSize); + end; + end; + + S.Read(fDataSize, SizeOf(Integer)); + S.Read(fCodeSize, SizeOf(Integer)); + + Data := AllocMem(fDataSize); + S.Read(Data^, fDataSize); + LoadCodeFromStream(S); + + S.Read(JS_Record, SizeOf(JS_Record)); + + S.Read(ModeSEH, SizeOf(ModeSEH)); + S.Read(PAX64, SizeOf(PAX64)); + if GENERICS_ALLOWED then + S.Read(PCULang, SizeOf(PCULang)); + + ClassList.Clear; + ClassList.LoadFromStream(S, Version); + + RunTimeModuleList.Clear; + RunTimeModuleList.LoadFromStream(S); + TryList.Clear; + TryList.LoadFromStream(S); + + HostMapTable.Clear; + HostMapTable.LoadFromStream(S); + ScriptMapTable.Clear; + ScriptMapTable.LoadFromStream(S); + + OffsetList.Clear; + OffsetList.LoadFromStream(S); + ExportList.Clear; + ExportList.LoadFromStream(S); + MessageList.Clear; + MessageList.LoadFromStream(S); + ProgTypeInfoList.Clear; + ProgTypeInfoList.LoadFromStream(S); + + ProgList.Clear; + ProgList.LoadFromStream(S, Self); + ProgList.SetPCUOwner(Self); + + UseMapping := HostMapTable.Count > 0; + + SetAddress(H_SelfPtr, Self); + SetAddress(H_ExceptionPtr, @ fCurrException); + + RegisterDefinitions(GlobalSym); + if UseMapping then + begin + FreeAndNil(LocalSymbolTable); + LocalSymbolTable := TProgSymbolTable.Create(GlobalSym); + + LocalSymbolTable.Reset; + RegisterDefinitions(LocalSymbolTable); + end; + + SetupInterfaces(CodePtr); + + ProgClassFactory.ForceCreate := true; +end; + +function TIRunner.GetByteCodeLine: Integer; +begin + result := N; + if result > Card then + result := Card; +end; + +function TIRunner.GetCallStackCount: Integer; +begin + result := RootCallStack.Count; +end; + +function TIRunner.GetCallStackItem(I: Integer): Integer; +begin + if (I >= 0) and (I < GetCallStackCount) then + result := RootCallStack[I].SubId + else + result := 0; +end; + +function TIRunner.GetCallStackLineNumber(I: Integer): Integer; +var + N: Integer; +begin + if (I >= 0) and (I < GetCallStackCount) then + begin + N := RootCallStack[I].NCall; + if (N = -1) or (N = MaxInt - 1) then + begin + N := GetByteCodeLine; + RootCallStack[I].NCall := N; + end; + + result := RunTimeModuleList.GetSourceLine(N); + end + else + result := 0; +end; + +function TIRunner.GetCallStackModuleName(I: Integer): String; +var + N: Integer; +begin + result := ''; + if (I >= 0) and (I < GetCallStackCount) then + begin + N := RootCallStack[I].NCall; + if (N = -1) or (N = MaxInt - 1) then + Exit; + result := RunTimeModuleList.GetModuleName(N); + end; +end; + +function TIRunner.GetCallStackModuleIndex(I: Integer): Integer; +var + N: Integer; +begin + result := -1; + if (I >= 0) and (I < GetCallStackCount) then + begin + N := RootCallStack[I].NCall; + if (N = -1) or (N = MaxInt - 1) then + Exit; + result := RunTimeModuleList.GetModuleIndex(N); + end; +end; + +procedure TIRunner.InitStringLiterals; +var + I, Op: Integer; + P: Pointer; + R: TIRunRec; +begin + for I := 1 to Card do + begin + R := Records[I]; + Op := R.Op; +{$IFNDEF PAXARM} + if Op = OP_INIT_PANSICHAR_LITERAL then + begin + P := LoadAddress(R.A1); + P := ShiftPointer(P, 12); + SaveIntVal(IntPax(P), R.A1); + end + else +{$ENDIF} + if Op = OP_INIT_PWIDECHAR_LITERAL then + begin + P := LoadAddress(R.A1); + P := ShiftPointer(P, 8); + SaveIntVal(IntPax(P), R.A1); + end; + end; +end; + +function TIRunner.GetGlobalAddress(PA: TIArg): Pointer; +begin + result := Pointer(IntPax(Data) + PA.Offset); + if PA.ByRef then + result := Pointer(result^); +end; + +function TIRunner.GetLocalAddress(PA: TIArg): Pointer; +var + ACallRec: TICallRec; +begin + if TopCallRec.LocalFrame = nil then + ACallRec := RootCallStack.Prev + else + ACallRec := TopCallRec; + + if ACallRec.SubId <> PA.Level then + ACallRec := RootCallStack.GetBySubId(PA.Level); + result := Pointer(ACallRec.ROffset + PA.Offset); + if PA.ByRef then + result := Pointer(result^); +end; + +procedure TIRunner.SetGlobalAddresses; +var + P: Pointer; +begin + P := ShiftPointer(Data, H_ExceptionPtr); + Pointer(P^) := @ CurrException; +end; + +function TIRunner.LoadAddress(const Arg: TIArg): Pointer; +begin + if Arg.Local then + result := GetLocalAddress(Arg) + else + result := GetGlobalAddress(Arg); +end; + +function TIRunner.LoadAddress1: Pointer; +begin + result := LoadAddress(RR.A1); +end; + +function TIRunner.LoadAddress2: Pointer; +begin + result := LoadAddress(RR.A2); +end; + +function TIRunner.LoadAddressR: Pointer; +begin + result := LoadAddress(RR.AR); +end; + +function TIRunner.LoadIntVal(const Arg: TIArg): IntPax; +var + P: Pointer; +begin + P := LoadAddress(Arg); + case Arg.PtrSize of + 1: result := ShortInt(P^); + 2: result := SmallInt(P^); + 4: result := Integer(P^); + 8: result := Int64(P^); + 16: result := Int64(P^); + else + result := 0; + end; +end; + +function TIRunner.LoadIntVal1: IntPax; +begin + result := LoadIntVal(RR.A1); +end; + +function TIRunner.LoadIntVal2: IntPax; +begin + result := LoadIntVal(RR.A2); +end; + +procedure TIRunner.SaveIntVal(value: IntPax; var Arg: TIArg); +var + P: Pointer; +begin + P := LoadAddress(Arg); + case Arg.PtrSize of + 1: ShortInt(P^) := value; + 2: SmallInt(P^) := value; + 4: Integer(P^) := value; + 8: Int64(P^) := value; + end; +end; + +procedure TIRunner.SavePointer(value: Pointer; var Arg: TIArg); +var + P: Pointer; + temp: Boolean; +begin + temp := Arg.ByRef; + Arg.ByRef := false; + P := LoadAddress(Arg); + Arg.ByRef := temp; + Pointer(P^) := value; +end; + +procedure TIRunner.CallJavaScriptFunction; +var + ExtraData: TISubExtraData; + F: TJS_Function; + I: Integer; +{$IFNDEF PAXARM_DEVICE} + Invoke: TPaxInvoke; +{$ENDIF} + P, Dest: Pointer; + NN: IntPax; +begin + F := TJS_Function(TopCallRec.This); + NN := IntPax(F.InternalFuncAddr); + + if NN = 0 then + begin + Inc(N); + Exit; + end; + + if F.__this <> nil then + TopCallRec.This := F.__this; + + if NativeAddress(Pointer(NN)) then + begin + Dest := LoadAddressR; + + for I := 0 to TopCallRec.NP - 1 do + TopCallRec.ParamList[I] := TopCallRec.ParamList[I+1]; +{$IFDEF PAXARM_DEVICE} +{$ELSE} + Invoke := TPaxInvoke.Create(nil); + try + for I := 0 to F.InternalLength - 1 do + begin + P := TopCallRec.ParamList[I].Address; + Invoke.AddArgAsPointer(P); + end; + Invoke.SetResultAsVariant(Dest); + Invoke.This := F.__this; + Invoke.CallConv := TopCallRec.ED.CallConv; + Invoke.Address := Pointer(NN); + Invoke.CallHost; + finally + Inc(N); + FreeAndNil(Invoke); + end; +{$ENDIF} + Exit; + end; + + N := NN; + + ExtraData := ExtraDataList[Records[N].ExtraDataIndex] as TISubExtraData; + + TopCallRec.SubId := ExtraData.Id; + TopCallRec.NP := ExtraData.Count; + TopCallRec.Host := false; + + if RR.AR.Id <> 0 then + begin + TopCallRec.ResAddress := LoadAddressR; + TopCallRec.PtrSize := RR.AR.PtrSize; + end; + + for I := 0 to TopCallRec.NP - 1 do + TopCallRec.ParamList[I] := TopCallRec.ParamList[I+1]; +end; + +{$IFDEF DRTTI} +procedure TIRunner.CallRTTIMethod(Address: Pointer); +var + ExtraData: TISubExtraData; + I, NP: Integer; + Args: array of TValue; + X: TObject; + C: TClass; + V: TValue; + m: TRTTIMethod; + P, buff: Pointer; + PParamDescRec: PIParamDescRec; + param: TRTTIParameter; +begin + ExtraData := TopCallRec.ED; + TopCallRec.NCall := N; + + m := ExtraData.rtti_method; + NP := System.Length(m.GetParameters); + + try + SetLength(Args, NP); + + I := -1; + for param in m.GetParameters do + begin + Inc(I); + P := TopCallRec.ParamList[I].Address; + TValue.MakeWithoutCopy(P, param.ParamType.Handle, Args[I]); + end; + + if m.IsConstructor then + begin + if Records[N].Op = OP_CALL_INHERITED then + begin + X := TObject(TopCallRec.This); + V := X; + end + else + begin + C := TClass(TopCallRec.This); + V := C; + end; + V := m.Invoke(V, Args); + end + else if m.IsDestructor then + begin + X := TObject(TopCallRec.This); + + if IsPaxClass(X.ClassType) then + begin + C := GetHostParentClass(X.ClassType); + buff := AllocMem(C.InstanceSize); + Move(Pointer(X)^, buff^, C.InstanceSize); + Pointer(buff^) := C; + m.Invoke(TObject(buff), Args); + C := X.ClassType; + FreeMem(Pointer(X), C.InstanceSize); + if Assigned(OnAfterObjectDestruction) then + OnAfterObjectDestruction(Owner, C); + RootOuterMostStack.Pop; + RootOuterMostStack.Push(0); + end + else + begin + m.Invoke(X, Args); + end; + Exit; + end + else if m.IsClassMethod then + begin + if IsDelphiClass(TopCallRec.This) then + C := TClass(TopCallRec.This) + else + C := TObject(TopCallRec.This).ClassType; + V := m.Invoke(C, Args); + end + else + begin + X := TObject(TopCallRec.This); + V := m.Invoke(X, Args); + end; + + I := -1; + for param in m.GetParameters do + begin + Inc(I); + PParamDescRec := @ExtraData.ParamDescList[I]; + P := TopCallRec.ParamList[I].Address; + if PParamDescRec^.ByRef and (not PParamDescRec^.IsConst) then + _VarFromTValue(@Args[I], PParamDescRec.FT, P); + end; + + if RR.AR.Id <> 0 then + begin + P := LoadAddressR; + _VarFromTValue(@V, TopCallRec.ED.FT, P); + end; + + finally + N := TopCallRec.NCall + 1; + TopCallRec := RootCallStack.Pop; + end; +end; +{$ENDIF} + +procedure TIRunner.InvokeDestructor(This: Pointer; InitN: Integer); +var + ExtraData: TISubExtraData; + tempN: Integer; + tempRR: TIRunRec; +begin + tempN := N; + tempRR:= RR; + try + N := InitN; + RR := Records[N]; + ExtraData := ExtraDataList[RR.ExtraDataIndex] as TISubExtraData; + + TopCallRec := RootCallStack.AddRecord(Self); + TopCallRec.SubId := ExtraData.Id; + TopCallRec.NP := 0; + + TopCallRec.ED := ExtraData; + + TopCallRec.This := This; + TopCallRec.Host := false; + + TopCallRec.NCall := MaxInt - 1; + + RunLoop(Self); + finally + N := tempN; + RR := TempRR; + end; +end; + +function TIRunner.GetUnhandled: Boolean; +var + TryStack: TITryStack; + I, J: Integer; + R: TIRunner; +begin + result := true; + TryStack := RootTryStack; + if TryStack.Count = 0 then + Exit; + for I := TryStack.Count - 1 downto 0 do + begin + J := TryStack[I].TryBlockNumber; + R := TIRunner(TryStack[I].Runner); + if R.TryList[J].TryKind = tryExcept then + begin + result := false; + Exit; + end; + end; +end; + +procedure ProcessException(var ResRunner: TIRunner; E: Exception); +var + I, ClassIndex: Integer; + TryRec: TITryRec; + ClassRec: TClassRec; + TryStackRec: TITryStackRec; + SubId: Integer; + CallStack: TICallStack; +begin + TryStackRec := ResRunner.RootTryStack.Top; + + ResRunner := TryStackRec.Runner; + I := TryStackRec.TryBlockNumber; + SubId := TryStackRec.SubId; + + TryRec := ResRunner.TryList[I]; + + if TryRec.TryKind = tryExcept then + begin + ResRunner.HasError := false; + ResRunner.N := TryRec.N; + for I := 0 to TryRec.ExceptOnInfo.Count - 1 do + begin + ClassIndex := TryRec.ExceptOnInfo.Keys[I]; + if ClassIndex >= 0 then + begin + ClassRec := ResRunner.ClassList[ClassIndex]; + if ClassRec.PClass <> nil then + begin + if E is ClassRec.PClass then + begin + ResRunner.N := TryRec.ExceptOnInfo.Values[I]; + break; + end; + end; + end + else + begin + ResRunner.N := TryRec.ExceptOnInfo.Values[I]; + break; + end; + end; + end + else if TryRec.TryKind = tryFinally then + begin + ResRunner.N := TryRec.N; + end; + CallStack := ResRunner.RootCallStack; + repeat + if CallStack.Count = 0 then + break; + ResRunner.TopCallRec := CallStack.Top; + if (ResRunner.TopCallRec.SubId = SubId) and (ResRunner.TopCallRec.Runner = ResRunner) then + break + else + ResRunner.TopCallRec := CallStack.Pop; + until false; +end; + +procedure TIRunner.CreateTryList; +var + I: Integer; + R: TIRunRec; + TryRec: TITryRec; +begin + TryList.Clear; + TryList.AddRecord; + + for I := 1 to Card do + begin + R := Records[I]; + if R.Op = OP_TRY_ON then + begin + TryRec := TryList.AddRecord; + TryRec.Level := R.AR.Id; + end; + end; + for I := 1 to Card do + begin + R := Records[I]; + if R.Op = OP_EXCEPT then + begin + TryRec := TryList[R.A1.Id]; + TryRec.TryKind := tryExcept; + TryRec.N := I; + end + else if R.Op = OP_EXCEPT_ON then + begin + TryRec := TryList[R.A1.Id]; + TryRec.TryKind := tryExcept; + TryRec.N := I; + TryRec.ExceptOnInfo.Add(R.JMP, I); + end + else if R.Op = OP_FINALLY then + begin + TryRec := TryList[R.A1.Id]; + TryRec.TryKind := tryFinally; + TryRec.N := I; + end; + end; +end; + + +procedure _DestroyObject(_Self: Pointer; OuterMost: ShortInt); +var + PaxInfo: PPaxInfo; + ClassRec: TClassRec; + _ProgOffset: Integer; + P, RootProg, TargetProg: TIRunner; + C: TClass; + VMT: PVMT; + I: Integer; + FullName: String; + Self: TObject; +begin + Self := TObject(_Self); + + C := Self.ClassType; + + VMT := GetVMTFromClass(C); + if OuterMost <> 0 then + if not C.InheritsFrom(TInterfacedObject) then + PBeforeDestruction(vmtBeforeDestructionSlot(VMT)^)(Self); + + PaxInfo := GetPaxInfo(C); + if PaxInfo = nil then + raise Exception.Create(errInternalError); + + P := TIRunner(PaxInfo^.Prog); + + if Assigned(P.OnDestroyObject) then + if OuterMost <> 0 then + P.OnDestroyObject(P.Owner, Self); + + ClassRec := P.ClassList[PaxInfo^.ClassIndex]; + _ProgOffset := ClassRec.DestructorProgOffset; + + TargetProg := nil; + if _ProgOffset = 0 then + begin + FullName := ClassRec.FullName; + RootProg := P.GetRootProg as TIRunner; + for I := 0 to RootProg.ProgList.Count - 1 do + begin + TargetProg := TIRunner(RootProg.ProgList[I].Prog); + ClassRec := TargetProg.ClassList.Lookup(FullName); + if ClassRec <> nil then + begin + _ProgOffset := ClassRec.DestructorProgOffset; + break; + end; + end; + end + else + TargetProg := P; + + if _ProgOffset > 0 then + begin + TargetProg.RootOuterMostStack.Push(OuterMost); + TargetProg.InvokeDestructor(Self, _ProgOffset); + OuterMost := TargetProg.RootOuterMostStack.Pop; + end; + + if OuterMost = 0 then + Exit; + + _ToParentClass2(Self); + Self.CleanupInstance; + _UpdateInstance2(Self, C); + FreeMem(Pointer(Self), Self.InstanceSize); + + if Assigned(P.OnAfterObjectDestruction) then + P.OnAfterObjectDestruction(P.Owner, C); + + Pointer(Self) := nil; +end; + +function TIRunner.GetDestructorAddress: Pointer; +begin + result := @ _DestroyObject; +end; + +function TIRunner.IsPaused: Boolean; +begin + result := fPaused; +end; + +procedure TIRunner.Pause; +begin + fPaused := true; +end; + +procedure TIRunner.RemovePause; +begin + fPaused := false; +end; + +procedure TIRunner.DiscardPause; +begin + fPaused := false; +end; + +procedure TIRunner.RunInitialization; +var + b: Boolean; + P: TIRunner; +begin + inherited; + + ProgTag := 1; + + if ProgClassFactory.ForceCreate then + begin + CreateClassFactory; + ProgClassFactory.ForceCreate := false; + + CreateTryList; + SetGlobalAddresses; + InitStringLiterals; + end; + + N := 1; + b := false; + repeat + RR := Records[N]; + if RR.Op = OP_BEGIN_CRT_JS_FUNC_OBJECT then + begin + b := true; + Inc(N); + end + else if RR.Op = OP_END_CRT_JS_FUNC_OBJECT then + begin + b := false; + Inc(N); + end + else if RR.Op = OP_BEGIN_INIT_CONST then + begin + b := true; + Inc(N); + end + else if RR.Op = OP_END_INIT_CONST then + begin + b := false; + Inc(N); + end + else if RR.Op = OP_BEGIN_INITIALIZATION then + begin + b := true; + Inc(N); + end + else if RR.Op = OP_END_INITIALIZATION then + begin + b := false; + Inc(N); + end + else if RR.Op = OP_LOAD_PROC then + begin + P := Self; + _OP_LOAD_PROC(P); + end + else if RR.Op = OP_ADD_MESSAGE then + begin + P := Self; + _OP_ADD_MESSAGE(P); + end + else + begin + if b then + begin + P := Self; + ProcList[-RR.Op](P); + end + else + Inc(N); + end; + until N > Card; + N := 1; + + ProgTag := 0; +end; + +procedure TIRunner.RunExceptInitialization; +begin + Run; + if not IsPaused then + begin + if (not SuspendFinalization) and (ProgTag <> 1) then + fGC.ClearObjects; + + if not SuspendFinalization then + begin + if fCurrException = nil then + RunFinalization; + end; + end; +end; + +procedure TIRunner.RunFinalization; +var + b: Boolean; + I: Integer; + P: TIRunner; +begin + b := false; + for I := 1 to Card do + begin + RR := Records[I]; + if RR.Op = OP_BEGIN_FINALIZATION then + begin + b := true; + N := I; + break; + end; + end; + if not b then + Exit; + + b := false; + repeat + RR := Records[N]; + if RR.Op = OP_BEGIN_FINALIZATION then + begin + b := true; + Inc(N); + end + else if RR.Op = OP_END_FINALIZATION then + begin + b := false; + Inc(N); + end + else + begin + if b then + begin + P := Self; + ProcList[-RR.Op](P); + end + else + Inc(N); + end; + until N > Card; + N := 1; +end; + +procedure RunLoop(Self: TIRunner); +var + b: Boolean; + ResRunner: TIRunner; + IsExitException, IsPauseException, IsHaltException: Boolean; +begin + ResRunner := Self; + + ResRunner.DiscardPause; + + IsPauseException := false; + IsHaltException := false; + ResRunner.HasError := false; + + b := true; + while b do + begin + try + repeat + CurrRunner := ResRunner; + ResRunner.RR := ResRunner[ResRunner.N]; + ResRunner.ProcList[-ResRunner.RR.Op](ResRunner); + if ResRunner.N > ResRunner.Card then + break; + until false; + b := false; + except + on E: Exception do + begin + IsExitException := E is PaxExitException; + IsPauseException := E is TPauseException; + IsHaltException := (E is THaltException) or + ((E is EAbort) and (not IsPauseException) and (not IsExitException)); + + if (not IsPauseException) and (not IsHaltException) then + begin + if not IsExitException then + begin + if ResRunner.Unhandled then + begin + ResRunner.HasError := true; + + if E.ClassType <> TWorkException then + if Assigned(ResRunner.OnUnhandledException) then + ResRunner.OnUnhandledException(ResRunner.RootOwner, + E, + ResRunner.GetModuleName, + ResRunner.GetSourceLine); + DuplicateWorkException(ResRunner.fCurrException, E); + end + else + begin + if E.ClassType <> TWorkException then + if Assigned(ResRunner.OnException) then + ResRunner.OnException(ResRunner.RootOwner, + E, + ResRunner.GetModuleName, + ResRunner.GetSourceLine); + DuplicateException(ResRunner.fCurrException, E); + end; + end + else + begin + // exit exception + DuplicateException(ResRunner.fCurrException, E); + end; + + if ResRunner.RootTryStack.Count > 0 then + begin + ProcessException(ResRunner, E); + b := true; + end + else + begin + b := false; + end; + end + else + begin + ResRunner.CurrException := DupException(E); + b := false; + end; + end; + end; + end; + + if IsHaltException then + begin + if Assigned(ResRunner.OnHalt) then + ResRunner.OnHalt(ResRunner.RootOwner, + ExitCode, + ResRunner.GetModuleName, + ResRunner.GetSourceLine); + ResRunner.DiscardPause; + end + else if IsPauseException then + begin + if Assigned(ResRunner.OnPause) then + ResRunner.OnPause(ResRunner.RootOwner, + ResRunner.GetModuleName, + ResRunner.GetSourceLine); + end; +end; + +procedure TIRunner.Run; +begin + if ProgClassFactory.ForceCreate then + begin + CreateClassFactory; + ProgClassFactory.ForceCreate := false; + + CreateTryList; + SetGlobalAddresses; + InitStringLiterals; + end; + + RunLoop(Self); +end; + +procedure TIRunner.RunInternal; +begin +{$IFNDEF PAXARM_DEVICE} + if EPoint <> nil then + begin + if not InitializationProcessed then + RunInitialization; + + TPaxInvoke(EPoint.Outer).CallHost; + Exit; + end; +{$ENDIF} + Inc(N); + RunLoop(Self); +end; + +procedure TIRunner.ResetRun; +begin + RootTryStack.Clear; + RootCallStack.Clear; + RootInitCallStackCount := 0; + + IsRunning := false; + RootIsEvent := false; +end; + +function TIRunner.CallFunc(const FullName: String; + This: Pointer; + const ParamList: array of OleVariant; + OverCount: Integer = 0): OleVariant; +var + MR: TMapRec; + Address: Pointer; + ExtraData: TISubExtraData; + I, NP: Integer; + ResBuff: Pointer; +begin + ResBuff := nil; + Address := GetAddressEx(FullName, OverCount, MR); + if Address = nil then + RaiseError(errRoutineNotFound, [FullName]); + NP := MR.SubDesc.ParamList.Count; + if NP > System.Length(ParamList) then + RaiseError(errNotEnoughActualParameters, []) + else if NP < System.Length(ParamList) then + RaiseError(errTooManyActualParameters, []); + + N := IntPax(Address); + RR := Records[N]; + ExtraData := ExtraDataList[RR.ExtraDataIndex] as TISubExtraData; + + TopCallRec := RootCallStack.AddRecord(Self); + + TopCallRec.SubId := ExtraData.Id; + TopCallRec.NP := ExtraData.Count; + + TopCallRec.ED := ExtraData; + + for I := 0 to NP - 1 do + begin + TopCallRec.ParamList[I].Value := VariantToPaxValue(ParamList[I], + ExtraData.ParamDescList[I].FT); + TopCallRec.ParamList[I].Address := AddressOfPaxValue(TopCallRec.ParamList[I].Value); + end; + + TopCallRec.This := This; + TopCallRec.Host := false; + + TopCallRec.NCall := MaxInt - 1; + if ExtraData.FT > typeVOID then + begin + ResBuff := AllocMem(ExtraData.ResSize); + TopCallRec.ResAddress := ResBuff; + TopCallRec.PtrSize := ExtraData.ResSize; + end; + + RunLoop(Self); + + if ExtraData.FT > typeVOID then + begin + result := GetVariantValue(ResBuff, ExtraData.FT); + FreeMem(ResBuff, ExtraData.ResSize); + end; +end; + +type + TIntObject = class(TInterfacedObject); + +function TIRunner.CallByteCode(InitN: Integer; + This: Pointer; + R_AX, R_CX, R_DX, R_8, R_9: IntPax; + StackPtr: Pointer; + ResultPtr: Pointer; + var FT: Integer): Integer; +var + ExtraData: TISubExtraData; + I, tempN: Integer; + P: Pointer; + tempRR: TIRunRec; + TempPaused: Boolean; +begin + tempN := N; + tempRR := RR; + TempPaused := fPaused; + try + N := InitN; + RR := Records[N]; + ExtraData := ExtraDataList[RR.ExtraDataIndex] as TISubExtraData; + result := ExtraData.SizeOfParams; + if ExtraData.CallConv = ccCDECL then + result := 0; + + FT := ExtraData.FT; + + if RR.Op = OP_JUMP_SUB then + begin + if ExtraData.CallConv = ccREGISTER then + begin + P := Pointer(R_AX); + end + else if ExtraData.CallConv = cc64 then + begin + P := Pointer(R_CX); + end + else // ccSTDCALL + begin + if ExtraData.ExtraParamNeeded then + begin + ResultPtr := ShiftPointer(StackPtr, 8); + ResultPtr := Pointer(ResultPtr^); + + P := ShiftPointer(StackPtr, 12); + end + else + P := ShiftPointer(StackPtr, 8); + P := Pointer(P^); + end; + + P := ShiftPointer(P, - RR.A2.Id); + if RR.AR.Id = 1 then + begin + Integer(ResultPtr^) := TIntObject(P)._AddRef; + Exit; + end + else if RR.AR.Id = 2 then + begin + Integer(ResultPtr^) := TIntObject(P)._Release; + Exit; + end; + This := P; + N := RR.JMP; + end; + + TopCallRec := RootCallStack.AddRecord(Self); + + TopCallRec.SubId := ExtraData.Id; + TopCallRec.NP := ExtraData.Count; + + TopCallRec.ED := ExtraData; + +{$IFDEF FPC} + if TopCallRec.ED.Kind = kindCONSTRUCTOR then + begin + {$IFDEF PAX64} + This := Pointer(R_DX); + R_CX := R_DX; + R_DX := 1; + TopCallRec.DL := 1; + {$ELSE} + This := Pointer(R_DX); + R_AX := R_DX; + R_DX := 1; + TopCallRec.DL := 1; + {$ENDIF} + end; +{$ELSE} + if TopCallRec.ED.Kind = kindCONSTRUCTOR then + TopCallRec.DL := 1; +{$ENDIF} + + for I := 0 to TopCallRec.NP - 1 do + begin + case ExtraData.ParamDescList[I].Register of + _EAX: + begin + TopCallRec.ParamList[I].Value.VPointer := Pointer(R_AX); + P := @ TopCallRec.ParamList[I].Value; + end; + _ECX: + begin + TopCallRec.ParamList[I].Value.VPointer := Pointer(R_CX); + P := @ TopCallRec.ParamList[I].Value; + end; + _EDX: + begin + TopCallRec.ParamList[I].Value.VPointer := Pointer(R_DX); + P := @ TopCallRec.ParamList[I].Value; + end; + _R8: + begin + TopCallRec.ParamList[I].Value.VPointer := Pointer(R_8); + P := @ TopCallRec.ParamList[I].Value; + end; + _R9: + begin + TopCallRec.ParamList[I].Value.VPointer := Pointer(R_9); + P := @ TopCallRec.ParamList[I].Value; + end; +{$IFDEF PAX64} + _XMM0: + begin + case ExtraData.ParamDescList[I].FT of + typeDOUBLE: + begin + AssignDouble0(@ TopCallRec.ParamList[I].Value.VDouble); + P := @ TopCallRec.ParamList[I].Value; + end; + typeSINGLE: + begin + AssignSingle0(@ TopCallRec.ParamList[I].Value.VSingle); + P := @ TopCallRec.ParamList[I].Value; + end; + typeEXTENDED: + begin + AssignSingle0(@ TopCallRec.ParamList[I].Value.VExtended); + P := @ TopCallRec.ParamList[I].Value; + end; + end; + end; + _XMM1: + begin + case ExtraData.ParamDescList[I].FT of + typeDOUBLE: + begin + AssignDouble1(@ TopCallRec.ParamList[I].Value.VDouble); + P := @ TopCallRec.ParamList[I].Value; + end; + typeSINGLE: + begin + AssignSingle1(@ TopCallRec.ParamList[I].Value.VSingle); + P := @ TopCallRec.ParamList[I].Value; + end; + typeEXTENDED: + begin + AssignSingle1(@ TopCallRec.ParamList[I].Value.VExtended); + P := @ TopCallRec.ParamList[I].Value; + end; + end; + end; + _XMM2: + begin + case ExtraData.ParamDescList[I].FT of + typeDOUBLE: + begin + AssignDouble2(@ TopCallRec.ParamList[I].Value.VDouble); + P := @ TopCallRec.ParamList[I].Value; + end; + typeSINGLE: + begin + AssignSingle2(@ TopCallRec.ParamList[I].Value.VSingle); + P := @ TopCallRec.ParamList[I].Value; + end; + typeEXTENDED: + begin + AssignSingle2(@ TopCallRec.ParamList[I].Value.VExtended); + P := @ TopCallRec.ParamList[I].Value; + end; + end; + end; + _XMM3: + begin + case ExtraData.ParamDescList[I].FT of + typeDOUBLE: + begin + AssignDouble3(@ TopCallRec.ParamList[I].Value.VDouble); + P := @ TopCallRec.ParamList[I].Value; + end; + typeSINGLE: + begin + AssignSingle3(@ TopCallRec.ParamList[I].Value.VSingle); + P := @ TopCallRec.ParamList[I].Value; + end; + typeEXTENDED: + begin + AssignSingle3(@ TopCallRec.ParamList[I].Value.VExtended); + P := @ TopCallRec.ParamList[I].Value; + end; + end; + end; +{$ENDIF} + else + begin +{$IFDEF PAX64} + P := ShiftPointer(StackPtr, ExtraData.ParamDescList[I].Offset); +{$ELSE} + P := ShiftPointer(StackPtr, ExtraData.ParamDescList[I].Offset - 3*4); +{$ENDIF} + end; + end; + TopCallRec.ParamList[I].Address := P; + end; + + TopCallRec.This := This; + TopCallRec.Host := false; + TopCallRec.NCall := MaxInt - 1; + TopCallRec.ResAddress := ResultPtr; + if ExtraData.ResRegister > 0 then + case ExtraData.ResRegister of + _EAX: TopCallRec.ResAddress := Pointer(R_AX); + _ECX: TopCallRec.ResAddress := Pointer(R_CX); + _EDX: TopCallRec.ResAddress := Pointer(R_DX); + _R8: TopCallRec.ResAddress := Pointer(R_8); + _R9: TopCallRec.ResAddress := Pointer(R_9); + end; + TopCallRec.PtrSize := ExtraData.ResSize; + + RunLoop(Self); + finally + N := tempN; + RR := tempRR; + fPaused := TempPaused; + end; +end; + +procedure TIRunner.UpdateAddress(var Address: Pointer; Data: Pointer); +var + I: Integer; +begin + if Address = @ TForm.Create then + begin + Address := @ TForm.CreateNew; + + TopCallRec.NP := IntPax(Data); + + I := TopCallRec.NP - 1; + TopCallRec.ParamList[I].Value.VInteger := 0; + TopCallRec.ParamList[I].Address := @ TopCallRec.ParamList[I].Value.VInteger; + TopCallRec.ParamList[I].Size := SizeOf(Integer); + + TopCallRec.ED.Count := TopCallRec.NP; + SetLength(TopCallRec.ED.ParamDescList, TopCallRec.NP); + TopCallRec.ED.ParamDescList[I].ByRef := false; + TopCallRec.ED.ParamDescList[I].FT := typeINTEGER; + TopCallRec.ED.ParamDescList[I].PtrSize := SizeOf(Integer); + end; +end; + +function TIRunner.GetInterfaceToObjectOffset(JumpN: Integer): Integer; +begin + result := - Records[JumpN].A2.Id; +end; + +function TIRunner.GetReturnFinalTypeId(InitSubN: Integer): Integer; +var + ExtraData: TISubExtraData; +begin + ExtraData := ExtraDataList[Records[InitSubN].ExtraDataIndex] as TISubExtraData; + result := ExtraData.FT; +end; + +{$IFNDEF PAXARM_DEVICE} + +procedure TIRunner.SetEntryPoint(EntryPoint: TPaxInvoke); +begin + EPoint := EntryPoint.GetImplementation; + EPoint.Outer := EntryPoint; +end; + +procedure TIRunner.ResetEntryPoint(EntryPoint: TPaxInvoke); +begin + EPoint := nil; +end; + +{$ENDIF} +end. + + diff --git a/Sources/PAXINT_SEH.pas b/Sources/PAXINT_SEH.pas new file mode 100644 index 0000000..48110e1 --- /dev/null +++ b/Sources/PAXINT_SEH.pas @@ -0,0 +1,163 @@ +//////////////////////////////////////////////////////////////////////////// +// PaxCompiler +// Site: http://www.paxcompiler.com +// Author: Alexander Baranovsky (paxscript@gmail.com) +// ======================================================================== +// Copyright (c) Alexander Baranovsky, 2006-2014. All rights reserved. +// Code Version: 4.2 +// ======================================================================== +// Unit: PAXINT_SEH.pas +// ======================================================================== +//////////////////////////////////////////////////////////////////////////// + +{$I PaxCompiler.def} +unit PAXINT_SEH; +interface +uses + SysUtils, + Classes, + PAXCOMP_TYPES, + PAXCOMP_SYS; +type + TITryStackRec = class + public + TryBlockNumber: Integer; + SubId: Integer; + Runner: Pointer; + end; + + TITryStack = class(TTypedList) + private + function GetRecord(I: Integer): TITryStackRec; + function GetTop: TITryStackRec; + public + function Push(Runner: Pointer; TryBlockNumber, SubId: Integer): TITryStackRec; + procedure Pop; + + property Records[I: Integer]: TITryStackRec read GetRecord; default; + property Top: TITryStackRec read GetTop; + end; + + TITryRec = class + public + TryKind: TTryKind; + Level: Integer; + BreakOffset: Integer; + ContinueOffset: Integer; + ExceptOnInfo: TAssocIntegers; + + N: Integer; // not saved into stream + constructor Create; + destructor Destroy; override; + procedure SaveToStream(S: TStream); + procedure LoadFromStream(S: TStream); + end; + + TITryList = class(TTypedList) + private + function GetRecord(I: Integer): TITryRec; + public + function AddRecord: TITryRec; + procedure SaveToStream(S: TStream); + procedure LoadFromStream(S: TStream); + property Records[I: Integer]: TITryRec read GetRecord; default; + end; + +implementation + +// TITryStack ------------------------------------------------------------------ + +function TITryStack.GetRecord(I: Integer): TITryStackRec; +begin + result := TITryStackRec(L[I]); +end; + +function TITryStack.GetTop: TITryStackRec; +begin + result := TITryStackRec(L[Count - 1]); +end; + +function TITryStack.Push(Runner: Pointer; TryBlockNumber, SubId: Integer): TITryStackRec; +begin + result := TITryStackRec.Create; + result.TryBlockNumber := TryBlockNumber; + result.Runner := Runner; + result.SubId := SubId; + L.Add(result); +end; + +procedure TITryStack.Pop; +begin + RemoveAt(Count - 1); +end; + +// TITryRec -------------------------------------------------------------------- + +constructor TITryRec.Create; +begin + inherited; + ExceptOnInfo := TAssocIntegers.Create; +end; + +destructor TITryRec.Destroy; +begin + FreeAndNil(ExceptOnInfo); + inherited; +end; + +procedure TITryRec.SaveToStream(S: TStream); +begin + S.Write(TryKind, SizeOf(TryKind)); + S.Write(Level, SizeOf(Level)); + S.Write(BreakOffset, SizeOf(BreakOffset)); + S.Write(ContinueOffset, SizeOf(ContinueOffset)); + ExceptOnInfo.SaveToStream(S); +end; + +procedure TITryRec.LoadFromStream(S: TStream); +begin + S.Read(TryKind, SizeOf(TryKind)); + S.Read(Level, SizeOf(Level)); + S.Read(BreakOffset, SizeOf(BreakOffset)); + S.Read(ContinueOffset, SizeOf(ContinueOffset)); + ExceptOnInfo.LoadFromStream(S); +end; + +// TITryList ------------------------------------------------------------------- + +function TITryList.GetRecord(I: Integer): TITryRec; +begin + result := TITryRec(L[I]); +end; + +function TITryList.AddRecord: TITryRec; +begin + result := TITryRec.Create; + L.Add(result); +end; + +procedure TITryList.SaveToStream(S: TStream); +var + I, K: Integer; +begin + K := Count; + S.Write(K, SizeOf(K)); + for I := 0 to K - 1 do + Records[I].SaveToStream(S); +end; + +procedure TITryList.LoadFromStream(S: TStream); +var + I, K: Integer; + R: TITryRec; +begin + K := Count; + S.Read(K, SizeOf(K)); + for I := 0 to K - 1 do + begin + R := AddRecord; + R.LoadFromStream(S); + end; +end; + +end. diff --git a/Sources/PAXINT_SYS.pas b/Sources/PAXINT_SYS.pas new file mode 100644 index 0000000..284b12b --- /dev/null +++ b/Sources/PAXINT_SYS.pas @@ -0,0 +1,547 @@ +//////////////////////////////////////////////////////////////////////////// +// PaxCompiler +// Site: http://www.paxcompiler.com +// Author: Alexander Baranovsky (paxscript@gmail.com) +// ======================================================================== +// Copyright (c) Alexander Baranovsky, 2006-2014. All rights reserved. +// Code Version: 4.2 +// ======================================================================== +// Unit: PAXINT_SYS.pas +// ======================================================================== +//////////////////////////////////////////////////////////////////////////// + +{$I PaxCompiler.def} +unit PAXINT_SYS; +interface +uses + Classes, + SysUtils, +{$IFDEF DRTTI} + RTTI, +{$ENDIF} + PAXCOMP_CONSTANTS, + PAXCOMP_TYPES, + PAXCOMP_SYS; + +const + EXTRA_LOCAL_SIZE = $200; + + IntTypes = OrdinalTypes + + [typeCLASSREF, +{$IFNDEF ARC} + typeCLASS, +{$ENDIF} + typePOINTER, + typePROC]; + + MAX_JS_PARAM = 30; + +type + TIArg = packed record + Id: Integer; + Offset: Integer; + PtrSize: SmallInt; + Level: Integer; + Kind: Byte; + FT: Byte; + Local: Boolean; + HasOwner: Boolean; + ByRef: Boolean; + end; + + TIParamDescRec = record + Offset: Integer; + PtrSize: Integer; + ByRef: Boolean; + IsConst: Boolean; + FT: Integer; + Register: Integer; + IsOpenArray: Boolean; + HighOffset: Integer; + end; + + PIParamDescRec = ^TIParamDescRec; + + TIExtraDataType = (edNone, edSub, edArr, edEvent, edGuid, edStruct); + + TIExtraDataList = class; + + TIBaseExtraData = class + private + Owner: TIExtraDataList; + public + EDType: TIExtraDataType; + Id: Integer; + constructor Create(AOwner: TIExtraDataList); virtual; + procedure SaveToStream(S: TStream); virtual; + procedure LoadFromStream(S: TStream); virtual; + end; + + TISubExtraData = class(TIBaseExtraData) + public + FullName: String; + Host: Boolean; + IsShared: Boolean; + ExtraParamNeeded: Boolean; + IsInterfaceMethod: Boolean; + IsRecordMethod: Boolean; + IsFakeMethod: Boolean; + PushProgRequired: Boolean; + RunnerParam: Boolean; + CallMode: Byte; + FT: Integer; + Kind: Integer; + Level: Integer; + MethodIndex: Integer; + OverCount: Integer; + Count: Integer; + CallConv: Integer; + LocalSize: Integer; + ResOffset: Integer; + ResByRef: Boolean; + ResSize: Integer; + ResRegister: Byte; + SizeOfParams: Integer; + JMP: Integer; + ParamDescList: array of TIParamDescRec; + PCURunner: Pointer; // not save to stream +{$IFDEF DRTTI} + rtti_method: TRTTIMethod; +{$ENDIF} + constructor Create(AOwner: TIExtraDataList); override; + procedure SaveToStream(S: TStream); override; + procedure LoadFromStream(S: TStream); override; + end; + + TIArrExtraData = class(TIBaseExtraData) + public + H1: Integer; + ElTypeId: Integer; + ElFinTypeId: Integer; + ElSize: Integer; + constructor Create(AOwner: TIExtraDataList); override; + procedure SaveToStream(S: TStream); override; + procedure LoadFromStream(S: TStream); override; + end; + + TIEventExtraData = class(TIBaseExtraData) + public + CodeArg, DataArg: TIArg; + constructor Create(AOwner: TIExtraDataList); override; + procedure SaveToStream(S: TStream); override; + procedure LoadFromStream(S: TStream); override; + end; + + TIGuidExtraData = class(TIBaseExtraData) + public + GUID: TGUID; + constructor Create(AOwner: TIExtraDataList); override; + procedure SaveToStream(S: TStream); override; + procedure LoadFromStream(S: TStream); override; + end; + + TIStructExtraData = class(TIBaseExtraData) + public + Types, FinTypes, Offsets: TIntegerList; + constructor Create(AOwner: TIExtraDataList); override; + destructor Destroy; override; + procedure SaveToStream(S: TStream); override; + procedure LoadFromStream(S: TStream); override; + end; + + TIExtraDataList = class(TTypedList) + private + runner: Pointer; + function GetRecord(I: Integer): TIBaseExtraData; + function AddBaseRecord: TIBaseExtraData; + public + constructor Create(ARunner: Pointer); + + procedure Reset; + function Find(Id: Integer): TIBaseExtraData; + function IndexOf(Id: Integer): Integer; + function AddSubRecord(Id: Integer): TISubExtraData; + function AddArrRecord(Id: Integer): TIArrExtraData; + function AddEventRecord(Id: Integer): TIEventExtraData; + function AddGuidRecord(Id: Integer): TIGuidExtraData; + function AddStructRecord(Id: Integer): TIStructExtraData; + procedure SaveToStream(S: TStream); + procedure LoadFromStream(S: TStream); + procedure AttachRTTI; + property Records[I: Integer]: TIBaseExtraData read GetRecord; default; + end; + +procedure SaveArg(A: TIArg; S: TStream); +procedure LoadArg(var A: TIArg; S: TStream); + +implementation + +uses + PAXCOMP_BASERUNNER; + +procedure SaveArg(A: TIArg; S: TStream); +var + B:Boolean; +begin + B := A.Id > 0; + S.Write(B, SizeOf(B)); + if B then + S.Write(A, SizeOf(A)); +end; + +procedure LoadArg(var A: TIArg; S: TStream); +var + B:Boolean; +begin + S.Read(B, SizeOf(B)); + if B then + S.Read(A, SizeOf(A)); +end; + +// TIBaseExtraData ------------------------------------------------------------- + +constructor TIBaseExtraData.Create; +begin + inherited Create; + Owner := AOwner; +end; + +procedure TIBaseExtraData.SaveToStream(S: TStream); +begin + S.Write(Id, SizeOf(Id)); +end; + +procedure TIBaseExtraData.LoadFromStream(S: TStream); +begin + S.Read(Id, SizeOf(Id)); +end; + +// TISubExtraData -------------------------------------------------------------- + +constructor TISubExtraData.Create; +begin + inherited; + EDType := edSub; +end; + +procedure TISubExtraData.SaveToStream(S: TStream); +var + I: Integer; +begin + inherited; + SaveStringToStream(FullName, S); + S.Write(Host, SizeOf(Host)); + S.Write(IsShared, SizeOf(IsShared)); + S.Write(IsInterfaceMethod, SizeOf(IsInterfaceMethod)); + S.Write(IsRecordMethod, SizeOf(IsRecordMethod)); + S.Write(IsFakeMethod, SizeOf(IsFakeMethod)); + S.Write(PushProgRequired, SizeOf(PushProgRequired)); + S.Write(RunnerParam, SizeOf(RunnerParam)); + S.Write(CallMode, SizeOf(CallMode)); + S.Write(ExtraParamNeeded, SizeOf(ExtraParamNeeded)); + S.Write(FT, SizeOf(FT)); + S.Write(Kind, SizeOf(Kind)); + S.Write(Level, SizeOf(Level)); + S.Write(MethodIndex, SizeOf(MethodIndex)); + S.Write(OverCount, SizeOf(OverCount)); + S.Write(Count, SizeOf(Count)); + S.Write(CallConv, SizeOf(CallConv)); + S.Write(LocalSize, SizeOf(LocalSize)); + S.Write(ResOffset, SizeOf(ResOffset)); + S.Write(ResByRef, SizeOf(ResByRef)); + S.Write(ResSize, SizeOf(ResSize)); + S.Write(ResRegister, SizeOf(ResRegister)); + S.Write(SizeOfParams, SizeOf(SizeOfParams)); + S.Write(JMP, SizeOf(JMP)); + for I := 0 to Count - 1 do + S.Write(ParamDescList[I], SizeOf(ParamDescList[I])); +end; + +procedure TISubExtraData.LoadFromStream(S: TStream); +var + I: Integer; +begin + inherited; + FullName := LoadStringFromStream(S); + S.Read(Host, SizeOf(Host)); + S.Read(IsShared, SizeOf(IsShared)); + S.Read(IsInterfaceMethod, SizeOf(IsInterfaceMethod)); + S.Read(IsRecordMethod, SizeOf(IsRecordMethod)); + S.Read(IsFakeMethod, SizeOf(IsFakeMethod)); + S.Read(PushProgRequired, SizeOf(PushProgRequired)); + S.Read(RunnerParam, SizeOf(RunnerParam)); + S.Read(CallMode, SizeOf(CallMode)); + S.Read(ExtraParamNeeded, SizeOf(ExtraParamNeeded)); + S.Read(FT, SizeOf(FT)); + S.Read(Kind, SizeOf(Kind)); + S.Read(Level, SizeOf(Level)); + S.Read(MethodIndex, SizeOf(MethodIndex)); + S.Read(OverCount, SizeOf(OverCount)); + S.Read(Count, SizeOf(Count)); + S.Read(CallConv, SizeOf(CallConv)); + S.Read(LocalSize, SizeOf(LocalSize)); + S.Read(ResOffset, SizeOf(ResOffset)); + S.Read(ResByRef, SizeOf(ResByRef)); + S.Read(ResSize, SizeOf(ResSize)); + S.Read(ResRegister, SizeOf(ResRegister)); + S.Read(SizeOfParams, SizeOf(SizeOfParams)); + S.Read(JMP, SizeOf(JMP)); + SetLength(ParamDescList, Count); + for I := 0 to Count - 1 do + S.Read(ParamDescList[I], SizeOf(ParamDescList[I])); +end; + +// TIArrExtraData -------------------------------------------------------------- + +constructor TIArrExtraData.Create; +begin + inherited; + EDType := edArr; +end; + +procedure TIArrExtraData.SaveToStream(S: TStream); +begin + inherited; + S.Write(H1, SizeOf(H1)); + S.Write(ElTypeId, SizeOf(ElTypeId)); + S.Write(ElFinTypeId, SizeOf(ElFinTypeId)); + S.Write(ElSize, SizeOf(ElSize)); +end; + +procedure TIArrExtraData.LoadFromStream(S: TStream); +begin + inherited; + S.Read(H1, SizeOf(H1)); + S.Read(ElTypeId, SizeOf(ElTypeId)); + S.Read(ElFinTypeId, SizeOf(ElFinTypeId)); + S.Read(ElSize, SizeOf(ElSize)); +end; + +// TIEventExtraData ------------------------------------------------------------ + +constructor TIEventExtraData.Create; +begin + inherited; + EDType := edEvent; +end; + +procedure TIEventExtraData.SaveToStream(S: TStream); +begin + inherited; + SaveArg(CodeArg, S); + SaveArg(DataArg, S); +end; + +procedure TIEventExtraData.LoadFromStream(S: TStream); +begin + inherited; + LoadArg(CodeArg, S); + LoadArg(DataArg, S); +end; + +// TIGuidExtraData ------------------------------------------------------------- + +constructor TIGuidExtraData.Create; +begin + inherited; + EDType := edGuid; +end; + +procedure TIGuidExtraData.SaveToStream(S: TStream); +begin + inherited; + S.Write(GUID, SizeOf(GUID)); +end; + +procedure TIGuidExtraData.LoadFromStream(S: TStream); +begin + inherited; + S.Read(GUID, SizeOf(GUID)); +end; + +// TIStructExtraData ----------------------------------------------------------- + +constructor TIStructExtraData.Create; +begin + inherited; + EDType := edStruct; + Types := TIntegerList.Create; + FinTypes := TIntegerList.Create; + Offsets := TIntegerList.Create; +end; + +destructor TIStructExtraData.Destroy; +begin + FreeAndNil(Types); + FreeAndNil(FinTypes); + FreeAndNil(Offsets); + inherited; +end; + +procedure TIStructExtraData.SaveToStream(S: TStream); +begin + inherited; + Types.SaveToStream(S); + FinTypes.SaveToStream(S); + Offsets.SaveToStream(S); +end; + +procedure TIStructExtraData.LoadFromStream(S: TStream); +begin + inherited; + Types.LoadFromStream(S); + FinTypes.LoadFromStream(S); + Offsets.LoadFromStream(S); +end; + +// TIExtraDataList ------------------------------------------------------------- + +constructor TIExtraDataList.Create(ARunner: Pointer); +begin + inherited Create; + runner := ARunner; + Reset; +end; + +function TIExtraDataList.GetRecord(I: Integer): TIBaseExtraData; +begin + result := TIBaseExtraData(L[I]); +end; + +procedure TIExtraDataList.Reset; +begin + Clear; + AddBaseRecord; +end; + +function TIExtraDataList.IndexOf(Id: Integer): Integer; +var + I: Integer; +begin + result := -1; + for I := 0 to Count - 1 do + if Records[I].Id = Id then + begin + result := I; + Exit; + end; +end; + +function TIExtraDataList.Find(Id: Integer): TIBaseExtraData; +var + I: Integer; +begin + result := nil; + for I := 0 to Count - 1 do + if Records[I].Id = Id then + begin + result := Records[I]; + Exit; + end; +end; + +function TIExtraDataList.AddBaseRecord: TIBaseExtraData; +begin + result := TIBaseExtraData.Create(Self); + result.Id := -1; + L.Add(result); +end; + +function TIExtraDataList.AddSubRecord(Id: Integer): TISubExtraData; +begin + result := TISubExtraData.Create(Self); + result.Id := Id; + L.Add(result); +end; + +function TIExtraDataList.AddArrRecord(Id: Integer): TIArrExtraData; +begin + result := TIArrExtraData.Create(Self); + result.Id := Id; + L.Add(result); +end; + +function TIExtraDataList.AddEventRecord(Id: Integer): TIEventExtraData; +begin + result := TIEventExtraData.Create(Self); + result.Id := Id; + L.Add(result); +end; + +function TIExtraDataList.AddGuidRecord(Id: Integer): TIGuidExtraData; +begin + result := TIGuidExtraData.Create(Self); + result.Id := Id; + L.Add(result); +end; + +function TIExtraDataList.AddStructRecord(Id: Integer): TIStructExtraData; +begin + result := TIStructExtraData.Create(Self); + result.Id := Id; + L.Add(result); +end; + +procedure TIExtraDataList.SaveToStream(S: TStream); +var + I, K: Integer; +begin + K := Count; + S.Write(K, SizeOf(K)); + for I := 1 to K - 1 do + begin + S.Write(Records[I].EDType, SizeOf(TIExtraDataType)); + Records[I].SaveToStream(S); + end; +end; + +procedure TIExtraDataList.LoadFromStream(S: TStream); +var + I, K: Integer; + EDType: TIExtraDataType; + R: TIBaseExtraData; +begin + Reset; + S.Read(K, SizeOf(K)); + for I := 1 to K - 1 do + begin + S.Read(EDType, SizeOf(TIExtraDataType)); + case EDType of + edNone: R := nil; + edSub: R := TISubExtraData.Create(Self); + edArr: R := TIArrExtraData.Create(Self); + edEvent: R := TIEventExtraData.Create(Self); + edGuid: R := TIGuidExtraData.Create(Self); + edStruct: R := TIStructExtraData.Create(Self); + else + R := nil; + end; + R.LoadFromStream(S); + L.Add(R); + end; + AttachRTTI; +end; + +{$IFDEF DRTTI} +procedure TIExtraDataList.AttachRTTI; +var + I: Integer; + R: TISubExtraData; +begin + for I := 1 to Count - 1 do + if Records[I].EDType = edSub then + begin + R := Records[I] as TISubExtraData; + if R.Host then + R.rtti_method := TBaseRunner(runner).LookUpAvailMethod(R.FullName, R.OverCount); + end; +end; +{$ELSE} +procedure TIExtraDataList.AttachRTTI; +begin +end; +{$ENDIF} + +initialization +finalization +end. diff --git a/Sources/PaxBasicLanguage.pas b/Sources/PaxBasicLanguage.pas new file mode 100644 index 0000000..c39d0ab --- /dev/null +++ b/Sources/PaxBasicLanguage.pas @@ -0,0 +1,82 @@ +//////////////////////////////////////////////////////////////////////////// +// PaxCompiler +// Site: http://www.paxcompiler.com +// Author: Alexander Baranovsky (paxscript@gmail.com) +// ======================================================================== +// Copyright (c) Alexander Baranovsky, 2006-2014. All rights reserved. +// Code Version: 4.2 +// ======================================================================== +// Unit: PaxBasicLanguage.pas +// ======================================================================== +//////////////////////////////////////////////////////////////////////////// + +{$I PaxCompiler.def} +unit PaxBasicLanguage; + +interface +uses {$I uses.def} + Classes, + PAXCOMP_PARSER, + PAXCOMP_BASIC_PARSER, + PaxRegister, + PaxCompiler; + +type + TPaxBasicLanguage = class(TPaxCompilerLanguage) + private + function GetUseFWArrays: Boolean; + procedure SetUseFWArrays(value: Boolean); + protected + function GetParser: TBaseParser; override; + public + constructor Create(AOwner: TComponent); override; + procedure SetCallConv(CallConv: Integer); override; + procedure SetDeclareCallConv(CallConv: Integer); + function GetLanguageName: String; override; + published + property ExplicitOff; + property CompleteBooleanEval; + property UseFWArrays: Boolean read GetUseFWArrays write SetUseFWArrays; + end; + +implementation + +constructor TPaxBasicLanguage.Create(AOwner: TComponent); +begin + inherited; + P := TBasicParser.Create; + SetCallConv(_ccREGISTER); +end; + +procedure TPaxBasicLanguage.SetCallConv(CallConv: Integer); +begin + P.CallConv := CallConv; +end; + +procedure TPaxBasicLanguage.SetDeclareCallConv(CallConv: Integer); +begin + P.DeclareCallConv := CallConv; +end; + +function TPaxBasicLanguage.GetParser: TBaseParser; +begin + result := P; +end; + +function TPaxBasicLanguage.GetLanguageName: String; +begin + result := P.LanguageName; +end; + +function TPaxBasicLanguage.GetUseFWArrays: Boolean; +begin + result := P.UseFWArrays; +end; + +procedure TPaxBasicLanguage.SetUseFWArrays(value: Boolean); +begin + P.UseFWArrays := value; +end; + + +end. diff --git a/Sources/PaxCompiler.def b/Sources/PaxCompiler.def new file mode 100644 index 0000000..ad3c050 --- /dev/null +++ b/Sources/PaxCompiler.def @@ -0,0 +1,300 @@ +// {$define TRIAL} +{$O-} + +//{$DEFINE EXPLICIT_OFF} + +{$IFDEF CPUARM} + {$DEFINE INTERPRETER_ONLY} +{$ENDIF} + + +// {$define NO_PARENT_CLASS} + +// {$define FPC} +{$ifdef FPC} + {$IFDEF CPUX64} + {$DEFINE PAX64} + {$ENDIF} + {$ASMMODE intel} + {$DEFINE VARIANTS} + {$MODE DELPHI} + {$DEFINE CPUASM} + {$H+} + {$M+} +{$endif} + +{$M+} + +{$define PCU_EX} +{$define GENERICS} +//{$define HTML} + +// {$DEFINE PAXARM} //////////////////////////////////////!!!!! +// {$DEFINE GENARC} + +{$IFDEF ANDROID} + {$DEFINE PAXARM} + {$DEFINE PAXARM_DEVICE} +{$ENDIF} +{$IFDEF IOS} + {$DEFINE PAXARM} + {$IFNDEF CPUARM} + {$DEFINE IOSIM} + {$ENDIF} + {$IFDEF CPUARM} + {$DEFINE PAXARM_DEVICE} + {$ENDIF} +{$ENDIF} + +{$IFDEF AUTOREFCOUNT} + {$DEFINE ARC} + {$DEFINE GENARC} + {$ZEROBASEDSTRINGS ON} + {$define SZERO} +{$ENDIF} + + +{$define DUMP} +{$ifdef Ver140} + {$define VARIANTS} +{$endif} +{$ifdef Ver150} + {$define VARIANTS} +{$endif} +{$ifdef Ver160} + {$define VARIANTS} +{$endif} +{$ifdef Ver170} + {$define VARIANTS} +{$endif} +{$ifdef Ver180} + {$define VARIANTS} +{$endif} +{$ifdef Ver190} + {$define VARIANTS} +{$endif} +{$ifdef Ver200} + {$define VARIANTS} + {$define UNIC} +{$endif} +{$ifdef Ver210} + {$define VARIANTS} + {$define UNIC} + {$define DRTTI} +{$endif} +{$ifdef Ver220} + {$define VARIANTS} + {$define UNIC} + {$define DRTTI} +{$endif} +{$ifdef Ver230} + {$define VARIANTS} + {$define UNIC} + {$define DRTTI} + {$define DPULSAR} + {$define GE_DXE2} + {$IFDEF CPUX64} + {$DEFINE PAX64} + {$ENDIF} +{$endif} +{$ifdef Ver240} + {$define VARIANTS} + {$define UNIC} + {$define DRTTI} + {$define DPULSAR} + {$define DXE3} + {$define GE_DXE3} + {$define GE_DXE2} + {$IFDEF CPUX64} + {$DEFINE PAX64} + {$ENDIF} +{$endif} +{$ifdef Ver250} + {$define VARIANTS} + {$define UNIC} + {$define DRTTI} + {$define DPULSAR} + {$define DXE4} + {$define GE_DXE2} + {$define GE_DXE3} + {$define GE_DXE4} + {$IFDEF CPUX64} + {$DEFINE PAX64} + {$ENDIF} +{$endif} +{$ifdef Ver260} + {$define VARIANTS} + {$define UNIC} + {$define DRTTI} + {$define DPULSAR} + {$define DXE5} + {$define GE_DXE2} + {$define GE_DXE3} + {$define GE_DXE4} + {$define GE_DXE5} + {$IFDEF CPUX64} + {$DEFINE PAX64} + {$ENDIF} +{$endif} +{$ifdef Ver270} + {$define VARIANTS} + {$define UNIC} + {$define DRTTI} + {$define DPULSAR} + {$define DXE6} + {$define GE_DXE2} + {$define GE_DXE3} + {$define GE_DXE4} + {$define GE_DXE5} + {$define GE_DXE6} + {$IFDEF CPUX64} + {$DEFINE PAX64} + {$ENDIF} +{$endif} + +{$ifdef Ver280} + {$define VARIANTS} + {$define UNIC} + {$define DRTTI} + {$define DPULSAR} + {$define DXE7} + {$define GE_DXE2} + {$define GE_DXE3} + {$define GE_DXE4} + {$define GE_DXE5} + {$define GE_DXE6} + {$define GE_DXE7} + {$IFDEF CPUX64} + {$DEFINE PAX64} + {$ENDIF} +{$endif} + +{$ifdef Ver290} + {$define VARIANTS} + {$define UNIC} + {$define DRTTI} + {$define DPULSAR} + {$define DXE7} + {$define GE_DXE2} + {$define GE_DXE3} + {$define GE_DXE4} + {$define GE_DXE5} + {$define GE_DXE6} + {$define GE_DXE7} + {$IFDEF CPUX64} + {$DEFINE PAX64} + {$ENDIF} +{$endif} + +{$ifdef Ver300} + {$define VARIANTS} + {$define UNIC} + {$define DRTTI} + {$define DPULSAR} + {$define DXE7} + {$define GE_DXE2} + {$define GE_DXE3} + {$define GE_DXE4} + {$define GE_DXE5} + {$define GE_DXE6} + {$define GE_DXE7} + {$IFDEF CPUX64} + {$DEFINE PAX64} + {$ENDIF} +{$endif} + +{$ifdef Ver330} + {$define VARIANTS} + {$define UNIC} //Check this because 1.bin should store ansistring + {$define DRTTI} + {$define DPULSAR} + {$define DXE7} + {$define GE_DXE2} + {$define GE_DXE3} + {$define GE_DXE4} + {$define GE_DXE5} + {$define GE_DXE6} + {$define GE_DXE7} + {$define GE_DXE8} + {$define GE_DXE10.1} + {$define GE_DXE10.2} + {$define GE_DXE10.3} + {$IFDEF CPUX64} + {$DEFINE PAX64} + {$ENDIF} +{$endif} + +{$ifdef Ver340} + {$define VARIANTS} + {$define UNIC} //Check this because 1.bin should store ansistring + {$define DRTTI} + {$define DPULSAR} + {$define DXE7} + {$define GE_DXE2} + {$define GE_DXE3} + {$define GE_DXE4} + {$define GE_DXE5} + {$define GE_DXE6} + {$define GE_DXE7} + {$define GE_DXE8} + {$define GE_DXE10.1} + {$define GE_DXE10.2} + {$define GE_DXE10.3} + {$define GE_DXE10.4} + {$IFDEF CPUX64} + {$DEFINE PAX64} + {$ENDIF} +{$endif} + +{$IFDEF Ver350} // Alexandria + {$DEFINE VARIANTS} + {$DEFINE UNIC} + {$DEFINE DRTTI} + {$DEFINE DPULSAR} + {$DEFINE DXETOKYO} + {$DEFINE GE_DXE2} + {$DEFINE GE_DXE3} + {$DEFINE GE_DXE4} + {$DEFINE GE_DXE5} + {$DEFINE GE_DXE6} + {$DEFINE GE_DXE7} + {$DEFINE GE_DXE8} + {$DEFINE GE_DXESEATTLE} + {$DEFINE GE_DXEBERLIN} + {$DEFINE GE_DXETOKYO} + {$DEFINE GE_DXERIO} + {$DEFINE GE_DXESYDNEY} + {$DEFINE GE_DXEALEXANDRIA} + {$IFDEF CPUX64} + {$DEFINE PAX64} + {$ENDIF} +{$ENDIF} + +{$IFDEF Ver360} // Athens + {$DEFINE VARIANTS} + {$DEFINE UNIC} + {$DEFINE DRTTI} + {$DEFINE DPULSAR} + {$DEFINE DXETOKYO} + {$DEFINE GE_DXE2} + {$DEFINE GE_DXE3} + {$DEFINE GE_DXE4} + {$DEFINE GE_DXE5} + {$DEFINE GE_DXE6} + {$DEFINE GE_DXE7} + {$DEFINE GE_DXE8} + {$DEFINE GE_DXESEATTLE} + {$DEFINE GE_DXEBERLIN} + {$DEFINE GE_DXETOKYO} + {$DEFINE GE_DXERIO} + {$DEFINE GE_DXESYDNEY} + {$DEFINE GE_DXEALEXANDRIA} + {$IFDEF CPUX64} + {$DEFINE PAX64} + {$ENDIF} +{$ENDIF} + + +{$IFNDEF VARIANTS} + {$DEFINE MSWINDOWS} +{$ENDIF} diff --git a/Sources/PaxCompiler.pas b/Sources/PaxCompiler.pas new file mode 100644 index 0000000..df85e1c --- /dev/null +++ b/Sources/PaxCompiler.pas @@ -0,0 +1,3004 @@ +//////////////////////////////////////////////////////////////////////////// +// PaxCompiler +// Site: http://www.paxcompiler.com +// Author: Alexander Baranovsky (paxscript@gmail.com) +// ======================================================================== +// Copyright (c) Alexander Baranovsky, 2006-2014. All rights reserved. +// Code Version: 4.2 +// ======================================================================== +// Unit: PaxCompiler.pas +// ======================================================================== +//////////////////////////////////////////////////////////////////////////// + +{$I PaxCompiler.def} +unit PaxCompiler; + +interface + +uses {$I uses.def} + TypInfo, + SysUtils, + Classes, + PAXCOMP_CONSTANTS, + PAXCOMP_TYPES, + PAXCOMP_SYS, + PAXCOMP_KERNEL, + PAXCOMP_BASESYMBOL_TABLE, + PAXCOMP_PARSER, + PAXCOMP_PASCAL_PARSER, + PAXCOMP_OLE, + PAXCOMP_MODULE, + PAXCOMP_SYMBOL_REC, + PAXCOMP_TYPEINFO, + PAXCOMP_CLASSFACT, + PAXCOMP_BASERUNNER, + PaxRunner, + PaxRegister; + +const + PLATFORM_Win32 = 1; + PLATFORM_Win64 = 2; + PLATFORM_OSX32 = 3; + PLATFORM_IOSsim = 4; + PLATFORM_IOSdev = 5; + PLATFORM_ANDROID = 6; + PLATFORM_LINUX32 = 7; + +type + TPaxCompiler = class; + TPaxCompilerLanguage = class; + + TPaxCompilerNotifyEvent = procedure (Sender: TPaxCompiler) of object; + TPaxCompilerUnitAliasEvent = procedure (Sender: TPaxCompiler; + var UnitName: String) of object; + TPaxCompilerUsedUnitEvent = function (Sender: TPaxCompiler; const UnitName: String; + var SourceCode: String): Boolean of object; + TPaxCompilerImportMemberEvent = procedure (Sender: TPaxCompiler; + Id: Integer; + const AFullName: String) of object; + TPaxCompilerSavePCUEvent = procedure (Sender: TPaxCompiler; const UnitName: String; + var result: TStream) of object; + TPaxCompilerLoadPCUEvent = procedure (Sender: TPaxCompiler; const UnitName: String; + var result: TStream) of object; + TPaxCompilerSavePCUFinishedEvent = procedure (Sender: TPaxCompiler; const UnitName: String; var Stream : TStream) of object; // jason + TPaxCompilerLoadPCUFinishedEvent = procedure(Sender: TPaxCompiler; const UnitName: String; var Stream : TStream) of object; // jason + + TPaxCompilerDirectiveEvent = procedure (Sender: TPaxCompiler; + const Directive: String; var ok: Boolean) of object; + + TPaxCompilerIncludeEvent = procedure (Sender: TPaxCompiler; const FileName: String; + var Text: String) of object; + + TPaxCompilerUndeclaredIdentifierEvent = function (Sender: TPaxCompiler; + const IdentName: String; + var Scope: String; + var FullTypeName: String): boolean + of object; + + TPaxCompilerCommentEvent = procedure (Sender: TPaxCompiler; + const Comment: String; + const Context: String; + CommentedTokens: TStrings) of object; + + TPaxCompiler = class(TComponent) + private + kernel: TKernel; + + function GetTargetPlatform: Integer; + procedure SetTargetPlatform(value: Integer); + procedure CreateMapping(Runner: TBaseRunner); + function GetErrorCount: Integer; + function GetErrorMessage(I: Integer): String; + function GetErrorModuleName(I: Integer): String; + function GetErrorLine(I: Integer): String; + function GetErrorLineNumber(I: Integer): Integer; + function GetErrorLinePos(I: Integer): Integer; + function GetErrorFileName(I: Integer): String; + + function GetWarningCount: Integer; + function GetWarningMessage(I: Integer): String; + function GetWarningModuleName(I: Integer): String; + function GetWarningLine(I: Integer): String; + function GetWarningLineNumber(I: Integer): Integer; + function GetWarningLinePos(I: Integer): Integer; + function GetWarningFileName(I: Integer): String; + + function GetOnCompilerProgress: TPaxCompilerNotifyEvent; + procedure SetOnCompilerProgress(value: TPaxCompilerNotifyEvent); + + function GetOnUsedUnit: TPaxCompilerUsedUnitEvent; + procedure SetOnUsedUnit(value: TPaxCompilerUsedUnitEvent); + + function GetOnImportUnit: TPaxCompilerImportMemberEvent; + procedure SetOnImportUnit(value: TPaxCompilerImportMemberEvent); + + function GetOnImportType: TPaxCompilerImportMemberEvent; + procedure SetOnImportType(value: TPaxCompilerImportMemberEvent); + + function GetOnImportGlobalMembers: TPaxCompilerNotifyEvent; + procedure SetOnImportGlobalMembers(value: TPaxCompilerNotifyEvent); + + function GetOnUnitAlias: TPaxCompilerUnitAliasEvent; + procedure SetOnUnitAlias(value: TPaxCompilerUnitAliasEvent); + + function GetOnSavePCU: TPaxCompilerSavePCUEvent; + procedure SetOnSavePCU(value: TPaxCompilerSavePCUEvent); + + function GetOnLoadPCU: TPaxCompilerLoadPCUEvent; + procedure SetOnLoadPCU(value: TPaxCompilerLoadPCUEvent); + + function GetOnInclude: TPaxCompilerIncludeEvent; + procedure SetOnInclude(value: TPaxCompilerIncludeEvent); + + function GetOnDefineDirective: TPaxCompilerDirectiveEvent; + procedure SetOnDefineDirective(value: TPaxCompilerDirectiveEvent); + + function GetOnUndefineDirective: TPaxCompilerDirectiveEvent; + procedure SetOnUndefineDirective(value: TPaxCompilerDirectiveEvent); + + function GetOnUnknownDirective: TPaxCompilerDirectiveEvent; + procedure SetOnUnknownDirective(value: TPaxCompilerDirectiveEvent); + + function GetOnUndeclaredIdentifier: TPaxCompilerUndeclaredIdentifierEvent; + procedure SetOnUndeclaredIdentifier(value: TPaxCompilerUndeclaredIdentifierEvent); + + function GetOnComment: TPaxCompilerCommentEvent; + procedure SetOnComment(value: TPaxCompilerCommentEvent); + + function GetDebugMode: Boolean; + procedure SetDebugMode(value: Boolean); + + function GetCondDirectiveList: TStringList; + + function GetSourceModule(const ModuleName: String): TStringList; + function GetCurrLineNumber: Integer; + function GetCurrModuleNumber: Integer; + function GetCurrModuleName: String; + + function GetAlignment: Integer; + procedure SetAlignment(value: Integer); + + function GetCurrLanguage: String; + procedure SetCurrLanguage(const value: String); + + function GetNativeSEH: Boolean; + procedure SetNativeSEH(const value: Boolean); + + function GetOnSavePCUFinished: TPaxCompilerSavePCUFinishedEvent; // jason + procedure SetOnSavePCUFinished(value: TPaxCompilerSavePCUFinishedEvent); // jason + + function GetOnLoadPCUFinished: TPaxCompilerLoadPCUFinishedEvent; // jason + procedure SetOnLoadPCUFinished(value: TPaxCompilerLoadPCUFinishedEvent); // jason + + function GetCompletionPrefix: String; + + function GetUnicode: Boolean; + procedure SetUnicode(value: Boolean); + protected + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + procedure Reset; + procedure ResetCompilation; + procedure AddModule(const ModuleName, LanguageName: String); + procedure AddCode(const ModuleName, Text: String); + procedure AddCodeFromFile(const ModuleName, FileName: String); + procedure RegisterLanguage(L: TPaxCompilerLanguage); + procedure RegisterDirective(const Directive: string; const value: Variant); + + function RegisterNamespace(LevelId: Integer; + const NamespaceName: String): Integer; + procedure RegisterUsingNamespace(const aNamespaceName: String); overload; + procedure RegisterUsingNamespace(aNamespaceID: Integer); overload; + procedure UnregisterUsingNamespace(aNamespaceID: Integer); overload; + procedure UnregisterUsingNamespaces; + procedure UnregisterUsingNamespace(const aNamespaceName: String); overload; + function RegisterInterfaceType(LevelId: Integer; + const TypeName: String; + const GUID: TGUID): Integer; overload; + function RegisterInterfaceType(LevelId: Integer; + const TypeName: String; + const GUID: TGUID; + const ParentName: String; + const ParentGUID: TGUID): Integer; overload; + + procedure RegisterSupportedInterface(TypeId: Integer; + const SupportedInterfaceName: String; + const GUID: TGUID); + function RegisterClassType(LevelId: Integer; + const TypeName: String; AncestorId: Integer): Integer; overload; + function RegisterClassType(LevelId: Integer; + C: TClass): Integer; overload; + function RegisterClassReferenceType(LevelId: Integer; + const TypeName: String; OriginClassId: Integer): Integer; + function RegisterClassHelperType(LevelId: Integer; + const TypeName: String; OriginClassId: Integer): Integer; overload; + function RegisterClassHelperType(LevelID: Integer; + const TypeName, OriginalTypeName: String): Integer; overload; + function RegisterRecordHelperType(LevelId: Integer; + const TypeName: String; OriginRecordId: Integer): Integer; overload; + function RegisterRecordHelperType(LevelID: Integer; + const TypeName, OriginalTypeName: String): Integer; overload; + function RegisterClassTypeField(TypeId: Integer; const FieldName: String; + FieldTypeID: Integer; FieldShift: Integer = -1): Integer; + function RegisterProperty(LevelId: Integer; const PropName: String; + PropTypeID, ReadId, WriteId: Integer; + IsDefault: Boolean): Integer; overload; + function RegisterProperty(LevelId: Integer; const Header: String): Integer; overload; + function RegisterInterfaceProperty(LevelId: Integer; + const PropName: String; + PropTypeID, + ReadIndex, + WriteIndex: Integer): Integer; + function RegisterRecordType(LevelId: Integer; + const TypeName: String; + IsPacked: Boolean = false): Integer; + function RegisterRecordTypeField(TypeId: Integer; const FieldName: String; + FieldTypeID: Integer; FieldShift: Integer = -1): Integer; + function RegisterVariantRecordTypeField(TypeId: Integer; const FieldName: String; + FieldTypeID: Integer; + VarCount: Int64): Integer; overload; + function RegisterVariantRecordTypeField(LevelId: Integer; const Declaration: String; + VarCount: Int64): Integer; overload; + function RegisterSubrangeType(LevelId: Integer; + const TypeName: String; + TypeBaseId: Integer; + B1, B2: Integer): Integer; + function RegisterEnumType(LevelId: Integer; + const TypeName: String; + TypeBaseId: Integer = _typeINTEGER): Integer; + function RegisterEnumValue(EnumTypeId: Integer; + const FieldName: String; + const Value: Integer): Integer; + function RegisterArrayType(LevelId: Integer; + const TypeName: String; + RangeTypeId, ElemTypeId: Integer; + IsPacked: Boolean = false): Integer; + function RegisterDynamicArrayType(LevelId: Integer; + const TypeName: String; + ElemTypeId: Integer): Integer; + function RegisterPointerType(LevelId: Integer; + const TypeName: String; + OriginTypeId: Integer; + const OriginTypeName: String = ''): Integer; + function RegisterMethodReferenceType(LevelId: Integer; + const TypeName: String; + SubId: Integer): Integer; + function RegisterSetType(LevelId: Integer; + const TypeName: String; + OriginTypeId: Integer): Integer; + function RegisterProceduralType(LevelId: Integer; + const TypeName: String; + SubId: Integer): Integer; +{$IFNDEF PAXARM} + function RegisterShortStringType(LevelId: Integer; + const TypeName: String; + L: Integer): Integer; +{$ENDIF} + + function RegisterEventType(LevelId: Integer; + const TypeName: String; + SubId: Integer): Integer; + function RegisterRTTIType(LevelId: Integer; + pti: PTypeInfo): Integer; + function RegisterTypeAlias(LevelId:Integer; + const TypeName: String; + OriginTypeId: Integer): Integer; + function RegisterVariable(LevelId: Integer; + const VarName: String; TypeId: Integer; + Address: Pointer = nil): Integer; overload; + function RegisterVariable(LevelId: Integer; + const Declaration: String; Address: Pointer): Integer; overload; + function RegisterObject(LevelId: Integer; + const ObjectName: String; + TypeId: Integer; + Address: Pointer = nil): Integer; + function RegisterVirtualObject(LevelId: Integer; + const ObjectName: String): Integer; + function RegisterConstant(LevelId: Integer; + const ConstName: String; + typeID: Integer; + const Value: Variant): Integer; overload; + function RegisterConstant(LevelId: Integer; + const ConstName: String; + const Value: Variant): Integer; overload; + function RegisterPointerConstant(LevelId: Integer; + const ConstName: String; + const Value: Pointer): Integer; overload; + function RegisterConstant(LevelId: Integer; + const ConstName: String; + const Value: Extended): Integer; overload; + function RegisterConstant(LevelId: Integer; + const ConstName: String; + const Value: Int64): Integer; overload; + function RegisterConstant(LevelId: Integer; + const Declaration: String): Integer; overload; + function RegisterRoutine(LevelId: Integer; + const RoutineName: String; ResultTypeID: Integer; + CallConvention: Integer; + Address: Pointer = nil): Integer; overload; + function RegisterRoutine(LevelId: Integer; const Name: String; ResultId: Integer; + Address: Pointer; + CallConvention: Integer = _ccREGISTER; + OverCount: Integer = 0; + i_IsDeprecated: Boolean = false): Integer; overload; + function RegisterRoutine(LevelId: Integer; const Name, ResultType: String; + Address: Pointer; + CallConvention: Integer = _ccREGISTER; + OverCount: Integer = 0; + i_IsDeprecated: Boolean = false): Integer; overload; + function RegisterMethod(LevelId: Integer; + const RoutineName: String; ResultTypeID: Integer; + CallConvention: Integer; + Address: Pointer = nil; + IsShared: Boolean = false): Integer; overload; + function RegisterMethod(ClassId: Integer; + const Name: String; + ResultId: Integer; + Address: Pointer; + CallConvention: Integer = _ccREGISTER; + IsShared: Boolean = false; + CallMode: Integer = _cmNONE; + MethodIndex: Integer = 0; + OverCount: Integer = 0; + i_IsAbstract: Boolean = false; + i_AbstractMethodCount: Integer = 0; + i_IsDeprecated: Boolean = false): Integer; overload; + function RegisterMethod(ClassId: Integer; + const Name, ResultType: String; + Address: Pointer; + CallConvention: Integer = _ccREGISTER; + IsShared: Boolean = false; + CallMode: Integer = _cmNONE; + MethodIndex: Integer = 0; + OverCount: Integer = 0; + i_IsAbstract: Boolean = false; + i_AbstractMethodCount: Integer = 0; + i_IsDeprecated: Boolean = false): Integer; overload; + function RegisterConstructor(ClassId: Integer; + const Name: String; + Address: Pointer; + CallConvention: Integer = _ccREGISTER; + IsShared: Boolean = false; + CallMode: Integer = cmNONE; + i_MethodIndex: Integer = 0; + OverCount: Integer = 0; + i_IsAbstract: Boolean = false; + i_AbstractMethodCount: Integer = 0; + i_IsDeprecated: Boolean = false): Integer; + function RegisterDestructor(ClassId: Integer; const Name: String; + Address: Pointer): Integer; + function RegisterParameter(HSub: Integer; ParamTypeID: Integer; + const DefaultValue: Variant; + ByRef: Boolean = false): Integer; overload; + function RegisterParameter(LevelId: Integer; + const ParameterName: String; + ParamTypeID: Integer; + ParamMod: Integer = 0; + Optional: Boolean = false; + const DefaultValue: String = ''): Integer; overload; + function RegisterParameter(LevelId: Integer; + const ParameterName: String; + const ParameterType: String; + ParamMod: Integer = 0; + Optional: Boolean = false; + const DefaultValue: String = ''): Integer; overload; + function RegisterHeader(LevelId: Integer; const Header: String; + Address: Pointer = nil; + MethodIndex: Integer = 0): Integer; + function RegisterFakeHeader(LevelId: Integer; + const Header: String; Address: Pointer): Integer; + function RegisterTypeDeclaration(LevelId: Integer; + const Declaration: String): Integer; + function RegisterSomeType(LevelId: Integer; + const TypeName: String): Integer; +{$ifdef DRTTI} + procedure RegisterImportUnit(Level: Integer; const AUnitName: String); +{$endif} + function GetHandle(LevelId: Integer; const MemberName: String; Upcase: Boolean): Integer; + function Compile(APaxRunner: TPaxRunner; + BuildAll: Boolean = false; + BuildWithRuntimePackages: Boolean = false): boolean; overload; + function Compile: boolean; overload; + function Parse: boolean; + function CompileExpression(const Expression: String; + APaxRunner: TPaxRunner; + const LangName: String = ''): Boolean; + function CodeCompletion(const ModuleName: String; + X, Y: Integer; L: TStrings; PaxLang: TPaxCompilerLanguage = nil): Boolean; + function FindDeclaration(const ModuleName: String; + X, Y: Integer; + PaxLang: TPaxCompilerLanguage = nil): Integer; + function GetKernelPtr: Pointer; + procedure RegisterGlobalJSObjects(var R: TJS_Record); + function GetUndeclaredTypes: TStringList; + function GetUndeclaredIdentifiers: TStringList; + + function LookupId(const FullName: String; UpCase: Boolean = true): Integer; + function LookupTypeId(const TypeName: String): Integer; + function LookupTypeNamespaceId(const TypeName: String): Integer; + function LookupNamespace(LevelId: Integer; const NamespaceName: String; + CaseSensitive: Boolean): Integer; overload; + function LookupNamespace(const NamespaceName: String): Integer; overload; + procedure AssignImportTable(ImportTable: Pointer); + function GetModuleName(Id: Integer): String; + function GetPosition(Id: Integer): Integer; + function GetKind(Id: Integer): Integer; + function GetEvalList: TStringList; + function InScript(const IdentName: String): Boolean; + procedure ExtendAlphabet(B1, B2: Word); + + property ErrorCount: Integer read GetErrorCount; + property ErrorMessage[I: Integer]: String read GetErrorMessage; + property ErrorModuleName[I: Integer]: String read GetErrorModuleName; + property ErrorLine[I: Integer]: String read GetErrorLine; + property ErrorLineNumber[I: Integer]: Integer read GetErrorLineNumber; + property ErrorLinePos[I: Integer]: Integer read GetErrorLinePos; + property ErrorFileName[I: Integer]: String read GetErrorFileName; + + property WarningCount: Integer read GetWarningCount; + property WarningMessage[I: Integer]: String read GetWarningMessage; + property WarningModuleName[I: Integer]: String read GetWarningModuleName; + property WarningLine[I: Integer]: String read GetWarningLine; + property WarningLineNumber[I: Integer]: Integer read GetWarningLineNumber; + property WarningLinePos[I: Integer]: Integer read GetWarningLinePos; + property WarningFileName[I: Integer]: String read GetWarningFileName; + + property Modules[const ModuleName: String]: TStringList read GetSourceModule; + property CurrLineNumber: Integer read GetCurrLineNumber; + property CurrModuleNumber: Integer read GetCurrModuleNumber; + property CurrModuleName: String read GetCurrModuleName; + property CondDirectiveList: TStringList read GetCondDirectiveList; + property CurrLanguage: String read GetCurrLanguage write SetCurrLanguage; + property NativeSEH: Boolean read GetNativeSEH write SetNativeSEH; + property CompletionPrefix: String read GetCompletionPrefix; + property Unicode: Boolean read GetUnicode write SetUnicode; + property TargetPlatform: Integer read GetTargetPlatform write SetTargetPlatform; + published + property Alignment: Integer read GetAlignment write SetAlignment; + property OnCompilerProgress: TPaxCompilerNotifyEvent + read GetOnCompilerProgress write SetOnCompilerProgress; + property OnUnitAlias: TPaxCompilerUnitAliasEvent + read GetOnUnitAlias write SetOnUnitAlias; + property OnUsedUnit: TPaxCompilerUsedUnitEvent + read GetOnUsedUnit write SetOnUsedUnit; + property OnImportUnit: TPaxCompilerImportMemberEvent + read GetOnImportUnit write SetOnImportUnit; + property OnImportType: TPaxCompilerImportMemberEvent + read GetOnImportType write SetOnImportType; + property OnImportGlobalMembers: TPaxCompilerNotifyEvent + read GetOnImportGlobalMembers write SetOnImportGlobalMembers; + property OnSavePCU: TPaxCompilerSavePCUEvent + read GetOnSavePCU write SetOnSavePCU; + property OnLoadPCU: TPaxCompilerLoadPCUEvent + read GetOnLoadPCU write SetOnLoadPCU; + property OnInclude: TPaxCompilerIncludeEvent + read GetOnInclude write SetOnInclude; + property OnSavePCUFinished: TPaxCompilerSavePCUFinishedEvent + read GetOnSavePCUFinished write SetOnSavePCUFinished; // jason + property OnLoadPCUFinished: TPaxCompilerLoadPCUFinishedEvent + read GetOnLoadPCUFinished write SetOnLoadPCUFinished; // jason + property OnDefineDirective: TPaxCompilerDirectiveEvent + read GetOnDefineDirective write SetOnDefineDirective; + property OnUndefineDirective: TPaxCompilerDirectiveEvent + read GetOnUndefineDirective write SetOnUndefineDirective; + property OnUnknownDirective: TPaxCompilerDirectiveEvent + read GetOnUnknownDirective write SetOnUnknownDirective; + property OnUndeclaredIdentifier: TPaxCompilerUndeclaredIdentifierEvent + read GetOnUndeclaredIdentifier write SetOnUndeclaredIdentifier; + property OnComment: TPaxCompilerCommentEvent + read GetOnComment write SetOnComment; + property DebugMode: Boolean read GetDebugMode write SetDebugMode; + end; + + TPaxCompilerLanguage = class(TComponent) + private + function GetCompleteBooleanEval: Boolean; + procedure SetCompleteBooleanEval(value: Boolean); + function GetPrintKeyword: String; + function GetPrintlnKeyword: String; + procedure SetPrintKeyword(const value: String); + procedure SetPrintlnKeyword(const value: String); + function GetUnitLookup: Boolean; + procedure SetUnitLookup(value: Boolean); + function GetExplicitOff: Boolean; + procedure SetExplicitOff(value: Boolean); + function GetInitFuncResult: Boolean; + procedure SetInitFuncResult(value: Boolean); + protected + P: TBaseParser; + function GetLanguageName: String; virtual; abstract; + function GetParser: TBaseParser; virtual; abstract; + property ExplicitOff: Boolean read GetExplicitOff write SetExplicitOff; + property CompleteBooleanEval: Boolean read GetCompleteBooleanEval write SetCompleteBooleanEval; + property PrintKeyword: String read GetPrintKeyword write SetPrintKeyword; + property PrintlnKeyword: String read GetPrintlnKeyword write SetPrintlnKeyword; + property UnitLookup: Boolean read GetUnitLookup write SetUnitLookup; + public + destructor Destroy; override; + procedure SetCallConv(CallConv: Integer); virtual; abstract; + property LanguageName: String read GetLanguageName; + property InitFuncResult: Boolean read GetInitFuncResult write SetInitFuncResult; + end; + + TPaxCompilerLanguageClass = class of TPaxCompilerLanguage; + + TPaxPascalLanguage = class; + + TPaxParserNotifyEvent = procedure(Sender: TPaxPascalLanguage) of object; + TPaxParserIdentEvent = procedure(Sender: TPaxPascalLanguage; + const IdentName: String; Id: Integer) of object; + TPaxParserIdentEventEx = procedure(Sender: TPaxPascalLanguage; + const IdentName: String; Id: Integer; const Declaration: String) of object; + TPaxParserNamedValueEvent = procedure(Sender: TPaxPascalLanguage; + const IdentName: String; Id: Integer; const Value: Variant; + const Declaration: String) of object; + TPaxParserTypedIdentEvent = procedure(Sender: TPaxPascalLanguage; + const IdentName: String; Id: Integer; const TypeName: String; + const Declaration: String) of object; + TPaxParserVariantRecordFieldEvent = procedure(Sender: TPaxPascalLanguage; + const IdentName: String; Id: Integer; const TypeName: String; VarCount: Int64; + const Declaration: String) of object; + TPaxParserNamedTypedValueEvent = procedure(Sender: TPaxPascalLanguage; + const IdentName: String; Id: Integer; const TypeName: String; + const DefaultValue: String; + const Declaration: String) of object; + TPaxParserDeclarationEvent = procedure(Sender: TPaxPascalLanguage; + const IdentName: String; Id: Integer; const Declaration: String) of object; + TPaxParserArrayTypeEvent = procedure(Sender: TPaxPascalLanguage; + const IdentName: String; Id: Integer; + Ranges: TStringList; + const ElemTypeName: String) of object; + + TPaxPascalLanguage = class(TPaxCompilerLanguage) + private + function GetOnParseUnitName: TPaxParserIdentEvent; + procedure SetOnParseUnitName(value: TPaxParserIdentEvent); + function GetOnParseImplementationSection: TPaxParserNotifyEvent; + procedure SetOnParseImplementationSection(value: TPaxParserNotifyEvent); + function GetOnParseBeginUsedUnitList: TPaxParserNotifyEvent; + procedure SetOnParseBeginUsedUnitList(value: TPaxParserNotifyEvent); + function GetOnParseEndUsedUnitList: TPaxParserNotifyEvent; + procedure SetOnParseEndUsedUnitList(value: TPaxParserNotifyEvent); + function GetOnParseUsedUnitName: TPaxParserIdentEvent; + procedure SetOnParseUsedUnitName(value: TPaxParserIdentEvent); + function GetOnParseBeginClassTypeDeclaration: TPaxParserIdentEventEx; + procedure SetOnParseBeginClassTypeDeclaration(value: TPaxParserIdentEventEx); + function GetOnParseEndClassTypeDeclaration: TPaxParserIdentEvent; + procedure SetOnParseEndClassTypeDeclaration(value: TPaxParserIdentEvent); + function GetOnParseTypeDeclaration: TPaxParserIdentEvent; + procedure SetOnParseTypeDeclaration(value: TPaxParserIdentEvent); + function GetOnParseForwardTypeDeclaration: TPaxParserIdentEvent; + procedure SetOnParseForwardTypeDeclaration(value: TPaxParserIdentEvent); + function GetOnParseAncestorTypeDeclaration: TPaxParserIdentEvent; + procedure SetOnParseAncestorTypeDeclaration(value: TPaxParserIdentEvent); + function GetOnParseUsedInterface: TPaxParserIdentEvent; + procedure SetOnParseUsedInterface(value: TPaxParserIdentEvent); + function GetOnParseClassReferenceTypeDeclaration: TPaxParserTypedIdentEvent; + procedure SetOnParseClassReferenceTypeDeclaration(value: TPaxParserTypedIdentEvent); + function GetOnParseAliasTypeDeclaration: TPaxParserTypedIdentEvent; + procedure SetOnParseAliasTypeDeclaration(value: TPaxParserTypedIdentEvent); + function GetOnParseProceduralTypeDeclaration: TPaxParserIdentEventEx; + procedure SetOnParseProceduralTypeDeclaration(value: TPaxParserIdentEventEx); + function GetOnParseEventTypeDeclaration: TPaxParserIdentEventEx; + procedure SetOnParseEventTypeDeclaration(value: TPaxParserIdentEventEx); + function GetOnParseMethodReferenceTypeDeclaration: TPaxParserIdentEventEx; + procedure SetOnParseMethodReferenceTypeDeclaration(value: TPaxParserIdentEventEx); + function GetOnParseSetTypeDeclaration: TPaxParserTypedIdentEvent; + procedure SetOnParseSetTypeDeclaration(value: TPaxParserTypedIdentEvent); + function GetOnParsePointerTypeDeclaration: TPaxParserTypedIdentEvent; + procedure SetOnParsePointerTypeDeclaration(value: TPaxParserTypedIdentEvent); + function GetOnParseArrayTypeDeclaration: TPaxParserArrayTypeEvent; + procedure SetOnParseArrayTypeDeclaration(value: TPaxParserArrayTypeEvent); + function GetOnParseDynArrayTypeDeclaration: TPaxParserTypedIdentEvent; + procedure SetOnParseDynArrayTypeDeclaration(value: TPaxParserTypedIdentEvent); + function GetOnParseShortStringTypeDeclaration: TPaxParserNamedValueEvent; + procedure SetOnParseShortStringTypeDeclaration(value: TPaxParserNamedValueEvent); + function GetOnParseSubrangeTypeDeclaration: TPaxParserDeclarationEvent; + procedure SetOnParseSubrangeTypeDeclaration(value: TPaxParserDeclarationEvent); + function GetOnParseBeginRecordTypeDeclaration: TPaxParserIdentEventEx; + procedure SetOnParseBeginRecordTypeDeclaration(value: TPaxParserIdentEventEx); + function GetOnParseEndRecordTypeDeclaration: TPaxParserIdentEvent; + procedure SetOnParseEndRecordTypeDeclaration(value: TPaxParserIdentEvent); + function GetOnParseBeginClassHelperTypeDeclaration: TPaxParserTypedIdentEvent; + procedure SetOnParseBeginClassHelperTypeDeclaration(value: TPaxParserTypedIdentEvent); + function GetOnParseEndClassHelperTypeDeclaration: TPaxParserIdentEvent; + procedure SetOnParseEndClassHelperTypeDeclaration(value: TPaxParserIdentEvent); + function GetOnParseBeginRecordHelperTypeDeclaration: TPaxParserTypedIdentEvent; + procedure SetOnParseBeginRecordHelperTypeDeclaration(value: TPaxParserTypedIdentEvent); + function GetOnParseEndRecordHelperTypeDeclaration: TPaxParserIdentEvent; + procedure SetOnParseEndRecordHelperTypeDeclaration(value: TPaxParserIdentEvent); + function GetOnParseBeginInterfaceTypeDeclaration: TPaxParserIdentEvent; + procedure SetOnParseBeginInterfaceTypeDeclaration(value: TPaxParserIdentEvent); + function GetOnParseEndInterfaceTypeDeclaration: TPaxParserIdentEvent; + procedure SetOnParseEndInterfaceTypeDeclaration(value: TPaxParserIdentEvent); + function GetOnParseBeginEnumTypeDeclaration: TPaxParserIdentEvent; + procedure SetOnParseBeginEnumTypeDeclaration(value: TPaxParserIdentEvent); + function GetOnParseEndEnumTypeDeclaration: TPaxParserIdentEvent; + procedure SetOnParseEndEnumTypeDeclaration(value: TPaxParserIdentEvent); + function GetOnParseEnumName: TPaxParserNamedValueEvent; + procedure SetOnParseEnumName(value: TPaxParserNamedValueEvent); + function GetOnParseFieldDeclaration: TPaxParserTypedIdentEvent; + procedure SetOnParseFieldDeclaration(value: TPaxParserTypedIdentEvent); + function GetOnParseVariantRecordFieldDeclaration: TPaxParserVariantRecordFieldEvent; + procedure SetOnParseVariantRecordFieldDeclaration(value: TPaxParserVariantRecordFieldEvent); + function GetOnParsePropertyDeclaration: TPaxParserTypedIdentEvent; + procedure SetOnParsePropertyDeclaration(value: TPaxParserTypedIdentEvent); + function GetOnParseConstantDeclaration: TPaxParserNamedValueEvent; + procedure SetOnParseConstantDeclaration(value: TPaxParserNamedValueEvent); + function GetOnParseResourceStringDeclaration: TPaxParserNamedValueEvent; + procedure SetOnParseResourceStringDeclaration(value: TPaxParserNamedValueEvent); + function GetOnParseTypedConstantDeclaration: TPaxParserNamedTypedValueEvent; + procedure SetOnParseTypedConstantDeclaration(value: TPaxParserNamedTypedValueEvent); + function GetOnParseVariableDeclaration: TPaxParserTypedIdentEvent; + procedure SetOnParseVariableDeclaration(value: TPaxParserTypedIdentEvent); + function GetOnParseBeginSubDeclaration: TPaxParserIdentEvent; + procedure SetOnParseBeginSubDeclaration(value: TPaxParserIdentEvent); + function GetOnParseEndSubDeclaration: TPaxParserDeclarationEvent; + procedure SetOnParseEndSubDeclaration(value: TPaxParserDeclarationEvent); + function GetOnParseBeginFormalParameterList: TPaxParserNotifyEvent; + procedure SetOnParseBeginFormalParameterList(value: TPaxParserNotifyEvent); + function GetOnParseEndFormalParameterList: TPaxParserNotifyEvent; + procedure SetOnParseEndFormalParameterList(value: TPaxParserNotifyEvent); + function GetOnParseFormalParameterDeclaration: TPaxParserNamedTypedValueEvent; + procedure SetOnParseFormalParameterDeclaration(value: TPaxParserNamedTypedValueEvent); + function GetOnParseResultType: TPaxParserIdentEvent; + procedure SetOnParseResultType(value: TPaxParserIdentEvent); + function GetOnParseSubDirective: TPaxParserIdentEvent; + procedure SetOnParseSubDirective(value: TPaxParserIdentEvent); + protected + function GetParser: TBaseParser; override; + public + constructor Create(AOwner: TComponent); override; + procedure SetCallConv(CallConv: Integer); override; + function GetLanguageName: String; override; + + property OnParseUnitName: TPaxParserIdentEvent read GetOnParseUnitName + write SetOnParseUnitName; + property OnParseImplementationSection: TPaxParserNotifyEvent read GetOnParseImplementationSection + write SetOnParseImplementationSection; + property OnParseBeginUsedUnitList: TPaxParserNotifyEvent read GetOnParseBeginUsedUnitList + write SetOnParseBeginUsedUnitList; + property OnParseEndUsedUnitList: TPaxParserNotifyEvent read GetOnParseEndUsedUnitList + write SetOnParseEndUsedUnitList; + property OnParseUsedUnitName: TPaxParserIdentEvent read GetOnParseUsedUnitName + write SetOnParseUsedUnitName; + property OnParseTypeDeclaration: TPaxParserIdentEvent read GetOnParseTypeDeclaration + write SetOnParseTypeDeclaration; + property OnParseForwardTypeDeclaration: TPaxParserIdentEvent read GetOnParseForwardTypeDeclaration + write SetOnParseForwardTypeDeclaration; + property OnParseBeginClassTypeDeclaration: TPaxParserIdentEventEx read GetOnParseBeginClassTypeDeclaration + write SetOnParseBeginClassTypeDeclaration; + property OnParseEndClassTypeDeclaration: TPaxParserIdentEvent read GetOnParseEndClassTypeDeclaration + write SetOnParseEndClassTypeDeclaration; + property OnParseAncestorTypeDeclaration: TPaxParserIdentEvent read GetOnParseAncestorTypeDeclaration + write SetOnParseAncestorTypeDeclaration; + property OnParseUsedInterface: TPaxParserIdentEvent read GetOnParseUsedInterface + write SetOnParseUsedInterface; + property OnParseClassReferenceTypeDeclaration: TPaxParserTypedIdentEvent read GetOnParseClassReferenceTypeDeclaration + write SetOnParseClassReferenceTypeDeclaration; + property OnParseAliasTypeDeclaration: TPaxParserTypedIdentEvent read GetOnParseAliasTypeDeclaration + write SetOnParseAliasTypeDeclaration; + property OnParseProceduralTypeDeclaration: TPaxParserIdentEventEx read GetOnParseProceduralTypeDeclaration + write SetOnParseProceduralTypeDeclaration; + property OnParseEventTypeDeclaration: TPaxParserIdentEventEx read GetOnParseEventTypeDeclaration + write SetOnParseEventTypeDeclaration; + property OnParseMethodReferenceTypeDeclaration: TPaxParserIdentEventEx read GetOnParseMethodReferenceTypeDeclaration + write SetOnParseMethodReferenceTypeDeclaration; + property OnParseSetTypeDeclaration: TPaxParserTypedIdentEvent read GetOnParseSetTypeDeclaration + write SetOnParseSetTypeDeclaration; + property OnParsePointerTypeDeclaration: TPaxParserTypedIdentEvent read GetOnParsePointerTypeDeclaration + write SetOnParsePointerTypeDeclaration; + property OnParseArrayTypeDeclaration: TPaxParserArrayTypeEvent read GetOnParseArrayTypeDeclaration + write SetOnParseArrayTypeDeclaration; + property OnParseDynArrayTypeDeclaration: TPaxParserTypedIdentEvent read GetOnParseDynArrayTypeDeclaration + write SetOnParseDynArrayTypeDeclaration; + property OnParseShortStringTypeDeclaration: TPaxParserNamedValueEvent read GetOnParseShortStringTypeDeclaration + write SetOnParseShortStringTypeDeclaration; + property OnParseSubrangeTypeDeclaration: TPaxParserDeclarationEvent read GetOnParseSubrangeTypeDeclaration + write SetOnParseSubrangeTypeDeclaration; + property OnParseBeginRecordTypeDeclaration: TPaxParserIdentEventEx read GetOnParseBeginRecordTypeDeclaration + write SetOnParseBeginRecordTypeDeclaration; + property OnParseEndRecordTypeDeclaration: TPaxParserIdentEvent read GetOnParseEndRecordTypeDeclaration + write SetOnParseEndRecordTypeDeclaration; + property OnParseBeginClassHelperTypeDeclaration: TPaxParserTypedIdentEvent read GetOnParseBeginClassHelperTypeDeclaration + write SetOnParseBeginClassHelperTypeDeclaration; + property OnParseEndClassHelperTypeDeclaration: TPaxParserIdentEvent read GetOnParseEndClassHelperTypeDeclaration + write SetOnParseEndClassHelperTypeDeclaration; + property OnParseBeginRecordHelperTypeDeclaration: TPaxParserTypedIdentEvent read GetOnParseBeginRecordHelperTypeDeclaration + write SetOnParseBeginRecordHelperTypeDeclaration; + property OnParseEndRecordHelperTypeDeclaration: TPaxParserIdentEvent read GetOnParseEndRecordHelperTypeDeclaration + write SetOnParseEndRecordHelperTypeDeclaration; + property OnParseBeginInterfaceTypeDeclaration: TPaxParserIdentEvent read GetOnParseBeginInterfaceTypeDeclaration + write SetOnParseBeginInterfaceTypeDeclaration; + property OnParseEndInterfaceTypeDeclaration: TPaxParserIdentEvent read GetOnParseEndInterfaceTypeDeclaration + write SetOnParseEndInterfaceTypeDeclaration; + property OnParseBeginEnumTypeDeclaration: TPaxParserIdentEvent read GetOnParseBeginEnumTypeDeclaration + write SetOnParseBeginEnumTypeDeclaration; + property OnParseEndEnumTypeDeclaration: TPaxParserIdentEvent read GetOnParseEndEnumTypeDeclaration + write SetOnParseEndEnumTypeDeclaration; + property OnParseEnumName: TPaxParserNamedValueEvent read GetOnParseEnumName + write SetOnParseEnumName; + property OnParseFieldDeclaration: TPaxParserTypedIdentEvent read GetOnParseFieldDeclaration + write SetOnParseFieldDeclaration; + property OnParseVariantRecordFieldDeclaration: TPaxParserVariantRecordFieldEvent read GetOnParseVariantRecordFieldDeclaration + write SetOnParseVariantRecordFieldDeclaration; + property OnParsePropertyDeclaration: TPaxParserTypedIdentEvent read GetOnParsePropertyDeclaration + write SetOnParsePropertyDeclaration; + property OnParseConstantDeclaration: TPaxParserNamedValueEvent read GetOnParseConstantDeclaration + write SetOnParseConstantDeclaration; + property OnParseResourceStringDeclaration: TPaxParserNamedValueEvent read GetOnParseResourceStringDeclaration + write SetOnParseResourceStringDeclaration; + property OnParseTypedConstantDeclaration: TPaxParserNamedTypedValueEvent read GetOnParseTypedConstantDeclaration + write SetOnParseTypedConstantDeclaration; + property OnParseVariableDeclaration: TPaxParserTypedIdentEvent read GetOnParseVariableDeclaration + write SetOnParseVariableDeclaration; + property OnParseBeginSubDeclaration: TPaxParserIdentEvent read GetOnParseBeginSubDeclaration + write SetOnParseBeginSubDeclaration; + property OnParseEndSubDeclaration: TPaxParserDeclarationEvent read GetOnParseEndSubDeclaration + write SetOnParseEndSubDeclaration; + property OnParseBeginFormalParameterList: TPaxParserNotifyEvent read GetOnParseBeginFormalParameterList + write SetOnParseBeginFormalParameterList; + property OnParseEndFormalParameterList: TPaxParserNotifyEvent read GetOnParseEndFormalParameterList + write SetOnParseEndFormalParameterList; + property OnParseFormalParameterDeclaration: TPaxParserNamedTypedValueEvent read GetOnParseFormalParameterDeclaration + write SetOnParseFormalParameterDeclaration; + property OnParseResultType: TPaxParserIdentEvent read GetOnParseResultType + write SetOnParseResultType; + property OnParseSubDirective: TPaxParserIdentEvent read GetOnParseSubDirective + write SetOnParseSubDirective; + published + property ExplicitOff; + property CompleteBooleanEval; + property UnitLookup; + property PrintKeyword; + property PrintlnKeyword; + end; + +procedure SetDump; + +implementation + +uses + PAXCOMP_BYTECODE, + PAXCOMP_STDLIB; + +//--------------------TPaxCompiler---------------------------------------------- + +constructor TPaxCompiler.Create(AOwner: TComponent); +begin + inherited; + kernel := TKernel.Create(Self); +end; + +destructor TPaxCompiler.Destroy; +begin + FreeAndNil(kernel); + inherited; +end; + +procedure TPaxCompiler.Reset; +begin + kernel.Reset; +end; + +procedure TPaxCompiler.ResetCompilation; +begin + kernel.ResetCompilation; +end; + +procedure TPaxCompiler.AddModule(const ModuleName, LanguageName: String); +begin + kernel.AddModule(ModuleName, LanguageName); +end; + +procedure TPaxCompiler.AddCode(const ModuleName, Text: String); +begin + kernel.AddCode(ModuleName, Text); +end; + +procedure TPaxCompiler.AddCodeFromFile(const ModuleName, FileName: String); +begin + kernel.AddCodeFromFile(ModuleName, FileName); +end; + +procedure TPaxCompiler.CreateMapping(Runner: TBaseRunner); +begin + kernel.code.CreateMapping(Runner.HostMapTable, true, + Runner.HostMapTable, nil); + if kernel.SignCompression then + begin + kernel.CompressHostClassList(Runner.HostMapTable); + kernel.SymbolTable.CreateOffsets(Runner.JS_Record.Id_JS_Object, + Runner.JS_Record.Id_JS_Error); + end; +end; + +function TPaxCompiler.CompileExpression(const Expression: String; + APaxRunner: TPaxRunner; + const LangName: String = ''): Boolean; +var + Runner: TBaseRunner; +begin + Runner := APaxRunner.GetProgPtr; + result := false; + + try + Runner.Reset; + RegisterGlobalJSObjects(Runner.JS_Record); + kernel.SetProg(Runner); + + kernel.ParseExpression(Expression, LangName); + if kernel.HasError then Exit; + kernel.Link; + if kernel.HasError then Exit; + + CreateMapping(Runner); + + APaxRunner.EmitProc(kernel, Runner); + finally + if kernel.SignCompression then + kernel.SymbolTable.RestoreClassIndexes; + end; + result := true; +end; + +function TPaxCompiler.Compile(APaxRunner: TPaxRunner; + BuildAll: Boolean = false; + BuildWithRuntimePackages: Boolean = false): boolean; +var + temp: Pointer; + Runner: TBaseRunner; +begin + if kernel.Modules.Count = 0 then + kernel.RaiseError(errEmptyModuleList, []); + + Runner := APaxRunner.GetProgPtr; + result := false; + if BuildWithRuntimePackages then + BuildAll := true; + + temp := CurrKernel; + CurrKernel := Kernel; + try + Runner.Reset; + RegisterGlobalJSObjects(Runner.JS_Record); + kernel.SetProg(Runner); + + kernel.BuildAll := BuildAll; + kernel.BuildWithRuntimePackages := BuildWithRuntimePackages; + + try + + kernel.Parse; + if kernel.HasError then Exit; + + if kernel.ImportOnly then + begin + result := true; + Exit; + end; + + kernel.Link; + if kernel.HasError then Exit; + + if kernel.Canceled then + begin + result := true; + Exit; + end; + + CreateMapping(Runner); + + APaxRunner.EmitProc(kernel, Runner); + + finally + if not kernel.ImportOnly then + begin + if not kernel.BuildWithRuntimePackages then + Runner.ProgList.LoadFromStreamList(kernel.PCUStreamList, Runner); + + if kernel.SignCompression then + kernel.SymbolTable.RestoreClassIndexes; + if BuildWithRuntimePackages then + Runner.ProgList.Clear; + + kernel.BuildAll := false; + kernel.BuildWithRuntimePackages := false; + end; + end; + + result := true; + finally + CurrKernel := temp; + end; +end; + +function TPaxCompiler.Compile: boolean; +var + ClassFactory: TPaxClassFactory; + TypeInfoList: TPaxTypeInfoList; + ExportList: TExportList; + MessageList: TMessageList; +begin + ClassFactory := TPaxClassFactory.Create; + TypeInfoList := TPaxTypeInfoList.Create; + ExportList := TExportList.Create; + MessageList := TMessageList.Create; + + CurrKernel := kernel; + try + kernel.ClassFactory := ClassFactory; + kernel.TypeInfoList := TypeInfoList; + kernel.MessageList := MessageList; + kernel.ExportList := ExportList; + + result := false; + kernel.Parse; + if kernel.HasError then Exit; + + if kernel.ImportOnly then + begin + result := true; + Exit; + end; + + kernel.Link; + if kernel.HasError then Exit; + result := true; + finally + FreeAndNil(ClassFactory); + FreeAndNil(TypeInfoList); + FreeAndNil(ExportList); + FreeAndNil(MessageList); + end; +end; + +function TPaxCompiler.Parse: boolean; +var + ClassFactory: TPaxClassFactory; + TypeInfoList: TPaxTypeInfoList; + ExportList: TExportList; + MessageList: TMessageList; +begin + ClassFactory := TPaxClassFactory.Create; + TypeInfoList := TPaxTypeInfoList.Create; + ExportList := TExportList.Create; + MessageList := TMessageList.Create; + + CurrKernel := kernel; + + try + kernel.ClassFactory := ClassFactory; + kernel.TypeInfoList := TypeInfoList; + kernel.MessageList := MessageList; + kernel.ExportList := ExportList; + + result := false; + kernel.Parse; + if kernel.HasError then Exit; + + if kernel.ImportOnly then + begin + result := true; + Exit; + end; + +// kernel.InterfaceOnly := true; + +// kernel.Link; + result := not kernel.HasError; + + dmp; + + finally + FreeAndNil(ClassFactory); + FreeAndNil(TypeInfoList); + FreeAndNil(ExportList); + FreeAndNil(MessageList); + end; +end; + +function TPaxCompiler.CodeCompletion(const ModuleName: String; + X, Y: Integer; L: TStrings; PaxLang: TPaxCompilerLanguage = nil): Boolean; +var + NN, Op, Id, I: Integer; + ClassFactory: TPaxClassFactory; + TypeInfoList: TPaxTypeInfoList; + ExportList : TExportList; + MessageList : TMessageList; + Lst: TIntegerList; + R: TCodeRec; + WithIsAllowed: Boolean; + temp: Pointer; + SkipParams: Integer; + VisSet: TMemberVisibilitySet; +begin + result := false; + ClassFactory := TPaxClassFactory.Create; + TypeInfoList := TPaxTypeInfoList.Create; + ExportList := TExportList.Create; + MessageList := TMessageList.Create; + + temp := CurrKernel; + CurrKernel := Kernel; + try + kernel.ClassFactory := ClassFactory; + kernel.TypeInfoList := TypeInfoList; + kernel.MessageList := MessageList; + kernel.ExportList := ExportList; + + kernel.ParseCompletion(ModuleName, X, Y); + + if kernel.HasError then + begin + CurrKernel := kernel; + Exit; + end; + if kernel.Code.Card = 0 then Exit; + kernel.Link; + + finally + CurrKernel := temp; + + FreeAndNil(ClassFactory); + FreeAndNil(TypeInfoList); + FreeAndNil(ExportList); + FreeAndNil(MessageList); + end; + + CurrKernel := kernel; + + kernel.Code.LocateDummyName(NN); + if NN > 0 then + begin + Op := kernel.Code[NN].GenOp; + Id := kernel.Code[NN].Arg1; + if Op = OP_EVAL then + begin + if NN < kernel.Code.Card then + if kernel.Code[NN + 1].GenOp = OP_BEGIN_USING then + begin + Id := kernel.Code.GetLevel(NN); + kernel.SymbolTable.ExtractNamespaces(Id, L); + result := true; + Exit; + end; + + if ByteInSet(kernel.CancelChar, [Ord('('), Ord('.')]) then + begin + result := true; + kernel.Errors.Reset; + Exit; + end; + + WithIsAllowed := true; + Lst := TIntegerList.Create; + try + for I := NN downto 1 do + begin + R := kernel.Code[I]; + if R.Op = OP_BEGIN_MODULE then + break; + if R.Op = OP_INIT_SUB then + WithIsAllowed := false; + if R.Op = OP_END_SUB then + WithIsAllowed := false; + if R.Op = OP_END_WITH then + WithIsAllowed := false; + if R.Op = OP_BEGIN_USING then +// if R.Arg1 > 0 then + Lst.Add(R.Arg1); + if R.Op = OP_BEGIN_WITH then + if WithIsAllowed then + Lst.Add(R.Arg1); + end; + + for I := 0 to Lst.Count - 1 do + begin + Id := Lst[I]; + + if Id > 0 then + begin + if kernel.SymbolTable[Id].Kind <> KindNAMESPACE then + if kernel.SymbolTable[Id].TypeId = 0 then + kernel.Code.RestoreFieldType(NN); + end; + + if PaxLang = nil then + kernel.SymbolTable.ExtractMembers(Id, L) + else if PaxLang is TPaxPascalLanguage then + kernel.SymbolTable.ExtractMembers(Id, L) + else + kernel.SymbolTable.ExtractMembers(Id, L, lngBasic); + end; + kernel.Errors.Reset; + + finally + FreeAndNil(Lst); + end; + end + else if Op = OP_FIELD then + begin + if kernel.SymbolTable[Id].Kind <> KindNAMESPACE then + if kernel.SymbolTable[Id].TypeId = 0 then + kernel.Code.RestoreFieldType(NN); + + VisSet := TKernel(kernel).Code.GetCompletionVisibility(Id, NN); + + if PaxLang = nil then + kernel.SymbolTable.ExtractMembers(Id, L, lngPascal, false, VisSet) + else if PaxLang is TPaxPascalLanguage then + kernel.SymbolTable.ExtractMembers(Id, L, lngPascal, false, VisSet) + else + kernel.SymbolTable.ExtractMembers(Id, L, lngBasic, false, VisSet); + + if L.Count > 0 then + kernel.Errors.Reset; + end + else if (Op = OP_CALL) or (Op = OP_BEGIN_CALL) then + begin + if not (kernel.SymbolTable[Id].Kind in KindSUBS) then + Exit; + + if kernel.CompletionTarget <> '' then + begin + if StrEql(kernel.CompletionTarget, 'New') or + StrEql(kernel.CompletionTarget, 'Dispose') then + begin + L.Add('X: Pointer'); + kernel.Errors.Reset; + end; + end + else + begin + if Id = JS_FunctionCallId then + begin + with kernel do + for I := Code.GetStmt(NN) to Code.Card do + if Code[I].Op = OP_PUSH_INST then + if Code[I].Res = JS_FunctionCallId then + begin + Id := Code[I].Arg1; + Inc(Id); + if SymbolTable[Id].Kind = KindSUB then + break + else + begin + kernel.Errors.Reset; + Exit; + end; + end; + end; + + SkipParams := 0; + I := NN; + while I > 1 do + begin + Dec(I); + with kernel do + if Code[I].GenOp = OP_PUSH then + if SymbolTable[Code[I].Arg1].Name = DummyName then + break; + end; + while I > 1 do + begin + Dec(I); + Op := kernel.Code[I].GenOp; + with kernel do + if Op = OP_PUSH then + begin + if Code[I].Res = Id then + Inc(SkipParams); + end + else + if Op = OP_BEGIN_CALL then + begin + if Code[I].Arg1 = Id then + break; + end; + end; + + kernel.SymbolTable.ExtractParametersEx(Id, L, true, SkipParams); + kernel.Errors.Reset; + end; + end + else if (Op = OP_PRINT) or (Op = OP_PRINT_EX) then + begin + L.Add('P1;[...,PN]'); + kernel.Errors.Reset; + end + else if Op = OP_ABS then + begin + L.Add('X: Real'); + kernel.Errors.Reset; + end + else if (Op = OP_INC) or (Op = OP_DEC) then + begin + L.Add('var X: Ordinal; [N: Integer]'); + kernel.Errors.Reset; + end + else if (Op = OP_PRED) or + (Op = OP_SUCC) or + (Op = OP_ORD) then + begin + L.Add('X: Ordinal'); + kernel.Errors.Reset; + end + else if Op = OP_CHR then + begin + L.Add('X: Byte'); + kernel.Errors.Reset; + end + else if Op = OP_STR then + begin + L.Add('const X[: Width[:Decimals]]; var S: String'); + kernel.Errors.Reset; + end + else if (Op = OP_SIZEOF) or + (Op = OP_ASSIGNED) or + (Op = OP_LOW) or + (Op = OP_HIGH) then + begin + L.Add('var X'); + kernel.Errors.Reset; + end + else // error + Exit; + end + else + begin + kernel.Errors.Reset; + end; + + result := not kernel.HasError; +end; + +function TPaxCompiler.FindDeclaration(const ModuleName: String; + X, Y: Integer; + PaxLang: TPaxCompilerLanguage = nil): Integer; +var + ClassFactory: TPaxClassFactory; + TypeInfoList: TPaxTypeInfoList; + ExportList : TExportList; + MessageList : TMessageList; + temp: Pointer; + Id, TypeId, LevelId: Integer; + S: String; +begin + result := 0; + + ClassFactory := TPaxClassFactory.Create; + TypeInfoList := TPaxTypeInfoList.Create; + ExportList := TExportList.Create; + MessageList := TMessageList.Create; + + temp := CurrKernel; + CurrKernel := Kernel; + try + kernel.ClassFactory := ClassFactory; + kernel.TypeInfoList := TypeInfoList; + kernel.MessageList := MessageList; + kernel.ExportList := ExportList; + + kernel.FindDeclId := -1; + kernel.ParseCompletion(ModuleName, X, Y); + + if kernel.HasError then + Exit; + if kernel.Code.Card = 0 then Exit; + kernel.Link; + + finally + if kernel.FindDeclId < 0 then + kernel.FindDeclId := 0; + + CurrKernel := temp; + + FreeAndNil(ClassFactory); + FreeAndNil(TypeInfoList); + FreeAndNil(ExportList); + FreeAndNil(MessageList); + end; + + result := kernel.FindDeclId; + + if result > 0 then + with kernel do + begin + Id := SymbolTable[result].OwnerId; + if SymbolTable[result].Kind = KindVAR then + if Id > 0 then + begin + S := SymbolTable[result].Name; + TypeId := SymbolTable[Id].TerminalTypeId; + result := SymbolTable.Lookup(S, TypeId, true); + end + else if PaxLang = nil then + begin + LevelId := SymbolTable[result].Level; + if LevelId > 0 then + if SymbolTable[LevelId].Kind = KindSUB then + if result = SymbolTable.GetResultId(LevelId) then + result := LevelId; + end + else if StrEql(PaxLang.LanguageName, 'Pascal') then + begin + LevelId := SymbolTable[result].Level; + if LevelId > 0 then + if SymbolTable[LevelId].Kind = KindSUB then + if result = SymbolTable.GetResultId(LevelId) then + result := LevelId; + end; + end; +end; + +procedure TPaxCompiler.RegisterLanguage(L: TPaxCompilerLanguage); +begin + kernel.RegisterParser(L.GetParser); +end; + +procedure TPaxCompiler.RegisterDirective(const Directive: string; const value: Variant); +begin + kernel.DefList.Add(Directive, value); +end; + +function TPaxCompiler.RegisterNamespace(LevelId: Integer; + const NamespaceName: String): Integer; +begin + result := kernel.SymbolTable.RegisterNamespace(LevelId, NamespaceName); +end; + +procedure TPaxCompiler.RegisterUsingNamespace(const aNamespaceName: String); +Var + H: integer; +begin + H := kernel.SymbolTable.LookupNamespace(aNamespaceName, 0, True); + if H > 0 then + RegisterUsingNamespace (H); +end; + +procedure TPaxCompiler.RegisterUsingNamespace(aNamespaceID: Integer); +begin + kernel.SymbolTable.HeaderParser.UsedNamespaceList.Add(aNamespaceID); +end; + +procedure TPaxCompiler.UnregisterUsingNamespace(aNamespaceID: Integer); +begin + kernel.SymbolTable.HeaderParser.UsedNamespaceList.DeleteValue(aNamespaceID); +end; + +procedure TPaxCompiler.UnregisterUsingNamespaces; +begin + kernel.SymbolTable.HeaderParser.UsedNamespaceList.Clear; +end; + +procedure TPaxCompiler.UnregisterUsingNamespace(const aNamespaceName: String); +Var + H: integer; +begin + H := kernel.SymbolTable.LookupNamespace(aNamespaceName, 0, True); + if H > 0 then + UnRegisterUsingNamespace (H); +end; + +function TPaxCompiler.RegisterInterfaceType(LevelId: Integer; + const TypeName: String; + const GUID: TGUID): Integer; +begin + result := kernel.SymbolTable.RegisterInterfaceType(LevelId, TypeName, GUID); +end; + +function TPaxCompiler.RegisterInterfaceType(LevelId: Integer; + const TypeName: String; + const GUID: TGUID; + const ParentName: String; + const ParentGUID: TGUID): Integer; +begin + result := kernel.SymbolTable.RegisterInterfaceType(LevelId, TypeName, GUID); + kernel.SymbolTable.RegisterSupportedInterface(result, ParentName, ParentGUID); +end; + +procedure TPaxCompiler.RegisterSupportedInterface(TypeId: Integer; + const SupportedInterfaceName: String; + const GUID: TGUID); +begin + kernel.SymbolTable.RegisterSupportedInterface(TypeId, SupportedInterfaceName, GUID); +end; + +function TPaxCompiler.RegisterClassType(LevelId: Integer; + const TypeName: String; AncestorId: Integer): Integer; +begin + result := kernel.SymbolTable.RegisterClassType(LevelId, TypeName, AncestorId); +end; + +function TPaxCompiler.RegisterClassType(LevelId: Integer; + C: TClass): Integer; +begin + result := kernel.SymbolTable.RegisterClassType(LevelId, C); +end; + +function TPaxCompiler.RegisterClassReferenceType(LevelId: Integer; + const TypeName: String; OriginClassId: Integer): Integer; +begin + result := kernel.SymbolTable.RegisterClassReferenceType(LevelId, TypeName, OriginClassId); +end; + +function TPaxCompiler.RegisterClassHelperType(LevelId: Integer; + const TypeName: String; OriginClassId: Integer): Integer; +begin + result := kernel.SymbolTable.RegisterHelperType(LevelId, TypeName, OriginClassId); +end; + +function TPaxCompiler.RegisterClassHelperType(LevelID: Integer; const TypeName, OriginalTypeName: String): Integer; +var + OriginClassId: Integer; +begin + OriginClassId := kernel.SymbolTable.LookUpType(OriginalTypeName, 0, true); + result := kernel.SymbolTable.RegisterHelperType(LevelId, TypeName, OriginClassId); +end; + +function TPaxCompiler.RegisterRecordHelperType(LevelId: Integer; + const TypeName: String; OriginRecordId: Integer): Integer; +begin + result := kernel.SymbolTable.RegisterHelperType(LevelId, TypeName, OriginRecordId); +end; + +function TPaxCompiler.RegisterRecordHelperType(LevelID: Integer; const TypeName, OriginalTypeName: String): Integer; +var + OriginRecordId: Integer; +begin + OriginRecordId := kernel.SymbolTable.LookUpType(OriginalTypeName, 0, true); + result := kernel.SymbolTable.RegisterHelperType(LevelId, TypeName, OriginRecordId); +end; + +function TPaxCompiler.RegisterClassTypeField(TypeId: Integer; const FieldName: String; + FieldTypeID: Integer; FieldShift: Integer = -1): Integer; +begin + result := kernel.SymbolTable.RegisterTypeField(TypeId, FieldName, FieldTypeID, FieldShift); +end; + +function TPaxCompiler.RegisterProperty(LevelId: Integer; const PropName: String; + PropTypeID, ReadId, WriteId: Integer; + IsDefault: Boolean): Integer; +begin + result := kernel.SymbolTable.RegisterProperty(LevelId, PropName, PropTypeId, + ReadId, WriteId, IsDefault); +end; + +function TPaxCompiler.RegisterInterfaceProperty(LevelId: Integer; + const PropName: String; + PropTypeID, + ReadIndex, + WriteIndex: Integer): Integer; +begin + result := kernel.SymbolTable.RegisterInterfaceProperty(LevelId, PropName, PropTypeId, + ReadIndex, WriteIndex); +end; + +function TPaxCompiler.RegisterProperty(LevelId: Integer; const Header: String): Integer; +begin + result := kernel.SymbolTable.RegisterHeader(LevelId, Header, nil); +end; + +function TPaxCompiler.RegisterRecordType(LevelId: Integer; + const TypeName: String; + IsPacked: Boolean = false): Integer; +begin + if IsPacked then + result := kernel.SymbolTable.RegisterRecordType(LevelId, TypeName, 1) + else + result := kernel.SymbolTable.RegisterRecordType(LevelId, TypeName, kernel.Alignment); +end; + +function TPaxCompiler.RegisterRecordTypeField(TypeId: Integer; const FieldName: String; + FieldTypeID: Integer; FieldShift: Integer = -1): Integer; +begin + result := kernel.SymbolTable.RegisterTypeField(TypeId, FieldName, FieldTypeID, FieldShift); +end; + +function TPaxCompiler.RegisterVariantRecordTypeField(TypeId: Integer; const FieldName: String; + FieldTypeID: Integer; + VarCount: Int64): Integer; +begin + result := kernel.SymbolTable.RegisterVariantRecordTypeField(TypeId, + FieldName, + FieldTypeId, + VarCount); +end; + +function TPaxCompiler.RegisterVariantRecordTypeField(LevelId: Integer; const Declaration: String; + VarCount: Int64): Integer; +begin + result := kernel.SymbolTable.RegisterVariantRecordTypeField(LevelId, + Declaration, VarCount); +end; + +function TPaxCompiler.RegisterSubrangeType(LevelId: Integer; + const TypeName: String; + TypeBaseId: Integer; + B1, B2: Integer): Integer; +begin + result := kernel.SymbolTable.RegisterSubrangeType(LevelId, TypeName, TypeBaseId, B1, B2); +end; + +function TPaxCompiler.RegisterEnumType(LevelId: Integer; + const TypeName: String; + TypeBaseId: Integer = _typeINTEGER): Integer; +begin + result := kernel.SymbolTable.RegisterEnumType(LevelId, TypeName, TypeBaseId); +end; + +function TPaxCompiler.RegisterEnumValue(EnumTypeId: Integer; + const FieldName: String; + const Value: Integer): Integer; +begin + result := kernel.SymbolTable.RegisterEnumValue(EnumTypeId, FieldName, Value); +end; + + +function TPaxCompiler.RegisterArrayType(LevelId: Integer; + const TypeName: String; + RangeTypeId, ElemTypeId: Integer; + IsPacked: Boolean = false): Integer; +begin + if IsPacked then + result := kernel.SymbolTable.RegisterArrayType(LevelId, TypeName, RangeTypeId, ElemTypeId, 1) + else + result := kernel.SymbolTable.RegisterArrayType(LevelId, TypeName, RangeTypeId, ElemTypeId, kernel.Alignment); +end; + +function TPaxCompiler.RegisterDynamicArrayType(LevelId: Integer; + const TypeName: String; + ElemTypeId: Integer): Integer; +begin + result := kernel.SymbolTable.RegisterDynamicArrayType(LevelId, TypeName, ElemTypeId); +end; + +function TPaxCompiler.RegisterPointerType(LevelId: Integer; + const TypeName: String; + OriginTypeId: Integer; + const OriginTypeName: String = ''): Integer; +begin + result := kernel.SymbolTable.RegisterPointerType(LevelId, + TypeName, OriginTypeId, OriginTypeName); +end; + +function TPaxCompiler.RegisterMethodReferenceType(LevelId: Integer; + const TypeName: String; + SubId: Integer): Integer; +begin + result := kernel.SymbolTable.RegisterMethodReferenceType(LevelId, TypeName, SubId); +end; + +function TPaxCompiler.RegisterTypeDeclaration(LevelId: Integer; + const Declaration: String): Integer; +begin + result := kernel.SymbolTable.RegisterTypeDeclaration(LevelId, Declaration); +end; + +function TPaxCompiler.RegisterSomeType(LevelId: Integer; + const TypeName: String): Integer; +begin + result := kernel.SymbolTable.RegisterSomeType(LevelId, TypeName); +end; + +function TPaxCompiler.RegisterSetType(LevelId: Integer; + const TypeName: String; + OriginTypeId: Integer): Integer; +begin + result := kernel.SymbolTable.RegisterSetType(LevelId, TypeName, OriginTypeId); +end; + +function TPaxCompiler.RegisterProceduralType(LevelId: Integer; + const TypeName: String; + SubId: Integer): Integer; +begin + result := kernel.SymbolTable.RegisterProceduralType(LevelId, TypeName, SubId); +end; + +{$IFNDEF PAXARM} +function TPaxCompiler.RegisterShortStringType(LevelId: Integer; + const TypeName: String; + L: Integer): Integer; +begin + result := kernel.SymbolTable.RegisterShortStringType(LevelId, TypeName, L); +end; +{$ENDIF} + +function TPaxCompiler.RegisterEventType(LevelId: Integer; + const TypeName: String; + SubId: Integer): Integer; +begin + result := kernel.SymbolTable.RegisterEventType(LevelId, TypeName, SubId); +end; + +function TPaxCompiler.RegisterRTTIType(LevelId: Integer; pti: PTypeInfo): Integer; +begin + result := kernel.SymbolTable.RegisterRTTIType(LevelId, pti); +end; + +function TPaxCompiler.RegisterTypeAlias(LevelId:Integer; const TypeName: String; + OriginTypeId: Integer): Integer; +begin + result := kernel.SymbolTable.RegisterTypeAlias(LevelId, TypeName, OriginTypeId); +end; + +function TPaxCompiler.RegisterObject(LevelId: Integer; + const ObjectName: String; + TypeId: Integer; + Address: Pointer = nil): Integer; +begin + result := kernel.SymbolTable.RegisterObject(LevelId, ObjectName, TypeId, Address); +end; + +function TPaxCompiler.RegisterVirtualObject(LevelId: Integer; + const ObjectName: String): Integer; +begin + result := kernel.SymbolTable.RegisterVirtualObject(LevelId, ObjectName); +end; + +function TPaxCompiler.RegisterVariable(LevelId: Integer; + const VarName: String; + TypeId: Integer; + Address: Pointer = nil): Integer; +begin + result := kernel.SymbolTable.RegisterVariable(LevelId, VarName, TypeId, Address); +end; + +function TPaxCompiler.RegisterVariable(LevelId: Integer; + const Declaration: String; Address: Pointer): Integer; +begin + result := kernel.SymbolTable.RegisterVariable(LevelId, Declaration, Address); +end; + +function TPaxCompiler.RegisterConstant(LevelId: Integer; + const ConstName: String; + typeID: Integer; + const Value: Variant): Integer; +begin + result := kernel.SymbolTable.RegisterConstant(LevelId, ConstName, TypeId, Value); +end; + +function TPaxCompiler.RegisterConstant(LevelId: Integer; + const ConstName: String; + const Value: Variant): Integer; +begin + result := kernel.SymbolTable.RegisterConstant(LevelId, ConstName, Value); +end; + +function TPaxCompiler.RegisterPointerConstant(LevelId: Integer; + const ConstName: String; + const Value: Pointer): Integer; +begin + result := kernel.SymbolTable.RegisterPointerConstant(LevelId, ConstName, Value); +end; + +function TPaxCompiler.RegisterConstant(LevelId: Integer; + const ConstName: String; + const Value: Extended): Integer; +begin + result := kernel.SymbolTable.RegisterExtendedConstant(LevelId, ConstName, Value); +end; + +function TPaxCompiler.RegisterConstant(LevelId: Integer; + const ConstName: String; + const Value: Int64): Integer; +begin + result := kernel.SymbolTable.RegisterInt64Constant(LevelId, ConstName, Value); +end; + +function TPaxCompiler.RegisterConstant(LevelId: Integer; + const Declaration: String): Integer; +begin + result := kernel.SymbolTable.RegisterConstant(LevelId, Declaration); +end; + +function TPaxCompiler.RegisterRoutine(LevelId: Integer; + const RoutineName: String; ResultTypeID: Integer; + CallConvention: Integer; + Address: Pointer = nil): Integer; +begin + result := kernel.SymbolTable.RegisterRoutine(LevelId, RoutineName, ResultTypeId, + CallConvention, Address); +end; + +function TPaxCompiler.RegisterRoutine(LevelId: Integer; const Name: String; + ResultId: Integer; + Address: Pointer; + CallConvention: Integer = _ccREGISTER; + OverCount: Integer = 0; + i_IsDeprecated: Boolean = false): Integer; +begin + result := kernel.SymbolTable.RegisterRoutine(LevelId, Name, + ResultId, CallConvention, Address, OverCount, i_IsDeprecated); +end; + +function TPaxCompiler.RegisterRoutine(LevelId: Integer; const Name, ResultType: String; + Address: Pointer; + CallConvention: Integer = _ccREGISTER; + OverCount: Integer = 0; + i_IsDeprecated: Boolean = false): Integer; +begin + result := kernel.SymbolTable.RegisterRoutine(LevelId, Name, ResultType, + CallConvention, Address, OverCount, i_IsDeprecated); +end; + +function TPaxCompiler.RegisterMethod(LevelId: Integer; + const RoutineName: String; ResultTypeID: Integer; + CallConvention: Integer; + Address: Pointer = nil; + IsShared: Boolean = false): Integer; +begin + result := kernel.SymbolTable.RegisterMethod(LevelId, RoutineName, ResultTypeId, + CallConvention, Address, IsShared); +end; + +function TPaxCompiler.RegisterMethod(ClassId: Integer; + const Name: String; + ResultId: Integer; + Address: Pointer; + CallConvention: Integer = _ccREGISTER; + IsShared: Boolean = false; + CallMode: Integer = _cmNONE; + MethodIndex: Integer = 0; + OverCount: Integer = 0; + i_IsAbstract: Boolean = false; + i_AbstractMethodCount: Integer = 0; + i_IsDeprecated: Boolean = false): Integer; +begin + result := kernel.SymbolTable.RegisterMethod(ClassId, + Name, + ResultId, + CallConvention, + Address, + IsShared, + CallMode, + MethodIndex, + OverCount, + i_IsAbstract, + i_AbstractMethodCount, + i_IsDeprecated); +end; + +function TPaxCompiler.RegisterMethod(ClassId: Integer; + const Name, ResultType: String; + Address: Pointer; + CallConvention: Integer = _ccREGISTER; + IsShared: Boolean = false; + CallMode: Integer = _cmNONE; + MethodIndex: Integer = 0; + OverCount: Integer = 0; + i_IsAbstract: Boolean = false; + i_AbstractMethodCount: Integer = 0; + i_IsDeprecated: Boolean = false): Integer; +begin + result := kernel.SymbolTable.RegisterMethod(ClassId, + Name, + ResultType, + CallConvention, + Address, + IsShared, + CallMode, + MethodIndex, + OverCount, + i_IsAbstract, + i_AbstractMethodCount, + i_IsDeprecated); +end; + +function TPaxCompiler.RegisterConstructor(ClassId: Integer; + const Name: String; + Address: Pointer; + CallConvention: Integer = _ccREGISTER; + IsShared: Boolean = false; + CallMode: Integer = 0; + i_MethodIndex: Integer = 0; + OverCount: Integer = 0; + i_IsAbstract: Boolean = false; + i_AbstractMethodCount: Integer = 0; + i_IsDeprecated: Boolean = false): Integer; +begin + result := kernel.SymbolTable.RegisterConstructor(ClassId, + Name, Address, IsShared, CallMode, i_MethodIndex, OverCount, + i_IsAbstract, i_AbstractMethodCount, i_IsDeprecated); +end; + +function TPaxCompiler.RegisterDestructor(ClassId: Integer; const Name: String; + Address: Pointer): Integer; +begin + result := kernel.SymbolTable.RegisterDestructor(ClassId, Name, Address); +end; + +function TPaxCompiler.RegisterParameter(HSub: Integer; ParamTypeID: Integer; + const DefaultValue: Variant; + ByRef: Boolean = false): Integer; +begin + result := kernel.SymbolTable.RegisterParameter(HSub, ParamTypeId, DefaultValue, ByRef); +end; + +function TPaxCompiler.RegisterParameter(LevelId: Integer; + const ParameterName: String; + ParamTypeID: Integer; + ParamMod: Integer = 0; + Optional: Boolean = false; + const DefaultValue: String = ''): Integer; +begin + result := kernel.SymbolTable.RegisterParameter(LevelId, + ParameterName, + ParamTypeId, + ParamMod, + Optional, + DefaultValue); +end; + +function TPaxCompiler.RegisterParameter(LevelId: Integer; + const ParameterName: String; + const ParameterType: String; + ParamMod: Integer = 0; + Optional: Boolean = false; + const DefaultValue: String = ''): Integer; +begin + result := kernel.SymbolTable.RegisterParameter(LevelId, + ParameterName, + ParameterType, + ParamMod, + Optional, + DefaultValue); +end; + +function TPaxCompiler.RegisterHeader(LevelId: Integer; const Header: String; + Address: Pointer = nil; + MethodIndex: Integer = 0): Integer; +begin + result := kernel.SymbolTable.RegisterHeader(LevelId, Header, Address, MethodIndex); +end; + +function TPaxCompiler.RegisterFakeHeader(LevelId: Integer; + const Header: String; Address: Pointer): Integer; +begin + result := kernel.SymbolTable.RegisterFakeHeader(LevelId, Header, Address); +end; + +function TPaxCompiler.GetHandle(LevelId: Integer; const MemberName: String; Upcase: Boolean): Integer; +begin + result := kernel.GetHandle(LevelId, MemberName, Upcase); +end; + +function TPaxCompiler.GetTargetPlatform: Integer; +begin + result := Ord(kernel.TargetPlatform); +end; + +procedure TPaxCompiler.SetTargetPlatform(value: Integer); +begin + kernel.TargetPlatform := TTargetPlatform(value); +end; + +function TPaxCompiler.GetErrorCount: Integer; +begin + result := kernel.Errors.Count; +end; + +function TPaxCompiler.GetErrorMessage(I: Integer): String; +begin + if (I >= 0) and (I < GetErrorCount) then + result := kernel.Errors[I].Message + else + result := ''; +end; + +function TPaxCompiler.GetErrorModuleName(I: Integer): String; +begin + if (I >= 0) and (I < GetErrorCount) then + result := kernel.Errors[I].ModuleName + else + result := ''; +end; + +function TPaxCompiler.GetErrorLine(I: Integer): String; +begin + if (I >= 0) and (I < GetErrorCount) then + result := kernel.Errors[I].SourceLine + else + result := ''; +end; + +function TPaxCompiler.GetErrorFileName(I: Integer): String; +begin + if (I >= 0) and (I < GetErrorCount) then + result := kernel.Errors[I].SourceFileName + else + result := ''; +end; + +function TPaxCompiler.GetErrorLineNumber(I: Integer): Integer; +begin + if (I >= 0) and (I < GetErrorCount) then + result := kernel.Errors[I].SourceLineNumber + else + result := 0; +end; + +function TPaxCompiler.GetErrorLinePos(I: Integer): Integer; +begin + if (I >= 0) and (I < GetErrorCount) then + result := kernel.Errors[I].LinePos + else + result := 0; +end; + +function TPaxCompiler.GetWarningCount: Integer; +begin + result := kernel.Warnings.Count; +end; + +function TPaxCompiler.GetWarningMessage(I: Integer): String; +begin + if (I >= 0) and (I < GetWarningCount) then + result := kernel.Warnings[I].Message + else + result := ''; +end; + +function TPaxCompiler.GetWarningModuleName(I: Integer): String; +begin + if (I >= 0) and (I < GetWarningCount) then + result := kernel.Warnings[I].ModuleName + else + result := ''; +end; + +function TPaxCompiler.GetWarningLine(I: Integer): String; +begin + if (I >= 0) and (I < GetWarningCount) then + result := kernel.Warnings[I].SourceLine + else + result := ''; +end; + +function TPaxCompiler.GetWarningLineNumber(I: Integer): Integer; +begin + if (I >= 0) and (I < GetWarningCount) then + result := kernel.Warnings[I].SourceLineNumber + else + result := 0; +end; + +function TPaxCompiler.GetWarningLinePos(I: Integer): Integer; +begin + if (I >= 0) and (I < GetWarningCount) then + result := kernel.Warnings[I].LinePos + else + result := 0; +end; + +function TPaxCompiler.GetWarningFileName(I: Integer): String; +begin + if (I >= 0) and (I < GetWarningCount) then + result := kernel.Warnings[I].SourceFileName + else + result := ''; +end; + +function TPaxCompiler.GetOnCompilerProgress: TPaxCompilerNotifyEvent; +begin + result := TPaxCompilerNotifyEvent(kernel.OnCompilerProgress); +end; + +procedure TPaxCompiler.SetOnCompilerProgress(value: TPaxCompilerNotifyEvent); +begin + kernel.OnCompilerProgress := TNotifyEvent(value); +end; + +function TPaxCompiler.GetOnUsedUnit: TPaxCompilerUsedUnitEvent; +begin + result := TPaxCompilerUsedUnitEvent(kernel.OnUsedUnit); +end; + +procedure TPaxCompiler.SetOnUsedUnit(value: TPaxCompilerUsedUnitEvent); +begin + kernel.OnUsedUnit := TUsedUnitEvent(value); +end; + +function TPaxCompiler.GetOnImportUnit: TPaxCompilerImportMemberEvent; +begin + result := TPaxCompilerImportMemberEvent(kernel.OnImportUnit); +end; + +procedure TPaxCompiler.SetOnImportUnit(value: TPaxCompilerImportMemberEvent); +begin + kernel.OnImportUnit := TImportMemberEvent(value); +end; + +function TPaxCompiler.GetOnImportType: TPaxCompilerImportMemberEvent; +begin + result := TPaxCompilerImportMemberEvent(kernel.OnImportType); +end; + +procedure TPaxCompiler.SetOnImportType(value: TPaxCompilerImportMemberEvent); +begin + kernel.OnImportType := TImportMemberEvent(value); +end; + +function TPaxCompiler.GetOnImportGlobalMembers: TPaxCompilerNotifyEvent; +begin + result := TPaxCompilerNotifyEvent(kernel.OnImportGlobalMembers); +end; + +procedure TPaxCompiler.SetOnImportGlobalMembers(value: TPaxCompilerNotifyEvent); +begin + kernel.OnImportGlobalMembers := TNotifyEvent(value); +end; + +function TPaxCompiler.GetOnUnitAlias: TPaxCompilerUnitAliasEvent; +begin + result := TPaxCompilerUnitAliasEvent(kernel.OnUnitAlias); +end; + +procedure TPaxCompiler.SetOnUnitAlias(value: TPaxCompilerUnitAliasEvent); +begin + kernel.OnUnitAlias := TUnitAliasEvent(value); +end; + +function TPaxCompiler.GetOnSavePCU: TPaxCompilerSavePCUEvent; +begin + result := TPaxCompilerSavePCUEvent(kernel.OnSavePCU); +end; + +procedure TPaxCompiler.SetOnSavePCU(value: TPaxCompilerSavePCUEvent); +begin + kernel.OnSavePCU := TSavePCUEvent(value); +end; + +function TPaxCompiler.GetOnLoadPCU: TPaxCompilerLoadPCUEvent; +begin + result := TPaxCompilerLoadPCUEvent(kernel.OnLoadPCU); +end; + +procedure TPaxCompiler.SetOnLoadPCU(value: TPaxCompilerLoadPCUEvent); +begin + kernel.OnLoadPCU := TLoadPCUEvent(value); +end; + +function TPaxCompiler.GetOnInclude: TPaxCompilerIncludeEvent; +begin + result := TPaxCompilerIncludeEvent(kernel.OnInclude); +end; + +procedure TPaxCompiler.SetOnInclude(value: TPaxCompilerIncludeEvent); +begin + kernel.OnInclude := TIncludeEvent(value); +end; + +function TPaxCompiler.GetOnDefineDirective: TPaxCompilerDirectiveEvent; +begin + result := TPaxCompilerDirectiveEvent(kernel.OnDefineDirective); +end; + +procedure TPaxCompiler.SetOnDefineDirective(value: TPaxCompilerDirectiveEvent); +begin + kernel.OnDefineDirective := TCompilerDirectiveEvent(value); +end; + +function TPaxCompiler.GetOnUndefineDirective: TPaxCompilerDirectiveEvent; +begin + result := TPaxCompilerDirectiveEvent(kernel.OnUndefineDirective); +end; + +procedure TPaxCompiler.SetOnUndefineDirective(value: TPaxCompilerDirectiveEvent); +begin + kernel.OnUndefineDirective := TCompilerDirectiveEvent(value); +end; + +function TPaxCompiler.GetOnUnknownDirective: TPaxCompilerDirectiveEvent; +begin + result := TPaxCompilerDirectiveEvent(kernel.OnUnknownDirective); +end; + +procedure TPaxCompiler.SetOnUnknownDirective(value: TPaxCompilerDirectiveEvent); +begin + kernel.OnUnknownDirective := TCompilerDirectiveEvent(value); +end; + +function TPaxCompiler.GetSourceModule(const ModuleName: String): TStringList; +var + I: Integer; +begin + I := kernel.Modules.IndexOf(ModuleName); + if I >= 0 then + result := kernel.Modules[I].Lines + else + result := nil; +end; + +function TPaxCompiler.GetCurrLineNumber: Integer; +begin + result := kernel.Code.GetSourceLineNumber(kernel.Code.N); +end; + +function TPaxCompiler.GetCurrModuleNumber: Integer; +begin + result := kernel.Code.GetModuleNumber(kernel.Code.N); +end; + +function TPaxCompiler.GetCurrModuleName: String; +begin + result := kernel.Modules[CurrModuleNumber].Name; +end; + +function TPaxCompiler.GetDebugMode: Boolean; +begin + result := kernel.DEBUG_MODE; +end; + +procedure TPaxCompiler.SetDebugMode(value: Boolean); +begin + kernel.DEBUG_MODE := value; +end; + +// added in v 1.5 + +function TPaxCompiler.GetKernelPtr: Pointer; +begin + result := kernel; +end; + +// added in v 1.6 + +procedure TPaxCompiler.RegisterGlobalJSObjects(var R: TJS_Record); +begin + with kernel.SymbolTable do + begin + R.H_JS_Object := RegisterVariable(JS_JavaScriptNamespace, + 'Object', JS_ObjectClassId, nil); + R.Id_JS_Object := kernel.SymbolTable.Card; + + R.H_JS_Boolean := RegisterVariable(JS_JavaScriptNamespace, + 'Boolean', JS_BooleanClassId, nil); + R.Id_JS_Boolean := kernel.SymbolTable.Card; + + R.H_JS_String := RegisterVariable(JS_JavaScriptNamespace, + 'String', JS_StringClassId, nil); + R.Id_JS_String := kernel.SymbolTable.Card; + + R.H_JS_Number := RegisterVariable(JS_JavaScriptNamespace, + 'Number', JS_NumberClassId, nil); + R.Id_JS_Number := kernel.SymbolTable.Card; + + R.H_JS_Date := RegisterVariable(JS_JavaScriptNamespace, + 'Date', JS_DateClassId, nil); + R.Id_JS_Date := kernel.SymbolTable.Card; + + R.H_JS_Function := RegisterVariable(JS_JavaScriptNamespace, + 'Function', JS_FunctionClassId, nil); + R.Id_JS_Function := kernel.SymbolTable.Card; + + R.H_JS_Array := RegisterVariable(JS_JavaScriptNamespace, + 'Array', JS_ArrayClassId, nil); + R.Id_JS_Array := kernel.SymbolTable.Card; + + R.H_JS_RegExp := RegisterVariable(JS_JavaScriptNamespace, + 'RegExp', JS_RegExpClassId, nil); + R.Id_JS_RegExp := kernel.SymbolTable.Card; + + R.H_JS_Math := RegisterVariable(JS_JavaScriptNamespace, + 'Math', JS_MathClassId, nil); + R.Id_JS_Math := kernel.SymbolTable.Card; + + R.H_JS_Error := RegisterVariable(JS_JavaScriptNamespace, + 'Error', JS_ErrorClassId, nil); + R.Id_JS_Error := kernel.SymbolTable.Card; + end; +end; + +// added in v 1.9 + +function TPaxCompiler.GetCondDirectiveList: TStringList; +begin + result := kernel.CondDirectiveList; +end; + +function TPaxCompiler.GetAlignment: Integer; +begin + result := kernel.Alignment; +end; + +procedure TPaxCompiler.SetAlignment(value: Integer); +begin + if not + ( + (value = 1) or (value = 2) or + (value = 4) or (value = 8) + ) + then + raise Exception.Create(Format(errInvalidAlignmentValue, [value])); + + kernel.Alignment := value; +end; + +function TPaxCompiler.GetUndeclaredTypes: TStringList; +begin + result := kernel.UndeclaredTypes; +end; + +function TPaxCompiler.GetUndeclaredIdentifiers: TStringList; +begin + result := kernel.UndeclaredIdents; +end; + +function TPaxCompiler.GetCurrLanguage: String; +begin + result := kernel.CurrLanguage; +end; + +procedure TPaxCompiler.SetCurrLanguage(const value: String); +begin + kernel.CurrLanguage := value; +end; + +function TPaxCompiler.GetOnUndeclaredIdentifier: TPaxCompilerUndeclaredIdentifierEvent; +begin + result := TPaxCompilerUndeclaredIdentifierEvent(TKernel(kernel).OnUndeclaredIdentifier); +end; + +procedure TPaxCompiler.SetOnUndeclaredIdentifier(value: TPaxCompilerUndeclaredIdentifierEvent); +begin + TKernel(kernel).OnUndeclaredIdentifier := TUndeclaredIdentifierEvent(value); +end; + +function TPaxCompiler.GetOnComment: TPaxCompilerCommentEvent; +begin + result := TPaxCompilerCommentEvent(TKernel(kernel).OnComment); +end; + +procedure TPaxCompiler.SetOnComment(value: TPaxCompilerCommentEvent); +begin + TKernel(kernel).OnComment := TCommentEvent(value); +end; + +function TPaxCompiler.LookupId(const FullName: String; UpCase: Boolean = true): Integer; +begin + if FullName = '' then + begin + result := 0; + Exit; + end; + result := TKernel(kernel).SymbolTable.LookupFullName(FullName, UpCase); +end; + +function TPaxCompiler.LookupTypeId(const TypeName: String): Integer; +begin + result := TKernel(kernel).SymbolTable.LookupType(TypeName, true); +end; + +function TPaxCompiler.LookupTypeNamespaceId(const TypeName: String): Integer; +var + R: TSymbolRec; + L, Id: Integer; +begin + result := 0; + Id := LookupTypeId(TypeName); + if Id = 0 then + Exit; + + L := TKernel(kernel).SymbolTable[Id].Level; + + repeat + if L = 0 then + begin + result := 0; + Exit; + end; + + R := TKernel(kernel).SymbolTable[L]; + + if R.Kind = kindNAMESPACE then + begin + result := R.Id; + Exit; + end; + + L := R.Level; + + until false; +end; + +function TPaxCompiler.LookupNamespace(LevelId: Integer; const NamespaceName: String; + CaseSensitive: Boolean): Integer; +begin + result := TKernel(kernel).SymbolTable.LookupNamespace(NamespaceName, LevelId, not CaseSensitive); +end; + +function TPaxCompiler.LookupNamespace(const NamespaceName: String): Integer; +begin + result := LookupNamespace(0, NamespaceName, true); +end; + +function TPaxCompiler.GetNativeSEH: Boolean; +begin + result := TKernel(kernel).ModeSEH; +end; + +procedure TPaxCompiler.SetNativeSEH(const value: Boolean); +begin + TKernel(kernel).ModeSEH := value; +end; + +procedure TPaxCompiler.AssignImportTable(ImportTable: Pointer); +begin + if ImportTable = nil then + ImportTable := GlobalSymbolTable; + TKernel(kernel).AssignImportTable(ImportTable); +end; + +function TPaxCompiler.GetOnSavePCUFinished: TPaxCompilerSavePCUFinishedEvent; // jason +begin + result := TPaxCompilerSavePCUFinishedEvent(kernel.OnSavePCUFinished); +end; + +procedure TPaxCompiler.SetOnSavePCUFinished(value: TPaxCompilerSavePCUFinishedEvent); // jason +begin + kernel.OnSavePCUFinished := TSavePCUFinishedEvent(value); +end; + +function TPaxCompiler.GetOnLoadPCUFinished: TPaxCompilerLoadPCUFinishedEvent; // jason +begin + result := TPaxCompilerLoadPCUFinishedEvent(kernel.OnLoadPCUFinished); +end; + +procedure TPaxCompiler.SetOnLoadPCUFinished( value: TPaxCompilerLoadPCUFinishedEvent); // jason +begin + kernel.OnLoadPCUFinished := TLoadPCUFinishedEvent(value); +end; + +function TPaxCompiler.GetCompletionPrefix: String; +begin + result := TKernel(kernel).CompletionPrefix; +end; + +function TPaxCompiler.GetModuleName(Id: Integer): String; +var + I: Integer; +begin + result := ''; + if TKernel(kernel).SymbolTable[Id].Host then + begin + I := TKernel(kernel).SymbolTable[Id].Level; + if I > 0 then + begin + if TKernel(kernel).SymbolTable[I].Kind = KindNAMESPACE then + begin + result := TKernel(kernel).SymbolTable[I].Name; + Exit; + end + else + result := GetModuleName(I); + end; + end; + I := TKernel(kernel).Modules.IndexOfModuleById(Id); + if I = -1 then + Exit; + result := TKernel(kernel).Modules[I].Name; +end; + +function TPaxCompiler.GetPosition(Id: Integer): Integer; +begin + result := TKernel(kernel).SymbolTable[Id].Position; +end; + +function TPaxCompiler.GetKind(Id: Integer): Integer; +begin + result := TKernel(kernel).SymbolTable[Id].Kind; +end; + +function TPaxCompiler.GetUnicode: Boolean; +begin + result := TKernel(kernel).IsUNIC; +end; + +procedure TPaxCompiler.SetUnicode(value: Boolean); +begin + TKernel(kernel).IsUNIC := value; +end; + +{$ifdef DRTTI} +procedure TPaxCompiler.RegisterImportUnit(Level: Integer; const AUnitName: String); +begin + TKernel(kernel).RegisterImportUnit(Level, AUnitName); +end; +{$endif} + +function TPaxCompiler.GetEvalList: TStringList; +begin + result := TKernel(kernel).EvalList; +end; + +function TPaxCompiler.InScript(const IdentName: String): Boolean; +begin + result := GetEvalList.IndexOf(IdentName) >= 0; +end; + +procedure TPaxCompiler.ExtendAlphabet(B1, B2: Word); +begin + kernel.ExAlphaList.Add(B1, B2); +end; + +/////////////// TPaxCompilerLanguage /////////////////////////////////////////// + +destructor TPaxCompilerLanguage.Destroy; +begin + FreeAndNil(P); + inherited; +end; + +function TPaxCompilerLanguage.GetExplicitOff: Boolean; +begin + result := P.EXPLICIT_OFF; +end; + +procedure TPaxCompilerLanguage.SetExplicitOff(value: Boolean); +begin + P.EXPLICIT_OFF := value; +end; + +function TPaxCompilerLanguage.GetCompleteBooleanEval: Boolean; +begin + result := P.CompleteBooleanEval; +end; + +procedure TPaxCompilerLanguage.SetCompleteBooleanEval(value: Boolean); +begin + P.CompleteBooleanEval := value; +end; + +function TPaxCompilerLanguage.GetPrintKeyword: String; +begin + result := P.PrintKeyword; +end; + +function TPaxCompilerLanguage.GetPrintlnKeyword: String; +begin + result := P.PrintlnKeyword; +end; + +procedure TPaxCompilerLanguage.SetPrintKeyword(const value: String); +begin + P.PrintKeyword := value; + if P.ParsesModule then + P.Gen(OP_PRINT_KWD, P.NewConst(typeSTRING, value), 0, 0); +end; + +procedure TPaxCompilerLanguage.SetPrintlnKeyword(const value: String); +begin + P.PrintlnKeyword := value; + if P.ParsesModule then + P.Gen(OP_PRINTLN_KWD, P.NewConst(typeSTRING, value), 0, 0); +end; + +function TPaxCompilerLanguage.GetUnitLookup: Boolean; +begin + result := P.UnitLookup; +end; + +procedure TPaxCompilerLanguage.SetUnitLookup(value: Boolean); +begin + P.UnitLookup := value; +end; + +function TPaxCompilerLanguage.GetInitFuncResult: Boolean; +begin + result := P.InitFuncResult; +end; + +procedure TPaxCompilerLanguage.SetInitFuncResult(value: Boolean); +begin + P.InitFuncResult := value; +end; + +/////////////// TPaxPascalLanguage ///////////////////////////////////////////// + +constructor TPaxPascalLanguage.Create(AOwner: TComponent); +begin + inherited; + P := TPascalParser.Create; + P.Owner := Self; + SetCallConv(_ccREGISTER); +end; + +procedure TPaxPascalLanguage.SetCallConv(CallConv: Integer); +begin + P.CallConv := CallConv; +end; + +function TPaxPascalLanguage.GetParser: TBaseParser; +begin + result := P; +end; + +function TPaxPascalLanguage.GetLanguageName: String; +begin + result := P.LanguageName; +end; + +function TPaxPascalLanguage.GetOnParseUnitName: TPaxParserIdentEvent; +begin + result := TPaxParserIdentEvent((P as TPascalParser).OnParseUnitName); +end; + +procedure TPaxPascalLanguage.SetOnParseUnitName(value: TPaxParserIdentEvent); +begin + (P as TPascalParser).OnParseUnitName := TParserIdentEvent(value); +end; + +function TPaxPascalLanguage.GetOnParseImplementationSection: TPaxParserNotifyEvent; +begin + result := TPaxParserNotifyEvent((P as TPascalParser).OnParseImplementationSection); +end; + +procedure TPaxPascalLanguage.SetOnParseImplementationSection(value: TPaxParserNotifyEvent); +begin + (P as TPascalParser).OnParseImplementationSection := TParserNotifyEvent(value); +end; + +function TPaxPascalLanguage.GetOnParseBeginUsedUnitList: TPaxParserNotifyEvent; +begin + result := TPaxParserNotifyEvent((P as TPascalParser).OnParseBeginUsedUnitList); +end; + +procedure TPaxPascalLanguage.SetOnParseBeginUsedUnitList(value: TPaxParserNotifyEvent); +begin + (P as TPascalParser).OnParseBeginUsedUnitList := TParserNotifyEvent(value); +end; + +function TPaxPascalLanguage.GetOnParseEndUsedUnitList: TPaxParserNotifyEvent; +begin + result := TPaxParserNotifyEvent((P as TPascalParser).OnParseEndUsedUnitList); +end; + +procedure TPaxPascalLanguage.SetOnParseEndUsedUnitList(value: TPaxParserNotifyEvent); +begin + (P as TPascalParser).OnParseEndUsedUnitList := TParserNotifyEvent(value); +end; + +function TPaxPascalLanguage.GetOnParseUsedUnitName: TPaxParserIdentEvent; +begin + result := TPaxParserIdentEvent((P as TPascalParser).OnParseUsedUnitName); +end; + +procedure TPaxPascalLanguage.SetOnParseUsedUnitName(value: TPaxParserIdentEvent); +begin + (P as TPascalParser).OnParseUsedUnitName := TParserIdentEvent(value); +end; + +function TPaxPascalLanguage.GetOnParseBeginClassTypeDeclaration: TPaxParserIdentEventEx; +begin + result := TPaxParserIdentEventEx((P as TPascalParser).OnParseBeginClassTypeDeclaration); +end; + +procedure TPaxPascalLanguage.SetOnParseBeginClassTypeDeclaration(value: TPaxParserIdentEventEx); +begin + (P as TPascalParser).OnParseBeginClassTypeDeclaration := TParserIdentEventEx(value); +end; + +function TPaxPascalLanguage.GetOnParseEndClassTypeDeclaration: TPaxParserIdentEvent; +begin + result := TPaxParserIdentEvent((P as TPascalParser).OnParseEndClassTypeDeclaration); +end; + +procedure TPaxPascalLanguage.SetOnParseEndClassTypeDeclaration(value: TPaxParserIdentEvent); +begin + (P as TPascalParser).OnParseEndClassTypeDeclaration := TParserIdentEvent(value); +end; + +function TPaxPascalLanguage.GetOnParseTypeDeclaration: TPaxParserIdentEvent; +begin + result := TPaxParserIdentEvent((P as TPascalParser).OnParseTypeDeclaration); +end; + +procedure TPaxPascalLanguage.SetOnParseTypeDeclaration(value: TPaxParserIdentEvent); +begin + (P as TPascalParser).OnParseTypeDeclaration := TParserIdentEvent(value); +end; + +function TPaxPascalLanguage.GetOnParseForwardTypeDeclaration: TPaxParserIdentEvent; +begin + result := TPaxParserIdentEvent((P as TPascalParser).OnParseForwardTypeDeclaration); +end; + +procedure TPaxPascalLanguage.SetOnParseForwardTypeDeclaration(value: TPaxParserIdentEvent); +begin + (P as TPascalParser).OnParseForwardTypeDeclaration := TParserIdentEvent(value); +end; + +function TPaxPascalLanguage.GetOnParseAncestorTypeDeclaration: TPaxParserIdentEvent; +begin + result := TPaxParserIdentEvent((P as TPascalParser).OnParseAncestorTypeDeclaration); +end; + +procedure TPaxPascalLanguage.SetOnParseAncestorTypeDeclaration(value: TPaxParserIdentEvent); +begin + (P as TPascalParser).OnParseAncestorTypeDeclaration := TParserIdentEvent(value); +end; + +function TPaxPascalLanguage.GetOnParseUsedInterface: TPaxParserIdentEvent; +begin + result := TPaxParserIdentEvent((P as TPascalParser).OnParseUsedInterface); +end; + +procedure TPaxPascalLanguage.SetOnParseUsedInterface(value: TPaxParserIdentEvent); +begin + (P as TPascalParser).OnParseUsedInterface := TParserIdentEvent(value); +end; + +function TPaxPascalLanguage.GetOnParseClassReferenceTypeDeclaration: TPaxParserTypedIdentEvent; +begin + result := TPaxParserTypedIdentEvent((P as TPascalParser).OnParseClassReferenceTypeDeclaration); +end; + +procedure TPaxPascalLanguage.SetOnParseClassReferenceTypeDeclaration(value: TPaxParserTypedIdentEvent); +begin + (P as TPascalParser).OnParseClassReferenceTypeDeclaration := TParserTypedIdentEvent(value); +end; + +function TPaxPascalLanguage.GetOnParseAliasTypeDeclaration: TPaxParserTypedIdentEvent; +begin + result := TPaxParserTypedIdentEvent((P as TPascalParser).OnParseAliasTypeDeclaration); +end; + +procedure TPaxPascalLanguage.SetOnParseAliasTypeDeclaration(value: TPaxParserTypedIdentEvent); +begin + (P as TPascalParser).OnParseAliasTypeDeclaration := TParserTypedIdentEvent(value); +end; + +function TPaxPascalLanguage.GetOnParseProceduralTypeDeclaration: TPaxParserIdentEventEx; +begin + result := TPaxParserIdentEventEx((P as TPascalParser).OnParseProceduralTypeDeclaration); +end; + +procedure TPaxPascalLanguage.SetOnParseProceduralTypeDeclaration(value: TPaxParserIdentEventEx); +begin + (P as TPascalParser).OnParseProceduralTypeDeclaration := TParserIdentEventEx(value); +end; + +function TPaxPascalLanguage.GetOnParseEventTypeDeclaration: TPaxParserIdentEventEx; +begin + result := TPaxParserIdentEventEx((P as TPascalParser).OnParseEventTypeDeclaration); +end; + +procedure TPaxPascalLanguage.SetOnParseEventTypeDeclaration(value: TPaxParserIdentEventEx); +begin + (P as TPascalParser).OnParseEventTypeDeclaration := TParserIdentEventEx(value); +end; + +function TPaxPascalLanguage.GetOnParseMethodReferenceTypeDeclaration: TPaxParserIdentEventEx; +begin + result := TPaxParserIdentEventEx((P as TPascalParser).OnParseMethodReferenceTypeDeclaration); +end; + +procedure TPaxPascalLanguage.SetOnParseMethodReferenceTypeDeclaration(value: TPaxParserIdentEventEx); +begin + (P as TPascalParser).OnParseMethodReferenceTypeDeclaration := TParserIdentEventEx(value); +end; + + +function TPaxPascalLanguage.GetOnParseSetTypeDeclaration: TPaxParserTypedIdentEvent; +begin + result := TPaxParserTypedIdentEvent((P as TPascalParser).OnParseSetTypeDeclaration); +end; + +procedure TPaxPascalLanguage.SetOnParseSetTypeDeclaration(value: TPaxParserTypedIdentEvent); +begin + (P as TPascalParser).OnParseSetTypeDeclaration := TParserTypedIdentEvent(value); +end; + +function TPaxPascalLanguage.GetOnParsePointerTypeDeclaration: TPaxParserTypedIdentEvent; +begin + result := TPaxParserTypedIdentEvent((P as TPascalParser).OnParsePointerTypeDeclaration); +end; + +procedure TPaxPascalLanguage.SetOnParsePointerTypeDeclaration(value: TPaxParserTypedIdentEvent); +begin + (P as TPascalParser).OnParsePointerTypeDeclaration := TParserTypedIdentEvent(value); +end; + +function TPaxPascalLanguage.GetOnParseArrayTypeDeclaration: TPaxParserArrayTypeEvent; +begin + result := TPaxParserArrayTypeEvent((P as TPascalParser).OnParseArrayTypeDeclaration); +end; + +procedure TPaxPascalLanguage.SetOnParseArrayTypeDeclaration(value: TPaxParserArrayTypeEvent); +begin + (P as TPascalParser).OnParseArrayTypeDeclaration := TParserArrayTypeEvent(value); +end; + +function TPaxPascalLanguage.GetOnParseDynArrayTypeDeclaration: TPaxParserTypedIdentEvent; +begin + result := TPaxParserTypedIdentEvent((P as TPascalParser).OnParseDynArrayTypeDeclaration); +end; + +procedure TPaxPascalLanguage.SetOnParseDynArrayTypeDeclaration(value: TPaxParserTypedIdentEvent); +begin + (P as TPascalParser).OnParseDynArrayTypeDeclaration := TParserTypedIdentEvent(value); +end; + +function TPaxPascalLanguage.GetOnParseShortStringTypeDeclaration: TPaxParserNamedValueEvent; +begin + result := TPaxParserNamedValueEvent((P as TPascalParser).OnParseShortStringTypeDeclaration); +end; + +procedure TPaxPascalLanguage.SetOnParseShortStringTypeDeclaration(value: TPaxParserNamedValueEvent); +begin + (P as TPascalParser).OnParseShortStringTypeDeclaration := TParserNamedValueEvent(value); +end; + +function TPaxPascalLanguage.GetOnParseSubrangeTypeDeclaration: TPaxParserDeclarationEvent; +begin + result := TPaxParserDeclarationEvent((P as TPascalParser).OnParseSubrangeTypeDeclaration); +end; + +procedure TPaxPascalLanguage.SetOnParseSubrangeTypeDeclaration(value: TPaxParserDeclarationEvent); +begin + (P as TPascalParser).OnParseSubrangeTypeDeclaration := TParserDeclarationEvent(value); +end; + +function TPaxPascalLanguage.GetOnParseBeginRecordTypeDeclaration: TPaxParserIdentEventEx; +begin + result := TPaxParserIdentEventEx((P as TPascalParser).OnParseBeginRecordTypeDeclaration); +end; + +procedure TPaxPascalLanguage.SetOnParseBeginRecordTypeDeclaration(value: TPaxParserIdentEventEx); +begin + (P as TPascalParser).OnParseBeginRecordTypeDeclaration := TParserIdentEventEx(value); +end; + +function TPaxPascalLanguage.GetOnParseEndRecordTypeDeclaration: TPaxParserIdentEvent; +begin + result := TPaxParserIdentEvent((P as TPascalParser).OnParseEndRecordTypeDeclaration); +end; + +procedure TPaxPascalLanguage.SetOnParseEndRecordTypeDeclaration(value: TPaxParserIdentEvent); +begin + (P as TPascalParser).OnParseEndRecordTypeDeclaration := TParserIdentEvent(value); +end; + +function TPaxPascalLanguage.GetOnParseBeginInterfaceTypeDeclaration: TPaxParserIdentEvent; +begin + result := TPaxParserIdentEvent((P as TPascalParser).OnParseBeginInterfaceTypeDeclaration); +end; + +procedure TPaxPascalLanguage.SetOnParseBeginInterfaceTypeDeclaration(value: TPaxParserIdentEvent); +begin + (P as TPascalParser).OnParseBeginInterfaceTypeDeclaration := TParserIdentEvent(value); +end; + +function TPaxPascalLanguage.GetOnParseEndInterfaceTypeDeclaration: TPaxParserIdentEvent; +begin + result := TPaxParserIdentEvent((P as TPascalParser).OnParseEndInterfaceTypeDeclaration); +end; + +procedure TPaxPascalLanguage.SetOnParseEndInterfaceTypeDeclaration(value: TPaxParserIdentEvent); +begin + (P as TPascalParser).OnParseEndInterfaceTypeDeclaration := TParserIdentEvent(value); +end; + +function TPaxPascalLanguage.GetOnParseBeginEnumTypeDeclaration: TPaxParserIdentEvent; +begin + result := TPaxParserIdentEvent((P as TPascalParser).OnParseBeginEnumTypeDeclaration); +end; + +procedure TPaxPascalLanguage.SetOnParseBeginEnumTypeDeclaration(value: TPaxParserIdentEvent); +begin + (P as TPascalParser).OnParseBeginEnumTypeDeclaration := TParserIdentEvent(value); +end; + +function TPaxPascalLanguage.GetOnParseEndEnumTypeDeclaration: TPaxParserIdentEvent; +begin + result := TPaxParserIdentEvent((P as TPascalParser).OnParseEndEnumTypeDeclaration); +end; + +procedure TPaxPascalLanguage.SetOnParseEndEnumTypeDeclaration(value: TPaxParserIdentEvent); +begin + (P as TPascalParser).OnParseEndEnumTypeDeclaration := TParserIdentEvent(value); +end; + +function TPaxPascalLanguage.GetOnParseEnumName: TPaxParserNamedValueEvent; +begin + result := TPaxParserNamedValueEvent((P as TPascalParser).OnParseEnumName); +end; + +procedure TPaxPascalLanguage.SetOnParseEnumName(value: TPaxParserNamedValueEvent); +begin + (P as TPascalParser).OnParseEnumName := TParserNamedValueEvent(value); +end; + +function TPaxPascalLanguage.GetOnParseFieldDeclaration: TPaxParserTypedIdentEvent; +begin + result := TPaxParserTypedIdentEvent((P as TPascalParser).OnParseFieldDeclaration); +end; + +procedure TPaxPascalLanguage.SetOnParseFieldDeclaration(value: TPaxParserTypedIdentEvent); +begin + (P as TPascalParser).OnParseFieldDeclaration := TParserTypedIdentEvent(value); +end; + +function TPaxPascalLanguage.GetOnParseVariantRecordFieldDeclaration: TPaxParserVariantRecordFieldEvent; +begin + result := TPaxParserVariantRecordFieldEvent((P as TPascalParser).OnParseVariantRecordFieldDeclaration); +end; + +procedure TPaxPascalLanguage.SetOnParseVariantRecordFieldDeclaration(value: TPaxParserVariantRecordFieldEvent); +begin + (P as TPascalParser).OnParseVariantRecordFieldDeclaration := TParserVariantRecordFieldEvent(value); +end; + +function TPaxPascalLanguage.GetOnParsePropertyDeclaration: TPaxParserTypedIdentEvent; +begin + result := TPaxParserTypedIdentEvent((P as TPascalParser).OnParsePropertyDeclaration); +end; + +procedure TPaxPascalLanguage.SetOnParsePropertyDeclaration(value: TPaxParserTypedIdentEvent); +begin + (P as TPascalParser).OnParsePropertyDeclaration := TParserTypedIdentEvent(value); +end; + +function TPaxPascalLanguage.GetOnParseConstantDeclaration: TPaxParserNamedValueEvent; +begin + result := TPaxParserNamedValueEvent((P as TPascalParser).OnParseConstantDeclaration); +end; + +procedure TPaxPascalLanguage.SetOnParseConstantDeclaration(value: TPaxParserNamedValueEvent); +begin + (P as TPascalParser).OnParseConstantDeclaration := TParserNamedValueEvent(value); +end; + +function TPaxPascalLanguage.GetOnParseResourceStringDeclaration: TPaxParserNamedValueEvent; +begin + result := TPaxParserNamedValueEvent((P as TPascalParser).OnParseResourceStringDeclaration); +end; + +procedure TPaxPascalLanguage.SetOnParseResourceStringDeclaration(value: TPaxParserNamedValueEvent); +begin + (P as TPascalParser).OnParseResourceStringDeclaration := TParserNamedValueEvent(value); +end; + +function TPaxPascalLanguage.GetOnParseTypedConstantDeclaration: TPaxParserNamedTypedValueEvent; +begin + result := TPaxParserNamedTypedValueEvent((P as TPascalParser).OnParseTypedConstantDeclaration); +end; + +procedure TPaxPascalLanguage.SetOnParseTypedConstantDeclaration(value: TPaxParserNamedTypedValueEvent); +begin + (P as TPascalParser).OnParseTypedConstantDeclaration := TParserNamedTypedValueEvent(value); +end; + +function TPaxPascalLanguage.GetOnParseVariableDeclaration: TPaxParserTypedIdentEvent; +begin + result := TPaxParserTypedIdentEvent((P as TPascalParser).OnParseVariableDeclaration); +end; + +procedure TPaxPascalLanguage.SetOnParseVariableDeclaration(value: TPaxParserTypedIdentEvent); +begin + (P as TPascalParser).OnParseVariableDeclaration := TParserTypedIdentEvent(value); +end; + +function TPaxPascalLanguage.GetOnParseBeginSubDeclaration: TPaxParserIdentEvent; +begin + result := TPaxParserIdentEvent((P as TPascalParser).OnParseBeginSubDeclaration); +end; + +procedure TPaxPascalLanguage.SetOnParseBeginSubDeclaration(value: TPaxParserIdentEvent); +begin + (P as TPascalParser).OnParseBeginSubDeclaration := TParserIdentEvent(value); +end; + +function TPaxPascalLanguage.GetOnParseEndSubDeclaration: TPaxParserDeclarationEvent; +begin + result := TPaxParserDeclarationEvent((P as TPascalParser).OnParseEndSubDeclaration); +end; + +procedure TPaxPascalLanguage.SetOnParseEndSubDeclaration(value: TPaxParserDeclarationEvent); +begin + (P as TPascalParser).OnParseEndSubDeclaration := TParserDeclarationEvent(value); +end; + +function TPaxPascalLanguage.GetOnParseBeginFormalParameterList: TPaxParserNotifyEvent; +begin + result := TPaxParserNotifyEvent((P as TPascalParser).OnParseBeginFormalParameterList); +end; + +procedure TPaxPascalLanguage.SetOnParseBeginFormalParameterList(value: TPaxParserNotifyEvent); +begin + (P as TPascalParser).OnParseBeginFormalParameterList := TParserNotifyEvent(value); +end; + +function TPaxPascalLanguage.GetOnParseEndFormalParameterList: TPaxParserNotifyEvent; +begin + result := TPaxParserNotifyEvent((P as TPascalParser).OnParseEndFormalParameterList); +end; + +procedure TPaxPascalLanguage.SetOnParseEndFormalParameterList(value: TPaxParserNotifyEvent); +begin + (P as TPascalParser).OnParseEndFormalParameterList := TParserNotifyEvent(value); +end; + +function TPaxPascalLanguage.GetOnParseFormalParameterDeclaration: TPaxParserNamedTypedValueEvent; +begin + result := TPaxParserNamedTypedValueEvent((P as TPascalParser).OnParseFormalParameterDeclaration); +end; + +procedure TPaxPascalLanguage.SetOnParseFormalParameterDeclaration(value: TPaxParserNamedTypedValueEvent); +begin + (P as TPascalParser).OnParseFormalParameterDeclaration := TParserNamedTypedValueEvent(value); +end; + +function TPaxPascalLanguage.GetOnParseResultType: TPaxParserIdentEvent; +begin + result := TPaxParserIdentEvent((P as TPascalParser).OnParseResultType); +end; + +procedure TPaxPascalLanguage.SetOnParseResultType(value: TPaxParserIdentEvent); +begin + (P as TPascalParser).OnParseResultType := TParserIdentEvent(value); +end; + +function TPaxPascalLanguage.GetOnParseBeginClassHelperTypeDeclaration: TPaxParserTypedIdentEvent; +begin + result := TPaxParserTypedIdentEvent((P as TPascalParser).OnParseBeginClassHelperTypeDeclaration); +end; + +procedure TPaxPascalLanguage.SetOnParseBeginClassHelperTypeDeclaration(value: TPaxParserTypedIdentEvent); +begin + (P as TPascalParser).OnParseBeginClassHelperTypeDeclaration := TParserTypedIdentEvent(value); +end; + +function TPaxPascalLanguage.GetOnParseEndClassHelperTypeDeclaration: TPaxParserIdentEvent; +begin + result := TPaxParserIdentEvent((P as TPascalParser).OnParseEndClassHelperTypeDeclaration); +end; + +procedure TPaxPascalLanguage.SetOnParseEndClassHelperTypeDeclaration(value: TPaxParserIdentEvent); +begin + (P as TPascalParser).OnParseEndClassHelperTypeDeclaration := TParserIdentEvent(value); +end; + +function TPaxPascalLanguage.GetOnParseBeginRecordHelperTypeDeclaration: TPaxParserTypedIdentEvent; +begin + result := TPaxParserTypedIdentEvent((P as TPascalParser).OnParseBeginRecordHelperTypeDeclaration); +end; + +procedure TPaxPascalLanguage.SetOnParseBeginRecordHelperTypeDeclaration(value: TPaxParserTypedIdentEvent); +begin + (P as TPascalParser).OnParseBeginRecordHelperTypeDeclaration := TParserTypedIdentEvent(value); +end; + +function TPaxPascalLanguage.GetOnParseEndRecordHelperTypeDeclaration: TPaxParserIdentEvent; +begin + result := TPaxParserIdentEvent((P as TPascalParser).OnParseEndRecordHelperTypeDeclaration); +end; + +procedure TPaxPascalLanguage.SetOnParseEndRecordHelperTypeDeclaration(value: TPaxParserIdentEvent); +begin + (P as TPascalParser).OnParseEndRecordHelperTypeDeclaration := TParserIdentEvent(value); +end; + +function TPaxPascalLanguage.GetOnParseSubDirective: TPaxParserIdentEvent; +begin + result := TPaxParserIdentEvent((P as TPascalParser).OnParseSubDirective); +end; + +procedure TPaxPascalLanguage.SetOnParseSubDirective(value: TPaxParserIdentEvent); +begin + (P as TPascalParser).OnParseSubDirective := TParserIdentEvent(value); +end; + +procedure SetDump; +begin + IsDump := true; +end; + +end. + + + + diff --git a/Sources/PaxCompilerDLL.pas b/Sources/PaxCompilerDLL.pas new file mode 100644 index 0000000..da70656 --- /dev/null +++ b/Sources/PaxCompilerDLL.pas @@ -0,0 +1,66 @@ +unit PaxCompilerDLL; + +interface + +const +{$IFDEF WIN32} + DLL = 'PaxCompilerLib.dll'; +{$ENDIF} +{$IFDEF LINUX} + DLL = 'libPaxCompiler.so'; +{$ENDIF} +{$IFDEF DARWIN} + DLL = 'libPaxCompiler.dylib'; +{$ENDIF} + +/////////////////////// PaxCompiler //////////////////////////////////////////// +function PaxCompiler_Create: Integer; {$IFDEF WIN32}stdcall;{$ELSE}cdecl;{$ENDIF} external DLL; +procedure PaxCompiler_Destroy(HCompiler: Integer); {$IFDEF WIN32}stdcall;{$ELSE}cdecl;{$ENDIF} external DLL; +procedure PaxCompiler_Reset(HCompiler: Integer); {$IFDEF WIN32}stdcall;{$ELSE}cdecl;{$ENDIF} external DLL; +procedure PaxCompiler_AddModule(HCompiler: Integer; Name, LanguageName: PChar); {$IFDEF WIN32}stdcall;{$ELSE}cdecl;{$ENDIF} external DLL; +procedure PaxCompiler_AddCode(HCompiler: Integer; ModuleName, Text: PChar); {$IFDEF WIN32}stdcall;{$ELSE}cdecl;{$ENDIF} external DLL; +procedure PaxCompiler_AddCodeFromFile(HCompiler: Integer; ModuleName, FileName: PChar); {$IFDEF WIN32}stdcall;{$ELSE}cdecl;{$ENDIF} external DLL; +procedure PaxCompiler_RegisterLanguage(HCompiler, HLanguage: Integer); {$IFDEF WIN32}stdcall;{$ELSE}cdecl;{$ENDIF} external DLL; +function PaxCompiler_RegisterNamespace(HCompiler, LevelId: Integer; NamespaceName: PChar): Integer; {$IFDEF WIN32}stdcall;{$ELSE}cdecl;{$ENDIF} external DLL; +function PaxCompiler_RegisterRecordType(HCompiler, LevelId: Integer; TypeName: PChar): Integer; {$IFDEF WIN32}stdcall;{$ELSE}cdecl;{$ENDIF} external DLL; +function PaxCompiler_RegisterRecordTypeField(HCompiler, RecordTypeId: Integer; FieldName: PChar; FieldTypeID: Integer): Integer; {$IFDEF WIN32}stdcall;{$ELSE}cdecl;{$ENDIF} external DLL; +function PaxCompiler_RegisterSubrangeType(HCompiler, LevelId: Integer; TypeName: PChar; TypeBaseId: Integer; B1, B2: Integer): Integer; {$IFDEF WIN32}stdcall;{$ELSE}cdecl;{$ENDIF} external DLL; +function PaxCompiler_RegisterArrayType(HCompiler, LevelId: Integer; TypeName: PChar; RangeTypeId, ElemTypeId: Integer): Integer; {$IFDEF WIN32}stdcall;{$ELSE}cdecl;{$ENDIF} external DLL; +function PaxCompiler_RegisterPointerType(HCompiler, LevelId: Integer; TypeName: PChar; OriginTypeId: Integer): Integer; {$IFDEF WIN32}stdcall;{$ELSE}cdecl;{$ENDIF} external DLL; +function PaxCompiler_RegisterSetType(HCompiler, LevelId: Integer; TypeName: PChar; OriginTypeId: Integer): Integer; {$IFDEF WIN32}stdcall;{$ELSE}cdecl;{$ENDIF} external DLL; +function PaxCompiler_RegisterProceduralType(HCompiler, LevelId: Integer; TypeName: PChar; SubId: Integer): Integer; {$IFDEF WIN32}stdcall;{$ELSE}cdecl;{$ENDIF} external DLL; +function PaxCompiler_RegisterVariable(HCompiler, LevelId: Integer; Name: PChar; TypeId: Integer): Integer; {$IFDEF WIN32}stdcall;{$ELSE}cdecl;{$ENDIF} external DLL; +function PaxCompiler_RegisterRoutine(HCompiler, LevelId: Integer; Name: PChar; ResultTypeID: Integer): Integer; {$IFDEF WIN32}stdcall;{$ELSE}cdecl;{$ENDIF} external DLL; +function PaxCompiler_RegisterRoutineEx(HCompiler, LevelId: Integer; Name: PChar; ResultTypeID: Integer; CallConvention: Integer): Integer; {$IFDEF WIN32}stdcall;{$ELSE}cdecl;{$ENDIF} external DLL; +function PaxCompiler_RegisterParameter(HCompiler, HSub: Integer; ParamTypeID: Integer; ByRef: Boolean): Integer; {$IFDEF WIN32}stdcall;{$ELSE}cdecl;{$ENDIF} external DLL; +function PaxCompiler_RegisterClassType(HCompiler, LevelId: Integer; C: TClass): Integer; {$IFDEF WIN32}stdcall;{$ELSE}cdecl;{$ENDIF} external DLL; +function PaxCompiler_RegisterHeader(HCompiler, LevelId: Integer; const Header: PChar; Address: Pointer{$IFDEF WIN32} = nil{$ENDIF}): Integer; {$IFDEF WIN32}stdcall;{$ELSE}cdecl;{$ENDIF} external DLL; +function PaxCompiler_GetHandle(HCompiler, LevelId: Integer; Name: PChar; Upcase: Boolean): Integer; {$IFDEF WIN32}stdcall;{$ELSE}cdecl;{$ENDIF} external DLL; +function PaxCompiler_Compile(HCompiler, HProgram: Integer): boolean; {$IFDEF WIN32}stdcall;{$ELSE}cdecl;{$ENDIF} external DLL; +function PaxCompiler_GetErrorCount(HCompiler: Integer): Integer; {$IFDEF WIN32}stdcall;{$ELSE}cdecl;{$ENDIF} external DLL; +function PaxCompiler_GetErrorMessage(HCompiler, I: Integer): PChar; {$IFDEF WIN32}stdcall;{$ELSE}cdecl;{$ENDIF} external DLL; +function PaxCompiler_GetErrorModuleName(HCompiler, I: Integer): PChar; {$IFDEF WIN32}stdcall;{$ELSE}cdecl;{$ENDIF} external DLL; +function PaxCompiler_GetErrorLine(HCompiler, I: Integer): PChar; {$IFDEF WIN32}stdcall;{$ELSE}cdecl;{$ENDIF} external DLL; +function PaxCompiler_GetErrorLineNumber(HCompiler, I: Integer): Integer; {$IFDEF WIN32}stdcall;{$ELSE}cdecl;{$ENDIF} external DLL; + +/////////////////////// PaxProgram ///////////////////////////////////////////// +function PaxProgram_Create: Integer; {$IFDEF WIN32}stdcall;{$ELSE}cdecl;{$ENDIF} external DLL; +procedure PaxProgram_Destroy(HProgram: Integer); {$IFDEF WIN32}stdcall;{$ELSE}cdecl;{$ENDIF} external DLL; +procedure PaxProgram_Run(HProgram: Integer); {$IFDEF WIN32}stdcall;{$ELSE}cdecl;{$ENDIF} external DLL; +procedure PaxProgram_SaveToFile(HProgram: Integer; Path: PChar); {$IFDEF WIN32}stdcall;{$ELSE}cdecl;{$ENDIF} external DLL; +procedure PaxProgram_LoadFromFile(HProgram: Integer; Path: PChar); {$IFDEF WIN32}stdcall;{$ELSE}cdecl;{$ENDIF} external DLL; +function PaxProgram_GetAddress(HProgram: Integer; Handle: Integer): Pointer; {$IFDEF WIN32}stdcall;{$ELSE}cdecl;{$ENDIF} external DLL; +procedure PaxProgram_SetAddress(HProgram, Handle: Integer; P: Pointer); {$IFDEF WIN32}stdcall;{$ELSE}cdecl;{$ENDIF} external DLL; +procedure PaxProgram_BeginCall(HProgram: Integer); {$IFDEF WIN32}stdcall;{$ELSE}cdecl;{$ENDIF} external DLL; +procedure PaxProgram_EndCall(HProgram: Integer); {$IFDEF WIN32}stdcall;{$ELSE}cdecl;{$ENDIF} external DLL; +function PaxProgram_GetDataPtr(HProgram: Integer): Pointer; {$IFDEF WIN32}stdcall;{$ELSE}cdecl;{$ENDIF} external DLL; +function PaxProgram_GetCodePtr(HProgram: Integer): Pointer; {$IFDEF WIN32}stdcall;{$ELSE}cdecl;{$ENDIF} external DLL; + +/////////////////////// PaxPascalLanguage ////////////////////////////////////// +function PaxPascalLanguage_Create: Integer; {$IFDEF WIN32}stdcall;{$ELSE}cdecl;{$ENDIF} external DLL; +procedure PaxPascalLanguage_Destroy(HPaxPascalLanguage: Integer); {$IFDEF WIN32}stdcall;{$ELSE}cdecl;{$ENDIF} external DLL; +procedure PaxPascalLanguage_SetCallConv(HPaxPascalLanguage: Integer; cc: Integer); {$IFDEF WIN32}stdcall;{$ELSE}cdecl;{$ENDIF} external DLL; + +implementation + +end. diff --git a/Sources/PaxCompilerDebugger.pas b/Sources/PaxCompilerDebugger.pas new file mode 100644 index 0000000..c062a63 --- /dev/null +++ b/Sources/PaxCompilerDebugger.pas @@ -0,0 +1,372 @@ +//////////////////////////////////////////////////////////////////////////// +// PaxCompiler +// Site: http://www.paxcompiler.com +// Author: Alexander Baranovsky (paxscript@gmail.com) +// ======================================================================== +// Copyright (c) Alexander Baranovsky, 2006-2014. All rights reserved. +// Code Version: 4.2 +// ======================================================================== +// Unit: PaxCompilerDebugger.pas +// ======================================================================== +//////////////////////////////////////////////////////////////////////////// + +{$I PaxCompiler.def} +unit PaxCompilerDebugger; +interface +uses {$I uses.def} + TypInfo, + SysUtils, + Classes, + PAXCOMP_CONSTANTS, + PAXCOMP_SYS, + PAXCOMP_KERNEL, + PAXCOMP_MAP, + PAXCOMP_BASERUNNER, + PaxCompiler, + PaxRunner; +type + TPaxCompilerDebugger = class(TComponent) + private + compiler: TPaxCompiler; + prog: TPaxRunner; + + function GetRunMode: Integer; + procedure SetRunMode(Value: Integer); + + function GetValid: Boolean; + function GetCallStackCount: Integer; + function GetCallStackItem(I: Integer): Integer; + function GetCallStackLineNumber(I: Integer): Integer; + function GetCallStackModuleName(I: Integer): String; + function GetCallStackModuleIndex(I: Integer): Integer; + + function GetSourceLineNumber: Integer; + function GetModuleName: String; + + protected + public + + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + procedure RegisterCompiler(i_compiler: TPaxCompiler; + i_prog: TPaxRunner); + procedure Run; + function IsPaused: Boolean; + + function GetAddress(StackFrameNumber, Id: Integer): Pointer; overload; + function GetAddress(Id: Integer): Pointer; overload; + + function GetValueAsString(StackFrameNumber, Id: Integer): String; overload; + function GetValueAsString(Id: Integer): String; overload; + + function GetValueAsBriefString(StackFrameNumber, Id: Integer): String; overload; + function GetValueAsBriefString(Id: Integer): String; overload; + + function GetValue(StackFrameNumber, Id: Integer): Variant; overload; + function GetValue(Id: Integer): Variant; overload; + + procedure PutValue(StackFrameNumber, Id: Integer; const Value: Variant); overload; + procedure PutValue(Id: Integer; const Value: Variant); overload; + + function GetFieldValueAsString(StackFrameNumber: Integer; + Id, FieldNumber: Integer): String; + function GetFieldValueAsBriefString(StackFrameNumber: Integer; + Id, FieldNumber: Integer): String; + function GetPublishedPropValueAsString(StackFrameNumber: Integer; + Id, PropNumber: Integer): String; + + function GetArrayItemValueAsString(StackFrameNumber: Integer; + Id, Index: Integer): String; + function GetDynArrayLength(StackFrameNumber, Id: Integer): Integer; + function GetDynArrayItemValueAsString(StackFrameNumber: Integer; + Id, Index: Integer): String; + function AddBreakpoint(const ModuleName: String; + SourceLine: Integer): Boolean; + function AddTempBreakpoint(const ModuleName: String; + SourceLine: Integer): Boolean; + function RemoveBreakpoint(const ModuleName: String; + SourceLine: Integer): Boolean; + procedure RemoveAllBreakpoints; + function HasBreakpoint(const ModuleName: String; + SourceLine: Integer): Boolean; + procedure Reset; + + property CallStackCount: Integer read GetCallStackCount; + property CallStack[I: Integer]: Integer read GetCallStackItem; + property CallStackLineNumber[I: Integer]: Integer read + GetCallStackLineNumber; + property CallStackModuleName[I: Integer]: String read + GetCallStackModuleName; + property CallStackModuleIndex[I: Integer]: Integer read + GetCallStackModuleIndex; + property ModuleName: String read GetModuleName; + property RunMode: Integer read GetRunMode write SetRunMode; + property SourceLineNumber: Integer read GetSourceLineNumber; + property Valid: Boolean read GetValid; + end; + +implementation + +/////////////// TPaxCompilerDebugger /////////////////////////////////////////// + +procedure RaiseError(const Message: string; params: array of Const); +begin + raise Exception.Create(Format(Message, params)) +end; + +constructor TPaxCompilerDebugger.Create(AOwner: TComponent); +begin + inherited; + compiler := nil; + prog := nil; +end; + +destructor TPaxCompilerDebugger.Destroy; +begin + inherited; +end; + +procedure TPaxCompilerDebugger.RegisterCompiler(i_compiler: TPaxCompiler; + i_prog: TPaxRunner); +begin +// if not i_compiler.DebugMode then +// RaiseError(errDebugModeIsRequred, []); + + compiler := i_compiler; + prog := i_prog; +end; + +procedure TPaxCompilerDebugger.Run; +begin + prog.Run; +end; + +function TPaxCompilerDebugger.IsPaused: Boolean; +begin + result := prog.GetProgPtr.IsPaused; +end; + +function TPaxCompilerDebugger.GetAddress(StackFrameNumber, Id: Integer): Pointer; +begin + result := TKernel(compiler.GetKernelPtr).SymbolTable.GetFinalAddress( + prog.GetProgPtr, StackFrameNumber, Id); +end; + +function TPaxCompilerDebugger.GetAddress(Id: Integer): Pointer; +begin + result := TKernel(compiler.GetKernelPtr).SymbolTable.GetFinalAddress( + prog.GetProgPtr, 0, Id); +end; + +function TPaxCompilerDebugger.GetValue(StackFrameNumber, Id: Integer): Variant; +begin + result := TKernel(compiler.GetKernelPtr).SymbolTable.GetValue( + prog.GetProgPtr, StackFrameNumber, Id); +end; + +function TPaxCompilerDebugger.GetValue(Id: Integer): Variant; +begin + result := TKernel(compiler.GetKernelPtr).SymbolTable.GetValue( + prog.GetProgPtr, 0, Id); +end; + +function TPaxCompilerDebugger.GetValueAsString(StackFrameNumber, Id: Integer): String; +var + TypeMapRec: TTypeMapRec; +begin + TypeMapRec := TKernel(compiler.GetKernelPtr).GetTypeMapRec(Id); + + result := TKernel(compiler.GetKernelPtr).SymbolTable.GetValueAsString( + prog.GetProgPtr, StackFrameNumber, Id, TypeMapRec); +end; + +function TPaxCompilerDebugger.GetValueAsString(Id: Integer): String; +var + TypeMapRec: TTypeMapRec; +begin + TypeMapRec := TKernel(compiler.GetKernelPtr).GetTypeMapRec(Id); + result := TKernel(compiler.GetKernelPtr).SymbolTable.GetValueAsString( + prog.GetProgPtr, 0, Id, TypeMapRec); +end; + +function TPaxCompilerDebugger.GetValueAsBriefString(StackFrameNumber, Id: Integer): String; +var + TypeMapRec: TTypeMapRec; +begin + TypeMapRec := TKernel(compiler.GetKernelPtr).GetTypeMapRec(Id); + + result := TKernel(compiler.GetKernelPtr).SymbolTable.GetValueAsString( + prog.GetProgPtr, StackFrameNumber, Id, TypeMapRec, true); +end; + +function TPaxCompilerDebugger.GetValueAsBriefString(Id: Integer): String; +var + TypeMapRec: TTypeMapRec; +begin + TypeMapRec := TKernel(compiler.GetKernelPtr).GetTypeMapRec(Id); + result := TKernel(compiler.GetKernelPtr).SymbolTable.GetValueAsString( + prog.GetProgPtr, 0, Id, TypeMapRec, true); +end; + +procedure TPaxCompilerDebugger.PutValue(StackFrameNumber, Id: Integer; const Value: Variant); +begin + TKernel(compiler.GetKernelPtr).SymbolTable.PutValue( + prog.GetProgPtr, StackFrameNumber, Id, Value); +end; + +procedure TPaxCompilerDebugger.PutValue(Id: Integer; const Value: Variant); +begin + TKernel(compiler.GetKernelPtr).SymbolTable.PutValue( + prog.GetProgPtr, 0, Id, Value); +end; + +function TPaxCompilerDebugger.GetFieldValueAsString(StackFrameNumber: Integer; + Id, FieldNumber: Integer): String; +var + TypeMapRec: TTypeMapRec; +begin + TypeMapRec := TKernel(compiler.GetKernelPtr).GetTypeMapRec(Id); + + result := TKernel(compiler.GetKernelPtr).SymbolTable.GetFieldValueAsString( + prog.GetProgPtr, StackFrameNumber, Id, FieldNumber, TypeMapRec); +end; + +function TPaxCompilerDebugger.GetFieldValueAsBriefString(StackFrameNumber: Integer; + Id, FieldNumber: Integer): String; +var + TypeMapRec: TTypeMapRec; +begin + TypeMapRec := TKernel(compiler.GetKernelPtr).GetTypeMapRec(Id); + + result := TKernel(compiler.GetKernelPtr).SymbolTable.GetFieldValueAsString( + prog.GetProgPtr, StackFrameNumber, Id, FieldNumber, TypeMapRec, true); +end; + +function TPaxCompilerDebugger.GetPublishedPropValueAsString(StackFrameNumber: Integer; + Id, PropNumber: Integer): String; +begin + result := TKernel(compiler.GetKernelPtr).SymbolTable.GetPublishedPropValueAsString( + prog.GetProgPtr, StackFrameNumber, Id, PropNumber); +end; + +function TPaxCompilerDebugger.GetDynArrayLength(StackFrameNumber, + Id: Integer): Integer; +var + Address, P: Pointer; +begin + Address := TKernel(compiler.GetKernelPtr).SymbolTable.GetFinalAddress( + prog.GetProgPtr, StackFrameNumber, Id); + Address := Pointer(Address^); + + if Address = nil then + begin + result := -1; + Exit; + end; + + P := ShiftPointer(Address, - SizeOf(Integer)); + result := Integer(P^); +end; + +function TPaxCompilerDebugger.GetArrayItemValueAsString(StackFrameNumber: Integer; + Id, Index: Integer): String; +begin + result := TKernel(compiler.GetKernelPtr).SymbolTable.GetArrayItemValueAsString( + prog.GetProgPtr, StackFrameNumber, Id, Index); +end; + +function TPaxCompilerDebugger.GetDynArrayItemValueAsString(StackFrameNumber: Integer; + Id, Index: Integer): String; +begin + result := TKernel(compiler.GetKernelPtr).SymbolTable.GetDynArrayItemValueAsString( + prog.GetProgPtr, StackFrameNumber, Id, Index); +end; + +function TPaxCompilerDebugger.AddBreakpoint(const ModuleName: String; + SourceLine: Integer): Boolean; +begin + result := prog.GetProgPtr.AddBreakpoint(ModuleName, SourceLine) <> nil; +end; + +function TPaxCompilerDebugger.AddTempBreakpoint(const ModuleName: String; + SourceLine: Integer): Boolean; +begin + result := prog.GetProgPtr.AddTempBreakpoint(ModuleName, SourceLine) <> nil; +end; + +function TPaxCompilerDebugger.RemoveBreakpoint(const ModuleName: String; + SourceLine: Integer): Boolean; +begin + result := prog.GetProgPtr.RemoveBreakpoint(ModuleName, SourceLine); +end; + +procedure TPaxCompilerDebugger.RemoveAllBreakpoints; +begin + prog.GetProgPtr.RemoveAllBreakpoints; +end; + +function TPaxCompilerDebugger.HasBreakpoint(const ModuleName: String; + SourceLine: Integer): Boolean; +begin + result := prog.GetProgPtr.HasBreakpoint(ModuleName, SourceLine); +end; + +function TPaxCompilerDebugger.GetSourceLineNumber: Integer; +begin + result := prog.GetProgPtr.GetSourceLine; +end; + +function TPaxCompilerDebugger.GetModuleName: String; +begin + result := prog.GetProgPtr.GetModuleName; +end; + +function TPaxCompilerDebugger.GetRunMode: Integer; +begin + result := prog.GetProgPtr.RunMode; +end; + +procedure TPaxCompilerDebugger.SetRunMode(Value: Integer); +begin + prog.GetProgPtr.RunMode := Value; +end; + +function TPaxCompilerDebugger.GetValid: Boolean; +begin + if prog = nil then + result := false + else + result := prog.GetProgPtr.Valid; +end; + +function TPaxCompilerDebugger.GetCallStackCount: Integer; +begin + result := prog.GetProgPtr.GetCallStackCount; +end; + +function TPaxCompilerDebugger.GetCallStackItem(I: Integer): Integer; +begin + result := prog.GetProgPtr.GetCallStackItem(I); +end; + +function TPaxCompilerDebugger.GetCallStackLineNumber(I: Integer): Integer; +begin + result := prog.GetProgPtr.GetCallStackLineNumber(I); +end; + +function TPaxCompilerDebugger.GetCallStackModuleName(I: Integer): String; +begin + result := prog.GetProgPtr.GetCallStackModuleName(I); +end; + +function TPaxCompilerDebugger.GetCallStackModuleIndex(I: Integer): Integer; +begin + result := prog.GetProgPtr.GetCallStackModuleIndex(I); +end; + +procedure TPaxCompilerDebugger.Reset; +begin + prog.GetProgPtr.ResetRun; +end; + +end. diff --git a/Sources/PaxCompilerExplorer.pas b/Sources/PaxCompilerExplorer.pas new file mode 100644 index 0000000..1d552b8 --- /dev/null +++ b/Sources/PaxCompilerExplorer.pas @@ -0,0 +1,1269 @@ +//////////////////////////////////////////////////////////////////////////// +// PaxCompiler +// Site: http://www.paxcompiler.com +// Author: Alexander Baranovsky (paxscript@gmail.com) +// ======================================================================== +// Copyright (c) Alexander Baranovsky, 2006-2014. All rights reserved. +// Code Version: 4.2 +// ======================================================================== +// Unit: PaxCompilerExplorer.pas +// ======================================================================== +//////////////////////////////////////////////////////////////////////////// + +{$I PaxCompiler.def} +unit PaxCompilerExplorer; +interface +uses {$I uses.def} + TypInfo, + SysUtils, + Classes, + PAXCOMP_CONSTANTS, + PAXCOMP_SYS, + PAXCOMP_TYPES, + PAXCOMP_SYMBOL_REC, + PAXCOMP_BASESYMBOL_TABLE, + PAXCOMP_SYMBOL_TABLE, + PAXCOMP_KERNEL, + PAXCOMP_MAP, + PAXCOMP_BYTECODE, + PAXCOMP_STDLIB, + PaxCompiler; +type + TPaxMemberKind = (pmkNone, pmkNamespace, pmkType, pmkField, pmkProperty, pmkProcedure, pmkFunction, + pmkConstructor, pmkDestructor, pmkEnumMember, + pmkParam, pmkVar, pmkConst); + + TExplorerEnumProc = procedure (Id: Integer; + Host: Boolean; + Kind: TPaxMemberKind; + Data: Pointer) of object; + + TPaxCompilerExplorer = class(TComponent) + private + compiler: TPaxCompiler; + fUsedNamespaces: TAssocStringInt; + fNotUsedNamespaces: TAssocStringInt; + fExisttNamespaceLists: Boolean; + procedure BuildNamespaceLists; + procedure TestId(Id: Integer); + procedure TestSubId(SubId: Integer); + procedure TestNamespaceId(NamespaceId: Integer); + procedure TestArrayId(ArrayId: Integer); +// procedure TestDynArrayId(DynArrayId: Integer); + + function GetName(Id: Integer): String; + function GetFullName(Id: Integer): String; + function GetKind(Id: Integer): TPaxMemberKind; + function GetTypeId(Id: Integer): Integer; + function GetTypeName(Id: Integer): String; + function GetPosition(Id: Integer): Integer; + + function GetUsedNamespaces: TStringList; + function GetNotUsedNamespaces: TStringList; + + protected + function GetStrKind(Id: Integer): String; virtual; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + procedure RegisterCompiler(i_compiler: TPaxCompiler); + function IsExecutableLine(const ModuleName: String; + LineNumber: Integer): Boolean; + + function GetParamCount(SubId: Integer): Integer; + function GetParamId(SubId, I: Integer): Integer; + function GetResultId(SubId: Integer): Integer; + + function GetLocalCount(SubId: Integer): Integer; + function GetLocalId(SubId, I: Integer): Integer; + + function GetGlobalCount(NamespaceId: Integer): Integer; + function GetGlobalId(NamespaceId, I: Integer): Integer; + + function HasArrayType(Id: Integer): Boolean; + function HasDynArrayType(Id: Integer): Boolean; + function HasRecordType(Id: Integer): Boolean; + function HasClassType(Id: Integer): Boolean; + + function Host(Id: Integer): Boolean; + + function GetFieldCount(Id: Integer): Integer; + function GetFieldName(Id, FieldNumber: Integer): String; + function GetFieldId(Id, FieldNumber: Integer): Integer; + + function GetPublishedPropCount(Id: Integer): Integer; + function GetPublishedPropName(Id, PropNumber: Integer): String; + + function GetArrayLowBound(Id: Integer): Integer; + function GetArrayHighBound(Id: Integer): Integer; + + function GetNamespaceId(Id: Integer): Integer; + function GetVisibility(Id: Integer): TClassVisibility; + function GetReadId(PropId: Integer): Integer; + function GetWriteId(PropId: Integer): Integer; +// function GetArrayDef(Id: Integer): String; + function GetLevelId(Id: Integer): Integer; + + function GetAncestorId(Id: Integer): Integer; + + procedure EnumMembers(OwnerId: Integer; + Host: Boolean; + pmk: TPaxMemberKind; + CallBack: TExplorerEnumProc; + Data: Pointer); + + procedure ExtractMembers(const Id: Integer; L: TStrings; + PaxLang: TPaxCompilerLanguage = nil); + + function IsConst(LevelId, Id: Integer): Boolean; + function IsVar(LevelId, Id: Integer): Boolean; + function IsProcedure(LevelId, Id: Integer): Boolean; + function IsFunction(LevelId, Id: Integer): Boolean; + function IsNamespace(LevelId, Id: Integer): Boolean; + function IsType(LevelId, Id: Integer): Boolean; + function IsTypeField(TypeId, Id: Integer): Boolean; + function IsProperty(TypeId, Id: Integer): Boolean; + function IsConstructor(TypeId, Id: Integer): Boolean; + function IsDestructor(TypeId, Id: Integer): Boolean; + function IsByRefParam(Id: Integer): Boolean; + function IsConstParam(Id: Integer): Boolean; + function IsMethod(Id: Integer): Boolean; + + function IsArrayType(Id: Integer): Boolean; + function IsDynArrayType(Id: Integer): Boolean; + function IsRecordType(Id: Integer): Boolean; + function IsClassType(Id: Integer): Boolean; + function IsInterfaceType(Id: Integer): Boolean; + function IsEnumType(Id: Integer): Boolean; + function IsAliasType(Id: Integer): Boolean; + function IsDeprecated(Id: Integer): Boolean; + function IsUsedNamespaceId(Id: Integer): Boolean; + + property Names[Id: Integer]: String read GetName; + property FullNames[Id: Integer]: String read GetFullName; + property Kinds[Id: Integer]: TPaxMemberKind read GetKind; + property StrKinds[Id: Integer]: String read GetStrKind; + property TypeIds[Id: Integer]: Integer read GetTypeId; + property TypeNames[Id: Integer]: String read GetTypeName; + property Positions[Id: Integer]: Integer read GetPosition; + + property UsedNamespaces: TStringList read GetUsedNamespaces; + property NotUsedNamespaces: TStringList read GetNotUsedNamespaces; + end; + +implementation + +/////////////// TPaxCompilerExplorer /////////////////////////////////////////// + +procedure RaiseError(const Message: string; params: array of Const); +begin + raise Exception.Create(Format(Message, params)) +end; + +constructor TPaxCompilerExplorer.Create(AOwner: TComponent); +begin + inherited; + fUsedNamespaces := TAssocStringInt.Create; + fNotUsedNamespaces := TAssocStringInt.Create; + + compiler := nil; +end; + +destructor TPaxCompilerExplorer.Destroy; +begin + FreeAndNil(fUsedNamespaces); + FreeAndNil(fNotUsedNamespaces); + + inherited; +end; + +procedure TPaxCompilerExplorer.RegisterCompiler(i_compiler: TPaxCompiler); +begin + compiler := i_compiler; +end; + +function TPaxCompilerExplorer.IsExecutableLine(const ModuleName: String; + LineNumber: Integer): Boolean; +begin + result := TKernel(compiler.GetKernelPtr).IsExecutableLine(ModuleName, + LineNumber); +end; + +procedure TPaxCompilerExplorer.TestId(Id: Integer); +begin + if (Id <= 0) or (Id > TKernel(compiler.GetKernelPtr).SymbolTable.Card) then + RaiseError(errInvalidId, [Id]); +end; + +procedure TPaxCompilerExplorer.TestSubId(SubId: Integer); +begin + TestId(SubId); + if not (TKernel(compiler.GetKernelPtr).SymbolTable[SubId].Kind + in [kindSUB, KindPROP, + KindCONSTRUCTOR, KindDESTRUCTOR]) then + RaiseError(errInvalidId, [SubId]); +end; + +procedure TPaxCompilerExplorer.TestNamespaceId(NamespaceId: Integer); +begin + if NamespaceId = 0 then + Exit; + TestId(NamespaceId); + if TKernel(compiler.GetKernelPtr).SymbolTable[NamespaceId].Kind <> + kindNAMESPACE then + RaiseError(errInvalidId, [NamespaceId]); +end; + +function TPaxCompilerExplorer.GetName(Id: Integer): String; +begin + TestId(Id); + result := TKernel(compiler.GetKernelPtr).SymbolTable[Id].Name; +end; + +function TPaxCompilerExplorer.GetFullName(Id: Integer): String; +begin + TestId(Id); + result := TKernel(compiler.GetKernelPtr).SymbolTable[Id].FullName; +end; + +function TPaxCompilerExplorer.GetKind(Id: Integer): TPaxMemberKind; +var + K: Integer; +begin + TestId(Id); + K := TKernel(compiler.GetKernelPtr).SymbolTable[Id].Kind; + result := pmkNone; + case K of + KindVAR: + begin + if TKernel(compiler.GetKernelPtr).SymbolTable[Id].Param then + result := pmkParam + else + result := pmkVar; + end; + KindCONST: result := pmkConst; + KindTYPE: result := pmkType; + KindNAMESPACE: result := pmkNamespace; + KindTYPE_FIELD: result := pmkField; + KindPROP: result := pmkProperty; + KindSUB: + if GetTypeId(id) = typeVOID then + result := pmkProcedure + else + result := pmkFunction; + KindCONSTRUCTOR: result := pmkConstructor; + KindDESTRUCTOR: result := pmkDestructor; + end; +end; + +function TPaxCompilerExplorer.GetStrKind(Id: Integer): String; +var + K: TPaxMemberKind; +begin + K := GetKind(Id); + case K of + pmkNone: result := ''; + pmkNamespace: result := 'namespace'; + pmkType: result := 'type'; + pmkField: result := 'field'; + pmkProperty: result := 'property'; + pmkProcedure: result := 'procedure'; + pmkFunction: result := 'function'; + pmkConstructor: result := 'constructor'; + pmkDestructor: result := 'destructor'; + pmkParam: result := 'parameter'; + pmkVar: result := 'variable'; + pmkConst: result := 'constant'; + end; +end; + +function TPaxCompilerExplorer.GetPosition(Id: Integer): Integer; +begin + TestId(Id); + result := TKernel(compiler.GetKernelPtr).SymbolTable[Id].Position; +end; + +function TPaxCompilerExplorer.GetTypeName(Id: Integer): String; +var + TypeId: Integer; +begin + TestId(Id); + TypeId := TKernel(compiler.GetKernelPtr).SymbolTable[Id].TypeId; + if TypeId = 0 then + result := '' + else + result := TKernel(compiler.GetKernelPtr).SymbolTable[TypeId].Name; +end; + +function TPaxCompilerExplorer.GetTypeId(Id: Integer): Integer; +begin + TestId(Id); + result := TKernel(compiler.GetKernelPtr).SymbolTable[Id].TypeId; +end; + +function TPaxCompilerExplorer.GetParamCount(SubId: Integer): Integer; +begin + TestSubId(SubId); + result := TKernel(compiler.GetKernelPtr).SymbolTable[SubId].Count; +end; + +function TPaxCompilerExplorer.GetParamId(SubId, I: Integer): Integer; +begin + TestId(SubId); + result := TKernel(compiler.GetKernelPtr).SymbolTable.GetParamId(SubId, I); +end; + +function TPaxCompilerExplorer.GetResultId(SubId: Integer): Integer; +begin + TestId(SubId); + result := TKernel(compiler.GetKernelPtr).SymbolTable.GetResultId(SubId); +end; + +function TPaxCompilerExplorer.GetLocalCount(SubId: Integer): Integer; +begin + TestSubId(SubId); + result := TKernel(compiler.GetKernelPtr).SymbolTable.GetLocalCount(SubId); +end; + +function TPaxCompilerExplorer.GetLocalId(SubId, I: Integer): Integer; +begin + TestSubId(SubId); + result := TKernel(compiler.GetKernelPtr).SymbolTable.GetLocalId(SubId, I); +end; + +function TPaxCompilerExplorer.GetGlobalCount(NamespaceId: Integer): Integer; +begin + TestNamespaceId(NamespaceId); + result := TKernel(compiler.GetKernelPtr).SymbolTable.GetGlobalCount(NamespaceId); +end; + +function TPaxCompilerExplorer.GetGlobalId(NamespaceId, I: Integer): Integer; +begin + TestNamespaceId(NamespaceId); + result := TKernel(compiler.GetKernelPtr).SymbolTable.GetGlobalId(NamespaceId, I); +end; + +function TPaxCompilerExplorer.GetFieldCount(Id: Integer): Integer; +var + T: Integer; + TypeMapRec: TTypeMapRec; + TypeMap: TTypeMap; +begin + TestId(Id); + T := TKernel(compiler.GetKernelPtr).SymbolTable[Id].FinalTypeId; + if T in [typeRECORD, typeCLASS] then + begin + TypeMap := TKernel(compiler.GetKernelPtr).TypeMap; + T := TKernel(compiler.GetKernelPtr).SymbolTable[Id].TerminalTypeId; + TypeMapRec := TypeMap.Lookup(T); + if TypeMapRec = nil then + TypeMapRec := TypeMap.Add(T) + else + if TypeMapRec.Completed then + begin + result := TypeMapRec.Fields.Count; + Exit; + end; + TypeMapRec.Fields.Clear; + result := TKernel(compiler.GetKernelPtr).SymbolTable.GetFieldCount(Id, + TypeMapRec); + TypeMapRec.Completed := true; + end + else + result := 0; +end; + +function TPaxCompilerExplorer.GetFieldName(Id, FieldNumber: Integer): String; +var + FieldId: Integer; + TypeMapRec: TTypeMapRec; +begin + TestId(Id); + + TypeMapRec := TKernel(compiler.GetKernelPtr).GetTypeMapRec(Id); + if TypeMapRec <> nil then + begin + FieldId := TypeMapRec.Fields[FieldNumber]; + result := TKernel(compiler.GetKernelPtr).SymbolTable[FieldId].Name; + end + else + result := ''; +end; + +function TPaxCompilerExplorer.GetFieldId(Id, FieldNumber: Integer): Integer; +var + TypeMapRec: TTypeMapRec; +begin + TestId(Id); + TypeMapRec := TKernel(compiler.GetKernelPtr).GetTypeMapRec(Id); + if TypeMapRec <> nil then + result := TypeMapRec.Fields[FieldNumber] + else + result := 0; +end; + +function TPaxCompilerExplorer.GetPublishedPropCount(Id: Integer): Integer; +begin + TestId(Id); + result := TKernel(compiler.GetKernelPtr).SymbolTable.GetPublishedPropCount(Id); +end; + +function TPaxCompilerExplorer.GetPublishedPropName(Id, PropNumber: Integer): String; +begin + TestId(Id); + result := TKernel(compiler.GetKernelPtr).SymbolTable.GetPublishedPropName(Id, + PropNumber); +end; + +procedure TPaxCompilerExplorer.TestArrayId(ArrayId: Integer); +begin + if ArrayId = 0 then + Exit; + TestId(ArrayId); + if TKernel(compiler.GetKernelPtr).SymbolTable[ArrayId].FinalTypeId <> + typeARRAY then + RaiseError(errInvalidId, [ArrayId]); +end; + +{ +procedure TPaxCompilerExplorer.TestDynArrayId(DynArrayId: Integer); +begin + if DynArrayId = 0 then + Exit; + TestId(DynArrayId); + if TKernel(compiler.GetKernelPtr).SymbolTable[DynArrayId].FinalTypeId <> + typeDYNARRAY then + RaiseError(errInvalidId, [DynArrayId]); +end; +} + +function TPaxCompilerExplorer.GetArrayLowBound(Id: Integer): Integer; +var + TypeId, RangeTypeId, ElemTypeId: Integer; +begin + TestArrayId(Id); + TypeId := TKernel(compiler.GetKernelPtr).SymbolTable[Id].TerminalTypeId; + with TKernel(compiler.GetKernelPtr).SymbolTable do + begin + GetArrayTypeInfo(TypeId, RangeTypeId, ElemTypeId); + result := GetLowBoundRec(RangeTypeId).Value; + end; +end; + +function TPaxCompilerExplorer.GetArrayHighBound(Id: Integer): Integer; +var + TypeId, RangeTypeId, ElemTypeId: Integer; +begin + TestArrayId(Id); + TypeId := TKernel(compiler.GetKernelPtr).SymbolTable[Id].TerminalTypeId; + with TKernel(compiler.GetKernelPtr).SymbolTable do + begin + GetArrayTypeInfo(TypeId, RangeTypeId, ElemTypeId); + result := GetHighBoundRec(RangeTypeId).Value; + end; +end; + +function TPaxCompilerExplorer.HasArrayType(Id: Integer): Boolean; +begin + TestId(Id); + with TKernel(compiler.GetKernelPtr).SymbolTable[Id] do + result := (Kind = KindVAR) and (FinalTypeId = typeARRAY); +end; + +function TPaxCompilerExplorer.HasDynArrayType(Id: Integer): Boolean; +begin + TestId(Id); + with TKernel(compiler.GetKernelPtr).SymbolTable[Id] do + result := (Kind = KindVAR) and (FinalTypeId = typeDYNARRAY); +end; + +function TPaxCompilerExplorer.HasRecordType(Id: Integer): Boolean; +begin + TestId(Id); + with TKernel(compiler.GetKernelPtr).SymbolTable[Id] do + result := (Kind = KindVAR) and (FinalTypeId = typeRECORD); +end; + +function TPaxCompilerExplorer.HasClassType(Id: Integer): Boolean; +begin + TestId(Id); + with TKernel(compiler.GetKernelPtr).SymbolTable[Id] do + result := (Kind = KindVAR) and (FinalTypeId = typeCLASS); +end; + +function TPaxCompilerExplorer.IsDeprecated(Id: Integer): Boolean; +begin + TestId(Id); + result := TKernel(compiler.GetKernelPtr).SymbolTable[Id].IsDeprecated; +end; + +function TPaxCompilerExplorer.IsArrayType(Id: Integer): Boolean; +begin + TestId(Id); + with TKernel(compiler.GetKernelPtr).SymbolTable[Id] do + result := (Kind = KindTYPE) and (FinalTypeId = typeARRAY); +end; + +function TPaxCompilerExplorer.IsDynArrayType(Id: Integer): Boolean; +begin + TestId(Id); + with TKernel(compiler.GetKernelPtr).SymbolTable[Id] do + result := (Kind = KindTYPE) and (FinalTypeId = typeDYNARRAY); +end; + +function TPaxCompilerExplorer.IsRecordType(Id: Integer): Boolean; +begin + TestId(Id); + with TKernel(compiler.GetKernelPtr).SymbolTable[Id] do + result := (Kind = KindTYPE) and (FinalTypeId = typeRECORD); +end; + +function TPaxCompilerExplorer.IsClassType(Id: Integer): Boolean; +begin + TestId(Id); + with TKernel(compiler.GetKernelPtr).SymbolTable[Id] do + result := (Kind = KindTYPE) and (FinalTypeId = typeCLASS); +end; + +function TPaxCompilerExplorer.IsInterfaceType(Id: Integer): Boolean; +begin + TestId(Id); + with TKernel(compiler.GetKernelPtr).SymbolTable[Id] do + result := (Kind = KindTYPE) and (FinalTypeId = typeINTERFACE); +end; + +function TPaxCompilerExplorer.Host(Id: Integer): Boolean; +begin + TestId(Id); + result := TKernel(compiler.GetKernelPtr).SymbolTable[Id].Host; +end; + +procedure TPaxCompilerExplorer.EnumMembers(OwnerId: Integer; + Host: Boolean; + pmk: TPaxMemberKind; + CallBack: TExplorerEnumProc; + Data: Pointer); +var + SymbolTable: TSymbolTable; + Count, K, I, FinTypeId: Integer; + RI: TSymbolRec; +begin + SymbolTable := TKernel(compiler.GetKernelPtr).SymbolTable; + BuildNamespaceLists; + + if not Host then + if OwnerId > 0 then + if SymbolTable[OwnerId].Host then + begin + Host := true; + end; + + if OwnerId = 0 then + begin + case pmk of + pmkProcedure: + begin + if Host then + for I:=1 to SymbolTable.CompileCard do + begin + RI := SymbolTable[I]; + if RI = SymbolTable.SR0 then + break; + if RI.Kind = kindNAMESPACE then + break; + + if SymbolTable.IsProcedure(OwnerId, I) then + CallBack(I, Host, pmk, Data); + end + else + for I:=SymbolTable.CompileCard + 1 to SymbolTable.Card do + begin + RI := SymbolTable[I]; + if RI.Kind = kindNAMESPACE then + break; + + if SymbolTable.IsProcedure(OwnerId, I) then + CallBack(I, Host, pmk, Data); + end; + end; + pmkFunction: + begin + if Host then + for I:=1 to SymbolTable.CompileCard do + begin + RI := SymbolTable[I]; + if RI = SymbolTable.SR0 then + break; + if RI.Kind = kindNAMESPACE then + break; + + if SymbolTable.IsFunction(OwnerId, I) then + CallBack(I, Host, pmk, Data); + end + else + for I:=SymbolTable.CompileCard + 1 to SymbolTable.Card do + begin + RI := SymbolTable[I]; + if RI.Kind = kindNAMESPACE then + break; + + if SymbolTable.IsFunction(OwnerId, I) then + CallBack(I, Host, pmk, Data); + end; + end; + pmkConst: + begin + if Host then + for I:=1 to SymbolTable.CompileCard do + begin + RI := SymbolTable[I]; + if RI = SymbolTable.SR0 then + break; + if RI.Kind = kindNAMESPACE then + break; + + if SymbolTable.IsConst(OwnerId, I) then + CallBack(I, Host, pmk, Data); + end + else + for I:=SymbolTable.CompileCard + 1 to SymbolTable.Card do + begin + RI := SymbolTable[I]; + if RI.Kind = kindNAMESPACE then + break; + + if SymbolTable.IsConst(OwnerId, I) then + CallBack(I, Host, pmk, Data); + end; + end; + pmkVar: + begin + if Host then + for I:=1 to SymbolTable.CompileCard do + begin + RI := SymbolTable[I]; + if RI = SymbolTable.SR0 then + break; + if RI.Kind = kindNAMESPACE then + break; + + if SymbolTable.IsVar(OwnerId, I) then + CallBack(I, Host, pmk, Data); + end + else + for I:=SymbolTable.CompileCard + 1 to SymbolTable.Card do + begin + RI := SymbolTable[I]; + if RI.Kind = kindNAMESPACE then + break; + + if SymbolTable.IsVar(OwnerId, I) then + CallBack(I, Host, pmk, Data); + end; + end; + pmkType: + begin + if Host then + for I:=1 to SymbolTable.CompileCard do + begin + RI := SymbolTable[I]; + if RI = SymbolTable.SR0 then + break; + if RI.Kind = kindNAMESPACE then + break; + + if SymbolTable.IsType(OwnerId, I) then + CallBack(I, Host, pmk, Data); + end + else + for I:=SymbolTable.CompileCard + 1 to SymbolTable.Card do + begin + if SymbolTable.IsType(OwnerId, I) then + CallBack(I, Host, pmk, Data); + end; + end; + pmkNamespace: + begin + if Host then + begin + for I:=1 to SymbolTable.GlobalST.Card do + if SymbolTable.IsNamespace(OwnerId, I) then + if IsUsedNamespaceId(I) then + CallBack(I, Host, pmk, Data); + for I:=FirstLocalId + 1 to SymbolTable.Card do + if SymbolTable.IsNamespace(OwnerId, I) then + if IsUsedNamespaceId(I) then + CallBack(I, Host, pmk, Data); + end + else + for I:=SymbolTable.CompileCard + 1 to SymbolTable.Card do + begin + if SymbolTable.IsNamespace(OwnerId, I) then + if IsUsedNamespaceId(I) then + CallBack(I, Host, pmk, Data); + end; + end; + end; + + Exit; + end; + + K := SymbolTable[OwnerId].Kind; + + if K in KindSUBS then + begin + case pmk of + pmkParam: + begin + Count := SymbolTable[OwnerId].Count; + if Count = 0 then + Exit; + K := 0; + for I:=OwnerId + 1 to SymbolTable.Card do + begin + if SymbolTable.IsParam(OwnerId, I) then + begin + CallBack(I, Host, pmk, Data); + Inc(K); + if K = Count then + Exit; + end; + end; + RaiseError(errInternalError, []); + end; + pmkVar: + begin + if Host then + Exit; + + for I:=OwnerId + 1 to SymbolTable.Card do + begin + if SymbolTable[I] = SymbolTable.SR0 then + break; + if SymbolTable[I].Kind = kindNAMESPACE then + break; + + if SymbolTable.IsVar(OwnerId, I) and (not SymbolTable[I].Param) then + CallBack(I, Host, pmk, Data); + end; + end; + pmkConst: + begin + if Host then + Exit; + + for I:=OwnerId + 1 to SymbolTable.Card do + begin + if SymbolTable[I] = SymbolTable.SR0 then + break; + if SymbolTable[I].Kind = kindNAMESPACE then + break; + + if SymbolTable.IsConst(OwnerId, I) then + CallBack(I, Host, pmk, Data); + end; + end; + pmkType: + begin + if Host then + Exit; + + for I:=OwnerId + 1 to SymbolTable.Card do + begin + if SymbolTable[I] = SymbolTable.SR0 then + break; + if SymbolTable[I].Kind = kindNAMESPACE then + break; + + if SymbolTable.IsType(OwnerId, I) then + CallBack(I, Host, pmk, Data); + end; + end; + pmkProcedure: + begin + if Host then + Exit; + + for I:=OwnerId + 1 to SymbolTable.Card do + begin + RI := SymbolTable[I]; + + if RI = SymbolTable.SR0 then + break; + if RI.Kind = kindSUB then + if RI.Level <> OwnerId then + break; + if RI.Kind = kindNAMESPACE then + break; + + if SymbolTable.IsProcedure(OwnerId, I) then + CallBack(I, Host, pmk, Data); + end; + end; + pmkFunction: + begin + if Host then + Exit; + + for I:=OwnerId + 1 to SymbolTable.Card do + begin + RI := SymbolTable[I]; + + if RI = SymbolTable.SR0 then + break; + if RI.Kind = kindSUB then + if RI.Level <> OwnerId then + break; + if RI.Kind = kindNAMESPACE then + break; + + if SymbolTable.IsFunction(OwnerId, I) then + CallBack(I, Host, pmk, Data); + end; + end; + end; + end // Owner in kindSUBS + else if K = KindTYPE then + begin + FinTypeId := SymbolTable[OwnerId].FinalTypeId; + case pmk of + pmkEnumMember: + begin + if FinTypeId <> typeENUM then + Exit; + for I:=OwnerId + 1 to SymbolTable.Card do + begin + RI := SymbolTable[I]; + if RI = SymbolTable.SR0 then + break; + if RI.Kind in [kindNAMESPACE, KindSUB] then + break; + + if SymbolTable.IsEnumMember(OwnerId, I) then + CallBack(I, Host, pmk, Data); + end; + end; + pmkField: + begin + if not (FinTypeId in [typeCLASS, typeRECORD]) then + Exit; + + for I:=OwnerId + 1 to SymbolTable.Card do + begin + RI := SymbolTable[I]; + if RI = SymbolTable.SR0 then + break; + if RI.Kind = kindNAMESPACE then + break; + + if SymbolTable.IsTypeField(OwnerId, I) then + CallBack(I, Host, pmk, Data); + end; + end; + pmkProperty: + begin + if not (FinTypeId in [typeCLASS, typeRECORD, typeINTERFACE]) then + Exit; + + for I:=OwnerId + 1 to SymbolTable.Card do + begin + RI := SymbolTable[I]; + if RI = SymbolTable.SR0 then + break; + if RI.Kind = kindNAMESPACE then + break; + + if SymbolTable.IsProperty(OwnerId, I) then + CallBack(I, Host, pmk, Data); + end; + end; + pmkProcedure: + begin + if not (FinTypeId in [typeCLASS, typeRECORD, typeINTERFACE]) then + Exit; + + for I:=OwnerId + 1 to SymbolTable.Card do + begin + RI := SymbolTable[I]; + if RI = SymbolTable.SR0 then + break; + if RI.Kind = kindNAMESPACE then + break; + + if SymbolTable.IsProcedure(OwnerId, I) then + CallBack(I, Host, pmk, Data); + end; + end; + pmkFunction: + begin + if not (FinTypeId in [typeCLASS, typeRECORD, typeINTERFACE]) then + Exit; + + for I:=OwnerId + 1 to SymbolTable.Card do + begin + RI := SymbolTable[I]; + if RI = SymbolTable.SR0 then + break; + if RI.Kind = kindNAMESPACE then + break; + + if SymbolTable.IsFunction(OwnerId, I) then + CallBack(I, Host, pmk, Data); + end; + end; + pmkConstructor: + begin + if not (FinTypeId in [typeCLASS, typeRECORD]) then + Exit; + + for I:=OwnerId + 1 to SymbolTable.Card do + begin + RI := SymbolTable[I]; + if RI = SymbolTable.SR0 then + break; + if RI.Kind = kindNAMESPACE then + break; + + if SymbolTable.IsConstructor(OwnerId, I) then + CallBack(I, Host, pmk, Data); + end; + end; + pmkDestructor: + begin + if not (FinTypeId in [typeCLASS, typeRECORD]) then + Exit; + + for I:=OwnerId + 1 to SymbolTable.Card do + begin + RI := SymbolTable[I]; + if RI = SymbolTable.SR0 then + break; + if RI.Kind = kindNAMESPACE then + break; + + if SymbolTable.IsDestructor(OwnerId, I) then + CallBack(I, Host, pmk, Data); + end; + end; + end; + end + else if K = KindNAMESPACE then + begin + case pmk of + pmkProcedure: + for I:=OwnerId + 1 to SymbolTable.Card do + begin + RI := SymbolTable[I]; + if RI = SymbolTable.SR0 then + break; + if RI.Kind = kindNAMESPACE then + break; + + if SymbolTable.IsProcedure(OwnerId, I) then + CallBack(I, Host, pmk, Data); + end; + pmkFunction: + for I:=OwnerId + 1 to SymbolTable.Card do + begin + RI := SymbolTable[I]; + if RI = SymbolTable.SR0 then + break; + if RI.Kind = kindNAMESPACE then + break; + + if SymbolTable.IsFunction(OwnerId, I) then + CallBack(I, Host, pmk, Data); + end; + pmkConst: + for I:=OwnerId + 1 to SymbolTable.Card do + begin + RI := SymbolTable[I]; + if RI = SymbolTable.SR0 then + break; + if RI.Kind = kindNAMESPACE then + break; + + if SymbolTable.IsConst(OwnerId, I) then + CallBack(I, Host, pmk, Data); + end; + pmkVar: + for I:=OwnerId + 1 to SymbolTable.Card do + begin + RI := SymbolTable[I]; + if RI = SymbolTable.SR0 then + break; + if RI.Kind = kindNAMESPACE then + break; + + if SymbolTable.IsVar(OwnerId, I) then + CallBack(I, Host, pmk, Data); + end; + pmkType: + for I:=OwnerId + 1 to SymbolTable.Card do + begin + RI := SymbolTable[I]; + if RI = SymbolTable.SR0 then + break; + if RI.Kind = kindNAMESPACE then + break; + + if SymbolTable.IsType(OwnerId, I) then + CallBack(I, Host, pmk, Data); + end; + end; + end; +end; + +function TPaxCompilerExplorer.IsConst(LevelId, Id: Integer): Boolean; +begin + result := TKernel(compiler.GetKernelPtr).SymbolTable.IsConst(LevelId, Id); +end; + +function TPaxCompilerExplorer.IsVar(LevelId, Id: Integer): Boolean; +begin + result := TKernel(compiler.GetKernelPtr).SymbolTable.IsVar(LevelId, Id); +end; + +function TPaxCompilerExplorer.IsProcedure(LevelId, Id: Integer): Boolean; +begin + result := TKernel(compiler.GetKernelPtr).SymbolTable.IsProcedure(LevelId, Id); +end; + +function TPaxCompilerExplorer.IsFunction(LevelId, Id: Integer): Boolean; +begin + result := TKernel(compiler.GetKernelPtr).SymbolTable.IsFunction(LevelId, Id); +end; + +function TPaxCompilerExplorer.IsNamespace(LevelId, Id: Integer): Boolean; +begin + result := TKernel(compiler.GetKernelPtr).SymbolTable.IsNamespace(LevelId, Id); +end; + +function TPaxCompilerExplorer.IsType(LevelId, Id: Integer): Boolean; +begin + result := TKernel(compiler.GetKernelPtr).SymbolTable.IsType(LevelId, Id); +end; + +function TPaxCompilerExplorer.IsTypeField(TypeId, Id: Integer): Boolean; +begin + result := TKernel(compiler.GetKernelPtr).SymbolTable.IsTypeField(TypeId, Id); +end; + +function TPaxCompilerExplorer.IsProperty(TypeId, Id: Integer): Boolean; +begin + result := TKernel(compiler.GetKernelPtr).SymbolTable.IsProperty(TypeId, Id); +end; + +function TPaxCompilerExplorer.IsConstructor(TypeId, Id: Integer): Boolean; +begin + result := TKernel(compiler.GetKernelPtr).SymbolTable.IsConstructor(TypeId, Id); +end; + +function TPaxCompilerExplorer.IsDestructor(TypeId, Id: Integer): Boolean; +begin + result := TKernel(compiler.GetKernelPtr).SymbolTable.IsDestructor(TypeId, Id); +end; + +function TPaxCompilerExplorer.GetNamespaceId(Id: Integer): Integer; +var + R: TSymbolRec; + L: Integer; +begin + L := TKernel(compiler.GetKernelPtr).SymbolTable[Id].Level; + repeat + if L = 0 then + begin + result := 0; + Exit; + end; + + R := TKernel(compiler.GetKernelPtr).SymbolTable[L]; + + if R.Kind = kindNAMESPACE then + begin + result := R.Id; + Exit; + end; + + L := R.Level; + + until false; +end; + +function TPaxCompilerExplorer.GetVisibility(Id: Integer): TClassVisibility; +begin + result := TKernel(compiler.GetKernelPtr).SymbolTable[Id].Vis; + if result = cvNone then + result := cvPublic; +end; + +function TPaxCompilerExplorer.GetReadId(PropId: Integer): Integer; +begin + result := TKernel(compiler.GetKernelPtr).SymbolTable[PropId].ReadId; +end; + +function TPaxCompilerExplorer.GetWriteId(PropId: Integer): Integer; +begin + result := TKernel(compiler.GetKernelPtr).SymbolTable[PropId].WriteId; +end; + +function TPaxCompilerExplorer.GetLevelId(Id: Integer): Integer; +begin + result := TKernel(compiler.GetKernelPtr).SymbolTable[Id].Level; +end; + +function TPaxCompilerExplorer.GetAncestorId(Id: Integer): Integer; +begin + result := TKernel(compiler.GetKernelPtr).SymbolTable[Id].AncestorId; +end; + +function TPaxCompilerExplorer.IsByRefParam(Id: Integer): Boolean; +var + R: TSymbolRec; +begin + R := TKernel(compiler.GetKernelPtr).SymbolTable[Id]; + result := R.Param and R.ByRef; +end; + +function TPaxCompilerExplorer.IsConstParam(Id: Integer): Boolean; +var + R: TSymbolRec; +begin + R := TKernel(compiler.GetKernelPtr).SymbolTable[Id]; + result := R.Param and R.IsConst; +end; + +function TPaxCompilerExplorer.IsMethod(Id: Integer): Boolean; +var + L: Integer; +begin + result := false; + L := TKernel(compiler.GetKernelPtr).SymbolTable[Id].Level; + if L = 0 then + Exit; + result := TKernel(compiler.GetKernelPtr).SymbolTable[L].Kind = KindTYPE; +end; + +function TPaxCompilerExplorer.IsEnumType(Id: Integer): Boolean; +begin + TestId(Id); + with TKernel(compiler.GetKernelPtr).SymbolTable[Id] do + result := (Kind = KindTYPE) and (FinalTypeId = typeENUM); +end; + +function TPaxCompilerExplorer.IsAliasType(Id: Integer): Boolean; +begin + TestId(Id); + with TKernel(compiler.GetKernelPtr).SymbolTable[Id] do + result := (Kind = KindTYPE) and (TypeId = typeALIAS); +end; + +procedure TPaxCompilerExplorer.ExtractMembers(const Id: Integer; L: TStrings; + PaxLang: TPaxCompilerLanguage = nil); +begin + TestId(Id); + + if PaxLang = nil then + TKernel(compiler.GetKernelPtr).SymbolTable.ExtractMembers(Id, L) + else if PaxLang is TPaxPascalLanguage then + TKernel(compiler.GetKernelPtr).SymbolTable.ExtractMembers(Id, L) + else + TKernel(compiler.GetKernelPtr).SymbolTable.ExtractMembers(Id, L, lngBasic); +end; + +procedure TPaxCompilerExplorer.BuildNamespaceLists; +var + I, J, Index, Id: Integer; + Code: TCode; + SymbolTable: TSymbolTable; + S: String; +begin + if compiler = nil then + Exit; + if not fExisttNamespaceLists then + begin + fUsedNamespaces.Clear; + Code := TKernel(compiler.GetKernelPtr).Code; + SymbolTable := TKernel(compiler.GetKernelPtr).SymbolTable; + for I := 1 to Code.Card do + if Code[I].Op = OP_BEGIN_USING then + begin + Id := Code[I].Arg1; + if Id = 0 then + S := 'Noname' + else + S := SymbolTable[Id].FullName; + Index := -1; + for J := 0 to fUsedNamespaces.Count - 1 do + if Id = fUsedNamespaces.Values[J] then + begin + Index := J; + break; + end; + if Index = -1 then + fUsedNamespaces.AddValue(S, Id); + end; + + fNotUsedNamespaces.Clear; + I := 0; + repeat + Inc(I); + if I > SymbolTable.Card then + break; + + if SymbolTable[I] = SymbolTable.SR0 then + begin + I := FirstLocalId + 1; + if I > SymbolTable.Card then + break; + end; + + if SymbolTable[I].Kind = KindNAMESPACE then + begin + Id := I; + Index := -1; + for J := 0 to fUsedNamespaces.Count - 1 do + if Id = fUsedNamespaces.Values[J] then + begin + Index := J; + break; + end; + if Index = -1 then + begin + S := SymbolTable[I].FullName; + fNotUsedNamespaces.AddValue(S, Id); + end; + + end; + until false; + + fExisttNamespaceLists := true; + end; +end; + +function TPaxCompilerExplorer.GetUsedNamespaces: TStringList; +begin + BuildNamespaceLists; + result := fUsedNamespaces.Keys; +end; + +function TPaxCompilerExplorer.GetNotUsedNamespaces: TStringList; +begin + BuildNamespaceLists; + result := fNotUsedNamespaces.Keys; +end; + +function TPaxCompilerExplorer.IsUsedNamespaceId(Id: Integer): Boolean; +var + J: Integer; +begin + result := false; + for J := 0 to fUsedNamespaces.Count - 1 do + if Id = fUsedNamespaces.Values[J] then + begin + result := true; + Exit; + end; +end; + +end. diff --git a/Sources/PaxCompilerGroup.groupproj b/Sources/PaxCompilerGroup.groupproj new file mode 100644 index 0000000..2742479 --- /dev/null +++ b/Sources/PaxCompilerGroup.groupproj @@ -0,0 +1,48 @@ + + + {6F4EE984-77D9-44F1-8CA0-AA4168218676} + + + + + + + + + + + Default.Personality.12 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/Sources/PaxCompilerLib.dpr b/Sources/PaxCompilerLib.dpr new file mode 100644 index 0000000..25fe7ed --- /dev/null +++ b/Sources/PaxCompilerLib.dpr @@ -0,0 +1,328 @@ +//////////////////////////////////////////////////////////////////////////// +// PaxCompiler +// Author: Alexander Baranovsky (ab@cable.netlux.org) +// ======================================================================== +// Copyright (c) Alexander Baranovsky, 2006-2010. All rights reserved. +// Code Version: 2.6 +// ======================================================================== +// Unit: PaxCompilerLib.dpr +// ======================================================================== +//////////////////////////////////////////////////////////////////////////// + +{$I PaxCompiler.def} + +library PaxCompilerDll; +uses + {$IFNDEF LINUX} + ShareMem, + {$ENDIF } + PAXCOMP_BASESYMBOL_TABLE, + PaxRegister, + PaxCompiler, + PaxProgram; + +/////////////////////// PaxCompiler //////////////////////////////////////////// + +function PaxCompiler_Create: Integer; stdcall; +var + C: TPaxCompiler; +begin + C := TPaxCompiler.Create(nil); + result := Integer(C); + DllDefined := true; +end; + +procedure PaxCompiler_Destroy(HCompiler: Integer); stdcall; +begin + TPaxCompiler(HCompiler).Free; +end; + +procedure PaxCompiler_Reset(HCompiler: Integer); stdcall; +begin + TPaxCompiler(HCompiler).Reset; +end; + +procedure PaxCompiler_AddModule(HCompiler: Integer; Name, LanguageName: PChar); stdcall; +begin + TPaxCompiler(HCompiler).AddModule(Name, LanguageName); +end; + +procedure PaxCompiler_AddCode(HCompiler: Integer; ModuleName, Text: PChar); stdcall; +begin + TPaxCompiler(HCompiler).AddCode(ModuleName, Text); +end; + +procedure PaxCompiler_AddCodeFromFile(HCompiler: Integer; ModuleName, FileName: PChar); stdcall; +begin + TPaxCompiler(HCompiler).AddCodeFromFile(ModuleName, FileName); +end; + +procedure PaxCompiler_RegisterLanguage(HCompiler, HLanguage: Integer); stdcall; +begin + TPaxCompiler(HCompiler).RegisterLanguage(TPaxCompilerLanguage(HLanguage)); +end; + +function PaxCompiler_RegisterNamespace(HCompiler, LevelId: Integer; NamespaceName: PChar): Integer; stdcall; +begin + if HCompiler = 0 then + result := RegisterNamespace(LevelId, NamespaceName) + else + result := TPaxCompiler(HCompiler).RegisterNamespace(LevelId, NamespaceName); +end; + +function PaxCompiler_RegisterRecordType(HCompiler, LevelId: Integer; TypeName: PChar): Integer; stdcall; +begin + if HCompiler = 0 then + result := RegisterRecordType(LevelId, TypeName) + else + result := TPaxCompiler(HCompiler).RegisterRecordType(LevelId, TypeName); +end; + +function PaxCompiler_RegisterRecordTypeField(HCompiler, RecordTypeId: Integer; FieldName: PChar; FieldTypeID: Integer): Integer; stdcall; +begin + if HCompiler = 0 then + result := RegisterRecordTypeField(RecordTypeId, FieldName, FieldTypeId) + else + result := TPaxCompiler(HCompiler).RegisterRecordTypeField(RecordTypeId, FieldName, FieldTypeId); +end; + +function PaxCompiler_RegisterSubrangeType(HCompiler, LevelId: Integer; TypeName: PChar; TypeBaseId: Integer; + B1, B2: Integer): Integer; stdcall; +begin + if HCompiler = 0 then + result := RegisterSubrangeType(LevelId, TypeName, TypeBaseId, B1, B2) + else + result := TPaxCompiler(HCompiler).RegisterSubrangeType(LevelId, TypeName, TypeBaseId, B1, B2); +end; + +function PaxCompiler_RegisterArrayType(HCompiler, LevelId: Integer; TypeName: PChar; RangeTypeId, ElemTypeId: Integer): Integer; stdcall; +begin + if HCompiler = 0 then + result := RegisterArrayType(LevelId, TypeName, RangeTypeId, ElemTypeId) + else + result := TPaxCompiler(HCompiler).RegisterArrayType(LevelId, TypeName, RangeTypeId, ElemTypeId); +end; + +function PaxCompiler_RegisterPointerType(HCompiler, LevelId: Integer; TypeName: PChar; OriginTypeId: Integer): Integer; stdcall; +begin + if HCompiler = 0 then + result := RegisterPointerType(LevelId, TypeName, OriginTypeId) + else + result := TPaxCompiler(HCompiler).RegisterPointerType(LevelId, TypeName, OriginTypeId); +end; + +function PaxCompiler_RegisterSetType(HCompiler, LevelId: Integer; TypeName: PChar; OriginTypeId: Integer): Integer; stdcall; +begin + if HCompiler = 0 then + result := RegisterSetType(LevelId, TypeName, OriginTypeId) + else + result := TPaxCompiler(HCompiler).RegisterSetType(LevelId, TypeName, OriginTypeId); +end; + +function PaxCompiler_RegisterProceduralType(HCompiler, LevelId: Integer; TypeName: PChar; SubId: Integer): Integer; stdcall; +begin + if HCompiler = 0 then + result := RegisterProceduralType(LevelId, TYpeName, SubId) + else + result := TPaxCompiler(HCompiler).RegisterProceduralType(LevelId, TYpeName, SubId); +end; + +function PaxCompiler_RegisterVariable(HCompiler, LevelId: Integer; Name: PChar; TypeId: Integer): Integer; stdcall; +begin + if HCompiler = 0 then + result := RegisterVariable(LevelId, Name, TypeId, nil) + else + result := TPaxCompiler(HCompiler).RegisterVariable(LevelId, Name, TypeId); +end; + +function PaxCompiler_RegisterRoutine(HCompiler, LevelId: Integer; Name: PChar; + ResultTypeID: Integer): Integer; stdcall; +begin + if HCompiler = 0 then + result := RegisterRoutine(LevelId, Name, ResultTypeId, nil, _ccSTDCALL) + else + result := TPaxCompiler(HCompiler).RegisterRoutine(LevelId, Name, ResultTypeId, _ccSTDCALL); +end; + +function PaxCompiler_RegisterRoutineEx(HCompiler, LevelId: Integer; Name: PChar; + ResultTypeID: Integer; CallConvention: Integer): Integer; stdcall; +begin + if HCompiler = 0 then + result := RegisterRoutine(LevelId, Name, ResultTypeId, nil, CallConvention) + else + result := TPaxCompiler(HCompiler).RegisterRoutine(LevelId, Name, ResultTypeId, CallConvention); +end; + +function PaxCompiler_RegisterParameter(HCompiler, HSub: Integer; ParamTypeID: Integer; + ByRef: Boolean): Integer; stdcall; +begin + if HCompiler = 0 then + result := RegisterParameter(HSub, ParamTypeId, _Unassigned, ByRef) + else + result := TPaxCompiler(HCompiler).RegisterParameter(HSub, ParamTypeId, _Unassigned, ByRef); +end; + +function PaxCompiler_RegisterClassType(HCompiler, LevelId: Integer; C: TClass): Integer; stdcall; +begin + if HCompiler = 0 then + result := RegisterClassType(LevelId, C) + else + result := TPaxCompiler(HCompiler).RegisterClassType(LevelId, C); +end; + +function PaxCompiler_RegisterHeader(HCompiler, LevelId: Integer; const Header: PChar; Address: Pointer): Integer; stdcall; +begin + if HCompiler = 0 then + result := RegisterHeader(LevelId, Header, Address) + else + result := TPaxCompiler(HCompiler).RegisterHeader(LevelId, Header, Address) +end; + +function PaxCompiler_GetHandle(HCompiler, LevelId: Integer; Name: PChar; Upcase: Boolean): Integer; stdcall; +begin + result := TPaxCompiler(HCompiler).GetHandle(LevelId, Name, Upcase); +end; + +function PaxCompiler_Compile(HCompiler, HProgram: Integer): boolean; stdcall; +begin + result := TPaxCompiler(HCompiler).Compile(TPaxProgram(HProgram)); +end; + +function PaxCompiler_GetErrorCount(HCompiler: Integer): Integer; stdcall; +begin + result := TPaxCompiler(HCompiler).ErrorCount; +end; + +function PaxCompiler_GetErrorMessage(HCompiler, I: Integer): PChar; stdcall; +begin + result := PChar(TPaxCompiler(HCompiler).ErrorMessage[I]); +end; + +function PaxCompiler_GetErrorModuleName(HCompiler, I: Integer): PChar; stdcall; +begin + result := PChar(TPaxCompiler(HCompiler).ErrorModuleName[I]); +end; + +function PaxCompiler_GetErrorLine(HCompiler, I: Integer): PChar; stdcall; +begin + result := PChar(TPaxCompiler(HCompiler).ErrorLine[I]); +end; + +function PaxCompiler_GetErrorLineNumber(HCompiler, I: Integer): Integer; stdcall; +begin + result := TPaxCompiler(HCompiler).ErrorLineNumber[I]; +end; + +/////////////////////// PaxProgram ///////////////////////////////////////////// + +function PaxProgram_Create: Integer; stdcall; +begin + result := Integer(TPaxProgram.Create(nil)); +end; + +procedure PaxProgram_Destroy(HProgram: Integer); stdcall; +begin + TPaxProgram(HProgram).Free; +end; + +procedure PaxProgram_Run(HProgram: Integer); stdcall; +begin + TPaxProgram(HProgram).Run; +end; + +procedure PaxProgram_SaveToFile(HProgram: Integer; Path: PChar); stdcall; +begin + TPaxProgram(HProgram).SaveToFile(Path); +end; + +procedure PaxProgram_LoadFromFile(HProgram: Integer; Path: PChar); stdcall; +begin + TPaxProgram(HProgram).LoadFromFile(Path); +end; + +function PaxProgram_GetAddress(HProgram: Integer; Handle: Integer): Pointer; stdcall; +begin + result := TPaxProgram(HProgram).GetAddress(Handle); +end; + +procedure PaxProgram_SetAddress(HProgram, Handle: Integer; P: Pointer); stdcall; +begin + TPaxProgram(HProgram).SetAddress(Handle, P); +end; + +function PaxProgram_GetDataPtr(HProgram: Integer): Pointer; stdcall; +begin + result := TPaxProgram(HProgram).DataPtr; +end; + +function PaxProgram_GetCodePtr(HProgram: Integer): Pointer; stdcall; +begin + result := TPaxProgram(HProgram).CodePtr; +end; + +/////////////////////// PaxPascalLanguage ////////////////////////////////////// + +function PaxPascalLanguage_Create: Integer; stdcall; +var + L: TPaxPascalLanguage; +begin + L := TPaxPascalLanguage.Create(nil); + result := Integer(L); +end; + +procedure PaxPascalLanguage_Destroy(HPaxPascalLanguage: Integer); stdcall; +begin + TPaxPascalLanguage(HPaxPascalLanguage).Free; +end; + +procedure PaxPascalLanguage_SetCallConv(HPaxPascalLanguage: Integer; cc: Integer); stdcall; +begin + TPaxPascalLanguage(HPaxPascalLanguage).SetCallConv(cc); +end; + +exports //////////////////////////////////////////////////////////////////////// + + PaxCompiler_Create, + PaxCompiler_Destroy, + PaxCompiler_Reset, + PaxCompiler_AddModule, + PaxCompiler_AddCode, + PaxCompiler_AddCodeFromFile, + PaxCompiler_RegisterLanguage, + PaxCompiler_RegisterNamespace, + PaxCompiler_RegisterRecordType, + PaxCompiler_RegisterRecordTypeField, + PaxCompiler_RegisterSubrangeType, + PaxCompiler_RegisterArrayType, + PaxCompiler_RegisterPointerType, + PaxCompiler_RegisterSetType, + PaxCompiler_RegisterProceduralType, + PaxCompiler_RegisterVariable, + PaxCompiler_RegisterRoutine, + PaxCompiler_RegisterRoutineEx, + PaxCompiler_RegisterParameter, + PaxCompiler_RegisterClassType, + PaxCompiler_RegisterHeader, + PaxCompiler_GetHandle, + PaxCompiler_Compile, + PaxCompiler_GetErrorCount, + PaxCompiler_GetErrorMessage, + PaxCompiler_GetErrorModuleName, + PaxCompiler_GetErrorLine, + PaxCompiler_GetErrorLineNumber, + + PaxProgram_Create, + PaxProgram_Destroy, + PaxProgram_Run, + PaxProgram_SaveToFile, + PaxProgram_LoadFromFile, + PaxProgram_GetAddress, + PaxProgram_SetAddress, + PaxProgram_GetDataPtr, + PaxProgram_GetCodePtr, + + PaxPascalLanguage_Create, + PaxPascalLanguage_Destroy, + PaxPascalLanguage_SetCallConv; +begin +end. diff --git a/Sources/PaxCompilerRegister.pas b/Sources/PaxCompilerRegister.pas new file mode 100644 index 0000000..d127c26 --- /dev/null +++ b/Sources/PaxCompilerRegister.pas @@ -0,0 +1,52 @@ +//////////////////////////////////////////////////////////////////////////// +// PaxCompiler +// Site: http://www.paxcompiler.com +// Author: Alexander Baranovsky (paxscript@gmail.com) +// ======================================================================== +// Copyright (c) Alexander Baranovsky, 2006-2014. All rights reserved. +// Code Version: 4.2 +// ======================================================================== +// Unit: PaxCompilerRegister.pas +// ======================================================================== +//////////////////////////////////////////////////////////////////////////// + +{$I PaxCompiler.def} +unit PaxCompilerRegister; + +interface +uses + Classes, + PaxCompiler, +{$IFNDEF INTERPRETER_ONLY} + PaxProgram, + PaxInvoke, +{$ENDIF} + PaxInterpreter, + PaxCompilerDebugger, + PaxCompilerExplorer, + PaxBasicLanguage, + PaxJavaScriptLanguage, + PaxEval; + +procedure Register; + +Implementation + +procedure Register; +begin + RegisterComponents('PaxCompiler', + [TPaxCompiler, + TPaxPascalLanguage, +{$IFNDEF INTERPRETER_ONLY} + TPaxProgram, + TPaxInvoke, +{$ENDIF} + TPaxCompilerDebugger, + TPaxCompilerExplorer, + TPaxBasicLanguage, + TPaxJavaScriptLanguage, + TPaxEval, + TPaxInterpreter]); +end; + +end. diff --git a/Sources/PaxCompiler_D11.res b/Sources/PaxCompiler_D11.res new file mode 100644 index 0000000..9f99f5d Binary files /dev/null and b/Sources/PaxCompiler_D11.res differ diff --git a/Sources/PaxCompiler_D11_Icon.ico b/Sources/PaxCompiler_D11_Icon.ico new file mode 100644 index 0000000..379ec80 Binary files /dev/null and b/Sources/PaxCompiler_D11_Icon.ico differ diff --git a/Sources/PaxCompiler_D12.dpk b/Sources/PaxCompiler_D12.dpk new file mode 100644 index 0000000..c613d6a --- /dev/null +++ b/Sources/PaxCompiler_D12.dpk @@ -0,0 +1,39 @@ +package PaxCompiler_D12; + +{$R *.res} +{$R 'paxcompiler.dcr'} +{$IFDEF IMPLICITBUILDING This IFDEF should not be used by users} +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO OFF} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS OFF} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO OFF} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$DEFINE RELEASE} +{$ENDIF IMPLICITBUILDING} +{$IMPLICITBUILD ON} + +requires + rtl, + vcl, + soaprtl; + +contains + PaxCompilerRegister in 'PaxCompilerRegister.pas'; + +end. diff --git a/Sources/PaxCompiler_D12.dproj b/Sources/PaxCompiler_D12.dproj new file mode 100644 index 0000000..a32fbdb --- /dev/null +++ b/Sources/PaxCompiler_D12.dproj @@ -0,0 +1,1022 @@ + + + {2A35E6B4-ABED-4AA8-A7A1-AE93BAEF0AE8} + PaxCompiler_D12.dpk + True + Release + 3 + Package + VCL + 20.1 + Win32 + + + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Cfg_1 + true + true + + + true + Cfg_1 + true + true + + + true + Base + true + + + true + Cfg_2 + true + true + + + false + false + false + false + false + 00400000 + true + true + PaxCompiler_D12 + 1 + Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;System;Xml;Data;Datasnap;Web;Soap;DUnitX.Loggers.GUI;$(DCC_Namespace) + 9242 + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=;CFBundleName= + .\$(Platform)\$(Config) + .\$(Platform)\$(Config) + + + Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) + Debug + true + CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(MSBuildProjectName) + 1033 + PaxCompiler_D11_Icon.ico + vcl;rtl;soaprtl;$(DCC_UsePackage) + + + PaxCompiler_D11_Icon.ico + Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;$(DCC_Namespace) + Debug + true + CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProgramID=com.embarcadero.$(MSBuildProjectName);ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments= + 1033 + vcl;rtl;soaprtl;$(DCC_UsePackage) + + + RELEASE;$(DCC_Define) + 0 + false + 0 + + + true + 1033 + CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(MSBuildProjectName) + + + true + 1033 + CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProgramID=com.embarcadero.$(MSBuildProjectName);ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments= + + + DEBUG;$(DCC_Define) + false + true + true + true + + + true + 1033 + CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(MSBuildProjectName) + + + + MainSource + + + + + + + + Base + + + Cfg_1 + Base + + + Cfg_2 + Base + + + + Delphi.Personality.12 + Package + + + + PaxCompiler_D12.dpk + + + Microsoft Office 2000 Sample Automation Server Wrapper Components + Microsoft Office XP Sample Automation Server Wrapper Components + + + + True + True + + + + + PaxCompiler_D12.bpl + true + + + + + PaxCompiler_D12.bpl + true + + + + + 1 + + + 0 + + + + + classes + 64 + + + classes + 64 + + + + + res\xml + 1 + + + res\xml + 1 + + + + + library\lib\armeabi + 1 + + + library\lib\armeabi + 1 + + + + + library\lib\armeabi-v7a + 1 + + + + + library\lib\mips + 1 + + + library\lib\mips + 1 + + + + + library\lib\armeabi-v7a + 1 + + + library\lib\arm64-v8a + 1 + + + + + library\lib\armeabi-v7a + 1 + + + + + res\drawable + 1 + + + res\drawable + 1 + + + + + res\drawable-anydpi-v21 + 1 + + + res\drawable-anydpi-v21 + 1 + + + + + res\values + 1 + + + res\values + 1 + + + + + res\values-v21 + 1 + + + res\values-v21 + 1 + + + + + res\values-v31 + 1 + + + res\values-v31 + 1 + + + + + res\drawable-anydpi-v26 + 1 + + + res\drawable-anydpi-v26 + 1 + + + + + res\drawable + 1 + + + res\drawable + 1 + + + + + res\drawable + 1 + + + res\drawable + 1 + + + + + res\drawable + 1 + + + res\drawable + 1 + + + + + res\drawable-anydpi-v33 + 1 + + + res\drawable-anydpi-v33 + 1 + + + + + res\values + 1 + + + res\values + 1 + + + + + res\values-night-v21 + 1 + + + res\values-night-v21 + 1 + + + + + res\drawable + 1 + + + res\drawable + 1 + + + + + res\drawable-xxhdpi + 1 + + + res\drawable-xxhdpi + 1 + + + + + res\drawable-xxxhdpi + 1 + + + res\drawable-xxxhdpi + 1 + + + + + res\drawable-ldpi + 1 + + + res\drawable-ldpi + 1 + + + + + res\drawable-mdpi + 1 + + + res\drawable-mdpi + 1 + + + + + res\drawable-hdpi + 1 + + + res\drawable-hdpi + 1 + + + + + res\drawable-xhdpi + 1 + + + res\drawable-xhdpi + 1 + + + + + res\drawable-mdpi + 1 + + + res\drawable-mdpi + 1 + + + + + res\drawable-hdpi + 1 + + + res\drawable-hdpi + 1 + + + + + res\drawable-xhdpi + 1 + + + res\drawable-xhdpi + 1 + + + + + res\drawable-xxhdpi + 1 + + + res\drawable-xxhdpi + 1 + + + + + res\drawable-xxxhdpi + 1 + + + res\drawable-xxxhdpi + 1 + + + + + res\drawable-small + 1 + + + res\drawable-small + 1 + + + + + res\drawable-normal + 1 + + + res\drawable-normal + 1 + + + + + res\drawable-large + 1 + + + res\drawable-large + 1 + + + + + res\drawable-xlarge + 1 + + + res\drawable-xlarge + 1 + + + + + res\values + 1 + + + res\values + 1 + + + + + res\drawable-anydpi-v24 + 1 + + + res\drawable-anydpi-v24 + 1 + + + + + res\drawable + 1 + + + res\drawable + 1 + + + + + res\drawable-night-anydpi-v21 + 1 + + + res\drawable-night-anydpi-v21 + 1 + + + + + res\drawable-anydpi-v31 + 1 + + + res\drawable-anydpi-v31 + 1 + + + + + res\drawable-night-anydpi-v31 + 1 + + + res\drawable-night-anydpi-v31 + 1 + + + + + 1 + + + 1 + + + 0 + + + + + 1 + .framework + + + 1 + .framework + + + 1 + .framework + + + 0 + + + + + 1 + .dylib + + + 1 + .dylib + + + 1 + .dylib + + + 0 + .dll;.bpl + + + + + 1 + .dylib + + + 1 + .dylib + + + 1 + .dylib + + + 1 + .dylib + + + 1 + .dylib + + + 1 + .dylib + + + 0 + .bpl + + + + + 0 + + + 0 + + + 0 + + + 0 + + + 0 + + + 0 + + + 0 + + + 0 + + + 0 + + + + + 1 + + + 1 + + + + + + + + Contents\Resources + 1 + + + Contents\Resources + 1 + + + Contents\Resources + 1 + + + + + library\lib\armeabi-v7a + 1 + + + library\lib\arm64-v8a + 1 + + + 1 + + + 1 + + + 1 + + + 1 + + + 1 + + + 1 + + + 1 + + + 0 + + + + + library\lib\armeabi-v7a + 1 + + + + + 1 + + + 1 + + + + + ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF + 1 + + + ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF + 1 + + + ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF + 1 + + + + + + + + 1 + + + 1 + + + 1 + + + + + Assets + 1 + + + Assets + 1 + + + + + Assets + 1 + + + Assets + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + + + + + + + + + + + + + + + + 12 + + + + + diff --git a/Sources/PaxCompiler_D12.res b/Sources/PaxCompiler_D12.res new file mode 100644 index 0000000..d3670e0 Binary files /dev/null and b/Sources/PaxCompiler_D12.res differ diff --git a/Sources/PaxCompiler_D7.dpk b/Sources/PaxCompiler_D7.dpk new file mode 100644 index 0000000..b3f47ec --- /dev/null +++ b/Sources/PaxCompiler_D7.dpk @@ -0,0 +1,35 @@ +package PaxCompiler_D7; + +{$R *.res} +{$R 'paxcompiler.dcr'} +{$ALIGN 8} +{$ASSERTIONS OFF} +{$BOOLEVAL OFF} +{$DEBUGINFO OFF} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS OFF} +{$LOCALSYMBOLS OFF} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION OFF} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO OFF} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$IMPLICITBUILD OFF} + +requires + rtl, + vcl; + +contains + PaxCompilerRegister in 'PaxCompilerRegister.pas'; + +end. diff --git a/Sources/PaxCompiler_D7.res b/Sources/PaxCompiler_D7.res new file mode 100644 index 0000000..22d2d27 Binary files /dev/null and b/Sources/PaxCompiler_D7.res differ diff --git a/Sources/PaxCompiler_d5.dpk b/Sources/PaxCompiler_d5.dpk new file mode 100644 index 0000000..9a5b845 --- /dev/null +++ b/Sources/PaxCompiler_d5.dpk @@ -0,0 +1,34 @@ +package PaxCompiler_d5; + +{$R *.RES} +{$R 'paxcompiler.dcr'} +{$ALIGN ON} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$IMPLICITBUILD OFF} + +requires + vcl50; + +contains + PaxCompilerRegister in 'PaxCompilerRegister.pas'; + +end. diff --git a/Sources/PaxCompiler_d6.dpk b/Sources/PaxCompiler_d6.dpk new file mode 100644 index 0000000..e7a040b --- /dev/null +++ b/Sources/PaxCompiler_d6.dpk @@ -0,0 +1,35 @@ +package PaxCompiler_d6; + +{$R *.res} +{$R 'paxcompiler.dcr'} +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$IMPLICITBUILD OFF} + +requires + rtl, + vcl; + +contains + PaxCompilerRegister in 'PaxCompilerRegister.pas'; + +end. diff --git a/Sources/PaxCompiler_d6.res b/Sources/PaxCompiler_d6.res new file mode 100644 index 0000000..45d3fb2 Binary files /dev/null and b/Sources/PaxCompiler_d6.res differ diff --git a/Sources/PaxDllImport.pas b/Sources/PaxDllImport.pas new file mode 100644 index 0000000..429875a --- /dev/null +++ b/Sources/PaxDllImport.pas @@ -0,0 +1,133 @@ +//////////////////////////////////////////////////////////////////////////// +// PaxCompiler +// Site: http://www.paxcompiler.com +// Author: Alexander Baranovsky (paxscript@gmail.com) +// ======================================================================== +// Copyright (c) Alexander Baranovsky, 2006-2014. All rights reserved. +// Code Version: 4.2 +// ======================================================================== +// Unit: PaxRegister.pas +// ======================================================================== +//////////////////////////////////////////////////////////////////////////// + +{$I PaxCompiler.def} + +unit PaxDllImport; + +interface + +uses {$I uses.def} + TypInfo; + +type + TRegisterNamespace = function (LevelId: Integer; const Name: String): Integer; + TRegisterConstant = function(LevelId: Integer; const Name: String; + const Value: Variant): Integer; + TRegisterVariable = function(LevelId: Integer; + const Name: String; TypeId: Integer; + Address: Pointer): Integer; + TRegisterHeader = function(LevelId: Integer; + const Header: String; Address: Pointer; + MethodIndex: Integer = 0; Visibility: Integer = 0): Integer; + TRegisterProperty = function(LevelId: Integer; const Header: String): Integer; + + TRegisterClassType = function(LevelId: Integer; C: TClass; + DoRegisterClass: Boolean = false): Integer; + + TRegisterClassReferenceType = function(LevelID: Integer; + const TypeName, OriginalTypeName: String): Integer; + TRegisterClassTypeField = function(TypeId: Integer; const Declaration: String): Integer; + + TRegisterRecordType = function(LevelId: Integer; + const TypeName: String; + IsPacked: Boolean = false): Integer; + TRegisterRecordTypeField = function(TypeId: Integer; const Declaration: String): Integer; + TRegisterVariantRecordTypeField = function(LevelId: Integer; const Declaration: String; + VarCount: Int64): Integer; + + TRegisterEnumType = function(LevelId: Integer; + const TypeName: String; + TypeBaseId: Integer = 7): Integer; + TRegisterEnumValue = function(EnumTypeId: Integer; + const FieldName: String; + const Value: Integer): Integer; + + TRegisterSubrangeType = function(LevelId: Integer; + const TypeName: String; + TypeBaseId: Integer; + B1, B2: Integer): Integer; + + TRegisterArrayType = function(LevelId: Integer; + const TypeName: String; + RangeTypeId, ElemTypeId: Integer; + IsPacked: Boolean = false): Integer; + TRegisterDynamicArrayType = function(LevelId: Integer; + const TypeName: String; + ElemTypeId: Integer): Integer; + + TRegisterPointerType = function(LevelId: Integer; + const TypeName: String; + OriginTypeId: Integer; + const OrginTypeName: String = ''): Integer; + TRegisterSetType = function(LevelId: Integer; + const TypeName: String; + OriginTypeId: Integer): Integer; + + TRegisterProceduralType = function(LevelId: Integer; + const TypeName: String; + SubId: Integer): Integer; + + TRegisterEventType = function(LevelId: Integer; + const TypeName: String; + SubId: Integer): Integer; + + TRegisterShortStringType = function(LevelId: Integer; + const TypeName: String; + L: Integer): Integer; + + TRegisterInterfaceType = function(LevelId: Integer; + const TypeName: String; + const GUID: TGUID; + const ParentName: String; + const ParentGUID: TGUID): Integer; + + TRegisterRTTIType = function(LevelId: Integer; + pti: PTypeInfo): Integer; + + TRegisterTypeAlias = function(LevelId:Integer; + const TypeName: String; + OriginTypeId: Integer): Integer; + + TRegisterProcRec = record + RegisterNamespace: TRegisterNamespace; + RegisterConstant: TRegisterConstant; + RegisterVariable: TRegisterVariable; + RegisterHeader: TRegisterHeader; + RegisterProperty: TRegisterProperty; + RegisterClassType: TRegisterClassType; + RegisterClassTypeField: TRegisterClassTypeField; + RegisterClassReferenceType: TRegisterClassReferenceType; + RegisterRecordType: TRegisterRecordType; + RegisterRecordTypeField: TRegisterRecordTypeField; + RegisterVariantRecordTypeField: TRegisterVariantRecordTypeField; + RegisterEnumType: TRegisterEnumType; + RegisterEnumValue: TRegisterEnumValue; + RegisterSubrangeType: TRegisterSubrangeType; + RegisterArrayType: TRegisterArrayType; + RegisterDynamicArrayType: TRegisterDynamicArrayType; + RegisterPointerType: TRegisterPointerType; + RegisterSetType: TRegisterSetType; + RegisterProceduralType: TRegisterProceduralType; + RegisterEventType: TRegisterEventType; + RegisterShortStringType: TRegisterShortStringType; + RegisterInterfaceType: TRegisterInterfaceType; + RegisterRTTIType: TRegisterRTTIType; + RegisterTypeAlias: TRegisterTypeAlias; + end; + + TRegisterDllProc = procedure (R: TRegisterProcRec); + +implementation + +end. + diff --git a/Sources/PaxEval.pas b/Sources/PaxEval.pas new file mode 100644 index 0000000..4cd14d8 --- /dev/null +++ b/Sources/PaxEval.pas @@ -0,0 +1,271 @@ +//////////////////////////////////////////////////////////////////////////// +// PaxInvoke +// Site: http://www.paxcompiler.com +// Author: Alexander Baranovsky (paxscript@gmail.com) +// ======================================================================== +// Copyright (c) Alexander Baranovsky, 2006-2014. All rights reserved. +// Code Version: 4.2 +// ======================================================================== +// Unit: PaxInvoke.pas +// Implements dynamically invoke of a global function or a method of object +// ======================================================================== +//////////////////////////////////////////////////////////////////////////// + +{$I PaxCompiler.def} +{$O-} +unit PaxEval; +interface +uses {$I uses.def} + Classes, + SysUtils, + PAXCOMP_CONSTANTS, + PAXCOMP_TYPES, + PAXCOMP_SYS, + PAXCOMP_EVAL, + PAXCOMP_BASERUNNER, + PaxCompiler, + PaxRunner; +type + TPaxEval = class(TComponent) + private + fEval: TEval; + function GetResultAsString: String; + function GetResultAddress: Pointer; + function GetResultTypeName: String; + function GetResultTypeId: Integer; + function GetHasErrors: Boolean; + function GetValid: Boolean; + function GetErrorCount: Integer; + function GetErrorMessage(I: Integer): String; + + function GetOnUnhandledException: TPaxErrNotifyEvent; + procedure SetOnUnhandledException(value: TPaxErrNotifyEvent); + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + procedure Reset; + procedure RegisterCompiler(ACompiler: TPaxCompiler; + AProgram: TPaxRunner); + procedure AddNamespace(const NamespaceName: String); + procedure CompileExpression(const Source: String); + procedure CompileProgram(const Source: String); + procedure Run; + + function GetEvalKernelPtr: Pointer; + property Valid: Boolean read GetValid; + property ResultAsString: String read GetResultAsString; + property ResultAddress: Pointer read GetResultAddress; + property ResultTypeName: String read GetResultTypeName; + property ResultTypeId: Integer read GetResultTypeId; + property HasErrors: Boolean read GetHasErrors; + property ErrorCount: Integer read GetErrorCount; + property ErrorMessage[I: Integer]: String read GetErrorMessage; + property OnUnhandledException: TPaxErrNotifyEvent read GetOnUnhandledException + write SetOnUnhandledException; + end; + +function EvalExpression(const Source: String; + ACompiler: TPaxCompiler; + AProgram: TPaxRunner): String; overload; + +function EvalExpression(const Source: String; const Language: String = ''): String; overload; + + +procedure EvalProgram(const Source: String; + ACompiler: TPaxCompiler; + AProgram: TPaxRunner); + +implementation + +uses + PaxBasicLanguage, PaxJavaScriptLanguage; + +constructor TPaxEval.Create(AOwner: TComponent); +begin + inherited; + fEval := TEval.Create; +end; + +destructor TPaxEval.Destroy; +begin + FreeAndNil(fEval); + inherited; +end; + +procedure TPaxEval.Reset; +begin + fEval.Reset; +end; + +procedure TPaxEval.RegisterCompiler(ACompiler: TPaxCompiler; + AProgram: TPaxRunner); +var + N: Integer; +begin + if AProgram.IsPaused then + N := AProgram.GetProgPtr.CurrN + else + N := -1; + fEval.Init(ACompiler.GetKernelPtr, AProgram.GetProgPtr, N); +end; + +function TPaxEval.GetValid: Boolean; +begin + result := fEval.Valid; +end; + +procedure TPaxEval.CompileExpression(const Source: String); +begin + fEval.CompileExpression(Source); +end; + +procedure TPaxEval.CompileProgram(const Source: String); +begin + fEval.CompileProgram(Source); +end; + +procedure TPaxEval.Run; +begin + fEval.Run; +end; + +function TPaxEval.GetResultAsString: String; +begin + result := fEval.GetResultAsString; +end; + +function TPaxEval.GetResultAddress: Pointer; +begin + result := fEval.GetResultAddress; +end; + +function TPaxEval.GetResultTypeName: String; +begin + result := fEval.GetResultTypeName; +end; + +function TPaxEval.GetResultTypeId: Integer; +begin + result := fEval.GetResultTypeId; +end; + +function TPaxEval.GetHasErrors: Boolean; +begin + result := fEval.HasErrors; +end; + +function TPaxEval.GetErrorCount: Integer; +begin + result := fEval.GetErrorCount; +end; + +function TPaxEval.GetErrorMessage(I: Integer): String; +begin + result := fEval.GetErrorMessage(I); +end; + +function TPaxEval.GetEvalKernelPtr: Pointer; +begin + result := fEval.EKernel; +end; + +function TPaxEval.GetOnUnhandledException: TPaxErrNotifyEvent; +begin + result := TPaxErrNotifyEvent(TBaseRunner(fEval.EProg).OnUnhandledException); +end; + +procedure TPaxEval.SetOnUnhandledException(value: TPaxErrNotifyEvent); +begin + TBaseRunner(fEval.EProg).OnUnhandledException := TErrNotifyEvent(value); +end; + +procedure TPaxEval.AddNamespace(const NamespaceName: String); +begin + fEval.NamespaceList.Add(NamespaceName); +end; + +function EvalExpression(const Source: String; + ACompiler: TPaxCompiler; + AProgram: TPaxRunner): String; +var + Eval: TPaxEval; +begin + Eval := TPaxEval.Create(nil); + try + Eval.RegisterCompiler(ACompiler, AProgram); + Eval.CompileExpression(Source); + + if Eval.HasErrors then + raise PaxCompilerException.Create(Eval.GetErrorMessage(0)); + + Eval.Run; + + result := Eval.GetResultAsString; + finally + FreeAndNil(Eval); + end; +end; + +function EvalExpression(const Source: String; const Language: String = ''): String; +var + Eval: TPaxEval; + ACompiler: TPaxCompiler; + AProgram: TPaxRunner; + ALanguage: TPaxCompilerLanguage; +begin + ACompiler := TPaxCompiler.Create(nil); + AProgram := TPaxRunner.Create(nil); + if (Language = '') or StrEql(Language, 'Pascal') then + ALanguage := TPaxPascalLanguage.Create(nil) + else if StrEql(Language, 'Basic') then + ALanguage := TPaxBasicLanguage.Create(nil) + else if StrEql(Language, 'JavaScript') then + ALanguage := TPaxJavaScriptLanguage.Create(nil) + else + raise Exception.Create(Format(errUnknownLanguage, [Language])); + Eval := TPaxEval.Create(nil); + try + ACompiler.RegisterLanguage(ALanguage); + ACompiler.AddModule('1', ALanguage.LanguageName); + ACompiler.Compile(AProgram); + + Eval.RegisterCompiler(ACompiler, AProgram); + Eval.CompileExpression(Source); + + if Eval.HasErrors then + raise PaxCompilerException.Create(Eval.GetErrorMessage(0)); + + Eval.Run; + + result := Eval.GetResultAsString; + finally + FreeAndNil(Eval); + FreeAndNil(ALanguage); + FreeAndNil(ACompiler); + FreeAndNil(AProgram); + end; +end; + +procedure EvalProgram(const Source: String; + ACompiler: TPaxCompiler; + AProgram: TPaxRunner); +var + Eval: TPaxEval; +begin + Eval := TPaxEval.Create(nil); + try + Eval.RegisterCompiler(ACompiler, AProgram); + Eval.CompileProgram(Source); + + if Eval.HasErrors then + raise PaxCompilerException.Create(Eval.GetErrorMessage(0)); + + Eval.Run; + finally + FreeAndNil(Eval); + end; +end; + + + +end. diff --git a/Sources/PaxInfos.pas b/Sources/PaxInfos.pas new file mode 100644 index 0000000..b4c956a --- /dev/null +++ b/Sources/PaxInfos.pas @@ -0,0 +1,51 @@ +////////////////////////////////////////////////////////////////////////// +// PaxCompiler +// Site: http://www.paxcompiler.com +// Author: Alexander Baranovsky (paxscript@gmail.com) +// ======================================================================== +// Copyright (c) Alexander Baranovsky, 2006-2014. All rights reserved. +// Code Version: 4.2 +// ======================================================================== +// Unit: PaxInfos.pas +// ======================================================================== +//////////////////////////////////////////////////////////////////////////// + +{$I PaxCompiler.def} +unit PaxInfos; +interface +uses {$I uses.def} + TypInfo; +type +{$IFNDEF UNIC} + TMemberVisibility = (mvPrivate, mvProtected, mvPublic, mvPublished); +{$ENDIF} + + TPrintClassTypeFieldInfo = record + Owner: TObject; + FieldIndex: Integer; + FieldCount: Integer; + Address: Pointer; + FieldName: String; + TypeId: Integer; + FieldTypeName: String; + Started: Boolean; + Finished: Boolean; + Visibility: TMemberVisibility; + Host: Boolean; + end; + + TPrintClassTypePropInfo = record + Owner: TObject; + PropIndex: Integer; + PropCount: Integer; + StrValue: String; + PropName: String; + PropTypeName: String; + Started: Boolean; + Finished: Boolean; + Visibility: TMemberVisibility; + Host: Boolean; + end; + +implementation +end. diff --git a/Sources/PaxInterpreter.pas b/Sources/PaxInterpreter.pas new file mode 100644 index 0000000..80d6779 --- /dev/null +++ b/Sources/PaxInterpreter.pas @@ -0,0 +1,47 @@ +//////////////////////////////////////////////////////////////////////////// +// PaxCompiler +// Site: http://www.paxcompiler.com +// Author: Alexander Baranovsky (paxscript@gmail.com) +// ======================================================================== +// Copyright (c) Alexander Baranovsky, 2006-2014. All rights reserved. +// Code Version: 4.2 +// ======================================================================== +// Unit: PaxInterpreter.pas +// ======================================================================== +//////////////////////////////////////////////////////////////////////////// + +{$I PaxCompiler.def} +unit PaxInterpreter; +interface +uses + Classes, + PAXCOMP_BASERUNNER, + PAXINT_RUNNER, + PAXINT_CRT, + PaxRunner; +type + TPaxInterpreter = class(TPaxRunner) + protected + function GetRunnerClass: TBaseRunnerClass; override; + public + constructor Create(AOwner: TComponent); override; + end; + +implementation + +constructor TPaxInterpreter.Create(AOwner: TComponent); +begin + inherited; +{$IFDEF FPC} + EmitProc := @ EmitInterProc; +{$ELSE} + EmitProc := EmitInterProc; +{$ENDIF} +end; + +function TPaxInterpreter.GetRunnerClass: TBaseRunnerClass; +begin + result := TIRunner; +end; + +end. diff --git a/Sources/PaxInvoke.pas b/Sources/PaxInvoke.pas new file mode 100644 index 0000000..3bd5981 --- /dev/null +++ b/Sources/PaxInvoke.pas @@ -0,0 +1,873 @@ +//////////////////////////////////////////////////////////////////////////// +// PaxInvoke +// Site: http://www.paxcompiler.com +// Author: Alexander Baranovsky (paxscript@gmail.com) +// ======================================================================== +// Copyright (c) Alexander Baranovsky, 2006-2014. All rights reserved. +// Code Version: 4.2 +// ======================================================================== +// Unit: PaxInvoke.pas +// Implements dynamically invoke of a global function or a method of object +// ======================================================================== +//////////////////////////////////////////////////////////////////////////// + +{$I PaxCompiler.def} +{$O-} +unit PaxInvoke; +interface +{$IFDEF PAXARM_DEVICE} +implementation +end. +{$ENDIF} +uses + Classes, + SysUtils, + PAXCOMP_CONSTANTS, + PAXCOMP_SYS, + PAXCOMP_INVOKE; +const + __ccSTDCALL = 1; + __ccREGISTER = 2; + __ccCDECL = 3; + __ccPASCAL = 4; + __ccSAFECALL = 5; + __ccMSFASTCALL = 6; +type + TPaxInvoke = class(TComponent) + private + function GetAddr: Pointer; + procedure SetAddr(value: Pointer); + procedure SetCallConv(value: Integer); + function GetCallConv: Integer; + function GetThis: Pointer; + procedure SetThis(value: Pointer); + function GetFake: Boolean; + procedure SetFake(value: Boolean); + public +{$IFNDEF PAXARM_DEVICE} + base_invoke: TInvoke; +{$ENDIF} + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + + procedure LoadAddress(const DllName, ProcName: String); + + procedure ClearArguments; + + procedure AddArgAsByte(value: Byte); + procedure AddArgAsWord(value: Word); + procedure AddArgAsCardinal(value: Cardinal); + procedure AddArgAsShortInt(value: ShortInt); + procedure AddArgAsSmallInt(value: SmallInt); + procedure AddArgAsInteger(value: Integer); + procedure AddArgAsInt64(value: Int64); + procedure AddArgAsUInt64(value: UInt64); + procedure AddArgAsBoolean(value: Boolean); + procedure AddArgAsWordBool(value: WordBool); + procedure AddArgAsLongBool(value: LongBool); + procedure AddArgAsChar(value: Char); + procedure AddArgAsWideChar(value: WideChar); + procedure AddArgAsDouble(value: Double); + procedure AddArgAsSingle(value: Single); + procedure AddArgAsExtended(value: Extended); + procedure AddArgAsCurrency(value: Currency); +{$IFNDEF PAXARM} + procedure AddArgAsAnsiString(const value: AnsiString); + procedure AddArgAsWideString(const value: WideString); + procedure AddArgAsShortString(const value: ShortString); + procedure AddArgAsPAnsiChar(value: PAnsiChar); +{$ENDIF} + procedure AddArgAsString(const value: String); +{$IFDEF UNIC} + procedure AddArgAsUnicString(const value: UnicodeString); +{$ENDIF} + procedure AddArgAsPChar(value: PChar); + procedure AddArgAsPWideChar(value: PWideChar); + procedure AddArgAsPointer(value: Pointer); + procedure AddArgAsRecord(pvalue: Pointer; Size: Integer); + procedure AddArgAsRecordByVal(var value; Size: Integer); + procedure AddArgAsArray(pvalue: Pointer; Size: Integer); + procedure AddArgAsArrayByVal(var value; Size: Integer); + procedure AddArgAsEvent(var value); + procedure AddArgAsDynArray(var value); + procedure AddArgAsObject(value: TObject); + procedure AddArgAsClassRef(value: TClass); + procedure AddArgAsVariant(const value: Variant); + procedure AddArgAsSet(pvalue: Pointer; Size: Integer); + procedure AddArgAsInterface(const value: IUnknown); + + procedure SetResultAsVoid; + procedure SetResultAsByte; + procedure SetResultAsWord; + procedure SetResultAsCardinal; + procedure SetResultAsShortInt; + procedure SetResultAsSmallInt; + procedure SetResultAsInteger; + procedure SetResultAsBoolean; + procedure SetResultAsWordBool; + procedure SetResultAsLongBool; + procedure SetResultAsChar; + procedure SetResultAsWideChar; + procedure SetResultAsDouble; + procedure SetResultAsSingle; + procedure SetResultAsExtended; + procedure SetResultAsCurrency; + procedure SetResultAsString(ResAddress: Pointer = nil); + procedure SetResultAsUnicodeString(ResAddress: Pointer = nil); +{$IFNDEF PAXARM} + procedure SetResultAsAnsiChar; + procedure SetResultAsAnsiString(ResAddress: Pointer = nil); + procedure SetResultAsWideString(ResAddress: Pointer = nil); + procedure SetResultAsShortString(ResAddress: Pointer = nil); +{$ENDIF} + procedure SetResultAsPChar; + procedure SetResultAsPWideChar; + procedure SetResultAsPointer; + procedure SetResultAsVariant(ResAddress: Pointer = nil); + procedure SetResultAsArray(Size: Integer; + ResAddress: Pointer = nil); + procedure SetResultAsDynArray(ResAddress: Pointer = nil); + procedure SetResultAsRecord(Size: Integer; + ResAddress: Pointer = nil); + procedure SetResultAsSet(Size: Integer; + ResAddress: Pointer = nil); + procedure SetResultAsObject(ResAddress: Pointer = nil); + procedure SetResultAsClassRef; + procedure SetResultAsInterface(ResAddress: Pointer = nil); + procedure SetResultAsEvent(ResAddress: Pointer = nil); + procedure SetResultAsInt64; + procedure SetResultAsUInt64; + procedure CallHost; + function GetResultPtr: Pointer; + procedure ClearResult; + function GetImplementation: Pointer; + property Address: Pointer read GetAddr write SetAddr; + property CallConv: Integer read GetCallConv write SetCallConv; + property This: Pointer read GetThis write SetThis; + property Fake: Boolean read GetFake write SetFake; + end; + +implementation + +constructor TPaxInvoke.Create(AOwner: TComponent); +begin + inherited; + base_invoke := TInvoke.Create; +end; + +destructor TPaxInvoke.Destroy; +begin + FreeAndNil(base_invoke); + inherited; +end; + +function TPaxInvoke.GetAddr: Pointer; +begin + result := base_invoke.Address; +end; + +procedure TPaxInvoke.SetAddr(value: Pointer); +begin + base_invoke.Address := value; +end; + +procedure TPaxInvoke.LoadAddress(const DllName, ProcName: String); +begin + base_invoke.LoadAddress(DllName, ProcName); +end; + +procedure TPaxInvoke.ClearArguments; +begin + base_invoke.ClearArguments; +end; + +procedure TPaxInvoke.AddArgAsByte(value: Byte); +begin + base_invoke.AddArg(value, typeINTEGER); +end; + +procedure TPaxInvoke.AddArgAsWord(value: Word); +begin + base_invoke.AddArg(value, typeINTEGER); +end; + +procedure TPaxInvoke.AddArgAsCardinal(value: Cardinal); +begin +{$IFDEF VARIANTS} + base_invoke.AddArg(value, typeINTEGER); +{$ELSE} + base_invoke.AddArg(Integer(value), typeINTEGER); +{$ENDIF} +end; + +procedure TPaxInvoke.AddArgAsShortInt(value: ShortInt); +begin + base_invoke.AddArg(value, typeINTEGER); +end; + +procedure TPaxInvoke.AddArgAsSmallInt(value: SmallInt); +begin + base_invoke.AddArg(value, typeINTEGER); +end; + +procedure TPaxInvoke.AddArgAsInteger(value: Integer); +begin + base_invoke.AddArg(value, typeINTEGER); +end; + +procedure TPaxInvoke.AddArgAsInt64(value: Int64); +begin +{$IFDEF PAX64} + base_invoke.AddArg(value, typeINT64); +{$ELSE} + base_invoke.AddArgByVal(value, SizeOf(Int64)); +{$ENDIF} +end; + +procedure TPaxInvoke.AddArgAsUInt64(value: UInt64); +begin +{$IFDEF PAX64} + base_invoke.AddArg(value, typeINT64); +{$ELSE} + base_invoke.AddArgByVal(value, SizeOf(UInt64)); +{$ENDIF} +end; + +procedure TPaxInvoke.AddArgAsBoolean(value: Boolean); +begin + base_invoke.AddArg(Integer(value), typeINTEGER); +end; + +procedure TPaxInvoke.AddArgAsWordBool(value: WordBool); +begin + base_invoke.AddArg(Integer(value), typeINTEGER); +end; + +procedure TPaxInvoke.AddArgAsLongBool(value: LongBool); +begin + base_invoke.AddArg(Integer(value), typeINTEGER); +end; + +procedure TPaxInvoke.AddArgAsChar(value: Char); +begin + base_invoke.AddArg(Integer(value), typeINTEGER); +end; + +procedure TPaxInvoke.AddArgAsWideChar(value: WideChar); +begin + base_invoke.AddArg(Integer(value), typeINTEGER); +end; + +procedure TPaxInvoke.AddArgAsDouble(value: Double); +begin +{$IFDEF PAX64} + base_invoke.AddArg(value, typeDOUBLE); +{$ELSE} + base_invoke.AddArgByVal(value, SizeOf(Double)); +{$ENDIF} +end; + +procedure TPaxInvoke.AddArgAsSingle(value: Single); +begin +{$IFDEF PAX64} + base_invoke.AddArg(value, typeSINGLE); +{$ELSE} + base_invoke.AddArgByVal(value, SizeOf(Single)); +{$ENDIF} +end; + +procedure TPaxInvoke.AddArgAsExtended(value: Extended); +begin +{$IFDEF PAX64} + base_invoke.AddArg(value, typeEXTENDED); +{$ELSE} + base_invoke.AddArgByVal(value, SizeOf(Extended)); +{$ENDIF} +end; + +procedure TPaxInvoke.AddArgAsCurrency(value: Currency); +begin +{$IFDEF PAX64} + base_invoke.AddArg(value, typeCURRENCY); +{$ELSE} + base_invoke.AddArgByVal(value, SizeOf(Currency)); +{$ENDIF} +end; + +{$IFNDEF PAXARM} +procedure TPaxInvoke.AddArgAsPAnsiChar(value: PAnsiChar); +begin + base_invoke.AddArg(IntPax(value), typePOINTER); +end; +{$IFDEF PAX64} +procedure TPaxInvoke.AddArgAsAnsiString(const value: AnsiString); +begin + base_invoke.AddArg(IntPax(Pointer(value)), typeANSISTRING); +end; +{$ELSE} +procedure TPaxInvoke.AddArgAsAnsiString(const value: AnsiString); +begin + base_invoke.AddArg(Integer(value), typeINTEGER); +end; +{$ENDIF} + +{$IFDEF PAX64} +procedure TPaxInvoke.AddArgAsWideString(const value: WideString); +begin + base_invoke.AddArg(IntPax(Pointer(value)), typeWIDESTRING); +end; +{$ELSE} +procedure TPaxInvoke.AddArgAsWideString(const value: WideString); +begin + base_invoke.AddArg(Integer(value), typeINTEGER); +end; +{$ENDIF} + +procedure TPaxInvoke.AddArgAsShortString(const value: ShortString); +begin + base_invoke.AddArg(Integer(@value), typeINTEGER); +end; +{$ENDIF} + +{$IFDEF UNIC} +{$IFDEF PAX64} +procedure TPaxInvoke.AddArgAsUnicString(const value: UnicodeString); +begin + base_invoke.AddArg(IntPax(Pointer(value)), typeUNICSTRING); +end; +{$ELSE} +procedure TPaxInvoke.AddArgAsUnicString(const value: UnicodeString); +begin + base_invoke.AddArg(Integer(value), typeINTEGER); +end; +{$ENDIF} +{$ELSE} +{$ENDIF} + +{$IFDEF PAX64} +procedure TPaxInvoke.AddArgAsString(const value: String); +begin + base_invoke.AddArg(IntPax(Pointer(value)), typeUNICSTRING); +end; +{$ELSE} +procedure TPaxInvoke.AddArgAsString(const value: String); +begin + base_invoke.AddArg(Integer(value), typeINTEGER); +end; +{$ENDIF} + +procedure TPaxInvoke.AddArgAsPChar(value: PChar); +begin + base_invoke.AddArg(IntPax(value), typePOINTER); +end; + +procedure TPaxInvoke.AddArgAsPWideChar(value: PWideChar); +begin + base_invoke.AddArg(IntPax(value), typePOINTER); +end; + +procedure TPaxInvoke.AddArgAsPointer(value: Pointer); +begin + base_invoke.AddArg(IntPax(value), typePOINTER); +end; + +procedure TPaxInvoke.AddArgAsRecord(pvalue: Pointer; Size: Integer); +var + P: Pointer; +begin + if Size > SizeOf(IntPax) then + base_invoke.AddArg(IntPax(pvalue), typeINTEGER) + else + begin + Move(pvalue^, P, Size); + base_invoke.AddArg(IntPax(P), typeINTEGER); + end; +end; + +procedure TPaxInvoke.AddArgAsRecordByVal(var value; Size: Integer); +begin + base_invoke.AddArgByVal(value, Size); +end; + +procedure TPaxInvoke.AddArgAsArray(pvalue: Pointer; Size: Integer); +begin + if Size > SizeOf(IntPax) then + base_invoke.AddArg(IntPax(pvalue), typeINTEGER) + else + base_invoke.AddArg(IntPax(pvalue^), typeINTEGER); +end; + +procedure TPaxInvoke.AddArgAsArrayByVal(var value; Size: Integer); +begin + base_invoke.AddArgByVal(value, Size); +end; + +procedure TPaxInvoke.AddArgAsEvent(var value); +begin + base_invoke.AddArgByVal(value, SizeOf(TMethod)); +end; + +{$IFDEF PAX64} +procedure TPaxInvoke.AddArgAsDynArray(var value); +begin + base_invoke.AddArg(Int64(Pointer(value)), typeDYNARRAY); +end; +{$ELSE} +procedure TPaxInvoke.AddArgAsDynArray(var value); +var + P: Pointer; + H: Integer; +begin + P := Pointer(value); + base_invoke.AddArg(IntPax(value), typeINTEGER); + + if P = nil then + H := 0 + else + begin + Dec(Integer(P), SizeOf(Integer)); + H := Integer(P^) - 1; + end; + + base_invoke.AddArg(H, typeINTEGER); +end; +{$ENDIF} + +procedure TPaxInvoke.AddArgAsSet(pvalue: Pointer; Size: Integer); +begin + if Size > SizeOf(IntPax) then + base_invoke.AddArg(IntPax(pvalue), typeINTEGER) + else + base_invoke.AddArg(IntPax(pvalue^), typeINTEGER); +end; + +procedure TPaxInvoke.AddArgAsObject(value: TObject); +begin + base_invoke.AddArg(IntPax(value), typeINTEGER); +end; + +procedure TPaxInvoke.AddArgAsClassRef(value: TClass); +begin + base_invoke.AddArg(IntPax(value), typeINTEGER); +end; + +{$IFDEF PAX64} +procedure TPaxInvoke.AddArgAsInterface(const value: IUnknown); +begin + base_invoke.AddArg(IntPax(Pointer(value)), typeINTERFACE); +end; +{$ELSE} +procedure TPaxInvoke.AddArgAsInterface(const value: IUnknown); +begin + base_invoke.AddArg(Integer(value), typeINTERFACE); +end; +{$ENDIF} + +procedure TPaxInvoke.AddArgAsVariant(const value: Variant); +begin + base_invoke.AddArg(value, typeVARIANT); +end; + +{$IFDEF PAX64} + +procedure AssignRDI(P: Pointer); assembler; +asm + mov RDI, P +end; + +procedure TPaxInvoke.CallHost; +var + P: Pointer; +begin + P := base_invoke.RunnerParam; + + base_invoke.Setup; + + if P <> nil then + AssignRDI(P); + + base_invoke.CallHost; + base_invoke.AdjustResult; +end; +{$ELSE} +{$IFDEF MACOS32} +procedure TPaxInvoke.CallHost; +var + P: Pointer; +begin + P := base_invoke.RunnerParam; + base_invoke.Setup; + + if P <> nil then + asm + mov edi, P + end; + +{$IFDEF MACOS} + case base_invoke.CallConv of + __ccCDECL: base_invoke.CallHostCDECL; + __ccSTDCALL: base_invoke.CallHostSTDCALL; + else + base_invoke.CallHost; + end; +{$ELSE} + base_invoke.CallHost; +{$ENDIF} + + base_invoke.AdjustResult; +end; +{$ELSE} +procedure TPaxInvoke.CallHost; +var + P: Pointer; +begin + P := base_invoke.RunnerParam; + + asm + push esi; + push edi; + push ebx; + end; + + base_invoke.Setup; + + if P <> nil then + asm + mov edi, P + end; + + base_invoke.CallHost; + base_invoke.AdjustResult; + + asm + pop ebx; + pop edi; + pop esi; + end; +end; +{$ENDIF} +{$ENDIF} + +function TPaxInvoke.GetImplementation: Pointer; +begin + result := base_invoke; +end; + +procedure TPaxInvoke.SetCallConv(value: Integer); +begin + base_invoke.CallConv := value; +end; + +function TPaxInvoke.GetCallConv: Integer; +begin + result := base_invoke.CallConv; +end; + +function TPaxInvoke.GetResultPtr: Pointer; +begin + result := base_invoke.GetResultPtr; +end; + +procedure TPaxInvoke.SetResultAsVoid; +begin + base_invoke.SetResType(typeVOID); + base_invoke.SetResSize(SizeOf(Pointer)); +end; + +procedure TPaxInvoke.SetResultAsByte; +begin + base_invoke.SetResType(typeINTEGER); + base_invoke.SetResSize(SizeOf(Byte)); +end; + +procedure TPaxInvoke.SetResultAsWord; +begin + base_invoke.SetResType(typeINTEGER); + base_invoke.SetResSize(SizeOf(Word)); +end; + +procedure TPaxInvoke.SetResultAsCardinal; +begin + base_invoke.SetResType(typeINTEGER); + base_invoke.SetResSize(SizeOf(Cardinal)); +end; + +procedure TPaxInvoke.SetResultAsShortInt; +begin + base_invoke.SetResType(typeINTEGER); + base_invoke.SetResSize(SizeOf(ShortInt)); +end; + +procedure TPaxInvoke.SetResultAsSmallInt; +begin + base_invoke.SetResType(typeINTEGER); + base_invoke.SetResSize(SizeOf(SmallInt)); +end; + +procedure TPaxInvoke.SetResultAsInteger; +begin + base_invoke.SetResType(typeINTEGER); + base_invoke.SetResSize(SizeOf(Integer)); +end; + +procedure TPaxInvoke.SetResultAsBoolean; +begin + base_invoke.SetResType(typeINTEGER); + base_invoke.SetResSize(SizeOf(Boolean)); +end; + +procedure TPaxInvoke.SetResultAsWordBool; +begin + base_invoke.SetResType(typeINTEGER); + base_invoke.SetResSize(SizeOf(WordBool)); +end; + +procedure TPaxInvoke.SetResultAsLongBool; +begin + base_invoke.SetResType(typeINTEGER); + base_invoke.SetResSize(SizeOf(LongBool)); +end; + +procedure TPaxInvoke.SetResultAsChar; +begin + base_invoke.SetResType(typeINTEGER); + base_invoke.SetResSize(SizeOf(Char)); +end; + +procedure TPaxInvoke.SetResultAsWideChar; +begin + base_invoke.SetResType(typeINTEGER); + base_invoke.SetResSize(SizeOf(WideChar)); +end; + +procedure TPaxInvoke.SetResultAsDouble; +begin + base_invoke.SetResType(typeDOUBLE); + base_invoke.SetResSize(SizeOf(Double)); +end; + +procedure TPaxInvoke.SetResultAsSingle; +begin + base_invoke.SetResType(typeSINGLE); + base_invoke.SetResSize(SizeOf(Single)); +end; + +procedure TPaxInvoke.SetResultAsExtended; +begin + base_invoke.SetResType(typeEXTENDED); + base_invoke.SetResSize(SizeOf(Extended)); +end; + +procedure TPaxInvoke.SetResultAsCurrency; +begin +{$IFDEF PAX64} + base_invoke.SetResType(typeINTEGER); + base_invoke.SetResSize(SizeOf(Int64)); +{$ELSE} + base_invoke.SetResType(typeCURRENCY); + base_invoke.SetResSize(SizeOf(Currency)); +{$ENDIF} +end; + +procedure TPaxInvoke.SetResultAsEvent(ResAddress: Pointer = nil); +begin + base_invoke.SetResType(typeEVENT); + base_invoke.SetResSize(SizeOf(TMethod)); + base_invoke.CustomResultAddress := ResAddress; +end; + +procedure TPaxInvoke.SetResultAsUnicodeString(ResAddress: Pointer = nil); +begin + base_invoke.SetResType(typeUNICSTRING); + base_invoke.SetResSize(SizeOf(String)); + base_invoke.CustomResultAddress := ResAddress; +end; + +procedure TPaxInvoke.SetResultAsString(ResAddress: Pointer = nil); +begin + base_invoke.SetResType(typeSTRING); + base_invoke.SetResSize(SizeOf(String)); + base_invoke.CustomResultAddress := ResAddress; +end; + +{$IFNDEF PAXARM} + +procedure TPaxInvoke.SetResultAsAnsiChar; +begin + base_invoke.SetResType(typeINTEGER); + base_invoke.SetResSize(SizeOf(AnsiChar)); +end; + +procedure TPaxInvoke.SetResultAsAnsiString(ResAddress: Pointer = nil); +begin + base_invoke.SetResType(typeSTRING); + base_invoke.SetResSize(SizeOf(String)); + base_invoke.CustomResultAddress := ResAddress; +end; + +procedure TPaxInvoke.SetResultAsWideString(ResAddress: Pointer = nil); +begin + base_invoke.SetResType(typeWIDESTRING); + base_invoke.SetResSize(SizeOf(WideString)); + base_invoke.CustomResultAddress := ResAddress; +end; + +procedure TPaxInvoke.SetResultAsShortString(ResAddress: Pointer = nil); +begin + base_invoke.SetResType(typeSHORTSTRING); + base_invoke.SetResSize(SizeOf(Pointer)); + base_invoke.CustomResultAddress := ResAddress; +end; +{$ENDIF} + +procedure TPaxInvoke.SetResultAsPChar; +begin + base_invoke.SetResType(typeINTEGER); + base_invoke.SetResSize(SizeOf(Pointer)); +end; + +procedure TPaxInvoke.SetResultAsPWideChar; +begin + base_invoke.SetResType(typeINTEGER); + base_invoke.SetResSize(SizeOf(Pointer)); +end; + +procedure TPaxInvoke.SetResultAsPointer; +begin + base_invoke.SetResType(typeINTEGER); + base_invoke.SetResSize(SizeOf(Pointer)); +end; + +procedure TPaxInvoke.SetResultAsVariant(ResAddress: Pointer = nil); +begin + base_invoke.SetResType(typeVARIANT); + base_invoke.SetResSize(SizeOf(Pointer)); + base_invoke.CustomResultAddress := ResAddress; +end; + +procedure TPaxInvoke.SetResultAsSet(Size: Integer; + ResAddress: Pointer = nil); +begin + if Size > SizeOf(Pointer) then + begin + base_invoke.SetResType(typeSET); + base_invoke.SetResSize(Size); + end + else + begin + base_invoke.SetResType(typeINTEGER); + base_invoke.SetResSize(SizeOf(Pointer)); + end; + base_invoke.CustomResultAddress := ResAddress; +end; + +procedure TPaxInvoke.SetResultAsArray(Size: Integer; + ResAddress: Pointer = nil); +begin + if Size > SizeOf(Pointer) then + begin + base_invoke.SetResType(typeARRAY); + base_invoke.SetResSize(Size); + end + else + begin + base_invoke.SetResType(typeINTEGER); + base_invoke.SetResSize(SizeOf(Pointer)); + end; + base_invoke.CustomResultAddress := ResAddress; +end; + +procedure TPaxInvoke.SetResultAsDynArray(ResAddress: Pointer = nil); +begin + base_invoke.SetResType(typeDYNARRAY); + base_invoke.SetResSize(SizeOf(Pointer)); + base_invoke.CustomResultAddress := ResAddress; +end; + +procedure TPaxInvoke.SetResultAsRecord(Size: Integer; ResAddress: Pointer = nil); +begin + if Size > SizeOf(Pointer) then + begin + base_invoke.SetResType(typeRECORD); + base_invoke.SetResSize(Size); + end + else + begin + base_invoke.SetResType(typeINTEGER); + base_invoke.SetResSize(Size); + end; + base_invoke.CustomResultAddress := ResAddress; +end; + +procedure TPaxInvoke.SetResultAsObject(ResAddress: Pointer = nil); +begin + base_invoke.SetResType(typeCLASS); + base_invoke.SetResSize(SizeOf(Pointer)); + base_invoke.CustomResultAddress := ResAddress; +{$IFDEF ARC} + if ResAddress = nil then + base_invoke.SetResType(typeINTEGER); +{$ENDIF} +end; + +procedure TPaxInvoke.SetResultAsClassRef; +begin + base_invoke.SetResType(typeINTEGER); + base_invoke.SetResSize(SizeOf(Pointer)); +end; + +procedure TPaxInvoke.SetResultAsInterface(ResAddress: Pointer = nil); +begin + base_invoke.SetResType(typeINTERFACE); + base_invoke.SetResSize(SizeOf(Pointer)); + base_invoke.CustomResultAddress := ResAddress; +end; + +procedure TPaxInvoke.SetResultAsInt64; +begin +{$IFDEF PAX64} + base_invoke.SetResType(typeINTEGER); + base_invoke.SetResSize(SizeOf(Int64)); +{$ELSE} + base_invoke.SetResType(typeINT64); + base_invoke.SetResSize(SizeOf(Int64)); +{$ENDIF} +end; + +procedure TPaxInvoke.SetResultAsUInt64; +begin +{$IFDEF PAX64} + base_invoke.SetResType(typeINTEGER); + base_invoke.SetResSize(SizeOf(Int64)); +{$ELSE} + base_invoke.SetResType(typeUINT64); + base_invoke.SetResSize(SizeOf(UInt64)); +{$ENDIF} +end; + +function TPaxInvoke.GetThis: Pointer; +begin + result := base_invoke.GetThis; +end; + +procedure TPaxInvoke.SetThis(value: Pointer); +begin + base_invoke.SetThis(value); +end; + +function TPaxInvoke.GetFake: Boolean; +begin + result := base_invoke.IsFakeMethod; +end; + +procedure TPaxInvoke.SetFake(value: Boolean); +begin + base_invoke.IsFakeMethod := value; +end; + +procedure TPaxInvoke.ClearResult; +begin + base_invoke.ClearResult; +end; + +end. diff --git a/Sources/PaxInvokeRegister.pas b/Sources/PaxInvokeRegister.pas new file mode 100644 index 0000000..b085dbd --- /dev/null +++ b/Sources/PaxInvokeRegister.pas @@ -0,0 +1,30 @@ +//////////////////////////////////////////////////////////////////////////// +// PaxInvoke +// Site: http://www.paxcompiler.com +// Author: Alexander Baranovsky (paxscript@gmail.com) +// ======================================================================== +// Copyright (c) Alexander Baranovsky, 2006-2014. All rights reserved. +// Code Version: 4.2 +// ======================================================================== +// Unit: PaxInvokeRegister.pas +// ======================================================================== +//////////////////////////////////////////////////////////////////////////// + +unit PaxInvokeRegister; + +interface + +uses + Classes, + PaxInvoke; + +procedure Register; + +Implementation + +procedure Register; +begin + RegisterComponents('PaxPaxCompiler', [TPaxInvoke]); +end; + +end. diff --git a/Sources/PaxJavaScriptLanguage.pas b/Sources/PaxJavaScriptLanguage.pas new file mode 100644 index 0000000..f5528e4 --- /dev/null +++ b/Sources/PaxJavaScriptLanguage.pas @@ -0,0 +1,63 @@ +//////////////////////////////////////////////////////////////////////////// +// PaxCompiler +// Site: http://www.paxcompiler.com +// Author: Alexander Baranovsky (paxscript@gmail.com) +// ======================================================================== +// Copyright (c) Alexander Baranovsky, 2006-2014. All rights reserved. +// Code Version: 4.2 +// ======================================================================== +// Unit: PaxJavaScriptLanguage.pas +// ======================================================================== +//////////////////////////////////////////////////////////////////////////// + +{$I PaxCompiler.def} +unit PaxJavaScriptLanguage; + +interface +uses + SysUtils, + Classes, + PAXCOMP_PARSER, + PAXCOMP_JS_PARSER, + PaxRegister, + PaxCompiler; + +type + TPaxJavaScriptLanguage = class(TPaxCompilerLanguage) + protected + function GetParser: TBaseParser; override; + public + constructor Create(AOwner: TComponent); override; + procedure SetCallConv(CallConv: Integer); override; + function GetLanguageName: String; override; + published + end; + +implementation + +function TPaxJavaScriptLanguage.GetParser: TBaseParser; +begin + result := P; +end; + +function TPaxJavaScriptLanguage.GetLanguageName: String; +begin + result := P.LanguageName; +end; + +constructor TPaxJavaScriptLanguage.Create(AOwner: TComponent); +begin + inherited; + P := TJavaScriptParser.Create; + SetCallConv(_ccSTDCALL); +end; + +procedure TPaxJavaScriptLanguage.SetCallConv(CallConv: Integer); +begin + if CallConv <> _ccSTDCALL then + raise Exception.Create('Only STDCALL convention is allowed.'); + + P.CallConv := CallConv; +end; + +end. diff --git a/Sources/PaxPE.pas b/Sources/PaxPE.pas new file mode 100644 index 0000000..18f772a --- /dev/null +++ b/Sources/PaxPE.pas @@ -0,0 +1,199 @@ +//////////////////////////////////////////////////////////////////////////// +// PaxCompiler +// Site: http://www.paxcompiler.com +// Author: Alexander Baranovsky (paxscript@gmail.com) +// ======================================================================== +// Copyright (c) Alexander Baranovsky, 2006-2014. All rights reserved. +// Code Version: 4.2 +// ======================================================================== +// Unit: PAXCOMP_PE.pas +// ======================================================================== +//////////////////////////////////////////////////////////////////////////// + +{$I PaxCompiler.def} +unit PaxPE; +interface +uses {$I uses.def} + SysUtils, + PAXCOMP_SYS, + PaxRunner, + PaxProgram; + +procedure RunScript(ProgAddress: Pointer); stdcall; +function ScriptDllMain(ProgAddress: Pointer; + Instance, Reason, Reserved: Cardinal): Boolean; stdcall; +procedure CreateExeFile(const ExeName: String; + PaxProgram: TPaxProgram; + const ImportDllName: String; + const ProcName: String); +procedure CreateDllFile(const DllName: String; + PaxProgram: TPaxProgram; + const ImportDllName: String; + const ProcName: String); + +implementation + +uses + PAXCOMP_CONSTANTS, + PAXCOMP_PE; + +type + THandler = class + procedure OnPrintHandler(Sender: TPaxRunner; const Text: string); + end; + +procedure THandler.OnPrintHandler(Sender: TPaxRunner; const Text: string); +begin + write(Text); +end; + +procedure RunScript(ProgAddress: Pointer); stdcall; +var + PaxProgram1: TPaxProgram; + H: THandler; +begin + PaxProgram1 := TPaxProgram.Create(nil); + H := THandler.Create; + try + PaxProgram1.OnPrintEvent := H.OnPrintHandler; + PaxProgram1.LoadFromBuff(ProgAddress^); + PaxProgram1.Run; + finally + FreeAndNil(PaxProgram1); + FreeAndNil(H); + end; +{$IFDEF MACOS32} +{$ELSE} + ExitProcess(0); +{$ENDIF} +end; + +{$IFDEF MACOS32} +function ScriptDllMain(ProgAddress: Pointer; + Instance, Reason, Reserved: Cardinal): Boolean; stdcall; +begin +end; +{$ELSE} + +function ScriptDllMain(ProgAddress: Pointer; + Instance, Reason, Reserved: Cardinal): Boolean; stdcall; +var + PaxProgram1: TPaxProgram; + H: THandler; + I: Integer; + P: Pointer; + S: String; + Delta: Integer; + K: IntPax; + mbi: TMemoryBasicInformation; + OldProtect: Cardinal; +begin + Delta := (ImageBase + SectionAlignment * 3) - Cardinal(ProgAddress); + + case Reason of + DLL_PROCESS_ATTACH: + begin +// ErrMessageBox('Dll is loaded'); + + PaxProgram1 := TPaxProgram.Create(nil); + H := THandler.Create; + PaxProgram1.OnPrintEvent := H.OnPrintHandler; + PaxProgram1.LoadFromBuff(ProgAddress^); + PaxProgram1.Run; + + K := (ImageBase + SectionAlignment) - Delta; + Inc(K, DllJumpsOffset + 1); + + for I := 0 to PaxProgram1.GetProgPtr.ExportList.Count - 1 do + begin +// S := PaxProgram1.GetProgPtr.ExportList[I].Name; +// P := PaxProgram1.GetAddress(S); + P := ShiftPointer(PaxProgram1.CodePtr, PaxProgram1.GetProgPtr.ExportList[I].Offset); + + VirtualQuery(Pointer(K), mbi, sizeof(mbi)); + VirtualProtect(Pointer(K), 16, PAGE_EXECUTE_READWRITE, OldProtect); + FlushInstructionCache(GetCurrentProcess, Pointer(K), 16); + try + Pointer(Pointer(K)^) := P; + finally + VirtualProtect(Pointer(K), 16, OldProtect, OldProtect); + end; + Inc(K, DllJumpStep); + end; + + K := (ImageBase + SectionAlignment) - Delta; + Inc(K, DllInitSize); + + VirtualQuery(Pointer(K), mbi, sizeof(mbi)); + VirtualProtect(Pointer(K), 16, PAGE_EXECUTE_READWRITE, OldProtect); + FlushInstructionCache(GetCurrentProcess, Pointer(K), 16); + try + Pointer(Pointer(K)^) := PaxProgram1; + finally + VirtualProtect(Pointer(K), 16, OldProtect, OldProtect); + end; + + Inc(K, 4); + + VirtualQuery(Pointer(K), mbi, sizeof(mbi)); + VirtualProtect(Pointer(K), 16, PAGE_EXECUTE_READWRITE, OldProtect); + FlushInstructionCache(GetCurrentProcess, Pointer(K), 16); + try + Pointer(Pointer(K)^) := H; + finally + VirtualProtect(Pointer(K), 16, OldProtect, OldProtect); + end; + + end; + DLL_PROCESS_DETACH: + begin +// ErrMessageBox('Dll is unloaded'); + + K := (ImageBase + SectionAlignment) - Delta; + Inc(K, DllInitSize); + + VirtualQuery(Pointer(K), mbi, sizeof(mbi)); + VirtualProtect(Pointer(K), 16, PAGE_EXECUTE_READWRITE, OldProtect); + FlushInstructionCache(GetCurrentProcess, Pointer(K), 16); + try + PaxProgram1 := Pointer(Pointer(K)^); + finally + VirtualProtect(Pointer(K), 16, OldProtect, OldProtect); + end; + + Inc(K, 4); + + VirtualQuery(Pointer(K), mbi, sizeof(mbi)); + VirtualProtect(Pointer(K), 16, PAGE_EXECUTE_READWRITE, OldProtect); + FlushInstructionCache(GetCurrentProcess, Pointer(K), 16); + try + H := Pointer(Pointer(K)^); + finally + VirtualProtect(Pointer(K), 16, OldProtect, OldProtect); + end; + + FreeAndNil(PaxProgram1); + FreeAndNil(H); + end; + end; + result := true; +end; +{$ENDIF} + +procedure CreateExeFile(const ExeName: String; + PaxProgram: TPaxProgram; + const ImportDllName: String; + const ProcName: String); +begin + CreatePE(ExeName, ImportDllName, ProcName, PaxProgram, peEXE); +end; + +procedure CreateDllFile(const DllName: String; + PaxProgram: TPaxProgram; + const ImportDllName: String; + const ProcName: String); +begin + CreatePE(DllName, ImportDllName, ProcName, PaxProgram, peDLL); +end; + +end. diff --git a/Sources/PaxProgram.pas b/Sources/PaxProgram.pas new file mode 100644 index 0000000..1a51b01 --- /dev/null +++ b/Sources/PaxProgram.pas @@ -0,0 +1,43 @@ +//////////////////////////////////////////////////////////////////////////// +// PaxCompiler +// Site: http://www.paxcompiler.com +// Author: Alexander Baranovsky (paxscript@gmail.com) +// ======================================================================== +// Copyright (c) Alexander Baranovsky, 2006-2014. All rights reserved. +// Code Version: 4.2 +// ======================================================================== +// Unit: PaxProgram.pas +// ======================================================================== +//////////////////////////////////////////////////////////////////////////// + +{$I PaxCompiler.def} +unit PaxProgram; +interface +uses + Classes, + PAXCOMP_BASERUNNER, + PAXCOMP_PROG, + PAXCOMP_EMIT, + PaxRunner; +type + TPaxProgram = class(TPaxRunner) + protected + function GetRunnerClass: TBaseRunnerClass; override; + public + constructor Create(AOwner: TComponent); override; + end; + +implementation + +constructor TPaxProgram.Create(AOwner: TComponent); +begin + inherited; + EmitProc := EmitProgProc; +end; + +function TPaxProgram.GetRunnerClass: TBaseRunnerClass; +begin + result := TProgram; +end; + +end. diff --git a/Sources/PaxRegister.pas b/Sources/PaxRegister.pas new file mode 100644 index 0000000..ee78001 --- /dev/null +++ b/Sources/PaxRegister.pas @@ -0,0 +1,1421 @@ +//////////////////////////////////////////////////////////////////////////// +// PaxCompiler +// Site: http://www.paxcompiler.com +// Author: Alexander Baranovsky (paxscript@gmail.com) +// ======================================================================== +// Copyright (c) Alexander Baranovsky, 2006-2014. All rights reserved. +// Code Version: 4.2 +// ======================================================================== +// Unit: PaxRegister.pas +// ======================================================================== +//////////////////////////////////////////////////////////////////////////// + +{$I PaxCompiler.def} +unit PaxRegister; +interface +uses {$I uses.def} +{$ifdef DRTTI} + RTTI, + PAXCOMP_2010, + PAXCOMP_2010REG, +{$ENDIF} + SysUtils, + Classes, + TypInfo, + PAXCOMP_CONSTANTS, + PAXCOMP_TYPES, + PAXCOMP_SYS, + PAXCOMP_FORBID, + PAXCOMP_SYMBOL_REC, + PAXCOMP_BASESYMBOL_TABLE, + PAXCOMP_LOCALSYMBOL_TABLE, + PAXCOMP_STDLIB; + +const + _ccSTDCALL = 1; + _ccREGISTER = 2; + _ccCDECL = 3; + _ccPASCAL = 4; + _ccSAFECALL = 5; + _ccMSFASTCALL = 6; + + _visPUBLIC = 0; + _visPROTECTED = 1; + _visPRIVATE = 2; + + _cmNONE = 0; + _cmVIRTUAL = 1; + _cmOVERRIDE = 2; + _cmDYNAMIC = 3; + _cmSTATIC = 4; + + _parVal = 0; + _parVar = 1; + _parConst = 2; + _parOut = 3; + + _typeVOID = 1; + _typeBOOLEAN = 2; + _typeBYTE = 3; + _typeANSICHAR = 4; + _typeANSISTRING = 5; + _typeWORD = 6; + _typeINTEGER = 7; + _typeDOUBLE = 8; + _typePOINTER = 9; + _typeRECORD = 10; + _typeARRAY = 11; + _typeALIAS = 12; + _typeENUM = 13; + _typePROC = 14; + _typeSET = 15; + _typeSHORTSTRING = 16; + _typeSINGLE = 17; + _typeEXTENDED = 18; + _typeCLASS = 19; + _typeWIDECHAR = 21; + _typeWIDESTRING = 22; + _typeVARIANT = 23; + _typeDYNARRAY = 24; + _typeINT64 = 25; + _typeCARDINAL = 27; + _typeCURRENCY = 29; + _typeSMALLINT = 30; + _typeSHORTINT = 31; + _typeWORDBOOL = 32; + _typeLONGBOOL = 33; + _typeBYTEBOOL = 34; + _typeOLEVARIANT = 35; + _typeUNICSTRING = 36; + _typeUINT64 = 39; + +{$IFDEF UNIC} + _typeSTRING = _typeUNICSTRING; + _typeCHAR = _typeWIDECHAR; +{$ELSE} + _typeSTRING = _typeANSISTRING; + _typeCHAR = _typeANSICHAR; +{$ENDIF} + + _typePCHAR = 49; + _typePVOID = 50; + _typePWIDECHAR = 51; +var + _Unassigned: Variant; + +function RegisterNamespace(LevelId: Integer; const Name: String): Integer; + +procedure RegisterUsingNamespace(const aNamespaceName: String); overload; +procedure RegisterUsingNamespace(aNamespaceID: Integer); overload; + +procedure UnregisterUsingNamespace(aNamespaceID: Integer); overload; +procedure UnregisterUsingNamespace(const aNamespaceName: String); overload; +procedure UnregisterUsingNamespaces; + +function RegisterConstant(LevelId: Integer; const Name: String; TypeId: Integer; + const Value: Variant): Integer; overload; +function RegisterConstant(LevelId: Integer; const Name: String; + const Value: Variant): Integer; overload; +function RegisterPointerConstant(LevelId: Integer; const Name: String; + const Value: Pointer): Integer; overload; +function RegisterConstant(LevelId: Integer; const Name: String; + const Value: Extended): Integer; overload; +function RegisterConstant(LevelId: Integer; const Name: String; + const Value: Int64): Integer; overload; +function RegisterConstant(LevelId: Integer; const Declaration: String): Integer; overload; +function RegisterVariable(LevelId: Integer; + const Name: String; TypeId: Integer; + Address: Pointer): Integer; overload; +function RegisterVariable(LevelId: Integer; + const Declaration: String; Address: Pointer): Integer; overload; +function RegisterObject(LevelId: Integer; + const ObjectName: String; + TypeId: Integer; + Address: Pointer = nil): Integer; +function RegisterVirtualObject(LevelId: Integer; + const ObjectName: String): Integer; +function RegisterRoutine(LevelId: Integer; const Name: String; ResultId: Integer; + Address: Pointer; + CallConvention: Integer = _ccREGISTER; + OverCount: Integer = 0; + i_IsDeprecated: Boolean = false): Integer; overload; +function RegisterRoutine(LevelId: Integer; const Name, ResultType: String; + Address: Pointer; + CallConvention: Integer = _ccREGISTER; + OverCount: Integer = 0; + i_IsDeprecated: Boolean = false): Integer; overload; +procedure RegisterMember(LevelId: Integer; const Name: String; + Address: Pointer); +function RegisterConstructor(ClassId: Integer; + const Name: String; + Address: Pointer; + CallConvention: Integer = _ccREGISTER; + IsShared: Boolean = false; + CallMode: Integer = cmNONE; + i_MethodIndex: Integer = 0; + OverCount: Integer = 0; + i_IsAbstract: Boolean = false; + i_AbstractMethodCount: Integer = 0; + i_IsDeprecated: Boolean = false): Integer; overload; +function RegisterDestructor(ClassId: Integer; const Name: String; + Address: Pointer): Integer; +function RegisterMethod(ClassId: Integer; + const Name: String; + ResultId: Integer; + Address: Pointer; + CallConvention: Integer = _ccREGISTER; + IsShared: Boolean = false; + CallMode: Integer = _cmNONE; + MethodIndex: Integer = 0; + OverCount: Integer = 0; + i_IsAbstract: Boolean = false; + i_AbstractMethodCount: Integer = 0; + i_IsDeprecated: Boolean = false): Integer; overload; +function RegisterMethod(ClassId: Integer; + const Name, ResultType: String; + Address: Pointer; + CallConvention: Integer = _ccREGISTER; + IsShared: Boolean = false; + CallMode: Integer = _cmNONE; + MethodIndex: Integer = 0; + OverCount: Integer = 0; + i_IsAbstract: Boolean = false; + i_AbstractMethodCount: Integer = 0; + i_IsDeprecated: Boolean = false): Integer; overload; +function RegisterHeader(LevelId: Integer; + const Header: String; Address: Pointer; + MethodIndex: Integer = 0; + Visibility: Integer = 0): Integer; +function RegisterFakeHeader(LevelId: Integer; + const Header: String; Address: Pointer): Integer; +function RegisterParameter(LevelId: Integer; + const ParameterName: String; + ParamTypeID: Integer; + ParamMod: Integer = 0; + Optional: Boolean = false; + const DefaultValue: String = ''): Integer; overload; +function RegisterParameter(LevelId: Integer; + const ParameterName: String; + const ParameterType: String; + ParamMod: Integer = 0; + Optional: Boolean = false; + const DefaultValue: String = ''): Integer; overload; +function RegisterParameter(LevelId: Integer; TypeId: Integer; + ByRef: Boolean = false): Integer; overload; +function RegisterParameter(LevelId: Integer; TypeId: Integer; + const DefaultValue: Variant; + ByRef: Boolean = false): Integer; overload; +function RegisterParameter(LevelId: Integer; + ParameterName: String; + TypeID: Integer; + const DefaultValue: Variant; + ByRef: Boolean): Integer; overload; +function RegisterParameterEx(LevelId: Integer; + ParameterName: String; + TypeID: Integer; + const DefaultValue: Variant; + ByRef: Boolean; + IsConst: Boolean): Integer; +function RegisterParameterEx2(LevelId: Integer; ParameterName: String; + TypeID: Integer; const DefaultValue: Variant; + ByRef, IsConst, IsOpenArray: Boolean): Integer; +procedure RegisterRunnerParameter(HSub: Integer); +function RegisterInterfaceType(LevelId: Integer; + const TypeName: String; + const GUID: TGUID): Integer; overload; +function RegisterInterfaceType(LevelId: Integer; + const TypeName: String; + const GUID: TGUID; + const ParentName: String; + const ParentGUID: TGUID): Integer; overload; + +procedure RegisterSupportedInterface(TypeId: Integer; + const SupportedInterfaceName: String; + const GUID: TGUID); +function RegisterClassType(LevelId: Integer; C: TClass; + DoRegisterClass: Boolean = false): Integer; overload; +function RegisterClassType(LevelId: Integer; C: TClass; + DoRegisterClass: Boolean; + Reserved: Integer): Integer; overload; +function RegisterClassType(LevelId: Integer; + const TypeName: String; AncestorId: Integer): Integer; overload; +function RegisterClassType(LevelId: Integer; + const TypeName: String): Integer; overload; +function RegisterClassTypeForImporter(LevelId: Integer; + C: TClass): Integer; +procedure RegisterClassTypeInfos(ClassId: Integer; + C: TClass); +function RegisterClassReferenceType(LevelId: Integer; + const TypeName: String; OriginClassId: Integer): Integer; overload; +function RegisterClassReferenceType(LevelId: Integer; + const TypeName: String): Integer; overload; +function RegisterClassReferenceType(LevelID: Integer; const TypeName, OriginalTypeName: String): Integer; overload; +function RegisterClassHelperType(LevelId: Integer; + const TypeName: String; OriginClassId: Integer): Integer; overload; +function RegisterClassHelperType(LevelID: Integer; const TypeName, OriginalTypeName: String): Integer; overload; +function RegisterRecordHelperType(LevelId: Integer; + const TypeName: String; OriginRecordId: Integer): Integer; overload; +function RegisterRecordHelperType(LevelID: Integer; const TypeName, OriginalTypeName: String): Integer; overload; +function RegisterClassTypeField(ClassTypeId: Integer; const Name: String; + TypeID: Integer; Offset: Integer = -1): Integer; overload; +function RegisterClassTypeField(TypeId: Integer; const Declaration: String + ): Integer; overload; +function RegisterProperty(LevelId: Integer; const PropName: String; + PropTypeID, ReadId, WriteId: Integer; + IsDefault: Boolean): Integer; overload; +function RegisterProperty(LevelId: Integer; const Header: String): Integer; overload; +function RegisterInterfaceProperty(LevelId: Integer; + const PropName: String; + PropTypeID, + ReadIndex, + WriteIndex: Integer): Integer; +function RegisterRecordType(LevelId: Integer; + const TypeName: String; + IsPacked: Boolean = false): Integer; +function RegisterRecordTypeField(TypeId: Integer; const FieldName: String; + FieldTypeID: Integer; + FieldOffset: Integer = -1): Integer; overload; +function RegisterRecordTypeField(TypeId: Integer; const Declaration: String + ): Integer; overload; + +function RegisterVariantRecordTypeField(LevelId: Integer; const FieldName: String; + FieldTypeID: Integer; + VarCount: Int64): Integer; overload; +function RegisterVariantRecordTypeField(LevelId: Integer; const Declaration: String; + VarCount: Int64): Integer; overload; +function RegisterSubrangeType(LevelId: Integer; + const TypeName: String; + TypeBaseId: Integer; + B1, B2: Integer): Integer; + +function RegisterEnumType(LevelId: Integer; + const TypeName: String; + TypeBaseId: Integer = _typeINTEGER): Integer; +function RegisterEnumValue(EnumTypeId: Integer; + const FieldName: String; + const Value: Integer): Integer; + +function RegisterArrayType(LevelId: Integer; + const TypeName: String; + RangeTypeId, ElemTypeId: Integer; + IsPacked: Boolean = false): Integer; +function RegisterDynamicArrayType(LevelId: Integer; + const TypeName: String; + ElemTypeId: Integer): Integer; +function RegisterPointerType(LevelId: Integer; + const TypeName: String; + OriginTypeId: Integer; + const OriginTypeName: String = ''): Integer; +function RegisterSetType(LevelId: Integer; + const TypeName: String; + OriginTypeId: Integer): Integer; + +function RegisterProceduralType(LevelId: Integer; + const TypeName: String; + SubId: Integer): Integer; + +function RegisterMethodReferenceType(LevelId: Integer; + const TypeName: String; + SubId: Integer): Integer; +{$IFNDEF PAXARM} +function RegisterShortStringType(LevelId: Integer; + const TypeName: String; + L: Integer): Integer; +{$ENDIF} +function RegisterEventType(LevelId: Integer; + const TypeName: String; + SubId: Integer): Integer; +function RegisterRTTIType(LevelId: Integer; + pti: PTypeInfo): Integer; +function RegisterTypeAlias(LevelId:Integer; + const TypeName: String; + OriginTypeId: Integer): Integer; overload; +function RegisterTypeAlias(LevelId:Integer; + const TypeName, OriginTypeName: String): Integer; overload; +function RegisterTypeAlias(LevelId:Integer; + const Declaration: String): Integer; overload; + +function RegisterTypeDeclaration(LevelId: Integer; + const Declaration: String): Integer; + +function RegisterDummyType(LevelId: Integer; + const TypeName: String): Integer; +function RegisterSomeType(LevelId: Integer; + const TypeName: String): Integer; +function RegisterSpace(K: Integer): Integer; + +procedure ForbidClass(C: TClass); +procedure ForbidPublishedProperty(C: TClass; const PropName: String); +procedure ForbidAllPublishedProperties(C: TClass); + +function LookupTypeId(const TypeName: String): Integer; +function LookupTypeNamespaceId(const TypeName: String): Integer; +function LookupNamespace(LevelId: Integer; const NamespaceName: String; + CaseSensitive: Boolean): Integer; overload; +function LookupNamespace(const NamespaceName: String): Integer; overload; + +procedure SaveNamespaceToStream(const NamespaceName: String; + S: TStream); +procedure SaveNamespaceToFile(const NamespaceName: String; + const FileName: String); + +procedure LoadNamespaceFromStream(S: TStream); +procedure LoadNamespaceFromFile(const FileName: String); + +procedure RegisterAlignment(value: Integer); +procedure SetVisibility(C: TClass; const MemberName: String; value: Integer); overload; +procedure SetVisibility(ClassId: integer; + const MemberName: String; value: Integer); overload; + +procedure EndOfRegistration(CheckProc: TCheckProc; Data: Pointer); overload; +procedure EndOfRegistration; overload; + +function CreateNewImportTable: Pointer; +procedure SetImportTable(ImportTable: Pointer); +procedure DestroyImportTable(var ImportTable: Pointer); + +function LoadImportLibrary(const DllName: String): Cardinal; +function FreeImportLibrary(H: Cardinal): LongBool; + +function SetImportEntry(K: Integer): Integer; +function GetImportEntry: Integer; + +procedure LoadGlobalSymbolTableFromStream(Stream: TStream); +procedure LoadGlobalSymbolTableFromFile(const FileName: String); +procedure SaveGlobalSymbolTableToStream(Stream: TStream); +procedure SaveGlobalSymbolTableToFile(const FileName: String); + +function FindNextVirtualMethodAddress(C: TClass; PrevAddress: Pointer): Pointer; +function RenameClassType(C: TClass; const NewName: String): Boolean; +procedure EndOfStructuredType(Id: Integer); + +{$ifdef DRTTI} +function RegisterRTTIRecordType(Level: Integer; t: TRTTIRecordType): Integer; +function RegisterRTTIClassType(Level: Integer; t: TRTTIInstanceType): Integer; +function RegisterRTTIInterfaceType(Level: Integer; t: TRTTIInterfaceType): Integer; +{$endif} + +var + MustRegisterClass: Boolean = false; + +implementation + +uses + PaxDllImport; + +procedure ForbidPublishedProperty(C: TClass; const PropName: String); +begin + if ForbiddenPropList = nil then + ForbiddenPropList := TForbiddenPropList.Create; + + ForbiddenPropList.Add(C, PropName); +end; + +procedure ForbidAllPublishedProperties(C: TClass); +begin + if ForbiddenPropList = nil then + ForbiddenPropList := TForbiddenPropList.Create; + + ForbiddenPropList.AddAll(C); +end; + +procedure RaiseError(const Message: string; params: array of Const); +begin + if RaiseE then + raise Exception.Create(Format(Message, params)) + else + begin + REG_ERROR := Format(Message, params); + REG_OK := false; + + if Message = errUndeclaredIdentifier then + REG_ERROR := ''; + end; +end; + +function RegisterNamespace(LevelId: Integer; const Name: String): Integer; +begin + result := GlobalImportTable.RegisterNamespace(LevelId, Name); +end; + +procedure RegisterUsingNamespace(const aNamespaceName: String); overload; +Var + H: integer; +begin + H := GlobalImportTable.LookupNamespace(aNamespaceName, 0, True); + if H > 0 then + RegisterUsingNamespace (H); +end; + +procedure RegisterUsingNamespace(aNamespaceID: Integer); +begin + GlobalImportTable.HeaderParser.UsedNamespaceList.Add(aNamespaceID); +end; + +procedure UnregisterUsingNamespace(aNamespaceID: Integer); overload; +begin + GlobalImportTable.HeaderParser.UsedNamespaceList.DeleteValue(aNamespaceID); +end; + +procedure UnregisterUsingNamespaces; +begin + GlobalImportTable.HeaderParser.UsedNamespaceList.Clear; +end; + +procedure UnregisterUsingNamespace(const aNamespaceName: String); overload; +Var + H: integer; +begin + H := GlobalImportTable.LookupNamespace(aNamespaceName, 0, True); + if H > 0 then + UnRegisterUsingNamespace(H); +end; + +function RegisterConstant(LevelId: Integer; const Name: String; TypeId: Integer; + const Value: Variant): Integer; +begin + result := GlobalImportTable.RegisterConstant(LevelId, Name, TypeId, Value); +end; + +function RegisterConstant(LevelId: Integer; const Name: String; + const Value: Variant): Integer; +begin + result := GlobalImportTable.RegisterConstant(LevelId, Name, Value); +end; + +function RegisterPointerConstant(LevelId: Integer; const Name: String; + const Value: Pointer): Integer; +begin + result := GlobalImportTable.RegisterPointerConstant(LevelId, Name, Value); +end; + +function RegisterConstant(LevelId: Integer; const Name: String; + const Value: Extended): Integer; +begin + result := GlobalImportTable.RegisterExtendedConstant(LevelId, Name, Value); +end; + +function RegisterConstant(LevelId: Integer; const Name: String; + const Value: Int64): Integer; +begin + result := GlobalImportTable.RegisterInt64Constant(LevelId, Name, Value); +end; + +function RegisterConstant(LevelId: Integer; const Declaration: String): Integer; +begin + result := GlobalImportTable.RegisterConstant(LevelId, Declaration); +end; + +function RegisterObject(LevelId: Integer; + const ObjectName: String; + TypeId: Integer; + Address: Pointer = nil): Integer; +begin + result := GlobalImportTable.RegisterObject(LevelId, ObjectName, TypeId, Address); +end; + +function RegisterVirtualObject(LevelId: Integer; + const ObjectName: String): Integer; +begin + result := GlobalImportTable.RegisterVirtualObject(LevelId, ObjectName); +end; + +function RegisterVariable(LevelId: Integer; + const Name: String; TypeId: Integer; + Address: Pointer): Integer; +begin + result := GlobalImportTable.RegisterVariable(LevelId, Name, TypeId, Address); +end; + +function RegisterVariable(LevelId: Integer; + const Declaration: String; Address: Pointer): Integer; +begin + result := GlobalImportTable.RegisterVariable(LevelId, Declaration, Address); +end; + +function RegisterRoutine(LevelId: Integer; const Name: String; + ResultId: Integer; + Address: Pointer; + CallConvention: Integer = _ccREGISTER; + OverCount: Integer = 0; + i_IsDeprecated: Boolean = false): Integer; +begin + result := GlobalImportTable.RegisterRoutine(LevelId, Name, + ResultId, CallConvention, Address, OverCount, i_IsDeprecated); +end; + +function RegisterRoutine(LevelId: Integer; const Name, ResultType: String; + Address: Pointer; + CallConvention: Integer = _ccREGISTER; + OverCount: Integer = 0; + i_IsDeprecated: Boolean = false): Integer; +begin + result := GlobalImportTable.RegisterRoutine(LevelId, Name, ResultType, + CallConvention, Address, OverCount, i_IsDeprecated); +end; + +procedure RegisterMember(LevelId: Integer; const Name: String; + Address: Pointer); +begin + GlobalImportTable.RegisterMember(LevelId, Name, Address); +end; + +function RegisterConstructor(ClassId: Integer; + const Name: String; + Address: Pointer; + CallConvention: Integer = _ccREGISTER; + IsShared: Boolean = false; + CallMode: Integer = 0; + i_MethodIndex: Integer = 0; + OverCount: Integer = 0; + i_IsAbstract: Boolean = false; + i_AbstractMethodCount: Integer = 0; + i_IsDeprecated: Boolean = false): Integer; +begin + result := GlobalImportTable.RegisterConstructor(ClassId, + Name, Address, IsShared, CallMode, i_MethodIndex, OverCount, + i_IsAbstract, i_AbstractMethodCount, i_IsDeprecated); +end; + +function RegisterDestructor(ClassId: Integer; const Name: String; + Address: Pointer): Integer; +begin + result := GlobalImportTable.RegisterDestructor(ClassId, Name, Address); +end; + +function RegisterMethod(ClassId: Integer; + const Name: String; + ResultId: Integer; + Address: Pointer; + CallConvention: Integer = _ccREGISTER; + IsShared: Boolean = false; + CallMode: Integer = _cmNONE; + MethodIndex: Integer = 0; + OverCount: Integer = 0; + i_IsAbstract: Boolean = false; + i_AbstractMethodCount: Integer = 0; + i_IsDeprecated: Boolean = false): Integer; +begin + result := GlobalImportTable.RegisterMethod(ClassId, + Name, + ResultId, + CallConvention, + Address, + IsShared, + CallMode, + MethodIndex, + OverCount, + i_IsAbstract, + i_AbstractMethodCount, + i_IsDeprecated); +end; + +function RegisterMethod(ClassId: Integer; + const Name, ResultType: String; + Address: Pointer; + CallConvention: Integer = _ccREGISTER; + IsShared: Boolean = false; + CallMode: Integer = _cmNONE; + MethodIndex: Integer = 0; + OverCount: Integer = 0; + i_IsAbstract: Boolean = false; + i_AbstractMethodCount: Integer = 0; + i_IsDeprecated: Boolean = false): Integer; +begin + result := GlobalImportTable.RegisterMethod(ClassId, + Name, + ResultType, + CallConvention, + Address, + IsShared, + CallMode, + MethodIndex, + OverCount, + i_IsAbstract, + i_AbstractMethodCount, + i_IsDeprecated); +end; + +function RegisterHeader(LevelId: Integer; + const Header: String; Address: Pointer; + MethodIndex: Integer = 0; Visibility: Integer = 0): Integer; +var + Id: Integer; + Vis: TClassVisibility; +begin + result := GlobalImportTable.RegisterHeader(LevelId, Header, Address, MethodIndex); + if (Visibility > 0) and (LevelId > 0) then + if GlobalImportTable[LevelId].Kind = KindTYPE then + begin + Id := GlobalImportTable.LastSubId; + Vis := cvNone; + if Visibility = 0 then + Vis := cvPublic + else if Visibility = 1 then + Vis := cvProtected + else if Visibility = 2 then + Vis := cvPrivate + else if Visibility = 3 then + Vis := cvPublished; + GlobalImportTable[Id].Vis := Vis; + end; +end; + +function RegisterFakeHeader(LevelId: Integer; + const Header: String; Address: Pointer): Integer; +begin + result := GlobalImportTable.RegisterFakeHeader(LevelId, Header, Address); +end; + +procedure RegisterRunnerParameter(HSub: Integer); +begin + GlobalImportTable.RegisterRunnerParameter(HSub); +end; + +function RegisterParameter(LevelId: Integer; + const ParameterName: String; + ParamTypeID: Integer; + ParamMod: Integer = 0; + Optional: Boolean = false; + const DefaultValue: String = ''): Integer; +begin + result := GlobalImportTable.RegisterParameter(LevelId, + ParameterName, + ParamTypeId, + ParamMod, + Optional, + DefaultValue); +end; + +function RegisterParameter(LevelId: Integer; + const ParameterName: String; + const ParameterType: String; + ParamMod: Integer = 0; + Optional: Boolean = false; + const DefaultValue: String = ''): Integer; +begin + result := GlobalImportTable.RegisterParameter(LevelId, + ParameterName, + ParameterType, + ParamMod, + Optional, + DefaultValue); +end; + +function RegisterParameter(LevelId: Integer; TypeId: Integer; ByRef: Boolean = false): Integer; +begin + result := GlobalImportTable.RegisterParameter(LevelId, TypeId, _Unassigned, ByRef); +end; + +function RegisterParameter(LevelId: Integer; TypeId: Integer; + const DefaultValue: Variant; ByRef: Boolean = false): Integer; +begin + result := GlobalImportTable.RegisterParameter(LevelId, TypeId, DefaultValue, ByRef); +end; + +function RegisterParameter(LevelId: Integer; + ParameterName: String; + TypeID: Integer; + const DefaultValue: Variant; + ByRef: Boolean): Integer; +begin + result := GlobalImportTable.RegisterParameter(LevelId, TypeId, DefaultValue, ByRef, ParameterName); +end; + +function RegisterParameterEx(LevelId: Integer; + ParameterName: String; + TypeID: Integer; + const DefaultValue: Variant; + ByRef: Boolean; + IsConst: Boolean): Integer; +begin + result := GlobalImportTable.RegisterParameter(LevelId, TypeId, DefaultValue, ByRef, ParameterName); + if IsConst then + GlobalImportTable[GlobalImportTable.Card].IsConst := true; +end; + +function RegisterParameterEx2(LevelId: Integer; ParameterName: String; TypeID: Integer; const DefaultValue: Variant; + ByRef, IsConst, IsOpenArray: Boolean): Integer; +Begin + Result := RegisterParameterEx(LevelId, ParameterName, TypeId, DefaultValue, ByRef, IsConst); + if IsOpenArray then + GlobalImportTable[GlobalImportTable.Card].IsOpenArray := True; +end; + +function RegisterClassType(LevelId: Integer; C: TClass; + DoRegisterClass: Boolean = false + ): Integer; +begin + if DoRegisterClass or MustRegisterClass then + if C.InheritsFrom(TPersistent) then + if Classes.GetClass(C.ClassName) = nil then + Classes.RegisterClass(TPersistentClass(C)); + + result := GlobalImportTable.RegisterClassType(LevelId, C); +end; + + +function RegisterClassType(LevelId: Integer; C: TClass; + DoRegisterClass: Boolean; + Reserved: Integer): Integer; +begin + if DoRegisterClass or MustRegisterClass then + if C.InheritsFrom(TPersistent) then + if Classes.GetClass(C.ClassName) = nil then + Classes.RegisterClass(TPersistentClass(C)); + + result := GlobalImportTable.RegisterClassType(LevelId, C, Reserved); +end; + +function RegisterClassTypeForImporter(LevelId: Integer; + C: TClass): Integer; +begin + result := GlobalImportTable.RegisterClassTypeForImporter(LevelId, C); +end; + +function RegisterInterfaceType(LevelId: Integer; + const TypeName: String; + const GUID: TGUID; + const ParentName: String; + const ParentGUID: TGUID): Integer; +begin + result := GlobalImportTable.RegisterInterfaceType(LevelId, TypeName, GUID); + GlobalImportTable.RegisterSupportedInterface(result, ParentName, ParentGUID); +end; + +function RegisterInterfaceType(LevelId: Integer; + const TypeName: String; + const GUID: TGUID): Integer; +begin + result := GlobalImportTable.RegisterInterfaceType(LevelId, TypeName, GUID); +end; + +procedure RegisterSupportedInterface(TypeId: Integer; + const SupportedInterfaceName: String; + const GUID: TGUID); +begin + GlobalImportTable.RegisterSupportedInterface(TypeId, SupportedInterfaceName, GUID); +end; + +function RegisterClassType(LevelId: Integer; + const TypeName: String; AncestorId: Integer): Integer; +begin + result := GlobalImportTable.RegisterClassType(LevelId, TypeName, AncestorId); +end; + +function RegisterClassType(LevelId: Integer; + const TypeName: String): Integer; +begin + result := GlobalImportTable.RegisterClassType(LevelId, TypeName, H_TObject); +end; + +procedure RegisterClassTypeInfos(ClassId: Integer; + C: TClass); +begin + GlobalImportTable.RegisterClassTypeInfos(ClassId, C); +end; + +function RegisterClassReferenceType(LevelId: Integer; + const TypeName: String; OriginClassId: Integer): Integer; +begin + result := GlobalImportTable.RegisterClassReferenceType(LevelId, TypeName, OriginClassId); +end; + +function RegisterClassReferenceType(LevelId: Integer; + const TypeName: String): Integer; +var + OriginClassId: Integer; + OriginTypeName: String; +begin + OriginTypeName := Copy(TypeName, 1, Length(TypeName) - 5); + OriginClassId := GlobalImportTable.LookUpType(OriginTypeName, 0, true); + if OriginClassId = 0 then + begin + result := 0; + RaiseError(errUndeclaredIdentifier, [OriginTypeName]); + Exit; + end; + result := GlobalImportTable.RegisterClassReferenceType(LevelId, TypeName, OriginClassId); +end; + +function RegisterClassReferenceType(LevelID: Integer; const TypeName, OriginalTypeName: String): Integer; overload; +var + OriginClassId: Integer; +begin + OriginClassId := GlobalImportTable.LookUpType(OriginalTypeName, 0, true); + if OriginClassId = 0 then + begin + result := 0; + RaiseError(errUndeclaredIdentifier, [OriginalTypeName]); + Exit; + end; + result := GlobalImportTable.RegisterClassReferenceType(LevelId, TypeName, OriginClassId); +end; + +function RegisterClassHelperType(LevelId: Integer; + const TypeName: String; OriginClassId: Integer): Integer; +begin + result := GlobalImportTable.RegisterHelperType(LevelId, TypeName, OriginClassId); +end; + +function RegisterClassHelperType(LevelID: Integer; const TypeName, OriginalTypeName: String): Integer; overload; +var + OriginClassId: Integer; +begin + OriginClassId := GlobalImportTable.LookUpType(OriginalTypeName, 0, true); + result := GlobalImportTable.RegisterHelperType(LevelId, TypeName, OriginClassId); +end; + +function RegisterRecordHelperType(LevelId: Integer; + const TypeName: String; OriginRecordId: Integer): Integer; +begin + result := GlobalImportTable.RegisterHelperType(LevelId, TypeName, OriginRecordId); +end; + +function RegisterRecordHelperType(LevelID: Integer; const TypeName, OriginalTypeName: String): Integer; overload; +var + OriginRecordId: Integer; +begin + OriginRecordId := GlobalImportTable.LookUpType(OriginalTypeName, 0, true); + result := GlobalImportTable.RegisterHelperType(LevelId, TypeName, OriginRecordId); +end; + +function RegisterClassTypeField(ClassTypeId: Integer; const Name: String; + TypeID: Integer; Offset: Integer = -1): Integer; +begin + result := GlobalImportTable.RegisterTypeField(ClassTypeId, Name, TypeId, Offset); +end; + +function RegisterClassTypeField(TypeId: Integer; const Declaration: String + ): Integer; +begin + result := GlobalImportTable.RegisterTypeFieldEx(TypeId, Declaration); +end; + +function RegisterProperty(LevelId: Integer; const PropName: String; + PropTypeID, ReadId, WriteId: Integer; + IsDefault: Boolean): Integer; +begin + result := GlobalImportTable.RegisterProperty(LevelId, PropName, + PropTypeId, ReadId, WriteId, IsDefault); +end; + +function RegisterInterfaceProperty(LevelId: Integer; + const PropName: String; + PropTypeID, + ReadIndex, + WriteIndex: Integer): Integer; +begin + result := GlobalImportTable.RegisterInterfaceProperty(LevelId, PropName, PropTypeId, + ReadIndex, WriteIndex); +end; + +function RegisterProperty(LevelId: Integer; const Header: String): Integer; +begin + result := GlobalImportTable.RegisterHeader(LevelId, Header, nil); +end; + +function RegisterRecordType(LevelId: Integer; + const TypeName: String; + IsPacked: Boolean = false): Integer; +begin + if IsPacked then + result := GlobalImportTable.RegisterRecordType(LevelId, TypeName, 1) + else + result := GlobalImportTable.RegisterRecordType(LevelId, TypeName, GlobalAlignment); +end; + +function RegisterDummyType(LevelId: Integer; + const TypeName: String): Integer; +begin + result := GlobalImportTable.RegisterDummyType(LevelId, TypeName); +end; + +function RegisterSomeType(LevelId: Integer; + const TypeName: String): Integer; +begin + result := GlobalImportTable.RegisterSomeType(LevelId, TypeName); +end; + +function LookupNamespace(LevelId: Integer; const NamespaceName: String; + CaseSensitive: Boolean): Integer; +begin + result := GlobalImportTable.LookupNamespace(NamespaceName, LevelId, not CaseSensitive); +end; + +function LookupNamespace(const NamespaceName: String): Integer; overload; +begin + result := LookupNamespace(0, NamespaceName, true); +end; + +function RegisterRecordTypeField(TypeId: Integer; const FieldName: String; + FieldTypeID: Integer; FieldOffset: Integer = -1): Integer; +begin + result := GlobalImportTable.RegisterTypeField(TypeId, FieldName, + FieldTypeId, FieldOffset); +end; + +function RegisterRecordTypeField(TypeId: Integer; const Declaration: String + ): Integer; +begin + result := GlobalImportTable.RegisterTypeFieldEx(TypeId, Declaration); +end; + +function RegisterVariantRecordTypeField(LevelId: Integer; const FieldName: String; + FieldTypeID: Integer; + VarCount: Int64): Integer; +begin + result := GlobalImportTable.RegisterVariantRecordTypeField(LevelId, + FieldName, + FieldTypeId, + VarCount); +end; + +function RegisterVariantRecordTypeField(LevelId: Integer; const Declaration: String; + VarCount: Int64): Integer; +begin + result := GlobalImportTable.RegisterVariantRecordTypeField(LevelId, + Declaration, VarCount); +end; + +function RegisterSubrangeType(LevelId: Integer; + const TypeName: String; + TypeBaseId: Integer; + B1, B2: Integer): Integer; +begin + result := GlobalImportTable.RegisterSubrangeType(LevelId, TypeName, TypeBaseId, B1, B2); +end; + +function RegisterTypeDeclaration(LevelId: Integer; + const Declaration: String): Integer; +begin + result := GlobalImportTable.RegisterTypeDeclaration(LevelId, Declaration); +end; + +function LookupTypeId(const TypeName: String): Integer; +begin +// result := GlobalImportTable.HeaderParser.LookupId(TypeName); + result := GlobalImportTable.LookupType(TypeName, true); +end; + +function LookupTypeNamespaceId(const TypeName: String): Integer; +var + R: TSymbolRec; + L, Id: Integer; +begin + result := 0; + Id := LookupTypeId(TypeName); + if Id = 0 then + Exit; + + L := GlobalImportTable[Id].Level; + + repeat + if L = 0 then + begin + result := 0; + Exit; + end; + + R := GlobalImportTable[L]; + + if R.Kind = kindNAMESPACE then + begin + result := R.Id; + Exit; + end; + + L := R.Level; + + until false; +end; + + +function RegisterEnumType(LevelId: Integer; + const TypeName: String; + TypeBaseId: Integer = _typeINTEGER): Integer; +begin + result := GlobalImportTable.RegisterEnumType(LevelId, TypeName, TypeBaseId); +end; + +function RegisterEnumValue(EnumTypeId: Integer; + const FieldName: String; + const Value: Integer): Integer; +begin + result := GlobalImportTable.RegisterEnumValue(EnumTypeId, FieldName, Value); +end; + +function RegisterArrayType(LevelId: Integer; + const TypeName: String; + RangeTypeId, ElemTypeId: Integer; + IsPacked: Boolean = false): Integer; +begin + if IsPacked then + result := GlobalImportTable.RegisterArrayType(LevelId, TypeName, RangeTypeId, ElemTypeId, 1) + else + result := GlobalImportTable.RegisterArrayType(LevelId, TypeName, RangeTypeId, ElemTypeId, GlobalAlignment); +end; + +function RegisterDynamicArrayType(LevelId: Integer; + const TypeName: String; + ElemTypeId: Integer): Integer; +begin + result := GlobalImportTable.RegisterDynamicArrayType(LevelId, TypeName, ElemTypeId); +end; + +function RegisterPointerType(LevelId: Integer; + const TypeName: String; + OriginTypeId: Integer; + const OriginTypeName: String = ''): Integer; +begin + result := GlobalImportTable.RegisterPointerType(LevelId, + TypeName, OriginTypeId, OriginTypeName); +end; + +function RegisterSetType(LevelId: Integer; + const TypeName: String; + OriginTypeId: Integer): Integer; +begin + result := GlobalImportTable.RegisterSetType(LevelId, TypeName, OriginTypeId); +end; + +function RegisterProceduralType(LevelId: Integer; + const TypeName: String; + SubId: Integer): Integer; +begin + result := GlobalImportTable.RegisterProceduralType(LevelId, TypeName, SubId); +end; + +function RegisterMethodReferenceType(LevelId: Integer; + const TypeName: String; + SubId: Integer): Integer; +begin + result := GlobalImportTable.RegisterMethodReferenceType(LevelId, TypeName, SubId); +end; + +{$IFNDEF PAXARM} +function RegisterShortStringType(LevelId: Integer; + const TypeName: String; + L: Integer): Integer; +begin + result := GlobalImportTable.RegisterShortStringType(LevelId, TypeName, L); +end; +{$ENDIF} + +function RegisterEventType(LevelId: Integer; + const TypeName: String; + SubId: Integer): Integer; +begin + result := GlobalImportTable.RegisterEventType(LevelId, TypeName, SubId); +end; + +function RegisterRTTIType(LevelId: Integer; pti: PTypeInfo): Integer; +begin + result := GlobalImportTable.RegisterRTTIType(LevelId, pti); +end; + +function RegisterTypeAlias(LevelId:Integer; const TypeName: String; + OriginTypeId: Integer): Integer; +begin + result := GlobalImportTable.RegisterTypeAlias(LevelId, TypeName, OriginTypeId); +end; + +function RegisterTypeAlias(LevelId:Integer; const TypeName, OriginTypeName: String): Integer; +begin + result := GlobalImportTable.RegisterTypeAlias(LevelId, TypeName, OriginTypeName); +end; + +function RegisterTypeAlias(LevelId:Integer; + const Declaration: String): Integer; +begin + result := GlobalImportTable.RegisterTypeAlias(LevelId, Declaration); +end; + +function RegisterSpace(K: Integer): Integer; +begin + result := GlobalImportTable.RegisterSpace(K); +end; + +procedure RegisterAlignment(value: Integer); +begin + GlobalAlignment := value; +end; + +procedure SetVisibility(C: TClass; const MemberName: String; value: Integer); overload; +begin + GlobalImportTable.SetVisibility(C, MemberName, value); +end; + +procedure SetVisibility(ClassId: integer; + const MemberName: String; value: Integer); overload; +begin + GlobalImportTable.SetVisibility(ClassId, MemberName, value); +end; + +procedure SaveNamespaceToStream(const NamespaceName: String; + S: TStream); +begin + GlobalImportTable.SaveNamespaceToStream(NamespaceName, S); +end; + +procedure SaveNamespaceToFile(const NamespaceName: String; + const FileName: String); +begin + GlobalImportTable.SaveNamespaceToFile(NamespaceName, FileName); +end; + +procedure LoadNamespaceFromStream(S: TStream); +begin + GlobalImportTable.LoadNamespaceFromStream(S); +end; + +procedure LoadNamespaceFromFile(const FileName: String); +begin + GlobalImportTable.LoadNamespaceFromFile(FileName); +end; + +{$O-} +procedure EndOfRegistration(CheckProc: TCheckProc; Data: Pointer); +var + I, J, L: Integer; + RI: TSymbolRec; + pti: PTypeInfo; + ptd: PTypeData; + C: TClass; + S, err: String; + LS: TStringList; + found: Boolean; +begin + GlobalImportTable.ResolveExternList(CheckProc, Data); +{$IFDEF DRTTI} + Exit; +{$ENDIF} + err := ''; + LS := TStringList.Create; + try + for I:=1 to GlobalImportTable.Card do + begin + RI := GlobalImportTable[I]; + if RI.Kind = kindTYPE then + RI.Completed := true + else + RI.Size; + if RI.FinalTypeId = typeCLASS then + begin + if I <= StdCard then + continue; + + C := RI.PClass; + if C = nil then + continue; + + pti := C.ClassInfo; + if pti = nil then + continue; + + ptd := GetTypeData(pti); + if ptd = nil then + continue; + L := RI.Level; + if L > 0 then + S := GlobalImportTable[L].Name + else + S := ''; + if not StrEql(S, StringFromPShortString(PShortString(@ptd^.UnitName))) then + begin + err := RI.Name + '(' + StringFromPShortString(PShortString(@ptd^.UnitName)) + ')' + + errWrongRegistration + '-' + S; + found := false; + for J := 0 to LS.Count - 1 do + if StrEql(LS[J], err) then + begin + found := true; + break; + end; + if not found then + LS.Add(err); + end; + end; + end; + + err := ''; + for J := 0 to LS.Count - 1 do + err := err + LS[J] + #13#10; + + finally + FreeAndNil(LS); + end; + + if err <> '' then + RaiseError(errWrongRegistration + ':' + err, []); +end; + +procedure EndOfRegistration; +begin + EndOfRegistration(nil, nil); +end; + +procedure ForbidClass(C: TClass); +begin + GlobalImportTable.HideClass(C); +end; + +function CreateNewImportTable: Pointer; +var + st: TBaseSymbolTable; +begin + st := TBaseSymbolTable.Create; + AddStdRoutines(st); + result := st; + GlobalExtraImportTableList.Add(st); +end; + +procedure SetImportTable(ImportTable: Pointer); +begin + if ImportTable = nil then + GlobalImportTable := GlobalSymbolTable + else + GlobalImportTable := ImportTable; +end; + +procedure DestroyImportTable(var ImportTable: Pointer); +begin + GlobalExtraImportTableList.Remove(ImportTable); + ImportTable := nil; +end; + +function LoadImportLibrary(const DllName: String): Cardinal; +var + P: TRegisterDllProc; + R: TRegisterProcRec; +begin + R.RegisterNamespace := RegisterNamespace; + R.RegisterConstant := RegisterConstant; + R.RegisterVariable := RegisterVariable; + R.RegisterHeader := RegisterHeader; + R.RegisterProperty := RegisterProperty; + + R.RegisterClassType := RegisterClassType; + R.RegisterClassTypeField := RegisterClassTypeField; + + R.RegisterClassReferenceType := RegisterClassReferenceType; + + R.RegisterRecordType := RegisterRecordType; + R.RegisterRecordTypeField := RegisterRecordTypeField; + R.RegisterVariantRecordTypeField := RegisterVariantRecordTypeField; + + R.RegisterEnumType := RegisterEnumType; + R.RegisterEnumValue:= RegisterEnumValue; + + R.RegisterSubrangeType := RegisterSubrangeType; + R.RegisterArrayType := RegisterArrayType; + R.RegisterDynamicArrayType := RegisterDynamicArrayType; + R.RegisterPointerType := RegisterPointerType; + R.RegisterSetType := RegisterSetType; + R.RegisterProceduralType := RegisterProceduralType; + R.RegisterEventType := RegisterEventType; +{$IFNDEF PAXARM} + R.RegisterShortStringType := RegisterShortStringType; +{$ENDIF} + R.RegisterRTTIType := RegisterRTTIType; + R.RegisterTypeAlias := RegisterTypeAlias; + +{$IFDEF FPC} + result := HMODULE(dynlibs.LoadLibrary(DLLName)); +{$ELSE} + result := LoadLibrary(PChar(DllName)); +{$ENDIF} + if result > 0 then + begin + P := GetProcAddress(result, 'RegisterDllProcs'); + if not Assigned(P) then + begin + result := 0; + Exit; + end; + + P(R); + end; +end; + +function FreeImportLibrary(H: Cardinal): LongBool; +begin + result := FreeLibrary(H); +end; + +function SetImportEntry(K: Integer): Integer; +begin + result := GlobalImportTable.Card; + GlobalImportTable.RestoreState(K); +end; + +function GetImportEntry: Integer; +begin + result := GlobalImportTable.Card; + GlobalImportTable.SaveState; +end; + +procedure LoadGlobalSymbolTableFromStream(Stream: TStream); +begin + GlobalImportTable.LoadGlobalSymbolTableFromStream(Stream); +end; + +procedure LoadGlobalSymbolTableFromFile(const FileName: String); +begin + GlobalImportTable.LoadGlobalSymbolTableFromFile(FileName); +end; + +procedure SaveGlobalSymbolTableToStream(Stream: TStream); +begin + GlobalImportTable.SaveGlobalSymbolTableToStream(Stream); +end; + +procedure SaveGlobalSymbolTableToFile(const FileName: String); +begin + GlobalImportTable.SaveGlobalSymbolTableToFile(FileName); +end; + +function FindNextVirtualMethodAddress(C: TClass; PrevAddress: Pointer): Pointer; +begin + result := paxcomp_sys.FindNextVirtualMethodAddress(C, PrevAddress); +end; + +function RenameClassType(C: TClass; const NewName: String): Boolean; +var + Id: Integer; +begin + result := false; + Id := LookupTypeId(C.ClassName); + if Id > 0 then + begin + result := true; + ForbidClass(C); + GlobalImportTable[Id].Name := NewName; + end; +end; + +procedure EndOfStructuredType(Id: Integer); +begin + GlobalImportTable[Id].Completed := true; +end; + +{$ifdef DRTTI} +function RegisterRTTIRecordType(Level: Integer; t: TRTTIRecordType): Integer; +begin + result := PAXCOMP_2010Reg.RegisterRecordType(Level, t, GlobalImportTable); +end; + +function RegisterRTTIClassType(Level: Integer; t: TRTTIInstanceType): Integer; +begin + result := PAXCOMP_2010Reg.RegisterClassType(Level, t, GlobalImportTable); +end; + +function RegisterRTTIInterfaceType(Level: Integer; t: TRTTIInterfaceType): Integer; +begin + result := PAXCOMP_2010Reg.RegisterInterfaceType(Level, t, GlobalImportTable); +end; + +{$endif} + + +end. diff --git a/Sources/PaxRunner.pas b/Sources/PaxRunner.pas new file mode 100644 index 0000000..31cbe8c --- /dev/null +++ b/Sources/PaxRunner.pas @@ -0,0 +1,1261 @@ +//////////////////////////////////////////////////////////////////////////// +// PaxCompiler +// Site: http://www.paxcompiler.com +// Author: Alexander Baranovsky (paxscript@gmail.com) +// ======================================================================== +// Copyright (c) Alexander Baranovsky, 2006-2014. All rights reserved. +// Code Version: 4.2 +// ======================================================================== +// Unit: PaxRunner.pas +// ======================================================================== +//////////////////////////////////////////////////////////////////////////// + +{$I PaxCompiler.def} +unit PaxRunner; +interface +uses + TypInfo, + SysUtils, + Classes, + PaxInfos, + PAXCOMP_CONSTANTS, + PAXCOMP_SYS, + PAXCOMP_MAP, + PAXCOMP_RTI, + PAXCOMP_BASERUNNER, + PaxInvoke; + +const + _rmRUN = 0; + _rmTRACE_INTO = 1; + _rmSTEP_OVER = 2; + _rmRUN_TO_CURSOR = 3; + _rmNEXT_SOURCE_LINE = 4; + +type + TPaxRunner = class; + + TPaxPauseNotifyEvent = procedure (Sender: TPaxRunner; + const ModuleName: String; SourceLineNumber: Integer) of object; + + TPaxHaltNotifyEvent = procedure (Sender: TPaxRunner; ExitCode: Integer; + const ModuleName: String; SourceLineNumber: Integer) of object; + + TPaxErrNotifyEvent = procedure (Sender: TPaxRunner; E: Exception; + const ModuleName: String; SourceLineNumber: Integer) of object; + + TPaxLoadProcEvent = procedure (Sender: TPaxRunner; + const ProcName, DllName: String; var Address: Pointer) of object; + + TPaxObjectNotifyEvent = procedure (Sender: TPaxRunner; + Instance: TObject) of object; + + TPaxIdNotifyEvent = procedure (Sender: TPaxRunner; + Id: Integer) of object; + + TPaxClassNotifyEvent = procedure (Sender: TPaxRunner; + C: TClass) of object; + + TPaxMapTableNamespaceEvent = procedure (Sender: TPaxRunner; + const FullName: String; + Global: Boolean) of object; + + TPaxMapTableVarAddressEvent = procedure (Sender: TPaxRunner; + const FullName: String; Global: Boolean; var Address: Pointer) of object; + TPaxMapTableProcAddressEvent = procedure (Sender: TPaxRunner; + const FullName: String; OverCount: Byte; + Global: Boolean; var Address: Pointer) of object; + + TPaxMapTableClassRefEvent = procedure (Sender: TPaxRunner; + const FullName: String; + Global: Boolean; var ClassRef: TClass) of object; + + TPaxPrintEvent = procedure (Sender: TPaxRunner; + const Text: String) of object; + TPaxPrintExEvent = procedure (Sender: TPaxRunner; + Address: Pointer; + Kind: Integer; + FT: Integer; + L1, L2: Integer) of object; + TPaxPrintClassTypeFieldEvent = procedure (Sender: TPaxRunner; + const Infos: TPrintClassTypeFieldInfo) + of object; + TPaxPrintClassTypePropEvent = procedure (Sender: TPaxRunner; + const Infos: TPrintClassTypePropInfo) + of object; + + TPaxCustomExceptionHelperEvent = procedure (Sender: TPaxRunner; + RaisedException, DestException: Exception) + of object; + + TPaxRunnerLoadPCUEvent = procedure (Sender: TPaxRunner; const UnitName: String; + var result: TStream) of object; + + TPaxStreamEvent = procedure (Sender: TPaxRunner; Stream: TStream) of object; + TPaxProcNotifyEvent = procedure (Sender: TPaxRunner; + const FullName: String; OverCount: Byte) of object; + + TPaxVirtualObjectMethodCallEvent = procedure(Sender: TPaxRunner; const ObjectName, + PropName: String; const Params: array of Variant; var result: Variant) of object; + TPaxVirtualObjectPutPropertyEvent = procedure(Sender: TPaxRunner; const ObjectName, + PropName: String; const Params: array of Variant; const value: Variant) of object; + + TPaxRunner = class(TComponent) + private + prog: TBaseRunner; + function GetSourceLine: Integer; + function GetModuleName: String; + function GetDataPtr: Pointer; + function GetCodePtr: Pointer; + function GetDataSize: Integer; + function GetCodeSize: Integer; + function GetProgramSize: Integer; + function GetResultPtr: Pointer; + function GetPCUCount: Integer; + function GetSearchPathList: TStringList; + + function GetRunMode: Integer; + procedure SetRunMode(value: Integer); + + function GetConsole: Boolean; + procedure SetConsole(value: Boolean); + + function GetOnPause: TPaxPauseNotifyEvent; + procedure SetOnPause(value: TPaxPauseNotifyEvent); + + function GetOnPauseUpdated: TPaxPauseNotifyEvent; + procedure SetOnPauseUpdated(value: TPaxPauseNotifyEvent); + + function GetOnHalt: TPaxHaltNotifyEvent; + procedure SetOnHalt(value: TPaxHaltNotifyEvent); + + function GetOnException: TPaxErrNotifyEvent; + procedure SetOnException(value: TPaxErrNotifyEvent); + + function GetOnUnhandledException: TPaxErrNotifyEvent; + procedure SetOnUnhandledException(value: TPaxErrNotifyEvent); + + function GetOnLoadProc: TPaxLoadProcEvent; + procedure SetOnLoadProc(value: TPaxLoadProcEvent); + + function GetOnBeforeCallHost: TPaxIdNotifyEvent; + procedure SetOnBeforeCallHost(value: TPaxIdNotifyEvent); + + function GetOnAfterCallHost: TPaxIdNotifyEvent; + procedure SetOnAfterCallHost(value: TPaxIdNotifyEvent); + + function GetOnCreateObject: TPaxObjectNotifyEvent; + procedure SetOnCreateObject(value: TPaxObjectNotifyEvent); + + function GetOnAfterObjectCreation: TPaxObjectNotifyEvent; + procedure SetOnAfterObjectCreation(value: TPaxObjectNotifyEvent); + + function GetOnAfterObjectDestruction: TPaxClassNotifyEvent; + procedure SetOnAfterObjectDestruction(value: TPaxClassNotifyEvent); + + function GetOnDestroyObject: TPaxObjectNotifyEvent; + procedure SetOnDestroyObject(value: TPaxObjectNotifyEvent); + + function GetOnCreateHostObject: TPaxObjectNotifyEvent; + procedure SetOnCreateHostObject(value: TPaxObjectNotifyEvent); + + function GetOnDestroyHostObject: TPaxObjectNotifyEvent; + procedure SetOnDestroyHostObject(value: TPaxObjectNotifyEvent); + + function GetOnMapTableNamespace: TPaxMapTableNamespaceEvent; + procedure SetOnMapTableNamespace(value: TPaxMapTableNamespaceEvent); + + function GetOnMapTableVarAddress: TPaxMapTableVarAddressEvent; + procedure SetOnMapTableVarAddress(value: TPaxMapTableVarAddressEvent); + + function GetOnMapTableProcAddress: TPaxMapTableProcAddressEvent; + procedure SetOnMapTableProcAddress(value: TPaxMapTableProcAddressEvent); + + function GetOnMapTableClassRef: TPaxMapTableClassRefEvent; + procedure SetOnMapTableClassRef(value: TPaxMapTableClassRefEvent); + + function GetOnPrint: TPaxPrintEvent; + procedure SetOnPrint(value: TPaxPrintEvent); + + function GetOnPrintEx: TPaxPrintExEvent; + procedure SetOnPrintEx(value: TPaxPrintExEvent); + + function GetCustomExceptionHelper: TPaxCustomExceptionHelperEvent; + procedure SetCustomExceptionHelper(value: TPaxCustomExceptionHelperEvent); + + function GetOnLoadPCU: TPaxRunnerLoadPCUEvent; + procedure SetOnLoadPCU(value: TPaxRunnerLoadPCUEvent); + + function GetOnStreamSave: TPaxStreamEvent; + procedure SetOnStreamSave(value: TPaxStreamEvent); + + function GetOnStreamLoad: TPaxStreamEvent; + procedure SetOnStreamLoad(value: TPaxStreamEvent); + + function GetOnBeginProcNotify: TPaxProcNotifyEvent; + procedure SetOnBeginProcNotify(value: TPaxProcNotifyEvent); + + function GetOnEndProcNotify: TPaxProcNotifyEvent; + procedure SetOnEndProcNotify(value: TPaxProcNotifyEvent); + + function GetOnVirtualObjectMethodCall: TPaxVirtualObjectMethodCallEvent; + procedure SetOnVirtualObjectMethodCall(value: TPaxVirtualObjectMethodCallEvent); + + function GetOnVirtualObjectPutProperty: TPaxVirtualObjectPutPropertyEvent; + procedure SetOnVirtualObjectPutProperty(value: TPaxVirtualObjectPutPropertyEvent); + + function GetExitCode: Integer; + function GetIsEvent: Boolean; + procedure SetSuspendFinalization(value: Boolean); + function GetSuspendFinalization: Boolean; + + function GetPausedPCU: TBaseRunner; + procedure SetPausedPCU(value: TBaseRunner); + + function GetPrintClassTypeField: TPaxPrintClassTypeFieldEvent; + procedure SetPrintClassTypeField(value: TPaxPrintClassTypeFieldEvent); + + function GetPrintClassTypeProp: TPaxPrintClassTypePropEvent; + procedure SetPrintClassTypeProp(value: TPaxPrintClassTypePropEvent); + + function GetPCUUnit(I: Integer): TBaseRunner; + protected + function GetRunnerClass: TBaseRunnerClass; virtual; + public + EmitProc: TEmitProc; + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + procedure Run; + function GetProgPtr: TBaseRunner; + procedure RunInitialization; + procedure RunFinalization; + procedure Pause; + function IsPaused: Boolean; + function IsRunning: Boolean; + procedure Resume; + procedure RegisterClass(C: TClass; const FullName: String = ''); + procedure SaveToBuff(var Buff); + procedure LoadFromBuff(var Buff); + procedure SaveToStream(S: TStream); + procedure LoadFromStream(S: TStream); + procedure SaveToFile(const Path: String); + procedure LoadFromFile(const Path: String); + function GetAddress(Handle: Integer): Pointer; overload; + function GetAddress(const FullName: String): Pointer; overload; + function GetAddressEx(const FullName: String; OverCount: Integer): Pointer; overload; + function GetAddressEx(const FullName: String): Pointer; overload; + function GetAddress(const FullName: String; OverCount: Integer): Pointer; overload; + procedure SetAddress(Handle: Integer; P: Pointer); + function SetHostAddress(const FullName: String; Address: Pointer): Boolean; + function GetFieldAddress(X: TObject; const FieldName: String): Pointer; + function GetCallConv(const FullName: String): Integer; + function GetRetSize(const FullName: String): Integer; +{$IFDEF PAXARM} +{$ELSE} + procedure SetEntryPoint(EntryPoint: TPaxInvoke); + procedure ResetEntryPoint(EntryPoint: TPaxInvoke); +{$ENDIF} + procedure CreateGlobalJSObjects; + procedure DiscardPause; + function GetImageSize: Integer; + procedure DiscardDebugMode; + procedure AssignEventHandlerRunner(MethodAddress: Pointer; + Instance: TObject); + function RegisterNamespace(LevelId: Integer; const Name: String): Integer; + function RegisterClassType(LevelId: Integer; C: TClass): Integer; + procedure RegisterMember(LevelId: Integer; const Name: String; + Address: Pointer); + procedure MapGlobal; + procedure MapLocal; + function CreateScriptObject(const ScriptClassName: String; + const ParamList: array of const): TObject; + procedure DestroyScriptObject(X: TObject); + procedure LoadDFMFile(Instance: TObject; const FileName: String); + procedure LoadDFMStream(Instance: TObject; S: TStream); + function GetTypeInfo(const FullTypeName: String): PTypeInfo; + function CallRoutine(const FullName: String; + const ParamList: array of OleVariant): OleVariant; + function CallMethod(const FullName: String; + Instance: TObject; + const ParamList: array of OleVariant): OleVariant; + function CallClassMethod(const FullName: String; + Instance: TClass; + const ParamList: array of OleVariant): OleVariant; + procedure UnloadPCU(const FullPath: String); + procedure LoadPCU(const FileName: String); + function GetExceptionRecord: Pointer; + function AddBreakpoint(const ModuleName: String; + SourceLineNumber: Integer): Boolean; + function AddTempBreakpoint(const ModuleName: String; + SourceLineNumber: Integer): Boolean; + function RemoveBreakpoint(const ModuleName: String; + SourceLineNumber: Integer): Boolean; overload; + function RemoveBreakpoint(const ModuleName: String): Boolean; overload; + function HasBreakpoint(const ModuleName: String; + SourceLineNumber: Integer): Boolean; + function IsExecutableLine(const ModuleName: String; + SourceLineNumber: Integer): Boolean; + procedure RemoveAllBreakpoints; + function GetCurrentFunctionFullName: String; + procedure GetCurrentParams(result: TStrings); + procedure GetCurrentLocalVars(result: TStrings); + function HasPCU(const ModuleName: String): Boolean; + + property DataPtr: Pointer read GetDataPtr; + property CodePtr: Pointer read GetCodePtr; + property DataSize: Integer read GetDataSize; + property CodeSize: Integer read GetCodeSize; + property ProgramSize: Integer read GetProgramSize; + property ImageSize: Integer read GetImageSize; + property ResultPtr: Pointer read GetResultPtr; + property ExitCode: Integer read GetExitCode; + property IsEvent: Boolean read GetIsEvent; + property SourceLine: Integer read GetSourceLine; + property ModuleName: String read GetModuleName; + property SuspendFinalization: Boolean + read GetSuspendFinalization write SetSuspendFinalization; + property RunMode: Integer read GetRunMode write SetRunMode; + property PCUCount: Integer read GetPCUCount; + property PausedPCU: TBaseRunner read GetPausedPCU write SetPausedPCU; + property PCUUnits[I: Integer]: TBaseRunner read GetPCUUnit; + property SearchPathList: TStringList read GetSearchPathList; + published + + property Console: boolean read GetConsole write SetConsole; + + property OnPause: TPaxPauseNotifyEvent read GetOnPause write SetOnPause; + property OnPauseUpdated: TPaxPauseNotifyEvent read GetOnPauseUpdated write SetOnPauseUpdated; + property OnHalt: TPaxHaltNotifyEvent read GetOnHalt write SetOnHalt; + property OnException: TPaxErrNotifyEvent read GetOnException write SetOnException; + property OnUnhandledException: TPaxErrNotifyEvent read GetOnUnhandledException + write SetOnUnhandledException; + property OnLoadProc: TPaxLoadProcEvent read GetOnLoadProc + write SetOnLoadProc; + + property OnCreateObject: TPaxObjectNotifyEvent read GetOnCreateObject + write SetOnCreateObject; + + property OnAfterObjectCreation: TPaxObjectNotifyEvent read GetOnAfterObjectCreation + write SetOnAfterObjectCreation; + + property OnDestroyObject: TPaxObjectNotifyEvent read GetOnDestroyObject + write SetOnDestroyObject; + + property OnCreateHostObject: TPaxObjectNotifyEvent read GetOnCreateHostObject + write SetOnCreateHostObject; + property OnDestroyHostObject: TPaxObjectNotifyEvent read GetOnDestroyHostObject + write SetOnDestroyHostObject; + + property OnAfterObjectDestruction: TPaxClassNotifyEvent read GetOnAfterObjectDestruction + write SetOnAfterObjectDestruction; + + property OnMapTableNamespace: TPaxMapTableNamespaceEvent read GetOnMapTableNamespace + write SetOnMapTableNamespace; + property OnMapTableVarAddress: TPaxMapTableVarAddressEvent read GetOnMapTableVarAddress + write SetOnMapTableVarAddress; + property OnMapTableProcAddress: TPaxMapTableProcAddressEvent read GetOnMapTableProcAddress + write SetOnMapTableProcAddress; + property OnMapTableClassRef: TPaxMapTableClassRefEvent read GetOnMapTableClassRef + write SetOnMapTableClassRef; + + property OnPrintEvent: TPaxPrintEvent read GetOnPrint + write SetOnPrint; + property OnPrintEx: TPaxPrintExEvent read GetOnPrintEx + write SetOnPrintEx; + property OnPrintClassTypeField: TPaxPrintClassTypeFieldEvent + read GetPrintClassTypeField write SetPrintClassTypeField; + + property OnPrintClassTypeProp: TPaxPrintClassTypePropEvent + read GetPrintClassTypeProp write SetPrintClassTypeProp; + + property OnCustomExceptionHelperEvent: TPaxCustomExceptionHelperEvent + read GetCustomExceptionHelper + write SetCustomExceptionHelper; + + property OnLoadPCU: TPaxRunnerLoadPCUEvent + read GetOnLoadPCU write SetOnLoadPCU; + + property OnSaveToStream: TPaxStreamEvent + read GetOnStreamSave write SetOnStreamSave; + property OnLoadFromStream: TPaxStreamEvent + read GetOnStreamLoad write SetOnStreamLoad; + property OnBeginProc: TPaxProcNotifyEvent + read GetOnBeginProcNotify write SetOnBeginProcNotify; + property OnEndProc: TPaxProcNotifyEvent + read GetOnEndProcNotify write SetOnEndProcNotify; + property OnVirtualObjectMethodCall: TPaxVirtualObjectMethodCallEvent + read GetOnVirtualObjectMethodCall write SetOnVirtualObjectMethodCall; + property OnVirtualObjectPutProperty: TPaxVirtualObjectPutPropertyEvent + read GetOnVirtualObjectPutProperty write SetOnVirtualObjectPutProperty; + + property OnBeforeCallHost: TPaxIdNotifyEvent read GetOnBeforeCallHost + write SetOnBeforeCallHost; + + property OnAfterCallHost: TPaxIdNotifyEvent read GetOnAfterCallHost + write SetOnAfterCallHost; + end; + + TPaxRunnerClass = class of TPaxRunner; + +function ScalarValueToString(Address: Pointer; T: Integer): String; + +implementation + +// TPaxRunner ----------------------------------------------------------------- + +constructor TPaxRunner.Create(AOwner: TComponent); +begin + inherited; + prog := GetRunnerClass.Create; + prog.Owner := Self; +end; + +destructor TPaxRunner.Destroy; +begin + FreeAndNil(prog); + inherited; +end; + +function TPaxRunner.GetRunnerClass: TBaseRunnerClass; +begin + result := nil; +end; + +procedure TPaxRunner.Run; +begin + prog.RunExtended; +end; + +procedure TPaxRunner.RunInitialization; +begin + prog.RunInitialization; +end; + +procedure TPaxRunner.RunFinalization; +begin + prog.RunFinalization; +end; + +procedure TPaxRunner.Pause; +begin + prog.Pause; +end; + +function TPaxRunner.IsPaused: Boolean; +begin + result := prog.IsPaused; +end; + +function TPaxRunner.IsRunning: Boolean; +begin + result := prog.IsRunning; +end; + +procedure TPaxRunner.Resume; +begin + prog.Run; +end; + +procedure TPaxRunner.DiscardPause; +begin + prog.DiscardPause; +end; + +procedure TPaxRunner.SaveToBuff(var Buff); +begin + prog.SaveToBuff(Buff); +end; + +procedure TPaxRunner.LoadFromBuff(var Buff); +begin + prog.LoadFromBuff(Buff); +end; + +procedure TPaxRunner.SaveToStream(S: TStream); +begin + prog.SaveToStream(S); +end; + +procedure TPaxRunner.LoadFromStream(S: TStream); +begin + prog.LoadFromStream(S); +end; + +procedure TPaxRunner.SaveToFile(const Path: String); +begin + prog.SaveToFile(path); +end; + +procedure TPaxRunner.LoadFromFile(const Path: String); +begin + prog.LoadFromFile(path); +end; + +function TPaxRunner.GetAddress(Handle: Integer): Pointer; +var + MR: TMapRec; +begin + result := prog.GetAddress(Handle); + if not NativeAddress(result) then + begin + MR := prog.ScriptMapTable.LookupByOffset(-Handle); + if MR = nil then + result := nil + else if MR.IsMethod then + prog.WrapMethodAddress(result) + else if MR.Kind = KindSUB then + prog.WrapGlobalAddress(result); + end; +end; + +function TPaxRunner.GetAddress(const FullName: String): Pointer; +var + MR: TMapRec; + S, MethName: String; + I: Integer; + C: TClass; +begin + result := prog.GetAddress(FullName, MR); + if result <> nil then + begin + if MR.IsMethod then + prog.WrapMethodAddress(result) + else if MR.Kind = KindSUB then + prog.WrapGlobalAddress(result); + Exit; + end; + S := ExtractClassName(FullName); + if S = '' then + Exit; + I := prog.ClassList.IndexOf(S); + if I = -1 then + Exit; + C := prog.ClassList[I].PClass.ClassParent; + if C = nil then + Exit; + MethName := ExtractName(FullName); + result := GetAddress(C.ClassName + '.' + MethName); + prog.WrapMethodAddress(result); +end; + +function TPaxRunner.GetAddress(const FullName: String; OverCount: Integer): Pointer; +var + MR: TMapRec; + S, MethName: String; + I: Integer; + C: TClass; +begin + result := prog.GetAddressEx(FullName, OverCount, MR); + if result <> nil then + begin + if MR.IsMethod then + prog.WrapMethodAddress(result) + else if MR.Kind = KindSUB then + prog.WrapGlobalAddress(result); + Exit; + end; + S := ExtractClassName(FullName); + if S = '' then + Exit; + I := prog.ClassList.IndexOf(S); + if I = -1 then + Exit; + C := prog.ClassList[I].PClass.ClassParent; + if C = nil then + Exit; + MethName := ExtractName(FullName); + result := GetAddress(C.ClassName + '.' + MethName, OverCount); + prog.WrapMethodAddress(result); +end; + +function TPaxRunner.GetAddressEx(const FullName: String): Pointer; +var + MR: TMapRec; +begin + result := prog.GetAddressExtended(FullName, MR); + if MR = nil then + Exit; + if MR.IsMethod then + prog.WrapMethodAddress(result) + else if MR.Kind = KindSUB then + prog.WrapGlobalAddress(result); +end; + +function TPaxRunner.GetAddressEx(const FullName: String; OverCount: Integer): Pointer; +var + MR: TMapRec; +begin + result := prog.GetAddressExtended(FullName, OverCount, MR); + if MR = nil then + Exit; + if MR.IsMethod then + prog.WrapMethodAddress(result) + else if MR.Kind = KindSUB then + prog.WrapGlobalAddress(result); +end; + +function TPaxRunner.GetCallConv(const FullName: String): Integer; +begin + result := prog.GetCallConv(FullName); +end; + +function TPaxRunner.GetRetSize(const FullName: String): Integer; +begin + result := prog.GetRetSize(FullName); +end; + +procedure TPaxRunner.SetAddress(Handle: Integer; P: Pointer); +var + Offset: Integer; +begin + Offset := prog.GetOffset(Handle); + if Offset = -1 then + Exit; + + prog.SetAddress(Offset, P); +end; + +function TPaxRunner.SetHostAddress(const FullName: String; Address: Pointer): Boolean; +begin + result := prog.SetHostAddress(FullName, Address); +end; + +function TPaxRunner.GetResultPtr: Pointer; +begin + result := prog.ResultPtr; +end; + +function TPaxRunner.GetDataPtr: Pointer; +begin + result := prog.DataPtr; +end; + +function TPaxRunner.GetCodePtr: Pointer; +begin + result := prog.CodePtr; +end; + +function TPaxRunner.GetDataSize: Integer; +begin + result := prog.DataSize; +end; + +function TPaxRunner.GetCodeSize: Integer; +begin + result := prog.CodeSize; +end; + +function TPaxRunner.GetProgramSize: Integer; +begin + result := prog.ProgramSize; +end; + +procedure TPaxRunner.RegisterClass(C: TClass; const FullName: String = ''); +begin + if FullName = '' then + prog.RegisterClass(C, C.ClassName) + else + prog.RegisterClass(C, FullName); +end; + +function TPaxRunner.GetProgPtr: TBaseRunner; +begin + result := prog; +end; + +function TPaxRunner.GetOnPause: TPaxPauseNotifyEvent; +begin + result := TPaxPauseNotifyEvent(prog.OnPause); +end; + +procedure TPaxRunner.SetOnPause(value: TPaxPauseNotifyEvent); +begin + prog.OnPause := TPauseNotifyEvent(value); +end; + +function TPaxRunner.GetOnPauseUpdated: TPaxPauseNotifyEvent; +begin + result := TPaxPauseNotifyEvent(prog.OnPauseUpdated); +end; + +procedure TPaxRunner.SetOnPauseUpdated(value: TPaxPauseNotifyEvent); +begin + prog.OnPauseUpdated := TPauseNotifyEvent(value); +end; + +function TPaxRunner.GetOnBeforeCallHost: TPaxIdNotifyEvent; +begin + result := TPaxIdNotifyEvent(prog.OnBeforeCallHost); +end; + +procedure TPaxRunner.SetOnBeforeCallHost(value: TPaxIdNotifyEvent); +begin + prog.OnBeforeCallHost := TIdNotifyEvent(value); +end; + +function TPaxRunner.GetOnAfterCallHost: TPaxIdNotifyEvent; +begin + result := TPaxIdNotifyEvent(prog.OnAfterCallHost); +end; + +procedure TPaxRunner.SetOnAfterCallHost(value: TPaxIdNotifyEvent); +begin + prog.OnAfterCallHost := TIdNotifyEvent(value); +end; + +function TPaxRunner.GetOnCreateObject: TPaxObjectNotifyEvent; +begin + result := TPaxObjectNotifyEvent(prog.OnCreateObject); +end; + +procedure TPaxRunner.SetOnCreateObject(value: TPaxObjectNotifyEvent); +begin + prog.OnCreateObject := TObjectNotifyEvent(value); +end; + +function TPaxRunner.GetOnAfterObjectCreation: TPaxObjectNotifyEvent; +begin + result := TPaxObjectNotifyEvent(prog.OnAfterObjectCreation); +end; + +procedure TPaxRunner.SetOnAfterObjectCreation(value: TPaxObjectNotifyEvent); +begin + prog.OnAfterObjectCreation := TObjectNotifyEvent(value); +end; + +function TPaxRunner.GetOnAfterObjectDestruction: TPaxClassNotifyEvent; +begin + result := TPaxClassNotifyEvent(prog.OnAfterObjectDestruction); +end; + +procedure TPaxRunner.SetOnAfterObjectDestruction(value: TPaxClassNotifyEvent); +begin + prog.OnAfterObjectDestruction := TClassNotifyEvent(value); +end; + +function TPaxRunner.GetOnDestroyObject: TPaxObjectNotifyEvent; +begin + result := TPaxObjectNotifyEvent(prog.OnDestroyObject); +end; + +procedure TPaxRunner.SetOnDestroyObject(value: TPaxObjectNotifyEvent); +begin + prog.OnDestroyObject := TObjectNotifyEvent(value); +end; + +function TPaxRunner.GetOnCreateHostObject: TPaxObjectNotifyEvent; +begin + result := TPaxObjectNotifyEvent(prog.OnCreateHostObject); +end; + +procedure TPaxRunner.SetOnCreateHostObject(value: TPaxObjectNotifyEvent); +begin + prog.OnCreateHostObject := TObjectNotifyEvent(value); +end; + +function TPaxRunner.GetOnDestroyHostObject: TPaxObjectNotifyEvent; +begin + result := TPaxObjectNotifyEvent(prog.OnDestroyHostObject); +end; + +procedure TPaxRunner.SetOnDestroyHostObject(value: TPaxObjectNotifyEvent); +begin + prog.OnDestroyHostObject := TObjectNotifyEvent(value); +end; + +function TPaxRunner.GetOnHalt: TPaxHaltNotifyEvent; +begin + result := TPaxHaltNotifyEvent(prog.OnHalt); +end; + +procedure TPaxRunner.SetOnHalt(value: TPaxHaltNotifyEvent); +begin + prog.OnHalt := THaltNotifyEvent(value); +end; + +function TPaxRunner.GetOnLoadProc: TPaxLoadProcEvent; +begin + result := TPaxLoadProcEvent(prog.OnLoadProc); +end; + +procedure TPaxRunner.SetOnLoadProc(value: TPaxLoadProcEvent); +begin + prog.OnLoadProc := TLoadProcEvent(value); +end; + +function TPaxRunner.GetOnPrint: TPaxPrintEvent; +begin + result := TPaxPrintEvent(prog.OnPrint); +end; + +procedure TPaxRunner.SetOnPrint(value: TPaxPrintEvent); +begin + prog.OnPrint := TPrintEvent(value); +end; + +function TPaxRunner.GetOnPrintEx: TPaxPrintExEvent; +begin + result := TPaxPrintExEvent(prog.OnPrintEx); +end; + +procedure TPaxRunner.SetOnPrintEx(value: TPaxPrintExEvent); +begin + prog.OnPrintEx := TPrintExEvent(value); +end; + +function TPaxRunner.GetCustomExceptionHelper: TPaxCustomExceptionHelperEvent; +begin + result := TPaxCustomExceptionHelperEvent(prog.OnCustomExceptionHelper); +end; + +procedure TPaxRunner.SetCustomExceptionHelper(value: TPaxCustomExceptionHelperEvent); +begin + prog.OnCustomExceptionHelper := TCustomExceptionHelperEvent(value); +end; + +function TPaxRunner.GetOnMapTableNamespace: TPaxMapTableNamespaceEvent; +begin + result := TPaxMapTableNamespaceEvent(prog.OnMapTableNamespace); +end; + +procedure TPaxRunner.SetOnMapTableNamespace(value: TPaxMapTableNamespaceEvent); +begin + prog.OnMapTableNamespace := TMapTableNamespaceEvent(value); +end; + +function TPaxRunner.GetOnMapTableVarAddress: TPaxMapTableVarAddressEvent; +begin + result := TPaxMapTableVarAddressEvent(prog.OnMapTableVarAddress); +end; + +procedure TPaxRunner.SetOnMapTableVarAddress(value: TPaxMapTableVarAddressEvent); +begin + prog.OnMapTableVarAddress := TMapTableVarAddressEvent(value); +end; + +function TPaxRunner.GetOnMapTableProcAddress: TPaxMapTableProcAddressEvent; +begin + result := TPaxMapTableProcAddressEvent(prog.OnMapTableProcAddress); +end; + +procedure TPaxRunner.SetOnMapTableProcAddress(value: TPaxMapTableProcAddressEvent); +begin + prog.OnMapTableProcAddress := TMapTableProcAddressEvent(value); +end; + +function TPaxRunner.GetOnMapTableClassRef: TPaxMapTableClassRefEvent; +begin + result := TPaxMapTableClassRefEvent(prog.OnMapTableClassRef); +end; + +procedure TPaxRunner.SetOnMapTableClassRef(value: TPaxMapTableClassRefEvent); +begin + prog.OnMapTableClassRef := TMapTableClassRefEvent(value); +end; + +function TPaxRunner.GetOnException: TPaxErrNotifyEvent; +begin + result := TPaxErrNotifyEvent(prog.OnException); +end; + +procedure TPaxRunner.SetOnException(value: TPaxErrNotifyEvent); +begin + prog.OnException := TErrNotifyEvent(value); +end; + +function TPaxRunner.GetOnUnhandledException: TPaxErrNotifyEvent; +begin + result := TPaxErrNotifyEvent(prog.OnUnhandledException); +end; + +procedure TPaxRunner.SetOnUnhandledException(value: TPaxErrNotifyEvent); +begin + prog.OnUnhandledException := TErrNotifyEvent(value); +end; + +// added in v1.6 + +{$IFDEF PAXARM} +{$ELSE} +procedure TPaxRunner.SetEntryPoint(EntryPoint: TPaxInvoke); +begin + prog.SetEntryPoint(EntryPoint); +end; + +procedure TPaxRunner.ResetEntryPoint(EntryPoint: TPaxInvoke); +begin + prog.ResetEntryPoint(EntryPoint); +end; +{$ENDIF} + +procedure TPaxRunner.CreateGlobalJSObjects; +begin + if Assigned(CrtJSObjects) then + CrtJSObjects(prog, prog.JS_Record); +end; + +function TPaxRunner.GetImageSize: Integer; +begin + result := prog.GetImageSize; +end; + +function TPaxRunner.CreateScriptObject(const ScriptClassName: String; + const ParamList: array of const): TObject; +begin + result := prog.CreateScriptObject(ScriptClassName, ParamList); +end; + +procedure TPaxRunner.DestroyScriptObject(X: TObject); +begin + prog.DestroyScriptObject(X); +end; + +function TPaxRunner.GetExitCode: Integer; +begin + result := prog.ExitCode; +end; + +procedure TPaxRunner.RegisterMember(LevelId: Integer; const Name: String; + Address: Pointer); +begin + prog.RegisterMember(LevelId, Name, Address); +end; + +function TPaxRunner.RegisterNamespace(LevelId: Integer; const Name: String): Integer; +begin + result := prog.RegisterNamespace(LevelId, Name); +end; + +function TPaxRunner.RegisterClassType(LevelId: Integer; C: TClass): Integer; +begin + result := prog.RegisterClassType(LevelId, C); +end; + +procedure TPaxRunner.MapGlobal; +begin + prog.MapGlobal; +end; + +procedure TPaxRunner.MapLocal; +begin + prog.MapLocal; +end; + +function TPaxRunner.GetFieldAddress(X: TObject; const FieldName: String): Pointer; +begin + result := prog.GetFieldAddress(X, FieldName); +end; + +procedure TPaxRunner.DiscardDebugMode; +begin + prog.DiscardDebugMode; +end; + +procedure TPaxRunner.AssignEventHandlerRunner(MethodAddress: Pointer; + Instance: TObject); +begin + prog.AssignEventHandlerRunner(MethodAddress, Instance); +end; + +function TPaxRunner.GetIsEvent: Boolean; +begin + result := prog.RootIsEvent; +end; + +procedure TPaxRunner.LoadDFMFile(Instance: TObject; const FileName: String); +begin + prog.LoadDFMFile(Instance, FileName); +end; + +procedure TPaxRunner.LoadDFMStream(Instance: TObject; S: TStream); +begin + prog.LoadDFMStream(Instance, S); +end; + +function TPaxRunner.GetTypeInfo(const FullTypeName: String): PTypeInfo; +begin + result := prog.GetTypeInfo(FullTypeName); +end; + +function TPaxRunner.CallRoutine(const FullName: String; + const ParamList: array of OleVariant): OleVariant; +begin + result := prog.CallFunc(FullName, nil, ParamList); +end; + +function TPaxRunner.CallMethod(const FullName: String; + Instance: TObject; + const ParamList: array of OleVariant): OleVariant; +begin + result := prog.CallFunc(FullName, Instance, ParamList); +end; + +function TPaxRunner.CallClassMethod(const FullName: String; + Instance: TClass; + const ParamList: array of OleVariant): OleVariant; +begin + result := prog.CallFunc(FullName, Instance, ParamList); +end; + +function TPaxRunner.GetSourceLine: Integer; +begin + result := prog.GetSourceLine; +end; + +function TPaxRunner.GetModuleName: String; +begin + result := prog.GetModuleName; +end; + +function TPaxRunner.GetOnLoadPCU: TPaxRunnerLoadPCUEvent; +begin + result := TPaxRunnerLoadPCUEvent(prog.OnLoadPCU); +end; + +procedure TPaxRunner.SetOnLoadPCU(value: TPaxRunnerLoadPCUEvent); +begin + prog.OnLoadPCU := TLoadPCUEvent(value); +end; + +procedure TPaxRunner.SetSuspendFinalization(value: Boolean); +begin + prog.SuspendFinalization := value; +end; + +function TPaxRunner.GetOnStreamSave: TPaxStreamEvent; +begin + result := TPaxStreamEvent(prog.OnSaveToStream); +end; + +procedure TPaxRunner.SetOnStreamSave(value: TPaxStreamEvent); +begin + prog.OnSaveToStream := TStreamEvent(value); +end; + +function TPaxRunner.GetOnStreamLoad: TPaxStreamEvent; +begin + result := TPaxStreamEvent(prog.OnLoadFromStream); +end; + +procedure TPaxRunner.SetOnStreamLoad(value: TPaxStreamEvent); +begin + prog.OnLoadFromStream := TStreamEvent(value); +end; + +function TPaxRunner.GetSuspendFinalization: Boolean; +begin + result := prog.SuspendFinalization; +end; + +procedure TPaxRunner.UnloadPCU(const FullPath: String); +begin + prog.UnloadPCU(FullPath); +end; + +procedure TPaxRunner.LoadPCU(const FileName: String); +var + DestProg: Pointer; +begin + prog.LoadPCU(FileName, DestProg); +end; + +function TPaxRunner.GetExceptionRecord: Pointer; +begin + result := prog.ExceptionRec; +end; + +function TPaxRunner.GetConsole: Boolean; +begin + result := prog.Console; +end; + +procedure TPaxRunner.SetConsole(value: Boolean); +begin + prog.Console := value; +end; + +function TPaxRunner.GetRunMode: Integer; +begin + result := prog.RunMode; +end; + +procedure TPaxRunner.SetRunMode(value: Integer); +begin + if (value < 0) or (value > _rmRUN_TO_CURSOR) then + prog.RaiseError(errIncorrectValue, []); + prog.RunMode := value; +end; + +function TPaxRunner.AddBreakpoint(const ModuleName: String; + SourceLineNumber: Integer): Boolean; +var + B: TBreakpoint; +begin + B := prog.AddBreakpoint(ModuleName, SourceLineNumber); + result := B <> nil; +end; + +function TPaxRunner.AddTempBreakpoint(const ModuleName: String; + SourceLineNumber: Integer): Boolean; +var + B: TBreakpoint; +begin + B := prog.AddTempBreakpoint(ModuleName, SourceLineNumber); + result := B <> nil; +end; + +function TPaxRunner.RemoveBreakpoint(const ModuleName: String; + SourceLineNumber: Integer): Boolean; +begin + result := prog.RemoveBreakpoint(ModuleName, SourceLineNumber); +end; + +function TPaxRunner.RemoveBreakpoint(const ModuleName: String): Boolean; +begin + result := prog.RemoveBreakpoint(ModuleName); +end; + +procedure TPaxRunner.RemoveAllBreakpoints; +begin + prog.RemoveAllBreakpoints; +end; + +function TPaxRunner.HasBreakpoint(const ModuleName: String; + SourceLineNumber: Integer): Boolean; +begin + result := prog.HasBreakpoint(ModuleName, SourceLineNumber); +end; + +function TPaxRunner.IsExecutableLine(const ModuleName: String; + SourceLineNumber: Integer): Boolean; +begin + result := prog.IsExecutableLine(ModuleName, SourceLineNumber); +end; + +function TPaxRunner.GetPCUCount: Integer; +begin + result := prog.ProgList.Count; +end; + +function TPaxRunner.GetOnBeginProcNotify: TPaxProcNotifyEvent; +begin + result := TPaxProcNotifyEvent(prog.OnBeginProcNotifyEvent); +end; + +procedure TPaxRunner.SetOnBeginProcNotify(value: TPaxProcNotifyEvent); +begin + prog.OnBeginProcNotifyEvent := TProcNotifyEvent(value); +end; + +function TPaxRunner.GetOnEndProcNotify: TPaxProcNotifyEvent; +begin + result := TPaxProcNotifyEvent(prog.OnEndProcNotifyEvent); +end; + +procedure TPaxRunner.SetOnEndProcNotify(value: TPaxProcNotifyEvent); +begin + prog.OnEndProcNotifyEvent := TProcNotifyEvent(value); +end; + +function TPaxRunner.GetOnVirtualObjectMethodCall: TPaxVirtualObjectMethodCallEvent; +begin + result := TPaxVirtualObjectMethodCallEvent(prog.OnVirtualObjectMethodCall); +end; + +procedure TPaxRunner.SetOnVirtualObjectMethodCall(value: TPaxVirtualObjectMethodCallEvent); +begin + prog.OnVirtualObjectMethodCall := TVirtualObjectMethodCallEvent(value); +end; + +function TPaxRunner.GetOnVirtualObjectPutProperty: TPaxVirtualObjectPutPropertyEvent; +begin + result := TPaxVirtualObjectPutPropertyEvent(prog.OnVirtualObjectPutProperty); +end; + +procedure TPaxRunner.SetOnVirtualObjectPutProperty(value: TPaxVirtualObjectPutPropertyEvent); +begin + prog.OnVirtualObjectPutProperty := TVirtualObjectPutPropertyEvent(value); +end; + +function TPaxRunner.GetPausedPCU: TBaseRunner; +begin + result := prog.PausedPCU; +end; + +procedure TPaxRunner.SetPausedPCU(value: TBaseRunner); +begin + prog.PausedPCU := value; +end; + +function TPaxRunner.GetPrintClassTypeField: TPaxPrintClassTypeFieldEvent; +begin + result := TPaxPrintClassTypeFieldEvent(prog.OnPrintClassTypeField); +end; + +procedure TPaxRunner.SetPrintClassTypeField(value: TPaxPrintClassTypeFieldEvent); +begin + prog.OnPrintClassTypeField := TPrintClassTypeFieldEvent(value); +end; + +function TPaxRunner.GetPrintClassTypeProp: TPaxPrintClassTypePropEvent; +begin + result := TPaxPrintClassTypePropEvent(prog.OnPrintClassTypeProp); +end; + +procedure TPaxRunner.SetPrintClassTypeProp(value: TPaxPrintClassTypePropEvent); +begin + prog.OnPrintClassTypeProp := TPrintClassTypePropEvent(value); +end; + +function TPaxRunner.GetCurrentFunctionFullName: String; +begin + result := prog.GetCurrentFunctionFullName; +end; + +procedure TPaxRunner.GetCurrentParams(result: TStrings); +begin + prog.GetCurrentParams(result); +end; + +procedure TPaxRunner.GetCurrentLocalVars(result: TStrings); +begin + prog.GetCurrentLocalVars(result); +end; + +function TPaxRunner.GetPCUUnit(I: Integer): TBaseRunner; +begin + if I < PCUCount then + result := TBaseRunner(prog.ProgList[I].Prog) + else + result := nil; +end; + +function TPaxRunner.HasPCU(const ModuleName: String): Boolean; +var + I: Integer; + S: String; +begin + result := false; + for I := 0 to PCUCount - 1 do + begin + S := prog.ProgList[I].FullPath; + S := ExtractFullOwner(S); + if StrEql(S, ModuleName) then + begin + result := true; + Exit; + end; + end; +end; + +function ScalarValueToString(Address: Pointer; T: Integer): String; +begin + result := PAXCOMP_SYS.ScalarValueToString(Address, T); +end; + +function TPaxRunner.GetSearchPathList: TStringList; +begin + result := prog.RootSearchPathList; +end; + +end. diff --git a/Sources/RegExpr2.pas b/Sources/RegExpr2.pas new file mode 100644 index 0000000..ac9079b --- /dev/null +++ b/Sources/RegExpr2.pas @@ -0,0 +1,4803 @@ +{$I PaxCompiler.def} +{$B-} +unit RegExpr2; +{$IFDEF PAXARM} + +interface + +implementation + +end. +{$ENDIF} +{$IFDEF GE_DXE4} +{$ZEROBASEDSTRINGS OFF} +{$ENDIF} +(* + TRegExpr library + Regular Expressions for Delphi + + Author: + Andrey V. Sorokin + St-Petersburg + Russia + anso@mail.ru, anso@usa.net + http://anso.da.ru + http://anso.virtualave.net + + This library is derived from Henry Spencer sources. + I translated the C sources into Object Pascal, + implemented object wrapper and some new features. + Many features suggested or partially implemented + by TRegExpr's users (see Gratitude below). + + --------------------------------------------------------------- + Legal issues + --------------------------------------------------------------- + Copyright (c) 1999-00 by Andrey V. Sorokin + + This software is provided as it is, without any kind of warranty + given. Use it at your own risk. + + You may use this software in any kind of development, including + comercial, redistribute, and modify it freely, under the + following restrictions : + 1. The origin of this software may not be mispresented, you must + not claim that you wrote the original software. If you use + this software in any kind of product, it would be appreciated + that there in a information box, or in the documentation would + be an acknowledgmnent like this + Partial Copyright (c) 2000 by Andrey V. Sorokin + 2. You may not have any income from distributing this source + to other developers. When you use this product in a comercial + package, the source may not be charged seperatly. + + + --------------------------------------------------------------- + Legal issues for the original C sources: + --------------------------------------------------------------- + * Copyright (c) 1986 by University of Toronto. + * Written by Henry Spencer. Not derived from licensed software. + * + * Permission is granted to anyone to use this software for any + * purpose on any computer system, and to redistribute it freely, + * subject to the following restrictions: + * 1. The author is not responsible for the consequences of use of + * this software, no matter how awful, even if they arise + * from defects in it. + * 2. The origin of this software must not be misrepresented, either + * by explicit claim or by omission. + * 3. Altered versions must be plainly marked as such, and must not + * be misrepresented as being the original software. + + + --------------------------------------------------------------- + Gratitudes + --------------------------------------------------------------- + Guido Muehlwitz + found and fixed ugly bug in big string processing + Stephan Klimek + testing in CPPB and suggesting/implementing many features + Steve Mudford + implemented Offset parameter + Martin Baur + usefull suggetions, help translation into German + Yury Finkel + Implemented UniCode support, found and fixed some bugs + Ralf Junker + Implemented some features, many optimization suggestions + Filip Jirsák and Matthew Winter (wintermi@yahoo.com) + Help in Implementation non-greedy mode + Kit Eason + many examples for introduction help section + Juergen Schroth + bug hunting and usefull suggestions + Simeon Lilov + help translation into Bulgarian + Martin Ledoux + help translation into French + Diego Calp (mail@diegocalp.com), Argentina + help translation into Spanish + + And many others - for big work of bug hunting ! + + I am still looking for person who can help me to translate + this documentation into other languages (especially German) + + + --------------------------------------------------------------- + To do + --------------------------------------------------------------- + + -=- VCL-version of TRegExpr - for dummies ;) and TRegExprEdit + (replacement for TMaskEdit). + Actually, I am writing non-VCL aplications (with web-based + interfaces), so I don't need VCL's TRegExpr for myself. + Will it be really usefull ? + + -=- working with pascal-style string. + Now pascal-strings converted into PChar, so + you can't find r.e. in strings with #0 -chars. + (suggested by Pavel O). + + -=- put precalculated lengths into EXACTLY[CI] ! + + -=- fInputString as string (suggested by Ralf Junker) + + -=- Add regstart optimization for case-insensitive mode ? + Or complitely remove because FirstCharSet is faster ? + + -=- "Russian Ranges" --> National ranges (use property WordChars ? + for ordering letters in ranges by its order in WirdsChars if modifier /r is On) + + -=- FirstCharSet as array [#0 .. #255] of REChar ? + (2x faster then set of REChar) + + -=- p-code optimization (remove BRANCH-to-EEND, COMMENT, BACK(?) + merge EXACTLY etc). + + -=- !!!!!!!! bug found by Lars Karlslund + "If I do '(something|^$)' on '' I get false (which is wrong ...)." + + -=- There are no special command for files (Johan Smit). + + I need your suggestions ! + What are more importent in this list ? + Did I forget anything ? + + + --------------------------------------------------------------- + History + --------------------------------------------------------------- + Legend: + (+) added feature + (-) fixed bug + (^) upgraded implementation + + v. 0.947 2001.10.03 + -=- (+) Word boundary (\b & \B) metachar + -=- (-) Bug in processing predefined char.classes in non-UseSetOfChar mode + -=- (+) Spanish help - translated by Diego Calp (mail@diegocalp.com), Argentina + -=- (+) VersionMajor/Minor class method of TRegExpr ;) + -=- (-) Bug in CompileRegExpr, Thanks to Oleg Orlov + -=- (^) Method RegExprSubExpressions wasn't compatible with D2-D3. + Thanks to Eugene Tarasov for bug report. + -=- (+) Method Replace can now do substitution as well (see documentation) + Thanks to Warren Bare, Ken Friesen and many others who suggested it. + -=- (+) Updated ReplaceRegExpr to use new Replace method functionality + -=- (^) Restored UniCode compatibility lost in some previous version + Thanks to Stephan Klimek for bug report + -=- (^) Updated TestRE project, new examples for Replace with substitution + included. + + v. 0.942+ 2001.03.01 + -=- (+) Published French help for TRegExpr, + translated by Martin Ledoux + + v. 0.942 2001.02.12 + -=- (-) Range-check error in DEMO-project (due to bug in + RegExprSubExpressions), Thanks to Juergen Schroth + -=- (^) RegExprSubExpressions - added error codes for "unclosed "[" error + -=- (^) Help file bug fixing + + v. 0.941 2001.02.01 + -=- (^) Attension! Behaviour of '\w', '\W' was changed! Now it really + match alphanum characters and '_' as described in documentation, + not only alpha as it was before. Thanks to Vadim Alexandrov. + If You want to restore previous behaviour, reassign + RegExprWordChars (exclude '0123456789' from it). + -=- (+) Full compatible with recommended at unicode.org implementation + of modifier /m, including DOS-styled line separators (\r\n) mixed + with Unix styled (\n) - see properties LineSeparators, LinePairedSeparator + -=- (^) Attension! Behaviour of '.' was changed! Now if modifier /s is off + it doesn't match all chars from LineSeparators and LinePairedSeparator (by + default \r and \n) + -=- (^) Attension! To prevent unneeded recompilation of r.e., now assignment + to Expression or changing modifiers doesn't cause immidiate [re]compilation. + So, now You don't get exception while assigning wrong expression, but can + get exception while calling Exec[Next], Substitute, Dump, etc if there + are errors in Expression or other properties. + -=- (+) Non-greedy style iterators (like '*?'), modifier /g. + Implemented with help from Matthew Winter and Filip Jirsák + -=- (+) /x modifier (eXtended syntax - allow formating r.e., see description + in the help) + -=- (+) Procedure Compile to [re]compile r.e. Usefull for GUI r.e. editors + and so on (to check all properties validity). + -=- (+) FAQ in documentation. I am too lazy to answer to the same + questions again and again :( Please, read the FAQ before sending + question to me! + -=- (^) DEMO project have been significantly improved. Now this is the + real r.e. debugger! Thanks to Jon Smith for his ideas. + -=- (+) function RegExprSubExpressions, usefull for GUI editors of + r.e. (see example of using in TestRExp.dpr project) + -=- (+) HyperLinkDecorator unit - practical example of TRegExpr + using (see description in the help file) + -=- (-) Range checking error in some cases if ComplexBraces defined + Thanks to Juergen Schroth + -=- (^) 'ComplexBraces' now is defined by default + -=- (+) Kit Eason sent to me many examples for 'Syntax' help section + and I decided to complitely rewrite this section. I hope, You'll enjoy + the results ;) + -=- (+) The \A and \Z metacharacters are just like "^" and "$", except + that they won't match multiple times when the modifier /m is used + + v. 0.939 2000.10.04 + -=- (-) Bug in Substitute method ($10.. didn't work properly) + Thanks to Serge S Klochkovski + + v. 0.938 2000.07.23 + -=- (^) Exeptions now jump to appropriate source line, not + to Error procedure (I am not quite sure this is safe for + all compiler versions. You can turn it off - remove + reRealExceptionAddr definition below). + -=- (^) Forgotten BSUBEXP[CI] in FillFirstCharSet caused + exeption 'memory corruption' in case if back reference can + be first op, like this: (a)*\1 (first subexpression can be + skipped and we'll start matching with back reference..). + + v. 0.937 2000.06.12 + -=- (-) Bug in optimization engine (since v.0.934). In some cases + TRegExpr didn't catch right strings. + Thanks to Matthias Fichtner + + v. 0.936 2000.04.22 + -=- (+) Back references, like , see + manual for details + -=- (+) Wide hex char support, like '\x{263a}' + + v. 0.935 2000.04.19 (by Yury Finkel) + -=- (-) fInvertCase now isn't readonly ;) + -=- (-) UniCode mode compiling errors + + v. 0.934 2000.04.17 + -=- (^) New ranges implementation (range matching now is very fast + - uses one(!) CPU instruction) + -=- (^) Internal p-code structure converted into 32-bits - works + faster and now there is no 64K limit for compiled r.e. + -=- (^) '{m,n}' now use 32-bits arguments (up to 2147483646) - specially + for Dmitry Veprintsev ;) + -=- (^) Ranges now support metachars: [\n-\x0D] -> #10,#11,#12,#13; + Changed '-' processing, now it's like in Perl: + [\d-t] -> '0'..'9','-','t'; []-a] -> ']'..'a' + -=- (-) Bug with \t and etc macro (they worked only in ranges) + Thanks to Yury Finkel + -=- (^) Added new preprocessing optimization (see FirstCharSet). + Incredible fast (!). But be carefull it isn's properly tested. + You can switch it Off - remove UseFirstCharSet definition. + -=- (^) Many other speed optimizations + -=- (-) Case-insensitive mode now support system-defined national + charset (due to bug in v.0.90 .. 0.926 supported only english one) + -=- (^) Case-insensitive mode implemented with InvertCase (param & + result of REChar type) - works 10 .. 100 times faster. + -=- (^) Match and ExecNext interfaces optimized, added IsProgrammOk + by Ralf Junker + -=- (^) Increased NSUBEXP (now 15) and fixed code for this, now you + can simply increase NSUBEXP constant by yourself. + Suggested by Alexander V. Akimov. + -=- (^+) Substitute adapted for NSUBEXP > 10 and significant (!) + optimized, improved error checking. + ATTENTION! Read new Substitute description - syntax was changed ! + -=- (+) SpaceChars & WordChars property - now you may change chars + treated as \s & \w. By defauled assigned RegExprSpaceChars/WordChars + -=- (+) Now \s and \w supported in ranges + -=- (-) Infinite loop if end of range=#$FF + Thanks to Andrey Kolegov + -=- (+) Function QuoteRegExprMetaChars (see description) + -=- (+) UniCode support - sorry, works VERY slow (remove '.' from + {.$DEFINE UniCode} after this comment for unicode version). + Implemented by Yury Finkel + + v. 0.926 2000.02.26 + -=- (-) Old bug derived from H.Spencer sources - SPSTART was + set for '?' and '*' instead of '*', '{m,n}' and '+'. + -=- (-^) Now {m,n} works like Perl's one - error occures only + if m > n or n > BracesMax (BracesMax = 255 in this version). + In other cases (no m or nondigit symbols in m or n values, + or no '}') symbol '{' will be compiled as literal. + Note: so, you must include m value (use {0,n} instead of {,n}). + Note: {m,} will be compiled as {m,BracesMax}. + -=- (-^) CaseInsensitive mode now support ranges + '(?i)[a]' == '[aA]' + -=- (^) Roman-number template in TestRExp ;) + -=- (+^) Beta version of complex-braces - like ((abc){1,2}|d){3} + By default its turned off. If you want take part in beta-testing, + please, remove '.' from {.$DEFINE ComplexBraces} below this comments. + -=- (-^) Removed \b metachar (in Perl it isn't BS as in my implementation, + but word bound) + -=- (+) Add /s modifier. Bu I am not sure that it's ok for Windows. + I implemented it as [^\n] for '.' metachar in non-/s mode. + But lines separated by \n\r in windows. I need you suggestions ! + -=- (^) Sorry, but I had to rename Modifiers to ModifierStr + (ModifierS uses for /s now) + + v. 0.91 2000.02.02 + -=- (^) some changes in documentation and demo-project. + + v. 0.90 2000.01.31 + -=- (+) implemented braces repetitions {min,max}. + Sorry - only simple cases now - like '\d{2,3}' + or '[a-z1-9]{,7}', but not (abc){2,3} .. + I still too short in time. + Wait for future versions of TRegExpr or + implement it by youself and share with me ;) + -=- (+) implemented case-insensitive modifier and way + to work with other modifiers - see properties + Modifiers, Modifier, ModifierI + and (?ismx-ismx) Perl extension. + You may use global variables RegExpr* for assigning + default modifier values. + -=- (+) property ExtSyntaxEnabled changed to 'r'-modifier + (russian extensions - see documentation) + -=- (+) implemented (?#comment) Perl extension - very hard + and usefull work ;) + -=- (^) property MatchCount renamed to SubExprMatchCount. + Sorry for any inconvenients, but it's because new + version works slightly different and if you used + MatchCount in your programms you have to rethink + it ! (see comments to this property) + -=- (+) add InputString property - stores input string + from last Exec call. You may directly assign values + to this property for using in ExecPos method. + -=- (+) add ExecPos method - for working with assigned + to InputString property. You may use it like this + InputString := AString; + ExecPos; + or this + InputString := AString; + ExecPos (AOffset); + Note: ExecPos without parameter works only in + Delphi 4 or higher. + -=- (+) add ExecNext method - simple and fast (!) way to finding + multiple occurences of r.e. in big input string. + -=- (^) Offset parameter removed from Exec method, if you + used it in your programs, please replace all + Exec (AString, AOffset) + with combination + InputString := AString; ExecPos (AOffset) + Sorry for any inconvenients, but old design + (see v.0.81) was too ugly :( + In addition, multiple Exec calls with same input + string produce fool overhead because each Exec + reallocate input string buffer. + -=- (^) optimized implementation of Substitution, + Replace and Split methods + -=- (-) fixed minor bug - if r.e. compilation raise error + during second pass (!!! I think it's impossible + in really practice), TRegExpr stayed in 'compiled' + state. + -=- (-) fixed bug - Dump method didn't check program existance + and raised 'access violation' if previouse Exec + was finished with error. + -=- (+) changed error handling (see functions Error, ErrorMsg, + LastError, property CompilerErrorPos, type ERegExpr). + -=- (-^) TRegExpr.Replace, Split and ExecNext made a infinite + loop in case of r.e. match empty-string. + Now ExecNext moves by MatchLen if MatchLen <> 0 + and by +1 if MatchLen = 0 + Thanks to Jon Smith and George Tasker for bugreports. + -=- (-) While playing with null-matchs I discovered, that + null-match at tail of input string is never found. + Well, I fixed this, but I am not sure this is safe + (MatchPos[0]=length(AInputString)+1, MatchLen = 0). + Any suggetions are very appreciated. + -=- (^) Demo project and documentation was upgraded + -=- (^) Documentation and this version was published on my home page + http://anso.da.ru + + + v. 0.81 1999.12.25 // Merry Christmas ! :) + -=- added \s (AnySpace) and \S (NotSpace) meta-symbols + - implemented by Stephan Klimek with minor fixes by AVS + -=- added \f, \a and \b chars (translates into FF, BEL, BS) + -=- removed meta-symbols '? & '? - sorry for any inconvenients + -=- added Match property (== copy (InputStr, MatchPos [Idx], MatchLen [Idx])) + -=- added extra parameter Offset to Exec method + (thanks to Steve Mudford) + + v. 0.7 1999.08.22 + -=- fixed bug - in some cases the r.e. [^...] + incorrectly processed (as any symbol) + (thanks to Jan Korycan) + -=- Some changes and improvements in TestRExp.dpr + + v. 0.6 1999.08.13 (Friday 13 !) + -=- changed header of TRegExpr.Substitute + -=- added Split, Replace & appropriate + global wrappers (thanks to Stephan Klimek for suggetions) + + v. 0.5 1999.08.12 + -=- TRegExpr.Substitute routine added + -=- Some changes and improvements in TestRExp.dpr + -=- Fixed bug in english version of documentation + (Thanks to Jon Buckheit) + + v. 0.4 1999.07.20 + -=- Fixed bug with parsing of strings longer then 255 bytes + (thanks to Guido Muehlwitz) + -=- Fixed bug in RegMatch - mathes only first occurence of r.e. + (thanks to Stephan Klimek) + + v. 0.3 1999.06.13 + -=- ExecRegExpr function + + v. 0.2 1999.06.10 + -=- packed into object-pascal class + -=- code slightly rewriten for pascal + -=- now macro correct proceeded in ranges + -=- r.e.ranges syntax extended for russian letters ranges: + ?ÿ - replaced with all small russian letters (Win1251) + ??- replaced with all capital russian letters (Win1251) + ??- replaced with all russian letters (Win1251) + -=- added macro '\d' (opcode ANYDIGIT) - match any digit + -=- added macro '\D' (opcode NOTDIGIT) - match not digit + -=- added macro '\w' (opcode ANYLETTER) - match any english letter or '_' + -=- added macro '\W' (opcode NOTLETTER) - match not english letter or '_' + (all r.e.syntax extensions may be turned off by flag ExtSyntax) + + v. 0.1 1999.06.09 + first version, with bugs, without help => must die :( + +*) + + interface + +{$DEFINE DebugRegExpr} // define for dump/trace enabling + +{$IFNDEF FPC} +{$DEFINE reRealExceptionAddr} // if defined then exceptions will +{$ENDIF} +// jump to appropriate source line, not to Error procedure + +{$DEFINE ComplexBraces} // define for beta-version of braces +// (in stable version it works only for simple cases) + +{ .$DEFINE UniCode } // define for Unicode support + +{$IFNDEF UniCode} // optionts applicable only for non-UniCode +{$DEFINE UseSetOfChar} // Significant optimization by using set of char +{$ENDIF} +{$IFDEF UseSetOfChar} +{$DEFINE UseFirstCharSet} // Significant optimization inm some cases +{$ENDIF} +// Determine version (for using 'params by default') +{$IFNDEF VER80} { Delphi 1.0 } +{$IFNDEF VER90} { Delphi 2.0 } +{$IFNDEF VER93} { C++Builder 1.0 } +{$IFNDEF VER100} { Borland Delphi 3.0 } +{$DEFINE D4_} { Delphi 4.0 or higher } +{$ENDIF} +{$ENDIF} +{$ENDIF} +{$ENDIF} +{ .$IFNDEF VER110 } { Borland C++Builder 3.0 } +{ .$IFNDEF VER120 } { Borland Delphi 4.0 } + +uses + Classes, // TStrings in Split method + SysUtils; // Exception + +type +{$IFDEF UniCode} + PRegExprChar = PWideChar; + RegExprString = WideString; + REChar = WideChar; +{$ELSE} + PRegExprChar = PAnsiChar; + RegExprString = AnsiString; + REChar = AnsiChar; +{$ENDIF} + TREOp = REChar; // internal p-code type //###0.933 + PREOp = ^TREOp; + TRENextOff = integer; + // internal Next "pointer" (offset to current p-code) //###0.933 + PRENextOff = ^TRENextOff; + // used for extracting Next "pointers" from compiled r.e. //###0.933 + TREBracesArg = integer; // type of {m,n} arguments + PREBracesArg = ^TREBracesArg; + +const + REOpSz = SizeOf(TREOp) div SizeOf(REChar); + // size of p-code in RegExprString units + RENextOffSz = SizeOf(TRENextOff) div SizeOf(REChar); + // size of Next 'pointer' -"- + REBracesArgSz = SizeOf(TREBracesArg) div SizeOf(REChar); + // size of BRACES arguments -"- + +type + TRegExprInvertCaseFunction = function(const Ch: REChar): REChar of object; + +const + RegExprModifierI: boolean = False; // default value for ModifierI + RegExprModifierR: boolean = True; // default value for ModifierR + RegExprModifierS: boolean = True; // default value for ModifierS + RegExprModifierG: boolean = True; // default value for ModifierG + RegExprModifierM: boolean = False; // default value for ModifierM + RegExprModifierX: boolean = False; // default value for ModifierX + RegExprSpaceChars: RegExprString = // default value for SpaceChars + ' '#$9#$A#$D#$C; + RegExprWordChars: RegExprString = // default value for WordChars + '0123456789' // ###0.940 + + 'abcdefghijklmnopqrstuvwxyz' + 'ABCDEFGHIJKLMNOPQRSTUVWXYZ_'; + RegExprLineSeparators: RegExprString = // default value for LineSeparators + #$d#$a{$IFDEF UniCode} + #$b#$c#$2028#$2029#$85{$ENDIF}; // ###0.947 + RegExprLinePairedSeparator: RegExprString = + // default value for LinePairedSeparator + #$d#$a; + { if You need Unix-styled line separators (only \n), then use: + RegExprLineSeparators = #$a; + RegExprLinePairedSeparator = ''; + } + +const + NSUBEXP = 15; // max number of subexpression //###0.929 + // Cannot be more than NSUBEXPMAX + // Be carefull - don't use values which overflow CLOSE opcode + // (in this case you'll get compiler erorr). + // Big NSUBEXP will cause more slow work and more stack required + NSUBEXPMAX = 255; // Max possible value for NSUBEXP. //###0.945 + // Don't change it! It's defined by internal TRegExpr design. + + MaxBracesArg = $7FFFFFFF - 1; // max value for {n,m} arguments //###0.933 + +{$IFDEF ComplexBraces} + LoopStackMax = 10; // max depth of loops stack //###0.925 +{$ENDIF} + TinySetLen = 3; + // if range includes more then TinySetLen chars, //###0.934 + // then use full (32 bytes) ANYOFFULL instead of ANYOF[BUT]TINYSET + // !!! Attension ! If you change TinySetLen, you must + // change code marked as "//!!!TinySet" + +type + +{$IFDEF UseSetOfChar} + PSetOfREChar = ^TSetOfREChar; + TSetOfREChar = set of REChar; +{$ENDIF} + + TRegExpr = class + private + startp: array [0 .. NSUBEXP - 1] of PRegExprChar; + // founded expr starting points + endp: array [0 .. NSUBEXP - 1] of PRegExprChar; // founded expr end points + +{$IFDEF ComplexBraces} + LoopStack: array [1 .. LoopStackMax] of integer; + // state before entering loop + LoopStackIdx: integer; // 0 - out of all loops +{$ENDIF} + // The "internal use only" fields to pass info from compile + // to execute that permits the execute phase to run lots faster on + // simple cases. + regstart: REChar; // char that must begin a match; '\0' if none obvious + reganch: REChar; // is the match anchored (at beginning-of-line only)? + regmust: PRegExprChar; + // string (pointer into program) that match must include, or nil + regmlen: integer; // length of regmust string + // Regstart and reganch permit very fast decisions on suitable starting points + // for a match, cutting down the work a lot. Regmust permits fast rejection + // of lines that cannot possibly match. The regmust tests are costly enough + // that regcomp() supplies a regmust only if the r.e. contains something + // potentially expensive (at present, the only such thing detected is * or + + // at the start of the r.e., which can involve a lot of backup). Regmlen is + // supplied because the test in regexec() needs it and regcomp() is computing + // it anyway. +{$IFDEF UseFirstCharSet} // ###0.929 + FirstCharSet: TSetOfREChar; +{$ENDIF} + // work variables for Exec's routins - save stack in recursion} + reginput: PRegExprChar; // String-input pointer. + fInputStart: PRegExprChar; // Pointer to first char of input string. + fInputEnd: PRegExprChar; // Pointer to char AFTER last char of input string + + // work variables for compiler's routines + regparse: PRegExprChar; // Input-scan pointer. + regnpar: integer; // count. + regdummy: AnsiChar; + regcode: PRegExprChar; // Code-emit pointer; @regdummy = don't. + regsize: integer; // Code size. + + regexpbeg: PRegExprChar; // only for error handling. Contains + // pointer to beginning of r.e. while compiling + fExprIsCompiled: boolean; // true if r.e. successfully compiled + + // programm is essentially a linear encoding + // of a nondeterministic finite-state machine (aka syntax charts or + // "railroad normal form" in parsing technology). Each node is an opcode + // plus a "next" pointer, possibly plus an operand. "Next" pointers of + // all nodes except BRANCH implement concatenation; a "next" pointer with + // a BRANCH on both ends of it is connecting two alternatives. (Here we + // have one of the subtle syntax dependencies: an individual BRANCH (as + // opposed to a collection of them) is never concatenated with anything + // because of operator precedence.) The operand of some types of node is + // a literal string; for others, it is a node leading into a sub-FSM. In + // particular, the operand of a BRANCH node is the first node of the branch. + // (NB this is *not* a tree structure: the tail of the branch connects + // to the thing following the set of BRANCHes.) The opcodes are: + programm: PRegExprChar; // Unwarranted chumminess with compiler. + + fExpression: PRegExprChar; // source of compiled r.e. + fInputString: PRegExprChar; // input string + + fLastError: integer; // see Error, LastError + + fModifiers: integer; // modifiers + fCompModifiers: integer; // compiler's copy of modifiers + fProgModifiers: integer; // modifiers values from last programm compilation + + fSpaceChars: RegExprString; // ###0.927 + fWordChars: RegExprString; // ###0.929 + fInvertCase: TRegExprInvertCaseFunction; // ###0.927 + + fLineSeparators: RegExprString; // ###0.941 + fLinePairedSeparatorAssigned: boolean; + fLinePairedSeparatorHead, fLinePairedSeparatorTail: REChar; +{$IFNDEF UniCode} + fLineSeparatorsSet: set of REChar; +{$ENDIF} + procedure InvalidateProgramm; + // Mark programm as have to be [re]compiled + + function IsProgrammOk: boolean; // ###0.941 + // Check if we can use precompiled r.e. or + // [re]compile it if something changed + + function GetExpression: RegExprString; + procedure SetExpression(const s: RegExprString); + + function GetModifierStr: RegExprString; + class function ParseModifiersStr(const AModifiers: RegExprString; + var AModifiersInt: integer): boolean; // ###0.941 class function now + // Parse AModifiers string and return true and set AModifiersInt + // if it's in format 'ismxrg-ismxrg'. + procedure SetModifierStr(const AModifiers: RegExprString); + + function GetModifier(AIndex: integer): boolean; + procedure SetModifier(AIndex: integer; ASet: boolean); + + procedure Error(AErrorID: integer); virtual; // error handler. + // Default handler raise exception ERegExpr with + // Message = ErrorMsg (AErrorID), ErrorCode = AErrorID + // and CompilerErrorPos = value of property CompilerErrorPos. + + { ==================== Compiler section =================== } + function CompileRegExpr(exp: PRegExprChar): boolean; + // compile a regular expression into internal code + + procedure Tail(p: PRegExprChar; val: PRegExprChar); + // set the next-pointer at the end of a node chain + + procedure OpTail(p: PRegExprChar; val: PRegExprChar); + // regoptail - regtail on operand of first argument; nop if operandless + + function EmitNode(op: TREOp): PRegExprChar; + // regnode - emit a node, return location + + procedure EmitC(b: REChar); + // emit (if appropriate) a byte of code + + procedure InsertOperator(op: TREOp; opnd: PRegExprChar; sz: integer); + // ###0.90 + // insert an operator in front of already-emitted operand + // Means relocating the operand. + + function ParseReg(paren: integer; var flagp: integer): PRegExprChar; + // regular expression, i.e. main body or parenthesized thing + + function ParseBranch(var flagp: integer): PRegExprChar; + // one alternative of an | operator + + function ParsePiece(var flagp: integer): PRegExprChar; + // something followed by possible [*+?] + + function ParseAtom(var flagp: integer): PRegExprChar; + // the lowest level + + function GetCompilerErrorPos: integer; + // current pos in r.e. - for error hanling + +{$IFDEF UseFirstCharSet} // ###0.929 + procedure FillFirstCharSet(prog: PRegExprChar); +{$ENDIF} + { ===================== Mathing section =================== } + function regrepeat(p: PRegExprChar; AMax: integer): integer; + // repeatedly match something simple, report how many + + function regnext(p: PRegExprChar): PRegExprChar; + // dig the "next" pointer out of a node + + function MatchPrim(prog: PRegExprChar): boolean; + // recursively matching routine + + function RegMatch(str: PRegExprChar): boolean; + // try match at specific point, uses MatchPrim for real work + + function ExecPrim(AOffset: integer): boolean; + // Exec for stored InputString + +{$IFDEF DebugRegExpr} + function DumpOp(op: REChar): RegExprString; +{$ENDIF} + function GetSubExprMatchCount: integer; + function GetMatchPos(Idx: integer): integer; + function GetMatchLen(Idx: integer): integer; + function GetMatch(Idx: integer): RegExprString; + + function GetInputString: RegExprString; + procedure SetInputString(const AInputString: RegExprString); + +{$IFNDEF UseSetOfChar} + function StrScanCI(s: PRegExprChar; Ch: REChar): PRegExprChar; // ###0.928 +{$ENDIF} + procedure SetLineSeparators(const AStr: RegExprString); + procedure SetLinePairedSeparator(const AStr: RegExprString); + function GetLinePairedSeparator: RegExprString; + + public + constructor Create; + destructor Destroy; override; + + class function VersionMajor: integer; // ###0.944 + class function VersionMinor: integer; // ###0.944 + + property Expression: RegExprString read GetExpression write SetExpression; + // Regular expression. + // For optimization, TRegExpr will automatically compiles it into 'P-code' + // (You can see it with help of Dump method) and stores in internal + // structures. Real [re]compilation occures only when it really needed - + // while calling Exec[Next], Substitute, Dump, etc + // and only if Expression or other P-code affected properties was changed + // after last [re]compilation. + // If any errors while [re]compilation occures, Error method is called + // (by default Error raises exception - see below) + + property ModifierStr: RegExprString read GetModifierStr + write SetModifierStr; + // Set/get default values of r.e.syntax modifiers. Modifiers in + // r.e. (?ismx-ismx) will replace this default values. + // If you try to set unsupported modifier, Error will be called + // (by defaul Error raises exception ERegExpr). + + property ModifierI: boolean index 1 read GetModifier write SetModifier; + // Modifier /i - caseinsensitive, initialized from RegExprModifierI + + property ModifierR: boolean index 2 read GetModifier write SetModifier; + // Modifier /r - use r.e.syntax extended for russian, + // (was property ExtSyntaxEnabled in previous versions) + // If true, then ?ÿ additional include russian letter '?, + // ?? additional include '?, and ??include all russian symbols. + // You have to turn it off if it may interfere with you national alphabet. + // , initialized from RegExprModifierR + + property ModifierS: boolean index 3 read GetModifier write SetModifier; + // Modifier /s - '.' works as any char (else as [^\n]), + // , initialized from RegExprModifierS + + property ModifierG: boolean index 4 read GetModifier write SetModifier; + // Switching off modifier /g switchs all operators in + // non-greedy style, so if ModifierG = False, then + // all '*' works as '*?', all '+' as '+?' and so on. + // , initialized from RegExprModifierG + + property ModifierM: boolean index 5 read GetModifier write SetModifier; + // Treat string as multiple lines. That is, change `^' and `$' from + // matching at only the very start or end of the string to the start + // or end of any line anywhere within the string. + // , initialized from RegExprModifierM + + property ModifierX: boolean index 6 read GetModifier write SetModifier; + // Modifier /x - eXtended syntax, allow r.e. text formatting, + // see description in the help. Initialized from RegExprModifierX + + function Exec(const AInputString: RegExprString): boolean; + // match a programm against a string AInputString + // !!! Exec store AInputString into InputString property + + function ExecNext: boolean; + // find next match: + // Exec (AString); ExecNext; + // works same as + // Exec (AString); + // if MatchLen [0] = 0 then ExecPos (MatchPos [0] + 1) + // else ExecPos (MatchPos [0] + MatchLen [0]); + // but it's more simpler ! + + function ExecPos(AOffset: integer {$IFDEF D4_} = 1{$ENDIF}): boolean; + // find match for InputString starting from AOffset position + // (AOffset=1 - first char of InputString) + + property InputString: RegExprString read GetInputString + write SetInputString; + // returns current input string (from last Exec call or last assign + // to this property). + // Any assignment to this property clear Match* properties ! + + function Substitute(const ATemplate: RegExprString): RegExprString; + // Returns ATemplate with '$&' or '$0' replaced by whole r.e. + // occurence and '$n' replaced by occurence of subexpression #n. + // Since v.0.929 '$' used instead of '\' (for future extensions + // and for more Perl-compatibility) and accept more then one digit. + // If you want place into template raw '$' or '\', use prefix '\' + // Example: '1\$ is $2\\rub\\' -> '1$ is \rub\' + // If you want to place raw digit after '$n' you must delimit + // n with curly braces '{}'. + // Example: 'a$12bc' -> 'abc' + // 'a${1}2bc' -> 'a2bc'. + + procedure Split(AInputStr: RegExprString; APieces: TStrings); + // Split AInputStr into APieces by r.e. occurencies + // Internally calls Exec[Next] + + function Replace(AInputStr: RegExprString; const AReplaceStr: RegExprString; + AUseSubstitution: boolean{$IFDEF D4_} = False{$ENDIF}) // ###0.946 + : RegExprString; + // Returns AInputStr with r.e. occurencies replaced by AReplaceStr + // If AUseSubstitution is true, then AReplaceStr will be used + // as template for Substitution methods. + // For example: + // Expression := '({-i}block|var)\s*\(\s*([^ ]*)\s*\)\s*'; + // Replace ('BLOCK( test1)', 'def "$1" value "$2"', True); + // will return: def 'BLOCK' value 'test1' + // Replace ('BLOCK( test1)', 'def "$1" value "$2"') + // will return: def "$1" value "$2" + // Internally calls Exec[Next] + + property SubExprMatchCount: integer read GetSubExprMatchCount; + // Number of subexpressions has been found in last Exec* call. + // If there are no subexpr. but whole expr was found (Exec* returned True), + // then SubExprMatchCount=0, if no subexpressions nor whole + // r.e. found (Exec* returned false) then SubExprMatchCount=-1. + // Note, that some subexpr. may be not found and for such + // subexpr. MathPos=MatchLen=-1 and Match=''. + // For example: Expression := '(1)?2(3)?'; + // Exec ('123'): SubExprMatchCount=2, Match[0]='123', [1]='1', [2]='3' + // Exec ('12'): SubExprMatchCount=1, Match[0]='12', [1]='1' + // Exec ('23'): SubExprMatchCount=2, Match[0]='23', [1]='', [2]='3' + // Exec ('2'): SubExprMatchCount=0, Match[0]='2' + // Exec ('7') - return False: SubExprMatchCount=-1 + + property MatchPos[Idx: integer]: integer read GetMatchPos; + // pos of entrance subexpr. #Idx into tested in last Exec* + // string. First subexpr. have Idx=1, last - MatchCount, + // whole r.e. have Idx=0. + // Returns -1 if in r.e. no such subexpr. or this subexpr. + // not found in input string. + + property MatchLen[Idx: integer]: integer read GetMatchLen; + // len of entrance subexpr. #Idx r.e. into tested in last Exec* + // string. First subexpr. have Idx=1, last - MatchCount, + // whole r.e. have Idx=0. + // Returns -1 if in r.e. no such subexpr. or this subexpr. + // not found in input string. + // Remember - MatchLen may be 0 (if r.e. match empty string) ! + + property Match[Idx: integer]: RegExprString read GetMatch; + // == copy (InputString, MatchPos [Idx], MatchLen [Idx]) + // Returns '' if in r.e. no such subexpr. or this subexpr. + // not found in input string. + + function LastError: integer; + // Returns ID of last error, 0 if no errors (unusable if + // Error method raises exception) and clear internal status + // into 0 (no errors). + + function ErrorMsg(AErrorID: integer): RegExprString; virtual; + // Returns Error message for error with ID = AErrorID. + + property CompilerErrorPos: integer read GetCompilerErrorPos; + // Returns pos in r.e. there compiler stopped. + // Usefull for error diagnostics + + property SpaceChars: RegExprString read fSpaceChars write fSpaceChars; + // ###0.927 + // Contains chars, treated as /s (initially filled with RegExprSpaceChars + // global constant) + + property WordChars: RegExprString read fWordChars write fWordChars; + // ###0.929 + // Contains chars, treated as /w (initially filled with RegExprWordChars + // global constant) + + property LineSeparators: RegExprString read fLineSeparators + write SetLineSeparators; // ###0.941 + // line separators (like \n in Unix) + + property LinePairedSeparator: RegExprString read GetLinePairedSeparator + write SetLinePairedSeparator; // ###0.941 + // paired line separator (like \r\n in DOS and Windows). + // must contain exactly two chars or no chars at all + + class function InvertCaseFunction(const Ch: REChar): REChar; + // Converts Ch into upper case if it in lower case or in lower + // if it in upper (uses current system local setings) + + property InvertCase: TRegExprInvertCaseFunction read fInvertCase + write fInvertCase; // ##0.935 + // Set this property if you want to override case-insensitive functionality. + // Create set it to RegExprInvertCaseFunction (InvertCaseFunction by default) + + procedure Compile; // ###0.941 + // [Re]compile r.e. Usefull for example for GUI r.e. editors (to check + // all properties validity). + +{$IFDEF DebugRegExpr} + function Dump: RegExprString; + // dump a compiled regexp in vaguely comprehensible form +{$ENDIF} + end; + + ERegExpr = class(Exception) + public + ErrorCode: integer; + CompilerErrorPos: integer; + end; + +var + RegExprInvertCaseFunction: TRegExprInvertCaseFunction = nil; + // defaul for InvertCase property + +function ExecRegExpr(const ARegExpr, AInputStr: RegExprString): boolean; +// true if string AInputString match regular expression ARegExpr +// ! will raise exeption if syntax errors in ARegExpr + + procedure SplitRegExpr(const ARegExpr, AInputStr: RegExprString; + APieces: TStrings); + // Split AInputStr into APieces by r.e. ARegExpr occurencies + + function ReplaceRegExpr(const ARegExpr, AInputStr, + AReplaceStr: RegExprString; + AUseSubstitution: boolean{$IFDEF D4_} = False{$ENDIF}): RegExprString; + // ###0.947 + // Returns AInputStr with r.e. occurencies replaced by AReplaceStr + // If AUseSubstitution is true, then AReplaceStr will be used + // as template for Substitution methods. + // For example: + // ReplaceRegExpr ('({-i}block|var)\s*\(\s*([^ ]*)\s*\)\s*', + // 'BLOCK( test1)', 'def "$1" value "$2"', True) + // will return: def 'BLOCK' value 'test1' + // ReplaceRegExpr ('({-i}block|var)\s*\(\s*([^ ]*)\s*\)\s*', + // 'BLOCK( test1)', 'def "$1" value "$2"') + // will return: def "$1" value "$2" + + function QuoteRegExprMetaChars(const AStr: RegExprString): RegExprString; + // Replace all metachars with its safe representation, + // for example 'abc$cd.(' converts into 'abc\$cd\.\(' + // This function usefull for r.e. autogeneration from + // user input + + function RegExprSubExpressions(const ARegExpr: AnsiString; + ASubExprs: TStrings; + AExtendedSyntax: boolean{$IFDEF D4_} = False{$ENDIF}): integer; + // Makes list of subexpressions found in ARegExpr r.e. + // In ASubExps every item represent subexpression, + // from first to last, in format: + // String - subexpression text (without '()') + // low word of Object - starting position in ARegExpr, including '(' + // if exists! (first position is 1) + // high word of Object - length, including starting '(' and ending ')' + // if exist! + // AExtendedSyntax - must be True if modifier /m will be On while + // using the r.e. + // Usefull for GUI editors of r.e. etc (You can find example of using + // in TestRExp.dpr project) + // Returns + // 0 Success. No unbalanced brackets was found; + // -1 There are not enough closing brackets ')'; + // -(n+1) At position n was found opening '[' without //###0.942 + // corresponding closing ']'; + // n At position n was found closing bracket ')' without + // corresponding opening '('. + // If Result <> 0, then ASubExpr can contain empty items or illegal ones + +implementation + +// uses +// Windows; // CharUpper/Lower + +const + TRegExprVersionMajor: integer = 0; + TRegExprVersionMinor: integer = 947; + // don't use this const directly, use TRegExpr.VersionXXX instead + + MaskModI = 1; // modifier /i bit in fModifiers + MaskModR = 2; // -"- /r + MaskModS = 4; // -"- /s + MaskModG = 8; // -"- /g + MaskModM = 16; // -"- /m + MaskModX = 32; // -"- /x + +{$IFDEF UniCode} + XIgnoredChars = ' '#9#$d#$a; +{$ELSE} + XIgnoredChars = [' ', #9, #$d, #$a]; +{$ENDIF} + { ============================================================= } + { =================== WideString functions ==================== } + { ============================================================= } + +{$IFDEF UniCode} + +function StrPCopy(Dest: PRegExprChar; const Source: RegExprString) + : PRegExprChar; +var + i, Len: integer; +begin + Len := length(Source); // ###0.932 + for i := 1 to Len do + Dest[i - 1] := Source[i]; + Dest[Len] := #0; + Result := Dest; +end; { of function StrPCopy + -------------------------------------------------------------- } + +function StrLCopy(Dest, Source: PRegExprChar; MaxLen: Cardinal): PRegExprChar; +var + i: integer; +begin + for i := 0 to MaxLen - 1 do + Dest[i] := Source[i]; + Result := Dest; +end; { of function StrLCopy + -------------------------------------------------------------- } + +function StrLen(str: PRegExprChar): Cardinal; +begin + Result := 0; + while str[Result] <> #0 do + Inc(Result); +end; { of function StrLen + -------------------------------------------------------------- } + +function StrPos(Str1, Str2: PRegExprChar): PRegExprChar; +var + n: integer; +begin + Result := nil; + n := Pos(RegExprString(Str2), RegExprString(Str1)); + if n = 0 then + EXIT; + Result := Str1 + n - 1; +end; { of function StrPos + -------------------------------------------------------------- } + +function StrLComp(Str1, Str2: PRegExprChar; MaxLen: Cardinal): integer; +var + S1, S2: RegExprString; +begin + S1 := Str1; + S2 := Str2; + if Copy(S1, 1, MaxLen) > Copy(S2, 1, MaxLen) then + Result := 1 + else if Copy(S1, 1, MaxLen) < Copy(S2, 1, MaxLen) then + Result := -1 + else + Result := 0; +end; { function StrLComp + -------------------------------------------------------------- } + +function StrScan(str: PRegExprChar; Chr: WideChar): PRegExprChar; +begin + Result := nil; + while (str^ <> #0) and (str^ <> Chr) do + Inc(str); + if (str^ <> #0) then + Result := str; +end; { of function StrScan + -------------------------------------------------------------- } + +{$ENDIF} +{ ============================================================= } +{ ===================== Global functions ====================== } +{ ============================================================= } + +function ExecRegExpr(const ARegExpr, AInputStr: RegExprString): boolean; +var + r: TRegExpr; +begin + r := TRegExpr.Create; + try + r.Expression := ARegExpr; + Result := r.Exec(AInputStr); + finally + r.Free; + end; +end; { of function ExecRegExpr + -------------------------------------------------------------- } + +procedure SplitRegExpr(const ARegExpr, AInputStr: RegExprString; + APieces: TStrings); +var + r: TRegExpr; +begin + APieces.Clear; + r := TRegExpr.Create; + try + r.Expression := ARegExpr; + r.Split(AInputStr, APieces); + finally + r.Free; + end; +end; { of procedure SplitRegExpr + -------------------------------------------------------------- } + +function ReplaceRegExpr(const ARegExpr, AInputStr, AReplaceStr: RegExprString; + AUseSubstitution: boolean{$IFDEF D4_} = False{$ENDIF}): RegExprString; +var + r: TRegExpr; +begin + r := TRegExpr.Create; + try + r.Expression := ARegExpr; + Result := r.Replace(AInputStr, AReplaceStr, AUseSubstitution); // ###0.947 + finally + r.Free; + end; +end; { of function ReplaceRegExpr + -------------------------------------------------------------- } + +function QuoteRegExprMetaChars(const AStr: RegExprString): RegExprString; +const + RegExprMetaSet: RegExprString = '^$.[()|?+*\{' + ']}'; + // - this last are additional to META. + // Very similar to META array, but slighly changed. + // !Any changes in META array must be synchronized with this set. +var + i, i0, Len: integer; +begin + Result := ''; + Len := length(AStr); + i := 1; + i0 := i; + while i <= Len do + begin + if Pos(AStr[i], RegExprMetaSet) > 0 then + begin + Result := Result + System.Copy(AStr, i0, i - i0) + '\' + AStr[i]; + i0 := i + 1; + end; + Inc(i); + end; + Result := Result + System.Copy(AStr, i0, MaxInt); // Tail +end; { of function QuoteRegExprMetaChars + -------------------------------------------------------------- } + +function RegExprSubExpressions(const ARegExpr: AnsiString; ASubExprs: TStrings; + AExtendedSyntax: boolean{$IFDEF D4_} = False{$ENDIF}): integer; +type + TStackItemRec = record // ###0.945 + SubExprIdx: integer; + StartPos: integer; + end; + + TStackArray = packed array [0 .. NSUBEXPMAX - 1] of TStackItemRec; +var + Len, SubExprLen: integer; + i, i0: integer; + Modif: integer; + Stack: ^TStackArray; // ###0.945 + StackIdx, StackSz: integer; +begin + Result := 0; // no unbalanced brackets found at this very moment + + ASubExprs.Clear; // I don't think that adding to non empty list + // can be usefull, so I simplified algorithm to work only with empty list + + Len := length(ARegExpr); // some optimization tricks + + // first we have to calculate number of subexpression to reserve + // space in Stack array (may be we'll reserve more then need, but + // it's faster then memory reallocation during parsing) + StackSz := 1; // add 1 for entire r.e. + for i := 1 to Len do + if ARegExpr[i] = '(' then + Inc(StackSz); + // SetLength (Stack, StackSz); //###0.945 + GetMem(Stack, SizeOf(TStackItemRec) * StackSz); + try + + StackIdx := 0; + i := 1; + while (i <= Len) do + begin + case ARegExpr[i] of + '(': + begin + if (i < Len) and (ARegExpr[i + 1] = '?') then + begin + // this is not subexpression, but comment or other + // Perl extension. We must check is it (?ismxrg-ismxrg) + // and change AExtendedSyntax if /x is changed. + Inc(i, 2); // skip '(?' + i0 := i; + while (i <= Len) and (ARegExpr[i] <> ')') do + Inc(i); + if i > Len then + Result := -1 // unbalansed '(' + else if TRegExpr.ParseModifiersStr(System.Copy(ARegExpr, i, + i - i0), Modif) then + AExtendedSyntax := (Modif and MaskModX) <> 0; + end + else + begin // subexpression starts + ASubExprs.Add(''); // just reserve space + with Stack^[StackIdx] do + begin + SubExprIdx := ASubExprs.Count - 1; + StartPos := i; + end; + Inc(StackIdx); + end; + end; + ')': + begin + if StackIdx = 0 then + Result := i // unbalanced ')' + else + begin + dec(StackIdx); + with Stack^[StackIdx] do + begin + SubExprLen := i - StartPos + 1; + ASubExprs.Objects[SubExprIdx] := + TObject(StartPos or (SubExprLen ShL 16)); + ASubExprs[SubExprIdx] := System.Copy(ARegExpr, StartPos + 1, + SubExprLen - 2); // add without brackets + end; + end; + end; + '\': + Inc(i); // skip quoted symbol + '[': + begin + // we have to skip character ranges at once, because they can + // contain '#', and '#' in it must NOT be recognized as eXtended + // comment beginning! + i0 := i; + Inc(i); + if ARegExpr[i] = ']' // cannot be 'emty' ranges - this interpretes + then + Inc(i); // as ']' by itself + while (i <= Len) and (ARegExpr[i] <> ']') do + if ARegExpr[i] = '\' // ###0.942 + then + Inc(i, 2) // skip 'escaped' char to prevent stopping at '\]' + else + Inc(i); + if (i > Len) or (ARegExpr[i] <> ']') // ###0.942 + then + Result := -(i0 + 1); // unbalansed '[' //###0.942 + end; + '#': + if AExtendedSyntax then + begin + // skip eXtended comments + while (i <= Len) and (ARegExpr[i] <> #$d) and (ARegExpr[i] <> #$a) + // do not use [#$d, #$a] due to UniCode compatibility + do + Inc(i); + while (i + 1 <= Len) and + ((ARegExpr[i + 1] = #$d) or (ARegExpr[i + 1] = #$a)) do + Inc(i); // attempt to work with different kinds of line separators + // now we are at the line separator that must be skipped. + end; + // here is no 'else' clause - we simply skip ordinary chars + end; // of case + Inc(i); // skip scanned char + // ! can move after Len due to skipping quoted symbol + end; + + // check brackets balance + if StackIdx <> 0 then + Result := -1; // unbalansed '(' + + // check if entire r.e. added + if (ASubExprs.Count = 0) or ((integer(ASubExprs.Objects[0]) and $FFFF) <> 1) + or (((integer(ASubExprs.Objects[0]) ShR 16) and $FFFF) <> Len) + // whole r.e. wasn't added because it isn't bracketed + // well, we add it now: + then + ASubExprs.InsertObject(0, ARegExpr, TObject((Len ShL 16) or 1)); + + finally + FreeMem(Stack); + end; +end; { of function RegExprSubExpressions + -------------------------------------------------------------- } + +const + MAGIC = TREOp(216); // programm signature + + // name opcode opnd? meaning + EEND = TREOp(0); // - End of program + BOL = TREOp(1); // - Match "" at beginning of line + EOL = TREOp(2); // - Match "" at end of line + ANY = TREOp(3); // - Match any one character + ANYOF = TREOp(4); // Str Match any character in string Str + ANYBUT = TREOp(5); // Str Match any char. not in string Str + BRANCH = TREOp(6); // Node Match this alternative, or the next + BACK = TREOp(7); // - Jump backward (Next < 0) + EXACTLY = TREOp(8); // Str Match string Str + NOTHING = TREOp(9); // - Match empty string + STAR = TREOp(10); // Node Match this (simple) thing 0 or more times + PLUS = TREOp(11); // Node Match this (simple) thing 1 or more times + ANYDIGIT = TREOp(12); // - Match any digit (equiv [0-9]) + NOTDIGIT = TREOp(13); // - Match not digit (equiv [0-9]) + ANYLETTER = TREOp(14); // - Match any letter from property WordChars + NOTLETTER = TREOp(15); // - Match not letter from property WordChars + ANYSPACE = TREOp(16); // - Match any space char (see property SpaceChars) + NOTSPACE = TREOp(17); // - Match not space char (see property SpaceChars) + BRACES = TREOp(18); + // Node,Min,Max Match this (simple) thing from Min to Max times. + // Min and Max are TREBracesArg + COMMENT = TREOp(19); // - Comment ;) + EXACTLYCI = TREOp(20); // Str Match string Str case insensitive + ANYOFCI = TREOp(21); + // Str Match any character in string Str, case insensitive + ANYBUTCI = TREOp(22); + // Str Match any char. not in string Str, case insensitive + LOOPENTRY = TREOp(23); // Node Start of loop (Node - LOOP for this loop) + LOOP = TREOp(24); // Node,Min,Max,LoopEntryJmp - back jump for LOOPENTRY. + // Min and Max are TREBracesArg + // Node - next node in sequence, + // LoopEntryJmp - associated LOOPENTRY node addr + ANYOFTINYSET = TREOp(25); + // Chrs Match any one char from Chrs (exactly TinySetLen chars) + ANYBUTTINYSET = TREOp(26); + // Chrs Match any one char not in Chrs (exactly TinySetLen chars) + ANYOFFULLSET = TREOp(27); // Set Match any one char from set of char + // - very fast (one CPU instruction !) but takes 32 bytes of p-code + BSUBEXP = TREOp(28); + // Idx Match previously matched subexpression #Idx (stored as REChar) //###0.936 + BSUBEXPCI = TREOp(29); // Idx -"- in case-insensitive mode + + // Non-Greedy Style Ops //###0.940 + STARNG = TREOp(30); // Same as START but in non-greedy mode + PLUSNG = TREOp(31); // Same as PLUS but in non-greedy mode + BRACESNG = TREOp(32); // Same as BRACES but in non-greedy mode + LOOPNG = TREOp(33); // Same as LOOP but in non-greedy mode + + // Multiline mode \m + BOLML = TREOp(34); // - Match "" at beginning of line + EOLML = TREOp(35); // - Match "" at end of line + ANYML = TREOp(36); // - Match any one character + + // Word boundary + BOUND = TREOp(37); // Match "" between words //###0.943 + NOTBOUND = TREOp(38); // Match "" not between words //###0.943 + + // !!! Change OPEN value if you add new opcodes !!! + + OPEN = TREOp(39); // - Mark this point in input as start of \n + // OPEN + 1 is \1, etc. + CLOSE = TREOp(ord(OPEN) + NSUBEXP); + // - Analogous to OPEN. + + // !!! Don't add new OpCodes after CLOSE !!! + + // We work with p-code thru pointers, compatible with PRegExprChar. + // Note: all code components (TRENextOff, TREOp, TREBracesArg, etc) + // must have lengths that can be divided by SizeOf (REChar) ! + // A node is TREOp of opcode followed Next "pointer" of TRENextOff type. + // The Next is a offset from the opcode of the node containing it. + // An operand, if any, simply follows the node. (Note that much of + // the code generation knows about this implicit relationship!) + // Using TRENextOff=integer speed up p-code processing. + + // Opcodes description: + // + // BRANCH The set of branches constituting a single choice are hooked + // together with their "next" pointers, since precedence prevents + // anything being concatenated to any individual branch. The + // "next" pointer of the last BRANCH in a choice points to the + // thing following the whole choice. This is also where the + // final "next" pointer of each individual branch points; each + // branch starts with the operand node of a BRANCH node. + // BACK Normal "next" pointers all implicitly point forward; BACK + // exists to make loop structures possible. + // STAR,PLUS,BRACES '?', and complex '*' and '+', are implemented as + // circular BRANCH structures using BACK. Complex '{min,max}' + // - as pair LOOPENTRY-LOOP (see below). Simple cases (one + // character per match) are implemented with STAR, PLUS and + // BRACES for speed and to minimize recursive plunges. + // LOOPENTRY,LOOP {min,max} are implemented as special pair + // LOOPENTRY-LOOP. Each LOOPENTRY initialize loopstack for + // current level. + // OPEN,CLOSE are numbered at compile time. + + { ============================================================= } + { ================== Error handling section =================== } + { ============================================================= } + +const + reeOk = 0; + reeCompNullArgument = 100; + reeCompRegexpTooBig = 101; + reeCompParseRegTooManyBrackets = 102; + reeCompParseRegUnmatchedBrackets = 103; + reeCompParseRegUnmatchedBrackets2 = 104; + reeCompParseRegJunkOnEnd = 105; + reePlusStarOperandCouldBeEmpty = 106; + reeNestedSQP = 107; + reeBadHexDigit = 108; + reeInvalidRange = 109; + reeParseAtomTrailingBackSlash = 110; + reeNoHexCodeAfterBSlashX = 111; + reeHexCodeAfterBSlashXTooBig = 112; + reeUnmatchedSqBrackets = 113; + reeInternalUrp = 114; + reeQPSBFollowsNothing = 115; + reeTrailingBackSlash = 116; + reeRarseAtomInternalDisaster = 119; + reeBRACESArgTooBig = 122; + reeBracesMinParamGreaterMax = 124; + reeUnclosedComment = 125; + reeComplexBracesNotImplemented = 126; + reeUrecognizedModifier = 127; + reeBadLinePairedSeparator = 128; + reeRegRepeatCalledInappropriately = 1000; + reeMatchPrimMemoryCorruption = 1001; + reeMatchPrimCorruptedPointers = 1002; + reeNoExpression = 1003; + reeCorruptedProgram = 1004; + reeNoInpitStringSpecified = 1005; + reeOffsetMustBeGreaterThen0 = 1006; + reeExecNextWithoutExec = 1007; + reeGetInputStringWithoutInputString = 1008; + reeDumpCorruptedOpcode = 1011; + reeModifierUnsupported = 1013; + reeLoopStackExceeded = 1014; + reeLoopWithoutEntry = 1015; + +function TRegExpr.ErrorMsg(AErrorID: integer): RegExprString; +begin + case AErrorID of + reeOk: + Result := 'No errors'; + reeCompNullArgument: + Result := 'TRegExpr(comp): Null Argument'; + reeCompRegexpTooBig: + Result := 'TRegExpr(comp): Regexp Too Big'; + reeCompParseRegTooManyBrackets: + Result := 'TRegExpr(comp): ParseReg Too Many ()'; + reeCompParseRegUnmatchedBrackets: + Result := 'TRegExpr(comp): ParseReg Unmatched ()'; + reeCompParseRegUnmatchedBrackets2: + Result := 'TRegExpr(comp): ParseReg Unmatched ()'; + reeCompParseRegJunkOnEnd: + Result := 'TRegExpr(comp): ParseReg Junk On End'; + reePlusStarOperandCouldBeEmpty: + Result := 'TRegExpr(comp): *+ Operand Could Be Empty'; + reeNestedSQP: + Result := 'TRegExpr(comp): Nested *?+'; + reeBadHexDigit: + Result := 'TRegExpr(comp): Bad Hex Digit'; + reeInvalidRange: + Result := 'TRegExpr(comp): Invalid [] Range'; + reeParseAtomTrailingBackSlash: + Result := 'TRegExpr(comp): Parse Atom Trailing \'; + reeNoHexCodeAfterBSlashX: + Result := 'TRegExpr(comp): No Hex Code After \x'; + reeHexCodeAfterBSlashXTooBig: + Result := 'TRegExpr(comp): Hex Code After \x Is Too Big'; + reeUnmatchedSqBrackets: + Result := 'TRegExpr(comp): Unmatched []'; + reeInternalUrp: + Result := 'TRegExpr(comp): Internal Urp'; + reeQPSBFollowsNothing: + Result := 'TRegExpr(comp): ?+*{ Follows Nothing'; + reeTrailingBackSlash: + Result := 'TRegExpr(comp): Trailing \'; + reeRarseAtomInternalDisaster: + Result := 'TRegExpr(comp): RarseAtom Internal Disaster'; + reeBRACESArgTooBig: + Result := 'TRegExpr(comp): BRACES Argument Too Big'; + reeBracesMinParamGreaterMax: + Result := 'TRegExpr(comp): BRACE Min Param Greater then Max'; + reeUnclosedComment: + Result := 'TRegExpr(comp): Unclosed (?#Comment)'; + reeComplexBracesNotImplemented: + Result := 'TRegExpr(comp): If you want take part in beta-testing BRACES ''{min,max}'' and non-greedy ops ''*?'', ''+?'', ''??'' for complex cases - remove ''.'' from {.$DEFINE ComplexBraces}'; + reeUrecognizedModifier: + Result := 'TRegExpr(comp): Urecognized Modifier'; + reeBadLinePairedSeparator: + Result := 'TRegExpr(comp): LinePairedSeparator must countain two different chars or no chars at all'; + + reeRegRepeatCalledInappropriately: + Result := 'TRegExpr(exec): RegRepeat Called Inappropriately'; + reeMatchPrimMemoryCorruption: + Result := 'TRegExpr(exec): MatchPrim Memory Corruption'; + reeMatchPrimCorruptedPointers: + Result := 'TRegExpr(exec): MatchPrim Corrupted Pointers'; + reeNoExpression: + Result := 'TRegExpr(exec): Not Assigned Expression Property'; + reeCorruptedProgram: + Result := 'TRegExpr(exec): Corrupted Program'; + reeNoInpitStringSpecified: + Result := 'TRegExpr(exec): No Inpit String Specified'; + reeOffsetMustBeGreaterThen0: + Result := 'TRegExpr(exec): Offset Must Be Greater Then 0'; + reeExecNextWithoutExec: + Result := 'TRegExpr(exec): ExecNext Without Exec[Pos]'; + reeGetInputStringWithoutInputString: + Result := 'TRegExpr(exec): GetInputString Without InputString'; + reeDumpCorruptedOpcode: + Result := 'TRegExpr(dump): Corrupted Opcode'; + reeLoopStackExceeded: + Result := 'TRegExpr(exec): Loop Stack Exceeded'; + reeLoopWithoutEntry: + Result := 'TRegExpr(exec): Loop Without LoopEntry !'; + else + Result := 'Unknown error'; + end; +end; { of procedure TRegExpr.Error + -------------------------------------------------------------- } + +function TRegExpr.LastError: integer; +begin + Result := fLastError; + fLastError := reeOk; +end; { of function TRegExpr.LastError + -------------------------------------------------------------- } + +{ ============================================================= } +{ ===================== Common section ======================== } +{ ============================================================= } + +class function TRegExpr.VersionMajor: integer; // ###0.944 +begin + Result := TRegExprVersionMajor; +end; { of class function TRegExpr.VersionMajor + -------------------------------------------------------------- } + +class function TRegExpr.VersionMinor: integer; // ###0.944 +begin + Result := TRegExprVersionMinor; +end; { of class function TRegExpr.VersionMinor + -------------------------------------------------------------- } + +constructor TRegExpr.Create; +begin + inherited; + programm := nil; + fExpression := nil; + fInputString := nil; + + regexpbeg := nil; + fExprIsCompiled := False; + + ModifierI := RegExprModifierI; + ModifierR := RegExprModifierR; + ModifierS := RegExprModifierS; + ModifierG := RegExprModifierG; + ModifierM := RegExprModifierM; // ###0.940 + + SpaceChars := RegExprSpaceChars; // ###0.927 + WordChars := RegExprWordChars; // ###0.929 + fInvertCase := RegExprInvertCaseFunction; // ###0.927 + + fLineSeparators := RegExprLineSeparators; // ###0.941 + LinePairedSeparator := RegExprLinePairedSeparator; // ###0.941 +end; { of constructor TRegExpr.Create + -------------------------------------------------------------- } + +destructor TRegExpr.Destroy; +begin + if programm <> nil then + FreeMem(programm); + if fExpression <> nil then + FreeMem(fExpression); + if fInputString <> nil then + FreeMem(fInputString); +end; { of destructor TRegExpr.Destroy + -------------------------------------------------------------- } + +class function TRegExpr.InvertCaseFunction(const Ch: REChar): REChar; +var + s: String; +begin +{$IFDEF UniCode} + if Ch >= #128 then + Result := Ch + else +{$ENDIF} + begin + // Result := REChar (CharUpper (pointer (Ch))); + Result := REChar(UpCase(Ch)); + if Result = Ch + // then Result := REChar (CharLower (pointer (Ch))); + then + begin + s := LowerCase(Ch); + Result := REChar(s[1]); + end; + end; +end; { of function TRegExpr.InvertCaseFunction + -------------------------------------------------------------- } + +function TRegExpr.GetExpression: RegExprString; +begin + if fExpression <> nil then + Result := fExpression + else + Result := ''; +end; { of function TRegExpr.GetExpression + -------------------------------------------------------------- } + +procedure TRegExpr.SetExpression(const s: RegExprString); +begin + if (s <> fExpression) or not fExprIsCompiled then + begin + fExprIsCompiled := False; + if fExpression <> nil then + begin + FreeMem(fExpression); + fExpression := nil; + end; + if s <> '' then + begin + GetMem(fExpression, (length(s) + 1) * SizeOf(REChar)); + StrPCopy(fExpression, s); + InvalidateProgramm; // ###0.941 + end; + end; +end; { of procedure TRegExpr.SetExpression + -------------------------------------------------------------- } + +function TRegExpr.GetSubExprMatchCount: integer; +begin + if Assigned(fInputString) then + begin + Result := NSUBEXP - 1; + while (Result > 0) and ((startp[Result] = nil) or (endp[Result] = nil)) do + dec(Result); + end + else + Result := -1; +end; { of function TRegExpr.GetSubExprMatchCount + -------------------------------------------------------------- } + +function TRegExpr.GetMatchPos(Idx: integer): integer; +begin + if (Idx >= 0) and (Idx < NSUBEXP) and Assigned(fInputString) and + Assigned(startp[Idx]) and Assigned(endp[Idx]) then + begin + Result := (startp[Idx] - fInputString) + 1; + end + else + Result := -1; +end; { of function TRegExpr.GetMatchPos + -------------------------------------------------------------- } + +function TRegExpr.GetMatchLen(Idx: integer): integer; +begin + if (Idx >= 0) and (Idx < NSUBEXP) and Assigned(fInputString) and + Assigned(startp[Idx]) and Assigned(endp[Idx]) then + begin + Result := endp[Idx] - startp[Idx]; + end + else + Result := -1; +end; { of function TRegExpr.GetMatchLen + -------------------------------------------------------------- } + +function TRegExpr.GetMatch(Idx: integer): RegExprString; +begin + if (Idx >= 0) and (Idx < NSUBEXP) and Assigned(fInputString) and + Assigned(startp[Idx]) and Assigned(endp[Idx]) + // then Result := copy (fInputString, MatchPos [Idx], MatchLen [Idx]) //###0.929 + then + SetString(Result, startp[Idx], endp[Idx] - startp[Idx]) + else + Result := ''; +end; { of function TRegExpr.GetMatch + -------------------------------------------------------------- } + +function TRegExpr.GetModifierStr: RegExprString; +begin + Result := '-'; + + if ModifierI then + Result := 'i' + Result + else + Result := Result + 'i'; + if ModifierR then + Result := 'r' + Result + else + Result := Result + 'r'; + if ModifierS then + Result := 's' + Result + else + Result := Result + 's'; + if ModifierG then + Result := 'g' + Result + else + Result := Result + 'g'; + if ModifierM then + Result := 'm' + Result + else + Result := Result + 'm'; + if ModifierX then + Result := 'x' + Result + else + Result := Result + 'x'; + + if Result[length(Result)] = '-' // remove '-' if all modifiers are 'On' + then + System.Delete(Result, length(Result), 1); +end; { of function TRegExpr.GetModifierStr + -------------------------------------------------------------- } + +class function TRegExpr.ParseModifiersStr(const AModifiers: RegExprString; + var AModifiersInt: integer): boolean; +// !!! Be carefull - this is class function and must not use object instance fields +var + i: integer; + IsOn: boolean; + Mask: integer; +begin + Result := True; + IsOn := True; + Mask := 0; // prevent compiler warning + for i := 1 to length(AModifiers) do + if AModifiers[i] = '-' then + IsOn := False + else + begin + if Pos(AModifiers[i], 'iI') > 0 then + Mask := MaskModI + else if Pos(AModifiers[i], 'rR') > 0 then + Mask := MaskModR + else if Pos(AModifiers[i], 'sS') > 0 then + Mask := MaskModS + else if Pos(AModifiers[i], 'gG') > 0 then + Mask := MaskModG + else if Pos(AModifiers[i], 'mM') > 0 then + Mask := MaskModM + else if Pos(AModifiers[i], 'xX') > 0 then + Mask := MaskModX + else + begin + Result := False; + EXIT; + end; + if IsOn then + AModifiersInt := AModifiersInt or Mask + else + AModifiersInt := AModifiersInt and not Mask; + end; +end; { of function TRegExpr.ParseModifiersStr + -------------------------------------------------------------- } + +procedure TRegExpr.SetModifierStr(const AModifiers: RegExprString); +begin + if not ParseModifiersStr(AModifiers, fModifiers) then + Error(reeModifierUnsupported); +end; { of procedure TRegExpr.SetModifierStr + -------------------------------------------------------------- } + +function TRegExpr.GetModifier(AIndex: integer): boolean; +var + Mask: integer; +begin + Result := False; + case AIndex of + 1: + Mask := MaskModI; + 2: + Mask := MaskModR; + 3: + Mask := MaskModS; + 4: + Mask := MaskModG; + 5: + Mask := MaskModM; + 6: + Mask := MaskModX; + else + begin + Error(reeModifierUnsupported); + EXIT; + end; + end; + Result := (fModifiers and Mask) <> 0; +end; { of function TRegExpr.GetModifier + -------------------------------------------------------------- } + +procedure TRegExpr.SetModifier(AIndex: integer; ASet: boolean); +var + Mask: integer; +begin + case AIndex of + 1: + Mask := MaskModI; + 2: + Mask := MaskModR; + 3: + Mask := MaskModS; + 4: + Mask := MaskModG; + 5: + Mask := MaskModM; + 6: + Mask := MaskModX; + else + begin + Error(reeModifierUnsupported); + EXIT; + end; + end; + if ASet then + fModifiers := fModifiers or Mask + else + fModifiers := fModifiers and not Mask; +end; { of procedure TRegExpr.SetModifier + -------------------------------------------------------------- } + +{ ============================================================= } +{ ==================== Compiler section ======================= } +{ ============================================================= } + +procedure TRegExpr.InvalidateProgramm; +begin + if programm <> nil then + begin + FreeMem(programm); + programm := nil; + end; +end; { of procedure TRegExpr.InvalidateProgramm + -------------------------------------------------------------- } + +procedure TRegExpr.Compile; // ###0.941 +begin + if fExpression = nil then + begin // No Expression assigned + Error(reeNoExpression); + EXIT; + end; + CompileRegExpr(fExpression); +end; { of procedure TRegExpr.Compile + -------------------------------------------------------------- } + +function TRegExpr.IsProgrammOk: boolean; +{$IFNDEF UniCode} +var + i: integer; +{$ENDIF} +begin + Result := False; + + // check modifiers + if fModifiers <> fProgModifiers // ###0.941 + then + InvalidateProgramm; + + // can we optimize line separators by using sets? +{$IFNDEF UniCode} + fLineSeparatorsSet := []; + for i := 1 to length(fLineSeparators) do + System.Include(fLineSeparatorsSet, fLineSeparators[i]); +{$ENDIF} + // [Re]compile if needed + if programm = nil then + Compile; // ###0.941 + + // check [re]compiled programm + if programm = nil then + EXIT // error was set/raised by Compile (was reeExecAfterCompErr) + else if programm[0] <> MAGIC // Program corrupted. + then + Error(reeCorruptedProgram) + else + Result := True; +end; { of function TRegExpr.IsProgrammOk + -------------------------------------------------------------- } + +procedure TRegExpr.Tail(p: PRegExprChar; val: PRegExprChar); +// set the next-pointer at the end of a node chain +var + scan: PRegExprChar; + temp: PRegExprChar; +begin + if p = @regdummy then + EXIT; + // Find last node. + scan := p; + REPEAT + temp := regnext(scan); + if temp = nil then + BREAK; + scan := temp; + UNTIL False; + // Set Next 'pointer' + PRENextOff(scan + REOpSz)^ := val - scan; // ###0.933 +end; { of procedure TRegExpr.Tail + -------------------------------------------------------------- } + +procedure TRegExpr.OpTail(p: PRegExprChar; val: PRegExprChar); +// regtail on operand of first argument; nop if operandless +begin + // "Operandless" and "op != BRANCH" are synonymous in practice. + if (p = nil) or (p = @regdummy) or (PREOp(p)^ <> BRANCH) then + EXIT; + Tail(p + REOpSz + RENextOffSz, val); // ###0.933 +end; { of procedure TRegExpr.OpTail + -------------------------------------------------------------- } + +function TRegExpr.EmitNode(op: TREOp): PRegExprChar; // ###0.933 +// emit a node, return location +begin + Result := regcode; + if Result <> @regdummy then + begin + PREOp(regcode)^ := op; + Inc(regcode, REOpSz); + PRENextOff(regcode)^ := 0; // Next "pointer" := nil + Inc(regcode, RENextOffSz); + end + else + Inc(regsize, REOpSz + RENextOffSz); + // compute code size without code generation +end; { of function TRegExpr.EmitNode + -------------------------------------------------------------- } + +procedure TRegExpr.EmitC(b: REChar); +// emit a byte to code +begin + if regcode <> @regdummy then + begin + regcode^ := b; + Inc(regcode); + end + else + Inc(regsize); // Type of p-code pointer always is ^REChar +end; { of procedure TRegExpr.EmitC + -------------------------------------------------------------- } + +procedure TRegExpr.InsertOperator(op: TREOp; opnd: PRegExprChar; sz: integer); +// insert an operator in front of already-emitted operand +// Means relocating the operand. +var + src, dst, place: PRegExprChar; + i: integer; +begin + if regcode = @regdummy then + begin + Inc(regsize, sz); + EXIT; + end; + src := regcode; + Inc(regcode, sz); + dst := regcode; + while src > opnd do + begin + dec(dst); + dec(src); + dst^ := src^; + end; + place := opnd; // Op node, where operand used to be. + PREOp(place)^ := op; + Inc(place, REOpSz); + for i := 1 + REOpSz to sz do + begin + place^ := #0; + Inc(place); + end; +end; { of procedure TRegExpr.InsertOperator + -------------------------------------------------------------- } + +function strcspn(S1: PRegExprChar; S2: PRegExprChar): integer; +// find length of initial segment of s1 consisting +// entirely of characters not from s2 +var + scan1, scan2: PRegExprChar; +begin + Result := 0; + scan1 := S1; + while scan1^ <> #0 do + begin + scan2 := S2; + while scan2^ <> #0 do + if scan1^ = scan2^ then + EXIT + else + Inc(scan2); + Inc(Result); + Inc(scan1) + end; +end; { of function strcspn + -------------------------------------------------------------- } + +const + // Flags to be passed up and down. + HASWIDTH = 01; // Known never to match nil string. + SIMPLE = 02; // Simple enough to be STAR/PLUS/BRACES operand. + SPSTART = 04; // Starts with * or +. + WORST = 0; // Worst case. + META: array [0 .. 12] of REChar = ('^', '$', '.', '[', '(', ')', '|', '?', + '+', '*', '\', '{', #0); + // Any modification must be synchronized with QuoteRegExprMetaChars !!! + +{$IFDEF UniCode} + RusRangeLo: array [0 .. 33] of REChar = (#$430, #$431, #$432, #$433, #$434, + #$435, #$451, #$436, #$437, #$438, #$439, #$43A, #$43B, #$43C, #$43D, #$43E, + #$43F, #$440, #$441, #$442, #$443, #$444, #$445, #$446, #$447, #$448, #$449, + #$44A, #$44B, #$44C, #$44D, #$44E, #$44F, #0); + RusRangeHi: array [0 .. 33] of REChar = (#$410, #$411, #$412, #$413, #$414, + #$415, #$401, #$416, #$417, #$418, #$419, #$41A, #$41B, #$41C, #$41D, #$41E, + #$41F, #$420, #$421, #$422, #$423, #$424, #$425, #$426, #$427, #$428, #$429, + #$42A, #$42B, #$42C, #$42D, #$42E, #$42F, #0); + RusRangeLoLow = #$430 { '? }; + RusRangeLoHigh = #$44F { 'ÿ' }; + RusRangeHiLow = #$410 { '? }; + RusRangeHiHigh = #$42F { '? }; +{$ELSE} + RusRangeLo = 'àáâãäå¸æçèéêëìíîïðñòóôõö÷øùúûüýþÿ'; + RusRangeHi = 'ÀÁÂÃÄŨÆÇÈÉÊËÌÍÎÏÐÑÒÓÔÕÖ×ØÙÚÛÜÝÞ?; RusRangeLoLow = '?; RusRangeLoHigh = 'ÿ'; +RusRangeHiLow = '?; RusRangeHiHigh = '?; +{$ENDIF} +function TRegExpr.CompileRegExpr(exp: PRegExprChar): boolean; + +// compile a regular expression into internal code +// We can't allocate space until we know how big the compiled form will be, +// but we can't compile it (and thus know how big it is) until we've got a +// place to put the code. So we cheat: we compile it twice, once with code +// generation turned off and size counting turned on, and once "for real". +// This also means that we don't allocate space until we are sure that the +// thing really will compile successfully, and we never have to move the +// code and thus invalidate pointers into it. (Note that it has to be in +// one piece because free() must be able to free it all.) +// Beware that the optimization-preparation code in here knows about some +// of the structure of the compiled regexp. +var + scan, longest: PRegExprChar; + Len: Cardinal; + flags: integer; +begin + Result := False; // life too dark + + regparse := nil; // for correct error handling + regexpbeg := exp; + try + + if programm <> nil then + begin + FreeMem(programm); + programm := nil; + end; + + if exp = nil then + begin + Error(reeCompNullArgument); + EXIT; + end; + + fProgModifiers := fModifiers; + // well, may it's paranoia. I'll check it later... !!!!!!!! + + // First pass: determine size, legality. + fCompModifiers := fModifiers; + regparse := exp; + regnpar := 1; + regsize := 0; + regcode := @regdummy; + EmitC(MAGIC); + if ParseReg(0, flags) = nil then + EXIT; + + // Small enough for 2-bytes programm pointers ? + // ###0.933 no real p-code length limits now :))) + // if regsize >= 64 * 1024 then begin + // Error (reeCompRegexpTooBig); + // EXIT; + // end; + + // Allocate space. + GetMem(programm, regsize * SizeOf(REChar)); + + // Second pass: emit code. + fCompModifiers := fModifiers; + regparse := exp; + regnpar := 1; + regcode := programm; + EmitC(MAGIC); + if ParseReg(0, flags) = nil then + EXIT; + + // Dig out information for optimizations. +{$IFDEF UseFirstCharSet} // ###0.929 + FirstCharSet := []; + FillFirstCharSet(programm + REOpSz); +{$ENDIF} + regstart := #0; // Worst-case defaults. + reganch := #0; + regmust := nil; + regmlen := 0; + scan := programm + REOpSz; // First BRANCH. + if PREOp(regnext(scan))^ = EEND then + begin // Only one top-level choice. + scan := scan + REOpSz + RENextOffSz; + + // Starting-point info. + if PREOp(scan)^ = EXACTLY then + regstart := (scan + REOpSz + RENextOffSz)^ + else if PREOp(scan)^ = BOL then + Inc(reganch); + + // If there's something expensive in the r.e., find the longest + // literal string that must appear and make it the regmust. Resolve + // ties in favor of later strings, since the regstart check works + // with the beginning of the r.e. and avoiding duplication + // strengthens checking. Not a strong reason, but sufficient in the + // absence of others. + if (flags and SPSTART) <> 0 then + begin + longest := nil; + Len := 0; + while scan <> nil do + begin + if (PREOp(scan)^ = EXACTLY) and + (StrLen(scan + REOpSz + RENextOffSz) >= Len) then + begin + longest := scan + REOpSz + RENextOffSz; + Len := StrLen(longest); + end; + scan := regnext(scan); + end; + regmust := longest; + regmlen := Len; + end; + end; + + Result := True; + + finally + begin + if not Result then + InvalidateProgramm; + regexpbeg := nil; + fExprIsCompiled := Result; // ###0.944 + end; + end; + +end; { of function TRegExpr.CompileRegExpr + -------------------------------------------------------------- } + +function TRegExpr.ParseReg(paren: integer; var flagp: integer): PRegExprChar; +// regular expression, i.e. main body or parenthesized thing +// Caller must absorb opening parenthesis. +// Combining parenthesis handling with the base level of regular expression +// is a trifle forced, but the need to tie the tails of the branches to what +// follows makes it hard to avoid. +var + ret, br, ender: PRegExprChar; + parno: integer; + flags: integer; + SavedModifiers: integer; +begin + Result := nil; + flagp := HASWIDTH; // Tentatively. + parno := 0; // eliminate compiler stupid warning + SavedModifiers := fCompModifiers; + + // Make an OPEN node, if parenthesized. + if paren <> 0 then + begin + if regnpar >= NSUBEXP then + begin + Error(reeCompParseRegTooManyBrackets); + EXIT; + end; + parno := regnpar; + Inc(regnpar); + ret := EmitNode(TREOp(ord(OPEN) + parno)); + end + else + ret := nil; + + // Pick up the branches, linking them together. + br := ParseBranch(flags); + if br = nil then + begin + Result := nil; + EXIT; + end; + if ret <> nil then + Tail(ret, br) // OPEN -> first. + else + ret := br; + if (flags and HASWIDTH) = 0 then + flagp := flagp and not HASWIDTH; + flagp := flagp or flags and SPSTART; + while (regparse^ = '|') do + begin + Inc(regparse); + br := ParseBranch(flags); + if br = nil then + begin + Result := nil; + EXIT; + end; + Tail(ret, br); // BRANCH -> BRANCH. + if (flags and HASWIDTH) = 0 then + flagp := flagp and not HASWIDTH; + flagp := flagp or flags and SPSTART; + end; + + // Make a closing node, and hook it on the end. + if paren <> 0 then + ender := EmitNode(TREOp(ord(CLOSE) + parno)) + else + ender := EmitNode(EEND); + Tail(ret, ender); + + // Hook the tails of the branches to the closing node. + br := ret; + while br <> nil do + begin + OpTail(br, ender); + br := regnext(br); + end; + + // Check for proper termination. + if paren <> 0 then + if regparse^ <> ')' then + begin + Error(reeCompParseRegUnmatchedBrackets); + EXIT; + end + else + Inc(regparse); // skip trailing ')' + if (paren = 0) and (regparse^ <> #0) then + begin + if regparse^ = ')' then + Error(reeCompParseRegUnmatchedBrackets2) + else + Error(reeCompParseRegJunkOnEnd); + EXIT; + end; + fCompModifiers := SavedModifiers; // restore modifiers of parent + Result := ret; +end; { of function TRegExpr.ParseReg + -------------------------------------------------------------- } + +function TRegExpr.ParseBranch(var flagp: integer): PRegExprChar; +// one alternative of an | operator +// Implements the concatenation operator. +var + ret, chain, latest: PRegExprChar; + flags: integer; +begin + flagp := WORST; // Tentatively. + + ret := EmitNode(BRANCH); + chain := nil; + while (regparse^ <> #0) and (regparse^ <> '|') and (regparse^ <> ')') do + begin + latest := ParsePiece(flags); + if latest = nil then + begin + Result := nil; + EXIT; + end; + flagp := flagp or flags and HASWIDTH; + if chain = nil // First piece. + then + flagp := flagp or flags and SPSTART + else + Tail(chain, latest); + chain := latest; + end; + if chain = nil // Loop ran zero times. + then + EmitNode(NOTHING); + Result := ret; +end; { of function TRegExpr.ParseBranch + -------------------------------------------------------------- } + +function TRegExpr.ParsePiece(var flagp: integer): PRegExprChar; +// something followed by possible [*+?{] +// Note that the branching code sequences used for ? and the general cases +// of * and + and { are somewhat optimized: they use the same NOTHING node as +// both the endmarker for their branch list and the body of the last branch. +// It might seem that this node could be dispensed with entirely, but the +// endmarker role is not redundant. + function parsenum(AStart, AEnd: PRegExprChar): TREBracesArg; + begin + Result := 0; + if AEnd - AStart + 1 > 8 then + begin // prevent stupid scanning + Error(reeBRACESArgTooBig); + EXIT; + end; + while AStart <= AEnd do + begin + Result := Result * 10 + (ord(AStart^) - ord('0')); + Inc(AStart); + end; + if (Result > MaxBracesArg) or (Result < 0) then + begin + Error(reeBRACESArgTooBig); + EXIT; + end; + end; + +var + op: REChar; + NonGreedyOp, NonGreedyCh: boolean; // ###0.940 + TheOp: TREOp; // ###0.940 + NextNode: PRegExprChar; + flags: integer; + BracesMin, Bracesmax: TREBracesArg; + p, savedparse: PRegExprChar; + + procedure EmitComplexBraces(ABracesMin, ABracesMax: TREBracesArg; + ANonGreedyOp: boolean); // ###0.940 +{$IFDEF ComplexBraces} + var + off: integer; +{$ENDIF} + begin +{$IFNDEF ComplexBraces} + Error(reeComplexBracesNotImplemented); +{$ELSE} + if ANonGreedyOp then + TheOp := LOOPNG + else + TheOp := LOOP; + InsertOperator(LOOPENTRY, Result, REOpSz + RENextOffSz); + NextNode := EmitNode(TheOp); + if regcode <> @regdummy then + begin + off := (Result + REOpSz + RENextOffSz) - (regcode - REOpSz - RENextOffSz); + // back to Atom after LOOPENTRY + PREBracesArg(regcode)^ := ABracesMin; + Inc(regcode, REBracesArgSz); + PREBracesArg(regcode)^ := ABracesMax; + Inc(regcode, REBracesArgSz); + PRENextOff(regcode)^ := off; + Inc(regcode, RENextOffSz); + end + else + Inc(regsize, REBracesArgSz * 2 + RENextOffSz); + Tail(Result, NextNode); // LOOPENTRY -> LOOP + if regcode <> @regdummy then + Tail(Result + REOpSz + RENextOffSz, NextNode); // Atom -> LOOP +{$ENDIF} + end; + + procedure EmitSimpleBraces(ABracesMin, ABracesMax: TREBracesArg; + ANonGreedyOp: boolean); // ###0.940 + begin + if ANonGreedyOp // ###0.940 + then + TheOp := BRACESNG + else + TheOp := BRACES; + InsertOperator(TheOp, Result, REOpSz + RENextOffSz + REBracesArgSz * 2); + if regcode <> @regdummy then + begin + PREBracesArg(Result + REOpSz + RENextOffSz)^ := ABracesMin; + PREBracesArg(Result + REOpSz + RENextOffSz + REBracesArgSz)^ := + ABracesMax; + end; + end; + +begin + Result := ParseAtom(flags); + if Result = nil then + EXIT; + + op := regparse^; + if not((op = '*') or (op = '+') or (op = '?') or (op = '{')) then + begin + flagp := flags; + EXIT; + end; + if ((flags and HASWIDTH) = 0) and (op <> '?') then + begin + Error(reePlusStarOperandCouldBeEmpty); + EXIT; + end; + + case op of + '*': + begin + flagp := WORST or SPSTART; + NonGreedyCh := (regparse + 1)^ = '?'; // ###0.940 + NonGreedyOp := NonGreedyCh or ((fCompModifiers and MaskModG) = 0); + // ###0.940 + if (flags and SIMPLE) = 0 then + begin + if NonGreedyOp // ###0.940 + then + EmitComplexBraces(0, MaxBracesArg, NonGreedyOp) + else + begin // Emit x* as (x&|), where & means "self". + InsertOperator(BRANCH, Result, REOpSz + RENextOffSz); // Either x + OpTail(Result, EmitNode(BACK)); // and loop + OpTail(Result, Result); // back + Tail(Result, EmitNode(BRANCH)); // or + Tail(Result, EmitNode(NOTHING)); // nil. + end + end + else + begin // Simple + if NonGreedyOp // ###0.940 + then + TheOp := STARNG + else + TheOp := STAR; + InsertOperator(TheOp, Result, REOpSz + RENextOffSz); + end; + if NonGreedyCh // ###0.940 + then + Inc(regparse); // Skip extra char ('?') + end; { of case '*' } + '+': + begin + flagp := WORST or SPSTART or HASWIDTH; + NonGreedyCh := (regparse + 1)^ = '?'; // ###0.940 + NonGreedyOp := NonGreedyCh or ((fCompModifiers and MaskModG) = 0); + // ###0.940 + if (flags and SIMPLE) = 0 then + begin + if NonGreedyOp // ###0.940 + then + EmitComplexBraces(1, MaxBracesArg, NonGreedyOp) + else + begin // Emit x+ as x(&|), where & means "self". + NextNode := EmitNode(BRANCH); // Either + Tail(Result, NextNode); + Tail(EmitNode(BACK), Result); // loop back + Tail(NextNode, EmitNode(BRANCH)); // or + Tail(Result, EmitNode(NOTHING)); // nil. + end + end + else + begin // Simple + if NonGreedyOp // ###0.940 + then + TheOp := PLUSNG + else + TheOp := PLUS; + InsertOperator(TheOp, Result, REOpSz + RENextOffSz); + end; + if NonGreedyCh // ###0.940 + then + Inc(regparse); // Skip extra char ('?') + end; { of case '+' } + '?': + begin + flagp := WORST; + NonGreedyCh := (regparse + 1)^ = '?'; // ###0.940 + NonGreedyOp := NonGreedyCh or ((fCompModifiers and MaskModG) = 0); + // ###0.940 + if NonGreedyOp then + begin // ###0.940 // We emit x?? as x{0,1}? + if (flags and SIMPLE) = 0 then + EmitComplexBraces(0, 1, NonGreedyOp) + else + EmitSimpleBraces(0, 1, NonGreedyOp); + end + else + begin // greedy '?' + InsertOperator(BRANCH, Result, REOpSz + RENextOffSz); // Either x + Tail(Result, EmitNode(BRANCH)); // or + NextNode := EmitNode(NOTHING); // nil. + Tail(Result, NextNode); + OpTail(Result, NextNode); + end; + if NonGreedyCh // ###0.940 + then + Inc(regparse); // Skip extra char ('?') + end; { of case '?' } + '{': + begin + savedparse := regparse; + // !!!!!!!!!!!! + // Filip Jirsak's note - what will happen, when we are at the end of regparse? + Inc(regparse); + p := regparse; + while Pos(regparse^, '0123456789') > 0 // MUST appear + do + Inc(regparse); + if (regparse^ <> '}') and (regparse^ <> ',') or (p = regparse) then + begin + regparse := savedparse; + flagp := flags; + EXIT; + end; + BracesMin := parsenum(p, regparse - 1); + if regparse^ = ',' then + begin + Inc(regparse); + p := regparse; + while Pos(regparse^, '0123456789') > 0 do + Inc(regparse); + if regparse^ <> '}' then + begin + regparse := savedparse; + EXIT; + end; + if p = regparse then + Bracesmax := MaxBracesArg + else + Bracesmax := parsenum(p, regparse - 1); + end + else + Bracesmax := BracesMin; // {n} == {n,n} + if BracesMin > Bracesmax then + begin + Error(reeBracesMinParamGreaterMax); + EXIT; + end; + if BracesMin > 0 then + flagp := WORST; + if Bracesmax > 0 then + flagp := flagp or HASWIDTH or SPSTART; + + NonGreedyCh := (regparse + 1)^ = '?'; // ###0.940 + NonGreedyOp := NonGreedyCh or ((fCompModifiers and MaskModG) = 0); + // ###0.940 + if (flags and SIMPLE) <> 0 then + EmitSimpleBraces(BracesMin, Bracesmax, NonGreedyOp) + else + EmitComplexBraces(BracesMin, Bracesmax, NonGreedyOp); + if NonGreedyCh // ###0.940 + then + Inc(regparse); // Skip extra char '?' + end; // { of case '{'} + // else here we can't be + end; { of case op } + + Inc(regparse); + if (regparse^ = '*') or (regparse^ = '+') or (regparse^ = '?') or + (regparse^ = '{') then + begin + Error(reeNestedSQP); + EXIT; + end; +end; { of function TRegExpr.ParsePiece + -------------------------------------------------------------- } + +function TRegExpr.ParseAtom(var flagp: integer): PRegExprChar; +// the lowest level +// Optimization: gobbles an entire sequence of ordinary characters so that +// it can turn them into a single node, which is smaller to store and +// faster to run. Backslashed characters are exceptions, each becoming a +// separate node; the code is simpler that way and it's not worth fixing. +var + ret: PRegExprChar; + flags: integer; + RangeBeg, RangeEnd: REChar; + CanBeRange: boolean; + Len: integer; + ender: REChar; + begmodfs: PRegExprChar; + +{$IFDEF UseSetOfChar} // ###0.930 + RangePCodeBeg: PRegExprChar; + RangePCodeIdx: integer; + RangeIsCI: boolean; + RangeSet: TSetOfREChar; + RangeLen: integer; + RangeChMin, RangeChMax: REChar; +{$ENDIF} + procedure EmitExactly(Ch: REChar); + begin + if (fCompModifiers and MaskModI) <> 0 then + ret := EmitNode(EXACTLYCI) + else + ret := EmitNode(EXACTLY); + EmitC(Ch); + EmitC(#0); + flagp := flagp or HASWIDTH or SIMPLE; + end; + + procedure EmitStr(const s: RegExprString); + var + i: integer; + begin + for i := 1 to length(s) do + EmitC(s[i]); + end; + + function HexDig(Ch: REChar): integer; + begin + Result := 0; + if (Ch >= 'a') and (Ch <= 'f') then + Ch := REChar(ord(Ch) - (ord('a') - ord('A'))); + if (Ch < '0') or (Ch > 'F') or ((Ch > '9') and (Ch < 'A')) then + begin + Error(reeBadHexDigit); + EXIT; + end; + Result := ord(Ch) - ord('0'); + if Ch >= 'A' then + Result := Result - (ord('A') - ord('9') - 1); + end; + + function EmitRange(AOpCode: REChar): PRegExprChar; + begin +{$IFDEF UseSetOfChar} + case AOpCode of + ANYBUTCI, ANYBUT: + Result := EmitNode(ANYBUTTINYSET); + else // ANYOFCI, ANYOF + Result := EmitNode(ANYOFTINYSET); + end; + case AOpCode of + ANYBUTCI, ANYOFCI: + RangeIsCI := True; + else // ANYBUT, ANYOF + RangeIsCI := False; + end; + RangePCodeBeg := regcode; + RangePCodeIdx := regsize; + RangeLen := 0; + RangeSet := []; + RangeChMin := #255; + RangeChMax := #0; +{$ELSE} + Result := EmitNode(AOpCode); + // ToDo: + // !!!!!!!!!!!!! Implement ANYOF[BUT]TINYSET generation for UniCode !!!!!!!!!! +{$ENDIF} + end; + +{$IFDEF UseSetOfChar} + procedure EmitRangeCPrim(b: REChar); // ###0.930 + begin + if b in RangeSet then + EXIT; + Inc(RangeLen); + if b < RangeChMin then + RangeChMin := b; + if b > RangeChMax then + RangeChMax := b; + Include(RangeSet, b); + end; +{$ENDIF} + procedure EmitRangeC(b: REChar); +{$IFDEF UseSetOfChar} + var + Ch: REChar; +{$ENDIF} + begin + CanBeRange := False; +{$IFDEF UseSetOfChar} + if b <> #0 then + begin + EmitRangeCPrim(b); // ###0.930 + if RangeIsCI then + EmitRangeCPrim(InvertCase(b)); // ###0.930 + end + else + begin + Assert(RangeLen > 0, + 'TRegExpr.ParseAtom(subroutine EmitRangeC): empty range'); + // impossible, but who knows.. + Assert(RangeChMin <= RangeChMax, + 'TRegExpr.ParseAtom(subroutine EmitRangeC): RangeChMin > RangeChMax'); + // impossible, but who knows.. + if RangeLen <= TinySetLen then + begin // emit "tiny set" + if regcode = @regdummy then + begin + regsize := RangePCodeIdx + TinySetLen; // RangeChMin/Max !!! + EXIT; + end; + regcode := RangePCodeBeg; + for Ch := RangeChMin to RangeChMax do // ###0.930 + if Ch in RangeSet then + begin + regcode^ := Ch; + Inc(regcode); + end; + // fill rest: + while regcode < RangePCodeBeg + TinySetLen do + begin + regcode^ := RangeChMax; + Inc(regcode); + end; + end + else + begin + if regcode = @regdummy then + begin + regsize := RangePCodeIdx + SizeOf(TSetOfREChar); + EXIT; + end; + if (RangePCodeBeg - REOpSz - RENextOffSz)^ = ANYBUTTINYSET then + RangeSet := [#0 .. #255] - RangeSet; + PREOp(RangePCodeBeg - REOpSz - RENextOffSz)^ := ANYOFFULLSET; + regcode := RangePCodeBeg; + Move(RangeSet, regcode^, SizeOf(TSetOfREChar)); + Inc(regcode, SizeOf(TSetOfREChar)); + end; + end; +{$ELSE} + EmitC(b); +{$ENDIF} + end; + + procedure EmitSimpleRangeC(b: REChar); + begin + RangeBeg := b; + EmitRangeC(b); + CanBeRange := True; + end; + + procedure EmitRangeStr(const s: RegExprString); + var + i: integer; + begin + for i := 1 to length(s) do + EmitRangeC(s[i]); + end; + + function UnQuoteChar(var APtr: PRegExprChar): REChar; // ###0.934 + begin + case APtr^ of + 't': + Result := #$9; // tab (HT/TAB) + 'n': + Result := #$a; // newline (NL) + 'r': + Result := #$d; // car.return (CR) + 'f': + Result := #$c; // form feed (FF) + 'a': + Result := #$7; // alarm (bell) (BEL) + 'e': + Result := #$1b; // escape (ESC) + 'x': + begin // hex char + Result := #0; + Inc(APtr); + if APtr^ = #0 then + begin + Error(reeNoHexCodeAfterBSlashX); + EXIT; + end; + if APtr^ = '{' then + begin // \x{nnnn} //###0.936 + REPEAT + Inc(APtr); + if APtr^ = #0 then + begin + Error(reeNoHexCodeAfterBSlashX); + EXIT; + end; + if APtr^ <> '}' then + begin + if (ord(Result) ShR (SizeOf(REChar) * 8 - 4)) and $F <> 0 then + begin + Error(reeHexCodeAfterBSlashXTooBig); + EXIT; + end; + Result := REChar((ord(Result) ShL 4) or HexDig(APtr^)); + // HexDig will cause Error if bad hex digit found + end + else + BREAK; + UNTIL False; + end + else + begin + Result := REChar(HexDig(APtr^)); + // HexDig will cause Error if bad hex digit found + Inc(APtr); + if APtr^ = #0 then + begin + Error(reeNoHexCodeAfterBSlashX); + EXIT; + end; + Result := REChar((ord(Result) ShL 4) or HexDig(APtr^)); + // HexDig will cause Error if bad hex digit found + end; + end; + else + Result := APtr^; + end; + end; + +begin + Result := nil; + flagp := WORST; // Tentatively. + + Inc(regparse); + case (regparse - 1)^ of + '^': + if ((fCompModifiers and MaskModM) = 0) or + ((fLineSeparators = '') and not fLinePairedSeparatorAssigned) then + ret := EmitNode(BOL) + else + ret := EmitNode(BOLML); + '$': + if ((fCompModifiers and MaskModM) = 0) or + ((fLineSeparators = '') and not fLinePairedSeparatorAssigned) then + ret := EmitNode(EOL) + else + ret := EmitNode(EOLML); + '.': + if (fCompModifiers and MaskModS) <> 0 then + begin + ret := EmitNode(ANY); + flagp := flagp or HASWIDTH or SIMPLE; + end + else + begin // not /s, so emit [^:LineSeparators:] + ret := EmitNode(ANYML); + flagp := flagp or HASWIDTH; // not so simple ;) + // ret := EmitRange (ANYBUT); + // EmitRangeStr (LineSeparators); //###0.941 + // EmitRangeStr (LinePairedSeparator); // !!! isn't correct if have to accept only paired + // EmitRangeC (#0); + // flagp := flagp or HASWIDTH or SIMPLE; + end; + '[': + begin + if regparse^ = '^' then + begin // Complement of range. + if (fCompModifiers and MaskModI) <> 0 then + ret := EmitRange(ANYBUTCI) + else + ret := EmitRange(ANYBUT); + Inc(regparse); + end + else if (fCompModifiers and MaskModI) <> 0 then + ret := EmitRange(ANYOFCI) + else + ret := EmitRange(ANYOF); + + CanBeRange := False; + + if (regparse^ = ']') then + begin + EmitSimpleRangeC(regparse^); // []-a] -> ']' .. 'a' + Inc(regparse); + end; + + while (regparse^ <> #0) and (regparse^ <> ']') do + begin + if (regparse^ = '-') and ((regparse + 1)^ <> #0) and + ((regparse + 1)^ <> ']') and CanBeRange then + begin + Inc(regparse); + RangeEnd := regparse^; + if RangeEnd = '\' then + begin +{$IFDEF UniCode} // ###0.935 + if (ord((regparse + 1)^) < 256) and + (AnsiChar((regparse + 1)^) in ['d', 'D', 's', 'S', 'w', 'W']) + then + begin +{$ELSE} + if (regparse + 1)^ in ['d', 'D', 's', 'S', 'w', 'W'] then + begin +{$ENDIF} + EmitRangeC('-'); // or treat as error ?!! + CONTINUE; + end; + Inc(regparse); + RangeEnd := UnQuoteChar(regparse); + end; + + // r.e.ranges extension for russian + if ((fCompModifiers and MaskModR) <> 0) and + (RangeBeg = RusRangeLoLow) and (RangeEnd = RusRangeLoHigh) then + begin + EmitRangeStr(RusRangeLo); + end + else if ((fCompModifiers and MaskModR) <> 0) and + (RangeBeg = RusRangeHiLow) and (RangeEnd = RusRangeHiHigh) then + begin + EmitRangeStr(RusRangeHi); + end + else if ((fCompModifiers and MaskModR) <> 0) and + (RangeBeg = RusRangeLoLow) and (RangeEnd = RusRangeHiHigh) then + begin + EmitRangeStr(RusRangeLo); + EmitRangeStr(RusRangeHi); + end + else + begin // standard r.e. handling + if RangeBeg > RangeEnd then + begin + Error(reeInvalidRange); + EXIT; + end; + Inc(RangeBeg); + EmitRangeC(RangeEnd); // prevent infinite loop if RangeEnd=$ff + while RangeBeg < RangeEnd do + begin // ###0.929 + EmitRangeC(RangeBeg); + Inc(RangeBeg); + end; + end; + Inc(regparse); + end + else + begin + if regparse^ = '\' then + begin + Inc(regparse); + if regparse^ = #0 then + begin + Error(reeParseAtomTrailingBackSlash); + EXIT; + end; + case regparse^ of // r.e.extensions + 'd': + EmitRangeStr('0123456789'); + 'w': + EmitRangeStr(WordChars); + 's': + EmitRangeStr(SpaceChars); + else + EmitSimpleRangeC(UnQuoteChar(regparse)); + end; { of case } + end + else + EmitSimpleRangeC(regparse^); + Inc(regparse); + end; + end; { of while } + EmitRangeC(#0); + if regparse^ <> ']' then + begin + Error(reeUnmatchedSqBrackets); + EXIT; + end; + Inc(regparse); + flagp := flagp or HASWIDTH or SIMPLE; + end; + '(': + begin + if regparse^ = '?' then + begin + // check for extended Perl syntax : (?..) + if (regparse + 1)^ = '#' then + begin // (?#comment) + Inc(regparse, 2); // find closing ')' + while (regparse^ <> #0) and (regparse^ <> ')') do + Inc(regparse); + if regparse^ <> ')' then + begin + Error(reeUnclosedComment); + EXIT; + end; + Inc(regparse); // skip ')' + ret := EmitNode(COMMENT); // comment + end + else + begin // modifiers ? + Inc(regparse); // skip '?' + begmodfs := regparse; + while (regparse^ <> #0) and (regparse^ <> ')') do + Inc(regparse); + if (regparse^ <> ')') or not ParseModifiersStr + (Copy(begmodfs, 1, (regparse - begmodfs)), fCompModifiers) then + begin + Error(reeUrecognizedModifier); + EXIT; + end; + Inc(regparse); // skip ')' + ret := EmitNode(COMMENT); // comment + // Error (reeQPSBFollowsNothing); + // EXIT; + end; + end + else + begin + ret := ParseReg(1, flags); + if ret = nil then + begin + Result := nil; + EXIT; + end; + flagp := flagp or flags and (HASWIDTH or SPSTART); + end; + end; + #0, '|', ')': + begin // Supposed to be caught earlier. + Error(reeInternalUrp); + EXIT; + end; + '?', '+', '*': + begin + Error(reeQPSBFollowsNothing); + EXIT; + end; + '\': + begin + if regparse^ = #0 then + begin + Error(reeTrailingBackSlash); + EXIT; + end; + case regparse^ of // r.e.extensions + 'b': + ret := EmitNode(BOUND); // ###0.943 + 'B': + ret := EmitNode(NOTBOUND); // ###0.943 + 'A': + ret := EmitNode(BOL); // ###0.941 + 'Z': + ret := EmitNode(EOL); // ###0.941 + 'd': + begin // r.e.extension - any digit ('0' .. '9') + ret := EmitNode(ANYDIGIT); + flagp := flagp or HASWIDTH or SIMPLE; + end; + 'D': + begin // r.e.extension - not digit ('0' .. '9') + ret := EmitNode(NOTDIGIT); + flagp := flagp or HASWIDTH or SIMPLE; + end; + 's': + begin // r.e.extension - any space char +{$IFDEF UseSetOfChar} + ret := EmitRange(ANYOF); + EmitRangeStr(SpaceChars); + EmitRangeC(#0); +{$ELSE} + ret := EmitNode(ANYSPACE); +{$ENDIF} + flagp := flagp or HASWIDTH or SIMPLE; + end; + 'S': + begin // r.e.extension - not space char +{$IFDEF UseSetOfChar} + ret := EmitRange(ANYBUT); + EmitRangeStr(SpaceChars); + EmitRangeC(#0); +{$ELSE} + ret := EmitNode(NOTSPACE); +{$ENDIF} + flagp := flagp or HASWIDTH or SIMPLE; + end; + 'w': + begin // r.e.extension - any english char / digit / '_' +{$IFDEF UseSetOfChar} + ret := EmitRange(ANYOF); + EmitRangeStr(WordChars); + EmitRangeC(#0); +{$ELSE} + ret := EmitNode(ANYLETTER); +{$ENDIF} + flagp := flagp or HASWIDTH or SIMPLE; + end; + 'W': + begin // r.e.extension - not english char / digit / '_' +{$IFDEF UseSetOfChar} + ret := EmitRange(ANYBUT); + EmitRangeStr(WordChars); + EmitRangeC(#0); +{$ELSE} + ret := EmitNode(NOTLETTER); +{$ENDIF} + flagp := flagp or HASWIDTH or SIMPLE; + end; + '1' .. '9': + begin // ###0.936 + if (fCompModifiers and MaskModI) <> 0 then + ret := EmitNode(BSUBEXPCI) + else + ret := EmitNode(BSUBEXP); + EmitC(REChar(ord(regparse^) - ord('0'))); + flagp := flagp or HASWIDTH or SIMPLE; + end; + else + EmitExactly(UnQuoteChar(regparse)); + end; { of case } + Inc(regparse); + end; + else + begin + dec(regparse); + if ((fCompModifiers and MaskModX) <> 0) and // check for eXtended syntax + ((regparse^ = '#') or ({$IFDEF UniCode}StrScan(XIgnoredChars, regparse^) + <> nil // ###0.947 +{$ELSE}regparse^ in XIgnoredChars{$ENDIF})) then + begin // ###0.941 \x + if regparse^ = '#' then + begin // Skip eXtended comment + // find comment terminator (group of \n and/or \r) + while (regparse^ <> #0) and (regparse^ <> #$d) and + (regparse^ <> #$a) do + Inc(regparse); + while (regparse^ = #$d) or (regparse^ = #$a) + // skip comment terminator + do + Inc(regparse); + // attempt to support different type of line separators + end + else + begin // Skip the blanks! + while {$IFDEF UniCode}StrScan(XIgnoredChars, regparse^) <> nil + // ###0.947 +{$ELSE}regparse^ in XIgnoredChars{$ENDIF} + do + Inc(regparse); + end; + ret := EmitNode(COMMENT); // comment + end + else + begin + Len := strcspn(regparse, META); + if Len <= 0 then + if regparse^ <> '{' then + begin + Error(reeRarseAtomInternalDisaster); + EXIT; + end + else + Len := strcspn(regparse + 1, META) + 1; + // bad {n,m} - compile as EXATLY + ender := (regparse + Len)^; + if (Len > 1) and ((ender = '*') or (ender = '+') or (ender = '?') or + (ender = '{')) then + dec(Len); // Back off clear of ?+*{ operand. + flagp := flagp or HASWIDTH; + if Len = 1 then + flagp := flagp or SIMPLE; + if (fCompModifiers and MaskModI) <> 0 then + ret := EmitNode(EXACTLYCI) + else + ret := EmitNode(EXACTLY); + while (Len > 0) and (((fCompModifiers and MaskModX) = 0) or + (regparse^ <> '#')) do + begin + if ((fCompModifiers and MaskModX) = 0) or not( // ###0.941 +{$IFDEF UniCode}StrScan(XIgnoredChars, regparse^) <> nil + // ###0.947 +{$ELSE}regparse^ in XIgnoredChars{$ENDIF} ) then + EmitC(regparse^); + Inc(regparse); + dec(Len); + end; + EmitC(#0); + end; { of if not comment } + end; { of case else } + end; { of case } + + Result := ret; +end; { of function TRegExpr.ParseAtom + -------------------------------------------------------------- } + +function TRegExpr.GetCompilerErrorPos: integer; +begin + Result := 0; + if (regexpbeg = nil) or (regparse = nil) then + EXIT; // not in compiling mode ? + Result := regparse - regexpbeg; +end; { of function TRegExpr.GetCompilerErrorPos + -------------------------------------------------------------- } + +{ ============================================================= } +{ ===================== Matching section ====================== } +{ ============================================================= } + +{$IFNDEF UseSetOfChar} + +function TRegExpr.StrScanCI(s: PRegExprChar; Ch: REChar): PRegExprChar; +// ###0.928 - now method of TRegExpr +begin + while (s^ <> #0) and (s^ <> Ch) and (s^ <> InvertCase(Ch)) do + Inc(s); + if s^ <> #0 then + Result := s + else + Result := nil; +end; { of function TRegExpr.StrScanCI + -------------------------------------------------------------- } +{$ENDIF} + +function TRegExpr.regrepeat(p: PRegExprChar; AMax: integer): integer; +// repeatedly match something simple, report how many +var + scan: PRegExprChar; + opnd: PRegExprChar; + TheMax: integer; + { Ch, } InvCh: REChar; // ###0.931 + sestart, seend: PRegExprChar; // ###0.936 +begin + Result := 0; + scan := reginput; + opnd := p + REOpSz + RENextOffSz; // OPERAND + TheMax := fInputEnd - scan; + if TheMax > AMax then + TheMax := AMax; + case PREOp(p)^ of + ANY: + begin + // note - ANYML cannot be proceeded in regrepeat because can skip + // more than one char at once + Result := TheMax; + Inc(scan, Result); + end; + EXACTLY: + begin // in opnd can be only ONE char !!! + // Ch := opnd^; // store in register //###0.931 + while (Result < TheMax) and (opnd^ = scan^) do + begin + Inc(Result); + Inc(scan); + end; + end; + EXACTLYCI: + begin // in opnd can be only ONE char !!! + // Ch := opnd^; // store in register //###0.931 + while (Result < TheMax) and (opnd^ = scan^) do + begin // prevent unneeded InvertCase //###0.931 + Inc(Result); + Inc(scan); + end; + if Result < TheMax then + begin // ###0.931 + InvCh := InvertCase(opnd^); // store in register + while (Result < TheMax) and ((opnd^ = scan^) or (InvCh = scan^)) do + begin + Inc(Result); + Inc(scan); + end; + end; + end; + BSUBEXP: + begin // ###0.936 + sestart := startp[ord(opnd^)]; + if sestart = nil then + EXIT; + seend := endp[ord(opnd^)]; + if seend = nil then + EXIT; + REPEAT + opnd := sestart; + while opnd < seend do + begin + if (scan >= fInputEnd) or (scan^ <> opnd^) then + EXIT; + Inc(scan); + Inc(opnd); + end; + Inc(Result); + reginput := scan; + UNTIL Result >= AMax; + end; + BSUBEXPCI: + begin // ###0.936 + sestart := startp[ord(opnd^)]; + if sestart = nil then + EXIT; + seend := endp[ord(opnd^)]; + if seend = nil then + EXIT; + REPEAT + opnd := sestart; + while opnd < seend do + begin + if (scan >= fInputEnd) or + ((scan^ <> opnd^) and (scan^ <> InvertCase(opnd^))) then + EXIT; + Inc(scan); + Inc(opnd); + end; + Inc(Result); + reginput := scan; + UNTIL Result >= AMax; + end; + ANYDIGIT: + while (Result < TheMax) and (scan^ >= '0') and (scan^ <= '9') do + begin + Inc(Result); + Inc(scan); + end; + NOTDIGIT: + while (Result < TheMax) and ((scan^ < '0') or (scan^ > '9')) do + begin + Inc(Result); + Inc(scan); + end; +{$IFNDEF UseSetOfChar} // ###0.929 + ANYLETTER: + while (Result < TheMax) and (Pos(scan^, fWordChars) > 0) // ###0.940 + { ((scan^ >= 'a') and (scan^ <= 'z') !! I've forgotten (>='0') and (<='9') + or (scan^ >= 'A') and (scan^ <= 'Z') or (scan^ = '_')) } do + begin + Inc(Result); + Inc(scan); + end; + NOTLETTER: + while (Result < TheMax) and (Pos(scan^, fWordChars) <= 0) // ###0.940 + { not ((scan^ >= 'a') and (scan^ <= 'z') !! I've forgotten (>='0') and (<='9') + or (scan^ >= 'A') and (scan^ <= 'Z') + or (scan^ = '_')) } do + begin + Inc(Result); + Inc(scan); + end; + ANYSPACE: + while (Result < TheMax) and (Pos(scan^, fSpaceChars) > 0) do + begin + Inc(Result); + Inc(scan); + end; + NOTSPACE: + while (Result < TheMax) and (Pos(scan^, fSpaceChars) <= 0) do + begin + Inc(Result); + Inc(scan); + end; +{$ENDIF} + ANYOFTINYSET: + begin + while (Result < TheMax) and // !!!TinySet + ((scan^ = opnd^) or (scan^ = (opnd + 1)^) or (scan^ = (opnd + 2)^)) do + begin + Inc(Result); + Inc(scan); + end; + end; + ANYBUTTINYSET: + begin + while (Result < TheMax) and // !!!TinySet + (scan^ <> opnd^) and (scan^ <> (opnd + 1)^) and + (scan^ <> (opnd + 2)^) do + begin + Inc(Result); + Inc(scan); + end; + end; +{$IFDEF UseSetOfChar} // ###0.929 + ANYOFFULLSET: + begin + while (Result < TheMax) and (scan^ in PSetOfREChar(opnd)^) do + begin + Inc(Result); + Inc(scan); + end; + end; +{$ELSE} + ANYOF: + while (Result < TheMax) and (StrScan(opnd, scan^) <> nil) do + begin + Inc(Result); + Inc(scan); + end; + ANYBUT: + while (Result < TheMax) and (StrScan(opnd, scan^) = nil) do + begin + Inc(Result); + Inc(scan); + end; + ANYOFCI: + while (Result < TheMax) and (StrScanCI(opnd, scan^) <> nil) do + begin + Inc(Result); + Inc(scan); + end; + ANYBUTCI: + while (Result < TheMax) and (StrScanCI(opnd, scan^) = nil) do + begin + Inc(Result); + Inc(scan); + end; +{$ENDIF} + else + begin // Oh dear. Called inappropriately. + Result := 0; // Best compromise. + Error(reeRegRepeatCalledInappropriately); + EXIT; + end; + end; { of case } + reginput := scan; +end; { of function TRegExpr.regrepeat + -------------------------------------------------------------- } + +function TRegExpr.regnext(p: PRegExprChar): PRegExprChar; +// dig the "next" pointer out of a node +var + offset: TRENextOff; +begin + if p = @regdummy then + begin + Result := nil; + EXIT; + end; + offset := PRENextOff(p + REOpSz)^; // ###0.933 inlined NEXT + if offset = 0 then + Result := nil + else + Result := p + offset; +end; { of function TRegExpr.regnext + -------------------------------------------------------------- } + +function TRegExpr.MatchPrim(prog: PRegExprChar): boolean; +// recursively matching routine +// Conceptually the strategy is simple: check to see whether the current +// node matches, call self recursively to see whether the rest matches, +// and then act accordingly. In practice we make some effort to avoid +// recursion, in particular by going through "ordinary" nodes (that don't +// need to know whether the rest of the match failed) by a loop instead of +// by recursion. +var + scan: PRegExprChar; // Current node. + next: PRegExprChar; // Next node. + Len: integer; + opnd: PRegExprChar; + no: integer; + save: PRegExprChar; + nextch: REChar; + BracesMin, Bracesmax: integer; + // we use integer instead of TREBracesArg for better support */+ +{$IFDEF ComplexBraces} + SavedLoopStack: array [1 .. LoopStackMax] of integer; + // :(( very bad for recursion + SavedLoopStackIdx: integer; // ###0.925 +{$ENDIF} +begin + Result := False; + scan := prog; + + while scan <> nil do + begin + Len := PRENextOff(scan + 1)^; // ###0.932 inlined regnext + if Len = 0 then + next := nil + else + next := scan + Len; + + case scan^ of + NOTBOUND, // ###0.943 //!!! think about UseSetOfChar !!! + BOUND: + if (scan^ = BOUND) + xor (((reginput = fInputStart) or (Pos((reginput - 1)^, fWordChars) <= + 0)) and (reginput^ <> #0) and (Pos(reginput^, fWordChars) > 0) or + (reginput <> fInputStart) and (Pos((reginput - 1)^, fWordChars) > 0) + and ((reginput^ = #0) or (Pos(reginput^, fWordChars) <= 0))) then + EXIT; + + BOL: + if reginput <> fInputStart then + EXIT; + EOL: + if reginput^ <> #0 then + EXIT; + BOLML: + if reginput > fInputStart then + begin + nextch := (reginput - 1)^; + if (nextch <> fLinePairedSeparatorTail) or + ((reginput - 1) <= fInputStart) or + ((reginput - 2)^ <> fLinePairedSeparatorHead) then + begin + if (nextch = fLinePairedSeparatorHead) and + (reginput^ = fLinePairedSeparatorTail) then + EXIT; // don't stop between paired separator + if +{$IFNDEF UniCode} + not(nextch in fLineSeparatorsSet) +{$ELSE} + (Pos(nextch, fLineSeparators) <= 0) +{$ENDIF} + then + EXIT; + end; + end; + EOLML: + if reginput^ <> #0 then + begin + nextch := reginput^; + if (nextch <> fLinePairedSeparatorHead) or + ((reginput + 1)^ <> fLinePairedSeparatorTail) then + begin + if (nextch = fLinePairedSeparatorTail) and (reginput > fInputStart) + and ((reginput - 1)^ = fLinePairedSeparatorHead) then + EXIT; // don't stop between paired separator + if +{$IFNDEF UniCode} + not(nextch in fLineSeparatorsSet) +{$ELSE} + (Pos(nextch, fLineSeparators) <= 0) +{$ENDIF} + then + EXIT; + end; + end; + ANY: + begin + if reginput^ = #0 then + EXIT; + Inc(reginput); + end; + ANYML: + begin // ###0.941 + if (reginput^ = #0) or ((reginput^ = fLinePairedSeparatorHead) and + ((reginput + 1)^ = fLinePairedSeparatorTail)) or + {$IFNDEF UniCode} (reginput^ in fLineSeparatorsSet) +{$ELSE} (Pos(reginput^, fLineSeparators) > 0) {$ENDIF} + then + EXIT; + Inc(reginput); + end; + ANYDIGIT: + begin + if (reginput^ = #0) or (reginput^ < '0') or (reginput^ > '9') then + EXIT; + Inc(reginput); + end; + NOTDIGIT: + begin + if (reginput^ = #0) or ((reginput^ >= '0') and (reginput^ <= '9')) + then + EXIT; + Inc(reginput); + end; +{$IFNDEF UseSetOfChar} // ###0.929 + ANYLETTER: + begin + if (reginput^ = #0) or (Pos(reginput^, fWordChars) <= 0) // ###0.943 + then + EXIT; + Inc(reginput); + end; + NOTLETTER: + begin + if (reginput^ = #0) or (Pos(reginput^, fWordChars) > 0) // ###0.943 + then + EXIT; + Inc(reginput); + end; + ANYSPACE: + begin + if (reginput^ = #0) or not(Pos(reginput^, fSpaceChars) > 0) + // ###0.943 + then + EXIT; + Inc(reginput); + end; + NOTSPACE: + begin + if (reginput^ = #0) or (Pos(reginput^, fSpaceChars) > 0) // ###0.943 + then + EXIT; + Inc(reginput); + end; +{$ENDIF} + EXACTLYCI: + begin + opnd := scan + REOpSz + RENextOffSz; // OPERAND + // Inline the first character, for speed. + if (opnd^ <> reginput^) and (InvertCase(opnd^) <> reginput^) then + EXIT; + Len := StrLen(opnd); + // ###0.929 begin + no := Len; + save := reginput; + while no > 1 do + begin + Inc(save); + Inc(opnd); + if (opnd^ <> save^) and (InvertCase(opnd^) <> save^) then + EXIT; + dec(no); + end; + // ###0.929 end + Inc(reginput, Len); + end; + EXACTLY: + begin + opnd := scan + REOpSz + RENextOffSz; // OPERAND + // Inline the first character, for speed. + if opnd^ <> reginput^ then + EXIT; + Len := StrLen(opnd); + // ###0.929 begin + no := Len; + save := reginput; + while no > 1 do + begin + Inc(save); + Inc(opnd); + if opnd^ <> save^ then + EXIT; + dec(no); + end; + // ###0.929 end + Inc(reginput, Len); + end; + BSUBEXP: + begin // ###0.936 + no := ord((scan + REOpSz + RENextOffSz)^); + if startp[no] = nil then + EXIT; + if endp[no] = nil then + EXIT; + save := reginput; + opnd := startp[no]; + while opnd < endp[no] do + begin + if (save >= fInputEnd) or (save^ <> opnd^) then + EXIT; + Inc(save); + Inc(opnd); + end; + reginput := save; + end; + BSUBEXPCI: + begin // ###0.936 + no := ord((scan + REOpSz + RENextOffSz)^); + if startp[no] = nil then + EXIT; + if endp[no] = nil then + EXIT; + save := reginput; + opnd := startp[no]; + while opnd < endp[no] do + begin + if (save >= fInputEnd) or + ((save^ <> opnd^) and (save^ <> InvertCase(opnd^))) then + EXIT; + Inc(save); + Inc(opnd); + end; + reginput := save; + end; + ANYOFTINYSET: + begin + if (reginput^ = #0) or // !!!TinySet + ((reginput^ <> (scan + REOpSz + RENextOffSz)^) and + (reginput^ <> (scan + REOpSz + RENextOffSz + 1)^) and + (reginput^ <> (scan + REOpSz + RENextOffSz + 2)^)) then + EXIT; + Inc(reginput); + end; + ANYBUTTINYSET: + begin + if (reginput^ = #0) or // !!!TinySet + (reginput^ = (scan + REOpSz + RENextOffSz)^) or + (reginput^ = (scan + REOpSz + RENextOffSz + 1)^) or + (reginput^ = (scan + REOpSz + RENextOffSz + 2)^) then + EXIT; + Inc(reginput); + end; +{$IFDEF UseSetOfChar} // ###0.929 + ANYOFFULLSET: + begin + if (reginput^ = #0) or + not(reginput^ in PSetOfREChar(scan + REOpSz + RENextOffSz)^) then + EXIT; + Inc(reginput); + end; +{$ELSE} + ANYOF: + begin + if (reginput^ = #0) or + (StrScan(scan + REOpSz + RENextOffSz, reginput^) = nil) then + EXIT; + Inc(reginput); + end; + ANYBUT: + begin + if (reginput^ = #0) or + (StrScan(scan + REOpSz + RENextOffSz, reginput^) <> nil) then + EXIT; + Inc(reginput); + end; + ANYOFCI: + begin + if (reginput^ = #0) or + (StrScanCI(scan + REOpSz + RENextOffSz, reginput^) = nil) then + EXIT; + Inc(reginput); + end; + ANYBUTCI: + begin + if (reginput^ = #0) or + (StrScanCI(scan + REOpSz + RENextOffSz, reginput^) <> nil) then + EXIT; + Inc(reginput); + end; +{$ENDIF} + NOTHING: + ; + COMMENT: + ; + BACK: + ; + Succ(OPEN) .. TREOp(ord(OPEN) + NSUBEXP - 1): + begin // ###0.929 + no := ord(scan^) - ord(OPEN); + // save := reginput; + save := startp[no]; // ###0.936 + startp[no] := reginput; // ###0.936 + Result := MatchPrim(next); + if not Result // ###0.936 + then + startp[no] := save; + // if Result and (startp [no] = nil) + // then startp [no] := save; + // Don't set startp if some later invocation of the same + // parentheses already has. + EXIT; + end; + Succ(CLOSE) .. TREOp(ord(CLOSE) + NSUBEXP - 1): + begin // ###0.929 + no := ord(scan^) - ord(CLOSE); + // save := reginput; + save := endp[no]; // ###0.936 + endp[no] := reginput; // ###0.936 + Result := MatchPrim(next); + if not Result // ###0.936 + then + endp[no] := save; + // if Result and (endp [no] = nil) + // then endp [no] := save; + // Don't set endp if some later invocation of the same + // parentheses already has. + EXIT; + end; + BRANCH: + begin + if (next^ <> BRANCH) // No choice. + then + next := scan + REOpSz + RENextOffSz // Avoid recursion + else + begin + REPEAT + save := reginput; + Result := MatchPrim(scan + REOpSz + RENextOffSz); + if Result then + EXIT; + reginput := save; + scan := regnext(scan); + UNTIL (scan = nil) or (scan^ <> BRANCH); + EXIT; + end; + end; +{$IFDEF ComplexBraces} + LOOPENTRY: + begin // ###0.925 + no := LoopStackIdx; + Inc(LoopStackIdx); + if LoopStackIdx > LoopStackMax then + begin + Error(reeLoopStackExceeded); + EXIT; + end; + save := reginput; + LoopStack[LoopStackIdx] := 0; // init loop counter + Result := MatchPrim(next); // execute LOOP + LoopStackIdx := no; // cleanup + if Result then + EXIT; + reginput := save; + EXIT; + end; + LOOP, LOOPNG: + begin // ###0.940 + if LoopStackIdx <= 0 then + begin + Error(reeLoopWithoutEntry); + EXIT; + end; + opnd := scan + PRENextOff(scan + REOpSz + RENextOffSz + 2 * + REBracesArgSz)^; + BracesMin := PREBracesArg(scan + REOpSz + RENextOffSz)^; + Bracesmax := PREBracesArg(scan + REOpSz + RENextOffSz + + REBracesArgSz)^; + save := reginput; + if LoopStack[LoopStackIdx] >= BracesMin then + begin // Min alredy matched - we can work + if scan^ = LOOP then + begin + // greedy way - first try to max deep of greed ;) + if LoopStack[LoopStackIdx] < Bracesmax then + begin + Inc(LoopStack[LoopStackIdx]); + no := LoopStackIdx; + Result := MatchPrim(opnd); + LoopStackIdx := no; + if Result then + EXIT; + reginput := save; + end; + dec(LoopStackIdx); // Fail. May be we are too greedy? ;) + Result := MatchPrim(next); + if not Result then + reginput := save; + EXIT; + end + else + begin + // non-greedy - try just now + Result := MatchPrim(next); + if Result then + EXIT + else + reginput := save; // failed - move next and try again + if LoopStack[LoopStackIdx] < Bracesmax then + begin + Inc(LoopStack[LoopStackIdx]); + no := LoopStackIdx; + Result := MatchPrim(opnd); + LoopStackIdx := no; + if Result then + EXIT; + reginput := save; + end; + dec(LoopStackIdx); // Failed - back up + EXIT; + end + end + else + begin // first match a min_cnt times + Inc(LoopStack[LoopStackIdx]); + no := LoopStackIdx; + Result := MatchPrim(opnd); + LoopStackIdx := no; + if Result then + EXIT; + dec(LoopStack[LoopStackIdx]); + reginput := save; + EXIT; + end; + end; +{$ENDIF} + STAR, PLUS, BRACES, STARNG, PLUSNG, BRACESNG: + begin + // Lookahead to avoid useless match attempts when we know + // what character comes next. + nextch := #0; + if next^ = EXACTLY then + nextch := (next + REOpSz + RENextOffSz)^; + Bracesmax := MaxInt; // infinite loop for * and + //###0.92 + if (scan^ = STAR) or (scan^ = STARNG) then + BracesMin := 0 // STAR + else if (scan^ = PLUS) or (scan^ = PLUSNG) then + BracesMin := 1 // PLUS + else + begin // BRACES + BracesMin := PREBracesArg(scan + REOpSz + RENextOffSz)^; + Bracesmax := PREBracesArg(scan + REOpSz + RENextOffSz + + REBracesArgSz)^; + end; + save := reginput; + opnd := scan + REOpSz + RENextOffSz; + if (scan^ = BRACES) or (scan^ = BRACESNG) then + Inc(opnd, 2 * REBracesArgSz); + + if (scan^ = PLUSNG) or (scan^ = STARNG) or (scan^ = BRACESNG) then + begin + // non-greedy mode + Bracesmax := regrepeat(opnd, Bracesmax); + // don't repeat more than BracesMax + // Now we know real Max limit to move forward (for recursion 'back up') + // In some cases it can be faster to check only Min positions first, + // but after that we have to check every position separtely instead + // of fast scannig in loop. + no := BracesMin; + while no <= Bracesmax do + begin + reginput := save + no; + // If it could work, try it. + if (nextch = #0) or (reginput^ = nextch) then + begin +{$IFDEF ComplexBraces} + System.Move(LoopStack, SavedLoopStack, SizeOf(LoopStack)); + // ###0.925 + SavedLoopStackIdx := LoopStackIdx; +{$ENDIF} + if MatchPrim(next) then + begin + Result := True; + EXIT; + end; +{$IFDEF ComplexBraces} + System.Move(SavedLoopStack, LoopStack, SizeOf(LoopStack)); + LoopStackIdx := SavedLoopStackIdx; +{$ENDIF} + end; + Inc(no); // Couldn't or didn't - move forward. + end; { of while } + EXIT; + end + else + begin // greedy mode + no := regrepeat(opnd, Bracesmax); // don't repeat more than max_cnt + while no >= BracesMin do + begin + // If it could work, try it. + if (nextch = #0) or (reginput^ = nextch) then + begin +{$IFDEF ComplexBraces} + System.Move(LoopStack, SavedLoopStack, SizeOf(LoopStack)); + // ###0.925 + SavedLoopStackIdx := LoopStackIdx; +{$ENDIF} + if MatchPrim(next) then + begin + Result := True; + EXIT; + end; +{$IFDEF ComplexBraces} + System.Move(SavedLoopStack, LoopStack, SizeOf(LoopStack)); + LoopStackIdx := SavedLoopStackIdx; +{$ENDIF} + end; + dec(no); // Couldn't or didn't - back up. + reginput := save + no; + end; { of while } + EXIT; + end; + end; + EEND: + begin + Result := True; // Success! + EXIT; + end; + else + begin + Error(reeMatchPrimMemoryCorruption); + EXIT; + end; + end; { of case scan^ } + scan := next; + end; { of while scan <> nil } + + // We get here only if there's trouble -- normally "case EEND" is the + // terminating point. + Error(reeMatchPrimCorruptedPointers); +end; { of function TRegExpr.MatchPrim + -------------------------------------------------------------- } + +{$IFDEF UseFirstCharSet} +// ###0.929 +procedure TRegExpr.FillFirstCharSet(prog: PRegExprChar); +var + scan: PRegExprChar; // Current node. + next: PRegExprChar; // Next node. + opnd: PRegExprChar; + min_cnt: integer; +begin + scan := prog; + while scan <> nil do + begin + next := regnext(scan); + case PREOp(scan)^ of + BSUBEXP, BSUBEXPCI: + begin // ###0.938 + FirstCharSet := [#0 .. #255]; // :((( we cannot + // optimize r.e. if it starts with back reference + EXIT; + end; + BOL, BOLML: + ; // EXIT; //###0.937 + EOL, EOLML: + ; // EXIT; //###0.937 + BOUND, NOTBOUND: + ; // ###0.943 ?!! + ANY, ANYML: + begin // we can better define ANYML !!! + FirstCharSet := [#0 .. #255]; // ###0.930 + EXIT; + end; + ANYDIGIT: + begin + FirstCharSet := FirstCharSet + ['0' .. '9']; + EXIT; + end; + NOTDIGIT: + begin + FirstCharSet := [#0 .. #255] - ['0' .. '9']; + EXIT; + end; + EXACTLYCI: + begin + Include(FirstCharSet, (scan + REOpSz + RENextOffSz)^); + Include(FirstCharSet, InvertCase((scan + REOpSz + RENextOffSz)^)); + EXIT; + end; + EXACTLY: + begin + Include(FirstCharSet, (scan + REOpSz + RENextOffSz)^); + EXIT; + end; + ANYOFFULLSET: + begin + FirstCharSet := FirstCharSet + + PSetOfREChar(scan + REOpSz + RENextOffSz)^; + EXIT; + end; + ANYOFTINYSET: + begin + // !!!TinySet + Include(FirstCharSet, (scan + REOpSz + RENextOffSz)^); + Include(FirstCharSet, (scan + REOpSz + RENextOffSz + 1)^); + Include(FirstCharSet, (scan + REOpSz + RENextOffSz + 2)^); + // ... // up to TinySetLen + EXIT; + end; + ANYBUTTINYSET: + begin + // !!!TinySet + FirstCharSet := [#0 .. #255]; + Exclude(FirstCharSet, (scan + REOpSz + RENextOffSz)^); + Exclude(FirstCharSet, (scan + REOpSz + RENextOffSz + 1)^); + Exclude(FirstCharSet, (scan + REOpSz + RENextOffSz + 2)^); + // ... // up to TinySetLen + EXIT; + end; + NOTHING: + ; + COMMENT: + ; + BACK: + ; + Succ(OPEN) .. TREOp(ord(OPEN) + NSUBEXP - 1): + begin // ###0.929 + FillFirstCharSet(next); + EXIT; + end; + Succ(CLOSE) .. TREOp(ord(CLOSE) + NSUBEXP - 1): + begin // ###0.929 + FillFirstCharSet(next); + EXIT; + end; + BRANCH: + begin + if (PREOp(next)^ <> BRANCH) // No choice. + then + next := scan + REOpSz + RENextOffSz // Avoid recursion. + else + begin + REPEAT + FillFirstCharSet(scan + REOpSz + RENextOffSz); + scan := regnext(scan); + UNTIL (scan = nil) or (PREOp(scan)^ <> BRANCH); + EXIT; + end; + end; +{$IFDEF ComplexBraces} + LOOPENTRY: + begin // ###0.925 + // LoopStack [LoopStackIdx] := 0; //###0.940 line removed + FillFirstCharSet(next); // execute LOOP + EXIT; + end; + LOOP, LOOPNG: + begin // ###0.940 + opnd := scan + PRENextOff(scan + REOpSz + RENextOffSz + + REBracesArgSz * 2)^; + min_cnt := PREBracesArg(scan + REOpSz + RENextOffSz)^; + FillFirstCharSet(opnd); + if min_cnt = 0 then + FillFirstCharSet(next); + EXIT; + end; +{$ENDIF} + STAR, STARNG: // ###0.940 + FillFirstCharSet(scan + REOpSz + RENextOffSz); + PLUS, PLUSNG: + begin // ###0.940 + FillFirstCharSet(scan + REOpSz + RENextOffSz); + EXIT; + end; + BRACES, BRACESNG: + begin // ###0.940 + opnd := scan + REOpSz + RENextOffSz + REBracesArgSz * 2; + min_cnt := PREBracesArg(scan + REOpSz + RENextOffSz)^; // BRACES + FillFirstCharSet(opnd); + if min_cnt > 0 then + EXIT; + end; + EEND: + begin + EXIT; + end; + else + begin + Error(reeMatchPrimMemoryCorruption); + EXIT; + end; + end; { of case scan^ } + scan := next; + end; { of while scan <> nil } +end; { of procedure FillFirstCharSet; + -------------------------------------------------------------- } +{$ENDIF} + +function TRegExpr.RegMatch(str: PRegExprChar): boolean; +// try match at specific point +var + i: integer; +begin + for i := 0 to NSUBEXP - 1 do + begin + startp[i] := nil; + endp[i] := nil; + end; + reginput := str; + Result := MatchPrim(programm + REOpSz); + if Result then + begin + startp[0] := str; + endp[0] := reginput; + end; +end; { of function TRegExpr.RegMatch + -------------------------------------------------------------- } + +function TRegExpr.Exec(const AInputString: RegExprString): boolean; +begin + InputString := AInputString; + Result := ExecPrim(1); +end; { of function TRegExpr.Exec + -------------------------------------------------------------- } + +function TRegExpr.ExecPrim(AOffset: integer): boolean; +var + s: PRegExprChar; + StartPtr: PRegExprChar; + InputLen: integer; +begin + Result := False; // Be paranoid... + + if not IsProgrammOk // ###0.929 + then + EXIT; + + // Check InputString presence + if not Assigned(fInputString) then + begin + Error(reeNoInpitStringSpecified); + EXIT; + end; + + InputLen := length(fInputString); + + // Check that the start position is not negative + if AOffset < 1 then + begin + Error(reeOffsetMustBeGreaterThen0); + EXIT; + end; + // Check that the start position is not longer than the line + // If so then exit with nothing found + if AOffset > (InputLen + 1) // for matching empty string after last char. + then + EXIT; + + StartPtr := fInputString + AOffset - 1; + + // If there is a "must appear" string, look for it. + if regmust <> nil then + begin + s := StartPtr; + REPEAT + s := StrScan(s, regmust[0]); + if s <> nil then + begin + if StrLComp(s, regmust, regmlen) = 0 then + BREAK; // Found it. + Inc(s); + end; + UNTIL s = nil; + if s = nil // Not present. + then + EXIT; + end; + + // Mark beginning of line for ^ . + fInputStart := fInputString; + + // Pointer to end of input stream - for + // pascal-style string processing (may include #0) + fInputEnd := fInputString + InputLen; + +{$IFDEF ComplexBraces} + // no loops started + LoopStackIdx := 0; // ###0.925 +{$ENDIF} + // Simplest case: anchored match need be tried only once. + if reganch <> #0 then + begin + Result := RegMatch(StartPtr); + EXIT; + end; + + // Messy cases: unanchored match. + s := StartPtr; + if regstart <> #0 then // We know what char it must start with. + REPEAT + s := StrScan(s, regstart); + if s <> nil then + begin + Result := RegMatch(s); + if Result then + EXIT; + Inc(s); + end; + UNTIL s = nil + else + begin // We don't - general case. +{$IFDEF UseFirstCharSet} // ###0.929 + while s^ <> #0 do + begin + if s^ in FirstCharSet then + Result := RegMatch(s); + if Result then + EXIT; + Inc(s); + end; +{$ELSE} + REPEAT + Result := RegMatch(s); + if Result then + EXIT; + Inc(s); + UNTIL s^ = #0; +{$ENDIF} + end; + // Failure +end; { of function TRegExpr.ExecPrim + -------------------------------------------------------------- } + +function TRegExpr.ExecNext: boolean; +var + offset: integer; +begin + Result := False; + if not Assigned(startp[0]) or not Assigned(endp[0]) then + begin + Error(reeExecNextWithoutExec); + EXIT; + end; + // Offset := MatchPos [0] + MatchLen [0]; + // if MatchLen [0] = 0 + offset := endp[0] - fInputString + 1; // ###0.929 + if endp[0] = startp[0] // ###0.929 + then + Inc(offset); // prevent infinite looping if empty string match r.e. + Result := ExecPrim(offset); +end; { of function TRegExpr.ExecNext + -------------------------------------------------------------- } + +function TRegExpr.ExecPos(AOffset: integer {$IFDEF D4_} = 1{$ENDIF}): boolean; +begin + Result := ExecPrim(AOffset); +end; { of function TRegExpr.ExecPos + -------------------------------------------------------------- } + +function TRegExpr.GetInputString: RegExprString; +begin + if not Assigned(fInputString) then + begin + Error(reeGetInputStringWithoutInputString); + EXIT; + end; + Result := fInputString; +end; { of function TRegExpr.GetInputString + -------------------------------------------------------------- } + +procedure TRegExpr.SetInputString(const AInputString: RegExprString); +var + Len: integer; + i: integer; +begin + // clear Match* - before next Exec* call it's undefined + for i := 0 to NSUBEXP - 1 do + begin + startp[i] := nil; + endp[i] := nil; + end; + + // need reallocation of input string buffer ? + Len := length(AInputString); + if Assigned(fInputString) and (length(fInputString) <> Len) then + begin + FreeMem(fInputString); + fInputString := nil; + end; + // buffer [re]allocation + if not Assigned(fInputString) then + GetMem(fInputString, (Len + 1) * SizeOf(REChar)); + + // copy input string into buffer +{$IFDEF UniCode} + StrPCopy(fInputString, Copy(AInputString, 1, Len)); // ###0.927 +{$ELSE} + StrLCopy(fInputString, PRegExprChar(AInputString), Len); +{$ENDIF} + { + fInputString : string; + fInputStart, fInputEnd : PRegExprChar; + + SetInputString: + fInputString := AInputString; + UniqueString (fInputString); + fInputStart := PChar (fInputString); + Len := length (fInputString); + fInputEnd := PRegExprChar (integer (fInputStart) + Len); ?? + !! startp/endp âñ?ðàâí?áóäå?îïàñíî èñïîëüçîâàòü ? + } +end; { of procedure TRegExpr.SetInputString + -------------------------------------------------------------- } + +procedure TRegExpr.SetLineSeparators(const AStr: RegExprString); +begin + if AStr <> fLineSeparators then + begin + fLineSeparators := AStr; + InvalidateProgramm; + end; +end; { of procedure TRegExpr.SetLineSeparators + -------------------------------------------------------------- } + +procedure TRegExpr.SetLinePairedSeparator(const AStr: RegExprString); +begin + if length(AStr) = 2 then + begin + if AStr[1] = AStr[2] then + begin + // it's impossible for our 'one-point' checking to support + // two chars separator for identical chars + Error(reeBadLinePairedSeparator); + EXIT; + end; + if not fLinePairedSeparatorAssigned or (AStr[1] <> fLinePairedSeparatorHead) + or (AStr[2] <> fLinePairedSeparatorTail) then + begin + fLinePairedSeparatorAssigned := True; + fLinePairedSeparatorHead := AStr[1]; + fLinePairedSeparatorTail := AStr[2]; + InvalidateProgramm; + end; + end + else if length(AStr) = 0 then + begin + if fLinePairedSeparatorAssigned then + begin + fLinePairedSeparatorAssigned := False; + InvalidateProgramm; + end; + end + else + Error(reeBadLinePairedSeparator); +end; { of procedure TRegExpr.SetLinePairedSeparator + -------------------------------------------------------------- } + +function TRegExpr.GetLinePairedSeparator: RegExprString; +begin + if fLinePairedSeparatorAssigned then + begin +{$IFDEF UniCode} + // Here is some UniCode 'magic' + // If You do know better decision to concatenate + // two WideChars, please, let me know! + Result := fLinePairedSeparatorHead; // ###0.947 + Result := Result + fLinePairedSeparatorTail; +{$ELSE} + Result := fLinePairedSeparatorHead + fLinePairedSeparatorTail; +{$ENDIF} + end + else + Result := ''; +end; { of function TRegExpr.GetLinePairedSeparator + -------------------------------------------------------------- } + +function TRegExpr.Substitute(const ATemplate: RegExprString): RegExprString; +// perform substitutions after a regexp match +// completely rewritten in 0.929 +var + TemplateLen: integer; + TemplateBeg, TemplateEnd: PRegExprChar; + p, p0, ResultPtr: PRegExprChar; + ResultLen: integer; + n: integer; + Ch: REChar; + function ParseVarName(var APtr: PRegExprChar): integer; + // extract name of variable (digits, may be enclosed with + // curly braces) from APtr^, uses TemplateEnd !!! + const + Digits = ['0' .. '9']; + var + p: PRegExprChar; + Delimited: boolean; + begin + Result := 0; + p := APtr; + Delimited := (p < TemplateEnd) and (p^ = '{'); + if Delimited then + Inc(p); // skip left curly brace + if (p < TemplateEnd) and (p^ = '&') then + Inc(p) // this is '$&' or '${&}' + else + while (p < TemplateEnd) and +{$IFDEF UniCode} // ###0.935 + (ord(p^) < 256) and (AnsiChar(p^) in Digits) +{$ELSE} + (p^ in Digits) +{$ENDIF} + do + begin + Result := Result * 10 + (ord(p^) - ord('0')); // ###0.939 + Inc(p); + end; + if Delimited then + if (p < TemplateEnd) and (p^ = '}') then + Inc(p) // skip right curly brace + else + p := APtr; // isn't properly terminated + if p = APtr then + Result := -1; // no valid digits found or no right curly brace + APtr := p; + end; + +begin + // Check programm and input string + if not IsProgrammOk then + EXIT; + if not Assigned(fInputString) then + begin + Error(reeNoInpitStringSpecified); + EXIT; + end; + // Prepare for working + TemplateLen := length(ATemplate); + if TemplateLen = 0 then + begin // prevent nil pointers + Result := ''; + EXIT; + end; + TemplateBeg := pointer(ATemplate); + TemplateEnd := TemplateBeg + TemplateLen; + // Count result length for speed optimization. + ResultLen := 0; + p := TemplateBeg; + while p < TemplateEnd do + begin + Ch := p^; + Inc(p); + if Ch = '$' then + n := ParseVarName(p) + else + n := -1; + if n >= 0 then + begin + if (n < NSUBEXP) and Assigned(startp[n]) and Assigned(endp[n]) then + Inc(ResultLen, endp[n] - startp[n]); + end + else + begin + if (Ch = '\') and (p < TemplateEnd) then + Inc(p); // quoted or special char followed + Inc(ResultLen); + end; + end; + // Get memory. We do it once and it significant speed up work ! + if ResultLen = 0 then + begin + Result := ''; + EXIT; + end; + SetString(Result, nil, ResultLen); + // Fill Result + ResultPtr := pointer(Result); + p := TemplateBeg; + while p < TemplateEnd do + begin + Ch := p^; + Inc(p); + if Ch = '$' then + n := ParseVarName(p) + else + n := -1; + if n >= 0 then + begin + p0 := startp[n]; + if (n < NSUBEXP) and Assigned(p0) and Assigned(endp[n]) then + while p0 < endp[n] do + begin + ResultPtr^ := p0^; + Inc(ResultPtr); + Inc(p0); + end; + end + else + begin + if (Ch = '\') and (p < TemplateEnd) then + begin // quoted or special char followed + Ch := p^; + Inc(p); + end; + ResultPtr^ := Ch; + Inc(ResultPtr); + end; + end; +end; { of function TRegExpr.Substitute + -------------------------------------------------------------- } + +procedure TRegExpr.Split(AInputStr: RegExprString; APieces: TStrings); +var + PrevPos: integer; +begin + PrevPos := 1; + if Exec(AInputStr) then + REPEAT + APieces.Add(System.Copy(AInputStr, PrevPos, MatchPos[0] - PrevPos)); + PrevPos := MatchPos[0] + MatchLen[0]; + UNTIL not ExecNext; + APieces.Add(System.Copy(AInputStr, PrevPos, MaxInt)); // Tail +end; { of procedure TRegExpr.Split + -------------------------------------------------------------- } + +function TRegExpr.Replace(AInputStr: RegExprString; + const AReplaceStr: RegExprString; + AUseSubstitution: boolean{$IFDEF D4_} = False{$ENDIF}): RegExprString; +var + PrevPos: integer; +begin + Result := ''; + PrevPos := 1; + if Exec(AInputStr) then + REPEAT + Result := Result + System.Copy(AInputStr, PrevPos, MatchPos[0] - PrevPos); + if AUseSubstitution // ###0.946 + then + Result := Result + Substitute(AReplaceStr) + else + Result := Result + AReplaceStr; + PrevPos := MatchPos[0] + MatchLen[0]; + UNTIL not ExecNext; + Result := Result + System.Copy(AInputStr, PrevPos, MaxInt); // Tail +end; { of function TRegExpr.Replace + -------------------------------------------------------------- } + +{ ============================================================= } +{ ====================== Debug section ======================== } +{ ============================================================= } + +{$IFDEF DebugRegExpr} + +function TRegExpr.DumpOp(op: TREOp): RegExprString; +// printable representation of opcode +begin + case op of + BOL: + Result := 'BOL'; + EOL: + Result := 'EOL'; + BOLML: + Result := 'BOLML'; + EOLML: + Result := 'EOLML'; + BOUND: + Result := 'BOUND'; // ###0.943 + NOTBOUND: + Result := 'NOTBOUND'; // ###0.943 + ANY: + Result := 'ANY'; + ANYML: + Result := 'ANYML'; // ###0.941 + ANYLETTER: + Result := 'ANYLETTER'; + NOTLETTER: + Result := 'NOTLETTER'; + ANYDIGIT: + Result := 'ANYDIGIT'; + NOTDIGIT: + Result := 'NOTDIGIT'; + ANYSPACE: + Result := 'ANYSPACE'; + NOTSPACE: + Result := 'NOTSPACE'; + ANYOF: + Result := 'ANYOF'; + ANYBUT: + Result := 'ANYBUT'; + ANYOFCI: + Result := 'ANYOF/CI'; + ANYBUTCI: + Result := 'ANYBUT/CI'; + BRANCH: + Result := 'BRANCH'; + EXACTLY: + Result := 'EXACTLY'; + EXACTLYCI: + Result := 'EXACTLY/CI'; + NOTHING: + Result := 'NOTHING'; + COMMENT: + Result := 'COMMENT'; + BACK: + Result := 'BACK'; + EEND: + Result := 'END'; + BSUBEXP: + Result := 'BSUBEXP'; + BSUBEXPCI: + Result := 'BSUBEXP/CI'; + Succ(OPEN) .. TREOp(ord(OPEN) + NSUBEXP - 1): // ###0.929 + Result := Format('OPEN[%d]', [ord(op) - ord(OPEN)]); + Succ(CLOSE) .. TREOp(ord(CLOSE) + NSUBEXP - 1): // ###0.929 + Result := Format('CLOSE[%d]', [ord(op) - ord(CLOSE)]); + STAR: + Result := 'STAR'; + PLUS: + Result := 'PLUS'; + BRACES: + Result := 'BRACES'; +{$IFDEF ComplexBraces} + LOOPENTRY: + Result := 'LOOPENTRY'; // ###0.925 + LOOP: + Result := 'LOOP'; // ###0.925 + LOOPNG: + Result := 'LOOPNG'; // ###0.940 +{$ENDIF} + ANYOFTINYSET: + Result := 'ANYOFTINYSET'; + ANYBUTTINYSET: + Result := 'ANYBUTTINYSET'; +{$IFDEF UseSetOfChar} // ###0.929 + ANYOFFULLSET: + Result := 'ANYOFFULLSET'; +{$ENDIF} + STARNG: + Result := 'STARNG'; // ###0.940 + PLUSNG: + Result := 'PLUSNG'; // ###0.940 + BRACESNG: + Result := 'BRACESNG'; // ###0.940 + else + Error(reeDumpCorruptedOpcode); + end; { of case op } + Result := ':' + Result; +end; { of function TRegExpr.DumpOp + -------------------------------------------------------------- } + +function TRegExpr.Dump: RegExprString; +// dump a regexp in vaguely comprehensible form +var + s: PRegExprChar; + op: TREOp; // Arbitrary non-END op. + next: PRegExprChar; + i: integer; +{$IFDEF UseSetOfChar} // ###0.929 + Ch: REChar; +{$ENDIF} +begin + if not IsProgrammOk // ###0.929 + then + EXIT; + + op := EXACTLY; + Result := ''; + s := programm + REOpSz; + while op <> EEND do + begin // While that wasn't END last time... + op := s^; + Result := Result + Format('%2d%s', [s - programm, DumpOp(s^)]); + // Where, what. + next := regnext(s); + if next = nil // Next ptr. + then + Result := Result + ' (0)' + else + Result := Result + Format(' (%d) ', [(s - programm) + (next - s)]); + Inc(s, REOpSz + RENextOffSz); + if (op = ANYOF) or (op = ANYOFCI) or (op = ANYBUT) or (op = ANYBUTCI) or + (op = EXACTLY) or (op = EXACTLYCI) then + begin + // Literal string, where present. + while s^ <> #0 do + begin + Result := Result + s^; + Inc(s); + end; + Inc(s); + end; + if (op = ANYOFTINYSET) or (op = ANYBUTTINYSET) then + begin + for i := 1 to TinySetLen do + begin + Result := Result + s^; + Inc(s); + end; + end; + if (op = BSUBEXP) or (op = BSUBEXPCI) then + begin + Result := Result + ' \' + IntToStr(ord(s^)); + Inc(s); + end; +{$IFDEF UseSetOfChar} // ###0.929 + if op = ANYOFFULLSET then + begin + for Ch := #0 to #255 do + if Ch in PSetOfREChar(s)^ then + if Ch < ' ' then + Result := Result + '#' + IntToStr(ord(Ch)) // ###0.936 + else + Result := Result + Ch; + Inc(s, SizeOf(TSetOfREChar)); + end; +{$ENDIF} + if (op = BRACES) or (op = BRACESNG) then + begin // ###0.941 + // show min/max argument of BRACES operator + Result := Result + Format('{%d,%d}', + [PREBracesArg(s)^, PREBracesArg(s + REBracesArgSz)^]); + Inc(s, REBracesArgSz * 2); + end; +{$IFDEF ComplexBraces} + if (op = LOOP) or (op = LOOPNG) then + begin // ###0.940 + Result := Result + Format(' -> (%d) {%d,%d}', + [(s - programm - (REOpSz + RENextOffSz)) + PRENextOff(s + 2 * + REBracesArgSz)^, PREBracesArg(s)^, PREBracesArg(s + REBracesArgSz)^]); + Inc(s, 2 * REBracesArgSz + RENextOffSz); + end; +{$ENDIF} + Result := Result + #$d#$a; + end; { of while } + + // Header fields of interest. + + if regstart <> #0 then + Result := Result + 'start ' + regstart; + if reganch <> #0 then + Result := Result + 'anchored '; + if regmust <> nil then + Result := Result + 'must have ' + regmust; +{$IFDEF UseFirstCharSet} // ###0.929 + Result := Result + #$d#$a'FirstCharSet:'; + for Ch := #0 to #255 do + if Ch in FirstCharSet then + Result := Result + Ch; +{$ENDIF} + Result := Result + #$d#$a; +end; { of function TRegExpr.Dump + -------------------------------------------------------------- } +{$ENDIF} +{$IFDEF reRealExceptionAddr} +{$OPTIMIZATION ON} +// ReturnAddr works correctly only if compiler optimization is ON +// I placed this method at very end of unit because there are no +// way to restore compiler optimization flag ... +{$ENDIF} + +procedure TRegExpr.Error(AErrorID: integer); +{$IFDEF reRealExceptionAddr} + function ReturnAddr: pointer; // ###0.938 + asm + mov eax,[ebp+4] + end; + +{$ENDIF} +var + e: ERegExpr; +begin + fLastError := AErrorID; // dummy stub - useless because will raise exception + if AErrorID < 1000 // compilation error ? + then + e := ERegExpr.Create(ErrorMsg(AErrorID) // yes - show error pos + + ' (pos ' + IntToStr(CompilerErrorPos) + ')') + else + e := ERegExpr.Create(ErrorMsg(AErrorID)); + e.ErrorCode := AErrorID; + e.CompilerErrorPos := CompilerErrorPos; + raise e +{$IFDEF reRealExceptionAddr} + At ReturnAddr; // ###0.938 +{$ENDIF} +end; { of procedure TRegExpr.Error + -------------------------------------------------------------- } + +// be carefull - placed here code will be always compiled with +// compiler optimization flag +initialization + +RegExprInvertCaseFunction := TRegExpr.InvertCaseFunction; + +end. diff --git a/Sources/iOS_Device/Demos/CallFunction/Project1.dpr b/Sources/iOS_Device/Demos/CallFunction/Project1.dpr new file mode 100644 index 0000000..3ac7d4f --- /dev/null +++ b/Sources/iOS_Device/Demos/CallFunction/Project1.dpr @@ -0,0 +1,14 @@ +program Project1; + +uses + System.StartUpCopy, + FMX.Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Sources/iOS_Device/Demos/CallFunction/Project1.dproj b/Sources/iOS_Device/Demos/CallFunction/Project1.dproj new file mode 100644 index 0000000..2e14ab4 --- /dev/null +++ b/Sources/iOS_Device/Demos/CallFunction/Project1.dproj @@ -0,0 +1,569 @@ + + + {39E0ADEA-F8D6-42DC-9A9E-86B640357759} + 15.1 + FMX + Project1.dpr + True + Debug + iOSDevice + 89 + Application + + + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Cfg_1 + true + true + + + true + Base + true + + + true + true + true + true + System;Xml;Data;Datasnap;Web;Soap;$(DCC_Namespace) + true + true + true + true + true + true + .\$(Platform)\$(Config) + .\$(Platform)\$(Config) + false + false + false + false + false + + + $(BDS)\bin\Artwork\Android\FM_LauncherIcon_72x72.png + FireDACSqliteDriver;bindcompfmx;DBXSqliteDriver;fmx;rtl;dbrtl;DbxClientDriver;IndySystem;FireDACCommon;bindcomp;DBXInterBaseDriver;DataSnapClient;DataSnapCommon;paxcomp_xe5;DataSnapProviderClient;xmlrtl;ibxpress;DbxCommonDriver;IndyProtocols;dbxcds;FireDACCommonDriver;bindengine;soaprtl;bindcompdbx;FMXTee;fmxFireDAC;CustomIPTransport;FireDAC;dsnap;IndyCore;FireDACDataSnapDriver;IndyIPCommon;CloudService;FireDACIBDriver;inet;FireDACDBXDriver;FmxTeeUI;RESTComponents;dbexpress;IndyIPClient;$(DCC_UsePackage) + $(BDS)\bin\Artwork\Android\FM_LauncherIcon_36x36.png + $(BDS)\bin\Artwork\Android\FM_LauncherIcon_96x96.png + package=com.embarcadero.$(MSBuildProjectName);label=$(MSBuildProjectName);versionCode=1;versionName=1.0.0;persistent=False;restoreAnyVersion=False;installLocation=preferExternal;largeHeap=False;theme=TitleBar + $(BDS)\bin\Artwork\Android\FM_LauncherIcon_48x48.png + true + Debug + $(BDS)\bin\Artwork\Android\FM_LauncherIcon_144x144.png + + + $(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_29x29.png + FireDACSqliteDriver;bindcompfmx;DBXSqliteDriver;fmx;rtl;dbrtl;DbxClientDriver;IndySystem;FireDACCommon;bindcomp;DBXInterBaseDriver;DataSnapClient;DataSnapCommon;DataSnapProviderClient;xmlrtl;ibxpress;DbxCommonDriver;IndyProtocols;dbxcds;FireDACCommonDriver;bindengine;soaprtl;bindcompdbx;FMXTee;fmxFireDAC;CustomIPTransport;FireDAC;dsnap;fmxase;IndyCore;FireDACDataSnapDriver;IndyIPCommon;CloudService;FireDACIBDriver;inet;FireDACDBXDriver;FmxTeeUI;RESTComponents;dbexpress;IndyIPClient;$(DCC_UsePackage) + $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_72x72.png + CFBundleName=$(MSBuildProjectName);CFBundleDevelopmentRegion=en;CFBundleDisplayName=$(MSBuildProjectName);CFBundleIdentifier=$(MSBuildProjectName);CFBundleInfoDictionaryVersion=6.0;CFBundleVersion=1.0.0.0;CFBundlePackageType=APPL;CFBundleSignature=????;LSRequiresIPhoneOS=true;CFBundleAllowMixedLocalizations=YES;CFBundleExecutable=$(MSBuildProjectName);UIDeviceFamily=iPhone & iPad;CFBundleResourceSpecification=ResourceRules.plist + $(BDS)\bin\Artwork\iOS\iPad\FM_SettingIcon_29x29.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_768x1004.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImage_640x1136.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_57x57.png + $(MSBuildProjectName) + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_2048x1496.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_1024x748.png + Debug + $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImage_320x480.png + true + $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImage_640x960.png + $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_144x144.png + iPhoneAndiPad + $(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_100x100.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SettingIcon_58x58.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_58x58.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_1536x2008.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_114x114.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_50x50.png + + + $(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_29x29.png + FireDACSqliteDriver;bindcompfmx;DBXSqliteDriver;fmx;rtl;dbrtl;DbxClientDriver;IndySystem;FireDACCommon;bindcomp;DBXInterBaseDriver;DataSnapClient;DataSnapCommon;DataSnapProviderClient;xmlrtl;ibxpress;DbxCommonDriver;IndyProtocols;dbxcds;FireDACCommonDriver;bindengine;soaprtl;bindcompdbx;FMXTee;fmxFireDAC;CustomIPTransport;FireDAC;dsnap;fmxase;IndyCore;FireDACDataSnapDriver;IndyIPCommon;CloudService;FireDACIBDriver;inet;FireDACDBXDriver;FmxTeeUI;RESTComponents;dbexpress;IndyIPClient;$(DCC_UsePackage) + $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_72x72.png + CFBundleName=$(MSBuildProjectName);CFBundleDevelopmentRegion=en;CFBundleDisplayName=$(MSBuildProjectName);CFBundleIdentifier=$(MSBuildProjectName);CFBundleInfoDictionaryVersion=6.0;CFBundleVersion=1.0.0.0;CFBundlePackageType=APPL;CFBundleSignature=????;LSRequiresIPhoneOS=true;CFBundleAllowMixedLocalizations=YES;CFBundleExecutable=$(MSBuildProjectName);UIDeviceFamily=iPhone & iPad;CFBundleResourceSpecification=ResourceRules.plist + $(BDS)\bin\Artwork\iOS\iPad\FM_SettingIcon_29x29.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImage_640x1136.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_57x57.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_1024x748.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_768x1004.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_2048x1496.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_58x58.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImage_320x480.png + true + $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImage_640x960.png + $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_144x144.png + iPhoneAndiPad + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_1536x2008.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SettingIcon_58x58.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_50x50.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_100x100.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_114x114.png + + + $(BDS)\bin\default_app.manifest + Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) + 1033 + true + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments= + DataSnapIndy10ServerTransport;FireDACASADriver;FireDACSqliteDriver;bindcompfmx;DBXSqliteDriver;vcldbx;FireDACPgDriver;FireDACODBCDriver;fmx;rtl;dbrtl;DbxClientDriver;IndySystem;FireDACCommon;bindcomp;inetdb;TeeDB;vclib;inetdbbde;DBXInterBaseDriver;DataSnapClient;DataSnapCommon;DBXOdbcDriver;DataSnapServer;Tee;vclFireDAC;paxcomp_xe5;DataSnapProviderClient;xmlrtl;svnui;ibxpress;DbxCommonDriver;DBXSybaseASEDriver;vclimg;IndyProtocols;dbxcds;DBXMySQLDriver;DatasnapConnectorsFreePascal;FireDACCommonDriver;MetropolisUILiveTile;bindengine;vclactnband;vcldb;soaprtl;bindcompdbx;vcldsnap;bindcompvcl;FMXTee;TeeUI;vclie;fmxFireDAC;FireDACADSDriver;vcltouch;DBXDb2Driver;DBXOracleDriver;CustomIPTransport;vclribbon;VclSmp;FireDACMSSQLDriver;FireDAC;dsnap;Intraweb;fmxase;vcl;IndyCore;FireDACDataSnapDriver;IndyIPServer;IndyIPCommon;VCLRESTComponents;CloudService;dsnapcon;FireDACIBDriver;DBXFirebirdDriver;inet;DBXMSSQLDriver;fmxobj;FireDACDBXDriver;DBXInformixDriver;DataSnapConnectors;FireDACMySQLDriver;FmxTeeUI;vclx;CodeSiteExpressPkg;inetdbxpress;svn;DBXSybaseASADriver;FireDACOracleDriver;fmxdae;FireDACDb2Driver;RESTComponents;bdertl;FireDACMSAccDriver;adortl;dbexpress;IndyIPClient;$(DCC_UsePackage) + + + DEBUG;$(DCC_Define) + true + false + true + true + true + + + false + + + false + RELEASE;$(DCC_Define) + 0 + 0 + + + + MainSource + + +
Form1
+ fmx + + + Cfg_2 + Base + + + Base + + + Cfg_1 + Base + + + + Delphi.Personality.12 + + + + + False + False + 1 + 0 + 0 + 0 + False + False + False + False + False + 1033 + 1252 + + + + + 1.0.0.0 + + + + + + 1.0.0.0 + + + + + + + + + + + + + + + + + + + + + + + + + + + Project1.dpr + + + + + + + + + + + + + + + + + + + ic_launcher.png + + + + + ic_launcher.png + + + + + ic_launcher.png + + + + + ic_launcher.png + + + + + classes.dex + + + + + ic_launcher.png + + + + + 1 + .dylib + + + 0 + .bpl + + + Contents\MacOS + 1 + .dylib + + + 1 + .dylib + + + + + 1 + .dylib + + + 0 + .dll;.bpl + + + Contents\MacOS + 1 + .dylib + + + 1 + .dylib + + + + + 1 + + + 1 + + + + + Contents + 1 + + + + + ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF + 1 + + + + + 1 + + + 1 + + + + + Contents + 1 + + + + + library\lib\armeabi + 1 + + + + + 1 + + + 1 + + + + + res\drawable-xhdpi + 1 + + + + + 1 + + + 1 + + + + + res\drawable-xxhdpi + 1 + + + + + Contents\MacOS + 1 + + + 1 + + + 0 + + + + + Contents\MacOS + 1 + .framework + + + 0 + + + + + 1 + + + + + Contents\MacOS + 1 + + + 1 + + + Contents\MacOS + 0 + + + + + classes + 1 + + + + + 1 + + + + + 1 + + + 1 + + + + + 1 + + + + + res\drawable + 1 + + + + + Contents\Resources + 1 + + + + + 1 + + + + + 1 + + + 1 + + + + + 1 + + + library\lib\armeabi + 1 + + + 0 + + + Contents\MacOS + 1 + + + 1 + + + + + 0 + + + 0 + + + 0 + + + Contents\MacOS + 0 + + + 0 + + + + + 1 + + + 1 + + + + + res\drawable-ldpi + 1 + + + + + 1 + + + 1 + + + + + res\drawable-mdpi + 1 + + + + + res\drawable-hdpi + 1 + + + + + 1 + + + + + + + + + + + True + True + True + True + + + 12 + + + + + diff --git a/Sources/iOS_Device/Demos/CallFunction/Project1.res b/Sources/iOS_Device/Demos/CallFunction/Project1.res new file mode 100644 index 0000000..36f26e2 Binary files /dev/null and b/Sources/iOS_Device/Demos/CallFunction/Project1.res differ diff --git a/Sources/iOS_Device/Demos/CallFunction/Unit1.fmx b/Sources/iOS_Device/Demos/CallFunction/Unit1.fmx new file mode 100644 index 0000000..679a15d --- /dev/null +++ b/Sources/iOS_Device/Demos/CallFunction/Unit1.fmx @@ -0,0 +1,61 @@ +object Form1: TForm1 + Left = 0 + Top = 0 + Caption = 'Form2' + ClientHeight = 567 + ClientWidth = 384 + FormFactor.Width = 320 + FormFactor.Height = 480 + FormFactor.Devices = [dkDesktop] + DesignerMobile = True + DesignerWidth = 384 + DesignerHeight = 592 + DesignerDeviceName = 'Google Nexus 4' + DesignerOrientation = 0 + DesignerOSVersion = '' + object Memo1: TMemo + Touch.InteractiveGestures = [igPan, igLongTap, igDoubleTap] + Height = 193.000000000000000000 + Position.X = 16.000000000000000000 + Position.Y = 16.000000000000000000 + TabOrder = 0 + Width = 233.000000000000000000 + Lines.Strings = ( + 'function Anchor(const Address, Text: String): String;' + 'begin' + ' result := '#39''#39' + Text + '#39''#39';' + 'end;' + '' + 'begin' + 'end.' + '') + end + object Memo2: TMemo + Touch.InteractiveGestures = [igPan, igLongTap, igDoubleTap] + Height = 73.000000000000000000 + Position.X = 8.000000000000000000 + Position.Y = 240.000000000000000000 + TabOrder = 1 + Width = 241.000000000000000000 + end + object Button1: TButton + Height = 44.000000000000000000 + Position.X = 48.000000000000000000 + Position.Y = 336.000000000000000000 + TabOrder = 2 + Text = 'Call' + Trimming = ttCharacter + Width = 73.000000000000000000 + OnClick = Button1Click + end + object Button2: TButton + Height = 44.000000000000000000 + Position.X = 152.000000000000000000 + Position.Y = 336.000000000000000000 + TabOrder = 3 + Text = 'Exit' + Trimming = ttCharacter + Width = 73.000000000000000000 + OnClick = Button2Click + end +end diff --git a/Sources/iOS_Device/Demos/CallFunction/Unit1.pas b/Sources/iOS_Device/Demos/CallFunction/Unit1.pas new file mode 100644 index 0000000..9f60651 --- /dev/null +++ b/Sources/iOS_Device/Demos/CallFunction/Unit1.pas @@ -0,0 +1,75 @@ +unit Unit1; + +interface + +uses + System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants, + FMX.Types, FMX.Controls, FMX.Forms, FMX.Graphics, FMX.Dialogs, FMX.StdCtrls, +{$IFDEF ANDROID} + FMX.Platform.Android, +{$ENDIF} + FMX.Layouts, FMX.Memo, + PaxCompiler, PaxRunner, PaxInterpreter; + +type + TForm1 = class(TForm) + Memo1: TMemo; + Memo2: TMemo; + Button1: TButton; + Button2: TButton; + procedure Button2Click(Sender: TObject); + procedure Button1Click(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.fmx} + +procedure TForm1.Button1Click(Sender: TObject); +var + PaxCompiler1: TPaxCompiler; + PaxInterpreter1: TPaxInterpreter; + PaxLanguage1: TPaxCompilerLanguage; + S: String; +begin + PaxCompiler1 := TPaxCompiler.Create(nil); + PaxInterpreter1 := TPaxInterpreter.Create(nil); + PaxLanguage1 := TPaxPascalLanguage.Create(nil); + try + PaxCompiler1.RegisterLanguage(PaxLanguage1); + PaxCompiler1.AddModule('1', 'Pascal'); + PaxCompiler1.AddCode('1', Memo1.Lines.Text); + if PaxCompiler1.Compile(PaxInterpreter1) then + begin + PaxInterpreter1.RunInitialization; + S := PaxInterpreter1.CallRoutine('Anchor', ['http://www.google.com', 'Click here...']); + Memo2.Lines.Add(S); + end + else + begin + ShowMessage(PaxCompiler1.ErrorMessage[0]); + end; + finally + FreeAndNil(PaxCompiler1); + FreeAndNil(PaxInterpreter1); + FreeAndNil(PaxLanguage1); + end; +end; + +procedure TForm1.Button2Click(Sender: TObject); +begin +{$IFDEF ANDROID} + MainActivity.finish; +{$ELSE} + Close; +{$ENDIF} +end; + +end. diff --git a/Sources/iOS_Device/Demos/DebugDemo/Project1.dpr b/Sources/iOS_Device/Demos/DebugDemo/Project1.dpr new file mode 100644 index 0000000..3ac7d4f --- /dev/null +++ b/Sources/iOS_Device/Demos/DebugDemo/Project1.dpr @@ -0,0 +1,14 @@ +program Project1; + +uses + System.StartUpCopy, + FMX.Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Sources/iOS_Device/Demos/DebugDemo/Project1.dproj b/Sources/iOS_Device/Demos/DebugDemo/Project1.dproj new file mode 100644 index 0000000..1a71ccc --- /dev/null +++ b/Sources/iOS_Device/Demos/DebugDemo/Project1.dproj @@ -0,0 +1,578 @@ + + + {A2936444-2C7D-4C37-AC89-85946911B94B} + 15.1 + FMX + Project1.dpr + True + Debug + iOSDevice + 89 + Application + + + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Cfg_1 + true + true + + + true + Cfg_1 + true + true + + + true + Base + true + + + true + true + true + true + true + true + true + true + System;Xml;Data;Datasnap;Web;Soap;$(DCC_Namespace) + true + true + .\$(Platform)\$(Config) + .\$(Platform)\$(Config) + false + false + false + false + false + + + $(BDS)\bin\Artwork\Android\FM_LauncherIcon_144x144.png + FireDACSqliteDriver;bindcompfmx;DBXSqliteDriver;fmx;rtl;dbrtl;DbxClientDriver;IndySystem;FireDACCommon;bindcomp;DBXInterBaseDriver;DataSnapClient;DataSnapCommon;paxcomp_xe5;DataSnapProviderClient;xmlrtl;ibxpress;DbxCommonDriver;IndyProtocols;dbxcds;FireDACCommonDriver;bindengine;soaprtl;bindcompdbx;FMXTee;fmxFireDAC;CustomIPTransport;FireDAC;dsnap;IndyCore;FireDACDataSnapDriver;IndyIPCommon;CloudService;FireDACIBDriver;inet;FireDACDBXDriver;FmxTeeUI;RESTComponents;dbexpress;IndyIPClient;$(DCC_UsePackage) + true + $(BDS)\bin\Artwork\Android\FM_LauncherIcon_96x96.png + $(BDS)\bin\Artwork\Android\FM_LauncherIcon_36x36.png + $(BDS)\bin\Artwork\Android\FM_LauncherIcon_72x72.png + package=com.embarcadero.$(MSBuildProjectName);label=$(MSBuildProjectName);versionCode=1;versionName=1.0.0;persistent=False;restoreAnyVersion=False;installLocation=preferExternal;largeHeap=False;theme=TitleBar + $(BDS)\bin\Artwork\Android\FM_LauncherIcon_48x48.png + Debug + + + $(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_100x100.png + FireDACSqliteDriver;bindcompfmx;DBXSqliteDriver;fmx;rtl;dbrtl;DbxClientDriver;IndySystem;FireDACCommon;bindcomp;DBXInterBaseDriver;DataSnapClient;DataSnapCommon;DataSnapProviderClient;xmlrtl;ibxpress;DbxCommonDriver;IndyProtocols;dbxcds;FireDACCommonDriver;bindengine;soaprtl;bindcompdbx;FMXTee;fmxFireDAC;CustomIPTransport;FireDAC;dsnap;fmxase;IndyCore;FireDACDataSnapDriver;IndyIPCommon;CloudService;FireDACIBDriver;inet;FireDACDBXDriver;FmxTeeUI;RESTComponents;dbexpress;IndyIPClient;$(DCC_UsePackage) + $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_72x72.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SettingIcon_58x58.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_50x50.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImage_640x1136.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SettingIcon_29x29.png + true + $(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_58x58.png + $(MSBuildProjectName) + iPhoneAndiPad + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_1024x748.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_29x29.png + Debug + CFBundleName=$(MSBuildProjectName);CFBundleDevelopmentRegion=en;CFBundleDisplayName=$(MSBuildProjectName);CFBundleIdentifier=$(MSBuildProjectName);CFBundleInfoDictionaryVersion=6.0;CFBundleVersion=1.0.0.0;CFBundlePackageType=APPL;CFBundleSignature=????;LSRequiresIPhoneOS=true;CFBundleAllowMixedLocalizations=YES;CFBundleExecutable=$(MSBuildProjectName);UIDeviceFamily=iPhone & iPad;CFBundleResourceSpecification=ResourceRules.plist + $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_114x114.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_2048x1496.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_1536x2008.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImage_320x480.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_768x1004.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImage_640x960.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_57x57.png + $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_144x144.png + + + $(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_100x100.png + FireDACSqliteDriver;bindcompfmx;DBXSqliteDriver;fmx;rtl;dbrtl;DbxClientDriver;IndySystem;FireDACCommon;bindcomp;DBXInterBaseDriver;DataSnapClient;DataSnapCommon;DataSnapProviderClient;xmlrtl;ibxpress;DbxCommonDriver;IndyProtocols;dbxcds;FireDACCommonDriver;bindengine;soaprtl;bindcompdbx;FMXTee;fmxFireDAC;CustomIPTransport;FireDAC;dsnap;fmxase;IndyCore;FireDACDataSnapDriver;IndyIPCommon;CloudService;FireDACIBDriver;inet;FireDACDBXDriver;FmxTeeUI;RESTComponents;dbexpress;IndyIPClient;$(DCC_UsePackage) + $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_72x72.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SettingIcon_58x58.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_50x50.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SettingIcon_29x29.png + true + $(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_58x58.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImage_640x1136.png + iPhoneAndiPad + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_1024x748.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_29x29.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_1536x2008.png + CFBundleName=$(MSBuildProjectName);CFBundleDevelopmentRegion=en;CFBundleDisplayName=$(MSBuildProjectName);CFBundleIdentifier=$(MSBuildProjectName);CFBundleInfoDictionaryVersion=6.0;CFBundleVersion=1.0.0.0;CFBundlePackageType=APPL;CFBundleSignature=????;LSRequiresIPhoneOS=true;CFBundleAllowMixedLocalizations=YES;CFBundleExecutable=$(MSBuildProjectName);UIDeviceFamily=iPhone & iPad;CFBundleResourceSpecification=ResourceRules.plist + $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_114x114.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_2048x1496.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImage_320x480.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_768x1004.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImage_640x960.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_57x57.png + $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_144x144.png + + + 1033 + DataSnapIndy10ServerTransport;FireDACASADriver;FireDACSqliteDriver;bindcompfmx;DBXSqliteDriver;vcldbx;FireDACPgDriver;FireDACODBCDriver;fmx;rtl;dbrtl;DbxClientDriver;IndySystem;FireDACCommon;bindcomp;inetdb;TeeDB;vclib;inetdbbde;DBXInterBaseDriver;DataSnapClient;DataSnapCommon;DBXOdbcDriver;DataSnapServer;Tee;vclFireDAC;paxcomp_xe5;DataSnapProviderClient;xmlrtl;svnui;ibxpress;DbxCommonDriver;DBXSybaseASEDriver;vclimg;IndyProtocols;dbxcds;DBXMySQLDriver;DatasnapConnectorsFreePascal;FireDACCommonDriver;MetropolisUILiveTile;bindengine;vclactnband;vcldb;soaprtl;bindcompdbx;vcldsnap;bindcompvcl;FMXTee;TeeUI;vclie;fmxFireDAC;FireDACADSDriver;vcltouch;DBXDb2Driver;DBXOracleDriver;CustomIPTransport;vclribbon;VclSmp;FireDACMSSQLDriver;FireDAC;dsnap;Intraweb;fmxase;vcl;IndyCore;FireDACDataSnapDriver;IndyIPServer;IndyIPCommon;VCLRESTComponents;CloudService;dsnapcon;FireDACIBDriver;DBXFirebirdDriver;inet;DBXMSSQLDriver;fmxobj;FireDACDBXDriver;DBXInformixDriver;DataSnapConnectors;FireDACMySQLDriver;FmxTeeUI;vclx;CodeSiteExpressPkg;inetdbxpress;svn;DBXSybaseASADriver;FireDACOracleDriver;fmxdae;FireDACDb2Driver;RESTComponents;bdertl;FireDACMSAccDriver;adortl;dbexpress;IndyIPClient;$(DCC_UsePackage) + true + $(BDS)\bin\default_app.manifest + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments= + Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) + + + DEBUG;$(DCC_Define) + true + false + true + true + true + + + C:\HOT\assem2\CURR\;$(Debugger_DebugSourcePath) + + + false + + + false + RELEASE;$(DCC_Define) + 0 + 0 + + + + MainSource + + +
Form1
+ fmx + + + Cfg_2 + Base + + + Base + + + Cfg_1 + Base + + + + Delphi.Personality.12 + + + + + False + False + 1 + 0 + 0 + 0 + False + False + False + False + False + 1033 + 1252 + + + + + 1.0.0.0 + + + + + + 1.0.0.0 + + + + + + + + + + + + + + + + + + + + + + + + + + + Project1.dpr + + + + + + ic_launcher.png + + + + + ic_launcher.png + + + + + + + + + + + + ic_launcher.png + + + + + ic_launcher.png + + + + + + + + ic_launcher.png + + + + + classes.dex + + + + + + + + 1 + .dylib + + + 0 + .bpl + + + Contents\MacOS + 1 + .dylib + + + 1 + .dylib + + + + + 1 + .dylib + + + 0 + .dll;.bpl + + + Contents\MacOS + 1 + .dylib + + + 1 + .dylib + + + + + 1 + + + 1 + + + + + Contents + 1 + + + + + ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF + 1 + + + + + 1 + + + 1 + + + + + Contents + 1 + + + + + library\lib\armeabi + 1 + + + + + 1 + + + 1 + + + + + res\drawable-xhdpi + 1 + + + + + 1 + + + 1 + + + + + res\drawable-xxhdpi + 1 + + + + + Contents\MacOS + 1 + + + 1 + + + 0 + + + + + Contents\MacOS + 1 + .framework + + + 0 + + + + + 1 + + + + + Contents\MacOS + 1 + + + 1 + + + Contents\MacOS + 0 + + + + + classes + 1 + + + + + 1 + + + + + 1 + + + 1 + + + + + 1 + + + + + res\drawable + 1 + + + + + Contents\Resources + 1 + + + + + 1 + + + + + 1 + + + 1 + + + + + 1 + + + library\lib\armeabi + 1 + + + 0 + + + Contents\MacOS + 1 + + + 1 + + + + + 0 + + + 0 + + + 0 + + + Contents\MacOS + 0 + + + 0 + + + + + 1 + + + 1 + + + + + res\drawable-ldpi + 1 + + + + + 1 + + + 1 + + + + + res\drawable-mdpi + 1 + + + + + res\drawable-hdpi + 1 + + + + + 1 + + + + + + + + + + + True + True + True + True + + + 12 + + + + + diff --git a/Sources/iOS_Device/Demos/DebugDemo/Project1.res b/Sources/iOS_Device/Demos/DebugDemo/Project1.res new file mode 100644 index 0000000..36f26e2 Binary files /dev/null and b/Sources/iOS_Device/Demos/DebugDemo/Project1.res differ diff --git a/Sources/iOS_Device/Demos/DebugDemo/Unit1.fmx b/Sources/iOS_Device/Demos/DebugDemo/Unit1.fmx new file mode 100644 index 0000000..68670dd --- /dev/null +++ b/Sources/iOS_Device/Demos/DebugDemo/Unit1.fmx @@ -0,0 +1,98 @@ +object Form1: TForm1 + Left = 0 + Top = 0 + Caption = 'Debug demo' + ClientHeight = 567 + ClientWidth = 384 + FormFactor.Width = 320 + FormFactor.Height = 480 + FormFactor.Devices = [dkDesktop] + OnCreate = FormCreate + OnDestroy = FormDestroy + DesignerMobile = True + DesignerWidth = 384 + DesignerHeight = 592 + DesignerDeviceName = 'Google Nexus 4' + DesignerOrientation = 0 + DesignerOSVersion = '' + object Memo1: TMemo + Touch.InteractiveGestures = [igPan, igLongTap, igDoubleTap] + Height = 137.000000000000000000 + Position.X = 16.000000000000000000 + Position.Y = 24.000000000000000000 + TabOrder = 0 + Width = 193.000000000000000000 + Lines.Strings = ( + 'function Fact(N: Integer): Integer;' + 'begin' + ' if N = 1 then' + ' result := 1' + ' else' + ' result := N * Fact(N - 1);' + 'end;' + 'var SS: Integer;' + 'begin' + ' SS := Fact(3);' + ' print(SS);' + 'end.' + '') + end + object Memo2: TMemo + Touch.InteractiveGestures = [igPan, igLongTap, igDoubleTap] + Height = 233.000000000000000000 + Position.X = 16.000000000000000000 + Position.Y = 184.000000000000000000 + TabOrder = 1 + Width = 193.000000000000000000 + end + object Button1: TButton + Height = 44.000000000000000000 + Position.X = 216.000000000000000000 + Position.Y = 24.000000000000000000 + TabOrder = 2 + Text = 'Compile' + Trimming = ttCharacter + Width = 97.000000000000000000 + OnClick = Button1Click + end + object Button2: TButton + Height = 44.000000000000000000 + Position.X = 216.000000000000000000 + Position.Y = 72.000000000000000000 + TabOrder = 3 + Text = 'Run' + Trimming = ttCharacter + Width = 97.000000000000000000 + OnClick = Button2Click + end + object Button3: TButton + Height = 44.000000000000000000 + Position.X = 216.000000000000000000 + Position.Y = 120.000000000000000000 + TabOrder = 4 + Text = 'Trace Into' + Trimming = ttCharacter + Width = 97.000000000000000000 + OnClick = Button3Click + end + object Button4: TButton + Height = 44.000000000000000000 + Position.X = 216.000000000000000000 + Position.Y = 168.000000000000000000 + TabOrder = 5 + Text = 'Step Over' + Trimming = ttCharacter + Width = 97.000000000000000000 + OnClick = Button4Click + end + object Button5: TButton + Height = 44.000000000000000000 + Position.X = 216.000000000000000000 + Position.Y = 216.000000000000000000 + TabOrder = 6 + Text = 'Exit' + Trimming = ttCharacter + Width = 97.000000000000000000 + OnClick = Button5Click + end +end diff --git a/Sources/iOS_Device/Demos/DebugDemo/Unit1.pas b/Sources/iOS_Device/Demos/DebugDemo/Unit1.pas new file mode 100644 index 0000000..2616f10 --- /dev/null +++ b/Sources/iOS_Device/Demos/DebugDemo/Unit1.pas @@ -0,0 +1,364 @@ +unit Unit1; + +interface + +uses + System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants, + FMX.Types, FMX.Controls, FMX.Forms, FMX.Graphics, FMX.Dialogs, FMX.StdCtrls, + FMX.Layouts, FMX.Memo, +{$IFDEF ANDROID} + FMX.Platform.Android, +{$ENDIF} + PaxCompiler, + PaxRunner, + PaxInterpreter, + PaxCompilerExplorer, + PaxCompilerDebugger; + +type + TForm1 = class(TForm) + Memo1: TMemo; + Memo2: TMemo; + Button1: TButton; + Button2: TButton; + Button3: TButton; + Button4: TButton; + Button5: TButton; + procedure Button1Click(Sender: TObject); + procedure FormCreate(Sender: TObject); + procedure FormDestroy(Sender: TObject); + procedure Button2Click(Sender: TObject); + procedure Button3Click(Sender: TObject); + procedure Button5Click(Sender: TObject); + procedure Button4Click(Sender: TObject); + private + { Private declarations } + PaxCompiler1: TPaxCompiler; + PaxInterpreter1: TPaxInterpreter; + PaxPascalLanguage1: TPaxPascalLanguage; + PaxCompilerExplorer1: TPaxCompilerExplorer; + PaxCompilerDebugger1: TPaxCompilerDebugger; + PauseProcessed: Boolean; + function TestValid: Boolean; + procedure DoPause(Sender: TPaxRunner; + const ModuleName: String; SourceLineNumber: Integer); + procedure DoPrint(Sender: TPaxRunner; const S: String); + procedure RunDebugger(RunMode: Integer); + public + { Public declarations } + procedure UpdateDebugInfo; + procedure ClearOutput; + procedure Output(const S: String); + end; + +var + Form1: TForm1; + +implementation + +{$R *.fmx} + +procedure TForm1.RunDebugger(RunMode: Integer); +begin + if not TestValid then Exit; + + PauseProcessed := false; + PaxCompilerDebugger1.RunMode := RunMode; + PaxCompilerDebugger1.Run; + if not PauseProcessed then + Output('FINISHED'); +end; + +procedure TForm1.Button2Click(Sender: TObject); +begin + RunDebugger(_rmRUN); +end; + +procedure TForm1.Button3Click(Sender: TObject); +begin + RunDebugger(_rmTRACE_INTO); +end; + +procedure TForm1.Button4Click(Sender: TObject); +begin + RunDebugger(_rmSTEP_OVER); +end; + +procedure TForm1.Button5Click(Sender: TObject); +begin +{$IFDEF ANDROID} + MainActivity.finish; +{$ELSE} + Close; +{$ENDIF} +end; + +procedure TForm1.FormCreate(Sender: TObject); +begin + PaxCompiler1 := TPaxCompiler.Create(nil); + PaxInterpreter1 := TPaxInterpreter.Create(nil); + PaxPascalLanguage1 := TPaxPascalLanguage.Create(nil); + PaxCompilerExplorer1 := TPaxCompilerExplorer.Create(nil); + PaxCompilerDebugger1 := TPaxCompilerDebugger.Create(nil); + + PaxInterpreter1.OnPause := DoPause; + PaxInterpreter1.OnPrintEvent := DoPrint; + + Button2.Enabled := false; + Button3.Enabled := false; + Button4.Enabled := false; +end; + +procedure TForm1.FormDestroy(Sender: TObject); +begin + FreeAndNil(PaxCompiler1); + FreeAndNil(PaxInterpreter1); + FreeAndNil(PaxPascalLanguage1); + FreeAndNil(PaxCompilerExplorer1); + FreeAndNil(PaxCompilerDebugger1); +end; + +procedure TForm1.ClearOutput; +begin + Memo2.Lines.Clear; +end; + +procedure TForm1.Output(const S: String); +begin + Memo2.Lines.Add(S); +end; + +procedure TForm1.Button1Click(Sender: TObject); +var + I: Integer; +begin + ClearOutput; + + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + PaxCompiler1.AddModule('1', PaxPascalLanguage1.LanguageName); + PaxCompiler1.AddCode('1', Memo1.Lines.Text); + PaxCompiler1.DebugMode := true; + if PaxCompiler1.Compile(PaxInterpreter1) then + begin + Output('Compilation: OK'); + PaxCompilerExplorer1.RegisterCompiler(PaxCompiler1); + PaxCompilerDebugger1.RegisterCompiler(PaxCompiler1, PaxInterpreter1); + + Button2.Enabled := true; + Button3.Enabled := true; + Button4.Enabled := true; + end + else + for I:=0 to PaxCompiler1.ErrorCount - 1 do + Output(PaxCompiler1.ErrorMessage[I]); +end; + +procedure TForm1.DoPause(Sender: TPaxRunner; + const ModuleName: String; SourceLineNumber: Integer); +begin + UpdateDebugInfo; + PauseProcessed := true; +end; + +procedure TForm1.DoPrint(Sender: TPaxRunner; const S: String); +begin + ShowMessage(S); +end; + +function TForm1.TestValid: Boolean; +begin + result := PaxCompilerDebugger1.Valid; + if not result then + Output('Script is not valid.'); +end; + +procedure TForm1.UpdateDebugInfo; + + procedure AddFields(StackFrameNumber, Id: Integer); + var + I, K: Integer; + OwnerName, S: String; + begin + K := PaxCompilerExplorer1.GetFieldCount(Id); + if K = 0 then + Exit; + + OwnerName := PaxCompilerExplorer1.Names[Id]; + if PaxCompilerDebugger1.GetValueAsString(Id) = 'nil' then + Exit; + + for I:=0 to K - 1 do + begin + S := OwnerName + '.' + PaxCompilerExplorer1.GetFieldName(Id, I); + S := ' ' + S + '=' + PaxCompilerDebugger1.GetFieldValueAsString( + StackFrameNumber, Id, I); + Output(S); + end; + end; + + procedure AddPublishedProps(StackFrameNumber, Id: Integer); + var + I, K: Integer; + OwnerName, S: String; + begin + K := PaxCompilerExplorer1.GetPublishedPropCount(Id); + if K = 0 then + Exit; + + OwnerName := PaxCompilerExplorer1.Names[Id]; + if PaxCompilerDebugger1.GetValueAsString(Id) = 'nil' then + Exit; + + for I:=0 to K - 1 do + begin + S := OwnerName + '.' + PaxCompilerExplorer1.GetPublishedPropName(Id, I); + S := ' ' + S + '=' + PaxCompilerDebugger1.GetPublishedPropValueAsString( + StackFrameNumber, Id, I); + Output(S); + end; + end; + + procedure AddArrayElements(StackFrameNumber, Id: Integer); + var + I, K1, K2: Integer; + OwnerName, S: String; + begin + if not PaxCompilerExplorer1.HasArrayType(Id) then + Exit; + + K1 := PaxCompilerExplorer1.GetArrayLowBound(Id); + K2 := PaxCompilerExplorer1.GetArrayHighBound(Id); + + OwnerName := PaxCompilerExplorer1.Names[Id]; + + for I:=K1 to K2 do + begin + S := OwnerName + '[' + IntToStr(I) + ']'; + S := ' ' + S + '=' + PaxCompilerDebugger1.GetArrayItemValueAsString( + StackFrameNumber, Id, I); + Output(S); + end; + end; + + procedure AddDynArrayElements(StackFrameNumber, Id: Integer); + var + I, L: Integer; + OwnerName, S: String; + begin + if not PaxCompilerExplorer1.HasDynArrayType(Id) then + Exit; + + L := PaxCompilerDebugger1.GetDynArrayLength(StackFrameNumber, Id); + + OwnerName := PaxCompilerExplorer1.Names[Id]; + + for I:=0 to L - 1 do + begin + S := OwnerName + '[' + IntToStr(I) + ']'; + S := ' ' + S + '=' + PaxCompilerDebugger1.GetDynArrayItemValueAsString( + StackFrameNumber, Id, I); + Output(S); + end; + end; + +var + SourceLineNumber: Integer; + ModuleName: String; + StackFrameNumber, J, K, SubId, Id: Integer; + S, V: String; + CallStackLineNumber: Integer; + CallStackModuleName: String; +begin + ClearOutput; + if PaxCompilerDebugger1.IsPaused then + begin + ModuleName := PaxCompilerDebugger1.ModuleName; + SourceLineNumber := PaxCompilerDebugger1.SourceLineNumber; + + Output('Paused at line ' + IntTosTr(SourceLineNumber)); + Output(PaxCompiler1.Modules[ModuleName][SourceLineNumber]); + Output('------------------------------------------------------'); + + if PaxCompilerDebugger1.CallStackCount > 0 then + begin + Output('Call stack:'); + for StackFrameNumber:=0 to PaxCompilerDebugger1.CallStackCount - 1 do + begin + SubId := PaxCompilerDebugger1.CallStack[StackFrameNumber]; + S := '('; + K := PaxCompilerExplorer1.GetParamCount(SubId); + for J:=0 to K - 1 do + begin + Id := PaxCompilerExplorer1.GetParamId(SubId, J); + V := PaxCompilerDebugger1.GetValueAsString(StackFrameNumber, Id); + S := S + V; + if J < K - 1 then + S := S + ','; + end; + S := PaxCompilerExplorer1.Names[SubId] + S + ')'; + + CallStackLineNumber := PaxCompilerDebugger1.CallStackLineNumber[StackFrameNumber]; + CallStackModuleName := PaxCompilerDebugger1.CallStackModuleName[StackFrameNumber]; + + S := S + '; // ' + PaxCompiler1.Modules[CallStackModuleName][CallStackLineNumber]; + + Output(S); + end; + Output('------------------------------------------------------'); + + Output('Local scope:'); + StackFrameNumber := PaxCompilerDebugger1.CallStackCount - 1; + SubId := PaxCompilerDebugger1.CallStack[StackFrameNumber]; + K := PaxCompilerExplorer1.GetLocalCount(SubId); + for J:=0 to K - 1 do + begin + Id := PaxCompilerExplorer1.GetLocalId(SubId, J); + V := PaxCompilerDebugger1.GetValueAsString(StackFrameNumber, Id); + S := PaxCompilerExplorer1.Names[Id] + '=' + V; + Output(S); + + if Pos('X', S) > 0 then + begin + PaxCompilerDebugger1.PutValue(StackFrameNumber, Id, 258); + + V := PaxCompilerDebugger1.GetValueAsString(StackFrameNumber, Id); + S := PaxCompilerExplorer1.Names[Id] + '=' + V; + S := S + ' // modified'; + Output(S); + end; + + AddFields(StackFrameNumber, Id); + AddPublishedProps(StackFrameNumber, Id); + AddArrayElements(StackFrameNumber, Id); + AddDynArrayElements(StackFrameNumber, Id); + end; + + Output('------------------------------------------------------'); + end; + + Output('Global scope:'); + K := PaxCompilerExplorer1.GetGlobalCount(0); + for J:=0 to K - 1 do + begin + Id := PaxCompilerExplorer1.GetGlobalId(0, J); + V := PaxCompilerDebugger1.GetValueAsString(Id); + S := PaxCompilerExplorer1.Names[Id] + '=' + V; + Output(S); + + AddFields(0, Id); + AddPublishedProps(0, Id); + AddArrayElements(0, Id); + AddDynArrayElements(0, Id); + end; + Output('------------------------------------------------------'); + + end + else + Output('Finished'); + + Memo2.SelStart := 0; + Memo2.SelLength := 0; +end; + +end. diff --git a/Sources/iOS_Device/Demos/Hello/Project1.dpr b/Sources/iOS_Device/Demos/Hello/Project1.dpr new file mode 100644 index 0000000..3ac7d4f --- /dev/null +++ b/Sources/iOS_Device/Demos/Hello/Project1.dpr @@ -0,0 +1,14 @@ +program Project1; + +uses + System.StartUpCopy, + FMX.Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Sources/iOS_Device/Demos/Hello/Project1.dproj b/Sources/iOS_Device/Demos/Hello/Project1.dproj new file mode 100644 index 0000000..01ad9d9 --- /dev/null +++ b/Sources/iOS_Device/Demos/Hello/Project1.dproj @@ -0,0 +1,271 @@ + + + {69F9C8A8-F413-48F1-8B31-6A84FC32AAD6} + 15.2 + FMX + Project1.dpr + True + Debug + iOSDevice + 89 + Application + + + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Cfg_1 + true + true + + + true + Base + true + + + true + true + true + System;Xml;Data;Datasnap;Web;Soap;$(DCC_Namespace) + true + true + true + true + true + true + true + .\$(Platform)\$(Config) + .\$(Platform)\$(Config) + false + false + false + false + false + + + $(BDS)\bin\Artwork\Android\FM_LauncherIcon_36x36.png + true + FireDACSqliteDriver;DBXSqliteDriver;fmx;IndySystem;DBXInterBaseDriver;DataSnapClient;DataSnapCommon;paxcomp_xe5;DataSnapProviderClient;DbxCommonDriver;dbxcds;fmxFireDAC;CustomIPTransport;dsnap;IndyCore;IndyIPCommon;CloudService;FmxTeeUI;FireDACIBDriver;FireDACDBXDriver;bindcompfmx;rtl;dbrtl;DbxClientDriver;FireDACCommon;bindcomp;xmlrtl;ibxpress;IndyProtocols;FireDACCommonDriver;bindengine;soaprtl;bindcompdbx;FMXTee;FireDAC;FireDACDataSnapDriver;inet;RESTComponents;dbexpress;IndyIPClient;$(DCC_UsePackage) + $(BDS)\bin\Artwork\Android\FM_LauncherIcon_72x72.png + $(BDS)\bin\Artwork\Android\FM_LauncherIcon_96x96.png + Debug + $(BDS)\bin\Artwork\Android\FM_LauncherIcon_144x144.png + package=com.embarcadero.$(MSBuildProjectName);label=$(MSBuildProjectName);versionCode=1;versionName=1.0.0;persistent=False;restoreAnyVersion=False;installLocation=preferExternal;largeHeap=False;theme=TitleBar + $(BDS)\bin\Artwork\Android\FM_LauncherIcon_48x48.png + + + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_768x1004.png + iPhoneAndiPad + $(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_40x40.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImage_640x1136.png + $(MSBuildProjectName) + $(BDS)\bin\Artwork\iOS\iPad\FM_SettingIcon_58x58.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_1024x748.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SettingIcon_29x29.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_60x60.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_50x50.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_80x80.png + FireDACSqliteDriver;DBXSqliteDriver;fmx;IndySystem;DBXInterBaseDriver;DataSnapClient;DataSnapCommon;DataSnapProviderClient;DbxCommonDriver;dbxcds;fmxFireDAC;CustomIPTransport;dsnap;fmxase;IndyCore;IndyIPCommon;CloudService;FmxTeeUI;FireDACIBDriver;FireDACDBXDriver;bindcompfmx;rtl;dbrtl;DbxClientDriver;FireDACCommon;bindcomp;xmlrtl;ibxpress;IndyProtocols;FireDACCommonDriver;bindengine;soaprtl;bindcompdbx;FMXTee;FireDAC;FireDACDataSnapDriver;inet;RESTComponents;dbexpress;IndyIPClient;$(DCC_UsePackage) + $(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_40x40.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImage_640x960.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_57x57.png + $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_72x72.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImage_320x480.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_1024x768.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_80x80.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_58x58.png + $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_152x152.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_1536x2008.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_2048x1496.png + $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_76x76.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_768x1024.png + Debug + $(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_29x29.png + $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_144x144.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_2048x1536.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_100x100.png + true + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_1536x2048.png + CFBundleName=$(MSBuildProjectName);CFBundleDevelopmentRegion=en;CFBundleDisplayName=$(MSBuildProjectName);CFBundleIdentifier=$(MSBuildProjectName);CFBundleInfoDictionaryVersion=6.0;CFBundleVersion=1.0.0.0;CFBundlePackageType=APPL;CFBundleSignature=????;LSRequiresIPhoneOS=true;CFBundleAllowMixedLocalizations=YES;CFBundleExecutable=$(MSBuildProjectName);UIDeviceFamily=iPhone & iPad;CFBundleResourceSpecification=ResourceRules.plist + $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_114x114.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_120x120.png + + + $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImage_640x1136.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_768x1004.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_60x60.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_40x40.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SettingIcon_29x29.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SettingIcon_58x58.png + iPhoneAndiPad + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_1024x748.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_50x50.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_80x80.png + FireDACSqliteDriver;DBXSqliteDriver;fmx;IndySystem;DBXInterBaseDriver;DataSnapClient;DataSnapCommon;DataSnapProviderClient;DbxCommonDriver;dbxcds;fmxFireDAC;CustomIPTransport;dsnap;fmxase;IndyCore;IndyIPCommon;CloudService;FmxTeeUI;FireDACIBDriver;FireDACDBXDriver;bindcompfmx;rtl;dbrtl;DbxClientDriver;FireDACCommon;bindcomp;xmlrtl;ibxpress;IndyProtocols;FireDACCommonDriver;bindengine;soaprtl;bindcompdbx;FMXTee;FireDAC;FireDACDataSnapDriver;inet;RESTComponents;dbexpress;IndyIPClient;$(DCC_UsePackage) + $(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_40x40.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImage_640x960.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_57x57.png + $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_72x72.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImage_320x480.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_1024x768.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_1536x2008.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_80x80.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_29x29.png + $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_152x152.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_2048x1496.png + $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_76x76.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_58x58.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_768x1024.png + $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_144x144.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_2048x1536.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_100x100.png + true + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_1536x2048.png + CFBundleName=$(MSBuildProjectName);CFBundleDevelopmentRegion=en;CFBundleDisplayName=$(MSBuildProjectName);CFBundleIdentifier=$(MSBuildProjectName);CFBundleInfoDictionaryVersion=6.0;CFBundleVersion=1.0.0.0;CFBundlePackageType=APPL;CFBundleSignature=????;LSRequiresIPhoneOS=true;CFBundleAllowMixedLocalizations=YES;CFBundleExecutable=$(MSBuildProjectName);UIDeviceFamily=iPhone & iPad;CFBundleResourceSpecification=ResourceRules.plist + $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_114x114.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_120x120.png + + + true + 1033 + FireDACSqliteDriver;DBXSqliteDriver;FireDACPgDriver;fmx;IndySystem;TeeDB;frx19;vclib;inetdbbde;DBXInterBaseDriver;DataSnapClient;DataSnapCommon;DataSnapServer;paxcomp_xe5;DataSnapProviderClient;DBXSybaseASEDriver;DbxCommonDriver;vclimg;dbxcds;DatasnapConnectorsFreePascal;MetropolisUILiveTile;vcldb;vcldsnap;fmxFireDAC;DBXDb2Driver;DBXOracleDriver;CustomIPTransport;vclribbon;dsnap;IndyIPServer;fmxase;vcl;IndyCore;IndyIPCommon;CloudService;DBXMSSQLDriver;FmxTeeUI;FireDACIBDriver;CodeSiteExpressPkg;FireDACDBXDriver;inetdbxpress;webdsnap;frxe19;FireDACDb2Driver;adortl;frxDB19;FireDACASADriver;bindcompfmx;vcldbx;FireDACODBCDriver;rtl;dbrtl;DbxClientDriver;FireDACCommon;bindcomp;inetdb;Tee;DBXOdbcDriver;vclFireDAC;xmlrtl;svnui;ibxpress;IndyProtocols;DBXMySQLDriver;FireDACCommonDriver;bindengine;vclactnband;soaprtl;bindcompdbx;FMXTee;TeeUI;bindcompvcl;vclie;FireDACADSDriver;vcltouch;VclSmp;FireDACMSSQLDriver;FireDAC;VCLRESTComponents;Intraweb;DBXInformixDriver;DataSnapConnectors;FireDACDataSnapDriver;dsnapcon;DBXFirebirdDriver;inet;fmxobj;FireDACMySQLDriver;vclx;svn;DBXSybaseASADriver;FireDACOracleDriver;fmxdae;RESTComponents;bdertl;FireDACMSAccDriver;DataSnapIndy10ServerTransport;dbexpress;IndyIPClient;$(DCC_UsePackage) + $(BDS)\bin\default_app.manifest + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments= + Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) + + + DEBUG;$(DCC_Define) + true + false + true + true + true + + + false + + + false + RELEASE;$(DCC_Define) + 0 + 0 + + + + MainSource + + +
Form1
+ fmx + + + Cfg_2 + Base + + + Base + + + Cfg_1 + Base + + + + Delphi.Personality.12 + + + + + False + False + 1 + 0 + 0 + 0 + False + False + False + False + False + 1033 + 1252 + + + + + 1.0.0.0 + + + + + + 1.0.0.0 + + + + + + + + + + + + + + + + + + + + + + + + + + + Project1.dpr + + + + + True + True + True + True + + + 12 + + + + diff --git a/Sources/iOS_Device/Demos/Hello/Project1.res b/Sources/iOS_Device/Demos/Hello/Project1.res new file mode 100644 index 0000000..5e7322a Binary files /dev/null and b/Sources/iOS_Device/Demos/Hello/Project1.res differ diff --git a/Sources/iOS_Device/Demos/Hello/Unit1.fmx b/Sources/iOS_Device/Demos/Hello/Unit1.fmx new file mode 100644 index 0000000..e84e972 --- /dev/null +++ b/Sources/iOS_Device/Demos/Hello/Unit1.fmx @@ -0,0 +1,50 @@ +object Form1: TForm1 + Left = 0 + Top = 0 + Caption = 'Form1' + ClientHeight = 567 + ClientWidth = 384 + FormFactor.Width = 320 + FormFactor.Height = 480 + FormFactor.Devices = [dkDesktop] + DesignerMobile = True + DesignerWidth = 384 + DesignerHeight = 592 + DesignerDeviceName = 'Google Nexus 4' + DesignerOrientation = 0 + DesignerOSVersion = '' + object Button1: TButton + Height = 44.000000000000000000 + Position.X = 16.000000000000000000 + Position.Y = 16.000000000000000000 + TabOrder = 0 + Text = 'Say Hello' + Trimming = ttCharacter + Width = 145.000000000000000000 + OnClick = Button1Click + end + object Memo1: TMemo + Touch.InteractiveGestures = [igPan, igLongTap, igDoubleTap] + Height = 129.000000000000000000 + Position.X = 16.000000000000000000 + Position.Y = 160.000000000000000000 + TabOrder = 1 + Width = 265.000000000000000000 + Lines.Strings = ( + 'uses Unit1;' + 'begin' + ' Form1.Button1.Text := '#39'Hello'#39';' + 'end.' + '') + end + object Button2: TButton + Height = 44.000000000000000000 + Position.X = 200.000000000000000000 + Position.Y = 16.000000000000000000 + TabOrder = 2 + Text = 'Exit' + Trimming = ttCharacter + Width = 73.000000000000000000 + OnClick = Button2Click + end +end diff --git a/Sources/iOS_Device/Demos/Hello/Unit1.pas b/Sources/iOS_Device/Demos/Hello/Unit1.pas new file mode 100644 index 0000000..963804a --- /dev/null +++ b/Sources/iOS_Device/Demos/Hello/Unit1.pas @@ -0,0 +1,94 @@ +unit Unit1; + +interface + +uses + System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants, + FMX.StdCtrls, + FMX.Memo, + FMX.Types, FMX.Controls, FMX.Forms, FMX.Graphics, FMX.Dialogs, + FMX.Layouts, +{$IFDEF ANDROID} + FMX.Platform.Android, +{$ENDIF} + PaxCompiler, PaxRunner, PaxInterpreter; + +type + TForm1 = class(TForm) + Button1: TButton; + Memo1: TMemo; + Button2: TButton; + procedure Button1Click(Sender: TObject); + procedure Button2Click(Sender: TObject); + private + { Private declarations } + procedure DoImportGlobalMembers(Sender: TPaxCompiler); + function DoUsedUnit(Sender: TPaxCompiler; + const UnitName: string; var SourceCode: string): Boolean; + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.fmx} + +procedure TForm1.Button2Click(Sender: TObject); +begin +{$IFDEF ANDROID} + MainActivity.finish; +{$ELSE} + Close; +{$ENDIF} +end; + +procedure TForm1.DoImportGlobalMembers(Sender: TPaxCompiler); +begin +// Global members must be imported explicitly. + + Sender.RegisterVariable(0, 'Form1: TForm1', @Form1); +end; + +function TForm1.DoUsedUnit(Sender: TPaxCompiler; + const UnitName: string; var SourceCode: string): Boolean; +begin +// Use OnUsedUnit event to prevent loading Unit1.pas from disk. +// We are going to import types of Unit1.pas, not to compile the unit. + result := false; +end; + +procedure TForm1.Button1Click(Sender: TObject); +var + PaxCompiler1: TPaxCompiler; + PaxInterpreter1: TPaxInterpreter; + PaxPascalLanguage1: TPaxPascalLanguage; +begin + PaxCompiler1 := TPaxCompiler.Create(nil); + PaxInterpreter1 := TPaxInterpreter.Create(nil); + PaxPascalLanguage1 := TPaxPascalLanguage.Create(nil); + try + PaxCompiler1.OnImportGlobalMembers := DoImportGlobalMembers; + PaxCompiler1.OnUsedUnit := DoUsedUnit; + + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + PaxCompiler1.AddModule('1', 'Pascal'); + PaxCompiler1.AddCode('1', Memo1.Lines.Text); + if PaxCompiler1.Compile(PaxInterpreter1) then + begin + PaxInterpreter1.Run; + end + else + begin + ShowMessage(PaxCompiler1.ErrorMessage[0]); + end; + finally + FreeAndNil(PaxCompiler1); + FreeAndNil(PaxInterpreter1); + FreeAndNil(PaxPascalLanguage1); + end; +end; + +end. diff --git a/Sources/iOS_Device/Demos/OperatorOverloading/Project1.dpr b/Sources/iOS_Device/Demos/OperatorOverloading/Project1.dpr new file mode 100644 index 0000000..3ac7d4f --- /dev/null +++ b/Sources/iOS_Device/Demos/OperatorOverloading/Project1.dpr @@ -0,0 +1,14 @@ +program Project1; + +uses + System.StartUpCopy, + FMX.Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Sources/iOS_Device/Demos/OperatorOverloading/Project1.dproj b/Sources/iOS_Device/Demos/OperatorOverloading/Project1.dproj new file mode 100644 index 0000000..ad3f87c --- /dev/null +++ b/Sources/iOS_Device/Demos/OperatorOverloading/Project1.dproj @@ -0,0 +1,271 @@ + + + {C55C11A6-3E14-4B9B-9595-24B90ECB6C08} + 15.2 + FMX + Project1.dpr + True + Debug + iOSDevice + 89 + Application + + + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Cfg_1 + true + true + + + true + Base + true + + + true + true + true + System;Xml;Data;Datasnap;Web;Soap;$(DCC_Namespace) + true + true + true + true + true + true + true + .\$(Platform)\$(Config) + .\$(Platform)\$(Config) + false + false + false + false + false + + + $(BDS)\bin\Artwork\Android\FM_LauncherIcon_36x36.png + true + FireDACSqliteDriver;DBXSqliteDriver;fmx;IndySystem;DBXInterBaseDriver;DataSnapClient;DataSnapCommon;paxcomp_xe5;DataSnapProviderClient;DbxCommonDriver;dbxcds;fmxFireDAC;CustomIPTransport;dsnap;IndyCore;IndyIPCommon;CloudService;FmxTeeUI;FireDACIBDriver;FireDACDBXDriver;bindcompfmx;rtl;dbrtl;DbxClientDriver;FireDACCommon;bindcomp;xmlrtl;ibxpress;IndyProtocols;FireDACCommonDriver;bindengine;soaprtl;bindcompdbx;FMXTee;FireDAC;FireDACDataSnapDriver;inet;RESTComponents;dbexpress;IndyIPClient;$(DCC_UsePackage) + $(BDS)\bin\Artwork\Android\FM_LauncherIcon_72x72.png + $(BDS)\bin\Artwork\Android\FM_LauncherIcon_96x96.png + Debug + $(BDS)\bin\Artwork\Android\FM_LauncherIcon_144x144.png + package=com.embarcadero.$(MSBuildProjectName);label=$(MSBuildProjectName);versionCode=1;versionName=1.0.0;persistent=False;restoreAnyVersion=False;installLocation=preferExternal;largeHeap=False;theme=TitleBar + $(BDS)\bin\Artwork\Android\FM_LauncherIcon_48x48.png + + + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_768x1004.png + iPhoneAndiPad + $(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_40x40.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImage_640x1136.png + $(MSBuildProjectName) + $(BDS)\bin\Artwork\iOS\iPad\FM_SettingIcon_58x58.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_1024x748.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SettingIcon_29x29.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_60x60.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_50x50.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_80x80.png + FireDACSqliteDriver;DBXSqliteDriver;fmx;IndySystem;DBXInterBaseDriver;DataSnapClient;DataSnapCommon;DataSnapProviderClient;DbxCommonDriver;dbxcds;fmxFireDAC;CustomIPTransport;dsnap;fmxase;IndyCore;IndyIPCommon;CloudService;FmxTeeUI;FireDACIBDriver;FireDACDBXDriver;bindcompfmx;rtl;dbrtl;DbxClientDriver;FireDACCommon;bindcomp;xmlrtl;ibxpress;IndyProtocols;FireDACCommonDriver;bindengine;soaprtl;bindcompdbx;FMXTee;FireDAC;FireDACDataSnapDriver;inet;RESTComponents;dbexpress;IndyIPClient;$(DCC_UsePackage) + $(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_40x40.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImage_640x960.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_57x57.png + $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_72x72.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImage_320x480.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_1024x768.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_80x80.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_58x58.png + $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_152x152.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_1536x2008.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_2048x1496.png + $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_76x76.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_768x1024.png + Debug + $(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_29x29.png + $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_144x144.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_2048x1536.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_100x100.png + true + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_1536x2048.png + CFBundleName=$(MSBuildProjectName);CFBundleDevelopmentRegion=en;CFBundleDisplayName=$(MSBuildProjectName);CFBundleIdentifier=$(MSBuildProjectName);CFBundleInfoDictionaryVersion=6.0;CFBundleVersion=1.0.0.0;CFBundlePackageType=APPL;CFBundleSignature=????;LSRequiresIPhoneOS=true;CFBundleAllowMixedLocalizations=YES;CFBundleExecutable=$(MSBuildProjectName);UIDeviceFamily=iPhone & iPad;CFBundleResourceSpecification=ResourceRules.plist + $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_114x114.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_120x120.png + + + $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImage_640x1136.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_768x1004.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_60x60.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_40x40.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SettingIcon_29x29.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SettingIcon_58x58.png + iPhoneAndiPad + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_1024x748.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_50x50.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_80x80.png + FireDACSqliteDriver;DBXSqliteDriver;fmx;IndySystem;DBXInterBaseDriver;DataSnapClient;DataSnapCommon;DataSnapProviderClient;DbxCommonDriver;dbxcds;fmxFireDAC;CustomIPTransport;dsnap;fmxase;IndyCore;IndyIPCommon;CloudService;FmxTeeUI;FireDACIBDriver;FireDACDBXDriver;bindcompfmx;rtl;dbrtl;DbxClientDriver;FireDACCommon;bindcomp;xmlrtl;ibxpress;IndyProtocols;FireDACCommonDriver;bindengine;soaprtl;bindcompdbx;FMXTee;FireDAC;FireDACDataSnapDriver;inet;RESTComponents;dbexpress;IndyIPClient;$(DCC_UsePackage) + $(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_40x40.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImage_640x960.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_57x57.png + $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_72x72.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImage_320x480.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_1024x768.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_1536x2008.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_80x80.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_29x29.png + $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_152x152.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_2048x1496.png + $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_76x76.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_58x58.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_768x1024.png + $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_144x144.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_2048x1536.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_100x100.png + true + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_1536x2048.png + CFBundleName=$(MSBuildProjectName);CFBundleDevelopmentRegion=en;CFBundleDisplayName=$(MSBuildProjectName);CFBundleIdentifier=$(MSBuildProjectName);CFBundleInfoDictionaryVersion=6.0;CFBundleVersion=1.0.0.0;CFBundlePackageType=APPL;CFBundleSignature=????;LSRequiresIPhoneOS=true;CFBundleAllowMixedLocalizations=YES;CFBundleExecutable=$(MSBuildProjectName);UIDeviceFamily=iPhone & iPad;CFBundleResourceSpecification=ResourceRules.plist + $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_114x114.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_120x120.png + + + true + 1033 + FireDACSqliteDriver;DBXSqliteDriver;FireDACPgDriver;fmx;IndySystem;TeeDB;frx19;vclib;inetdbbde;DBXInterBaseDriver;DataSnapClient;DataSnapCommon;DataSnapServer;paxcomp_xe5;DataSnapProviderClient;DBXSybaseASEDriver;DbxCommonDriver;vclimg;dbxcds;DatasnapConnectorsFreePascal;MetropolisUILiveTile;vcldb;vcldsnap;fmxFireDAC;DBXDb2Driver;DBXOracleDriver;CustomIPTransport;vclribbon;dsnap;IndyIPServer;fmxase;vcl;IndyCore;IndyIPCommon;CloudService;DBXMSSQLDriver;FmxTeeUI;FireDACIBDriver;CodeSiteExpressPkg;FireDACDBXDriver;inetdbxpress;webdsnap;frxe19;FireDACDb2Driver;adortl;frxDB19;FireDACASADriver;bindcompfmx;vcldbx;FireDACODBCDriver;rtl;dbrtl;DbxClientDriver;FireDACCommon;bindcomp;inetdb;Tee;DBXOdbcDriver;vclFireDAC;xmlrtl;svnui;ibxpress;IndyProtocols;DBXMySQLDriver;FireDACCommonDriver;bindengine;vclactnband;soaprtl;bindcompdbx;FMXTee;TeeUI;bindcompvcl;vclie;FireDACADSDriver;vcltouch;VclSmp;FireDACMSSQLDriver;FireDAC;VCLRESTComponents;Intraweb;DBXInformixDriver;DataSnapConnectors;FireDACDataSnapDriver;dsnapcon;DBXFirebirdDriver;inet;fmxobj;FireDACMySQLDriver;vclx;svn;DBXSybaseASADriver;FireDACOracleDriver;fmxdae;RESTComponents;bdertl;FireDACMSAccDriver;DataSnapIndy10ServerTransport;dbexpress;IndyIPClient;$(DCC_UsePackage) + $(BDS)\bin\default_app.manifest + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments= + Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) + + + DEBUG;$(DCC_Define) + true + false + true + true + true + + + false + + + false + RELEASE;$(DCC_Define) + 0 + 0 + + + + MainSource + + +
Form1
+ fmx + + + Cfg_2 + Base + + + Base + + + Cfg_1 + Base + + + + Delphi.Personality.12 + + + + + False + False + 1 + 0 + 0 + 0 + False + False + False + False + False + 1033 + 1252 + + + + + 1.0.0.0 + + + + + + 1.0.0.0 + + + + + + + + + + + + + + + + + + + + + + + + + + + Project1.dpr + + + + + True + True + True + True + + + 12 + + + + diff --git a/Sources/iOS_Device/Demos/OperatorOverloading/Project1.res b/Sources/iOS_Device/Demos/OperatorOverloading/Project1.res new file mode 100644 index 0000000..5e7322a Binary files /dev/null and b/Sources/iOS_Device/Demos/OperatorOverloading/Project1.res differ diff --git a/Sources/iOS_Device/Demos/OperatorOverloading/Unit1.fmx b/Sources/iOS_Device/Demos/OperatorOverloading/Unit1.fmx new file mode 100644 index 0000000..a1363ec --- /dev/null +++ b/Sources/iOS_Device/Demos/OperatorOverloading/Unit1.fmx @@ -0,0 +1,69 @@ +object Form1: TForm1 + Left = 0 + Top = 0 + Caption = 'Form1' + ClientHeight = 567 + ClientWidth = 384 + FormFactor.Width = 320 + FormFactor.Height = 480 + FormFactor.Devices = [dkDesktop] + DesignerMobile = True + DesignerWidth = 384 + DesignerHeight = 592 + DesignerDeviceName = 'Google Nexus 4' + DesignerOrientation = 0 + DesignerOSVersion = '' + object Memo1: TMemo + Touch.InteractiveGestures = [igPan, igLongTap, igDoubleTap] + Height = 385.000000000000000000 + Position.X = 24.000000000000000000 + Position.Y = -104.000000000000000000 + TabOrder = 0 + Width = 281.000000000000000000 + Lines.Strings = ( + 'uses Unit1;' + 'var U, V: TMyRecord; I: Integer;' + 'begin' + ' print '#39'Output:'#39';' + ' V := TMyRecord(4); // explicit type cast' + ' I := Integer(V); // explicit type cast' + ' print I;' + ' U := 3; // implicit type cast' + ' V.x := 1;' + ' V.y := 2;' + ' U := U + V; // operation of addition' + ' print U.X, U.Y;' + ' I := V;' + ' print I;' + 'end.' + '') + end + object Button1: TButton + Height = 44.000000000000000000 + Position.X = 16.000000000000000000 + Position.Y = 408.000000000000000000 + TabOrder = 1 + Text = 'Run' + Trimming = ttCharacter + Width = 73.000000000000000000 + OnClick = Button1Click + end + object Memo2: TMemo + Touch.InteractiveGestures = [igPan, igLongTap, igDoubleTap] + Height = 105.000000000000000000 + Position.X = 24.000000000000000000 + Position.Y = 296.000000000000000000 + TabOrder = 2 + Width = 273.000000000000000000 + end + object Button2: TButton + Height = 44.000000000000000000 + Position.X = 104.000000000000000000 + Position.Y = 408.000000000000000000 + TabOrder = 3 + Text = 'Exit' + Trimming = ttCharacter + Width = 73.000000000000000000 + OnClick = Button2Click + end +end diff --git a/Sources/iOS_Device/Demos/OperatorOverloading/Unit1.pas b/Sources/iOS_Device/Demos/OperatorOverloading/Unit1.pas new file mode 100644 index 0000000..96a2e7a --- /dev/null +++ b/Sources/iOS_Device/Demos/OperatorOverloading/Unit1.pas @@ -0,0 +1,145 @@ +unit Unit1; + +interface + +uses + System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants, + FMX.Types, FMX.Controls, FMX.Forms, FMX.Graphics, FMX.Dialogs, FMX.StdCtrls, +{$IFDEF ANDROID} + FMX.Platform.Android, +{$ENDIF} + FMX.Layouts, FMX.Memo, PaxCompiler, PaxRunner, PaxInterpreter; + +type + TForm1 = class(TForm) + Memo1: TMemo; + Button1: TButton; + Memo2: TMemo; + Button2: TButton; + procedure Button1Click(Sender: TObject); + procedure Button2Click(Sender: TObject); + private + { Private declarations } + procedure DoPrint(Sender: TPaxRunner; const S: String); + function DoUsedUnit(Sender: TPaxCompiler; + const UnitName: string; var SourceCode: string): Boolean; + public + { Public declarations } + end; + + TMyRecord = record + x, y: Integer; + class operator Add(a, b: TMyRecord): TMyRecord; + class operator Subtract(a, b: TMyRecord): TMyRecord; + class operator Implicit(a: Integer): TMyRecord; + class operator Implicit(a: TMyRecord): Integer; + class operator Explicit(a: Integer): TMyRecord; + class operator Explicit(a: TMyRecord): Integer; + class operator Explicit(a: TMyRecord): Double; + end; + +var + Form1: TForm1; + +implementation + +{$R *.fmx} + +class operator TMyRecord.Add(a, b: TMyRecord): TMyRecord; +begin + result.x := a.x + b.x; + result.y := a.y + b.y; +end; + +class operator TMyRecord.Subtract(a, b: TMyRecord): TMyRecord; +begin + result.x := a.x - b.x; + result.y := a.y - b.y; +end; + +class operator TMyRecord.Implicit(a: Integer): TMyRecord; +begin + result.x := a; + result.y := 0; +end; + +class operator TMyRecord.Implicit(a: TMyRecord): Integer; +begin + result := a.x; +end; + +class operator TMyRecord.Explicit(a: Integer): TMyRecord; +begin + result.x := a; + result.y := 0; +end; + +class operator TMyRecord.Explicit(a: TMyRecord): Integer; +begin + result := a.x; +end; + +class operator TMyRecord.Explicit(a: TMyRecord): Double; +begin + result := a.x; +end; + +procedure TForm1.Button2Click(Sender: TObject); +begin +{$IFDEF ANDROID} + MainActivity.finish; +{$ELSE} + Close; +{$ENDIF} +end; + +procedure TForm1.DoPrint(Sender: TPaxRunner; const S: String); +begin + Memo2.Lines.Add(S); +end; + +procedure Dummy(P: Pointer); begin end; + +function TForm1.DoUsedUnit(Sender: TPaxCompiler; + const UnitName: string; var SourceCode: string): Boolean; +begin +// Use OnUsedUnit event to prevent loading Unit1.pas from disk. +// We are going to import types of Unit1.pas, not to compile the unit. + result := false; +end; + +procedure TForm1.Button1Click(Sender: TObject); +var + PaxCompiler1: TPaxCompiler; + PaxInterpreter1: TPaxInterpreter; + PaxPascalLanguage1: TPaxPascalLanguage; +begin + Dummy(TypeInfo(TMyRecord)); // just to punish Delphi to create RTTI for TMyRecord + + PaxCompiler1 := TPaxCompiler.Create(nil); + PaxInterpreter1 := TPaxInterpreter.Create(nil); + PaxPascalLanguage1 := TPaxPascalLanguage.Create(nil); + + PaxCompiler1.OnUsedUnit := DoUsedUnit; + + try + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + PaxCompiler1.AddModule('1', 'Pascal'); + PaxCompiler1.AddCode('1', Memo1.Lines.Text); + if PaxCompiler1.Compile(PaxInterpreter1) then + begin + PaxInterpreter1.OnPrintEvent := DoPrint; + PaxInterpreter1.Run; + end + else + begin + ShowMessage(PaxCompiler1.ErrorMessage[0]); + end; + finally + FreeAndNil(PaxCompiler1); + FreeAndNil(PaxInterpreter1); + FreeAndNil(PaxPascalLanguage1); + end; +end; + +end. diff --git a/Sources/iOS_Device/Demos/ScriptClass/Project1.dpr b/Sources/iOS_Device/Demos/ScriptClass/Project1.dpr new file mode 100644 index 0000000..3ac7d4f --- /dev/null +++ b/Sources/iOS_Device/Demos/ScriptClass/Project1.dpr @@ -0,0 +1,14 @@ +program Project1; + +uses + System.StartUpCopy, + FMX.Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Sources/iOS_Device/Demos/ScriptClass/Project1.dproj b/Sources/iOS_Device/Demos/ScriptClass/Project1.dproj new file mode 100644 index 0000000..98c3d76 --- /dev/null +++ b/Sources/iOS_Device/Demos/ScriptClass/Project1.dproj @@ -0,0 +1,247 @@ + + + {90EBE9AB-475B-4547-B828-69AF52A85794} + 15.1 + FMX + Project1.dpr + True + Debug + iOSDevice + 89 + Application + + + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Cfg_1 + true + true + + + true + Base + true + + + true + true + System;Xml;Data;Datasnap;Web;Soap;$(DCC_Namespace) + true + true + true + true + true + true + true + true + .\$(Platform)\$(Config) + .\$(Platform)\$(Config) + false + false + false + false + false + + + $(BDS)\bin\Artwork\Android\FM_LauncherIcon_72x72.png + $(BDS)\bin\Artwork\Android\FM_LauncherIcon_36x36.png + FireDACSqliteDriver;bindcompfmx;DBXSqliteDriver;fmx;rtl;dbrtl;DbxClientDriver;IndySystem;FireDACCommon;bindcomp;DBXInterBaseDriver;DataSnapClient;DataSnapCommon;paxcomp_xe5;DataSnapProviderClient;xmlrtl;ibxpress;DbxCommonDriver;IndyProtocols;dbxcds;FireDACCommonDriver;bindengine;soaprtl;bindcompdbx;FMXTee;fmxFireDAC;CustomIPTransport;FireDAC;dsnap;IndyCore;FireDACDataSnapDriver;IndyIPCommon;CloudService;FireDACIBDriver;inet;FireDACDBXDriver;FmxTeeUI;RESTComponents;dbexpress;IndyIPClient;$(DCC_UsePackage) + $(BDS)\bin\Artwork\Android\FM_LauncherIcon_48x48.png + $(BDS)\bin\Artwork\Android\FM_LauncherIcon_96x96.png + $(BDS)\bin\Artwork\Android\FM_LauncherIcon_144x144.png + true + package=com.embarcadero.$(MSBuildProjectName);label=$(MSBuildProjectName);versionCode=1;versionName=1.0.0;persistent=False;restoreAnyVersion=False;installLocation=preferExternal;largeHeap=False;theme=TitleBar + Debug + + + FireDACSqliteDriver;bindcompfmx;DBXSqliteDriver;fmx;rtl;dbrtl;DbxClientDriver;IndySystem;FireDACCommon;bindcomp;DBXInterBaseDriver;DataSnapClient;DataSnapCommon;DataSnapProviderClient;xmlrtl;ibxpress;DbxCommonDriver;IndyProtocols;dbxcds;FireDACCommonDriver;bindengine;soaprtl;bindcompdbx;FMXTee;fmxFireDAC;CustomIPTransport;FireDAC;dsnap;fmxase;IndyCore;FireDACDataSnapDriver;IndyIPCommon;CloudService;FireDACIBDriver;inet;FireDACDBXDriver;FmxTeeUI;RESTComponents;dbexpress;IndyIPClient;$(DCC_UsePackage) + $(BDS)\bin\Artwork\iOS\iPad\FM_SettingIcon_58x58.png + iPhoneAndiPad + $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_72x72.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImage_640x1136.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_114x114.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_1024x748.png + $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_144x144.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_58x58.png + $(MSBuildProjectName) + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_2048x1496.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_100x100.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SettingIcon_29x29.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_50x50.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_768x1004.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_1536x2008.png + true + Debug + $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImage_640x960.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImage_320x480.png + CFBundleName=$(MSBuildProjectName);CFBundleDevelopmentRegion=en;CFBundleDisplayName=$(MSBuildProjectName);CFBundleIdentifier=$(MSBuildProjectName);CFBundleInfoDictionaryVersion=6.0;CFBundleVersion=1.0.0.0;CFBundlePackageType=APPL;CFBundleSignature=????;LSRequiresIPhoneOS=true;CFBundleAllowMixedLocalizations=YES;CFBundleExecutable=$(MSBuildProjectName);UIDeviceFamily=iPhone & iPad;CFBundleResourceSpecification=ResourceRules.plist + $(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_29x29.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_57x57.png + + + FireDACSqliteDriver;bindcompfmx;DBXSqliteDriver;fmx;rtl;dbrtl;DbxClientDriver;IndySystem;FireDACCommon;bindcomp;DBXInterBaseDriver;DataSnapClient;DataSnapCommon;DataSnapProviderClient;xmlrtl;ibxpress;DbxCommonDriver;IndyProtocols;dbxcds;FireDACCommonDriver;bindengine;soaprtl;bindcompdbx;FMXTee;fmxFireDAC;CustomIPTransport;FireDAC;dsnap;fmxase;IndyCore;FireDACDataSnapDriver;IndyIPCommon;CloudService;FireDACIBDriver;inet;FireDACDBXDriver;FmxTeeUI;RESTComponents;dbexpress;IndyIPClient;$(DCC_UsePackage) + $(BDS)\bin\Artwork\iOS\iPad\FM_SettingIcon_58x58.png + iPhoneAndiPad + $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_72x72.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImage_640x1136.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_1024x748.png + $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_144x144.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_58x58.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_114x114.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_2048x1496.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_100x100.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SettingIcon_29x29.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_50x50.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_768x1004.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_1536x2008.png + true + $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImage_640x960.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImage_320x480.png + CFBundleName=$(MSBuildProjectName);CFBundleDevelopmentRegion=en;CFBundleDisplayName=$(MSBuildProjectName);CFBundleIdentifier=$(MSBuildProjectName);CFBundleInfoDictionaryVersion=6.0;CFBundleVersion=1.0.0.0;CFBundlePackageType=APPL;CFBundleSignature=????;LSRequiresIPhoneOS=true;CFBundleAllowMixedLocalizations=YES;CFBundleExecutable=$(MSBuildProjectName);UIDeviceFamily=iPhone & iPad;CFBundleResourceSpecification=ResourceRules.plist + $(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_29x29.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_57x57.png + + + $(BDS)\bin\default_app.manifest + Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) + 1033 + true + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments= + DataSnapIndy10ServerTransport;FireDACASADriver;FireDACSqliteDriver;bindcompfmx;DBXSqliteDriver;vcldbx;FireDACPgDriver;FireDACODBCDriver;fmx;rtl;dbrtl;DbxClientDriver;IndySystem;FireDACCommon;bindcomp;inetdb;TeeDB;vclib;inetdbbde;DBXInterBaseDriver;DataSnapClient;DataSnapCommon;DBXOdbcDriver;DataSnapServer;Tee;vclFireDAC;paxcomp_xe5;DataSnapProviderClient;xmlrtl;svnui;ibxpress;DbxCommonDriver;DBXSybaseASEDriver;vclimg;IndyProtocols;dbxcds;DBXMySQLDriver;DatasnapConnectorsFreePascal;FireDACCommonDriver;MetropolisUILiveTile;bindengine;vclactnband;vcldb;soaprtl;bindcompdbx;vcldsnap;bindcompvcl;FMXTee;TeeUI;vclie;fmxFireDAC;FireDACADSDriver;vcltouch;DBXDb2Driver;DBXOracleDriver;CustomIPTransport;vclribbon;VclSmp;FireDACMSSQLDriver;FireDAC;dsnap;Intraweb;fmxase;vcl;IndyCore;FireDACDataSnapDriver;IndyIPServer;IndyIPCommon;VCLRESTComponents;CloudService;dsnapcon;FireDACIBDriver;DBXFirebirdDriver;inet;DBXMSSQLDriver;fmxobj;FireDACDBXDriver;DBXInformixDriver;DataSnapConnectors;FireDACMySQLDriver;FmxTeeUI;vclx;CodeSiteExpressPkg;inetdbxpress;svn;DBXSybaseASADriver;FireDACOracleDriver;fmxdae;FireDACDb2Driver;RESTComponents;bdertl;FireDACMSAccDriver;adortl;dbexpress;IndyIPClient;$(DCC_UsePackage) + + + DEBUG;$(DCC_Define) + true + false + true + true + true + + + false + + + false + RELEASE;$(DCC_Define) + 0 + 0 + + + + MainSource + + +
Form1
+ fmx + + + Cfg_2 + Base + + + Base + + + Cfg_1 + Base + + + + Delphi.Personality.12 + + + + + False + False + 1 + 0 + 0 + 0 + False + False + False + False + False + 1033 + 1252 + + + + + 1.0.0.0 + + + + + + 1.0.0.0 + + + + + + + + + + + + + + + + + + + + + + + + + + + Project1.dpr + + + + + True + True + True + True + + + 12 + + + + diff --git a/Sources/iOS_Device/Demos/ScriptClass/Project1.res b/Sources/iOS_Device/Demos/ScriptClass/Project1.res new file mode 100644 index 0000000..0739f2f Binary files /dev/null and b/Sources/iOS_Device/Demos/ScriptClass/Project1.res differ diff --git a/Sources/iOS_Device/Demos/ScriptClass/Unit1.fmx b/Sources/iOS_Device/Demos/ScriptClass/Unit1.fmx new file mode 100644 index 0000000..753f655 --- /dev/null +++ b/Sources/iOS_Device/Demos/ScriptClass/Unit1.fmx @@ -0,0 +1,76 @@ +object Form1: TForm1 + Left = 0 + Top = 0 + Caption = 'Form2' + ClientHeight = 567 + ClientWidth = 384 + FormFactor.Width = 320 + FormFactor.Height = 480 + FormFactor.Devices = [dkDesktop] + DesignerMobile = True + DesignerWidth = 384 + DesignerHeight = 592 + DesignerDeviceName = 'Google Nexus 4' + DesignerOrientation = 0 + DesignerOSVersion = '' + object Memo1: TMemo + Touch.InteractiveGestures = [igPan, igLongTap, igDoubleTap] + Height = 225.000000000000000000 + Position.X = 8.000000000000000000 + Position.Y = 8.000000000000000000 + TabOrder = 0 + Width = 281.000000000000000000 + Lines.Strings = ( + 'uses' + ' Unit1;' + 'type' + ' TScriptClass = class(TMyClass)' + ' public' + ' procedure P(X, Y: Integer); override;' + ' end;' + 'procedure TScriptClass.P(X, Y: Integer);' + 'begin' + ' print X, Y;' + 'end;' + 'var' + ' I: Integer;' + ' X: TMyClass;' + 'begin' + '// Test global variable' + ' print Form1.ClassName;' + '// Test global procedure' + ' IntegerByRef(I);' + ' print I;' + ' X := TScriptClass.Create;' + ' X.P(3, 4);' + 'end.') + end + object Memo2: TMemo + Touch.InteractiveGestures = [igPan, igLongTap, igDoubleTap] + Height = 106.000000000000000000 + Position.X = 8.000000000000000000 + Position.Y = 240.000000000000000000 + TabOrder = 1 + Width = 281.000000000000000000 + end + object Button1: TButton + Height = 44.000000000000000000 + Position.X = 8.000000000000000000 + Position.Y = 368.000000000000000000 + TabOrder = 2 + Text = 'Run ' + Trimming = ttCharacter + Width = 73.000000000000000000 + OnClick = Button1Click + end + object Button2: TButton + Height = 44.000000000000000000 + Position.X = 104.000000000000000000 + Position.Y = 368.000000000000000000 + TabOrder = 3 + Text = 'Exit' + Trimming = ttCharacter + Width = 73.000000000000000000 + OnClick = Button2Click + end +end diff --git a/Sources/iOS_Device/Demos/ScriptClass/Unit1.pas b/Sources/iOS_Device/Demos/ScriptClass/Unit1.pas new file mode 100644 index 0000000..d9c697e --- /dev/null +++ b/Sources/iOS_Device/Demos/ScriptClass/Unit1.pas @@ -0,0 +1,123 @@ +unit Unit1; + +interface + +uses + System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants, +{$IFDEF ANDROID} + FMX.Platform.Android, +{$ENDIF} + FMX.Types, FMX.Controls, FMX.Forms, FMX.Graphics, FMX.Dialogs, FMX.StdCtrls, + FMX.Layouts, FMX.Memo, + PaxCompiler, PaxRunner, PaxInterpreter; + +type + TForm1 = class(TForm) + Memo1: TMemo; + Memo2: TMemo; + Button1: TButton; + Button2: TButton; + procedure Button2Click(Sender: TObject); + procedure Button1Click(Sender: TObject); + private + { Private declarations } + procedure DoImportGlobalMembers(Sender: TPaxCompiler); + function DoUsedUnit(Sender: TPaxCompiler; + const UnitName: string; var SourceCode: string): Boolean; + procedure DoPrint(Sender: TPaxRunner; const S: String); + public + { Public declarations } + end; + + {$M+} + TMyClass = class + public + procedure P(X, Y: Integer); virtual; abstract; + destructor Destroy; override; + end; + +var + Form1: TForm1; + +implementation + +{$R *.fmx} + +destructor TMyClass.Destroy; +begin + Form1.Memo2.Lines.Add('*** Done ***'); + inherited; +end; + + +procedure IntegerByRef(var I: Integer); +begin + I := 5; +end; + +procedure TForm1.DoImportGlobalMembers(Sender: TPaxCompiler); +begin +// Global members must be imported explicitly. + + Sender.RegisterVariable(0, 'Form1: TForm1', @Form1); + Sender.RegisterHeader(0, + 'procedure IntegerByRef(var I: Integer);', + @ IntegerByRef); +end; + +function TForm1.DoUsedUnit(Sender: TPaxCompiler; + const UnitName: string; var SourceCode: string): Boolean; +begin +// Use OnUsedUnit event to prevent loading Unit1.pas from disk. +// We are going to import types of Unit1.pas, not to compile the unit. + result := false; +end; + +procedure TForm1.DoPrint(Sender: TPaxRunner; const S: String); +begin + Memo2.Lines.Add(S); +end; + +procedure TForm1.Button1Click(Sender: TObject); +var + PaxCompiler1: TPaxCompiler; + PaxInterpreter1: TPaxInterpreter; + PaxLanguage1: TPaxCompilerLanguage; +begin + PaxCompiler1 := TPaxCompiler.Create(nil); + PaxInterpreter1 := TPaxInterpreter.Create(nil); + PaxLanguage1 := TPaxPascalLanguage.Create(nil); + + PaxCompiler1.OnUsedUnit := DoUsedUnit; + PaxCompiler1.OnImportGlobalMembers := DoImportGlobalMembers; + + try + PaxCompiler1.RegisterLanguage(PaxLanguage1); + PaxCompiler1.AddModule('1', 'Pascal'); + PaxCompiler1.AddCode('1', Memo1.Lines.Text); + if PaxCompiler1.Compile(PaxInterpreter1) then + begin + PaxInterpreter1.OnPrintEvent := DoPrint; + PaxInterpreter1.Run; + end + else + begin + ShowMessage(PaxCompiler1.ErrorMessage[0]); + end; + finally + FreeAndNil(PaxCompiler1); + FreeAndNil(PaxInterpreter1); + FreeAndNil(PaxLanguage1); + end; +end; + +procedure TForm1.Button2Click(Sender: TObject); +begin +{$IFDEF ANDROID} + MainActivity.finish; +{$ELSE} + Close; +{$ENDIF} +end; + +end. diff --git a/Sources/iOS_Device/packages/xe5/PaxCompiler.def b/Sources/iOS_Device/packages/xe5/PaxCompiler.def new file mode 100644 index 0000000..6527a1d --- /dev/null +++ b/Sources/iOS_Device/packages/xe5/PaxCompiler.def @@ -0,0 +1,160 @@ +// {$define TRIAL} +{$O-} + +//{$DEFINE EXPLICIT_OFF} + +{$IFDEF MACOS} + {$DEFINE INTERPRETER_ONLY} +{$ENDIF} +{$IFDEF ANDROID} + {$DEFINE INTERPRETER_ONLY} +{$ENDIF} + + +// {$define NO_PARENT_CLASS} + +// {$define FPC} +{$ifdef FPC} + {$IFDEF CPUX64} + {$DEFINE PAX64} + {$ENDIF} + {$ASMMODE intel} + {$DEFINE VARIANTS} + {$MODE DELPHI} + {$DEFINE CPUASM} + {$H+} + {$M+} +{$endif} + +{$M+} + +{$define PCU_EX} +{$define GENERICS} +//{$define HTML} + +// {$DEFINE PAXARM} //////////////////////////////////////!!!!! +// {$DEFINE GENARC} + +{$IFDEF ANDROID} + {$DEFINE PAXARM} + {$DEFINE PAXARM_DEVICE} +{$ENDIF} +{$IFDEF IOS} + {$DEFINE PAXARM} + {$IFNDEF CPUARM} + {$DEFINE IOSIM} + {$ENDIF} + {$IFDEF CPUARM} + {$DEFINE PAXARM_DEVICE} + {$ENDIF} +{$ENDIF} + +{$IFDEF AUTOREFCOUNT} + {$DEFINE ARC} + {$DEFINE GENARC} + {$ZEROBASEDSTRINGS ON} + {$define SZERO} +{$ENDIF} + + +{$define DUMP} +{$ifdef Ver140} + {$define VARIANTS} +{$endif} +{$ifdef Ver150} + {$define VARIANTS} +{$endif} +{$ifdef Ver160} + {$define VARIANTS} +{$endif} +{$ifdef Ver170} + {$define VARIANTS} +{$endif} +{$ifdef Ver180} + {$define VARIANTS} +{$endif} +{$ifdef Ver190} + {$define VARIANTS} +{$endif} +{$ifdef Ver200} + {$define VARIANTS} + {$define UNIC} +{$endif} +{$ifdef Ver210} + {$define VARIANTS} + {$define UNIC} + {$define DRTTI} +{$endif} +{$ifdef Ver220} + {$define VARIANTS} + {$define UNIC} + {$define DRTTI} +{$endif} +{$ifdef Ver230} + {$define VARIANTS} + {$define UNIC} + {$define DRTTI} + {$define DPULSAR} + {$define GE_DXE2} + {$IFDEF CPUX64} + {$DEFINE PAX64} + {$ENDIF} +{$endif} +{$ifdef Ver240} + {$define VARIANTS} + {$define UNIC} + {$define DRTTI} + {$define DPULSAR} + {$define DXE3} + {$define GE_DXE3} + {$define GE_DXE2} + {$IFDEF CPUX64} + {$DEFINE PAX64} + {$ENDIF} +{$endif} +{$ifdef Ver250} + {$define VARIANTS} + {$define UNIC} + {$define DRTTI} + {$define DPULSAR} + {$define DXE4} + {$define GE_DXE2} + {$define GE_DXE3} + {$define GE_DXE4} + {$IFDEF CPUX64} + {$DEFINE PAX64} + {$ENDIF} +{$endif} +{$ifdef Ver260} + {$define VARIANTS} + {$define UNIC} + {$define DRTTI} + {$define DPULSAR} + {$define DXE5} + {$define GE_DXE2} + {$define GE_DXE3} + {$define GE_DXE4} + {$define GE_DXE5} + {$IFDEF CPUX64} + {$DEFINE PAX64} + {$ENDIF} +{$endif} +{$ifdef Ver270} + {$define VARIANTS} + {$define UNIC} + {$define DRTTI} + {$define DPULSAR} + {$define DXE5} + {$define GE_DXE2} + {$define GE_DXE3} + {$define GE_DXE4} + {$define GE_DXE5} + {$define GE_DXE6} + {$IFDEF CPUX64} + {$DEFINE PAX64} + {$ENDIF} +{$endif} + +{$IFNDEF VARIANTS} + {$DEFINE MSWINDOWS} +{$ENDIF} diff --git a/Sources/iOS_Device/packages/xe5/PaxCompilerRegister.pas b/Sources/iOS_Device/packages/xe5/PaxCompilerRegister.pas new file mode 100644 index 0000000..21ef041 --- /dev/null +++ b/Sources/iOS_Device/packages/xe5/PaxCompilerRegister.pas @@ -0,0 +1,52 @@ +//////////////////////////////////////////////////////////////////////////// +// PaxCompiler +// Site: http://www.paxcompiler.com +// Author: Alexander Baranovsky (paxscript@gmail.com) +// ======================================================================== +// Copyright (c) Alexander Baranovsky, 2006-2014. All rights reserved. +// Code Version: 4.0 +// ======================================================================== +// Unit: PaxCompilerRegister.pas +// ======================================================================== +//////////////////////////////////////////////////////////////////////////// + +{$I PaxCompiler.def} +unit PaxCompilerRegister; + +interface +uses + Classes, + PaxCompiler, +{$IFNDEF INTERPRETER_ONLY} + PaxProgram, + PaxInvoke, +{$ENDIF} + PaxInterpreter, + PaxCompilerDebugger, + PaxCompilerExplorer, + PaxBasicLanguage, + PaxJavaScriptLanguage, + PaxEval; + +procedure Register; + +Implementation + +procedure Register; +begin + RegisterComponents('PaxCompiler', + [TPaxCompiler, + TPaxPascalLanguage, +{$IFNDEF INTERPRETER_ONLY} + TPaxProgram, + TPaxInvoke, +{$ENDIF} + TPaxCompilerDebugger, + TPaxCompilerExplorer, + TPaxBasicLanguage, + TPaxJavaScriptLanguage, + TPaxEval, + TPaxInterpreter]); +end; + +end. diff --git a/Sources/iOS_Device/packages/xe5/paxcomp_ios_dev_xe5.dpk b/Sources/iOS_Device/packages/xe5/paxcomp_ios_dev_xe5.dpk new file mode 100644 index 0000000..95f8cea --- /dev/null +++ b/Sources/iOS_Device/packages/xe5/paxcomp_ios_dev_xe5.dpk @@ -0,0 +1,37 @@ +package paxcomp_ios_dev_xe5; + +{$R *.res} +{$R 'paxcompiler.dcr'} +{$IFDEF IMPLICITBUILDING This IFDEF should not be used by users} +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION OFF} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES ON} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$DEFINE DEBUG} +{$ENDIF IMPLICITBUILDING} +{$IMPLICITBUILD ON} + +requires + rtl; + +contains + PaxCompilerRegister in 'PaxCompilerRegister.pas'; + +end. diff --git a/Sources/iOS_Device/packages/xe5/paxcomp_ios_dev_xe5.dproj b/Sources/iOS_Device/packages/xe5/paxcomp_ios_dev_xe5.dproj new file mode 100644 index 0000000..3c319f7 --- /dev/null +++ b/Sources/iOS_Device/packages/xe5/paxcomp_ios_dev_xe5.dproj @@ -0,0 +1,194 @@ + + + {EA298461-5F3D-463D-8ABF-F2FC6DFB250E} + paxcomp_ios_dev_xe5.dpk + 15.1 + None + True + Debug + iOSDevice + 64 + Package + + + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Cfg_1 + true + true + + + true + Base + true + + + System;Xml;Data;Datasnap;Web;Soap;$(DCC_Namespace) + All + true + true + .\$(Platform)\$(Config) + .\$(Platform)\$(Config) + false + false + false + false + false + + + None + + + iPhoneAndiPad + None + true + Debug + CFBundleName=$(MSBuildProjectName);CFBundleDevelopmentRegion=en;CFBundleDisplayName=$(MSBuildProjectName);CFBundleIdentifier=$(MSBuildProjectName);CFBundleInfoDictionaryVersion=6.0;CFBundleVersion=1.0.0.0;CFBundlePackageType=APPL;CFBundleSignature=????;LSRequiresIPhoneOS=true;CFBundleAllowMixedLocalizations=YES;CFBundleExecutable=$(MSBuildProjectName);UIDeviceFamily=iPhone & iPad;CFBundleResourceSpecification=ResourceRules.plist + $(MSBuildProjectName) + + + None + + + Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) + true + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments= + 1033 + + + DEBUG;$(DCC_Define) + true + false + true + true + true + + + false + + + false + RELEASE;$(DCC_Define) + 0 + 0 + + + + MainSource + + + + + + Cfg_2 + Base + + + Base + + + Cfg_1 + Base + + + + Delphi.Personality.12 + Package + + + + paxcomp_ios_dev_xe5.dpk + + + True + False + 1 + 0 + 0 + 0 + False + False + False + False + False + 1033 + 1252 + + + + + 1.0.0.0 + + + + + + 1.0.0.0 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + False + True + False + False + False + False + + + 12 + + + + diff --git a/Sources/iOS_Device/packages/xe5/paxcomp_ios_dev_xe5.res b/Sources/iOS_Device/packages/xe5/paxcomp_ios_dev_xe5.res new file mode 100644 index 0000000..36f26e2 Binary files /dev/null and b/Sources/iOS_Device/packages/xe5/paxcomp_ios_dev_xe5.res differ diff --git a/Sources/iOS_Device/packages/xe5/paxcompiler.dcr b/Sources/iOS_Device/packages/xe5/paxcompiler.dcr new file mode 100644 index 0000000..4bcc339 Binary files /dev/null and b/Sources/iOS_Device/packages/xe5/paxcompiler.dcr differ diff --git a/Sources/iOS_Device/packages/xe5/uses.def b/Sources/iOS_Device/packages/xe5/uses.def new file mode 100644 index 0000000..e4155f2 --- /dev/null +++ b/Sources/iOS_Device/packages/xe5/uses.def @@ -0,0 +1,50 @@ +{$IFDEF MACOS} + {$DEFINE FMX} +{$ENDIF} + +{$IFDEF LINUX} + {$IFDEF FPC} + DynLibs, + uuid, // in hash folder + {$ELSE} + QForms, + {$ENDIF} +{$ENDIF} + +{$IFDEF MSWINDOWS} + {$IFDEF DPULSAR} + Winapi.Windows, + Winapi.Messages, + System.Win.ComObj, + Winapi.ActiveX, + {$IFDEF FMX} + Fmx.Forms, + Fmx.Dialogs, + {$ELSE} + Vcl.Forms, + Vcl.Dialogs, + {$ENDIF} + {$ELSE} + Windows, + Messages, + {$IFNDEF FPC} + Forms, + Dialogs, + {$ENDIF} + ComObj, + ActiveX, + {$ENDIF} +{$ENDIF} + + {$IFDEF MACOS} + Fmx.Forms, + Fmx.Dialogs, + {$ENDIF} + + {$IFDEF VARIANTS} + Variants, + {$ENDIF} + + {$IFDEF ARC} + System.Generics.Collections, + {$ENDIF} diff --git a/Sources/iOS_Device/packages/xe6/PaxCompiler.def b/Sources/iOS_Device/packages/xe6/PaxCompiler.def new file mode 100644 index 0000000..6527a1d --- /dev/null +++ b/Sources/iOS_Device/packages/xe6/PaxCompiler.def @@ -0,0 +1,160 @@ +// {$define TRIAL} +{$O-} + +//{$DEFINE EXPLICIT_OFF} + +{$IFDEF MACOS} + {$DEFINE INTERPRETER_ONLY} +{$ENDIF} +{$IFDEF ANDROID} + {$DEFINE INTERPRETER_ONLY} +{$ENDIF} + + +// {$define NO_PARENT_CLASS} + +// {$define FPC} +{$ifdef FPC} + {$IFDEF CPUX64} + {$DEFINE PAX64} + {$ENDIF} + {$ASMMODE intel} + {$DEFINE VARIANTS} + {$MODE DELPHI} + {$DEFINE CPUASM} + {$H+} + {$M+} +{$endif} + +{$M+} + +{$define PCU_EX} +{$define GENERICS} +//{$define HTML} + +// {$DEFINE PAXARM} //////////////////////////////////////!!!!! +// {$DEFINE GENARC} + +{$IFDEF ANDROID} + {$DEFINE PAXARM} + {$DEFINE PAXARM_DEVICE} +{$ENDIF} +{$IFDEF IOS} + {$DEFINE PAXARM} + {$IFNDEF CPUARM} + {$DEFINE IOSIM} + {$ENDIF} + {$IFDEF CPUARM} + {$DEFINE PAXARM_DEVICE} + {$ENDIF} +{$ENDIF} + +{$IFDEF AUTOREFCOUNT} + {$DEFINE ARC} + {$DEFINE GENARC} + {$ZEROBASEDSTRINGS ON} + {$define SZERO} +{$ENDIF} + + +{$define DUMP} +{$ifdef Ver140} + {$define VARIANTS} +{$endif} +{$ifdef Ver150} + {$define VARIANTS} +{$endif} +{$ifdef Ver160} + {$define VARIANTS} +{$endif} +{$ifdef Ver170} + {$define VARIANTS} +{$endif} +{$ifdef Ver180} + {$define VARIANTS} +{$endif} +{$ifdef Ver190} + {$define VARIANTS} +{$endif} +{$ifdef Ver200} + {$define VARIANTS} + {$define UNIC} +{$endif} +{$ifdef Ver210} + {$define VARIANTS} + {$define UNIC} + {$define DRTTI} +{$endif} +{$ifdef Ver220} + {$define VARIANTS} + {$define UNIC} + {$define DRTTI} +{$endif} +{$ifdef Ver230} + {$define VARIANTS} + {$define UNIC} + {$define DRTTI} + {$define DPULSAR} + {$define GE_DXE2} + {$IFDEF CPUX64} + {$DEFINE PAX64} + {$ENDIF} +{$endif} +{$ifdef Ver240} + {$define VARIANTS} + {$define UNIC} + {$define DRTTI} + {$define DPULSAR} + {$define DXE3} + {$define GE_DXE3} + {$define GE_DXE2} + {$IFDEF CPUX64} + {$DEFINE PAX64} + {$ENDIF} +{$endif} +{$ifdef Ver250} + {$define VARIANTS} + {$define UNIC} + {$define DRTTI} + {$define DPULSAR} + {$define DXE4} + {$define GE_DXE2} + {$define GE_DXE3} + {$define GE_DXE4} + {$IFDEF CPUX64} + {$DEFINE PAX64} + {$ENDIF} +{$endif} +{$ifdef Ver260} + {$define VARIANTS} + {$define UNIC} + {$define DRTTI} + {$define DPULSAR} + {$define DXE5} + {$define GE_DXE2} + {$define GE_DXE3} + {$define GE_DXE4} + {$define GE_DXE5} + {$IFDEF CPUX64} + {$DEFINE PAX64} + {$ENDIF} +{$endif} +{$ifdef Ver270} + {$define VARIANTS} + {$define UNIC} + {$define DRTTI} + {$define DPULSAR} + {$define DXE5} + {$define GE_DXE2} + {$define GE_DXE3} + {$define GE_DXE4} + {$define GE_DXE5} + {$define GE_DXE6} + {$IFDEF CPUX64} + {$DEFINE PAX64} + {$ENDIF} +{$endif} + +{$IFNDEF VARIANTS} + {$DEFINE MSWINDOWS} +{$ENDIF} diff --git a/Sources/iOS_Device/packages/xe6/PaxCompilerRegister.pas b/Sources/iOS_Device/packages/xe6/PaxCompilerRegister.pas new file mode 100644 index 0000000..21ef041 --- /dev/null +++ b/Sources/iOS_Device/packages/xe6/PaxCompilerRegister.pas @@ -0,0 +1,52 @@ +//////////////////////////////////////////////////////////////////////////// +// PaxCompiler +// Site: http://www.paxcompiler.com +// Author: Alexander Baranovsky (paxscript@gmail.com) +// ======================================================================== +// Copyright (c) Alexander Baranovsky, 2006-2014. All rights reserved. +// Code Version: 4.0 +// ======================================================================== +// Unit: PaxCompilerRegister.pas +// ======================================================================== +//////////////////////////////////////////////////////////////////////////// + +{$I PaxCompiler.def} +unit PaxCompilerRegister; + +interface +uses + Classes, + PaxCompiler, +{$IFNDEF INTERPRETER_ONLY} + PaxProgram, + PaxInvoke, +{$ENDIF} + PaxInterpreter, + PaxCompilerDebugger, + PaxCompilerExplorer, + PaxBasicLanguage, + PaxJavaScriptLanguage, + PaxEval; + +procedure Register; + +Implementation + +procedure Register; +begin + RegisterComponents('PaxCompiler', + [TPaxCompiler, + TPaxPascalLanguage, +{$IFNDEF INTERPRETER_ONLY} + TPaxProgram, + TPaxInvoke, +{$ENDIF} + TPaxCompilerDebugger, + TPaxCompilerExplorer, + TPaxBasicLanguage, + TPaxJavaScriptLanguage, + TPaxEval, + TPaxInterpreter]); +end; + +end. diff --git a/Sources/iOS_Device/packages/xe6/paxcomp_ios_dev_xe6.dpk b/Sources/iOS_Device/packages/xe6/paxcomp_ios_dev_xe6.dpk new file mode 100644 index 0000000..8681c0b --- /dev/null +++ b/Sources/iOS_Device/packages/xe6/paxcomp_ios_dev_xe6.dpk @@ -0,0 +1,37 @@ +package paxcomp_ios_dev_xe6; + +{$R *.res} +{$R 'paxcompiler.dcr'} +{$IFDEF IMPLICITBUILDING This IFDEF should not be used by users} +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO OFF} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION OFF} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES ON} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$DEFINE DEBUG} +{$ENDIF IMPLICITBUILDING} +{$IMPLICITBUILD ON} + +requires + rtl; + +contains + PaxCompilerRegister in 'PaxCompilerRegister.pas'; + +end. diff --git a/Sources/iOS_Device/packages/xe6/paxcomp_ios_dev_xe6.dproj b/Sources/iOS_Device/packages/xe6/paxcomp_ios_dev_xe6.dproj new file mode 100644 index 0000000..de63aff --- /dev/null +++ b/Sources/iOS_Device/packages/xe6/paxcomp_ios_dev_xe6.dproj @@ -0,0 +1,133 @@ + + + {309CB9CF-0D9F-43E2-9102-8A4D4755A97D} + paxcomp_ios_dev_xe6.dpk + True + Debug + 64 + Package + None + 15.4 + iOSDevice + + + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Cfg_2 + true + true + + + 00400000 + System;Xml;Data;Datasnap;Web;Soap;$(DCC_Namespace) + paxcomp_ios_dev_xe6 + false + false + true + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=;CFBundleName= + false + true + false + false + 1033 + + + Debug + package=com.embarcadero.$(MSBuildProjectName);label=$(MSBuildProjectName);versionCode=1;versionName=1.0.0;persistent=False;restoreAnyVersion=False;installLocation=preferExternal;largeHeap=False;theme=TitleBar;hardwareAccelerated=true + + + iPhoneAndiPad + true + Debug + $(MSBuildProjectName) + CFBundleName=$(MSBuildProjectName);CFBundleDevelopmentRegion=en;CFBundleDisplayName=$(MSBuildProjectName);CFBundleIdentifier=$(MSBuildProjectName);CFBundleInfoDictionaryVersion=6.0;CFBundleVersion=1.0.0.0;CFBundlePackageType=APPL;CFBundleSignature=????;LSRequiresIPhoneOS=true;CFBundleAllowMixedLocalizations=YES;CFBundleExecutable=$(MSBuildProjectName);UIDeviceFamily=iPhone & iPad;CFBundleResourceSpecification=ResourceRules.plist + + + true + Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments= + 1033 + + + 0 + false + RELEASE;$(DCC_Define) + 0 + + + false + DEBUG;$(DCC_Define) + true + + + true + + + + MainSource + + + + + + Cfg_2 + Base + + + Base + + + Cfg_1 + Base + + + + Delphi.Personality.12 + Package + + + + paxcomp_ios_dev_xe6.dpk + + + + False + True + False + False + False + False + + + 12 + + + + diff --git a/Sources/iOS_Device/packages/xe6/paxcomp_ios_dev_xe6.res b/Sources/iOS_Device/packages/xe6/paxcomp_ios_dev_xe6.res new file mode 100644 index 0000000..36f26e2 Binary files /dev/null and b/Sources/iOS_Device/packages/xe6/paxcomp_ios_dev_xe6.res differ diff --git a/Sources/iOS_Device/packages/xe6/uses.def b/Sources/iOS_Device/packages/xe6/uses.def new file mode 100644 index 0000000..e4155f2 --- /dev/null +++ b/Sources/iOS_Device/packages/xe6/uses.def @@ -0,0 +1,50 @@ +{$IFDEF MACOS} + {$DEFINE FMX} +{$ENDIF} + +{$IFDEF LINUX} + {$IFDEF FPC} + DynLibs, + uuid, // in hash folder + {$ELSE} + QForms, + {$ENDIF} +{$ENDIF} + +{$IFDEF MSWINDOWS} + {$IFDEF DPULSAR} + Winapi.Windows, + Winapi.Messages, + System.Win.ComObj, + Winapi.ActiveX, + {$IFDEF FMX} + Fmx.Forms, + Fmx.Dialogs, + {$ELSE} + Vcl.Forms, + Vcl.Dialogs, + {$ENDIF} + {$ELSE} + Windows, + Messages, + {$IFNDEF FPC} + Forms, + Dialogs, + {$ENDIF} + ComObj, + ActiveX, + {$ENDIF} +{$ENDIF} + + {$IFDEF MACOS} + Fmx.Forms, + Fmx.Dialogs, + {$ENDIF} + + {$IFDEF VARIANTS} + Variants, + {$ENDIF} + + {$IFDEF ARC} + System.Generics.Collections, + {$ENDIF} diff --git a/Sources/iOS_Device/packages/xe7/paxcomp_ios_dev_xe7.dpk b/Sources/iOS_Device/packages/xe7/paxcomp_ios_dev_xe7.dpk new file mode 100644 index 0000000..11b853d --- /dev/null +++ b/Sources/iOS_Device/packages/xe7/paxcomp_ios_dev_xe7.dpk @@ -0,0 +1,38 @@ +package paxcomp_ios_dev_xe7; + +{$R *.res} +{$R 'paxcompiler.dcr'} +{$IFDEF IMPLICITBUILDING This IFDEF should not be used by users} +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO OFF} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION OFF} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES ON} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$DEFINE DEBUG} +{$ENDIF IMPLICITBUILDING} +{$IMPLICITBUILD ON} + +requires + rtl; + +contains + PaxCompilerRegister in 'PaxCompilerRegister.pas'; + +end. + diff --git a/Sources/iOS_Device/packages/xe7/paxcomp_ios_dev_xe7.dproj b/Sources/iOS_Device/packages/xe7/paxcomp_ios_dev_xe7.dproj new file mode 100644 index 0000000..503f9e3 --- /dev/null +++ b/Sources/iOS_Device/packages/xe7/paxcomp_ios_dev_xe7.dproj @@ -0,0 +1,133 @@ + + + {CDE3F94D-75FC-4725-9F71-1E581E9768A7} + paxcomp_ios_dev_xe7.dpk + True + Debug + 65 + Package + None + 16.0 + iOSDevice + + + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Cfg_2 + true + true + + + false + paxcomp_ios_dev_xe7 + true + false + false + true + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=;CFBundleName= + System;Xml;Data;Datasnap;Web;Soap;$(DCC_Namespace) + false + 1033 + false + 00400000 + + + Debug + package=com.embarcadero.$(MSBuildProjectName);label=$(MSBuildProjectName);versionCode=1;versionName=1.0.0;persistent=False;restoreAnyVersion=False;installLocation=preferExternal;largeHeap=False;theme=TitleBar;hardwareAccelerated=true + + + true + iPhoneAndiPad + Debug + $(MSBuildProjectName) + CFBundleName=$(MSBuildProjectName);CFBundleDevelopmentRegion=en;CFBundleDisplayName=$(MSBuildProjectName);CFBundleIdentifier=$(MSBuildProjectName);CFBundleInfoDictionaryVersion=7.1;CFBundleVersion=1.0.0.0;CFBundlePackageType=APPL;CFBundleSignature=????;LSRequiresIPhoneOS=true;CFBundleAllowMixedLocalizations=YES;CFBundleExecutable=$(MSBuildProjectName);UIDeviceFamily=iPhone & iPad;CFBundleResourceSpecification=ResourceRules.plist + + + 1033 + true + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments= + Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) + + + 0 + false + RELEASE;$(DCC_Define) + 0 + + + true + DEBUG;$(DCC_Define) + false + + + true + + + + MainSource + + + + + + Cfg_2 + Base + + + Base + + + Cfg_1 + Base + + + + Delphi.Personality.12 + Package + + + + paxcomp_ios_dev_xe7.dpk + + + + False + True + False + False + True + False + + + 12 + + + + diff --git a/Sources/iOS_Device/packages/xe7/paxcomp_ios_dev_xe7.res b/Sources/iOS_Device/packages/xe7/paxcomp_ios_dev_xe7.res new file mode 100644 index 0000000..36f26e2 Binary files /dev/null and b/Sources/iOS_Device/packages/xe7/paxcomp_ios_dev_xe7.res differ diff --git a/Sources/iOS_Device/packages/xe7/paxcompiler.dcr b/Sources/iOS_Device/packages/xe7/paxcompiler.dcr new file mode 100644 index 0000000..4bcc339 Binary files /dev/null and b/Sources/iOS_Device/packages/xe7/paxcompiler.dcr differ diff --git a/Sources/iOS_Simulator/Demos/Hello/Project1.deployproj b/Sources/iOS_Simulator/Demos/Hello/Project1.deployproj new file mode 100644 index 0000000..2c42773 --- /dev/null +++ b/Sources/iOS_Simulator/Demos/Hello/Project1.deployproj @@ -0,0 +1,246 @@ + + + + 12 + + + + + + + + Project1.app\Contents\MacOS\ + libcgunwind.1.0.dylib + 1 + + + + + + + Project1.app\ + FM_ApplicationIcon_57x57.png + 0 + + + + + Project1.app\ + FM_ApplicationIcon_144x144.png + 0 + + + + + Project1.app\ + FM_SpotlightSearchIcon_50x50.png + 0 + + + + + Project1.app\ + FM_SettingIcon_29x29.png + 0 + + + + + Project1.app\ + Default.png + 1 + + + + + Project1.app\ + Default-Portrait@2x.png + 1 + + + + + Project1.app\ + Default-Landscape@2x.png + 1 + + + + + Project1.app\ + FM_ApplicationIcon_76x76.png + 0 + + + + + Project1.app\ + Default@2x.png + 1 + + + + + Project1.app\ + libcgunwind.1.0.dylib + 1 + + + + + Project1.app\ + Default-Portrait~ipad.png + 0 + + + + + Project1.app\ + FM_SettingIcon_58x58.png + 0 + + + + + Project1.app\ + FM_ApplicationIcon_120x120.png + 0 + + + + + Project1.app\ + FM_ApplicationIcon_60x60.png + 0 + + + + + Project1.app\ + FM_SpotlightSearchIcon_40x40.png + 0 + + + + + Project1.app\ + Default-Landscape@2x~ipad.png + 0 + + + + + Project1.app\ + Default-568h@2x.png + 1 + + + + + Project1.app\ + Default-Landscape~ipad.png + 0 + + + + + Project1.app\ + FM_ApplicationIcon_114x114.png + 0 + + + + + Project1.app\ + FM_SpotlightSearchIcon_80x80.png + 0 + + + + + Project1.app\ + Project1.rsm + 1 + + + + + Project1.app\ + FM_SpotlightSearchIcon_40x40.png + 0 + + + + + Project1.app\ + Info.plist + 1 + + + + + Project1.app\ + Entitlements.plist + 0 + + + + + Project1.app\ + FM_ApplicationIcon_72x72.png + 0 + + + + + Project1.app\ + Default~ipad.png + 1 + + + + + Project1.app\ + Default-Portrait@2x~ipad.png + 0 + + + + + Project1.app\ + FM_SpotlightSearchIcon_29x29.png + 0 + + + + + Project1.app\ + FM_SpotlightSearchIcon_100x100.png + 0 + + + + + Project1.app\ + Project1 + 1 + + + True + + + Project1.app\ + FM_ApplicationIcon_152x152.png + 0 + + + + + Project1.app\ + Default-Landscape.png + 1 + + + + + diff --git a/Sources/iOS_Simulator/Demos/Hello/Project1.dpr b/Sources/iOS_Simulator/Demos/Hello/Project1.dpr new file mode 100644 index 0000000..3ac7d4f --- /dev/null +++ b/Sources/iOS_Simulator/Demos/Hello/Project1.dpr @@ -0,0 +1,14 @@ +program Project1; + +uses + System.StartUpCopy, + FMX.Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Sources/iOS_Simulator/Demos/Hello/Project1.dproj b/Sources/iOS_Simulator/Demos/Hello/Project1.dproj new file mode 100644 index 0000000..96948cd --- /dev/null +++ b/Sources/iOS_Simulator/Demos/Hello/Project1.dproj @@ -0,0 +1,271 @@ + + + {69F9C8A8-F413-48F1-8B31-6A84FC32AAD6} + 15.2 + FMX + Project1.dpr + True + Debug + iOSSimulator + 89 + Application + + + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Cfg_1 + true + true + + + true + Base + true + + + true + true + true + System;Xml;Data;Datasnap;Web;Soap;$(DCC_Namespace) + true + true + true + true + true + true + true + .\$(Platform)\$(Config) + .\$(Platform)\$(Config) + false + false + false + false + false + + + $(BDS)\bin\Artwork\Android\FM_LauncherIcon_36x36.png + true + FireDACSqliteDriver;DBXSqliteDriver;fmx;IndySystem;DBXInterBaseDriver;DataSnapClient;DataSnapCommon;paxcomp_xe5;DataSnapProviderClient;DbxCommonDriver;dbxcds;fmxFireDAC;CustomIPTransport;dsnap;IndyCore;IndyIPCommon;CloudService;FmxTeeUI;FireDACIBDriver;FireDACDBXDriver;bindcompfmx;rtl;dbrtl;DbxClientDriver;FireDACCommon;bindcomp;xmlrtl;ibxpress;IndyProtocols;FireDACCommonDriver;bindengine;soaprtl;bindcompdbx;FMXTee;FireDAC;FireDACDataSnapDriver;inet;RESTComponents;dbexpress;IndyIPClient;$(DCC_UsePackage) + $(BDS)\bin\Artwork\Android\FM_LauncherIcon_72x72.png + $(BDS)\bin\Artwork\Android\FM_LauncherIcon_96x96.png + Debug + $(BDS)\bin\Artwork\Android\FM_LauncherIcon_144x144.png + package=com.embarcadero.$(MSBuildProjectName);label=$(MSBuildProjectName);versionCode=1;versionName=1.0.0;persistent=False;restoreAnyVersion=False;installLocation=preferExternal;largeHeap=False;theme=TitleBar + $(BDS)\bin\Artwork\Android\FM_LauncherIcon_48x48.png + + + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_768x1004.png + iPhoneAndiPad + $(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_40x40.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImage_640x1136.png + $(MSBuildProjectName) + $(BDS)\bin\Artwork\iOS\iPad\FM_SettingIcon_58x58.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_1024x748.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SettingIcon_29x29.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_60x60.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_50x50.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_80x80.png + FireDACSqliteDriver;DBXSqliteDriver;fmx;IndySystem;DBXInterBaseDriver;DataSnapClient;DataSnapCommon;DataSnapProviderClient;DbxCommonDriver;dbxcds;fmxFireDAC;CustomIPTransport;dsnap;fmxase;IndyCore;IndyIPCommon;CloudService;FmxTeeUI;FireDACIBDriver;FireDACDBXDriver;bindcompfmx;rtl;dbrtl;DbxClientDriver;FireDACCommon;bindcomp;xmlrtl;ibxpress;IndyProtocols;FireDACCommonDriver;bindengine;soaprtl;bindcompdbx;FMXTee;FireDAC;FireDACDataSnapDriver;inet;RESTComponents;dbexpress;IndyIPClient;$(DCC_UsePackage) + $(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_40x40.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImage_640x960.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_57x57.png + $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_72x72.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImage_320x480.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_1024x768.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_80x80.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_58x58.png + $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_152x152.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_1536x2008.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_2048x1496.png + $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_76x76.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_768x1024.png + Debug + $(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_29x29.png + $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_144x144.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_2048x1536.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_100x100.png + true + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_1536x2048.png + CFBundleName=$(MSBuildProjectName);CFBundleDevelopmentRegion=en;CFBundleDisplayName=$(MSBuildProjectName);CFBundleIdentifier=$(MSBuildProjectName);CFBundleInfoDictionaryVersion=6.0;CFBundleVersion=1.0.0.0;CFBundlePackageType=APPL;CFBundleSignature=????;LSRequiresIPhoneOS=true;CFBundleAllowMixedLocalizations=YES;CFBundleExecutable=$(MSBuildProjectName);UIDeviceFamily=iPhone & iPad;CFBundleResourceSpecification=ResourceRules.plist + $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_114x114.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_120x120.png + + + $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImage_640x1136.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_768x1004.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_60x60.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_40x40.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SettingIcon_29x29.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SettingIcon_58x58.png + iPhoneAndiPad + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_1024x748.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_50x50.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_80x80.png + FireDACSqliteDriver;DBXSqliteDriver;fmx;IndySystem;DBXInterBaseDriver;DataSnapClient;DataSnapCommon;DataSnapProviderClient;DbxCommonDriver;dbxcds;fmxFireDAC;CustomIPTransport;dsnap;fmxase;IndyCore;IndyIPCommon;CloudService;FmxTeeUI;FireDACIBDriver;FireDACDBXDriver;bindcompfmx;rtl;dbrtl;DbxClientDriver;FireDACCommon;bindcomp;xmlrtl;ibxpress;IndyProtocols;FireDACCommonDriver;bindengine;soaprtl;bindcompdbx;FMXTee;FireDAC;FireDACDataSnapDriver;inet;RESTComponents;dbexpress;IndyIPClient;$(DCC_UsePackage) + $(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_40x40.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImage_640x960.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_57x57.png + $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_72x72.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImage_320x480.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_1024x768.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_1536x2008.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_80x80.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_29x29.png + $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_152x152.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_2048x1496.png + $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_76x76.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_58x58.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_768x1024.png + $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_144x144.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_2048x1536.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_100x100.png + true + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_1536x2048.png + CFBundleName=$(MSBuildProjectName);CFBundleDevelopmentRegion=en;CFBundleDisplayName=$(MSBuildProjectName);CFBundleIdentifier=$(MSBuildProjectName);CFBundleInfoDictionaryVersion=6.0;CFBundleVersion=1.0.0.0;CFBundlePackageType=APPL;CFBundleSignature=????;LSRequiresIPhoneOS=true;CFBundleAllowMixedLocalizations=YES;CFBundleExecutable=$(MSBuildProjectName);UIDeviceFamily=iPhone & iPad;CFBundleResourceSpecification=ResourceRules.plist + $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_114x114.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_120x120.png + + + true + 1033 + FireDACSqliteDriver;DBXSqliteDriver;FireDACPgDriver;fmx;IndySystem;TeeDB;frx19;vclib;inetdbbde;DBXInterBaseDriver;DataSnapClient;DataSnapCommon;DataSnapServer;paxcomp_xe5;DataSnapProviderClient;DBXSybaseASEDriver;DbxCommonDriver;vclimg;dbxcds;DatasnapConnectorsFreePascal;MetropolisUILiveTile;vcldb;vcldsnap;fmxFireDAC;DBXDb2Driver;DBXOracleDriver;CustomIPTransport;vclribbon;dsnap;IndyIPServer;fmxase;vcl;IndyCore;IndyIPCommon;CloudService;DBXMSSQLDriver;FmxTeeUI;FireDACIBDriver;CodeSiteExpressPkg;FireDACDBXDriver;inetdbxpress;webdsnap;frxe19;FireDACDb2Driver;adortl;frxDB19;FireDACASADriver;bindcompfmx;vcldbx;FireDACODBCDriver;rtl;dbrtl;DbxClientDriver;FireDACCommon;bindcomp;inetdb;Tee;DBXOdbcDriver;vclFireDAC;xmlrtl;svnui;ibxpress;IndyProtocols;DBXMySQLDriver;FireDACCommonDriver;bindengine;vclactnband;soaprtl;bindcompdbx;FMXTee;TeeUI;bindcompvcl;vclie;FireDACADSDriver;vcltouch;VclSmp;FireDACMSSQLDriver;FireDAC;VCLRESTComponents;Intraweb;DBXInformixDriver;DataSnapConnectors;FireDACDataSnapDriver;dsnapcon;DBXFirebirdDriver;inet;fmxobj;FireDACMySQLDriver;vclx;svn;DBXSybaseASADriver;FireDACOracleDriver;fmxdae;RESTComponents;bdertl;FireDACMSAccDriver;DataSnapIndy10ServerTransport;dbexpress;IndyIPClient;$(DCC_UsePackage) + $(BDS)\bin\default_app.manifest + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments= + Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) + + + DEBUG;$(DCC_Define) + true + false + true + true + true + + + false + + + false + RELEASE;$(DCC_Define) + 0 + 0 + + + + MainSource + + +
Form1
+ fmx + + + Cfg_2 + Base + + + Base + + + Cfg_1 + Base + + + + Delphi.Personality.12 + + + + + False + False + 1 + 0 + 0 + 0 + False + False + False + False + False + 1033 + 1252 + + + + + 1.0.0.0 + + + + + + 1.0.0.0 + + + + + + + + + + + + + + + + + + + + + + + + + + + Project1.dpr + + + + + True + True + True + True + + + 12 + + + + diff --git a/Sources/iOS_Simulator/Demos/Hello/Project1.res b/Sources/iOS_Simulator/Demos/Hello/Project1.res new file mode 100644 index 0000000..36f26e2 Binary files /dev/null and b/Sources/iOS_Simulator/Demos/Hello/Project1.res differ diff --git a/Sources/iOS_Simulator/Demos/Hello/Unit1.fmx b/Sources/iOS_Simulator/Demos/Hello/Unit1.fmx new file mode 100644 index 0000000..5786ad5 --- /dev/null +++ b/Sources/iOS_Simulator/Demos/Hello/Unit1.fmx @@ -0,0 +1,40 @@ +object Form1: TForm1 + Left = 0 + Top = 0 + Caption = 'Form1' + ClientHeight = 567 + ClientWidth = 384 + FormFactor.Width = 320 + FormFactor.Height = 480 + FormFactor.Devices = [dkDesktop] + DesignerMobile = True + DesignerWidth = 384 + DesignerHeight = 592 + DesignerDeviceName = 'Google Nexus 4' + DesignerOrientation = 0 + DesignerOSVersion = '' + object Button1: TButton + Height = 44.000000000000000000 + Position.X = 56.000000000000000000 + Position.Y = 80.000000000000000000 + TabOrder = 0 + Text = 'Say Hello' + Trimming = ttCharacter + Width = 145.000000000000000000 + OnClick = Button1Click + end + object Memo1: TMemo + Touch.InteractiveGestures = [igPan, igLongTap, igDoubleTap] + Height = 129.000000000000000000 + Position.X = 16.000000000000000000 + Position.Y = 160.000000000000000000 + TabOrder = 1 + Width = 257.000000000000000000 + Lines.Strings = ( + 'uses Unit1;' + 'begin' + ' Form1.Button1.Text := '#39'Hello'#39';' + 'end.' + '') + end +end diff --git a/Sources/iOS_Simulator/Demos/Hello/Unit1.pas b/Sources/iOS_Simulator/Demos/Hello/Unit1.pas new file mode 100644 index 0000000..57c2879 --- /dev/null +++ b/Sources/iOS_Simulator/Demos/Hello/Unit1.pas @@ -0,0 +1,70 @@ +unit Unit1; + +interface + +uses + System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants, + FMX.StdCtrls, + FMX.Memo, + FMX.Types, FMX.Controls, FMX.Forms, FMX.Graphics, FMX.Dialogs, + PaxCompiler, PaxRunner, PaxInterpreter, FMX.Layouts; + +type + TForm1 = class(TForm) + Button1: TButton; + Memo1: TMemo; + procedure Button1Click(Sender: TObject); + private + { Private declarations } + procedure DoOnImportUnit(Sender: TPaxCompiler; Id: Integer; + const AFullName: string); + public + { Public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.fmx} + +procedure TForm1.DoOnImportUnit(Sender: TPaxCompiler; Id: Integer; + const AFullName: string); +begin +// Global members must be imported explicitly. + + Sender.RegisterVariable(Id, 'Form1: TForm1', @Form1); +end; + +procedure TForm1.Button1Click(Sender: TObject); +var + PaxCompiler1: TPaxCompiler; + PaxInterpreter1: TPaxInterpreter; + PaxPascalLanguage1: TPaxPascalLanguage; +begin + PaxCompiler1 := TPaxCompiler.Create(nil); + PaxInterpreter1 := TPaxInterpreter.Create(nil); + PaxPascalLanguage1 := TPaxPascalLanguage.Create(nil); + try + PaxCompiler1.OnImportUnit := DoOnImportUnit; + + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + PaxCompiler1.AddModule('1', 'Pascal'); + PaxCompiler1.AddCode('1', Memo1.Lines.Text); + if PaxCompiler1.Compile(PaxInterpreter1) then + begin + PaxInterpreter1.Run; + end + else + begin + ShowMessage(PaxCompiler1.ErrorMessage[0]); + end; + finally + PaxCompiler1.Free; + PaxInterpreter1.Free; + PaxPascalLanguage1.Free; + end; +end; + +end. diff --git a/Sources/iOS_Simulator/Demos/ImportAbstractClass/AndroidManifest.template.xml b/Sources/iOS_Simulator/Demos/ImportAbstractClass/AndroidManifest.template.xml new file mode 100644 index 0000000..3dde458 --- /dev/null +++ b/Sources/iOS_Simulator/Demos/ImportAbstractClass/AndroidManifest.template.xml @@ -0,0 +1,35 @@ + + + + + + +<%uses-permission%> + + + + + + + + + + + + + + diff --git a/Sources/iOS_Simulator/Demos/ImportAbstractClass/Project1.deployproj b/Sources/iOS_Simulator/Demos/ImportAbstractClass/Project1.deployproj new file mode 100644 index 0000000..2c42773 --- /dev/null +++ b/Sources/iOS_Simulator/Demos/ImportAbstractClass/Project1.deployproj @@ -0,0 +1,246 @@ + + + + 12 + + + + + + + + Project1.app\Contents\MacOS\ + libcgunwind.1.0.dylib + 1 + + + + + + + Project1.app\ + FM_ApplicationIcon_57x57.png + 0 + + + + + Project1.app\ + FM_ApplicationIcon_144x144.png + 0 + + + + + Project1.app\ + FM_SpotlightSearchIcon_50x50.png + 0 + + + + + Project1.app\ + FM_SettingIcon_29x29.png + 0 + + + + + Project1.app\ + Default.png + 1 + + + + + Project1.app\ + Default-Portrait@2x.png + 1 + + + + + Project1.app\ + Default-Landscape@2x.png + 1 + + + + + Project1.app\ + FM_ApplicationIcon_76x76.png + 0 + + + + + Project1.app\ + Default@2x.png + 1 + + + + + Project1.app\ + libcgunwind.1.0.dylib + 1 + + + + + Project1.app\ + Default-Portrait~ipad.png + 0 + + + + + Project1.app\ + FM_SettingIcon_58x58.png + 0 + + + + + Project1.app\ + FM_ApplicationIcon_120x120.png + 0 + + + + + Project1.app\ + FM_ApplicationIcon_60x60.png + 0 + + + + + Project1.app\ + FM_SpotlightSearchIcon_40x40.png + 0 + + + + + Project1.app\ + Default-Landscape@2x~ipad.png + 0 + + + + + Project1.app\ + Default-568h@2x.png + 1 + + + + + Project1.app\ + Default-Landscape~ipad.png + 0 + + + + + Project1.app\ + FM_ApplicationIcon_114x114.png + 0 + + + + + Project1.app\ + FM_SpotlightSearchIcon_80x80.png + 0 + + + + + Project1.app\ + Project1.rsm + 1 + + + + + Project1.app\ + FM_SpotlightSearchIcon_40x40.png + 0 + + + + + Project1.app\ + Info.plist + 1 + + + + + Project1.app\ + Entitlements.plist + 0 + + + + + Project1.app\ + FM_ApplicationIcon_72x72.png + 0 + + + + + Project1.app\ + Default~ipad.png + 1 + + + + + Project1.app\ + Default-Portrait@2x~ipad.png + 0 + + + + + Project1.app\ + FM_SpotlightSearchIcon_29x29.png + 0 + + + + + Project1.app\ + FM_SpotlightSearchIcon_100x100.png + 0 + + + + + Project1.app\ + Project1 + 1 + + + True + + + Project1.app\ + FM_ApplicationIcon_152x152.png + 0 + + + + + Project1.app\ + Default-Landscape.png + 1 + + + + + diff --git a/Sources/iOS_Simulator/Demos/ImportAbstractClass/Project1.dpr b/Sources/iOS_Simulator/Demos/ImportAbstractClass/Project1.dpr new file mode 100644 index 0000000..3ac7d4f --- /dev/null +++ b/Sources/iOS_Simulator/Demos/ImportAbstractClass/Project1.dpr @@ -0,0 +1,14 @@ +program Project1; + +uses + System.StartUpCopy, + FMX.Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Sources/iOS_Simulator/Demos/ImportAbstractClass/Project1.dproj b/Sources/iOS_Simulator/Demos/ImportAbstractClass/Project1.dproj new file mode 100644 index 0000000..d62a54e --- /dev/null +++ b/Sources/iOS_Simulator/Demos/ImportAbstractClass/Project1.dproj @@ -0,0 +1,271 @@ + + + {246BD949-5B31-4DE8-B594-0D9EEF75031C} + 15.2 + FMX + Project1.dpr + True + Debug + iOSSimulator + 89 + Application + + + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Cfg_1 + true + true + + + true + Base + true + + + true + true + true + System;Xml;Data;Datasnap;Web;Soap;$(DCC_Namespace) + true + true + true + true + true + true + true + .\$(Platform)\$(Config) + .\$(Platform)\$(Config) + false + false + false + false + false + + + $(BDS)\bin\Artwork\Android\FM_LauncherIcon_36x36.png + true + FireDACSqliteDriver;DBXSqliteDriver;fmx;IndySystem;DBXInterBaseDriver;DataSnapClient;DataSnapCommon;paxcomp_xe5;DataSnapProviderClient;DbxCommonDriver;dbxcds;fmxFireDAC;CustomIPTransport;dsnap;IndyCore;IndyIPCommon;CloudService;FmxTeeUI;FireDACIBDriver;FireDACDBXDriver;bindcompfmx;rtl;dbrtl;DbxClientDriver;FireDACCommon;bindcomp;xmlrtl;ibxpress;IndyProtocols;FireDACCommonDriver;bindengine;soaprtl;bindcompdbx;FMXTee;FireDAC;FireDACDataSnapDriver;inet;RESTComponents;dbexpress;IndyIPClient;$(DCC_UsePackage) + $(BDS)\bin\Artwork\Android\FM_LauncherIcon_72x72.png + $(BDS)\bin\Artwork\Android\FM_LauncherIcon_96x96.png + Debug + $(BDS)\bin\Artwork\Android\FM_LauncherIcon_144x144.png + package=com.embarcadero.$(MSBuildProjectName);label=$(MSBuildProjectName);versionCode=1;versionName=1.0.0;persistent=False;restoreAnyVersion=False;installLocation=preferExternal;largeHeap=False;theme=TitleBar + $(BDS)\bin\Artwork\Android\FM_LauncherIcon_48x48.png + + + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_768x1004.png + iPhoneAndiPad + $(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_40x40.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImage_640x1136.png + $(MSBuildProjectName) + $(BDS)\bin\Artwork\iOS\iPad\FM_SettingIcon_58x58.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_1024x748.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SettingIcon_29x29.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_60x60.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_50x50.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_80x80.png + FireDACSqliteDriver;DBXSqliteDriver;fmx;IndySystem;DBXInterBaseDriver;DataSnapClient;DataSnapCommon;DataSnapProviderClient;DbxCommonDriver;dbxcds;fmxFireDAC;CustomIPTransport;dsnap;fmxase;IndyCore;IndyIPCommon;CloudService;FmxTeeUI;FireDACIBDriver;FireDACDBXDriver;bindcompfmx;rtl;dbrtl;DbxClientDriver;FireDACCommon;bindcomp;xmlrtl;ibxpress;IndyProtocols;FireDACCommonDriver;bindengine;soaprtl;bindcompdbx;FMXTee;FireDAC;FireDACDataSnapDriver;inet;RESTComponents;dbexpress;IndyIPClient;$(DCC_UsePackage) + $(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_40x40.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImage_640x960.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_57x57.png + $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_72x72.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImage_320x480.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_1024x768.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_80x80.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_58x58.png + $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_152x152.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_1536x2008.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_2048x1496.png + $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_76x76.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_768x1024.png + Debug + $(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_29x29.png + $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_144x144.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_2048x1536.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_100x100.png + true + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_1536x2048.png + CFBundleName=$(MSBuildProjectName);CFBundleDevelopmentRegion=en;CFBundleDisplayName=$(MSBuildProjectName);CFBundleIdentifier=$(MSBuildProjectName);CFBundleInfoDictionaryVersion=6.0;CFBundleVersion=1.0.0.0;CFBundlePackageType=APPL;CFBundleSignature=????;LSRequiresIPhoneOS=true;CFBundleAllowMixedLocalizations=YES;CFBundleExecutable=$(MSBuildProjectName);UIDeviceFamily=iPhone & iPad;CFBundleResourceSpecification=ResourceRules.plist + $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_114x114.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_120x120.png + + + $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImage_640x1136.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_768x1004.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_60x60.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_40x40.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SettingIcon_29x29.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SettingIcon_58x58.png + iPhoneAndiPad + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_1024x748.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_50x50.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_80x80.png + FireDACSqliteDriver;DBXSqliteDriver;fmx;IndySystem;DBXInterBaseDriver;DataSnapClient;DataSnapCommon;DataSnapProviderClient;DbxCommonDriver;dbxcds;fmxFireDAC;CustomIPTransport;dsnap;fmxase;IndyCore;IndyIPCommon;CloudService;FmxTeeUI;FireDACIBDriver;FireDACDBXDriver;bindcompfmx;rtl;dbrtl;DbxClientDriver;FireDACCommon;bindcomp;xmlrtl;ibxpress;IndyProtocols;FireDACCommonDriver;bindengine;soaprtl;bindcompdbx;FMXTee;FireDAC;FireDACDataSnapDriver;inet;RESTComponents;dbexpress;IndyIPClient;$(DCC_UsePackage) + $(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_40x40.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImage_640x960.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_57x57.png + $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_72x72.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImage_320x480.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_1024x768.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_1536x2008.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_80x80.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_29x29.png + $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_152x152.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_2048x1496.png + $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_76x76.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_58x58.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_768x1024.png + $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_144x144.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_2048x1536.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_100x100.png + true + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_1536x2048.png + CFBundleName=$(MSBuildProjectName);CFBundleDevelopmentRegion=en;CFBundleDisplayName=$(MSBuildProjectName);CFBundleIdentifier=$(MSBuildProjectName);CFBundleInfoDictionaryVersion=6.0;CFBundleVersion=1.0.0.0;CFBundlePackageType=APPL;CFBundleSignature=????;LSRequiresIPhoneOS=true;CFBundleAllowMixedLocalizations=YES;CFBundleExecutable=$(MSBuildProjectName);UIDeviceFamily=iPhone & iPad;CFBundleResourceSpecification=ResourceRules.plist + $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_114x114.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_120x120.png + + + true + 1033 + FireDACSqliteDriver;DBXSqliteDriver;FireDACPgDriver;fmx;IndySystem;TeeDB;frx19;vclib;inetdbbde;DBXInterBaseDriver;DataSnapClient;DataSnapCommon;DataSnapServer;paxcomp_xe5;DataSnapProviderClient;DBXSybaseASEDriver;DbxCommonDriver;vclimg;dbxcds;DatasnapConnectorsFreePascal;MetropolisUILiveTile;vcldb;vcldsnap;fmxFireDAC;DBXDb2Driver;DBXOracleDriver;CustomIPTransport;vclribbon;dsnap;IndyIPServer;fmxase;vcl;IndyCore;IndyIPCommon;CloudService;DBXMSSQLDriver;FmxTeeUI;FireDACIBDriver;CodeSiteExpressPkg;FireDACDBXDriver;inetdbxpress;webdsnap;frxe19;FireDACDb2Driver;adortl;frxDB19;FireDACASADriver;bindcompfmx;vcldbx;FireDACODBCDriver;rtl;dbrtl;DbxClientDriver;FireDACCommon;bindcomp;inetdb;Tee;DBXOdbcDriver;vclFireDAC;xmlrtl;svnui;ibxpress;IndyProtocols;DBXMySQLDriver;FireDACCommonDriver;bindengine;vclactnband;soaprtl;bindcompdbx;FMXTee;TeeUI;bindcompvcl;vclie;FireDACADSDriver;vcltouch;VclSmp;FireDACMSSQLDriver;FireDAC;VCLRESTComponents;Intraweb;DBXInformixDriver;DataSnapConnectors;FireDACDataSnapDriver;dsnapcon;DBXFirebirdDriver;inet;fmxobj;FireDACMySQLDriver;vclx;svn;DBXSybaseASADriver;FireDACOracleDriver;fmxdae;RESTComponents;bdertl;FireDACMSAccDriver;DataSnapIndy10ServerTransport;dbexpress;IndyIPClient;$(DCC_UsePackage) + $(BDS)\bin\default_app.manifest + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments= + Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) + + + DEBUG;$(DCC_Define) + true + false + true + true + true + + + false + + + false + RELEASE;$(DCC_Define) + 0 + 0 + + + + MainSource + + +
Form1
+ fmx + + + Cfg_2 + Base + + + Base + + + Cfg_1 + Base + + + + Delphi.Personality.12 + + + + + False + False + 1 + 0 + 0 + 0 + False + False + False + False + False + 1033 + 1252 + + + + + 1.0.0.0 + + + + + + 1.0.0.0 + + + + + + + + + + + + + + + + + + + + + + + + + + + Project1.dpr + + + + + True + True + True + True + + + 12 + + + + diff --git a/Sources/iOS_Simulator/Demos/ImportAbstractClass/Project1.res b/Sources/iOS_Simulator/Demos/ImportAbstractClass/Project1.res new file mode 100644 index 0000000..36f26e2 Binary files /dev/null and b/Sources/iOS_Simulator/Demos/ImportAbstractClass/Project1.res differ diff --git a/Sources/iOS_Simulator/Demos/ImportAbstractClass/Unit1.fmx b/Sources/iOS_Simulator/Demos/ImportAbstractClass/Unit1.fmx new file mode 100644 index 0000000..a81feaa --- /dev/null +++ b/Sources/iOS_Simulator/Demos/ImportAbstractClass/Unit1.fmx @@ -0,0 +1,52 @@ +object Form1: TForm1 + Left = 0 + Top = 0 + Caption = 'Form1' + ClientHeight = 567 + ClientWidth = 384 + FormFactor.Width = 320 + FormFactor.Height = 480 + FormFactor.Devices = [dkDesktop] + DesignerMobile = True + DesignerWidth = 384 + DesignerHeight = 592 + DesignerDeviceName = 'Google Nexus 4' + DesignerOrientation = 0 + DesignerOSVersion = '' + object Memo1: TMemo + Touch.InteractiveGestures = [igPan, igLongTap, igDoubleTap] + Height = 337.000000000000000000 + Position.X = 16.000000000000000000 + Position.Y = 16.000000000000000000 + TabOrder = 0 + Width = 228.000000000000000000 + Lines.Strings = ( + 'uses Unit1;' + 'type' + ' TMyScriptClass = class(TMyHostClass)' + ' constructor Create; override;' + ' procedure P; override;' + ' end;' + 'constructor TMyScriptClass.Create;' + 'begin' + ' print '#39'Script object of '#39' + ClassName + '#39'is created.'#39 + 'end;' + 'procedure TMyScriptClass.P;' + 'begin' + ' print '#39'Hello from script!'#39';' + 'end;' + 'begin' + 'end.' + '') + end + object Button1: TButton + Height = 44.000000000000000000 + Position.X = 16.000000000000000000 + Position.Y = 360.000000000000000000 + TabOrder = 1 + Text = 'Run' + Trimming = ttCharacter + Width = 73.000000000000000000 + OnClick = Button1Click + end +end diff --git a/Sources/iOS_Simulator/Demos/ImportAbstractClass/Unit1.pas b/Sources/iOS_Simulator/Demos/ImportAbstractClass/Unit1.pas new file mode 100644 index 0000000..8e0c8d9 --- /dev/null +++ b/Sources/iOS_Simulator/Demos/ImportAbstractClass/Unit1.pas @@ -0,0 +1,74 @@ +unit Unit1; + +interface + +uses + System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants, + FMX.Types, FMX.Controls, FMX.Forms, FMX.Graphics, FMX.Dialogs, FMX.StdCtrls, + FMX.Layouts, FMX.Memo, PaxCompiler, PaxRunner, PaxInterpreter; + +type + TForm1 = class(TForm) + Memo1: TMemo; + Button1: TButton; + procedure Button1Click(Sender: TObject); + private + { Private declarations } + public + { Public declarations } + end; + + TMyHostClass = class + public + constructor Create; virtual; abstract; + procedure P; virtual; abstract; + end; + TMyHostClassClass = class of TMyHostClass; + +var + Form1: TForm1; + +implementation + +{$R *.fmx} + +procedure Dummy(P: Pointer); begin end; + +procedure TForm1.Button1Click(Sender: TObject); +var + PaxCompiler1: TPaxCompiler; + PaxInterpreter1: TPaxInterpreter; + PaxPascalLanguage1: TPaxPascalLanguage; + + C: TMyHostClassClass; + X: TMyHostClass; +begin + Dummy(TMyHostClass); // just to punish Delphi to create rtti for this class + + PaxCompiler1 := TPaxCompiler.Create(nil); + PaxInterpreter1 := TPaxInterpreter.Create(nil); + PaxPascalLanguage1 := TPaxPascalLanguage.Create(nil); + try + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + PaxCompiler1.AddModule('1', 'Pascal'); + PaxCompiler1.AddCode('1', Memo1.Lines.Text); + if PaxCompiler1.Compile(PaxInterpreter1) then + begin + PaxInterpreter1.RunInitialization; + + C := TMyHostClassClass(PaxInterpreter1.GetAddress('TMyScriptClass')^); + X := C.Create; + X.P; + end + else + begin + ShowMessage(PaxCompiler1.ErrorMessage[0]); + end; + finally + PaxCompiler1.Free; + PaxInterpreter1.Free; + PaxPascalLanguage1.Free; + end; +end; + +end. diff --git a/Sources/iOS_Simulator/Demos/OperatorOverloading/Project1.deployproj b/Sources/iOS_Simulator/Demos/OperatorOverloading/Project1.deployproj new file mode 100644 index 0000000..2c42773 --- /dev/null +++ b/Sources/iOS_Simulator/Demos/OperatorOverloading/Project1.deployproj @@ -0,0 +1,246 @@ + + + + 12 + + + + + + + + Project1.app\Contents\MacOS\ + libcgunwind.1.0.dylib + 1 + + + + + + + Project1.app\ + FM_ApplicationIcon_57x57.png + 0 + + + + + Project1.app\ + FM_ApplicationIcon_144x144.png + 0 + + + + + Project1.app\ + FM_SpotlightSearchIcon_50x50.png + 0 + + + + + Project1.app\ + FM_SettingIcon_29x29.png + 0 + + + + + Project1.app\ + Default.png + 1 + + + + + Project1.app\ + Default-Portrait@2x.png + 1 + + + + + Project1.app\ + Default-Landscape@2x.png + 1 + + + + + Project1.app\ + FM_ApplicationIcon_76x76.png + 0 + + + + + Project1.app\ + Default@2x.png + 1 + + + + + Project1.app\ + libcgunwind.1.0.dylib + 1 + + + + + Project1.app\ + Default-Portrait~ipad.png + 0 + + + + + Project1.app\ + FM_SettingIcon_58x58.png + 0 + + + + + Project1.app\ + FM_ApplicationIcon_120x120.png + 0 + + + + + Project1.app\ + FM_ApplicationIcon_60x60.png + 0 + + + + + Project1.app\ + FM_SpotlightSearchIcon_40x40.png + 0 + + + + + Project1.app\ + Default-Landscape@2x~ipad.png + 0 + + + + + Project1.app\ + Default-568h@2x.png + 1 + + + + + Project1.app\ + Default-Landscape~ipad.png + 0 + + + + + Project1.app\ + FM_ApplicationIcon_114x114.png + 0 + + + + + Project1.app\ + FM_SpotlightSearchIcon_80x80.png + 0 + + + + + Project1.app\ + Project1.rsm + 1 + + + + + Project1.app\ + FM_SpotlightSearchIcon_40x40.png + 0 + + + + + Project1.app\ + Info.plist + 1 + + + + + Project1.app\ + Entitlements.plist + 0 + + + + + Project1.app\ + FM_ApplicationIcon_72x72.png + 0 + + + + + Project1.app\ + Default~ipad.png + 1 + + + + + Project1.app\ + Default-Portrait@2x~ipad.png + 0 + + + + + Project1.app\ + FM_SpotlightSearchIcon_29x29.png + 0 + + + + + Project1.app\ + FM_SpotlightSearchIcon_100x100.png + 0 + + + + + Project1.app\ + Project1 + 1 + + + True + + + Project1.app\ + FM_ApplicationIcon_152x152.png + 0 + + + + + Project1.app\ + Default-Landscape.png + 1 + + + + + diff --git a/Sources/iOS_Simulator/Demos/OperatorOverloading/Project1.dpr b/Sources/iOS_Simulator/Demos/OperatorOverloading/Project1.dpr new file mode 100644 index 0000000..3ac7d4f --- /dev/null +++ b/Sources/iOS_Simulator/Demos/OperatorOverloading/Project1.dpr @@ -0,0 +1,14 @@ +program Project1; + +uses + System.StartUpCopy, + FMX.Forms, + Unit1 in 'Unit1.pas' {Form1}; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. diff --git a/Sources/iOS_Simulator/Demos/OperatorOverloading/Project1.dproj b/Sources/iOS_Simulator/Demos/OperatorOverloading/Project1.dproj new file mode 100644 index 0000000..8137ffc --- /dev/null +++ b/Sources/iOS_Simulator/Demos/OperatorOverloading/Project1.dproj @@ -0,0 +1,271 @@ + + + {C55C11A6-3E14-4B9B-9595-24B90ECB6C08} + 15.2 + FMX + Project1.dpr + True + Debug + iOSSimulator + 89 + Application + + + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Cfg_1 + true + true + + + true + Base + true + + + true + true + true + System;Xml;Data;Datasnap;Web;Soap;$(DCC_Namespace) + true + true + true + true + true + true + true + .\$(Platform)\$(Config) + .\$(Platform)\$(Config) + false + false + false + false + false + + + $(BDS)\bin\Artwork\Android\FM_LauncherIcon_36x36.png + true + FireDACSqliteDriver;DBXSqliteDriver;fmx;IndySystem;DBXInterBaseDriver;DataSnapClient;DataSnapCommon;paxcomp_xe5;DataSnapProviderClient;DbxCommonDriver;dbxcds;fmxFireDAC;CustomIPTransport;dsnap;IndyCore;IndyIPCommon;CloudService;FmxTeeUI;FireDACIBDriver;FireDACDBXDriver;bindcompfmx;rtl;dbrtl;DbxClientDriver;FireDACCommon;bindcomp;xmlrtl;ibxpress;IndyProtocols;FireDACCommonDriver;bindengine;soaprtl;bindcompdbx;FMXTee;FireDAC;FireDACDataSnapDriver;inet;RESTComponents;dbexpress;IndyIPClient;$(DCC_UsePackage) + $(BDS)\bin\Artwork\Android\FM_LauncherIcon_72x72.png + $(BDS)\bin\Artwork\Android\FM_LauncherIcon_96x96.png + Debug + $(BDS)\bin\Artwork\Android\FM_LauncherIcon_144x144.png + package=com.embarcadero.$(MSBuildProjectName);label=$(MSBuildProjectName);versionCode=1;versionName=1.0.0;persistent=False;restoreAnyVersion=False;installLocation=preferExternal;largeHeap=False;theme=TitleBar + $(BDS)\bin\Artwork\Android\FM_LauncherIcon_48x48.png + + + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_768x1004.png + iPhoneAndiPad + $(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_40x40.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImage_640x1136.png + $(MSBuildProjectName) + $(BDS)\bin\Artwork\iOS\iPad\FM_SettingIcon_58x58.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_1024x748.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SettingIcon_29x29.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_60x60.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_50x50.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_80x80.png + FireDACSqliteDriver;DBXSqliteDriver;fmx;IndySystem;DBXInterBaseDriver;DataSnapClient;DataSnapCommon;DataSnapProviderClient;DbxCommonDriver;dbxcds;fmxFireDAC;CustomIPTransport;dsnap;fmxase;IndyCore;IndyIPCommon;CloudService;FmxTeeUI;FireDACIBDriver;FireDACDBXDriver;bindcompfmx;rtl;dbrtl;DbxClientDriver;FireDACCommon;bindcomp;xmlrtl;ibxpress;IndyProtocols;FireDACCommonDriver;bindengine;soaprtl;bindcompdbx;FMXTee;FireDAC;FireDACDataSnapDriver;inet;RESTComponents;dbexpress;IndyIPClient;$(DCC_UsePackage) + $(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_40x40.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImage_640x960.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_57x57.png + $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_72x72.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImage_320x480.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_1024x768.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_80x80.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_58x58.png + $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_152x152.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_1536x2008.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_2048x1496.png + $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_76x76.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_768x1024.png + Debug + $(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_29x29.png + $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_144x144.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_2048x1536.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_100x100.png + true + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_1536x2048.png + CFBundleName=$(MSBuildProjectName);CFBundleDevelopmentRegion=en;CFBundleDisplayName=$(MSBuildProjectName);CFBundleIdentifier=$(MSBuildProjectName);CFBundleInfoDictionaryVersion=6.0;CFBundleVersion=1.0.0.0;CFBundlePackageType=APPL;CFBundleSignature=????;LSRequiresIPhoneOS=true;CFBundleAllowMixedLocalizations=YES;CFBundleExecutable=$(MSBuildProjectName);UIDeviceFamily=iPhone & iPad;CFBundleResourceSpecification=ResourceRules.plist + $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_114x114.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_120x120.png + + + $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImage_640x1136.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_768x1004.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_60x60.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_40x40.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SettingIcon_29x29.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SettingIcon_58x58.png + iPhoneAndiPad + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_1024x748.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_50x50.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_80x80.png + FireDACSqliteDriver;DBXSqliteDriver;fmx;IndySystem;DBXInterBaseDriver;DataSnapClient;DataSnapCommon;DataSnapProviderClient;DbxCommonDriver;dbxcds;fmxFireDAC;CustomIPTransport;dsnap;fmxase;IndyCore;IndyIPCommon;CloudService;FmxTeeUI;FireDACIBDriver;FireDACDBXDriver;bindcompfmx;rtl;dbrtl;DbxClientDriver;FireDACCommon;bindcomp;xmlrtl;ibxpress;IndyProtocols;FireDACCommonDriver;bindengine;soaprtl;bindcompdbx;FMXTee;FireDAC;FireDACDataSnapDriver;inet;RESTComponents;dbexpress;IndyIPClient;$(DCC_UsePackage) + $(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_40x40.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImage_640x960.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_57x57.png + $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_72x72.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_LaunchImage_320x480.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_1024x768.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_1536x2008.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_80x80.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_29x29.png + $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_152x152.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_2048x1496.png + $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_76x76.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_SpotlightSearchIcon_58x58.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_768x1024.png + $(BDS)\bin\Artwork\iOS\iPad\FM_ApplicationIcon_144x144.png + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImageLandscape_2048x1536.png + $(BDS)\bin\Artwork\iOS\iPad\FM_SpotlightSearchIcon_100x100.png + true + $(BDS)\bin\Artwork\iOS\iPad\FM_LaunchImagePortrait_1536x2048.png + CFBundleName=$(MSBuildProjectName);CFBundleDevelopmentRegion=en;CFBundleDisplayName=$(MSBuildProjectName);CFBundleIdentifier=$(MSBuildProjectName);CFBundleInfoDictionaryVersion=6.0;CFBundleVersion=1.0.0.0;CFBundlePackageType=APPL;CFBundleSignature=????;LSRequiresIPhoneOS=true;CFBundleAllowMixedLocalizations=YES;CFBundleExecutable=$(MSBuildProjectName);UIDeviceFamily=iPhone & iPad;CFBundleResourceSpecification=ResourceRules.plist + $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_114x114.png + $(BDS)\bin\Artwork\iOS\iPhone\FM_ApplicationIcon_120x120.png + + + true + 1033 + FireDACSqliteDriver;DBXSqliteDriver;FireDACPgDriver;fmx;IndySystem;TeeDB;frx19;vclib;inetdbbde;DBXInterBaseDriver;DataSnapClient;DataSnapCommon;DataSnapServer;paxcomp_xe5;DataSnapProviderClient;DBXSybaseASEDriver;DbxCommonDriver;vclimg;dbxcds;DatasnapConnectorsFreePascal;MetropolisUILiveTile;vcldb;vcldsnap;fmxFireDAC;DBXDb2Driver;DBXOracleDriver;CustomIPTransport;vclribbon;dsnap;IndyIPServer;fmxase;vcl;IndyCore;IndyIPCommon;CloudService;DBXMSSQLDriver;FmxTeeUI;FireDACIBDriver;CodeSiteExpressPkg;FireDACDBXDriver;inetdbxpress;webdsnap;frxe19;FireDACDb2Driver;adortl;frxDB19;FireDACASADriver;bindcompfmx;vcldbx;FireDACODBCDriver;rtl;dbrtl;DbxClientDriver;FireDACCommon;bindcomp;inetdb;Tee;DBXOdbcDriver;vclFireDAC;xmlrtl;svnui;ibxpress;IndyProtocols;DBXMySQLDriver;FireDACCommonDriver;bindengine;vclactnband;soaprtl;bindcompdbx;FMXTee;TeeUI;bindcompvcl;vclie;FireDACADSDriver;vcltouch;VclSmp;FireDACMSSQLDriver;FireDAC;VCLRESTComponents;Intraweb;DBXInformixDriver;DataSnapConnectors;FireDACDataSnapDriver;dsnapcon;DBXFirebirdDriver;inet;fmxobj;FireDACMySQLDriver;vclx;svn;DBXSybaseASADriver;FireDACOracleDriver;fmxdae;RESTComponents;bdertl;FireDACMSAccDriver;DataSnapIndy10ServerTransport;dbexpress;IndyIPClient;$(DCC_UsePackage) + $(BDS)\bin\default_app.manifest + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments= + Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) + + + DEBUG;$(DCC_Define) + true + false + true + true + true + + + false + + + false + RELEASE;$(DCC_Define) + 0 + 0 + + + + MainSource + + +
Form1
+ fmx + + + Cfg_2 + Base + + + Base + + + Cfg_1 + Base + + + + Delphi.Personality.12 + + + + + False + False + 1 + 0 + 0 + 0 + False + False + False + False + False + 1033 + 1252 + + + + + 1.0.0.0 + + + + + + 1.0.0.0 + + + + + + + + + + + + + + + + + + + + + + + + + + + Project1.dpr + + + + + True + True + True + True + + + 12 + + + + diff --git a/Sources/iOS_Simulator/Demos/OperatorOverloading/Project1.res b/Sources/iOS_Simulator/Demos/OperatorOverloading/Project1.res new file mode 100644 index 0000000..36f26e2 Binary files /dev/null and b/Sources/iOS_Simulator/Demos/OperatorOverloading/Project1.res differ diff --git a/Sources/iOS_Simulator/Demos/OperatorOverloading/Unit1.fmx b/Sources/iOS_Simulator/Demos/OperatorOverloading/Unit1.fmx new file mode 100644 index 0000000..a927486 --- /dev/null +++ b/Sources/iOS_Simulator/Demos/OperatorOverloading/Unit1.fmx @@ -0,0 +1,51 @@ +object Form1: TForm1 + Left = 0 + Top = 0 + Caption = 'Form1' + ClientHeight = 567 + ClientWidth = 384 + FormFactor.Width = 320 + FormFactor.Height = 480 + FormFactor.Devices = [dkDesktop] + DesignerMobile = True + DesignerWidth = 384 + DesignerHeight = 592 + DesignerDeviceName = 'Google Nexus 4' + DesignerOrientation = 0 + DesignerOSVersion = '' + object Memo1: TMemo + Touch.InteractiveGestures = [igPan, igLongTap, igDoubleTap] + Height = 385.000000000000000000 + Position.X = 16.000000000000000000 + Position.Y = 16.000000000000000000 + TabOrder = 0 + Width = 281.000000000000000000 + Lines.Strings = ( + 'uses Unit1;' + 'var U, V: TMyRecord; I: Integer;' + 'begin' + ' print '#39'Output:'#39';' + ' V := TMyRecord(4); // explicit type cast' + ' I := Integer(V); // explicit type cast' + ' print I;' + ' U := 3; // implicit type cast' + ' V.x := 1;' + ' V.y := 2;' + ' U := U + V; // operation of addition' + ' print U.X, U.Y;' + ' I := V;' + ' print I;' + 'end.' + '') + end + object Button1: TButton + Height = 44.000000000000000000 + Position.X = 16.000000000000000000 + Position.Y = 408.000000000000000000 + TabOrder = 1 + Text = 'Run' + Trimming = ttCharacter + Width = 73.000000000000000000 + OnClick = Button1Click + end +end diff --git a/Sources/iOS_Simulator/Demos/OperatorOverloading/Unit1.pas b/Sources/iOS_Simulator/Demos/OperatorOverloading/Unit1.pas new file mode 100644 index 0000000..507f34c --- /dev/null +++ b/Sources/iOS_Simulator/Demos/OperatorOverloading/Unit1.pas @@ -0,0 +1,117 @@ +unit Unit1; + +interface + +uses + System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants, + FMX.Types, FMX.Controls, FMX.Forms, FMX.Graphics, FMX.Dialogs, FMX.StdCtrls, + FMX.Layouts, FMX.Memo, PaxCompiler, PaxRunner, PaxInterpreter; + +type + TForm1 = class(TForm) + Memo1: TMemo; + Button1: TButton; + procedure Button1Click(Sender: TObject); + private + { Private declarations } + procedure DoPrint(Sender: TPaxRunner; const S: String); + public + { Public declarations } + end; + + TMyRecord = record + x, y: Integer; + class operator Add(a, b: TMyRecord): TMyRecord; + class operator Subtract(a, b: TMyRecord): TMyRecord; + class operator Implicit(a: Integer): TMyRecord; + class operator Implicit(a: TMyRecord): Integer; + class operator Explicit(a: Integer): TMyRecord; + class operator Explicit(a: TMyRecord): Integer; + class operator Explicit(a: TMyRecord): Double; + end; + +var + Form1: TForm1; + +implementation + +{$R *.fmx} + +class operator TMyRecord.Add(a, b: TMyRecord): TMyRecord; +begin + result.x := a.x + b.x; + result.y := a.y + b.y; +end; + +class operator TMyRecord.Subtract(a, b: TMyRecord): TMyRecord; +begin + result.x := a.x - b.x; + result.y := a.y - b.y; +end; + +class operator TMyRecord.Implicit(a: Integer): TMyRecord; +begin + result.x := a; + result.y := 0; +end; + +class operator TMyRecord.Implicit(a: TMyRecord): Integer; +begin + result := a.x; +end; + +class operator TMyRecord.Explicit(a: Integer): TMyRecord; +begin + result.x := a; + result.y := 0; +end; + +class operator TMyRecord.Explicit(a: TMyRecord): Integer; +begin + result := a.x; +end; + +class operator TMyRecord.Explicit(a: TMyRecord): Double; +begin + result := a.x; +end; + +procedure TForm1.DoPrint(Sender: TPaxRunner; const S: String); +begin + Memo1.Lines.Add(S); +end; + +procedure Dummy(P: Pointer); begin end; + +procedure TForm1.Button1Click(Sender: TObject); +var + PaxCompiler1: TPaxCompiler; + PaxInterpreter1: TPaxInterpreter; + PaxPascalLanguage1: TPaxPascalLanguage; +begin + Dummy(TypeInfo(TMyRecord)); // just to punish Delphi to create RTTI for TMyRecord + + PaxCompiler1 := TPaxCompiler.Create(nil); + PaxInterpreter1 := TPaxInterpreter.Create(nil); + PaxPascalLanguage1 := TPaxPascalLanguage.Create(nil); + try + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + PaxCompiler1.AddModule('1', 'Pascal'); + PaxCompiler1.AddCode('1', Memo1.Lines.Text); + if PaxCompiler1.Compile(PaxInterpreter1) then + begin + PaxInterpreter1.OnPrintEvent := DoPrint; + PaxInterpreter1.Run; + end + else + begin + ShowMessage(PaxCompiler1.ErrorMessage[0]); + end; + finally + PaxCompiler1.Free; + PaxInterpreter1.Free; + PaxPascalLanguage1.Free; + end; +end; + +end. diff --git a/Sources/iOS_Simulator/Demos/Scripts/Basic/Callback.bas b/Sources/iOS_Simulator/Demos/Scripts/Basic/Callback.bas new file mode 100644 index 0000000..35926b7 --- /dev/null +++ b/Sources/iOS_Simulator/Demos/Scripts/Basic/Callback.bas @@ -0,0 +1,26 @@ +Imports Classes + +Function Compare Register(Item1 As Integer, Item2 As Integer) As Integer + If CInt(Item1) > CInt(Item2) Then + Return 1 + ElseIf CInt(Item1) < CInt(Item2) Then + Return -1 + Else + Return 0 + End If +End Function + +Dim L As TList +Dim I As Integer +L = New TList() +L.Add(Pointer(3)) +L.Add(Pointer(1)) +L.Add(Pointer(2)) +L.Add(Pointer(6)) +L.Add(Pointer(4)) +L.Add(Pointer(5)) +L.Sort(AddressOf Compare) +For I=0 To L.Count - 1 + println Integer(L[I]) +Next +L.Free diff --git a/Sources/iOS_Simulator/Demos/Scripts/Basic/DefaultParameters.bas b/Sources/iOS_Simulator/Demos/Scripts/Basic/DefaultParameters.bas new file mode 100644 index 0000000..566f6b8 --- /dev/null +++ b/Sources/iOS_Simulator/Demos/Scripts/Basic/DefaultParameters.bas @@ -0,0 +1,9 @@ +Sub Test(X As Integer, S As Single = 12.5, _ + C As Char = "W", Str As String = "abc") + println X:10, S:10:2, " ", C, " ", Str +End Sub + +Test(5, 5, "a", "a") +Test(5, 5, "a") +Test(5, 5) +Test(5) diff --git a/Sources/iOS_Simulator/Demos/Scripts/Basic/Exceptions.bas b/Sources/iOS_Simulator/Demos/Scripts/Basic/Exceptions.bas new file mode 100644 index 0000000..33d2002 --- /dev/null +++ b/Sources/iOS_Simulator/Demos/Scripts/Basic/Exceptions.bas @@ -0,0 +1,9 @@ +Imports SysUtils +Dim X as Single = 0 +Try + X = X / X + Catch E As Exception + println E.Message + Finally + println "ok" +End Try \ No newline at end of file diff --git a/Sources/iOS_Simulator/Demos/Scripts/Basic/GenericTypes.bas b/Sources/iOS_Simulator/Demos/Scripts/Basic/GenericTypes.bas new file mode 100644 index 0000000..e5afbcd --- /dev/null +++ b/Sources/iOS_Simulator/Demos/Scripts/Basic/GenericTypes.bas @@ -0,0 +1,17 @@ +Imports Classes + +Class SomeClass + Dim X As T +End Class + +Structure GenPoint + X As R + Y As R +End Structure + +Dim P As New SomeClass +P.X = New TPersistent +Dim W As GenPoint +W.X = 2 +W.Y = 3 +println W.X, " ", W.Y \ No newline at end of file diff --git a/Sources/iOS_Simulator/Demos/Scripts/Basic/anonymous_function.bas b/Sources/iOS_Simulator/Demos/Scripts/Basic/anonymous_function.bas new file mode 100644 index 0000000..6315592 --- /dev/null +++ b/Sources/iOS_Simulator/Demos/Scripts/Basic/anonymous_function.bas @@ -0,0 +1,10 @@ +TypeDef MyFuncOfInt As Reference To Function (X As Integer) As Integer + +Function G(z As Word) As MyFuncOfInt + Return Function (x As Integer) As Integer + Return x + z + End Function +End Function + +Dim F As MyFuncOfInt = G(3) +println F(7) diff --git a/Sources/iOS_Simulator/Demos/Scripts/Basic/lambda_expression.bas b/Sources/iOS_Simulator/Demos/Scripts/Basic/lambda_expression.bas new file mode 100644 index 0000000..34687eb --- /dev/null +++ b/Sources/iOS_Simulator/Demos/Scripts/Basic/lambda_expression.bas @@ -0,0 +1,8 @@ +TypeDef MyFuncOfInt As Reference To Function (X As Integer) As Integer + +Function G(z As Word) As MyFuncOfInt + Return Lambda x => x + z +End Function + +Dim F As MyFuncOfInt = G(3) +println F(7) diff --git a/Sources/iOS_Simulator/Demos/Scripts/Basic/type_Interface.bas b/Sources/iOS_Simulator/Demos/Scripts/Basic/type_Interface.bas new file mode 100644 index 0000000..33004b2 --- /dev/null +++ b/Sources/iOS_Simulator/Demos/Scripts/Basic/type_Interface.bas @@ -0,0 +1,25 @@ +Interface IMyInterface + Sub P(X As Integer, Y As Integer) +End Interface + +Class TMyClass + + Inherits TInterfacedObject, IMyInterface + + Sub P(X As Integer, Y As Integer) + print "Here" + print Me.ClassName + print X, " ", Y + End Sub + + Sub Finalize + print "Done" + MyBase.Destroy + End Sub + +End Class + +Dim X As TMyClass = New TMyClass +Dim I As IMyInterface +I = X +I.P(3, 4) diff --git a/Sources/iOS_Simulator/Demos/Scripts/Basic/type_class.bas b/Sources/iOS_Simulator/Demos/Scripts/Basic/type_class.bas new file mode 100644 index 0000000..897db97 --- /dev/null +++ b/Sources/iOS_Simulator/Demos/Scripts/Basic/type_class.bas @@ -0,0 +1,29 @@ +Imports Classes + +Class MyStrings + + Inherits TStringList + + Private fLastPos As Integer = -1 + + Public Overrides Function IndexOf(S As String) As Integer + fLastPos = MyBase.IndexOf(S) + return fLastPos + End Function + + Public Property LastPos As Integer + Get + return fLastPos + End Get + End Property +End Class + +Dim l As MyStrings = New MyStrings() +Dim P As Integer +l.Add("abc") +l.Add("pqr") +l.Add("xyz") +print l.LastPos +P = l.IndexOf("pqr") +print P +print l.LastPos diff --git a/Sources/iOS_Simulator/Demos/Scripts/JavaScript/ArrayLiterals.js b/Sources/iOS_Simulator/Demos/Scripts/JavaScript/ArrayLiterals.js new file mode 100644 index 0000000..ad6870d --- /dev/null +++ b/Sources/iOS_Simulator/Demos/Scripts/JavaScript/ArrayLiterals.js @@ -0,0 +1,3 @@ +a = [10, 20, ]; +for (i in a) + print(a[i]); \ No newline at end of file diff --git a/Sources/iOS_Simulator/Demos/Scripts/JavaScript/Encapsulation.js b/Sources/iOS_Simulator/Demos/Scripts/JavaScript/Encapsulation.js new file mode 100644 index 0000000..5d595d1 --- /dev/null +++ b/Sources/iOS_Simulator/Demos/Scripts/JavaScript/Encapsulation.js @@ -0,0 +1,43 @@ +// encapsulation + +function MyClass() +{ + this.m_data = 5; + this.m_text = "Hello World"; + this.SetData = SetData; + this.SetText = SetText; + this.ShowData = DisplayData; + this.ShowText = DisplayText; + + function DisplayData() + { + print( this.m_data ); + } + + function DisplayText() + { + print( this.m_text ); + return; + } + + function SetData( myVal ) + { + this.m_data = myVal; + } + + function SetText( myText ) + { + this.m_text = myText; + } +} + +var myClassObj1 = new MyClass(); +var myClassObj2 = new MyClass(); +myClassObj1.SetData( 10 ); +myClassObj1.SetText( "Obj1: Hello World" ); +myClassObj2.SetData( 20 ); +myClassObj2.SetText( "Obj2: Hello World" ); +myClassObj1.ShowData(); // displays: 10 +myClassObj1.ShowText(); // displays: "Obj1: Hello World" +myClassObj2.ShowData(); // displays: 20 +myClassObj2.ShowText(); // displays: "Obj2: Hello World" \ No newline at end of file diff --git a/Sources/iOS_Simulator/Demos/Scripts/JavaScript/FunctionObject.js b/Sources/iOS_Simulator/Demos/Scripts/JavaScript/FunctionObject.js new file mode 100644 index 0000000..5dc675a --- /dev/null +++ b/Sources/iOS_Simulator/Demos/Scripts/JavaScript/FunctionObject.js @@ -0,0 +1,13 @@ +function f(g, x) +{ + return g(x); +} + +function p(x) +{ + return x + x; +} + +print(f(p, 5)); + + diff --git a/Sources/iOS_Simulator/Demos/Scripts/JavaScript/HostClasses.js b/Sources/iOS_Simulator/Demos/Scripts/JavaScript/HostClasses.js new file mode 100644 index 0000000..778338c --- /dev/null +++ b/Sources/iOS_Simulator/Demos/Scripts/JavaScript/HostClasses.js @@ -0,0 +1,15 @@ +using Classes; +x = new TStringList(); +x.Add("abc"); +var i; +with (x) +{ + i = Add("http://www.paxcompiler.com"); +} +print(i); + + + + + + diff --git a/Sources/iOS_Simulator/Demos/Scripts/JavaScript/ObjectLiterals.js b/Sources/iOS_Simulator/Demos/Scripts/JavaScript/ObjectLiterals.js new file mode 100644 index 0000000..4b22fdd --- /dev/null +++ b/Sources/iOS_Simulator/Demos/Scripts/JavaScript/ObjectLiterals.js @@ -0,0 +1,3 @@ +x = {'abc': 100, 'pqr': 200}; +for (var i in x) + print(x[i]); \ No newline at end of file diff --git a/Sources/iOS_Simulator/Demos/Scripts/JavaScript/With_Stmt.js b/Sources/iOS_Simulator/Demos/Scripts/JavaScript/With_Stmt.js new file mode 100644 index 0000000..9662899 --- /dev/null +++ b/Sources/iOS_Simulator/Demos/Scripts/JavaScript/With_Stmt.js @@ -0,0 +1,14 @@ +var x = new String; +for (i=0; i <100000; i++) +with (x) +{ + y = anchor("http://www.paxcompiler.com"); +} +println(y); + + + + + + + diff --git a/Sources/iOS_Simulator/Demos/Scripts/JavaScript/closure.js b/Sources/iOS_Simulator/Demos/Scripts/JavaScript/closure.js new file mode 100644 index 0000000..a193f89 --- /dev/null +++ b/Sources/iOS_Simulator/Demos/Scripts/JavaScript/closure.js @@ -0,0 +1,9 @@ +function foo(x) { + var tmp = 3; + this.bar = bar; + function bar(y) { + print(x + y + (++tmp)); + } + bar(10); +} +foo(2); diff --git a/Sources/iOS_Simulator/Demos/Scripts/JavaScript/closure2.js b/Sources/iOS_Simulator/Demos/Scripts/JavaScript/closure2.js new file mode 100644 index 0000000..efa66c0 --- /dev/null +++ b/Sources/iOS_Simulator/Demos/Scripts/JavaScript/closure2.js @@ -0,0 +1,7 @@ +function sayHello2(name) { + var text = 'Hello ' + name; // Local variable + var sayAlert = function() { alert(text); }; + return sayAlert; +} +say2 = sayHello2('Bob'); +say2(); // alerts "Hello Bob" \ No newline at end of file diff --git a/Sources/iOS_Simulator/Demos/Scripts/JavaScript/namespace.js b/Sources/iOS_Simulator/Demos/Scripts/JavaScript/namespace.js new file mode 100644 index 0000000..5cc6b8e --- /dev/null +++ b/Sources/iOS_Simulator/Demos/Scripts/JavaScript/namespace.js @@ -0,0 +1,14 @@ +var yourNamespace = { + + foo: function() + { + print 1; + }, + + bar: function() + { + print 2; + } +}; + +yourNamespace.foo(); \ No newline at end of file diff --git a/Sources/iOS_Simulator/Demos/Scripts/JavaScript/namespace2.js b/Sources/iOS_Simulator/Demos/Scripts/JavaScript/namespace2.js new file mode 100644 index 0000000..9cd0f79 --- /dev/null +++ b/Sources/iOS_Simulator/Demos/Scripts/JavaScript/namespace2.js @@ -0,0 +1,14 @@ +var ns = new function() { + + var a = 5; + + var internalFunction = function() { + print 1; + }; + + this.publicFunction = function() { + print 2; + }; +}; + +ns.publicFunction(); \ No newline at end of file diff --git a/Sources/iOS_Simulator/Demos/Scripts/JavaScript/sieve.js b/Sources/iOS_Simulator/Demos/Scripts/JavaScript/sieve.js new file mode 100644 index 0000000..f2a2f88 --- /dev/null +++ b/Sources/iOS_Simulator/Demos/Scripts/JavaScript/sieve.js @@ -0,0 +1,32 @@ +println("Eratosthenes Sieve prime number calculation"); + +size = 8190; +sizepl = 8191; + +var flags = new Array(sizepl); + +var i, prime, k, count, iter; + +print("10 iterations"); +starttime = new Date(); +for (iter = 1; iter <= 10; iter++) +{ count = 0; + for (i = 0; i <= size; i++) + flags[i] = true; + for (i = 0; i <= size; i++) + { if (flags[i]) + { prime = i + i + 3; + k = i + prime; + while (k <= size) + { + flags[k] = false; + k += prime; + } + count += 1; + } + } +} + +elapsedtime = new Date() - starttime; +println(count + " primes"); +println("elapsed time = " + elapsedtime); diff --git a/Sources/iOS_Simulator/Demos/Scripts/Pascal/Callback.pas b/Sources/iOS_Simulator/Demos/Scripts/Pascal/Callback.pas new file mode 100644 index 0000000..781cf76 --- /dev/null +++ b/Sources/iOS_Simulator/Demos/Scripts/Pascal/Callback.pas @@ -0,0 +1,28 @@ +uses Classes; + +function Compare(Item1, Item2: Pointer): Integer; register; +begin + if Integer(Item1) > Integer(Item2) then + result := 1 + else if Integer(Item1) < Integer(Item2) then + result := -1 + else + result := 0; +end; + +var + L: TList; + I: Integer; +begin + L := TList.Create; + L.Add(Pointer(3)); + L.Add(Pointer(1)); + L.Add(Pointer(2)); + L.Add(Pointer(6)); + L.Add(Pointer(4)); + L.Add(Pointer(5)); + L.Sort(@Compare); + for I:=0 to L.Count - 1 do + print(Integer(L[I])); + L.Free; +end. diff --git a/Sources/iOS_Simulator/Demos/Scripts/Pascal/Generic_types.pas b/Sources/iOS_Simulator/Demos/Scripts/Pascal/Generic_types.pas new file mode 100644 index 0000000..4ecb3f2 --- /dev/null +++ b/Sources/iOS_Simulator/Demos/Scripts/Pascal/Generic_types.pas @@ -0,0 +1,21 @@ +uses + Classes; +type + TGenClass = class + Value : T; + procedure Z(L: T); + end; + +procedure TGenClass.Z(L: T); +begin + print L.InstanceSize; + print L.ClassName; +end; +var + X: TGenClass; + Y: TStringList; +begin + X := TGenClass.Create; + Y := TStringList.Create; + X.Z(Y); +end. \ No newline at end of file diff --git a/Sources/iOS_Simulator/Demos/Scripts/Pascal/ScriptClasses.pas b/Sources/iOS_Simulator/Demos/Scripts/Pascal/ScriptClasses.pas new file mode 100644 index 0000000..56bee75 --- /dev/null +++ b/Sources/iOS_Simulator/Demos/Scripts/Pascal/ScriptClasses.pas @@ -0,0 +1,21 @@ +uses + Classes; +type + TMyComponent = class(TComponent) + procedure Show; virtual; abstract; + end; + TMyClass = class(TMyComponent) + procedure Show; override; + end; +procedure TMyClass.Show; +begin + print ClassName; +end; +var + X: TMyComponent; +begin + X := TMyClass.Create(nil); + X.Name := 'abc'; + print X.Name; + X.Show; +end. diff --git a/Sources/iOS_Simulator/Demos/Scripts/Pascal/Test_Interfaces.pas b/Sources/iOS_Simulator/Demos/Scripts/Pascal/Test_Interfaces.pas new file mode 100644 index 0000000..f4a3b37 --- /dev/null +++ b/Sources/iOS_Simulator/Demos/Scripts/Pascal/Test_Interfaces.pas @@ -0,0 +1,36 @@ +program Test; +type + IMyInterface = interface(IUnknown) + ['{E7AA427A-0F4D-4A96-A914-FAB1CA336337}'] + procedure P(X, Y: Integer); + end; + TMyClass = class(TInterfacedObject, IMyInterface) + constructor Create; + procedure P(X, Y: Integer); + destructor Destroy; override; + end; + +constructor TMyClass.Create; +begin + inherited; + print('Created'); +end; + +procedure TMyClass.P(X, Y: Integer); +begin + print(Self.ClassName); + print X, Y; +end; +destructor TMyClass.Destroy; +begin + print 'Done'; + inherited; +end; +var + I: IMyInterface; + X: TMyClass; +begin + X := TMyClass.Create; + I := X; + I.P(3, 4); +end. \ No newline at end of file diff --git a/Sources/iOS_Simulator/Demos/Scripts/Pascal/anonymous_function.pas b/Sources/iOS_Simulator/Demos/Scripts/Pascal/anonymous_function.pas new file mode 100644 index 0000000..653f721 --- /dev/null +++ b/Sources/iOS_Simulator/Demos/Scripts/Pascal/anonymous_function.pas @@ -0,0 +1,17 @@ +type + TFuncOfInt = reference to function(x: T): Integer; + +function G(z: Word): TFuncOfInt; +begin + result := function(x: Integer): Integer + begin + result := x + z; + end; +end; + +var + x: TFuncOfInt; +begin + x := G(3); + print x(7); +end. \ No newline at end of file diff --git a/Sources/iOS_Simulator/Demos/Scripts/Pascal/lambda_expression.pas b/Sources/iOS_Simulator/Demos/Scripts/Pascal/lambda_expression.pas new file mode 100644 index 0000000..2505d09 --- /dev/null +++ b/Sources/iOS_Simulator/Demos/Scripts/Pascal/lambda_expression.pas @@ -0,0 +1,14 @@ +type + TFuncOfInt = reference to function(x, y: Integer): Integer; + +procedure H(const A: array of Integer; r: TFuncOfInt); +var + I: Integer; +begin + for I in A do + print r(I, 1); +end; + +begin + H([10, 20, 30], lambda x, y => x + y); +end. \ No newline at end of file diff --git a/Sources/iOS_Simulator/Demos/Scripts/Pascal/test_Interfaces2.pas b/Sources/iOS_Simulator/Demos/Scripts/Pascal/test_Interfaces2.pas new file mode 100644 index 0000000..56b24a9 --- /dev/null +++ b/Sources/iOS_Simulator/Demos/Scripts/Pascal/test_Interfaces2.pas @@ -0,0 +1,42 @@ +program P; +type + IMyPropInterface = interface + function GetName: String; + end; + + TMyPropInterface = class + function GetName: String; + end; + + TMyClass = class(TInterfacedObject, IMyPropInterface) + private + fMyPropInterface: TMyPropInterface; + public + constructor Create; + property MyPropInterface: TMyPropInterface + read fMyPropInterface + write fMyPropInterface + implements IMyPropInterface; + end; + +function TMyPropInterface.GetName: String; +begin + result := 'abc'; +end; + +constructor TMyClass.Create; +begin + inherited; + MyPropInterface := TMyPropInterface.Create; +end; + +var + X: TMyClass; + I: IMyPropInterface; +begin + X := TMyClass.Create; + I := X; + print I.GetName(); +end. + + diff --git a/Sources/iOS_Simulator/packages/xe5/paxcomp_ios_sim_xe5.dpk b/Sources/iOS_Simulator/packages/xe5/paxcomp_ios_sim_xe5.dpk new file mode 100644 index 0000000..51eca52 --- /dev/null +++ b/Sources/iOS_Simulator/packages/xe5/paxcomp_ios_sim_xe5.dpk @@ -0,0 +1,36 @@ +package paxcomp_ios_sim_xe5; + +{$R *.res} +{$IFDEF IMPLICITBUILDING This IFDEF should not be used by users} +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION OFF} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES ON} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$DEFINE DEBUG} +{$ENDIF IMPLICITBUILDING} +{$IMPLICITBUILD ON} + +requires + rtl; + +contains + PaxCompilerRegister in 'PaxCompilerRegister.pas'; + +end. diff --git a/Sources/iOS_Simulator/packages/xe5/paxcomp_ios_sim_xe5.dproj b/Sources/iOS_Simulator/packages/xe5/paxcomp_ios_sim_xe5.dproj new file mode 100644 index 0000000..a724b84 --- /dev/null +++ b/Sources/iOS_Simulator/packages/xe5/paxcomp_ios_sim_xe5.dproj @@ -0,0 +1,191 @@ + + + {5491B9BF-052D-4D1F-AB9A-A68DAB5F1F92} + paxcomp_ios_sim_xe5.dpk + 15.2 + None + True + Debug + iOSSimulator + 9 + Package + + + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Cfg_1 + true + true + + + true + Base + true + + + System;Xml;Data;Datasnap;Web;Soap;$(DCC_Namespace) + true + true + All + .\$(Platform)\$(Config) + .\$(Platform)\$(Config) + false + false + false + false + false + + + None + + + None + + + None + iPhoneAndiPad + CFBundleName=$(MSBuildProjectName);CFBundleDevelopmentRegion=en;CFBundleDisplayName=$(MSBuildProjectName);CFBundleIdentifier=$(MSBuildProjectName);CFBundleInfoDictionaryVersion=6.0;CFBundleVersion=1.0.0.0;CFBundlePackageType=APPL;CFBundleSignature=????;LSRequiresIPhoneOS=true;CFBundleAllowMixedLocalizations=YES;CFBundleExecutable=$(MSBuildProjectName);UIDeviceFamily=iPhone & iPad;CFBundleResourceSpecification=ResourceRules.plist + true + + + true + 1033 + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments= + Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) + + + DEBUG;$(DCC_Define) + true + false + true + true + true + + + false + + + false + RELEASE;$(DCC_Define) + 0 + 0 + + + + MainSource + + + + + Cfg_2 + Base + + + Base + + + Cfg_1 + Base + + + + Delphi.Personality.12 + Package + + + + paxcomp_ios_sim_xe5.dpk + + + True + False + 1 + 0 + 0 + 0 + False + False + False + False + False + 1033 + 1252 + + + + + 1.0.0.0 + + + + + + 1.0.0.0 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + False + False + True + False + True + False + + + 12 + + + + diff --git a/Sources/iOS_Simulator/packages/xe5/paxcomp_ios_sim_xe5.res b/Sources/iOS_Simulator/packages/xe5/paxcomp_ios_sim_xe5.res new file mode 100644 index 0000000..36f26e2 Binary files /dev/null and b/Sources/iOS_Simulator/packages/xe5/paxcomp_ios_sim_xe5.res differ diff --git a/Sources/iOS_Simulator/packages/xe6/paxcomp_ios_sim_xe6.dpk b/Sources/iOS_Simulator/packages/xe6/paxcomp_ios_sim_xe6.dpk new file mode 100644 index 0000000..64501a1 --- /dev/null +++ b/Sources/iOS_Simulator/packages/xe6/paxcomp_ios_sim_xe6.dpk @@ -0,0 +1,36 @@ +package paxcomp_ios_sim_xe6; + +{$R *.res} +{$IFDEF IMPLICITBUILDING This IFDEF should not be used by users} +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO OFF} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION OFF} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES ON} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$DEFINE DEBUG} +{$ENDIF IMPLICITBUILDING} +{$IMPLICITBUILD ON} + +requires + rtl; + +contains + PaxCompilerRegister in 'PaxCompilerRegister.pas'; + +end. diff --git a/Sources/iOS_Simulator/packages/xe6/paxcomp_ios_sim_xe6.dproj b/Sources/iOS_Simulator/packages/xe6/paxcomp_ios_sim_xe6.dproj new file mode 100644 index 0000000..ce41c0a --- /dev/null +++ b/Sources/iOS_Simulator/packages/xe6/paxcomp_ios_sim_xe6.dproj @@ -0,0 +1,130 @@ + + + {6F76EE81-3219-496E-8012-8CB8A3FDA736} + paxcomp_ios_sim_xe6.dpk + True + Debug + 9 + Package + None + 15.4 + iOSSimulator + + + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Cfg_2 + true + true + + + false + false + true + 00400000 + System;Xml;Data;Datasnap;Web;Soap;$(DCC_Namespace) + false + false + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=;CFBundleName= + paxcomp_ios_sim_xe6 + true + false + 1033 + + + Debug + package=com.embarcadero.$(MSBuildProjectName);label=$(MSBuildProjectName);versionCode=1;versionName=1.0.0;persistent=False;restoreAnyVersion=False;installLocation=preferExternal;largeHeap=False;theme=TitleBar;hardwareAccelerated=true + + + iPhoneAndiPad + true + CFBundleName=$(MSBuildProjectName);CFBundleDevelopmentRegion=en;CFBundleDisplayName=$(MSBuildProjectName);CFBundleIdentifier=$(MSBuildProjectName);CFBundleInfoDictionaryVersion=6.0;CFBundleVersion=1.0.0.0;CFBundlePackageType=APPL;CFBundleSignature=????;LSRequiresIPhoneOS=true;CFBundleAllowMixedLocalizations=YES;CFBundleExecutable=$(MSBuildProjectName);UIDeviceFamily=iPhone & iPad;CFBundleResourceSpecification=ResourceRules.plist + + + true + Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments= + 1033 + + + 0 + false + 0 + RELEASE;$(DCC_Define) + + + true + false + DEBUG;$(DCC_Define) + + + true + + + + MainSource + + + + + Cfg_2 + Base + + + Base + + + Cfg_1 + Base + + + + Delphi.Personality.12 + Package + + + + paxcomp_ios_sim_xe6.dpk + + + + False + False + True + False + True + False + + + 12 + + + + diff --git a/Sources/iOS_Simulator/packages/xe6/paxcomp_ios_sim_xe6.res b/Sources/iOS_Simulator/packages/xe6/paxcomp_ios_sim_xe6.res new file mode 100644 index 0000000..36f26e2 Binary files /dev/null and b/Sources/iOS_Simulator/packages/xe6/paxcomp_ios_sim_xe6.res differ diff --git a/Sources/iOS_Simulator/packages/xe7/paxcomp_ios_sim_xe7.dpk b/Sources/iOS_Simulator/packages/xe7/paxcomp_ios_sim_xe7.dpk new file mode 100644 index 0000000..9a9465e --- /dev/null +++ b/Sources/iOS_Simulator/packages/xe7/paxcomp_ios_sim_xe7.dpk @@ -0,0 +1,36 @@ +package paxcomp_ios_sim_xe7; + +{$R *.res} +{$IFDEF IMPLICITBUILDING This IFDEF should not be used by users} +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO OFF} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION OFF} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES ON} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$DEFINE DEBUG} +{$ENDIF IMPLICITBUILDING} +{$IMPLICITBUILD ON} + +requires + rtl; + +contains + PaxCompilerRegister in 'PaxCompilerRegister.pas'; + +end. diff --git a/Sources/iOS_Simulator/packages/xe7/paxcomp_ios_sim_xe7.dproj b/Sources/iOS_Simulator/packages/xe7/paxcomp_ios_sim_xe7.dproj new file mode 100644 index 0000000..5e8c6c9 --- /dev/null +++ b/Sources/iOS_Simulator/packages/xe7/paxcomp_ios_sim_xe7.dproj @@ -0,0 +1,130 @@ + + + {509BD1DF-9097-4B16-881E-6458CDA224D3} + paxcomp_ios_sim_xe7.dpk + True + Debug + 9 + Package + None + 16.0 + iOSSimulator + + + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Cfg_2 + true + true + + + false + paxcomp_ios_sim_xe7 + true + false + false + true + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=;CFBundleName= + System;Xml;Data;Datasnap;Web;Soap;$(DCC_Namespace) + false + 1033 + false + 00400000 + + + Debug + package=com.embarcadero.$(MSBuildProjectName);label=$(MSBuildProjectName);versionCode=1;versionName=1.0.0;persistent=False;restoreAnyVersion=False;installLocation=preferExternal;largeHeap=False;theme=TitleBar;hardwareAccelerated=true + + + iPhoneAndiPad + true + CFBundleName=$(MSBuildProjectName);CFBundleDevelopmentRegion=en;CFBundleDisplayName=$(MSBuildProjectName);CFBundleIdentifier=$(MSBuildProjectName);CFBundleInfoDictionaryVersion=7.1;CFBundleVersion=1.0.0.0;CFBundlePackageType=APPL;CFBundleSignature=????;LSRequiresIPhoneOS=true;CFBundleAllowMixedLocalizations=YES;CFBundleExecutable=$(MSBuildProjectName);UIDeviceFamily=iPhone & iPad;CFBundleResourceSpecification=ResourceRules.plist + + + 1033 + true + CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments= + Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) + + + 0 + false + RELEASE;$(DCC_Define) + 0 + + + true + DEBUG;$(DCC_Define) + false + + + true + + + + MainSource + + + + + Cfg_2 + Base + + + Base + + + Cfg_1 + Base + + + + Delphi.Personality.12 + Package + + + + paxcomp_ios_sim_xe7.dpk + + + + False + False + True + False + True + False + + + 12 + + + + diff --git a/Sources/iOS_Simulator/packages/xe7/paxcomp_ios_sim_xe7.res b/Sources/iOS_Simulator/packages/xe7/paxcomp_ios_sim_xe7.res new file mode 100644 index 0000000..36f26e2 Binary files /dev/null and b/Sources/iOS_Simulator/packages/xe7/paxcomp_ios_sim_xe7.res differ diff --git a/Sources/iOS_Simulator/packages/xe7/paxcompiler.dcr b/Sources/iOS_Simulator/packages/xe7/paxcompiler.dcr new file mode 100644 index 0000000..4bcc339 Binary files /dev/null and b/Sources/iOS_Simulator/packages/xe7/paxcompiler.dcr differ diff --git a/Sources/lazarus32/Demos/Demos/BindLfm/project1.ico b/Sources/lazarus32/Demos/Demos/BindLfm/project1.ico new file mode 100644 index 0000000..0341321 Binary files /dev/null and b/Sources/lazarus32/Demos/Demos/BindLfm/project1.ico differ diff --git a/Sources/lazarus32/Demos/Demos/BindLfm/project1.lpi b/Sources/lazarus32/Demos/Demos/BindLfm/project1.lpi new file mode 100644 index 0000000..be247c4 --- /dev/null +++ b/Sources/lazarus32/Demos/Demos/BindLfm/project1.lpi @@ -0,0 +1,95 @@ + + + + + + + + + + <ResourceType Value="res"/> + <UseXPManifest Value="True"/> + <Icon Value="0"/> + </General> + <i18n> + <EnableI18N LFM="False"/> + </i18n> + <VersionInfo> + <StringTable ProductVersion=""/> + </VersionInfo> + <BuildModes Count="1"> + <Item1 Name="Default" Default="True"/> + </BuildModes> + <PublishOptions> + <Version Value="2"/> + <IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/> + <ExcludeFileFilter Value="*.(bak|ppu|o|so);*~;backup"/> + </PublishOptions> + <RunParams> + <local> + <FormatVersion Value="1"/> + </local> + </RunParams> + <RequiredPackages Count="2"> + <Item1> + <PackageName Value="paxcomp_lazarus32"/> + </Item1> + <Item2> + <PackageName Value="LCL"/> + </Item2> + </RequiredPackages> + <Units Count="2"> + <Unit0> + <Filename Value="project1.lpr"/> + <IsPartOfProject Value="True"/> + <UnitName Value="project1"/> + </Unit0> + <Unit1> + <Filename Value="unit1.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="Form1"/> + <HasResources Value="True"/> + <ResourceBaseClass Value="Form"/> + <UnitName Value="Unit1"/> + </Unit1> + </Units> + </ProjectOptions> + <CompilerOptions> + <Version Value="11"/> + <PathDelim Value="\"/> + <Target> + <Filename Value="project1"/> + </Target> + <SearchPaths> + <IncludeFiles Value="$(ProjOutDir)"/> + <OtherUnitFiles Value="..\..\IMPORT"/> + <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/> + </SearchPaths> + <Linking> + <Options> + <Win32> + <GraphicApplication Value="True"/> + </Win32> + </Options> + </Linking> + <Other> + <CompilerMessages> + <MsgFileName Value=""/> + </CompilerMessages> + <CompilerPath Value="$(CompPath)"/> + </Other> + </CompilerOptions> + <Debugging> + <Exceptions Count="3"> + <Item1> + <Name Value="EAbort"/> + </Item1> + <Item2> + <Name Value="ECodetoolError"/> + </Item2> + <Item3> + <Name Value="EFOpenError"/> + </Item3> + </Exceptions> + </Debugging> +</CONFIG> diff --git a/Sources/lazarus32/Demos/Demos/BindLfm/project1.lpr b/Sources/lazarus32/Demos/Demos/BindLfm/project1.lpr new file mode 100644 index 0000000..ced6d82 --- /dev/null +++ b/Sources/lazarus32/Demos/Demos/BindLfm/project1.lpr @@ -0,0 +1,21 @@ +program project1; + +{$mode objfpc}{$H+} + +uses + {$IFDEF UNIX}{$IFDEF UseCThreads} + cthreads, + {$ENDIF}{$ENDIF} + Interfaces, // this includes the LCL widgetset + Forms, Unit1 + { you can add units after this }; + +{$R *.res} + +begin + RequireDerivedFormResource := True; + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. + diff --git a/Sources/lazarus32/Demos/Demos/BindLfm/project1.lps b/Sources/lazarus32/Demos/Demos/BindLfm/project1.lps new file mode 100644 index 0000000..4f2c9c5 --- /dev/null +++ b/Sources/lazarus32/Demos/Demos/BindLfm/project1.lps @@ -0,0 +1,85 @@ +<?xml version="1.0"?> +<CONFIG> + <ProjectSession> + <PathDelim Value="\"/> + <Version Value="9"/> + <BuildModes Active="Default"/> + <Units Count="7"> + <Unit0> + <Filename Value="project1.lpr"/> + <IsPartOfProject Value="True"/> + <UnitName Value="project1"/> + <UsageCount Value="20"/> + </Unit0> + <Unit1> + <Filename Value="unit1.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="Form1"/> + <HasResources Value="True"/> + <ResourceBaseClass Value="Form"/> + <UnitName Value="Unit1"/> + <IsVisibleTab Value="True"/> + <EditorIndex Value="0"/> + <WindowIndex Value="0"/> + <TopLine Value="1"/> + <CursorPos X="56" Y="9"/> + <UsageCount Value="20"/> + <Loaded Value="True"/> + <LoadedDesigner Value="True"/> + </Unit1> + <Unit2> + <Filename Value="..\..\paxcomp_lazarus32\PAXCOMP_KERNEL.pas"/> + <UnitName Value="PAXCOMP_KERNEL"/> + <WindowIndex Value="0"/> + <TopLine Value="899"/> + <CursorPos X="1" Y="909"/> + <UsageCount Value="10"/> + </Unit2> + <Unit3> + <Filename Value="..\..\paxcomp_lazarus32\PAXCOMP_SYS.pas"/> + <UnitName Value="PAXCOMP_SYS"/> + <WindowIndex Value="0"/> + <TopLine Value="3570"/> + <CursorPos X="1" Y="3580"/> + <UsageCount Value="10"/> + </Unit3> + <Unit4> + <Filename Value="..\..\paxcomp_lazarus32\PAXCOMP_BASERUNNER.pas"/> + <UnitName Value="PAXCOMP_BASERUNNER"/> + <WindowIndex Value="0"/> + <TopLine Value="1626"/> + <CursorPos X="1" Y="1637"/> + <UsageCount Value="10"/> + </Unit4> + <Unit5> + <Filename Value="C:\laz32\lcl\include\control.inc"/> + <WindowIndex Value="0"/> + <TopLine Value="4854"/> + <CursorPos X="1" Y="4863"/> + <UsageCount Value="10"/> + </Unit5> + <Unit6> + <Filename Value="..\..\paxcomp_lazarus32\PAXINT_RUNNER.pas"/> + <UnitName Value="PAXINT_RUNNER"/> + <TopLine Value="7036"/> + <CursorPos X="37" Y="7043"/> + <UsageCount Value="10"/> + </Unit6> + </Units> + <General> + <ActiveWindowIndexAtStart Value="0"/> + </General> + <JumpHistory Count="0" HistoryIndex="-1"/> + </ProjectSession> + <Debugging> + <BreakPoints Count="1"> + <Item1> + <Kind Value="bpkSource"/> + <WatchScope Value="wpsLocal"/> + <WatchKind Value="wpkWrite"/> + <Source Value="..\..\paxcomp_lazarus32\PAXCOMP_BASERUNNER.pas"/> + <Line Value="1617"/> + </Item1> + </BreakPoints> + </Debugging> +</CONFIG> diff --git a/Sources/lazarus32/Demos/Demos/BindLfm/project1.res b/Sources/lazarus32/Demos/Demos/BindLfm/project1.res new file mode 100644 index 0000000..7c6cf3e Binary files /dev/null and b/Sources/lazarus32/Demos/Demos/BindLfm/project1.res differ diff --git a/Sources/lazarus32/Demos/Demos/BindLfm/unit1.lfm b/Sources/lazarus32/Demos/Demos/BindLfm/unit1.lfm new file mode 100644 index 0000000..f66496c --- /dev/null +++ b/Sources/lazarus32/Demos/Demos/BindLfm/unit1.lfm @@ -0,0 +1,60 @@ +object Form1: TForm1 + Left = 234 + Height = 240 + Top = 143 + Width = 621 + Caption = 'Bind LFM file' + ClientHeight = 240 + ClientWidth = 621 + LCLVersion = '1.0.12.0' + object Button1: TButton + Left = 512 + Height = 25 + Top = 192 + Width = 75 + Caption = 'Run' + OnClick = Button1Click + TabOrder = 0 + end + object Memo1: TMemo + Left = 15 + Height = 200 + Top = 17 + Width = 321 + Lines.Strings = ( + 'uses' + ' Unit2;' + 'begin' + ' Form2 := TForm2.Create(nil);' + ' try' + ' Form2.ShowModal;' + ' finally' + ' Form2.Free; ' + ' end;' + 'end.' + ) + TabOrder = 1 + end + object PaxCompiler1: TPaxCompiler + Alignment = 8 + OnUnknownDirective = PaxCompiler1UnknownDirective + DebugMode = False + left = 536 + top = 8 + end + object PaxPascalLanguage1: TPaxPascalLanguage + ExplicitOff = False + CompleteBooleanEval = False + UnitLookup = True + PrintKeyword = 'print' + PrintlnKeyword = 'println' + left = 536 + top = 72 + end + object PaxInterpreter1: TPaxInterpreter + Console = False + OnCreateObject = PaxInterpreter1CreateObject + left = 544 + top = 136 + end +end diff --git a/Sources/lazarus32/Demos/Demos/BindLfm/unit1.pas b/Sources/lazarus32/Demos/Demos/BindLfm/unit1.pas new file mode 100644 index 0000000..8952026 --- /dev/null +++ b/Sources/lazarus32/Demos/Demos/BindLfm/unit1.pas @@ -0,0 +1,71 @@ +unit Unit1; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls, + PaxCompiler, PaxInterpreter, PaxRunner, IMPORT_Common; + +type + + { TForm1 } + + TForm1 = class(TForm) + Button1: TButton; + Memo1: TMemo; + PaxCompiler1: TPaxCompiler; + PaxInterpreter1: TPaxInterpreter; + PaxPascalLanguage1: TPaxPascalLanguage; + procedure Button1Click(Sender: TObject); + procedure PaxCompiler1UnknownDirective(Sender: TPaxCompiler; + const Directive: String; var ok: Boolean); + procedure PaxInterpreter1CreateObject(Sender: TPaxRunner; Instance: TObject + ); + private + { private declarations } + CurrModule: String; + public + { public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.lfm} + +{ TForm1 } + +procedure TForm1.Button1Click(Sender: TObject); +begin + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + PaxCompiler1.AddModule('1', 'Pascal'); + PaxCompiler1.AddCode('1', Memo1.Lines.Text); + if PaxCompiler1.Compile(PaxInterpreter1) then + begin + PaxInterpreter1.Run; + end + else + ShowMessage(PaxCompiler1.ErrorMessage[0]); +end; + +procedure TForm1.PaxCompiler1UnknownDirective(Sender: TPaxCompiler; + const Directive: String; var ok: Boolean); +begin + ok := true; + CurrModule := Sender.CurrModuleName; +end; + +procedure TForm1.PaxInterpreter1CreateObject(Sender: TPaxRunner; + Instance: TObject); +begin + if Instance is TForm then + Sender.LoadDFMFile(Instance, CurrModule + '.lfm'); +end; + +end. + diff --git a/Sources/lazarus32/Demos/Demos/BindLfm/unit2.lfm b/Sources/lazarus32/Demos/Demos/BindLfm/unit2.lfm new file mode 100644 index 0000000..e75ccb9 --- /dev/null +++ b/Sources/lazarus32/Demos/Demos/BindLfm/unit2.lfm @@ -0,0 +1,20 @@ +object Form2: TForm2 + Left = 507 + Height = 240 + Top = 237 + Width = 320 + Caption = 'Form2' + ClientHeight = 240 + ClientWidth = 320 + OnCreate = FormCreate + LCLVersion = '1.0.12.0' + object Button1: TButton + Left = 37 + Height = 25 + Top = 35 + Width = 75 + Caption = 'Say Hello' + OnClick = Button1Click + TabOrder = 0 + end +end diff --git a/Sources/lazarus32/Demos/Demos/BindLfm/unit2.pas b/Sources/lazarus32/Demos/Demos/BindLfm/unit2.pas new file mode 100644 index 0000000..76159e5 --- /dev/null +++ b/Sources/lazarus32/Demos/Demos/BindLfm/unit2.pas @@ -0,0 +1,45 @@ +unit Unit2; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, Forms, Controls, Dialogs, StdCtrls; + +type + + { TForm2 } + + TForm2 = class(TForm) + Button1: TButton; + procedure Button1Click(Sender: TObject); + procedure FormCreate(Sender: TObject); + private + { private declarations } + public + { public declarations } + end; + +var + Form2: TForm2; + +implementation + +{$R *.lfm} + +{ TForm2 } + + +procedure TForm2.Button1Click(Sender: TObject); +begin + ShowMessage('Hello!'); +end; + +procedure TForm2.FormCreate(Sender: TObject); +begin + ShowMessage('Script form is created.'); +end; + +end. + diff --git a/Sources/lazarus32/Demos/Demos/CallInterfaceMethod/project1.ico b/Sources/lazarus32/Demos/Demos/CallInterfaceMethod/project1.ico new file mode 100644 index 0000000..0341321 Binary files /dev/null and b/Sources/lazarus32/Demos/Demos/CallInterfaceMethod/project1.ico differ diff --git a/Sources/lazarus32/Demos/Demos/CallInterfaceMethod/project1.lpi b/Sources/lazarus32/Demos/Demos/CallInterfaceMethod/project1.lpi new file mode 100644 index 0000000..3c13b2e --- /dev/null +++ b/Sources/lazarus32/Demos/Demos/CallInterfaceMethod/project1.lpi @@ -0,0 +1,93 @@ +<?xml version="1.0"?> +<CONFIG> + <ProjectOptions> + <Version Value="9"/> + <PathDelim Value="\"/> + <General> + <SessionStorage Value="InProjectDir"/> + <MainUnit Value="0"/> + <Title Value="project1"/> + <ResourceType Value="res"/> + <UseXPManifest Value="True"/> + <Icon Value="0"/> + </General> + <i18n> + <EnableI18N LFM="False"/> + </i18n> + <VersionInfo> + <StringTable ProductVersion=""/> + </VersionInfo> + <BuildModes Count="1"> + <Item1 Name="Default" Default="True"/> + </BuildModes> + <PublishOptions> + <Version Value="2"/> + <IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/> + <ExcludeFileFilter Value="*.(bak|ppu|o|so);*~;backup"/> + </PublishOptions> + <RunParams> + <local> + <FormatVersion Value="1"/> + </local> + </RunParams> + <RequiredPackages Count="2"> + <Item1> + <PackageName Value="paxcomp_lazarus32"/> + </Item1> + <Item2> + <PackageName Value="LCL"/> + </Item2> + </RequiredPackages> + <Units Count="2"> + <Unit0> + <Filename Value="project1.lpr"/> + <IsPartOfProject Value="True"/> + <UnitName Value="project1"/> + </Unit0> + <Unit1> + <Filename Value="unit1.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="Form1"/> + <ResourceBaseClass Value="Form"/> + <UnitName Value="Unit1"/> + </Unit1> + </Units> + </ProjectOptions> + <CompilerOptions> + <Version Value="11"/> + <PathDelim Value="\"/> + <Target> + <Filename Value="project1"/> + </Target> + <SearchPaths> + <IncludeFiles Value="$(ProjOutDir)"/> + <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/> + </SearchPaths> + <Linking> + <Options> + <Win32> + <GraphicApplication Value="True"/> + </Win32> + </Options> + </Linking> + <Other> + <CompilerMessages> + <MsgFileName Value=""/> + </CompilerMessages> + <CompilerPath Value="$(CompPath)"/> + </Other> + </CompilerOptions> + <Debugging> + <Exceptions Count="3"> + <Item1> + <Name Value="EAbort"/> + </Item1> + <Item2> + <Name Value="ECodetoolError"/> + </Item2> + <Item3> + <Name Value="EFOpenError"/> + </Item3> + </Exceptions> + </Debugging> +</CONFIG> diff --git a/Sources/lazarus32/Demos/Demos/CallInterfaceMethod/project1.lpr b/Sources/lazarus32/Demos/Demos/CallInterfaceMethod/project1.lpr new file mode 100644 index 0000000..ced6d82 --- /dev/null +++ b/Sources/lazarus32/Demos/Demos/CallInterfaceMethod/project1.lpr @@ -0,0 +1,21 @@ +program project1; + +{$mode objfpc}{$H+} + +uses + {$IFDEF UNIX}{$IFDEF UseCThreads} + cthreads, + {$ENDIF}{$ENDIF} + Interfaces, // this includes the LCL widgetset + Forms, Unit1 + { you can add units after this }; + +{$R *.res} + +begin + RequireDerivedFormResource := True; + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. + diff --git a/Sources/lazarus32/Demos/Demos/CallInterfaceMethod/project1.lps b/Sources/lazarus32/Demos/Demos/CallInterfaceMethod/project1.lps new file mode 100644 index 0000000..45dd738 --- /dev/null +++ b/Sources/lazarus32/Demos/Demos/CallInterfaceMethod/project1.lps @@ -0,0 +1,29 @@ +<?xml version="1.0"?> +<CONFIG> + <ProjectSession> + <PathDelim Value="\"/> + <Version Value="9"/> + <BuildModes Active="Default"/> + <Units Count="2"> + <Unit0> + <Filename Value="project1.lpr"/> + <IsPartOfProject Value="True"/> + <UnitName Value="project1"/> + <UsageCount Value="20"/> + </Unit0> + <Unit1> + <Filename Value="unit1.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="Form1"/> + <ResourceBaseClass Value="Form"/> + <UnitName Value="Unit1"/> + <IsVisibleTab Value="True"/> + <WindowIndex Value="0"/> + <TopLine Value="22"/> + <CursorPos X="1" Y="32"/> + <UsageCount Value="20"/> + </Unit1> + </Units> + <JumpHistory Count="0" HistoryIndex="-1"/> + </ProjectSession> +</CONFIG> diff --git a/Sources/lazarus32/Demos/Demos/CallInterfaceMethod/project1.res b/Sources/lazarus32/Demos/Demos/CallInterfaceMethod/project1.res new file mode 100644 index 0000000..7c6cf3e Binary files /dev/null and b/Sources/lazarus32/Demos/Demos/CallInterfaceMethod/project1.res differ diff --git a/Sources/lazarus32/Demos/Demos/CallInterfaceMethod/unit1.lfm b/Sources/lazarus32/Demos/Demos/CallInterfaceMethod/unit1.lfm new file mode 100644 index 0000000..0246712 --- /dev/null +++ b/Sources/lazarus32/Demos/Demos/CallInterfaceMethod/unit1.lfm @@ -0,0 +1,70 @@ +object Form1: TForm1 + Left = 234 + Height = 530 + Top = 143 + Width = 772 + Caption = 'Call interface method' + ClientHeight = 530 + ClientWidth = 772 + LCLVersion = '1.0.12.0' + object Memo1: TMemo + Left = 22 + Height = 480 + Top = 24 + Width = 482 + Lines.Strings = ( + 'type' + ' TMyScriptClass = class(TInterfacedObject, IMyInterface)' + ' public ' + ' function Add(X, Y: Integer): Integer; ' + ' destructor Destroy; override;' + ' end;' + 'function TMyScriptClass.Add(X, Y: Integer): Integer;' + 'begin' + ' print ''Hello from script!'';' + ' result := X + Y;' + 'end;' + 'destructor TMyScriptClass.Destroy; ' + 'begin' + ' print ''Script object has been destroyed.'';' + ' inherited;' + 'end;' + 'var' + ' X: TMyScriptClass;' + 'begin' + ' X := TMyScriptClass.Create;' + ' PassToHost(X, 3, 4);' + 'end.' + ) + TabOrder = 0 + end + object Button1: TButton + Left = 600 + Height = 25 + Top = 386 + Width = 75 + Caption = 'Run' + OnClick = Button1Click + TabOrder = 1 + end + object PaxCompiler1: TPaxCompiler + Alignment = 8 + DebugMode = False + left = 582 + top = 61 + end + object PaxPascalLanguage1: TPaxPascalLanguage + ExplicitOff = False + CompleteBooleanEval = False + UnitLookup = True + PrintKeyword = 'print' + PrintlnKeyword = 'println' + left = 570 + top = 126 + end + object PaxInterpreter1: TPaxInterpreter + Console = False + left = 581 + top = 205 + end +end diff --git a/Sources/lazarus32/Demos/Demos/CallInterfaceMethod/unit1.pas b/Sources/lazarus32/Demos/Demos/CallInterfaceMethod/unit1.pas new file mode 100644 index 0000000..3d24b39 --- /dev/null +++ b/Sources/lazarus32/Demos/Demos/CallInterfaceMethod/unit1.pas @@ -0,0 +1,76 @@ +unit Unit1; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls, + PaxCompiler, PaxInterpreter, PaxRegister; + +type + + { TForm1 } + + TForm1 = class(TForm) + Button1: TButton; + Memo1: TMemo; + PaxCompiler1: TPaxCompiler; + PaxInterpreter1: TPaxInterpreter; + PaxPascalLanguage1: TPaxPascalLanguage; + procedure Button1Click(Sender: TObject); + private + { private declarations } + public + { public declarations } + end; + + IMyInterface = interface + ['{D13115CA-4D57-4242-A54B-3684870CC7B3}'] + function Add(X, Y: Integer): Integer; + end; + +var + Form1: TForm1; + +implementation + +{$R *.lfm} + +{ TForm1 } + +procedure TForm1.Button1Click(Sender: TObject); +begin + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + PaxCompiler1.AddModule('1', 'Pascal'); + PaxCompiler1.AddCode('1', Memo1.Lines.Text); + if PaxCompiler1.Compile(PaxInterpreter1) then + begin + PaxInterpreter1.Run; + end + else + begin + ShowMessage(PaxCompiler1.ErrorMessage[0]); + end; +end; + +procedure PassToHost(X: IMyInterface; P1, P2: Integer); +begin + ShowMessage('Result = ' + IntToStr(X.Add(P1, P2))); +end; + +var I: Integer; + +initialization + +I := RegisterInterfaceType(0, 'IMyInterface', IMyInterface); +RegisterHeader(I, + 'function Add(X, Y: Integer): Integer;', nil, -1); + +RegisterHeader(0, + 'procedure PassToHost(X: IMyInterface; P1, P2: Integer);', + @ PassToHost); + +end. + diff --git a/Sources/lazarus32/Demos/Demos/DebugDemo/project1.ico b/Sources/lazarus32/Demos/Demos/DebugDemo/project1.ico new file mode 100644 index 0000000..0341321 Binary files /dev/null and b/Sources/lazarus32/Demos/Demos/DebugDemo/project1.ico differ diff --git a/Sources/lazarus32/Demos/Demos/DebugDemo/project1.lpi b/Sources/lazarus32/Demos/Demos/DebugDemo/project1.lpi new file mode 100644 index 0000000..3c13b2e --- /dev/null +++ b/Sources/lazarus32/Demos/Demos/DebugDemo/project1.lpi @@ -0,0 +1,93 @@ +<?xml version="1.0"?> +<CONFIG> + <ProjectOptions> + <Version Value="9"/> + <PathDelim Value="\"/> + <General> + <SessionStorage Value="InProjectDir"/> + <MainUnit Value="0"/> + <Title Value="project1"/> + <ResourceType Value="res"/> + <UseXPManifest Value="True"/> + <Icon Value="0"/> + </General> + <i18n> + <EnableI18N LFM="False"/> + </i18n> + <VersionInfo> + <StringTable ProductVersion=""/> + </VersionInfo> + <BuildModes Count="1"> + <Item1 Name="Default" Default="True"/> + </BuildModes> + <PublishOptions> + <Version Value="2"/> + <IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/> + <ExcludeFileFilter Value="*.(bak|ppu|o|so);*~;backup"/> + </PublishOptions> + <RunParams> + <local> + <FormatVersion Value="1"/> + </local> + </RunParams> + <RequiredPackages Count="2"> + <Item1> + <PackageName Value="paxcomp_lazarus32"/> + </Item1> + <Item2> + <PackageName Value="LCL"/> + </Item2> + </RequiredPackages> + <Units Count="2"> + <Unit0> + <Filename Value="project1.lpr"/> + <IsPartOfProject Value="True"/> + <UnitName Value="project1"/> + </Unit0> + <Unit1> + <Filename Value="unit1.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="Form1"/> + <ResourceBaseClass Value="Form"/> + <UnitName Value="Unit1"/> + </Unit1> + </Units> + </ProjectOptions> + <CompilerOptions> + <Version Value="11"/> + <PathDelim Value="\"/> + <Target> + <Filename Value="project1"/> + </Target> + <SearchPaths> + <IncludeFiles Value="$(ProjOutDir)"/> + <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/> + </SearchPaths> + <Linking> + <Options> + <Win32> + <GraphicApplication Value="True"/> + </Win32> + </Options> + </Linking> + <Other> + <CompilerMessages> + <MsgFileName Value=""/> + </CompilerMessages> + <CompilerPath Value="$(CompPath)"/> + </Other> + </CompilerOptions> + <Debugging> + <Exceptions Count="3"> + <Item1> + <Name Value="EAbort"/> + </Item1> + <Item2> + <Name Value="ECodetoolError"/> + </Item2> + <Item3> + <Name Value="EFOpenError"/> + </Item3> + </Exceptions> + </Debugging> +</CONFIG> diff --git a/Sources/lazarus32/Demos/Demos/DebugDemo/project1.lpr b/Sources/lazarus32/Demos/Demos/DebugDemo/project1.lpr new file mode 100644 index 0000000..ced6d82 --- /dev/null +++ b/Sources/lazarus32/Demos/Demos/DebugDemo/project1.lpr @@ -0,0 +1,21 @@ +program project1; + +{$mode objfpc}{$H+} + +uses + {$IFDEF UNIX}{$IFDEF UseCThreads} + cthreads, + {$ENDIF}{$ENDIF} + Interfaces, // this includes the LCL widgetset + Forms, Unit1 + { you can add units after this }; + +{$R *.res} + +begin + RequireDerivedFormResource := True; + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. + diff --git a/Sources/lazarus32/Demos/Demos/DebugDemo/project1.lps b/Sources/lazarus32/Demos/Demos/DebugDemo/project1.lps new file mode 100644 index 0000000..db24f54 --- /dev/null +++ b/Sources/lazarus32/Demos/Demos/DebugDemo/project1.lps @@ -0,0 +1,29 @@ +<?xml version="1.0"?> +<CONFIG> + <ProjectSession> + <PathDelim Value="\"/> + <Version Value="9"/> + <BuildModes Active="Default"/> + <Units Count="2"> + <Unit0> + <Filename Value="project1.lpr"/> + <IsPartOfProject Value="True"/> + <UnitName Value="project1"/> + <UsageCount Value="20"/> + </Unit0> + <Unit1> + <Filename Value="unit1.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="Form1"/> + <ResourceBaseClass Value="Form"/> + <UnitName Value="Unit1"/> + <IsVisibleTab Value="True"/> + <WindowIndex Value="0"/> + <TopLine Value="1"/> + <CursorPos X="54" Y="4"/> + <UsageCount Value="20"/> + </Unit1> + </Units> + <JumpHistory Count="0" HistoryIndex="-1"/> + </ProjectSession> +</CONFIG> diff --git a/Sources/lazarus32/Demos/Demos/DebugDemo/project1.res b/Sources/lazarus32/Demos/Demos/DebugDemo/project1.res new file mode 100644 index 0000000..7c6cf3e Binary files /dev/null and b/Sources/lazarus32/Demos/Demos/DebugDemo/project1.res differ diff --git a/Sources/lazarus32/Demos/Demos/DebugDemo/unit1.lfm b/Sources/lazarus32/Demos/Demos/DebugDemo/unit1.lfm new file mode 100644 index 0000000..c06d153 --- /dev/null +++ b/Sources/lazarus32/Demos/Demos/DebugDemo/unit1.lfm @@ -0,0 +1,105 @@ +object Form1: TForm1 + Left = 234 + Height = 531 + Top = 143 + Width = 699 + Caption = 'Form1' + ClientHeight = 531 + ClientWidth = 699 + OnCloseQuery = FormCloseQuery + LCLVersion = '1.0.12.0' + object Memo1: TMemo + Left = 16 + Height = 338 + Top = 16 + Width = 464 + Lines.Strings = ( + 'function Fact(N: Integer): Integer;' + 'begin' + ' if N = 1 then' + ' result := 1' + ' else' + ' result := N * Fact(N - 1);' + 'end;' + 'var' + ' SS: Integer;' + 'begin' + ' SS := Fact(3);' + ' print(SS);' + 'end.' + ) + TabOrder = 0 + end + object Memo2: TMemo + Left = 16 + Height = 154 + Top = 368 + Width = 464 + TabOrder = 1 + end + object Button1: TButton + Left = 554 + Height = 25 + Top = 35 + Width = 75 + Caption = 'Compile' + OnClick = Button1Click + TabOrder = 2 + end + object Button2: TButton + Left = 554 + Height = 25 + Top = 101 + Width = 75 + Caption = 'Run' + OnClick = Button2Click + TabOrder = 3 + end + object Button3: TButton + Left = 554 + Height = 25 + Top = 168 + Width = 75 + Caption = 'Trace Into' + OnClick = Button3Click + TabOrder = 4 + end + object Button4: TButton + Left = 554 + Height = 25 + Top = 232 + Width = 75 + Caption = 'Step Over' + OnClick = Button4Click + TabOrder = 5 + end + object PaxCompiler1: TPaxCompiler + Alignment = 8 + DebugMode = False + left = 502 + top = 349 + end + object PaxPascalLanguage1: TPaxPascalLanguage + ExplicitOff = False + CompleteBooleanEval = False + UnitLookup = True + PrintKeyword = 'print' + PrintlnKeyword = 'println' + left = 589 + top = 348 + end + object PaxCompilerDebugger1: TPaxCompilerDebugger + left = 510 + top = 405 + end + object PaxCompilerExplorer1: TPaxCompilerExplorer + left = 557 + top = 482 + end + object PaxInterpreter1: TPaxInterpreter + Console = False + OnPauseUpdated = PaxInterpreter1PauseUpdated + left = 609 + top = 421 + end +end diff --git a/Sources/lazarus32/Demos/Demos/DebugDemo/unit1.pas b/Sources/lazarus32/Demos/Demos/DebugDemo/unit1.pas new file mode 100644 index 0000000..ceb2aee --- /dev/null +++ b/Sources/lazarus32/Demos/Demos/DebugDemo/unit1.pas @@ -0,0 +1,331 @@ +unit Unit1; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls, + PaxCompiler, PaxCompilerDebugger, PaxCompilerExplorer, PaxInterpreter, + PaxRunner, PaxRegister; + +type + + { TForm1 } + + TForm1 = class(TForm) + Button1: TButton; + Button2: TButton; + Button3: TButton; + Button4: TButton; + Memo1: TMemo; + Memo2: TMemo; + PaxCompiler1: TPaxCompiler; + PaxCompilerDebugger1: TPaxCompilerDebugger; + PaxCompilerExplorer1: TPaxCompilerExplorer; + PaxInterpreter1: TPaxInterpreter; + PaxPascalLanguage1: TPaxPascalLanguage; + procedure Button1Click(Sender: TObject); + procedure Button2Click(Sender: TObject); + procedure Button3Click(Sender: TObject); + procedure Button4Click(Sender: TObject); + procedure FormCloseQuery(Sender: TObject; var CanClose: boolean); + procedure PaxInterpreter1PauseUpdated(Sender: TPaxRunner; + const ModuleName: String; SourceLineNumber: Integer); + private + ResumeRequest: Boolean; + CloseRequest: Boolean; + + function TestValid: Boolean; + procedure UpdateDebugInfo; + public + { public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.lfm} + +{ TForm1 } + +procedure TForm1.Button1Click(Sender: TObject); +var + I: Integer; +begin + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + PaxCompiler1.AddModule('1', PaxPascalLanguage1.LanguageName); + PaxCompiler1.AddCode('1', Memo1.Lines.Text); + PaxCompiler1.DebugMode := true; + if PaxCompiler1.Compile(PaxInterpreter1) then + begin + ShowMessage('Script has been successfully recompiled.'); + PaxCompilerExplorer1.RegisterCompiler(PaxCompiler1); + PaxCompilerDebugger1.RegisterCompiler(PaxCompiler1, PaxInterpreter1); + end + else + for I:=0 to PaxCompiler1.ErrorCount - 1 do + ShowMessage(PaxCompiler1.ErrorMessage[I]); +end; + +procedure TForm1.Button2Click(Sender: TObject); +begin + if not TestValid then Exit; + + PaxCompilerDebugger1.RunMode := _rmRUN; + if PaxCompilerDebugger1.IsPaused then + ResumeRequest := true + else + PaxCompilerDebugger1.Run; +end; + +procedure TForm1.Button3Click(Sender: TObject); +begin + if not TestValid then Exit; + + PaxCompilerDebugger1.RunMode := _rmTRACE_INTO; + if PaxCompilerDebugger1.IsPaused then + ResumeRequest := true + else + PaxCompilerDebugger1.Run; +end; + +procedure TForm1.Button4Click(Sender: TObject); +begin + if not TestValid then Exit; + + PaxCompilerDebugger1.RunMode := _rmSTEP_OVER; + if PaxCompilerDebugger1.IsPaused then + ResumeRequest := true + else + PaxCompilerDebugger1.Run; +end; + +procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: boolean); +begin + CanClose := true; + CloseRequest := true; +end; + +procedure TForm1.PaxInterpreter1PauseUpdated(Sender: TPaxRunner; + const ModuleName: String; SourceLineNumber: Integer); +begin + UpdateDebugInfo; + ResumeRequest := false; + repeat + Application.ProcessMessages; + if ResumeRequest then + Break; + if CloseRequest then + Abort; + until false; +end; + +function TForm1.TestValid: Boolean; +begin + result := PaxCompilerDebugger1.Valid; + if not result then + ShowMessage('You have to compile script. Press "Compile" button.'); +end; + +procedure TForm1.UpdateDebugInfo; + + procedure AddFields(StackFrameNumber, Id: Integer); + var + I, K: Integer; + OwnerName, S: String; + begin + K := PaxCompilerExplorer1.GetFieldCount(Id); + if K = 0 then + Exit; + + OwnerName := PaxCompilerExplorer1.Names[Id]; + if PaxCompilerDebugger1.GetValueAsString(Id) = 'nil' then + Exit; + + for I:=0 to K - 1 do + begin + S := OwnerName + '.' + PaxCompilerExplorer1.GetFieldName(Id, I); + S := ' ' + S + '=' + PaxCompilerDebugger1.GetFieldValueAsString( + StackFrameNumber, Id, I); + Memo2.Lines.Add(S); + end; + end; + + procedure AddPublishedProps(StackFrameNumber, Id: Integer); + var + I, K: Integer; + OwnerName, S: String; + begin + K := PaxCompilerExplorer1.GetPublishedPropCount(Id); + if K = 0 then + Exit; + + OwnerName := PaxCompilerExplorer1.Names[Id]; + if PaxCompilerDebugger1.GetValueAsString(Id) = 'nil' then + Exit; + + for I:=0 to K - 1 do + begin + S := OwnerName + '.' + PaxCompilerExplorer1.GetPublishedPropName(Id, I); + S := ' ' + S + '=' + PaxCompilerDebugger1.GetPublishedPropValueAsString( + StackFrameNumber, Id, I); + Memo2.Lines.Add(S); + end; + end; + + procedure AddArrayElements(StackFrameNumber, Id: Integer); + var + I, K1, K2: Integer; + OwnerName, S: String; + begin + if not PaxCompilerExplorer1.HasArrayType(Id) then + Exit; + + K1 := PaxCompilerExplorer1.GetArrayLowBound(Id); + K2 := PaxCompilerExplorer1.GetArrayHighBound(Id); + + OwnerName := PaxCompilerExplorer1.Names[Id]; + + for I:=K1 to K2 do + begin + S := OwnerName + '[' + IntToStr(I) + ']'; + S := ' ' + S + '=' + PaxCompilerDebugger1.GetArrayItemValueAsString( + StackFrameNumber, Id, I); + Memo2.Lines.Add(S); + end; + end; + + procedure AddDynArrayElements(StackFrameNumber, Id: Integer); + var + I, L: Integer; + OwnerName, S: String; + begin + if not PaxCompilerExplorer1.HasDynArrayType(Id) then + Exit; + + L := PaxCompilerDebugger1.GetDynArrayLength(StackFrameNumber, Id); + + OwnerName := PaxCompilerExplorer1.Names[Id]; + + for I:=0 to L - 1 do + begin + S := OwnerName + '[' + IntToStr(I) + ']'; + S := ' ' + S + '=' + PaxCompilerDebugger1.GetDynArrayItemValueAsString( + StackFrameNumber, Id, I); + Memo2.Lines.Add(S); + end; + end; + +var + SourceLineNumber: Integer; + ModuleName: String; + StackFrameNumber, J, K, SubId, Id: Integer; + S, V: String; + CallStackLineNumber: Integer; + CallStackModuleName: String; +begin + Memo2.Lines.Clear; + if PaxCompilerDebugger1.IsPaused then + begin + ModuleName := PaxCompilerDebugger1.ModuleName; + SourceLineNumber := PaxCompilerDebugger1.SourceLineNumber; + + Memo2.Lines.Add('Paused at line ' + IntTosTr(SourceLineNumber)); + Memo2.Lines.Add(PaxCompiler1.Modules[ModuleName][SourceLineNumber]); + Memo2.Lines.Add('------------------------------------------------------'); + + if PaxCompilerDebugger1.CallStackCount > 0 then + begin + Memo2.Lines.Add('Call stack:'); + for StackFrameNumber:=0 to PaxCompilerDebugger1.CallStackCount - 1 do + begin + SubId := PaxCompilerDebugger1.CallStack[StackFrameNumber]; + S := '('; + K := PaxCompilerExplorer1.GetParamCount(SubId); + for J:=0 to K - 1 do + begin + Id := PaxCompilerExplorer1.GetParamId(SubId, J); + V := PaxCompilerDebugger1.GetValueAsString(StackFrameNumber, Id); + S := S + V; + if J < K - 1 then + S := S + ','; + end; + S := PaxCompilerExplorer1.Names[SubId] + S + ')'; + + CallStackLineNumber := PaxCompilerDebugger1.CallStackLineNumber[StackFrameNumber]; + CallStackModuleName := PaxCompilerDebugger1.CallStackModuleName[StackFrameNumber]; + + S := S + '; // ' + PaxCompiler1.Modules[CallStackModuleName][CallStackLineNumber]; + + Memo2.Lines.Add(S); + end; + Memo2.Lines.Add('------------------------------------------------------'); + + Memo2.Lines.Add('Local scope:'); + StackFrameNumber := PaxCompilerDebugger1.CallStackCount - 1; + SubId := PaxCompilerDebugger1.CallStack[StackFrameNumber]; + K := PaxCompilerExplorer1.GetLocalCount(SubId); + for J:=0 to K - 1 do + begin + Id := PaxCompilerExplorer1.GetLocalId(SubId, J); + V := PaxCompilerDebugger1.GetValueAsString(StackFrameNumber, Id); + S := PaxCompilerExplorer1.Names[Id] + '=' + V; + Memo2.Lines.Add(S); + + if Pos('X', S) > 0 then + begin + PaxCompilerDebugger1.PutValue(StackFrameNumber, Id, 258); + + V := PaxCompilerDebugger1.GetValueAsString(StackFrameNumber, Id); + S := PaxCompilerExplorer1.Names[Id] + '=' + V; + S := S + ' // modified'; + Memo2.Lines.Add(S); + end; + + AddFields(StackFrameNumber, Id); + AddPublishedProps(StackFrameNumber, Id); + AddArrayElements(StackFrameNumber, Id); + AddDynArrayElements(StackFrameNumber, Id); + end; + + Memo2.Lines.Add('------------------------------------------------------'); + end; + + Memo2.Lines.Add('Global scope:'); + K := PaxCompilerExplorer1.GetGlobalCount(0); + for J:=0 to K - 1 do + begin + Id := PaxCompilerExplorer1.GetGlobalId(0, J); + V := PaxCompilerDebugger1.GetValueAsString(Id); + S := PaxCompilerExplorer1.Names[Id] + '=' + V; + Memo2.Lines.Add(S); + + AddFields(0, Id); + AddPublishedProps(0, Id); + AddArrayElements(0, Id); + AddDynArrayElements(0, Id); + end; + Memo2.Lines.Add('------------------------------------------------------'); + + end + else + Memo2.Lines.Add('Finished'); + + Memo2.SelStart := 0; + Memo2.SelLength := 0; +end; + +procedure Print(I: Integer); +begin + ShowMessage(IntToStr(I)); +end; + +initialization + RegisterHeader(0, 'procedure Print(I: Integer);', @Print); + +end. + diff --git a/Sources/lazarus32/Demos/Demos/Hello/project1.ico b/Sources/lazarus32/Demos/Demos/Hello/project1.ico new file mode 100644 index 0000000..0341321 Binary files /dev/null and b/Sources/lazarus32/Demos/Demos/Hello/project1.ico differ diff --git a/Sources/lazarus32/Demos/Demos/Hello/project1.lpi b/Sources/lazarus32/Demos/Demos/Hello/project1.lpi new file mode 100644 index 0000000..6a68026 --- /dev/null +++ b/Sources/lazarus32/Demos/Demos/Hello/project1.lpi @@ -0,0 +1,94 @@ +<?xml version="1.0"?> +<CONFIG> + <ProjectOptions> + <Version Value="9"/> + <PathDelim Value="\"/> + <General> + <SessionStorage Value="InProjectDir"/> + <MainUnit Value="0"/> + <Title Value="project1"/> + <ResourceType Value="res"/> + <UseXPManifest Value="True"/> + <Icon Value="0"/> + </General> + <i18n> + <EnableI18N LFM="False"/> + </i18n> + <VersionInfo> + <StringTable ProductVersion=""/> + </VersionInfo> + <BuildModes Count="1"> + <Item1 Name="Default" Default="True"/> + </BuildModes> + <PublishOptions> + <Version Value="2"/> + <IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/> + <ExcludeFileFilter Value="*.(bak|ppu|o|so);*~;backup"/> + </PublishOptions> + <RunParams> + <local> + <FormatVersion Value="1"/> + </local> + </RunParams> + <RequiredPackages Count="2"> + <Item1> + <PackageName Value="paxcomp_lazarus32"/> + </Item1> + <Item2> + <PackageName Value="LCL"/> + </Item2> + </RequiredPackages> + <Units Count="2"> + <Unit0> + <Filename Value="project1.lpr"/> + <IsPartOfProject Value="True"/> + <UnitName Value="project1"/> + </Unit0> + <Unit1> + <Filename Value="unit1.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="Form1"/> + <ResourceBaseClass Value="Form"/> + <UnitName Value="Unit1"/> + </Unit1> + </Units> + </ProjectOptions> + <CompilerOptions> + <Version Value="11"/> + <PathDelim Value="\"/> + <Target> + <Filename Value="project1"/> + </Target> + <SearchPaths> + <IncludeFiles Value="$(ProjOutDir)"/> + <OtherUnitFiles Value="..\..\IMPORT"/> + <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/> + </SearchPaths> + <Linking> + <Options> + <Win32> + <GraphicApplication Value="True"/> + </Win32> + </Options> + </Linking> + <Other> + <CompilerMessages> + <MsgFileName Value=""/> + </CompilerMessages> + <CompilerPath Value="$(CompPath)"/> + </Other> + </CompilerOptions> + <Debugging> + <Exceptions Count="3"> + <Item1> + <Name Value="EAbort"/> + </Item1> + <Item2> + <Name Value="ECodetoolError"/> + </Item2> + <Item3> + <Name Value="EFOpenError"/> + </Item3> + </Exceptions> + </Debugging> +</CONFIG> diff --git a/Sources/lazarus32/Demos/Demos/Hello/project1.lpr b/Sources/lazarus32/Demos/Demos/Hello/project1.lpr new file mode 100644 index 0000000..ced6d82 --- /dev/null +++ b/Sources/lazarus32/Demos/Demos/Hello/project1.lpr @@ -0,0 +1,21 @@ +program project1; + +{$mode objfpc}{$H+} + +uses + {$IFDEF UNIX}{$IFDEF UseCThreads} + cthreads, + {$ENDIF}{$ENDIF} + Interfaces, // this includes the LCL widgetset + Forms, Unit1 + { you can add units after this }; + +{$R *.res} + +begin + RequireDerivedFormResource := True; + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. + diff --git a/Sources/lazarus32/Demos/Demos/Hello/project1.lps b/Sources/lazarus32/Demos/Demos/Hello/project1.lps new file mode 100644 index 0000000..d6a6cee --- /dev/null +++ b/Sources/lazarus32/Demos/Demos/Hello/project1.lps @@ -0,0 +1,29 @@ +<?xml version="1.0"?> +<CONFIG> + <ProjectSession> + <PathDelim Value="\"/> + <Version Value="9"/> + <BuildModes Active="Default"/> + <Units Count="2"> + <Unit0> + <Filename Value="project1.lpr"/> + <IsPartOfProject Value="True"/> + <UnitName Value="project1"/> + <UsageCount Value="20"/> + </Unit0> + <Unit1> + <Filename Value="unit1.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="Form1"/> + <ResourceBaseClass Value="Form"/> + <UnitName Value="Unit1"/> + <IsVisibleTab Value="True"/> + <WindowIndex Value="0"/> + <TopLine Value="34"/> + <CursorPos X="42" Y="38"/> + <UsageCount Value="20"/> + </Unit1> + </Units> + <JumpHistory Count="0" HistoryIndex="-1"/> + </ProjectSession> +</CONFIG> diff --git a/Sources/lazarus32/Demos/Demos/Hello/project1.res b/Sources/lazarus32/Demos/Demos/Hello/project1.res new file mode 100644 index 0000000..7c6cf3e Binary files /dev/null and b/Sources/lazarus32/Demos/Demos/Hello/project1.res differ diff --git a/Sources/lazarus32/Demos/Demos/Hello/unit1.lfm b/Sources/lazarus32/Demos/Demos/Hello/unit1.lfm new file mode 100644 index 0000000..f4133a1 --- /dev/null +++ b/Sources/lazarus32/Demos/Demos/Hello/unit1.lfm @@ -0,0 +1,39 @@ +object Form1: TForm1 + Left = 234 + Height = 240 + Top = 143 + Width = 320 + Caption = 'Hello' + ClientHeight = 240 + ClientWidth = 320 + LCLVersion = '1.0.12.0' + object Button1: TButton + Left = 57 + Height = 25 + Top = 44 + Width = 75 + Caption = 'Say Hello' + OnClick = Button1Click + TabOrder = 0 + end + object PaxCompiler1: TPaxCompiler + Alignment = 8 + DebugMode = False + left = 217 + top = 20 + end + object PaxPascalLanguage1: TPaxPascalLanguage + ExplicitOff = False + CompleteBooleanEval = False + UnitLookup = True + PrintKeyword = 'print' + PrintlnKeyword = 'println' + left = 203 + top = 104 + end + object PaxInterpreter1: TPaxInterpreter + Console = False + left = 231 + top = 169 + end +end diff --git a/Sources/lazarus32/Demos/Demos/Hello/unit1.pas b/Sources/lazarus32/Demos/Demos/Hello/unit1.pas new file mode 100644 index 0000000..7d815aa --- /dev/null +++ b/Sources/lazarus32/Demos/Demos/Hello/unit1.pas @@ -0,0 +1,59 @@ +unit Unit1; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls, + PaxCompiler, PaxInterpreter, PaxRegister, IMPORT_Common; + +type + + { TForm1 } + + TForm1 = class(TForm) + Button1: TButton; + PaxCompiler1: TPaxCompiler; + PaxInterpreter1: TPaxInterpreter; + PaxPascalLanguage1: TPaxPascalLanguage; + procedure Button1Click(Sender: TObject); + private + { private declarations } + public + { public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.lfm} + +{ TForm1 } + +procedure TForm1.Button1Click(Sender: TObject); +var + I: Integer; +begin + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + + PaxCompiler1.RegisterVariable(0, 'Button1: TButton', @Button1); + + PaxCompiler1.AddModule('1', PaxPascalLanguage1.LanguageName); + PaxCompiler1.AddCode('1', 'begin'); + PaxCompiler1.AddCode('1', ' Button1.Caption := ''Hello'';'); + PaxCompiler1.AddCode('1', ' Button1.Width := Button1.Width + 100;'); + PaxCompiler1.AddCode('1', 'end.'); + + if PaxCompiler1.Compile(PaxInterpreter1) then + PaxInterpreter1.Run + else + for I:=0 to PaxCompiler1.ErrorCount - 1 do + ShowMessage(PaxCompiler1.ErrorMessage[I]); +end; + +end. + diff --git a/Sources/lazarus32/Demos/Demos/ImportAbstractClass/project1.ico b/Sources/lazarus32/Demos/Demos/ImportAbstractClass/project1.ico new file mode 100644 index 0000000..0341321 Binary files /dev/null and b/Sources/lazarus32/Demos/Demos/ImportAbstractClass/project1.ico differ diff --git a/Sources/lazarus32/Demos/Demos/ImportAbstractClass/project1.lpi b/Sources/lazarus32/Demos/Demos/ImportAbstractClass/project1.lpi new file mode 100644 index 0000000..3c13b2e --- /dev/null +++ b/Sources/lazarus32/Demos/Demos/ImportAbstractClass/project1.lpi @@ -0,0 +1,93 @@ +<?xml version="1.0"?> +<CONFIG> + <ProjectOptions> + <Version Value="9"/> + <PathDelim Value="\"/> + <General> + <SessionStorage Value="InProjectDir"/> + <MainUnit Value="0"/> + <Title Value="project1"/> + <ResourceType Value="res"/> + <UseXPManifest Value="True"/> + <Icon Value="0"/> + </General> + <i18n> + <EnableI18N LFM="False"/> + </i18n> + <VersionInfo> + <StringTable ProductVersion=""/> + </VersionInfo> + <BuildModes Count="1"> + <Item1 Name="Default" Default="True"/> + </BuildModes> + <PublishOptions> + <Version Value="2"/> + <IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/> + <ExcludeFileFilter Value="*.(bak|ppu|o|so);*~;backup"/> + </PublishOptions> + <RunParams> + <local> + <FormatVersion Value="1"/> + </local> + </RunParams> + <RequiredPackages Count="2"> + <Item1> + <PackageName Value="paxcomp_lazarus32"/> + </Item1> + <Item2> + <PackageName Value="LCL"/> + </Item2> + </RequiredPackages> + <Units Count="2"> + <Unit0> + <Filename Value="project1.lpr"/> + <IsPartOfProject Value="True"/> + <UnitName Value="project1"/> + </Unit0> + <Unit1> + <Filename Value="unit1.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="Form1"/> + <ResourceBaseClass Value="Form"/> + <UnitName Value="Unit1"/> + </Unit1> + </Units> + </ProjectOptions> + <CompilerOptions> + <Version Value="11"/> + <PathDelim Value="\"/> + <Target> + <Filename Value="project1"/> + </Target> + <SearchPaths> + <IncludeFiles Value="$(ProjOutDir)"/> + <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/> + </SearchPaths> + <Linking> + <Options> + <Win32> + <GraphicApplication Value="True"/> + </Win32> + </Options> + </Linking> + <Other> + <CompilerMessages> + <MsgFileName Value=""/> + </CompilerMessages> + <CompilerPath Value="$(CompPath)"/> + </Other> + </CompilerOptions> + <Debugging> + <Exceptions Count="3"> + <Item1> + <Name Value="EAbort"/> + </Item1> + <Item2> + <Name Value="ECodetoolError"/> + </Item2> + <Item3> + <Name Value="EFOpenError"/> + </Item3> + </Exceptions> + </Debugging> +</CONFIG> diff --git a/Sources/lazarus32/Demos/Demos/ImportAbstractClass/project1.lpr b/Sources/lazarus32/Demos/Demos/ImportAbstractClass/project1.lpr new file mode 100644 index 0000000..ced6d82 --- /dev/null +++ b/Sources/lazarus32/Demos/Demos/ImportAbstractClass/project1.lpr @@ -0,0 +1,21 @@ +program project1; + +{$mode objfpc}{$H+} + +uses + {$IFDEF UNIX}{$IFDEF UseCThreads} + cthreads, + {$ENDIF}{$ENDIF} + Interfaces, // this includes the LCL widgetset + Forms, Unit1 + { you can add units after this }; + +{$R *.res} + +begin + RequireDerivedFormResource := True; + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. + diff --git a/Sources/lazarus32/Demos/Demos/ImportAbstractClass/project1.lps b/Sources/lazarus32/Demos/Demos/ImportAbstractClass/project1.lps new file mode 100644 index 0000000..5b4c3d7 --- /dev/null +++ b/Sources/lazarus32/Demos/Demos/ImportAbstractClass/project1.lps @@ -0,0 +1,29 @@ +<?xml version="1.0"?> +<CONFIG> + <ProjectSession> + <PathDelim Value="\"/> + <Version Value="9"/> + <BuildModes Active="Default"/> + <Units Count="2"> + <Unit0> + <Filename Value="project1.lpr"/> + <IsPartOfProject Value="True"/> + <UnitName Value="project1"/> + <UsageCount Value="20"/> + </Unit0> + <Unit1> + <Filename Value="unit1.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="Form1"/> + <ResourceBaseClass Value="Form"/> + <UnitName Value="Unit1"/> + <IsVisibleTab Value="True"/> + <WindowIndex Value="0"/> + <TopLine Value="1"/> + <CursorPos X="43" Y="9"/> + <UsageCount Value="20"/> + </Unit1> + </Units> + <JumpHistory Count="0" HistoryIndex="-1"/> + </ProjectSession> +</CONFIG> diff --git a/Sources/lazarus32/Demos/Demos/ImportAbstractClass/project1.res b/Sources/lazarus32/Demos/Demos/ImportAbstractClass/project1.res new file mode 100644 index 0000000..7c6cf3e Binary files /dev/null and b/Sources/lazarus32/Demos/Demos/ImportAbstractClass/project1.res differ diff --git a/Sources/lazarus32/Demos/Demos/ImportAbstractClass/unit1.lfm b/Sources/lazarus32/Demos/Demos/ImportAbstractClass/unit1.lfm new file mode 100644 index 0000000..883f502 --- /dev/null +++ b/Sources/lazarus32/Demos/Demos/ImportAbstractClass/unit1.lfm @@ -0,0 +1,68 @@ +object Form1: TForm1 + Left = 234 + Height = 503 + Top = 143 + Width = 808 + Caption = 'Form1' + ClientHeight = 503 + ClientWidth = 808 + LCLVersion = '1.0.12.0' + object Memo1: TMemo + Left = 16 + Height = 469 + Top = 16 + Width = 542 + Lines.Strings = ( + 'type' + ' TMyScriptClass = class(TMyHostClass)' + ' procedure P; override;' + ' end;' + '' + 'procedure TMyScriptClass.P;' + 'begin' + ' print(''Hello from script!'');' + 'end;' + '' + 'var' + ' X: TMyScriptClass;' + 'begin' + ' X := TMyScriptClass.Create;' + ' try' + ' PassToHost(X);' + ' finally' + ' X.Free;' + ' end;' + 'end.' + ) + TabOrder = 0 + end + object Button1: TButton + Left = 630 + Height = 25 + Top = 301 + Width = 75 + Caption = 'Run' + OnClick = Button1Click + TabOrder = 1 + end + object PaxCompiler1: TPaxCompiler + Alignment = 8 + DebugMode = False + left = 648 + top = 32 + end + object PaxPascalLanguage1: TPaxPascalLanguage + ExplicitOff = False + CompleteBooleanEval = False + UnitLookup = True + PrintKeyword = 'print' + PrintlnKeyword = 'println' + left = 656 + top = 96 + end + object PaxInterpreter1: TPaxInterpreter + Console = False + left = 680 + top = 176 + end +end diff --git a/Sources/lazarus32/Demos/Demos/ImportAbstractClass/unit1.pas b/Sources/lazarus32/Demos/Demos/ImportAbstractClass/unit1.pas new file mode 100644 index 0000000..ad64205 --- /dev/null +++ b/Sources/lazarus32/Demos/Demos/ImportAbstractClass/unit1.pas @@ -0,0 +1,79 @@ +unit Unit1; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls, + PaxCompiler, PaxInterpreter, PaxRegister; + +type + + { TForm1 } + + TForm1 = class(TForm) + Button1: TButton; + Memo1: TMemo; + PaxCompiler1: TPaxCompiler; + PaxInterpreter1: TPaxInterpreter; + PaxPascalLanguage1: TPaxPascalLanguage; + procedure Button1Click(Sender: TObject); + private + { private declarations } + public + { public declarations } + end; + + TMyHostClass = class + public + procedure P; virtual; abstract; + end; + +var + Form1: TForm1; + +implementation + +{$R *.lfm} + +{ TForm1 } + +procedure TForm1.Button1Click(Sender: TObject); +begin + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + PaxCompiler1.AddModule('1', 'Pascal'); + PaxCompiler1.AddCode('1', Memo1.Lines.Text); + if PaxCompiler1.Compile(PaxInterpreter1) then + begin + PaxInterpreter1.Run; + end + else + begin + ShowMessage(PaxCompiler1.ErrorMessage[0]); + end; +end; + +procedure PassToHost(X: TMyHostClass); +begin + ShowMessage('At host side: ' + X.ClassName); + X.P; +end; + +var + I: Integer; + +initialization + +I := RegisterClassType(0, TMyHostClass); +RegisterHeader(I, + 'procedure P; virtual; abstract;', + nil); + +RegisterHeader(0, + 'procedure PassToHost(X: TMyHostClass);', + @ PassToHost); + +end. + diff --git a/Sources/lazarus32/PaxCompiler.def b/Sources/lazarus32/PaxCompiler.def new file mode 100644 index 0000000..35211a8 --- /dev/null +++ b/Sources/lazarus32/PaxCompiler.def @@ -0,0 +1,93 @@ +// {$define TRIAL} +{$O-} + +// {$define NO_PARENT_CLASS} + +{$define FPC} +{$ifdef FPC} +// {$DEFINE PAX64} + {$ASMMODE intel} + {$DEFINE VARIANTS} + {$MODE DELPHI} + {$DEFINE CPUASM} + {$H+} + {$M+} +{$endif} + +{$define PCU_EX} +{$define GENERICS} +//{$define HTML} + +{$define DUMP} +{$ifdef Ver140} + {$define VARIANTS} +{$endif} +{$ifdef Ver150} + {$define VARIANTS} +{$endif} +{$ifdef Ver160} + {$define VARIANTS} +{$endif} +{$ifdef Ver170} + {$define VARIANTS} +{$endif} +{$ifdef Ver180} + {$define VARIANTS} +{$endif} +{$ifdef Ver190} + {$define VARIANTS} +{$endif} +{$ifdef Ver200} + {$define VARIANTS} + {$define UNIC} +{$endif} +{$ifdef Ver210} + {$define VARIANTS} + {$define UNIC} + {$define DRTTI} +{$endif} +{$ifdef Ver220} + {$define VARIANTS} + {$define UNIC} + {$define DRTTI} +{$endif} +{$ifdef Ver230} + {$define VARIANTS} + {$define UNIC} + {$define DRTTI} + {$define DPULSAR} + {$IFDEF CPUX64} + {$DEFINE PAX64} + {$ENDIF} +{$endif} +{$ifdef Ver240} + {$define VARIANTS} + {$define UNIC} + {$define DRTTI} + {$define DPULSAR} + {$define DXE3} + {$IFDEF CPUX64} + {$DEFINE PAX64} + {$ENDIF} +{$endif} +{$ifdef Ver250} + {$define VARIANTS} + {$define UNIC} + {$define DRTTI} + {$define DPULSAR} + {$define DXE3} + {$IFDEF CPUX64} + {$DEFINE PAX64} + {$ENDIF} +{$endif} +{$ifdef Ver260} + {$define VARIANTS} + {$define UNIC} + {$define DRTTI} + {$define DPULSAR} + {$define DXE3} + {$IFDEF CPUX64} + {$DEFINE PAX64} + {$ENDIF} +{$endif} + diff --git a/Sources/lazarus32/paxcomp_lazarus32.lpk b/Sources/lazarus32/paxcomp_lazarus32.lpk new file mode 100644 index 0000000..1389ea6 --- /dev/null +++ b/Sources/lazarus32/paxcomp_lazarus32.lpk @@ -0,0 +1,350 @@ +<?xml version="1.0"?> +<CONFIG> + <Package Version="4"> + <PathDelim Value="\"/> + <Name Value="paxcomp_lazarus32"/> + <CompilerOptions> + <Version Value="11"/> + <PathDelim Value="\"/> + <SearchPaths> + <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/> + </SearchPaths> + <Other> + <CompilerMessages> + <MsgFileName Value=""/> + </CompilerMessages> + <CompilerPath Value="$(CompPath)"/> + </Other> + </CompilerOptions> + <Files Count="78"> + <Item1> + <Filename Value="PaxBasicLanguage.pas"/> + <UnitName Value="PaxBasicLanguage"/> + </Item1> + <Item2> + <Filename Value="PaxCompiler.pas"/> + <UnitName Value="PaxCompiler"/> + </Item2> + <Item3> + <Filename Value="PaxCompilerDebugger.pas"/> + <UnitName Value="PaxCompilerDebugger"/> + </Item3> + <Item4> + <Filename Value="PaxCompilerDLL.pas"/> + <UnitName Value="PaxCompilerDLL"/> + </Item4> + <Item5> + <Filename Value="PaxCompilerExplorer.pas"/> + <UnitName Value="PaxCompilerExplorer"/> + </Item5> + <Item6> + <Filename Value="PaxCompilerRegister.pas"/> + <HasRegisterProc Value="True"/> + <UnitName Value="PaxCompilerRegister"/> + </Item6> + <Item7> + <Filename Value="PAXCOMP_2010.pas"/> + <UnitName Value="PAXCOMP_2010"/> + </Item7> + <Item8> + <Filename Value="PAXCOMP_2010Reg.pas"/> + <UnitName Value="PAXCOMP_2010REG"/> + </Item8> + <Item9> + <Filename Value="PAXCOMP_BASERUNNER.pas"/> + <UnitName Value="PAXCOMP_BASERUNNER"/> + </Item9> + <Item10> + <Filename Value="PAXCOMP_BASESYMBOL_TABLE.pas"/> + <UnitName Value="PAXCOMP_BASESYMBOL_TABLE"/> + </Item10> + <Item11> + <Filename Value="PAXCOMP_Basic.pas"/> + <UnitName Value="PAXCOMP_Basic"/> + </Item11> + <Item12> + <Filename Value="PAXCOMP_BASIC_PARSER.pas"/> + <UnitName Value="PAXCOMP_BASIC_PARSER"/> + </Item12> + <Item13> + <Filename Value="PAXCOMP_BASIC_SCANNER.pas"/> + <UnitName Value="PAXCOMP_BASIC_SCANNER"/> + </Item13> + <Item14> + <Filename Value="PAXCOMP_BYTECODE.pas"/> + <UnitName Value="PAXCOMP_BYTECODE"/> + </Item14> + <Item15> + <Filename Value="PAXCOMP_CLASSFACT.pas"/> + <UnitName Value="PAXCOMP_CLASSFACT"/> + </Item15> + <Item16> + <Filename Value="PAXCOMP_CLASSLST.pas"/> + <UnitName Value="PAXCOMP_CLASSLST"/> + </Item16> + <Item17> + <Filename Value="PAXCOMP_CONSTANTS.pas"/> + <UnitName Value="PAXCOMP_CONSTANTS"/> + </Item17> + <Item18> + <Filename Value="PAXCOMP_DISASM.pas"/> + <UnitName Value="PAXCOMP_DISASM"/> + </Item18> + <Item19> + <Filename Value="PAXCOMP_EMIT.pas"/> + <UnitName Value="PAXCOMP_EMIT"/> + </Item19> + <Item20> + <Filename Value="PAXCOMP_ERROR.pas"/> + <UnitName Value="PAXCOMP_ERROR"/> + </Item20> + <Item21> + <Filename Value="PAXCOMP_EVAL.pas"/> + <UnitName Value="PAXCOMP_EVAL"/> + </Item21> + <Item22> + <Filename Value="PAXCOMP_EVENT.pas"/> + <UnitName Value="PAXCOMP_EVENT"/> + </Item22> + <Item23> + <Filename Value="PAXCOMP_EXTRASYMBOL_TABLE.pas"/> + <UnitName Value="PAXCOMP_EXTRASYMBOL_TABLE"/> + </Item23> + <Item24> + <Filename Value="PAXCOMP_FORBID.pas"/> + <UnitName Value="PAXCOMP_FORBID"/> + </Item24> + <Item25> + <Filename Value="PAXCOMP_FRAMEWORK.pas"/> + <UnitName Value="PAXCOMP_FRAMEWORK"/> + </Item25> + <Item26> + <Filename Value="PAXCOMP_GC.pas"/> + <UnitName Value="PAXCOMP_GC"/> + </Item26> + <Item27> + <Filename Value="PAXCOMP_GENERIC.pas"/> + <UnitName Value="PAXCOMP_GENERIC"/> + </Item27> + <Item28> + <Filename Value="PAXCOMP_HEADER_PARSER.pas"/> + <UnitName Value="PAXCOMP_HEADER_PARSER"/> + </Item28> + <Item29> + <Filename Value="PAXCOMP_HOSTCLS.pas"/> + <UnitName Value="PAXCOMP_HOSTCLS"/> + </Item29> + <Item30> + <Filename Value="PAXCOMP_INVOKE.pas"/> + <UnitName Value="PAXCOMP_INVOKE"/> + </Item30> + <Item31> + <Filename Value="PAXCOMP_JavaScript.pas"/> + <UnitName Value="PAXCOMP_JavaScript"/> + </Item31> + <Item32> + <Filename Value="PAXCOMP_JS_CONV.pas"/> + <UnitName Value="PAXCOMP_JS_CONV"/> + </Item32> + <Item33> + <Filename Value="PAXCOMP_JS_PARSER.pas"/> + <UnitName Value="PAXCOMP_JS_PARSER"/> + </Item33> + <Item34> + <Filename Value="PAXCOMP_JS_SCANNER.pas"/> + <UnitName Value="PAXCOMP_JS_SCANNER"/> + </Item34> + <Item35> + <Filename Value="PAXCOMP_KERNEL.pas"/> + <UnitName Value="PAXCOMP_KERNEL"/> + </Item35> + <Item36> + <Filename Value="PAXCOMP_LABEL_STACK.pas"/> + <UnitName Value="PAXCOMP_LABEL_STACK"/> + </Item36> + <Item37> + <Filename Value="PAXCOMP_LOCALSYMBOL_TABLE.pas"/> + <UnitName Value="PAXCOMP_LOCALSYMBOL_TABLE"/> + </Item37> + <Item38> + <Filename Value="PAXCOMP_MAP.pas"/> + <UnitName Value="PAXCOMP_MAP"/> + </Item38> + <Item39> + <Filename Value="PAXCOMP_MODULE.pas"/> + <UnitName Value="PAXCOMP_MODULE"/> + </Item39> + <Item40> + <Filename Value="PAXCOMP_OFFSET.pas"/> + <UnitName Value="PAXCOMP_OFFSET"/> + </Item40> + <Item41> + <Filename Value="PAXCOMP_OLE.pas"/> + <UnitName Value="PAXCOMP_OLE"/> + </Item41> + <Item42> + <Filename Value="PAXCOMP_PARSER.pas"/> + <UnitName Value="PAXCOMP_PARSER"/> + </Item42> + <Item43> + <Filename Value="PAXCOMP_PASCAL_PARSER.pas"/> + <UnitName Value="PAXCOMP_PASCAL_PARSER"/> + </Item43> + <Item44> + <Filename Value="PAXCOMP_PASCAL_SCANNER.pas"/> + <UnitName Value="PAXCOMP_PASCAL_SCANNER"/> + </Item44> + <Item45> + <Filename Value="PAXCOMP_PAUSE.pas"/> + <UnitName Value="PAXCOMP_PAUSE"/> + </Item45> + <Item46> + <Filename Value="PAXCOMP_PCU.pas"/> + <UnitName Value="PAXCOMP_PCU"/> + </Item46> + <Item47> + <Filename Value="PAXCOMP_PE.pas"/> + <UnitName Value="PAXCOMP_PE"/> + </Item47> + <Item48> + <Filename Value="PAXCOMP_PROG.pas"/> + <UnitName Value="PAXCOMP_PROG"/> + </Item48> + <Item49> + <Filename Value="PAXCOMP_PROGLIB.pas"/> + <UnitName Value="PAXCOMP_PROGLIB"/> + </Item49> + <Item50> + <Filename Value="PAXCOMP_PROGLIST.pas"/> + <UnitName Value="PAXCOMP_PROGLIST"/> + </Item50> + <Item51> + <Filename Value="PAXCOMP_RTI.pas"/> + <UnitName Value="PAXCOMP_RTI"/> + </Item51> + <Item52> + <Filename Value="PAXCOMP_SCANNER.pas"/> + <UnitName Value="PAXCOMP_SCANNER"/> + </Item52> + <Item53> + <Filename Value="PAXCOMP_SEH.pas"/> + <UnitName Value="PAXCOMP_SEH"/> + </Item53> + <Item54> + <Filename Value="PAXCOMP_STDLIB.pas"/> + <UnitName Value="PAXCOMP_STDLIB"/> + </Item54> + <Item55> + <Filename Value="PAXCOMP_SYMBOL_PROGRAM.pas"/> + <UnitName Value="PAXCOMP_SYMBOL_PROGRAM"/> + </Item55> + <Item56> + <Filename Value="PAXCOMP_SYMBOL_REC.pas"/> + <UnitName Value="PAXCOMP_SYMBOL_REC"/> + </Item56> + <Item57> + <Filename Value="PAXCOMP_SYMBOL_TABLE.pas"/> + <UnitName Value="PAXCOMP_SYMBOL_TABLE"/> + </Item57> + <Item58> + <Filename Value="PAXCOMP_SYS.pas"/> + <UnitName Value="PAXCOMP_SYS"/> + </Item58> + <Item59> + <Filename Value="PAXCOMP_TRYLST.pas"/> + <UnitName Value="PAXCOMP_TRYLST"/> + </Item59> + <Item60> + <Filename Value="PAXCOMP_TYPEINFO.pas"/> + <UnitName Value="PAXCOMP_TYPEINFO"/> + </Item60> + <Item61> + <Filename Value="PAXCOMP_VAROBJECT.pas"/> + <UnitName Value="PAXCOMP_VAROBJECT"/> + </Item61> + <Item62> + <Filename Value="PaxDllImport.pas"/> + <UnitName Value="PaxDllImport"/> + </Item62> + <Item63> + <Filename Value="PaxEval.pas"/> + <UnitName Value="PaxEval"/> + </Item63> + <Item64> + <Filename Value="PaxInfos.pas"/> + <UnitName Value="PaxInfos"/> + </Item64> + <Item65> + <Filename Value="PaxInterpreter.pas"/> + <UnitName Value="PaxInterpreter"/> + </Item65> + <Item66> + <Filename Value="PAXINT_CALL.pas"/> + <UnitName Value="PAXINT_CALL"/> + </Item66> + <Item67> + <Filename Value="PAXINT_CRT.pas"/> + <UnitName Value="PAXINT_CRT"/> + </Item67> + <Item68> + <Filename Value="PAXINT_RUNNER.pas"/> + <UnitName Value="PAXINT_RUNNER"/> + </Item68> + <Item69> + <Filename Value="PAXINT_SEH.pas"/> + <UnitName Value="PAXINT_SEH"/> + </Item69> + <Item70> + <Filename Value="PAXINT_SYS.pas"/> + <UnitName Value="PAXINT_SYS"/> + </Item70> + <Item71> + <Filename Value="PaxInvoke.pas"/> + <UnitName Value="PaxInvoke"/> + </Item71> + <Item72> + <Filename Value="PaxJavaScriptLanguage.pas"/> + <UnitName Value="PaxJavaScriptLanguage"/> + </Item72> + <Item73> + <Filename Value="PaxPE.pas"/> + <UnitName Value="PaxPE"/> + </Item73> + <Item74> + <Filename Value="PaxProgram.pas"/> + <UnitName Value="PaxProgram"/> + </Item74> + <Item75> + <Filename Value="PaxRegister.pas"/> + <UnitName Value="PaxRegister"/> + </Item75> + <Item76> + <Filename Value="PaxRunner.pas"/> + <UnitName Value="PaxRunner"/> + </Item76> + <Item77> + <Filename Value="RegExpr2.pas"/> + <UnitName Value="RegExpr2"/> + </Item77> + <Item78> + <Filename Value="PAXCOMP_TYPES.pas"/> + <UnitName Value="PAXCOMP_TYPES"/> + </Item78> + </Files> + <Type Value="RunAndDesignTime"/> + <RequiredPkgs Count="2"> + <Item1> + <PackageName Value="LCLBase"/> + </Item1> + <Item2> + <PackageName Value="FCL"/> + </Item2> + </RequiredPkgs> + <UsageOptions> + <UnitPath Value="$(PkgOutDir)"/> + </UsageOptions> + <PublishOptions> + <Version Value="2"/> + </PublishOptions> + </Package> +</CONFIG> diff --git a/Sources/lazarus32/paxcomp_lazarus32.pas b/Sources/lazarus32/paxcomp_lazarus32.pas new file mode 100644 index 0000000..79f061c --- /dev/null +++ b/Sources/lazarus32/paxcomp_lazarus32.pas @@ -0,0 +1,39 @@ +{ This file was automatically created by Lazarus. Do not edit! + This source is only used to compile and install the package. + } + +unit paxcomp_lazarus32; + +interface + +uses + PaxBasicLanguage, PaxCompiler, PaxCompilerDebugger, PaxCompilerDLL, + PaxCompilerExplorer, PaxCompilerRegister, PAXCOMP_2010, PAXCOMP_2010Reg, + PAXCOMP_BASERUNNER, PAXCOMP_BASESYMBOL_TABLE, PAXCOMP_Basic, + PAXCOMP_BASIC_PARSER, PAXCOMP_BASIC_SCANNER, PAXCOMP_BYTECODE, + PAXCOMP_CLASSFACT, PAXCOMP_CLASSLST, PAXCOMP_CONSTANTS, PAXCOMP_DISASM, + PAXCOMP_EMIT, PAXCOMP_ERROR, PAXCOMP_EVAL, PAXCOMP_EVENT, + PAXCOMP_EXTRASYMBOL_TABLE, PAXCOMP_FORBID, PAXCOMP_FRAMEWORK, PAXCOMP_GC, + PAXCOMP_GENERIC, PAXCOMP_HEADER_PARSER, PAXCOMP_HOSTCLS, PAXCOMP_INVOKE, + PAXCOMP_JavaScript, PAXCOMP_JS_CONV, PAXCOMP_JS_PARSER, PAXCOMP_JS_SCANNER, + PAXCOMP_KERNEL, PAXCOMP_LABEL_STACK, PAXCOMP_LOCALSYMBOL_TABLE, PAXCOMP_MAP, + PAXCOMP_MODULE, PAXCOMP_OFFSET, PAXCOMP_OLE, PAXCOMP_PARSER, + PAXCOMP_PASCAL_PARSER, PAXCOMP_PASCAL_SCANNER, PAXCOMP_PAUSE, PAXCOMP_PCU, + PAXCOMP_PE, PAXCOMP_PROG, PAXCOMP_PROGLIB, PAXCOMP_PROGLIST, PAXCOMP_RTI, + PAXCOMP_SCANNER, PAXCOMP_SEH, PAXCOMP_STDLIB, PAXCOMP_SYMBOL_PROGRAM, + PAXCOMP_SYMBOL_REC, PAXCOMP_SYMBOL_TABLE, PAXCOMP_SYS, PAXCOMP_TRYLST, + PAXCOMP_TYPEINFO, PAXCOMP_VAROBJECT, PaxDllImport, PaxEval, PaxInfos, + PaxInterpreter, PAXINT_CALL, PAXINT_CRT, PAXINT_RUNNER, PAXINT_SEH, + PAXINT_SYS, PaxInvoke, PaxJavaScriptLanguage, PaxPE, PaxProgram, + PaxRegister, PaxRunner, RegExpr2, PAXCOMP_TYPES, LazarusPackageIntf; + +implementation + +procedure Register; +begin + RegisterUnit('PaxCompilerRegister', @PaxCompilerRegister.Register); +end; + +initialization + RegisterPackage('paxcomp_lazarus32', @Register); +end. diff --git a/Sources/lazarus64/Demos/BindLFM/project1.ico b/Sources/lazarus64/Demos/BindLFM/project1.ico new file mode 100644 index 0000000..0341321 Binary files /dev/null and b/Sources/lazarus64/Demos/BindLFM/project1.ico differ diff --git a/Sources/lazarus64/Demos/BindLFM/project1.lpi b/Sources/lazarus64/Demos/BindLFM/project1.lpi new file mode 100644 index 0000000..88bbd50 --- /dev/null +++ b/Sources/lazarus64/Demos/BindLFM/project1.lpi @@ -0,0 +1,95 @@ +<?xml version="1.0"?> +<CONFIG> + <ProjectOptions> + <Version Value="9"/> + <PathDelim Value="\"/> + <General> + <SessionStorage Value="InProjectDir"/> + <MainUnit Value="0"/> + <Title Value="project1"/> + <ResourceType Value="res"/> + <UseXPManifest Value="True"/> + <Icon Value="0"/> + </General> + <i18n> + <EnableI18N LFM="False"/> + </i18n> + <VersionInfo> + <StringTable ProductVersion=""/> + </VersionInfo> + <BuildModes Count="1"> + <Item1 Name="Default" Default="True"/> + </BuildModes> + <PublishOptions> + <Version Value="2"/> + <IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/> + <ExcludeFileFilter Value="*.(bak|ppu|o|so);*~;backup"/> + </PublishOptions> + <RunParams> + <local> + <FormatVersion Value="1"/> + </local> + </RunParams> + <RequiredPackages Count="2"> + <Item1> + <PackageName Value="paxcomp_lazarus64"/> + </Item1> + <Item2> + <PackageName Value="LCL"/> + </Item2> + </RequiredPackages> + <Units Count="2"> + <Unit0> + <Filename Value="project1.lpr"/> + <IsPartOfProject Value="True"/> + <UnitName Value="project1"/> + </Unit0> + <Unit1> + <Filename Value="unit1.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="Form1"/> + <HasResources Value="True"/> + <ResourceBaseClass Value="Form"/> + <UnitName Value="Unit1"/> + </Unit1> + </Units> + </ProjectOptions> + <CompilerOptions> + <Version Value="11"/> + <PathDelim Value="\"/> + <Target> + <Filename Value="project1"/> + </Target> + <SearchPaths> + <IncludeFiles Value="$(ProjOutDir)"/> + <OtherUnitFiles Value="..\..\IMPORT"/> + <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/> + </SearchPaths> + <Linking> + <Options> + <Win32> + <GraphicApplication Value="True"/> + </Win32> + </Options> + </Linking> + <Other> + <CompilerMessages> + <MsgFileName Value=""/> + </CompilerMessages> + <CompilerPath Value="$(CompPath)"/> + </Other> + </CompilerOptions> + <Debugging> + <Exceptions Count="3"> + <Item1> + <Name Value="EAbort"/> + </Item1> + <Item2> + <Name Value="ECodetoolError"/> + </Item2> + <Item3> + <Name Value="EFOpenError"/> + </Item3> + </Exceptions> + </Debugging> +</CONFIG> diff --git a/Sources/lazarus64/Demos/BindLFM/project1.lpr b/Sources/lazarus64/Demos/BindLFM/project1.lpr new file mode 100644 index 0000000..53a218d --- /dev/null +++ b/Sources/lazarus64/Demos/BindLFM/project1.lpr @@ -0,0 +1,20 @@ +program project1; + +{$mode objfpc}{$H+} + +uses + {$IFDEF UNIX}{$IFDEF UseCThreads} + cthreads, + {$ENDIF}{$ENDIF} + Interfaces, // this includes the LCL widgetset + Forms, Unit1; + +{$R *.res} + +begin + RequireDerivedFormResource := True; + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. + diff --git a/Sources/lazarus64/Demos/BindLFM/project1.lps b/Sources/lazarus64/Demos/BindLFM/project1.lps new file mode 100644 index 0000000..37e44d7 --- /dev/null +++ b/Sources/lazarus64/Demos/BindLFM/project1.lps @@ -0,0 +1,165 @@ +<?xml version="1.0"?> +<CONFIG> + <ProjectSession> + <PathDelim Value="\"/> + <Version Value="9"/> + <BuildModes Active="Default"/> + <Units Count="18"> + <Unit0> + <Filename Value="project1.lpr"/> + <IsPartOfProject Value="True"/> + <UnitName Value="project1"/> + <UsageCount Value="31"/> + </Unit0> + <Unit1> + <Filename Value="unit1.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="Form1"/> + <HasResources Value="True"/> + <ResourceBaseClass Value="Form"/> + <UnitName Value="Unit1"/> + <IsVisibleTab Value="True"/> + <WindowIndex Value="0"/> + <TopLine Value="1"/> + <CursorPos X="40" Y="16"/> + <UsageCount Value="31"/> + </Unit1> + <Unit2> + <Filename Value="unit2.pas"/> + <ComponentName Value="Form2"/> + <HasResources Value="True"/> + <ResourceBaseClass Value="Form"/> + <UnitName Value="Unit2"/> + <WindowIndex Value="0"/> + <TopLine Value="28"/> + <CursorPos X="42" Y="39"/> + <UsageCount Value="31"/> + </Unit2> + <Unit3> + <Filename Value="..\..\paxcomp_lazarus64\PAXCOMP_KERNEL.pas"/> + <UnitName Value="PAXCOMP_KERNEL"/> + <WindowIndex Value="0"/> + <TopLine Value="900"/> + <CursorPos X="35" Y="903"/> + <UsageCount Value="10"/> + </Unit3> + <Unit4> + <Filename Value="..\..\paxcomp_lazarus64\PAXCOMP_SYS.pas"/> + <UnitName Value="PAXCOMP_SYS"/> + <WindowIndex Value="0"/> + <TopLine Value="1880"/> + <CursorPos X="1" Y="1891"/> + <UsageCount Value="14"/> + </Unit4> + <Unit5> + <Filename Value="..\..\paxcomp_lazarus64\PAXCOMP_INVOKE.pas"/> + <UnitName Value="PAXCOMP_INVOKE"/> + <WindowIndex Value="0"/> + <TopLine Value="967"/> + <CursorPos X="1" Y="983"/> + <UsageCount Value="10"/> + </Unit5> + <Unit6> + <Filename Value="..\..\paxcomp_lazarus64\PAXCOMP_BASERUNNER.pas"/> + <UnitName Value="PAXCOMP_BASERUNNER"/> + <WindowIndex Value="0"/> + <TopLine Value="174"/> + <CursorPos X="1" Y="187"/> + <UsageCount Value="16"/> + </Unit6> + <Unit7> + <Filename Value="..\..\paxcomp_lazarus64\PaxRunner.pas"/> + <UnitName Value="PaxRunner"/> + <WindowIndex Value="0"/> + <TopLine Value="901"/> + <CursorPos X="1" Y="910"/> + <UsageCount Value="15"/> + </Unit7> + <Unit8> + <Filename Value="..\..\paxcomp_lazarus64\PAXINT_RUNNER.pas"/> + <UnitName Value="PAXINT_RUNNER"/> + <WindowIndex Value="0"/> + <TopLine Value="7035"/> + <CursorPos X="1" Y="7043"/> + <UsageCount Value="15"/> + </Unit8> + <Unit9> + <Filename Value="C:\LAZ64\lcl\include\control.inc"/> + <WindowIndex Value="0"/> + <TopLine Value="5368"/> + <CursorPos X="1" Y="5377"/> + <UsageCount Value="15"/> + </Unit9> + <Unit10> + <Filename Value="C:\LAZ64\lcl\include\customform.inc"/> + <WindowIndex Value="0"/> + <TopLine Value="1971"/> + <CursorPos X="57" Y="1983"/> + <UsageCount Value="15"/> + </Unit10> + <Unit11> + <Filename Value="C:\LAZ64\fpc\2.6.2\source\rtl\objpas\typinfo.pp"/> + <UnitName Value="typinfo"/> + <WindowIndex Value="0"/> + <TopLine Value="205"/> + <CursorPos X="15" Y="220"/> + <UsageCount Value="15"/> + </Unit11> + <Unit12> + <Filename Value="..\..\paxcomp_lazarus64\PAXCOMP_TYPEINFO.pas"/> + <UnitName Value="PAXCOMP_TYPEINFO"/> + <WindowIndex Value="0"/> + <TopLine Value="1779"/> + <CursorPos X="48" Y="1782"/> + <UsageCount Value="15"/> + </Unit12> + <Unit13> + <Filename Value="C:\LAZ64\fpc\2.6.2\source\rtl\inc\objpash.inc"/> + <WindowIndex Value="0"/> + <TopLine Value="206"/> + <CursorPos X="54" Y="217"/> + <UsageCount Value="14"/> + </Unit13> + <Unit14> + <Filename Value="..\..\paxcomp_lazarus64\PAXINT_CRT.pas"/> + <UnitName Value="PAXINT_CRT"/> + <WindowIndex Value="0"/> + <TopLine Value="418"/> + <CursorPos X="1" Y="432"/> + <UsageCount Value="10"/> + </Unit14> + <Unit15> + <Filename Value="..\..\paxcomp_lazarus64\PAXCOMP_CLASSFACT.pas"/> + <UnitName Value="PAXCOMP_CLASSFACT"/> + <WindowIndex Value="0"/> + <TopLine Value="134"/> + <CursorPos X="4" Y="148"/> + <UsageCount Value="10"/> + </Unit15> + <Unit16> + <Filename Value="..\..\paxcomp_lazarus64\PAXCOMP_BYTECODE.pas"/> + <UnitName Value="PAXCOMP_BYTECODE"/> + <WindowIndex Value="0"/> + <TopLine Value="27577"/> + <CursorPos X="1" Y="27590"/> + <UsageCount Value="10"/> + </Unit16> + <Unit17> + <Filename Value="..\..\paxcomp_lazarus64\PAXCOMP_PROGLIB.pas"/> + <UnitName Value="PAXCOMP_PROGLIB"/> + <WindowIndex Value="0"/> + <TopLine Value="51"/> + <CursorPos X="5" Y="60"/> + <UsageCount Value="10"/> + </Unit17> + </Units> + <JumpHistory Count="0" HistoryIndex="-1"/> + </ProjectSession> + <Debugging> + <Watches Count="1"> + <Item1> + <Expression Value="R.MethodTableSize"/> + </Item1> + </Watches> + </Debugging> +</CONFIG> diff --git a/Sources/lazarus64/Demos/BindLFM/project1.res b/Sources/lazarus64/Demos/BindLFM/project1.res new file mode 100644 index 0000000..7c6cf3e Binary files /dev/null and b/Sources/lazarus64/Demos/BindLFM/project1.res differ diff --git a/Sources/lazarus64/Demos/BindLFM/unit1.lfm b/Sources/lazarus64/Demos/BindLFM/unit1.lfm new file mode 100644 index 0000000..18ad236 --- /dev/null +++ b/Sources/lazarus64/Demos/BindLFM/unit1.lfm @@ -0,0 +1,60 @@ +object Form1: TForm1 + Left = 239 + Height = 384 + Top = 167 + Width = 638 + Caption = 'Bind LFM file' + ClientHeight = 384 + ClientWidth = 638 + LCLVersion = '1.0.12.0' + object Button1: TButton + Left = 448 + Height = 25 + Top = 96 + Width = 75 + Caption = 'Run script' + OnClick = Button1Click + TabOrder = 0 + end + object Memo1: TMemo + Left = 24 + Height = 350 + Top = 23 + Width = 300 + Lines.Strings = ( + 'uses' + ' Unit2;' + 'begin' + ' Form2 := TForm2.Create(nil);' + ' try' + ' Form2.ShowModal;' + ' finally' + ' Form2.Free; ' + ' end;' + 'end.' + ) + TabOrder = 1 + end + object PaxCompiler1: TPaxCompiler + Alignment = 8 + OnUnknownDirective = PaxCompiler1UnknownDirective + DebugMode = False + left = 456 + top = 40 + end + object PaxPascalLanguage1: TPaxPascalLanguage + ExplicitOff = False + CompleteBooleanEval = False + UnitLookup = True + PrintKeyword = 'print' + PrintlnKeyword = 'println' + left = 408 + top = 112 + end + object PaxInterpreter1: TPaxInterpreter + Console = False + OnCreateObject = PaxInterpreter1CreateObject + left = 520 + top = 184 + end +end diff --git a/Sources/lazarus64/Demos/BindLFM/unit1.pas b/Sources/lazarus64/Demos/BindLFM/unit1.pas new file mode 100644 index 0000000..4232c09 --- /dev/null +++ b/Sources/lazarus64/Demos/BindLFM/unit1.pas @@ -0,0 +1,73 @@ +unit Unit1; + +{$mode objfpc}{$H+} + +interface + +uses + TypInfo, + Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls, + PaxCompiler, PaxInterpreter, IMPORT_Common, PaxRunner; + +type + + { TForm1 } + + TForm1 = class(TForm) + Button1: TButton; + Memo1: TMemo; + PaxCompiler1: TPaxCompiler; + PaxInterpreter1: TPaxInterpreter; + PaxPascalLanguage1: TPaxPascalLanguage; + procedure Button1Click(Sender: TObject); + procedure PaxCompiler1UnknownDirective(Sender: TPaxCompiler; + const Directive: String; var ok: Boolean); + procedure PaxInterpreter1CreateObject(Sender: TPaxRunner; Instance: TObject + ); + private + { private declarations } + CurrModule: String; + public + { public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.lfm} + +{ TForm1 } + +procedure TForm1.Button1Click(Sender: TObject); +begin + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + PaxCompiler1.AddModule('1', 'Pascal'); + PaxCompiler1.AddCode('1', Memo1.Lines.Text); + if PaxCompiler1.Compile(PaxInterpreter1) then + begin + PaxInterpreter1.Run; + end + else + ShowMessage(PaxCompiler1.ErrorMessage[0]); +end; + +procedure TForm1.PaxCompiler1UnknownDirective(Sender: TPaxCompiler; + const Directive: String; var ok: Boolean); +begin + setdump; + ok := true; + CurrModule := Sender.CurrModuleName; +end; + +procedure TForm1.PaxInterpreter1CreateObject(Sender: TPaxRunner; + Instance: TObject); +begin + if Instance is TForm then + Sender.LoadDFMFile(Instance, CurrModule + '.lfm'); +end; + +end. + diff --git a/Sources/lazarus64/Demos/BindLFM/unit2.lfm b/Sources/lazarus64/Demos/BindLFM/unit2.lfm new file mode 100644 index 0000000..e75ccb9 --- /dev/null +++ b/Sources/lazarus64/Demos/BindLFM/unit2.lfm @@ -0,0 +1,20 @@ +object Form2: TForm2 + Left = 507 + Height = 240 + Top = 237 + Width = 320 + Caption = 'Form2' + ClientHeight = 240 + ClientWidth = 320 + OnCreate = FormCreate + LCLVersion = '1.0.12.0' + object Button1: TButton + Left = 37 + Height = 25 + Top = 35 + Width = 75 + Caption = 'Say Hello' + OnClick = Button1Click + TabOrder = 0 + end +end diff --git a/Sources/lazarus64/Demos/BindLFM/unit2.pas b/Sources/lazarus64/Demos/BindLFM/unit2.pas new file mode 100644 index 0000000..76159e5 --- /dev/null +++ b/Sources/lazarus64/Demos/BindLFM/unit2.pas @@ -0,0 +1,45 @@ +unit Unit2; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, Forms, Controls, Dialogs, StdCtrls; + +type + + { TForm2 } + + TForm2 = class(TForm) + Button1: TButton; + procedure Button1Click(Sender: TObject); + procedure FormCreate(Sender: TObject); + private + { private declarations } + public + { public declarations } + end; + +var + Form2: TForm2; + +implementation + +{$R *.lfm} + +{ TForm2 } + + +procedure TForm2.Button1Click(Sender: TObject); +begin + ShowMessage('Hello!'); +end; + +procedure TForm2.FormCreate(Sender: TObject); +begin + ShowMessage('Script form is created.'); +end; + +end. + diff --git a/Sources/lazarus64/Demos/CallInterfaceMethod/project1.ico b/Sources/lazarus64/Demos/CallInterfaceMethod/project1.ico new file mode 100644 index 0000000..0341321 Binary files /dev/null and b/Sources/lazarus64/Demos/CallInterfaceMethod/project1.ico differ diff --git a/Sources/lazarus64/Demos/CallInterfaceMethod/project1.lpi b/Sources/lazarus64/Demos/CallInterfaceMethod/project1.lpi new file mode 100644 index 0000000..0409699 --- /dev/null +++ b/Sources/lazarus64/Demos/CallInterfaceMethod/project1.lpi @@ -0,0 +1,93 @@ +<?xml version="1.0"?> +<CONFIG> + <ProjectOptions> + <Version Value="9"/> + <PathDelim Value="\"/> + <General> + <SessionStorage Value="InProjectDir"/> + <MainUnit Value="0"/> + <Title Value="project1"/> + <ResourceType Value="res"/> + <UseXPManifest Value="True"/> + <Icon Value="0"/> + </General> + <i18n> + <EnableI18N LFM="False"/> + </i18n> + <VersionInfo> + <StringTable ProductVersion=""/> + </VersionInfo> + <BuildModes Count="1"> + <Item1 Name="Default" Default="True"/> + </BuildModes> + <PublishOptions> + <Version Value="2"/> + <IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/> + <ExcludeFileFilter Value="*.(bak|ppu|o|so);*~;backup"/> + </PublishOptions> + <RunParams> + <local> + <FormatVersion Value="1"/> + </local> + </RunParams> + <RequiredPackages Count="2"> + <Item1> + <PackageName Value="paxcomp_lazarus64"/> + </Item1> + <Item2> + <PackageName Value="LCL"/> + </Item2> + </RequiredPackages> + <Units Count="2"> + <Unit0> + <Filename Value="project1.lpr"/> + <IsPartOfProject Value="True"/> + <UnitName Value="project1"/> + </Unit0> + <Unit1> + <Filename Value="unit1.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="Form1"/> + <ResourceBaseClass Value="Form"/> + <UnitName Value="Unit1"/> + </Unit1> + </Units> + </ProjectOptions> + <CompilerOptions> + <Version Value="11"/> + <PathDelim Value="\"/> + <Target> + <Filename Value="project1"/> + </Target> + <SearchPaths> + <IncludeFiles Value="$(ProjOutDir)"/> + <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/> + </SearchPaths> + <Linking> + <Options> + <Win32> + <GraphicApplication Value="True"/> + </Win32> + </Options> + </Linking> + <Other> + <CompilerMessages> + <MsgFileName Value=""/> + </CompilerMessages> + <CompilerPath Value="$(CompPath)"/> + </Other> + </CompilerOptions> + <Debugging> + <Exceptions Count="3"> + <Item1> + <Name Value="EAbort"/> + </Item1> + <Item2> + <Name Value="ECodetoolError"/> + </Item2> + <Item3> + <Name Value="EFOpenError"/> + </Item3> + </Exceptions> + </Debugging> +</CONFIG> diff --git a/Sources/lazarus64/Demos/CallInterfaceMethod/project1.lpr b/Sources/lazarus64/Demos/CallInterfaceMethod/project1.lpr new file mode 100644 index 0000000..ced6d82 --- /dev/null +++ b/Sources/lazarus64/Demos/CallInterfaceMethod/project1.lpr @@ -0,0 +1,21 @@ +program project1; + +{$mode objfpc}{$H+} + +uses + {$IFDEF UNIX}{$IFDEF UseCThreads} + cthreads, + {$ENDIF}{$ENDIF} + Interfaces, // this includes the LCL widgetset + Forms, Unit1 + { you can add units after this }; + +{$R *.res} + +begin + RequireDerivedFormResource := True; + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. + diff --git a/Sources/lazarus64/Demos/CallInterfaceMethod/project1.lps b/Sources/lazarus64/Demos/CallInterfaceMethod/project1.lps new file mode 100644 index 0000000..017fabf --- /dev/null +++ b/Sources/lazarus64/Demos/CallInterfaceMethod/project1.lps @@ -0,0 +1,38 @@ +<?xml version="1.0"?> +<CONFIG> + <ProjectSession> + <PathDelim Value="\"/> + <Version Value="9"/> + <BuildModes Active="Default"/> + <Units Count="3"> + <Unit0> + <Filename Value="project1.lpr"/> + <IsPartOfProject Value="True"/> + <UnitName Value="project1"/> + <UsageCount Value="20"/> + </Unit0> + <Unit1> + <Filename Value="unit1.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="Form1"/> + <HasResources Value="True"/> + <ResourceBaseClass Value="Form"/> + <UnitName Value="Unit1"/> + <IsVisibleTab Value="True"/> + <WindowIndex Value="0"/> + <TopLine Value="13"/> + <CursorPos X="48" Y="20"/> + <UsageCount Value="20"/> + </Unit1> + <Unit2> + <Filename Value="..\..\paxcomp_lazarus64\PAXCOMP_KERNEL.pas"/> + <UnitName Value="PAXCOMP_KERNEL"/> + <WindowIndex Value="0"/> + <TopLine Value="900"/> + <CursorPos X="1" Y="909"/> + <UsageCount Value="10"/> + </Unit2> + </Units> + <JumpHistory Count="0" HistoryIndex="-1"/> + </ProjectSession> +</CONFIG> diff --git a/Sources/lazarus64/Demos/CallInterfaceMethod/project1.res b/Sources/lazarus64/Demos/CallInterfaceMethod/project1.res new file mode 100644 index 0000000..7c6cf3e Binary files /dev/null and b/Sources/lazarus64/Demos/CallInterfaceMethod/project1.res differ diff --git a/Sources/lazarus64/Demos/CallInterfaceMethod/unit1.lfm b/Sources/lazarus64/Demos/CallInterfaceMethod/unit1.lfm new file mode 100644 index 0000000..75dbe98 --- /dev/null +++ b/Sources/lazarus64/Demos/CallInterfaceMethod/unit1.lfm @@ -0,0 +1,70 @@ +object Form1: TForm1 + Left = 277 + Height = 591 + Top = 45 + Width = 639 + Caption = 'Call interface method' + ClientHeight = 591 + ClientWidth = 639 + LCLVersion = '1.0.12.0' + object Button1: TButton + Left = 505 + Height = 25 + Top = 267 + Width = 75 + Caption = 'Run script' + OnClick = Button1Click + TabOrder = 0 + end + object Memo1: TMemo + Left = 16 + Height = 550 + Top = 8 + Width = 400 + Lines.Strings = ( + 'type' + ' TMyScriptClass = class(TInterfacedObject, IMyInterface)' + ' public ' + ' function Add(X, Y: Integer): Integer; ' + ' destructor Destroy; override;' + ' end;' + 'function TMyScriptClass.Add(X, Y: Integer): Integer;' + 'begin' + ' print ''Hello from script!'';' + ' result := X + Y;' + 'end;' + 'destructor TMyScriptClass.Destroy; ' + 'begin' + ' print ''Script object has been destroyed.'';' + ' inherited;' + 'end;' + 'var' + ' X: TMyScriptClass;' + 'begin' + ' X := TMyScriptClass.Create;' + ' PassToHost(X, 3, 4);' + 'end.' + ) + TabOrder = 1 + end + object PaxCompiler1: TPaxCompiler + Alignment = 8 + DebugMode = False + left = 464 + top = 120 + end + object PaxPascalLanguage1: TPaxPascalLanguage + ExplicitOff = False + CompleteBooleanEval = False + UnitLookup = True + PrintKeyword = 'print' + PrintlnKeyword = 'println' + left = 424 + top = 24 + end + object PaxInterpreter1: TPaxInterpreter + Console = False + left = 496 + top = 56 + end +end diff --git a/Sources/lazarus64/Demos/CallInterfaceMethod/unit1.pas b/Sources/lazarus64/Demos/CallInterfaceMethod/unit1.pas new file mode 100644 index 0000000..29f3457 --- /dev/null +++ b/Sources/lazarus64/Demos/CallInterfaceMethod/unit1.pas @@ -0,0 +1,77 @@ +unit Unit1; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls, + PaxCompiler, PaxInterpreter, PaxRegister; + +type + + { TForm1 } + + TForm1 = class(TForm) + Button1: TButton; + Memo1: TMemo; + PaxCompiler1: TPaxCompiler; + PaxInterpreter1: TPaxInterpreter; + PaxPascalLanguage1: TPaxPascalLanguage; + procedure Button1Click(Sender: TObject); + private + { private declarations } + public + { public declarations } + end; + + IMyInterface = interface + ['{D13115CA-4D57-4242-A54B-3684870CC7B3}'] + function Add(X, Y: Integer): Integer; + end; + +var + Form1: TForm1; + +implementation + +{$R *.lfm} + +procedure PassToHost(X: IMyInterface; P1, P2: Integer); +begin + ShowMessage('Result = ' + IntToStr(X.Add(P1, P2))); +end; + +{ TForm1 } + +procedure TForm1.Button1Click(Sender: TObject); +begin + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + PaxCompiler1.AddModule('1', 'Pascal'); + PaxCompiler1.AddCode('1', Memo1.Lines.Text); + if PaxCompiler1.Compile(PaxInterpreter1) then + begin + PaxInterpreter1.Run; + end + else + begin + ShowMessage(PaxCompiler1.ErrorMessage[0]); + end; +end; + +var I: Integer; + +initialization + +I := RegisterInterfaceType(0, 'IMyInterface', IMyInterface); +RegisterHeader(I, + 'function Add(X, Y: Integer): Integer;', nil, -1); + +RegisterHeader(0, + 'procedure PassToHost(X: IMyInterface; P1, P2: Integer);', + @ PassToHost); + + +end. + diff --git a/Sources/lazarus64/Demos/DebugDemo/project1.ico b/Sources/lazarus64/Demos/DebugDemo/project1.ico new file mode 100644 index 0000000..0341321 Binary files /dev/null and b/Sources/lazarus64/Demos/DebugDemo/project1.ico differ diff --git a/Sources/lazarus64/Demos/DebugDemo/project1.lpi b/Sources/lazarus64/Demos/DebugDemo/project1.lpi new file mode 100644 index 0000000..0409699 --- /dev/null +++ b/Sources/lazarus64/Demos/DebugDemo/project1.lpi @@ -0,0 +1,93 @@ +<?xml version="1.0"?> +<CONFIG> + <ProjectOptions> + <Version Value="9"/> + <PathDelim Value="\"/> + <General> + <SessionStorage Value="InProjectDir"/> + <MainUnit Value="0"/> + <Title Value="project1"/> + <ResourceType Value="res"/> + <UseXPManifest Value="True"/> + <Icon Value="0"/> + </General> + <i18n> + <EnableI18N LFM="False"/> + </i18n> + <VersionInfo> + <StringTable ProductVersion=""/> + </VersionInfo> + <BuildModes Count="1"> + <Item1 Name="Default" Default="True"/> + </BuildModes> + <PublishOptions> + <Version Value="2"/> + <IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/> + <ExcludeFileFilter Value="*.(bak|ppu|o|so);*~;backup"/> + </PublishOptions> + <RunParams> + <local> + <FormatVersion Value="1"/> + </local> + </RunParams> + <RequiredPackages Count="2"> + <Item1> + <PackageName Value="paxcomp_lazarus64"/> + </Item1> + <Item2> + <PackageName Value="LCL"/> + </Item2> + </RequiredPackages> + <Units Count="2"> + <Unit0> + <Filename Value="project1.lpr"/> + <IsPartOfProject Value="True"/> + <UnitName Value="project1"/> + </Unit0> + <Unit1> + <Filename Value="unit1.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="Form1"/> + <ResourceBaseClass Value="Form"/> + <UnitName Value="Unit1"/> + </Unit1> + </Units> + </ProjectOptions> + <CompilerOptions> + <Version Value="11"/> + <PathDelim Value="\"/> + <Target> + <Filename Value="project1"/> + </Target> + <SearchPaths> + <IncludeFiles Value="$(ProjOutDir)"/> + <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/> + </SearchPaths> + <Linking> + <Options> + <Win32> + <GraphicApplication Value="True"/> + </Win32> + </Options> + </Linking> + <Other> + <CompilerMessages> + <MsgFileName Value=""/> + </CompilerMessages> + <CompilerPath Value="$(CompPath)"/> + </Other> + </CompilerOptions> + <Debugging> + <Exceptions Count="3"> + <Item1> + <Name Value="EAbort"/> + </Item1> + <Item2> + <Name Value="ECodetoolError"/> + </Item2> + <Item3> + <Name Value="EFOpenError"/> + </Item3> + </Exceptions> + </Debugging> +</CONFIG> diff --git a/Sources/lazarus64/Demos/DebugDemo/project1.lpr b/Sources/lazarus64/Demos/DebugDemo/project1.lpr new file mode 100644 index 0000000..ced6d82 --- /dev/null +++ b/Sources/lazarus64/Demos/DebugDemo/project1.lpr @@ -0,0 +1,21 @@ +program project1; + +{$mode objfpc}{$H+} + +uses + {$IFDEF UNIX}{$IFDEF UseCThreads} + cthreads, + {$ENDIF}{$ENDIF} + Interfaces, // this includes the LCL widgetset + Forms, Unit1 + { you can add units after this }; + +{$R *.res} + +begin + RequireDerivedFormResource := True; + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. + diff --git a/Sources/lazarus64/Demos/DebugDemo/project1.lps b/Sources/lazarus64/Demos/DebugDemo/project1.lps new file mode 100644 index 0000000..cb38a88 --- /dev/null +++ b/Sources/lazarus64/Demos/DebugDemo/project1.lps @@ -0,0 +1,29 @@ +<?xml version="1.0"?> +<CONFIG> + <ProjectSession> + <PathDelim Value="\"/> + <Version Value="9"/> + <BuildModes Active="Default"/> + <Units Count="2"> + <Unit0> + <Filename Value="project1.lpr"/> + <IsPartOfProject Value="True"/> + <UnitName Value="project1"/> + <UsageCount Value="20"/> + </Unit0> + <Unit1> + <Filename Value="unit1.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="Form1"/> + <ResourceBaseClass Value="Form"/> + <UnitName Value="Unit1"/> + <IsVisibleTab Value="True"/> + <WindowIndex Value="0"/> + <TopLine Value="113"/> + <CursorPos X="60" Y="122"/> + <UsageCount Value="20"/> + </Unit1> + </Units> + <JumpHistory Count="0" HistoryIndex="-1"/> + </ProjectSession> +</CONFIG> diff --git a/Sources/lazarus64/Demos/DebugDemo/project1.res b/Sources/lazarus64/Demos/DebugDemo/project1.res new file mode 100644 index 0000000..7c6cf3e Binary files /dev/null and b/Sources/lazarus64/Demos/DebugDemo/project1.res differ diff --git a/Sources/lazarus64/Demos/DebugDemo/unit1.lfm b/Sources/lazarus64/Demos/DebugDemo/unit1.lfm new file mode 100644 index 0000000..938ef47 --- /dev/null +++ b/Sources/lazarus64/Demos/DebugDemo/unit1.lfm @@ -0,0 +1,105 @@ +object Form1: TForm1 + Left = 251 + Height = 547 + Top = 119 + Width = 727 + Caption = 'Debug' + ClientHeight = 547 + ClientWidth = 727 + OnCloseQuery = FormCloseQuery + LCLVersion = '1.0.12.0' + object Memo1: TMemo + Left = 16 + Height = 300 + Top = 16 + Width = 450 + Lines.Strings = ( + 'function Fact(N: Integer): Integer;' + 'begin' + ' if N = 1 then' + ' result := 1' + ' else' + ' result := N * Fact(N - 1);' + 'end;' + 'var' + ' SS: Integer;' + 'begin' + ' SS := Fact(3);' + ' print(SS);' + 'end.' + ) + TabOrder = 0 + end + object Memo2: TMemo + Left = 16 + Height = 200 + Top = 328 + Width = 450 + TabOrder = 1 + end + object Button1: TButton + Left = 531 + Height = 25 + Top = 78 + Width = 75 + Caption = 'Compile' + OnClick = Button1Click + TabOrder = 2 + end + object Button2: TButton + Left = 534 + Height = 25 + Top = 140 + Width = 75 + Caption = 'Run' + OnClick = Button2Click + TabOrder = 3 + end + object Button3: TButton + Left = 536 + Height = 25 + Top = 204 + Width = 75 + Caption = 'Trace Into' + OnClick = Button3Click + TabOrder = 4 + end + object Button4: TButton + Left = 534 + Height = 25 + Top = 265 + Width = 75 + Caption = 'Step Over' + OnClick = Button4Click + TabOrder = 5 + end + object PaxCompiler1: TPaxCompiler + Alignment = 8 + DebugMode = False + left = 628 + top = 36 + end + object PaxPascalLanguage1: TPaxPascalLanguage + ExplicitOff = False + CompleteBooleanEval = False + UnitLookup = True + PrintKeyword = 'print' + PrintlnKeyword = 'println' + left = 627 + top = 101 + end + object PaxInterpreter1: TPaxInterpreter + Console = False + OnPauseUpdated = PaxInterpreter1PauseUpdated + left = 636 + top = 182 + end + object PaxCompilerDebugger1: TPaxCompilerDebugger + left = 639 + top = 260 + end + object PaxCompilerExplorer1: TPaxCompilerExplorer + left = 619 + top = 354 + end +end diff --git a/Sources/lazarus64/Demos/DebugDemo/unit1.pas b/Sources/lazarus64/Demos/DebugDemo/unit1.pas new file mode 100644 index 0000000..b800eba --- /dev/null +++ b/Sources/lazarus64/Demos/DebugDemo/unit1.pas @@ -0,0 +1,331 @@ +unit Unit1; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls, + PaxCompiler, PaxInterpreter, PaxCompilerDebugger, PaxCompilerExplorer, + PaxRegister, PaxRunner; + +type + + { TForm1 } + + TForm1 = class(TForm) + Button1: TButton; + Button2: TButton; + Button3: TButton; + Button4: TButton; + Memo1: TMemo; + Memo2: TMemo; + PaxCompiler1: TPaxCompiler; + PaxCompilerDebugger1: TPaxCompilerDebugger; + PaxCompilerExplorer1: TPaxCompilerExplorer; + PaxInterpreter1: TPaxInterpreter; + PaxPascalLanguage1: TPaxPascalLanguage; + procedure Button1Click(Sender: TObject); + procedure Button2Click(Sender: TObject); + procedure Button3Click(Sender: TObject); + procedure Button4Click(Sender: TObject); + procedure FormCloseQuery(Sender: TObject; var CanClose: boolean); + procedure PaxInterpreter1PauseUpdated(Sender: TPaxRunner; + const ModuleName: String; SourceLineNumber: Integer); + private + ResumeRequest: Boolean; + CloseRequest: Boolean; + + function TestValid: Boolean; + procedure UpdateDebugInfo; + public + { public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.lfm} + +{ TForm1 } + +procedure TForm1.Button1Click(Sender: TObject); +var + I: Integer; +begin + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + PaxCompiler1.AddModule('1', PaxPascalLanguage1.LanguageName); + PaxCompiler1.AddCode('1', Memo1.Lines.Text); + PaxCompiler1.DebugMode := true; + if PaxCompiler1.Compile(PaxInterpreter1) then + begin + ShowMessage('Script has been successfully recompiled.'); + PaxCompilerExplorer1.RegisterCompiler(PaxCompiler1); + PaxCompilerDebugger1.RegisterCompiler(PaxCompiler1, PaxInterpreter1); + end + else + for I:=0 to PaxCompiler1.ErrorCount - 1 do + ShowMessage(PaxCompiler1.ErrorMessage[I]); +end; + +procedure TForm1.Button2Click(Sender: TObject); +begin + if not TestValid then Exit; + + PaxCompilerDebugger1.RunMode := _rmRUN; + if PaxCompilerDebugger1.IsPaused then + ResumeRequest := true + else + PaxCompilerDebugger1.Run; +end; + +procedure TForm1.Button3Click(Sender: TObject); +begin + if not TestValid then Exit; + + PaxCompilerDebugger1.RunMode := _rmTRACE_INTO; + if PaxCompilerDebugger1.IsPaused then + ResumeRequest := true + else + PaxCompilerDebugger1.Run; +end; + +procedure TForm1.Button4Click(Sender: TObject); +begin + if not TestValid then Exit; + + PaxCompilerDebugger1.RunMode := _rmSTEP_OVER; + if PaxCompilerDebugger1.IsPaused then + ResumeRequest := true + else + PaxCompilerDebugger1.Run; +end; + +procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: boolean); +begin + CanClose := true; + CloseRequest := true; +end; + +procedure TForm1.PaxInterpreter1PauseUpdated(Sender: TPaxRunner; + const ModuleName: String; SourceLineNumber: Integer); +begin + UpdateDebugInfo; + ResumeRequest := false; + repeat + Application.ProcessMessages; + if ResumeRequest then + Break; + if CloseRequest then + Abort; + until false; +end; + +function TForm1.TestValid: Boolean; +begin + result := PaxCompilerDebugger1.Valid; + if not result then + ShowMessage('You have to compile script. Press "Compile" button.'); +end; + +procedure TForm1.UpdateDebugInfo; + + procedure AddFields(StackFrameNumber, Id: Integer); + var + I, K: Integer; + OwnerName, S: String; + begin + K := PaxCompilerExplorer1.GetFieldCount(Id); + if K = 0 then + Exit; + + OwnerName := PaxCompilerExplorer1.Names[Id]; + if PaxCompilerDebugger1.GetValueAsString(Id) = 'nil' then + Exit; + + for I:=0 to K - 1 do + begin + S := OwnerName + '.' + PaxCompilerExplorer1.GetFieldName(Id, I); + S := ' ' + S + '=' + PaxCompilerDebugger1.GetFieldValueAsString( + StackFrameNumber, Id, I); + Memo2.Lines.Add(S); + end; + end; + + procedure AddPublishedProps(StackFrameNumber, Id: Integer); + var + I, K: Integer; + OwnerName, S: String; + begin + K := PaxCompilerExplorer1.GetPublishedPropCount(Id); + if K = 0 then + Exit; + + OwnerName := PaxCompilerExplorer1.Names[Id]; + if PaxCompilerDebugger1.GetValueAsString(Id) = 'nil' then + Exit; + + for I:=0 to K - 1 do + begin + S := OwnerName + '.' + PaxCompilerExplorer1.GetPublishedPropName(Id, I); + S := ' ' + S + '=' + PaxCompilerDebugger1.GetPublishedPropValueAsString( + StackFrameNumber, Id, I); + Memo2.Lines.Add(S); + end; + end; + + procedure AddArrayElements(StackFrameNumber, Id: Integer); + var + I, K1, K2: Integer; + OwnerName, S: String; + begin + if not PaxCompilerExplorer1.HasArrayType(Id) then + Exit; + + K1 := PaxCompilerExplorer1.GetArrayLowBound(Id); + K2 := PaxCompilerExplorer1.GetArrayHighBound(Id); + + OwnerName := PaxCompilerExplorer1.Names[Id]; + + for I:=K1 to K2 do + begin + S := OwnerName + '[' + IntToStr(I) + ']'; + S := ' ' + S + '=' + PaxCompilerDebugger1.GetArrayItemValueAsString( + StackFrameNumber, Id, I); + Memo2.Lines.Add(S); + end; + end; + + procedure AddDynArrayElements(StackFrameNumber, Id: Integer); + var + I, L: Integer; + OwnerName, S: String; + begin + if not PaxCompilerExplorer1.HasDynArrayType(Id) then + Exit; + + L := PaxCompilerDebugger1.GetDynArrayLength(StackFrameNumber, Id); + + OwnerName := PaxCompilerExplorer1.Names[Id]; + + for I:=0 to L - 1 do + begin + S := OwnerName + '[' + IntToStr(I) + ']'; + S := ' ' + S + '=' + PaxCompilerDebugger1.GetDynArrayItemValueAsString( + StackFrameNumber, Id, I); + Memo2.Lines.Add(S); + end; + end; + +var + SourceLineNumber: Integer; + ModuleName: String; + StackFrameNumber, J, K, SubId, Id: Integer; + S, V: String; + CallStackLineNumber: Integer; + CallStackModuleName: String; +begin + Memo2.Lines.Clear; + if PaxCompilerDebugger1.IsPaused then + begin + ModuleName := PaxCompilerDebugger1.ModuleName; + SourceLineNumber := PaxCompilerDebugger1.SourceLineNumber; + + Memo2.Lines.Add('Paused at line ' + IntTosTr(SourceLineNumber)); + Memo2.Lines.Add(PaxCompiler1.Modules[ModuleName][SourceLineNumber]); + Memo2.Lines.Add('------------------------------------------------------'); + + if PaxCompilerDebugger1.CallStackCount > 0 then + begin + Memo2.Lines.Add('Call stack:'); + for StackFrameNumber:=0 to PaxCompilerDebugger1.CallStackCount - 1 do + begin + SubId := PaxCompilerDebugger1.CallStack[StackFrameNumber]; + S := '('; + K := PaxCompilerExplorer1.GetParamCount(SubId); + for J:=0 to K - 1 do + begin + Id := PaxCompilerExplorer1.GetParamId(SubId, J); + V := PaxCompilerDebugger1.GetValueAsString(StackFrameNumber, Id); + S := S + V; + if J < K - 1 then + S := S + ','; + end; + S := PaxCompilerExplorer1.Names[SubId] + S + ')'; + + CallStackLineNumber := PaxCompilerDebugger1.CallStackLineNumber[StackFrameNumber]; + CallStackModuleName := PaxCompilerDebugger1.CallStackModuleName[StackFrameNumber]; + + S := S + '; // ' + PaxCompiler1.Modules[CallStackModuleName][CallStackLineNumber]; + + Memo2.Lines.Add(S); + end; + Memo2.Lines.Add('------------------------------------------------------'); + + Memo2.Lines.Add('Local scope:'); + StackFrameNumber := PaxCompilerDebugger1.CallStackCount - 1; + SubId := PaxCompilerDebugger1.CallStack[StackFrameNumber]; + K := PaxCompilerExplorer1.GetLocalCount(SubId); + for J:=0 to K - 1 do + begin + Id := PaxCompilerExplorer1.GetLocalId(SubId, J); + V := PaxCompilerDebugger1.GetValueAsString(StackFrameNumber, Id); + S := PaxCompilerExplorer1.Names[Id] + '=' + V; + Memo2.Lines.Add(S); + + if Pos('X', S) > 0 then + begin + PaxCompilerDebugger1.PutValue(StackFrameNumber, Id, 258); + + V := PaxCompilerDebugger1.GetValueAsString(StackFrameNumber, Id); + S := PaxCompilerExplorer1.Names[Id] + '=' + V; + S := S + ' // modified'; + Memo2.Lines.Add(S); + end; + + AddFields(StackFrameNumber, Id); + AddPublishedProps(StackFrameNumber, Id); + AddArrayElements(StackFrameNumber, Id); + AddDynArrayElements(StackFrameNumber, Id); + end; + + Memo2.Lines.Add('------------------------------------------------------'); + end; + + Memo2.Lines.Add('Global scope:'); + K := PaxCompilerExplorer1.GetGlobalCount(0); + for J:=0 to K - 1 do + begin + Id := PaxCompilerExplorer1.GetGlobalId(0, J); + V := PaxCompilerDebugger1.GetValueAsString(Id); + S := PaxCompilerExplorer1.Names[Id] + '=' + V; + Memo2.Lines.Add(S); + + AddFields(0, Id); + AddPublishedProps(0, Id); + AddArrayElements(0, Id); + AddDynArrayElements(0, Id); + end; + Memo2.Lines.Add('------------------------------------------------------'); + + end + else + Memo2.Lines.Add('Finished'); + + Memo2.SelStart := 0; + Memo2.SelLength := 0; +end; + +procedure Print(I: Integer); +begin + ShowMessage(IntToStr(I)); +end; + +initialization + RegisterHeader(0, 'procedure Print(I: Integer);', @Print); + +end. + diff --git a/Sources/lazarus64/Demos/Hello/project1.ico b/Sources/lazarus64/Demos/Hello/project1.ico new file mode 100644 index 0000000..0341321 Binary files /dev/null and b/Sources/lazarus64/Demos/Hello/project1.ico differ diff --git a/Sources/lazarus64/Demos/Hello/project1.lpi b/Sources/lazarus64/Demos/Hello/project1.lpi new file mode 100644 index 0000000..7c170e3 --- /dev/null +++ b/Sources/lazarus64/Demos/Hello/project1.lpi @@ -0,0 +1,94 @@ +<?xml version="1.0"?> +<CONFIG> + <ProjectOptions> + <Version Value="9"/> + <PathDelim Value="\"/> + <General> + <SessionStorage Value="InProjectDir"/> + <MainUnit Value="0"/> + <Title Value="project1"/> + <ResourceType Value="res"/> + <UseXPManifest Value="True"/> + <Icon Value="0"/> + </General> + <i18n> + <EnableI18N LFM="False"/> + </i18n> + <VersionInfo> + <StringTable ProductVersion=""/> + </VersionInfo> + <BuildModes Count="1"> + <Item1 Name="Default" Default="True"/> + </BuildModes> + <PublishOptions> + <Version Value="2"/> + <IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/> + <ExcludeFileFilter Value="*.(bak|ppu|o|so);*~;backup"/> + </PublishOptions> + <RunParams> + <local> + <FormatVersion Value="1"/> + </local> + </RunParams> + <RequiredPackages Count="2"> + <Item1> + <PackageName Value="paxcomp_lazarus64"/> + </Item1> + <Item2> + <PackageName Value="LCL"/> + </Item2> + </RequiredPackages> + <Units Count="2"> + <Unit0> + <Filename Value="project1.lpr"/> + <IsPartOfProject Value="True"/> + <UnitName Value="project1"/> + </Unit0> + <Unit1> + <Filename Value="unit1.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="Form1"/> + <ResourceBaseClass Value="Form"/> + <UnitName Value="Unit1"/> + </Unit1> + </Units> + </ProjectOptions> + <CompilerOptions> + <Version Value="11"/> + <PathDelim Value="\"/> + <Target> + <Filename Value="project1"/> + </Target> + <SearchPaths> + <IncludeFiles Value="$(ProjOutDir)"/> + <OtherUnitFiles Value="..\..\IMPORT"/> + <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/> + </SearchPaths> + <Linking> + <Options> + <Win32> + <GraphicApplication Value="True"/> + </Win32> + </Options> + </Linking> + <Other> + <CompilerMessages> + <MsgFileName Value=""/> + </CompilerMessages> + <CompilerPath Value="$(CompPath)"/> + </Other> + </CompilerOptions> + <Debugging> + <Exceptions Count="3"> + <Item1> + <Name Value="EAbort"/> + </Item1> + <Item2> + <Name Value="ECodetoolError"/> + </Item2> + <Item3> + <Name Value="EFOpenError"/> + </Item3> + </Exceptions> + </Debugging> +</CONFIG> diff --git a/Sources/lazarus64/Demos/Hello/project1.lpr b/Sources/lazarus64/Demos/Hello/project1.lpr new file mode 100644 index 0000000..ced6d82 --- /dev/null +++ b/Sources/lazarus64/Demos/Hello/project1.lpr @@ -0,0 +1,21 @@ +program project1; + +{$mode objfpc}{$H+} + +uses + {$IFDEF UNIX}{$IFDEF UseCThreads} + cthreads, + {$ENDIF}{$ENDIF} + Interfaces, // this includes the LCL widgetset + Forms, Unit1 + { you can add units after this }; + +{$R *.res} + +begin + RequireDerivedFormResource := True; + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. + diff --git a/Sources/lazarus64/Demos/Hello/project1.lps b/Sources/lazarus64/Demos/Hello/project1.lps new file mode 100644 index 0000000..2e0ff53 --- /dev/null +++ b/Sources/lazarus64/Demos/Hello/project1.lps @@ -0,0 +1,58 @@ +<?xml version="1.0"?> +<CONFIG> + <ProjectSession> + <PathDelim Value="\"/> + <Version Value="9"/> + <BuildModes Active="Default"/> + <Units Count="3"> + <Unit0> + <Filename Value="project1.lpr"/> + <IsPartOfProject Value="True"/> + <UnitName Value="project1"/> + <UsageCount Value="20"/> + </Unit0> + <Unit1> + <Filename Value="unit1.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="Form1"/> + <ResourceBaseClass Value="Form"/> + <UnitName Value="Unit1"/> + <IsVisibleTab Value="True"/> + <EditorIndex Value="0"/> + <WindowIndex Value="0"/> + <TopLine Value="32"/> + <CursorPos X="68" Y="48"/> + <UsageCount Value="20"/> + <Loaded Value="True"/> + <LoadedDesigner Value="True"/> + </Unit1> + <Unit2> + <Filename Value="..\..\IMPORT\IMPORT_COMMON.pas"/> + <UnitName Value="IMPORT_COMMON"/> + <EditorIndex Value="1"/> + <WindowIndex Value="0"/> + <TopLine Value="1"/> + <CursorPos X="70" Y="6"/> + <UsageCount Value="10"/> + <Loaded Value="True"/> + </Unit2> + </Units> + <General> + <ActiveWindowIndexAtStart Value="0"/> + </General> + <JumpHistory Count="3" HistoryIndex="2"> + <Position1> + <Filename Value="unit1.pas"/> + <Caret Line="14" Column="42" TopLine="1"/> + </Position1> + <Position2> + <Filename Value="..\..\IMPORT\IMPORT_COMMON.pas"/> + <Caret Line="1" Column="1" TopLine="1"/> + </Position2> + <Position3> + <Filename Value="unit1.pas"/> + <Caret Line="4" Column="59" TopLine="1"/> + </Position3> + </JumpHistory> + </ProjectSession> +</CONFIG> diff --git a/Sources/lazarus64/Demos/Hello/project1.res b/Sources/lazarus64/Demos/Hello/project1.res new file mode 100644 index 0000000..7c6cf3e Binary files /dev/null and b/Sources/lazarus64/Demos/Hello/project1.res differ diff --git a/Sources/lazarus64/Demos/Hello/unit1.lfm b/Sources/lazarus64/Demos/Hello/unit1.lfm new file mode 100644 index 0000000..4f379fa --- /dev/null +++ b/Sources/lazarus64/Demos/Hello/unit1.lfm @@ -0,0 +1,39 @@ +object Form1: TForm1 + Left = 239 + Height = 240 + Top = 167 + Width = 320 + Caption = 'Hello' + ClientHeight = 240 + ClientWidth = 320 + LCLVersion = '1.0.12.0' + object Button1: TButton + Left = 65 + Height = 25 + Top = 83 + Width = 75 + Caption = 'Say Hello' + OnClick = Button1Click + TabOrder = 0 + end + object PaxCompiler1: TPaxCompiler + Alignment = 8 + DebugMode = False + left = 40 + top = 24 + end + object PaxPascalLanguage1: TPaxPascalLanguage + ExplicitOff = False + CompleteBooleanEval = False + UnitLookup = True + PrintKeyword = 'print' + PrintlnKeyword = 'println' + left = 120 + top = 28 + end + object PaxInterpreter1: TPaxInterpreter + Console = False + left = 143 + top = 170 + end +end diff --git a/Sources/lazarus64/Demos/Hello/unit1.pas b/Sources/lazarus64/Demos/Hello/unit1.pas new file mode 100644 index 0000000..7d815aa --- /dev/null +++ b/Sources/lazarus64/Demos/Hello/unit1.pas @@ -0,0 +1,59 @@ +unit Unit1; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls, + PaxCompiler, PaxInterpreter, PaxRegister, IMPORT_Common; + +type + + { TForm1 } + + TForm1 = class(TForm) + Button1: TButton; + PaxCompiler1: TPaxCompiler; + PaxInterpreter1: TPaxInterpreter; + PaxPascalLanguage1: TPaxPascalLanguage; + procedure Button1Click(Sender: TObject); + private + { private declarations } + public + { public declarations } + end; + +var + Form1: TForm1; + +implementation + +{$R *.lfm} + +{ TForm1 } + +procedure TForm1.Button1Click(Sender: TObject); +var + I: Integer; +begin + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + + PaxCompiler1.RegisterVariable(0, 'Button1: TButton', @Button1); + + PaxCompiler1.AddModule('1', PaxPascalLanguage1.LanguageName); + PaxCompiler1.AddCode('1', 'begin'); + PaxCompiler1.AddCode('1', ' Button1.Caption := ''Hello'';'); + PaxCompiler1.AddCode('1', ' Button1.Width := Button1.Width + 100;'); + PaxCompiler1.AddCode('1', 'end.'); + + if PaxCompiler1.Compile(PaxInterpreter1) then + PaxInterpreter1.Run + else + for I:=0 to PaxCompiler1.ErrorCount - 1 do + ShowMessage(PaxCompiler1.ErrorMessage[I]); +end; + +end. + diff --git a/Sources/lazarus64/Demos/ImportAbstractClass/project1.ico b/Sources/lazarus64/Demos/ImportAbstractClass/project1.ico new file mode 100644 index 0000000..0341321 Binary files /dev/null and b/Sources/lazarus64/Demos/ImportAbstractClass/project1.ico differ diff --git a/Sources/lazarus64/Demos/ImportAbstractClass/project1.lpi b/Sources/lazarus64/Demos/ImportAbstractClass/project1.lpi new file mode 100644 index 0000000..0409699 --- /dev/null +++ b/Sources/lazarus64/Demos/ImportAbstractClass/project1.lpi @@ -0,0 +1,93 @@ +<?xml version="1.0"?> +<CONFIG> + <ProjectOptions> + <Version Value="9"/> + <PathDelim Value="\"/> + <General> + <SessionStorage Value="InProjectDir"/> + <MainUnit Value="0"/> + <Title Value="project1"/> + <ResourceType Value="res"/> + <UseXPManifest Value="True"/> + <Icon Value="0"/> + </General> + <i18n> + <EnableI18N LFM="False"/> + </i18n> + <VersionInfo> + <StringTable ProductVersion=""/> + </VersionInfo> + <BuildModes Count="1"> + <Item1 Name="Default" Default="True"/> + </BuildModes> + <PublishOptions> + <Version Value="2"/> + <IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/> + <ExcludeFileFilter Value="*.(bak|ppu|o|so);*~;backup"/> + </PublishOptions> + <RunParams> + <local> + <FormatVersion Value="1"/> + </local> + </RunParams> + <RequiredPackages Count="2"> + <Item1> + <PackageName Value="paxcomp_lazarus64"/> + </Item1> + <Item2> + <PackageName Value="LCL"/> + </Item2> + </RequiredPackages> + <Units Count="2"> + <Unit0> + <Filename Value="project1.lpr"/> + <IsPartOfProject Value="True"/> + <UnitName Value="project1"/> + </Unit0> + <Unit1> + <Filename Value="unit1.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="Form1"/> + <ResourceBaseClass Value="Form"/> + <UnitName Value="Unit1"/> + </Unit1> + </Units> + </ProjectOptions> + <CompilerOptions> + <Version Value="11"/> + <PathDelim Value="\"/> + <Target> + <Filename Value="project1"/> + </Target> + <SearchPaths> + <IncludeFiles Value="$(ProjOutDir)"/> + <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/> + </SearchPaths> + <Linking> + <Options> + <Win32> + <GraphicApplication Value="True"/> + </Win32> + </Options> + </Linking> + <Other> + <CompilerMessages> + <MsgFileName Value=""/> + </CompilerMessages> + <CompilerPath Value="$(CompPath)"/> + </Other> + </CompilerOptions> + <Debugging> + <Exceptions Count="3"> + <Item1> + <Name Value="EAbort"/> + </Item1> + <Item2> + <Name Value="ECodetoolError"/> + </Item2> + <Item3> + <Name Value="EFOpenError"/> + </Item3> + </Exceptions> + </Debugging> +</CONFIG> diff --git a/Sources/lazarus64/Demos/ImportAbstractClass/project1.lpr b/Sources/lazarus64/Demos/ImportAbstractClass/project1.lpr new file mode 100644 index 0000000..ced6d82 --- /dev/null +++ b/Sources/lazarus64/Demos/ImportAbstractClass/project1.lpr @@ -0,0 +1,21 @@ +program project1; + +{$mode objfpc}{$H+} + +uses + {$IFDEF UNIX}{$IFDEF UseCThreads} + cthreads, + {$ENDIF}{$ENDIF} + Interfaces, // this includes the LCL widgetset + Forms, Unit1 + { you can add units after this }; + +{$R *.res} + +begin + RequireDerivedFormResource := True; + Application.Initialize; + Application.CreateForm(TForm1, Form1); + Application.Run; +end. + diff --git a/Sources/lazarus64/Demos/ImportAbstractClass/project1.lps b/Sources/lazarus64/Demos/ImportAbstractClass/project1.lps new file mode 100644 index 0000000..b2fb8c0 --- /dev/null +++ b/Sources/lazarus64/Demos/ImportAbstractClass/project1.lps @@ -0,0 +1,61 @@ +<?xml version="1.0"?> +<CONFIG> + <ProjectSession> + <PathDelim Value="\"/> + <Version Value="9"/> + <BuildModes Active="Default"/> + <Units Count="6"> + <Unit0> + <Filename Value="project1.lpr"/> + <IsPartOfProject Value="True"/> + <UnitName Value="project1"/> + <UsageCount Value="20"/> + </Unit0> + <Unit1> + <Filename Value="unit1.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="Form1"/> + <ResourceBaseClass Value="Form"/> + <UnitName Value="Unit1"/> + <IsVisibleTab Value="True"/> + <WindowIndex Value="0"/> + <TopLine Value="62"/> + <CursorPos X="63" Y="68"/> + <UsageCount Value="20"/> + </Unit1> + <Unit2> + <Filename Value="..\..\paxcomp_lazarus64\PAXCOMP_BASESYMBOL_TABLE.pas"/> + <UnitName Value="PAXCOMP_BASESYMBOL_TABLE"/> + <WindowIndex Value="0"/> + <TopLine Value="3590"/> + <CursorPos X="1" Y="3598"/> + <UsageCount Value="10"/> + </Unit2> + <Unit3> + <Filename Value="..\..\paxcomp_lazarus64\PAXINT_CRT.pas"/> + <UnitName Value="PAXINT_CRT"/> + <WindowIndex Value="0"/> + <TopLine Value="234"/> + <CursorPos X="1" Y="242"/> + <UsageCount Value="10"/> + </Unit3> + <Unit4> + <Filename Value="..\..\paxcomp_lazarus64\PaxRegister.pas"/> + <UnitName Value="PaxRegister"/> + <WindowIndex Value="0"/> + <TopLine Value="497"/> + <CursorPos X="1" Y="506"/> + <UsageCount Value="10"/> + </Unit4> + <Unit5> + <Filename Value="..\..\paxcomp_lazarus64\PAXCOMP_SYS.pas"/> + <UnitName Value="PAXCOMP_SYS"/> + <WindowIndex Value="0"/> + <TopLine Value="2091"/> + <CursorPos X="52" Y="2103"/> + <UsageCount Value="10"/> + </Unit5> + </Units> + <JumpHistory Count="0" HistoryIndex="-1"/> + </ProjectSession> +</CONFIG> diff --git a/Sources/lazarus64/Demos/ImportAbstractClass/project1.res b/Sources/lazarus64/Demos/ImportAbstractClass/project1.res new file mode 100644 index 0000000..7c6cf3e Binary files /dev/null and b/Sources/lazarus64/Demos/ImportAbstractClass/project1.res differ diff --git a/Sources/lazarus64/Demos/ImportAbstractClass/unit1.lfm b/Sources/lazarus64/Demos/ImportAbstractClass/unit1.lfm new file mode 100644 index 0000000..9a571d5 --- /dev/null +++ b/Sources/lazarus64/Demos/ImportAbstractClass/unit1.lfm @@ -0,0 +1,68 @@ +object Form1: TForm1 + Left = 280 + Height = 511 + Top = 118 + Width = 782 + Caption = 'Import abstract class' + ClientHeight = 511 + ClientWidth = 782 + LCLVersion = '1.0.12.0' + object Button1: TButton + Left = 664 + Height = 25 + Top = 264 + Width = 75 + Caption = 'Run script' + OnClick = Button1Click + TabOrder = 0 + end + object Memo1: TMemo + Left = 21 + Height = 450 + Top = 16 + Width = 550 + Lines.Strings = ( + 'type' + ' TMyScriptClass = class(TMyHostClass)' + ' procedure P; override;' + ' end;' + '' + 'procedure TMyScriptClass.P;' + 'begin' + ' print(''Hello from script!'');' + 'end;' + '' + 'var' + ' X: TMyScriptClass;' + 'begin' + ' X := TMyScriptClass.Create;' + ' try' + ' PassToHost(X);' + ' finally' + ' X.Free;' + ' end;' + 'end.' + ) + TabOrder = 1 + end + object PaxCompiler1: TPaxCompiler + Alignment = 8 + DebugMode = False + left = 628 + top = 25 + end + object PaxPascalLanguage1: TPaxPascalLanguage + ExplicitOff = False + CompleteBooleanEval = False + UnitLookup = True + PrintKeyword = 'print' + PrintlnKeyword = 'println' + left = 634 + top = 105 + end + object PaxInterpreter1: TPaxInterpreter + Console = False + left = 612 + top = 178 + end +end diff --git a/Sources/lazarus64/Demos/ImportAbstractClass/unit1.pas b/Sources/lazarus64/Demos/ImportAbstractClass/unit1.pas new file mode 100644 index 0000000..f423199 --- /dev/null +++ b/Sources/lazarus64/Demos/ImportAbstractClass/unit1.pas @@ -0,0 +1,80 @@ +unit Unit1; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls, + PaxCompiler, PaxInterpreter, PaxRegister; + +type + + { TForm1 } + + TForm1 = class(TForm) + Button1: TButton; + Memo1: TMemo; + PaxCompiler1: TPaxCompiler; + PaxInterpreter1: TPaxInterpreter; + PaxPascalLanguage1: TPaxPascalLanguage; + procedure Button1Click(Sender: TObject); + private + { private declarations } + public + { public declarations } + end; + +type + TMyHostClass = class + public + procedure P; virtual; abstract; + end; + +var + Form1: TForm1; + +implementation + +{$R *.lfm} + +{ TForm1 } + +procedure PassToHost(X: TMyHostClass); +begin + ShowMessage('At host side: ' + X.ClassName); + X.P; +end; + +procedure TForm1.Button1Click(Sender: TObject); +begin + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + PaxCompiler1.AddModule('1', 'Pascal'); + PaxCompiler1.AddCode('1', Memo1.Lines.Text); + if PaxCompiler1.Compile(PaxInterpreter1) then + begin + PaxInterpreter1.Run; + end + else + begin + ShowMessage(PaxCompiler1.ErrorMessage[0]); + end; +end; + +var + I: Integer; + +initialization + +I := RegisterClassType(0, TMyHostClass); +RegisterHeader(I, + 'procedure P; virtual; abstract;', + nil); + +RegisterHeader(0, + 'procedure PassToHost(X: TMyHostClass);', + @ PassToHost); + +end. + diff --git a/Sources/lazarus64/PaxCompiler.def b/Sources/lazarus64/PaxCompiler.def new file mode 100644 index 0000000..ac79814 --- /dev/null +++ b/Sources/lazarus64/PaxCompiler.def @@ -0,0 +1,93 @@ +// {$define TRIAL} +{$O-} + +// {$define NO_PARENT_CLASS} + +{$define FPC} +{$ifdef FPC} + {$DEFINE PAX64} + {$ASMMODE intel} + {$DEFINE VARIANTS} + {$MODE DELPHI} + {$DEFINE CPUASM} + {$H+} + {$M+} +{$endif} + +{$define PCU_EX} +{$define GENERICS} +//{$define HTML} + +{$define DUMP} +{$ifdef Ver140} + {$define VARIANTS} +{$endif} +{$ifdef Ver150} + {$define VARIANTS} +{$endif} +{$ifdef Ver160} + {$define VARIANTS} +{$endif} +{$ifdef Ver170} + {$define VARIANTS} +{$endif} +{$ifdef Ver180} + {$define VARIANTS} +{$endif} +{$ifdef Ver190} + {$define VARIANTS} +{$endif} +{$ifdef Ver200} + {$define VARIANTS} + {$define UNIC} +{$endif} +{$ifdef Ver210} + {$define VARIANTS} + {$define UNIC} + {$define DRTTI} +{$endif} +{$ifdef Ver220} + {$define VARIANTS} + {$define UNIC} + {$define DRTTI} +{$endif} +{$ifdef Ver230} + {$define VARIANTS} + {$define UNIC} + {$define DRTTI} + {$define DPULSAR} + {$IFDEF CPUX64} + {$DEFINE PAX64} + {$ENDIF} +{$endif} +{$ifdef Ver240} + {$define VARIANTS} + {$define UNIC} + {$define DRTTI} + {$define DPULSAR} + {$define DXE3} + {$IFDEF CPUX64} + {$DEFINE PAX64} + {$ENDIF} +{$endif} +{$ifdef Ver250} + {$define VARIANTS} + {$define UNIC} + {$define DRTTI} + {$define DPULSAR} + {$define DXE3} + {$IFDEF CPUX64} + {$DEFINE PAX64} + {$ENDIF} +{$endif} +{$ifdef Ver260} + {$define VARIANTS} + {$define UNIC} + {$define DRTTI} + {$define DPULSAR} + {$define DXE3} + {$IFDEF CPUX64} + {$DEFINE PAX64} + {$ENDIF} +{$endif} + diff --git a/Sources/lazarus64/paxcomp_lazarus64.lpk b/Sources/lazarus64/paxcomp_lazarus64.lpk new file mode 100644 index 0000000..f57d888 --- /dev/null +++ b/Sources/lazarus64/paxcomp_lazarus64.lpk @@ -0,0 +1,342 @@ +<?xml version="1.0"?> +<CONFIG> + <Package Version="4"> + <PathDelim Value="\"/> + <Name Value="paxcomp_lazarus64"/> + <CompilerOptions> + <Version Value="11"/> + <PathDelim Value="\"/> + <SearchPaths> + <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)\"/> + </SearchPaths> + <Other> + <CompilerMessages> + <MsgFileName Value=""/> + </CompilerMessages> + <CompilerPath Value="$(CompPath)"/> + </Other> + </CompilerOptions> + <Files Count="76"> + <Item1> + <Filename Value="PaxBasicLanguage.pas"/> + <UnitName Value="PaxBasicLanguage"/> + </Item1> + <Item2> + <Filename Value="PaxCompiler.pas"/> + <UnitName Value="PaxCompiler"/> + </Item2> + <Item3> + <Filename Value="PaxCompilerDebugger.pas"/> + <UnitName Value="PaxCompilerDebugger"/> + </Item3> + <Item4> + <Filename Value="PaxCompilerExplorer.pas"/> + <UnitName Value="PaxCompilerExplorer"/> + </Item4> + <Item5> + <Filename Value="PaxCompilerRegister.pas"/> + <HasRegisterProc Value="True"/> + <UnitName Value="PaxCompilerRegister"/> + </Item5> + <Item6> + <Filename Value="PAXCOMP_2010.pas"/> + <UnitName Value="PAXCOMP_2010"/> + </Item6> + <Item7> + <Filename Value="PAXCOMP_2010Reg.pas"/> + <UnitName Value="PAXCOMP_2010REG"/> + </Item7> + <Item8> + <Filename Value="PAXCOMP_BASERUNNER.pas"/> + <UnitName Value="PAXCOMP_BASERUNNER"/> + </Item8> + <Item9> + <Filename Value="PAXCOMP_BASESYMBOL_TABLE.pas"/> + <UnitName Value="PAXCOMP_BASESYMBOL_TABLE"/> + </Item9> + <Item10> + <Filename Value="PAXCOMP_Basic.pas"/> + <UnitName Value="PAXCOMP_Basic"/> + </Item10> + <Item11> + <Filename Value="PAXCOMP_BASIC_PARSER.pas"/> + <UnitName Value="PAXCOMP_BASIC_PARSER"/> + </Item11> + <Item12> + <Filename Value="PAXCOMP_BASIC_SCANNER.pas"/> + <UnitName Value="PAXCOMP_BASIC_SCANNER"/> + </Item12> + <Item13> + <Filename Value="PAXCOMP_BYTECODE.pas"/> + <UnitName Value="PAXCOMP_BYTECODE"/> + </Item13> + <Item14> + <Filename Value="PAXCOMP_CLASSFACT.pas"/> + <UnitName Value="PAXCOMP_CLASSFACT"/> + </Item14> + <Item15> + <Filename Value="PAXCOMP_CLASSLST.pas"/> + <UnitName Value="PAXCOMP_CLASSLST"/> + </Item15> + <Item16> + <Filename Value="PAXCOMP_CONSTANTS.pas"/> + <UnitName Value="PAXCOMP_CONSTANTS"/> + </Item16> + <Item17> + <Filename Value="PAXCOMP_DISASM.pas"/> + <UnitName Value="PAXCOMP_DISASM"/> + </Item17> + <Item18> + <Filename Value="PAXCOMP_EMIT.pas"/> + <UnitName Value="PAXCOMP_EMIT"/> + </Item18> + <Item19> + <Filename Value="PAXCOMP_ERROR.pas"/> + <UnitName Value="PAXCOMP_ERROR"/> + </Item19> + <Item20> + <Filename Value="PAXCOMP_EVAL.pas"/> + <UnitName Value="PAXCOMP_EVAL"/> + </Item20> + <Item21> + <Filename Value="PAXCOMP_EVENT.pas"/> + <UnitName Value="PAXCOMP_EVENT"/> + </Item21> + <Item22> + <Filename Value="PAXCOMP_EXTRASYMBOL_TABLE.pas"/> + <UnitName Value="PAXCOMP_EXTRASYMBOL_TABLE"/> + </Item22> + <Item23> + <Filename Value="PAXCOMP_FORBID.pas"/> + <UnitName Value="PAXCOMP_FORBID"/> + </Item23> + <Item24> + <Filename Value="PAXCOMP_FRAMEWORK.pas"/> + <UnitName Value="PAXCOMP_FRAMEWORK"/> + </Item24> + <Item25> + <Filename Value="PAXCOMP_GC.pas"/> + <UnitName Value="PAXCOMP_GC"/> + </Item25> + <Item26> + <Filename Value="PAXCOMP_GENERIC.pas"/> + <UnitName Value="PAXCOMP_GENERIC"/> + </Item26> + <Item27> + <Filename Value="PAXCOMP_HEADER_PARSER.pas"/> + <UnitName Value="PAXCOMP_HEADER_PARSER"/> + </Item27> + <Item28> + <Filename Value="PAXCOMP_HOSTCLS.pas"/> + <UnitName Value="PAXCOMP_HOSTCLS"/> + </Item28> + <Item29> + <Filename Value="PAXCOMP_INVOKE.pas"/> + <UnitName Value="PAXCOMP_INVOKE"/> + </Item29> + <Item30> + <Filename Value="PAXCOMP_JavaScript.pas"/> + <UnitName Value="PAXCOMP_JavaScript"/> + </Item30> + <Item31> + <Filename Value="PAXCOMP_JS_CONV.pas"/> + <UnitName Value="PAXCOMP_JS_CONV"/> + </Item31> + <Item32> + <Filename Value="PAXCOMP_JS_PARSER.pas"/> + <UnitName Value="PAXCOMP_JS_PARSER"/> + </Item32> + <Item33> + <Filename Value="PAXCOMP_JS_SCANNER.pas"/> + <UnitName Value="PAXCOMP_JS_SCANNER"/> + </Item33> + <Item34> + <Filename Value="PAXCOMP_KERNEL.pas"/> + <UnitName Value="PAXCOMP_KERNEL"/> + </Item34> + <Item35> + <Filename Value="PAXCOMP_LABEL_STACK.pas"/> + <UnitName Value="PAXCOMP_LABEL_STACK"/> + </Item35> + <Item36> + <Filename Value="PAXCOMP_LOCALSYMBOL_TABLE.pas"/> + <UnitName Value="PAXCOMP_LOCALSYMBOL_TABLE"/> + </Item36> + <Item37> + <Filename Value="PAXCOMP_MAP.pas"/> + <UnitName Value="PAXCOMP_MAP"/> + </Item37> + <Item38> + <Filename Value="PAXCOMP_MODULE.pas"/> + <UnitName Value="PAXCOMP_MODULE"/> + </Item38> + <Item39> + <Filename Value="PAXCOMP_OFFSET.pas"/> + <UnitName Value="PAXCOMP_OFFSET"/> + </Item39> + <Item40> + <Filename Value="PAXCOMP_OLE.pas"/> + <UnitName Value="PAXCOMP_OLE"/> + </Item40> + <Item41> + <Filename Value="PAXCOMP_PARSER.pas"/> + <UnitName Value="PAXCOMP_PARSER"/> + </Item41> + <Item42> + <Filename Value="PAXCOMP_PASCAL_PARSER.pas"/> + <UnitName Value="PAXCOMP_PASCAL_PARSER"/> + </Item42> + <Item43> + <Filename Value="PAXCOMP_PASCAL_SCANNER.pas"/> + <UnitName Value="PAXCOMP_PASCAL_SCANNER"/> + </Item43> + <Item44> + <Filename Value="PAXCOMP_PAUSE.pas"/> + <UnitName Value="PAXCOMP_PAUSE"/> + </Item44> + <Item45> + <Filename Value="PAXCOMP_PCU.pas"/> + <UnitName Value="PAXCOMP_PCU"/> + </Item45> + <Item46> + <Filename Value="PAXCOMP_PE.pas"/> + <UnitName Value="PAXCOMP_PE"/> + </Item46> + <Item47> + <Filename Value="PAXCOMP_PROG.pas"/> + <UnitName Value="PAXCOMP_PROG"/> + </Item47> + <Item48> + <Filename Value="PAXCOMP_PROGLIB.pas"/> + <UnitName Value="PAXCOMP_PROGLIB"/> + </Item48> + <Item49> + <Filename Value="PAXCOMP_PROGLIST.pas"/> + <UnitName Value="PAXCOMP_PROGLIST"/> + </Item49> + <Item50> + <Filename Value="PAXCOMP_RTI.pas"/> + <UnitName Value="PAXCOMP_RTI"/> + </Item50> + <Item51> + <Filename Value="PAXCOMP_SCANNER.pas"/> + <UnitName Value="PAXCOMP_SCANNER"/> + </Item51> + <Item52> + <Filename Value="PAXCOMP_SEH.pas"/> + <UnitName Value="PAXCOMP_SEH"/> + </Item52> + <Item53> + <Filename Value="PAXCOMP_STDLIB.pas"/> + <UnitName Value="PAXCOMP_STDLIB"/> + </Item53> + <Item54> + <Filename Value="PAXCOMP_SYMBOL_PROGRAM.pas"/> + <UnitName Value="PAXCOMP_SYMBOL_PROGRAM"/> + </Item54> + <Item55> + <Filename Value="PAXCOMP_SYMBOL_REC.pas"/> + <UnitName Value="PAXCOMP_SYMBOL_REC"/> + </Item55> + <Item56> + <Filename Value="PAXCOMP_SYMBOL_TABLE.pas"/> + <UnitName Value="PAXCOMP_SYMBOL_TABLE"/> + </Item56> + <Item57> + <Filename Value="PAXCOMP_SYS.pas"/> + <UnitName Value="PAXCOMP_SYS"/> + </Item57> + <Item58> + <Filename Value="PAXCOMP_TRYLST.pas"/> + <UnitName Value="PAXCOMP_TRYLST"/> + </Item58> + <Item59> + <Filename Value="PAXCOMP_TYPEINFO.pas"/> + <UnitName Value="PAXCOMP_TYPEINFO"/> + </Item59> + <Item60> + <Filename Value="PAXCOMP_VAROBJECT.pas"/> + <UnitName Value="PAXCOMP_VAROBJECT"/> + </Item60> + <Item61> + <Filename Value="PaxDllImport.pas"/> + <UnitName Value="PaxDllImport"/> + </Item61> + <Item62> + <Filename Value="PaxEval.pas"/> + <UnitName Value="PaxEval"/> + </Item62> + <Item63> + <Filename Value="PaxInfos.pas"/> + <UnitName Value="PaxInfos"/> + </Item63> + <Item64> + <Filename Value="PaxInterpreter.pas"/> + <UnitName Value="PaxInterpreter"/> + </Item64> + <Item65> + <Filename Value="PAXINT_CALL.pas"/> + <UnitName Value="PAXINT_CALL"/> + </Item65> + <Item66> + <Filename Value="PAXINT_CRT.pas"/> + <UnitName Value="PAXINT_CRT"/> + </Item66> + <Item67> + <Filename Value="PAXINT_RUNNER.pas"/> + <UnitName Value="PAXINT_RUNNER"/> + </Item67> + <Item68> + <Filename Value="PAXINT_SEH.pas"/> + <UnitName Value="PAXINT_SEH"/> + </Item68> + <Item69> + <Filename Value="PAXINT_SYS.pas"/> + <UnitName Value="PAXINT_SYS"/> + </Item69> + <Item70> + <Filename Value="PaxInvoke.pas"/> + <UnitName Value="PaxInvoke"/> + </Item70> + <Item71> + <Filename Value="PaxJavaScriptLanguage.pas"/> + <UnitName Value="PaxJavaScriptLanguage"/> + </Item71> + <Item72> + <Filename Value="PaxPE.pas"/> + <UnitName Value="PaxPE"/> + </Item72> + <Item73> + <Filename Value="PaxProgram.pas"/> + <UnitName Value="PaxProgram"/> + </Item73> + <Item74> + <Filename Value="PaxRegister.pas"/> + <UnitName Value="PaxRegister"/> + </Item74> + <Item75> + <Filename Value="PaxRunner.pas"/> + <UnitName Value="PaxRunner"/> + </Item75> + <Item76> + <Filename Value="RegExpr2.pas"/> + <UnitName Value="RegExpr2"/> + </Item76> + </Files> + <Type Value="RunAndDesignTime"/> + <RequiredPkgs Count="2"> + <Item1> + <PackageName Value="LCLBase"/> + </Item1> + <Item2> + <PackageName Value="FCL"/> + </Item2> + </RequiredPkgs> + <UsageOptions> + <UnitPath Value="$(PkgOutDir)"/> + </UsageOptions> + <PublishOptions> + <Version Value="2"/> + </PublishOptions> + </Package> +</CONFIG> diff --git a/Sources/lazarus64/paxcomp_lazarus64.pas b/Sources/lazarus64/paxcomp_lazarus64.pas new file mode 100644 index 0000000..b0e4239 --- /dev/null +++ b/Sources/lazarus64/paxcomp_lazarus64.pas @@ -0,0 +1,39 @@ +{ This file was automatically created by Lazarus. Do not edit! + This source is only used to compile and install the package. + } + +unit paxcomp_lazarus64; + +interface + +uses + PaxBasicLanguage, PaxCompiler, PaxCompilerDebugger, PaxCompilerExplorer, + PaxCompilerRegister, PAXCOMP_2010, PAXCOMP_2010Reg, PAXCOMP_BASERUNNER, + PAXCOMP_BASESYMBOL_TABLE, PAXCOMP_Basic, PAXCOMP_BASIC_PARSER, + PAXCOMP_BASIC_SCANNER, PAXCOMP_BYTECODE, PAXCOMP_CLASSFACT, + PAXCOMP_CLASSLST, PAXCOMP_CONSTANTS, PAXCOMP_DISASM, PAXCOMP_EMIT, + PAXCOMP_ERROR, PAXCOMP_EVAL, PAXCOMP_EVENT, PAXCOMP_EXTRASYMBOL_TABLE, + PAXCOMP_FORBID, PAXCOMP_FRAMEWORK, PAXCOMP_GC, PAXCOMP_GENERIC, + PAXCOMP_HEADER_PARSER, PAXCOMP_HOSTCLS, PAXCOMP_INVOKE, PAXCOMP_JavaScript, + PAXCOMP_JS_CONV, PAXCOMP_JS_PARSER, PAXCOMP_JS_SCANNER, PAXCOMP_KERNEL, + PAXCOMP_LABEL_STACK, PAXCOMP_LOCALSYMBOL_TABLE, PAXCOMP_MAP, PAXCOMP_MODULE, + PAXCOMP_OFFSET, PAXCOMP_OLE, PAXCOMP_PARSER, PAXCOMP_PASCAL_PARSER, + PAXCOMP_PASCAL_SCANNER, PAXCOMP_PAUSE, PAXCOMP_PCU, PAXCOMP_PE, + PAXCOMP_PROG, PAXCOMP_PROGLIB, PAXCOMP_PROGLIST, PAXCOMP_RTI, + PAXCOMP_SCANNER, PAXCOMP_SEH, PAXCOMP_STDLIB, PAXCOMP_SYMBOL_PROGRAM, + PAXCOMP_SYMBOL_REC, PAXCOMP_SYMBOL_TABLE, PAXCOMP_SYS, PAXCOMP_TRYLST, + PAXCOMP_TYPEINFO, PAXCOMP_VAROBJECT, PaxDllImport, PaxEval, PaxInfos, + PaxInterpreter, PAXINT_CALL, PAXINT_CRT, PAXINT_RUNNER, PAXINT_SEH, + PAXINT_SYS, PaxInvoke, PaxJavaScriptLanguage, PaxPE, PaxProgram, + PaxRegister, PaxRunner, RegExpr2, LazarusPackageIntf; + +implementation + +procedure Register; +begin + RegisterUnit('PaxCompilerRegister', @PaxCompilerRegister.Register); +end; + +initialization + RegisterPackage('paxcomp_lazarus64', @Register); +end. diff --git a/Sources/paxcomp_D10.dpk b/Sources/paxcomp_D10.dpk new file mode 100644 index 0000000..d1fa3ac --- /dev/null +++ b/Sources/paxcomp_D10.dpk @@ -0,0 +1,40 @@ +package paxcomp_D10; + +{$R *.res} +{$R *.otares} +{$R 'PaxCompiler.dcr'} +{$IFDEF IMPLICITBUILDING This IFDEF should not be used by users} +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO OFF} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION OFF} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES ON} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$DEFINE DEBUG} +{$ENDIF IMPLICITBUILDING} +{$IMPLICITBUILD ON} + +requires + rtl, + vcl, + soaprtl; + +contains + PaxCompilerRegister in 'PaxCompilerRegister.pas'; + +end. diff --git a/Sources/paxcomp_D10.dproj b/Sources/paxcomp_D10.dproj new file mode 100644 index 0000000..e1a8890 --- /dev/null +++ b/Sources/paxcomp_D10.dproj @@ -0,0 +1,535 @@ +<Project xmlns="http://schemas.microsoft.com/developer/msbuild/2003"> + <PropertyGroup> + <ProjectGuid>{D3E41B87-1FB2-4838-9992-AEE184233C8B}</ProjectGuid> + <MainSource>paxcomp_D10.dpk</MainSource> + <Base>True</Base> + <Config Condition="'$(Config)'==''">Debug</Config> + <TargetedPlatforms>1</TargetedPlatforms> + <AppType>Package</AppType> + <FrameworkType>VCL</FrameworkType> + <ProjectVersion>18.1</ProjectVersion> + <Platform Condition="'$(Platform)'==''">Win32</Platform> + </PropertyGroup> + <PropertyGroup Condition="'$(Config)'=='Base' or '$(Base)'!=''"> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="('$(Platform)'=='Android' and '$(Base)'=='true') or '$(Base_Android)'!=''"> + <Base_Android>true</Base_Android> + <CfgParent>Base</CfgParent> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="('$(Platform)'=='iOSDevice32' and '$(Base)'=='true') or '$(Base_iOSDevice32)'!=''"> + <Base_iOSDevice32>true</Base_iOSDevice32> + <CfgParent>Base</CfgParent> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="('$(Platform)'=='iOSDevice64' and '$(Base)'=='true') or '$(Base_iOSDevice64)'!=''"> + <Base_iOSDevice64>true</Base_iOSDevice64> + <CfgParent>Base</CfgParent> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="('$(Platform)'=='iOSSimulator' and '$(Base)'=='true') or '$(Base_iOSSimulator)'!=''"> + <Base_iOSSimulator>true</Base_iOSSimulator> + <CfgParent>Base</CfgParent> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="('$(Platform)'=='Win32' and '$(Base)'=='true') or '$(Base_Win32)'!=''"> + <Base_Win32>true</Base_Win32> + <CfgParent>Base</CfgParent> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="('$(Platform)'=='Win64' and '$(Base)'=='true') or '$(Base_Win64)'!=''"> + <Base_Win64>true</Base_Win64> + <CfgParent>Base</CfgParent> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="'$(Config)'=='Release' or '$(Cfg_1)'!=''"> + <Cfg_1>true</Cfg_1> + <CfgParent>Base</CfgParent> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="'$(Config)'=='Debug' or '$(Cfg_2)'!=''"> + <Cfg_2>true</Cfg_2> + <CfgParent>Base</CfgParent> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="('$(Platform)'=='iOSDevice32' and '$(Cfg_2)'=='true') or '$(Cfg_2_iOSDevice32)'!=''"> + <Cfg_2_iOSDevice32>true</Cfg_2_iOSDevice32> + <CfgParent>Cfg_2</CfgParent> + <Cfg_2>true</Cfg_2> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="('$(Platform)'=='iOSDevice64' and '$(Cfg_2)'=='true') or '$(Cfg_2_iOSDevice64)'!=''"> + <Cfg_2_iOSDevice64>true</Cfg_2_iOSDevice64> + <CfgParent>Cfg_2</CfgParent> + <Cfg_2>true</Cfg_2> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="('$(Platform)'=='Win32' and '$(Cfg_2)'=='true') or '$(Cfg_2_Win32)'!=''"> + <Cfg_2_Win32>true</Cfg_2_Win32> + <CfgParent>Cfg_2</CfgParent> + <Cfg_2>true</Cfg_2> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="'$(Base)'!=''"> + <DCC_F>false</DCC_F> + <SanitizedProjectName>paxcomp_D10</SanitizedProjectName> + <GenDll>true</GenDll> + <DCC_E>false</DCC_E> + <DCC_S>false</DCC_S> + <GenPackage>true</GenPackage> + <DCC_Namespace>Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;System;Xml;Data;Datasnap;Web;Soap;$(DCC_Namespace)</DCC_Namespace> + <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=;CFBundleName=</VerInfo_Keys> + <DCC_K>false</DCC_K> + <VerInfo_Locale>1033</VerInfo_Locale> + <DCC_N>false</DCC_N> + <DCC_ImageBase>00400000</DCC_ImageBase> + </PropertyGroup> + <PropertyGroup Condition="'$(Base_Android)'!=''"> + <EnabledSysJars>android-support-v4.dex.jar;apk-expansion.dex.jar;cloud-messaging.dex.jar;fmx.dex.jar;google-analytics-v2.dex.jar;google-play-billing.dex.jar;google-play-licensing.dex.jar;google-play-services.dex.jar</EnabledSysJars> + <BT_BuildType>Debug</BT_BuildType> + <VerInfo_Keys>package=com.embarcadero.$(MSBuildProjectName);label=$(MSBuildProjectName);versionCode=1;versionName=1.0.0;persistent=False;restoreAnyVersion=False;installLocation=preferExternal;largeHeap=False;theme=TitleBar;hardwareAccelerated=true</VerInfo_Keys> + <DCC_UsePackage>rtl;soaprtl;$(DCC_UsePackage)</DCC_UsePackage> + </PropertyGroup> + <PropertyGroup Condition="'$(Base_iOSDevice32)'!=''"> + <VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo> + <CfgParent>Base</CfgParent> + <VerInfo_BundleId>$(MSBuildProjectName)</VerInfo_BundleId> + <VerInfo_UIDeviceFamily>iPhoneAndiPad</VerInfo_UIDeviceFamily> + <VerInfo_Keys>CFBundleName=$(MSBuildProjectName);CFBundleDevelopmentRegion=en;CFBundleDisplayName=$(MSBuildProjectName);CFBundleIdentifier=$(MSBuildProjectName);CFBundleInfoDictionaryVersion=7.1;CFBundleVersion=1.0.0.0;CFBundlePackageType=APPL;CFBundleSignature=????;LSRequiresIPhoneOS=true;CFBundleAllowMixedLocalizations=YES;CFBundleExecutable=$(MSBuildProjectName);UIDeviceFamily=iPhone & iPad;CFBundleResourceSpecification=ResourceRules.plist;NSLocationAlwaysUsageDescription=The reason for accessing the location information of the user;NSLocationWhenInUseUsageDescription=The reason for accessing the location information of the user;FMLocalNotificationPermission=false;UIBackgroundModes=</VerInfo_Keys> + <BT_BuildType>Debug</BT_BuildType> + <Base>true</Base> + <Base_iOSDevice>true</Base_iOSDevice> + <DCC_UsePackage>rtl;soaprtl;$(DCC_UsePackage);$(DCC_UsePackage)</DCC_UsePackage> + </PropertyGroup> + <PropertyGroup Condition="'$(Base_iOSDevice64)'!=''"> + <VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo> + <CfgParent>Base</CfgParent> + <VerInfo_BundleId>$(MSBuildProjectName)</VerInfo_BundleId> + <VerInfo_UIDeviceFamily>iPhoneAndiPad</VerInfo_UIDeviceFamily> + <VerInfo_Keys>CFBundleName=$(MSBuildProjectName);CFBundleDevelopmentRegion=en;CFBundleDisplayName=$(MSBuildProjectName);CFBundleIdentifier=$(MSBuildProjectName);CFBundleInfoDictionaryVersion=7.1;CFBundleVersion=1.0.0.0;CFBundlePackageType=APPL;CFBundleSignature=????;LSRequiresIPhoneOS=true;CFBundleAllowMixedLocalizations=YES;CFBundleExecutable=$(MSBuildProjectName);UIDeviceFamily=iPhone & iPad;CFBundleResourceSpecification=ResourceRules.plist;NSLocationAlwaysUsageDescription=The reason for accessing the location information of the user;NSLocationWhenInUseUsageDescription=The reason for accessing the location information of the user;FMLocalNotificationPermission=false;UIBackgroundModes=</VerInfo_Keys> + <BT_BuildType>Debug</BT_BuildType> + <Base>true</Base> + <Base_iOSDevice>true</Base_iOSDevice> + <DCC_UsePackage>rtl;soaprtl;$(DCC_UsePackage);$(DCC_UsePackage)</DCC_UsePackage> + </PropertyGroup> + <PropertyGroup Condition="'$(Base_iOSSimulator)'!=''"> + <DCC_UsePackage>rtl;soaprtl;$(DCC_UsePackage)</DCC_UsePackage> + </PropertyGroup> + <PropertyGroup Condition="'$(Base_Win32)'!=''"> + <VerInfo_Locale>1033</VerInfo_Locale> + <VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo> + <DCC_Namespace>Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace)</DCC_Namespace> + <DCC_UsePackage>rtl;vcl;soaprtl;$(DCC_UsePackage)</DCC_UsePackage> + <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=</VerInfo_Keys> + </PropertyGroup> + <PropertyGroup Condition="'$(Base_Win64)'!=''"> + <DCC_Namespace>Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;$(DCC_Namespace)</DCC_Namespace> + <VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo> + <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=</VerInfo_Keys> + <DCC_UsePackage>rtl;vcl;soaprtl;$(DCC_UsePackage)</DCC_UsePackage> + </PropertyGroup> + <PropertyGroup Condition="'$(Cfg_1)'!=''"> + <DCC_DebugInformation>0</DCC_DebugInformation> + <DCC_LocalDebugSymbols>false</DCC_LocalDebugSymbols> + <DCC_Define>RELEASE;$(DCC_Define)</DCC_Define> + <DCC_SymbolReferenceInfo>0</DCC_SymbolReferenceInfo> + </PropertyGroup> + <PropertyGroup Condition="'$(Cfg_2)'!=''"> + <DCC_GenerateStackFrames>true</DCC_GenerateStackFrames> + <DCC_Define>DEBUG;$(DCC_Define)</DCC_Define> + <DCC_Optimize>false</DCC_Optimize> + </PropertyGroup> + <PropertyGroup Condition="'$(Cfg_2_iOSDevice32)'!=''"> + <DCC_RemoteDebug>true</DCC_RemoteDebug> + </PropertyGroup> + <PropertyGroup Condition="'$(Cfg_2_iOSDevice64)'!=''"> + <DCC_RemoteDebug>true</DCC_RemoteDebug> + </PropertyGroup> + <PropertyGroup Condition="'$(Cfg_2_Win32)'!=''"> + <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=</VerInfo_Keys> + </PropertyGroup> + <ItemGroup> + <DelphiCompile Include="$(MainSource)"> + <MainSource>MainSource</MainSource> + </DelphiCompile> + <DCCReference Include="PaxCompiler.dcr"/> + <DCCReference Include="rtl.dcp"/> + <DCCReference Include="vcl.dcp"/> + <DCCReference Include="soaprtl.dcp"/> + <DCCReference Include="PaxCompilerRegister.pas"/> + <BuildConfiguration Include="Debug"> + <Key>Cfg_2</Key> + <CfgParent>Base</CfgParent> + </BuildConfiguration> + <BuildConfiguration Include="Base"> + <Key>Base</Key> + </BuildConfiguration> + <BuildConfiguration Include="Release"> + <Key>Cfg_1</Key> + <CfgParent>Base</CfgParent> + </BuildConfiguration> + </ItemGroup> + <ProjectExtensions> + <Borland.Personality>Delphi.Personality.12</Borland.Personality> + <Borland.ProjectType>Package</Borland.ProjectType> + <BorlandProject> + <Delphi.Personality> + <Source> + <Source Name="MainSource">paxcomp_D10.dpk</Source> + </Source> + </Delphi.Personality> + <Platforms> + <Platform value="Android">False</Platform> + <Platform value="iOSDevice32">False</Platform> + <Platform value="iOSDevice64">False</Platform> + <Platform value="iOSSimulator">False</Platform> + <Platform value="Win32">True</Platform> + <Platform value="Win64">False</Platform> + </Platforms> + <Deployment Version="2"> + <DeployFile LocalName="..\..\..\..\Public\Documents\Embarcadero\Studio\17.0\Bpl\paxcomp_D10.bpl" Configuration="Debug" Class="ProjectOutput"> + <Platform Name="Win32"> + <RemoteName>paxcomp_D10.bpl</RemoteName> + <Overwrite>true</Overwrite> + </Platform> + </DeployFile> + <DeployClass Name="ProjectiOSDeviceResourceRules"/> + <DeployClass Name="ProjectOSXResource"> + <Platform Name="OSX32"> + <RemoteDir>Contents\Resources</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="AndroidClassesDexFile"> + <Platform Name="Android"> + <RemoteDir>classes</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="AdditionalDebugSymbols"> + <Platform Name="Win32"> + <RemoteDir>Contents\MacOS</RemoteDir> + <Operation>0</Operation> + </Platform> + <Platform Name="OSX32"> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="iPad_Launch768"> + <Platform Name="iOSSimulator"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice64"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice32"> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="Android_LauncherIcon144"> + <Platform Name="Android"> + <RemoteDir>res\drawable-xxhdpi</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="AndroidLibnativeMipsFile"> + <Platform Name="Android"> + <RemoteDir>library\lib\mips</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Required="true" Name="ProjectOutput"> + <Platform Name="Win32"> + <Operation>0</Operation> + </Platform> + <Platform Name="iOSDevice64"> + <Operation>1</Operation> + </Platform> + <Platform Name="OSX32"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice32"> + <Operation>1</Operation> + </Platform> + <Platform Name="Android"> + <RemoteDir>library\lib\armeabi-v7a</RemoteDir> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSSimulator"> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="DependencyFramework"> + <Platform Name="Win32"> + <Operation>0</Operation> + </Platform> + <Platform Name="OSX32"> + <Operation>1</Operation> + <Extensions>.framework</Extensions> + </Platform> + </DeployClass> + <DeployClass Name="iPhone_Launch640"> + <Platform Name="iOSSimulator"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice64"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice32"> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="iPad_Launch1024"> + <Platform Name="iOSSimulator"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice64"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice32"> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="ProjectiOSDeviceDebug"> + <Platform Name="iOSDevice64"> + <RemoteDir>..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF</RemoteDir> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice32"> + <RemoteDir>..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="AndroidLibnativeX86File"> + <Platform Name="Android"> + <RemoteDir>library\lib\x86</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="iPhone_Launch320"> + <Platform Name="iOSSimulator"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice64"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice32"> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="ProjectiOSInfoPList"/> + <DeployClass Name="AndroidLibnativeArmeabiFile"> + <Platform Name="Android"> + <RemoteDir>library\lib\armeabi</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="DebugSymbols"> + <Platform Name="Win32"> + <Operation>0</Operation> + </Platform> + <Platform Name="iOSSimulator"> + <Operation>1</Operation> + </Platform> + <Platform Name="OSX32"> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="iPad_Launch1536"> + <Platform Name="iOSSimulator"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice64"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice32"> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="Android_SplashImage470"> + <Platform Name="Android"> + <RemoteDir>res\drawable-normal</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="Android_LauncherIcon96"> + <Platform Name="Android"> + <RemoteDir>res\drawable-xhdpi</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="Android_SplashImage640"> + <Platform Name="Android"> + <RemoteDir>res\drawable-large</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="iPhone_Launch640x1136"> + <Platform Name="iOSSimulator"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice64"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice32"> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="ProjectiOSEntitlements"/> + <DeployClass Name="Android_LauncherIcon72"> + <Platform Name="Android"> + <RemoteDir>res\drawable-hdpi</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="AndroidGDBServer"> + <Platform Name="Android"> + <RemoteDir>library\lib\armeabi-v7a</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="ProjectOSXInfoPList"/> + <DeployClass Name="ProjectOSXEntitlements"/> + <DeployClass Name="iPad_Launch2048"> + <Platform Name="iOSSimulator"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice64"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice32"> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="AndroidSplashStyles"> + <Platform Name="Android"> + <RemoteDir>res\values</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="Android_SplashImage426"> + <Platform Name="Android"> + <RemoteDir>res\drawable-small</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="AndroidSplashImageDef"> + <Platform Name="Android"> + <RemoteDir>res\drawable</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="ProjectiOSResource"> + <Platform Name="iOSSimulator"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice64"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice32"> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="ProjectAndroidManifest"> + <Platform Name="Android"> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="Android_DefaultAppIcon"> + <Platform Name="Android"> + <RemoteDir>res\drawable</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="File"> + <Platform Name="Win32"> + <Operation>0</Operation> + </Platform> + <Platform Name="iOSDevice64"> + <Operation>0</Operation> + </Platform> + <Platform Name="OSX32"> + <Operation>0</Operation> + </Platform> + <Platform Name="iOSDevice32"> + <Operation>0</Operation> + </Platform> + <Platform Name="Android"> + <Operation>0</Operation> + </Platform> + <Platform Name="iOSSimulator"> + <Operation>0</Operation> + </Platform> + </DeployClass> + <DeployClass Name="AndroidServiceOutput"> + <Platform Name="Android"> + <RemoteDir>library\lib\armeabi-v7a</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Required="true" Name="DependencyPackage"> + <Platform Name="Win32"> + <Operation>0</Operation> + <Extensions>.bpl</Extensions> + </Platform> + <Platform Name="iOSDevice64"> + <Operation>1</Operation> + <Extensions>.dylib</Extensions> + </Platform> + <Platform Name="OSX32"> + <Operation>1</Operation> + <Extensions>.dylib</Extensions> + </Platform> + <Platform Name="iOSDevice32"> + <Operation>1</Operation> + <Extensions>.dylib</Extensions> + </Platform> + <Platform Name="iOSSimulator"> + <Operation>1</Operation> + <Extensions>.dylib</Extensions> + </Platform> + </DeployClass> + <DeployClass Name="Android_LauncherIcon48"> + <Platform Name="Android"> + <RemoteDir>res\drawable-mdpi</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="Android_SplashImage960"> + <Platform Name="Android"> + <RemoteDir>res\drawable-xlarge</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="Android_LauncherIcon36"> + <Platform Name="Android"> + <RemoteDir>res\drawable-ldpi</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="DependencyModule"> + <Platform Name="Win32"> + <Operation>0</Operation> + <Extensions>.dll;.bpl</Extensions> + </Platform> + <Platform Name="OSX32"> + <Operation>1</Operation> + <Extensions>.dylib</Extensions> + </Platform> + </DeployClass> + <ProjectRoot Platform="iOSDevice64" Name="$(PROJECTNAME).app"/> + <ProjectRoot Platform="Win64" Name="$(PROJECTNAME)"/> + <ProjectRoot Platform="iOSDevice32" Name="$(PROJECTNAME).app"/> + <ProjectRoot Platform="Win32" Name="$(PROJECTNAME)"/> + <ProjectRoot Platform="OSX32" Name="$(PROJECTNAME)"/> + <ProjectRoot Platform="Android" Name="$(PROJECTNAME)"/> + <ProjectRoot Platform="iOSSimulator" Name="$(PROJECTNAME).app"/> + </Deployment> + </BorlandProject> + <ProjectFileVersion>12</ProjectFileVersion> + </ProjectExtensions> + <Import Project="$(BDS)\Bin\CodeGear.Delphi.Targets" Condition="Exists('$(BDS)\Bin\CodeGear.Delphi.Targets')"/> + <Import Project="$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj" Condition="Exists('$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj')"/> + <Import Project="$(MSBuildProjectName).deployproj" Condition="Exists('$(MSBuildProjectName).deployproj')"/> +</Project> diff --git a/Sources/paxcomp_D10.otares b/Sources/paxcomp_D10.otares new file mode 100644 index 0000000..7435995 Binary files /dev/null and b/Sources/paxcomp_D10.otares differ diff --git a/Sources/paxcomp_D10.res b/Sources/paxcomp_D10.res new file mode 100644 index 0000000..a64cea3 Binary files /dev/null and b/Sources/paxcomp_D10.res differ diff --git a/Sources/paxcomp_D10_1.dpk b/Sources/paxcomp_D10_1.dpk new file mode 100644 index 0000000..45d981d --- /dev/null +++ b/Sources/paxcomp_D10_1.dpk @@ -0,0 +1,40 @@ +package paxcomp_D10_1; + +{$R *.res} +{$R *.otares} +{$R 'PaxCompiler.dcr'} +{$IFDEF IMPLICITBUILDING This IFDEF should not be used by users} +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO OFF} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION OFF} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES ON} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$DEFINE DEBUG} +{$ENDIF IMPLICITBUILDING} +{$IMPLICITBUILD ON} + +requires + rtl, + vcl, + soaprtl; + +contains + PaxCompilerRegister in 'PaxCompilerRegister.pas'; + +end. diff --git a/Sources/paxcomp_D10_1.dproj b/Sources/paxcomp_D10_1.dproj new file mode 100644 index 0000000..f4c84d2 --- /dev/null +++ b/Sources/paxcomp_D10_1.dproj @@ -0,0 +1,534 @@ +<Project xmlns="http://schemas.microsoft.com/developer/msbuild/2003"> + <PropertyGroup> + <ProjectGuid>{D3E41B87-1FB2-4838-9992-AEE184233C8B}</ProjectGuid> + <MainSource>paxcomp_D10_1.dpk</MainSource> + <Base>True</Base> + <Config Condition="'$(Config)'==''">Debug</Config> + <TargetedPlatforms>1</TargetedPlatforms> + <AppType>Package</AppType> + <FrameworkType>VCL</FrameworkType> + <ProjectVersion>18.1</ProjectVersion> + <Platform Condition="'$(Platform)'==''">Win32</Platform> + </PropertyGroup> + <PropertyGroup Condition="'$(Config)'=='Base' or '$(Base)'!=''"> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="('$(Platform)'=='Android' and '$(Base)'=='true') or '$(Base_Android)'!=''"> + <Base_Android>true</Base_Android> + <CfgParent>Base</CfgParent> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="('$(Platform)'=='iOSDevice32' and '$(Base)'=='true') or '$(Base_iOSDevice32)'!=''"> + <Base_iOSDevice32>true</Base_iOSDevice32> + <CfgParent>Base</CfgParent> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="('$(Platform)'=='iOSDevice64' and '$(Base)'=='true') or '$(Base_iOSDevice64)'!=''"> + <Base_iOSDevice64>true</Base_iOSDevice64> + <CfgParent>Base</CfgParent> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="('$(Platform)'=='iOSSimulator' and '$(Base)'=='true') or '$(Base_iOSSimulator)'!=''"> + <Base_iOSSimulator>true</Base_iOSSimulator> + <CfgParent>Base</CfgParent> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="('$(Platform)'=='Win32' and '$(Base)'=='true') or '$(Base_Win32)'!=''"> + <Base_Win32>true</Base_Win32> + <CfgParent>Base</CfgParent> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="('$(Platform)'=='Win64' and '$(Base)'=='true') or '$(Base_Win64)'!=''"> + <Base_Win64>true</Base_Win64> + <CfgParent>Base</CfgParent> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="'$(Config)'=='Release' or '$(Cfg_1)'!=''"> + <Cfg_1>true</Cfg_1> + <CfgParent>Base</CfgParent> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="'$(Config)'=='Debug' or '$(Cfg_2)'!=''"> + <Cfg_2>true</Cfg_2> + <CfgParent>Base</CfgParent> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="('$(Platform)'=='iOSDevice32' and '$(Cfg_2)'=='true') or '$(Cfg_2_iOSDevice32)'!=''"> + <Cfg_2_iOSDevice32>true</Cfg_2_iOSDevice32> + <CfgParent>Cfg_2</CfgParent> + <Cfg_2>true</Cfg_2> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="('$(Platform)'=='iOSDevice64' and '$(Cfg_2)'=='true') or '$(Cfg_2_iOSDevice64)'!=''"> + <Cfg_2_iOSDevice64>true</Cfg_2_iOSDevice64> + <CfgParent>Cfg_2</CfgParent> + <Cfg_2>true</Cfg_2> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="('$(Platform)'=='Win32' and '$(Cfg_2)'=='true') or '$(Cfg_2_Win32)'!=''"> + <Cfg_2_Win32>true</Cfg_2_Win32> + <CfgParent>Cfg_2</CfgParent> + <Cfg_2>true</Cfg_2> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="'$(Base)'!=''"> + <DCC_F>false</DCC_F> + <SanitizedProjectName>paxcomp_D10_1</SanitizedProjectName> + <GenDll>true</GenDll> + <DCC_E>false</DCC_E> + <DCC_S>false</DCC_S> + <GenPackage>true</GenPackage> + <DCC_Namespace>Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;System;Xml;Data;Datasnap;Web;Soap;$(DCC_Namespace)</DCC_Namespace> + <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=;CFBundleName=</VerInfo_Keys> + <DCC_K>false</DCC_K> + <VerInfo_Locale>1033</VerInfo_Locale> + <DCC_N>false</DCC_N> + <DCC_ImageBase>00400000</DCC_ImageBase> + </PropertyGroup> + <PropertyGroup Condition="'$(Base_Android)'!=''"> + <EnabledSysJars>android-support-v4.dex.jar;apk-expansion.dex.jar;cloud-messaging.dex.jar;fmx.dex.jar;google-analytics-v2.dex.jar;google-play-billing.dex.jar;google-play-licensing.dex.jar;google-play-services.dex.jar</EnabledSysJars> + <BT_BuildType>Debug</BT_BuildType> + <VerInfo_Keys>package=com.embarcadero.$(MSBuildProjectName);label=$(MSBuildProjectName);versionCode=1;versionName=1.0.0;persistent=False;restoreAnyVersion=False;installLocation=preferExternal;largeHeap=False;theme=TitleBar;hardwareAccelerated=true</VerInfo_Keys> + <DCC_UsePackage>rtl;soaprtl;$(DCC_UsePackage)</DCC_UsePackage> + </PropertyGroup> + <PropertyGroup Condition="'$(Base_iOSDevice32)'!=''"> + <VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo> + <CfgParent>Base</CfgParent> + <VerInfo_BundleId>$(MSBuildProjectName)</VerInfo_BundleId> + <VerInfo_UIDeviceFamily>iPhoneAndiPad</VerInfo_UIDeviceFamily> + <VerInfo_Keys>CFBundleName=$(MSBuildProjectName);CFBundleDevelopmentRegion=en;CFBundleDisplayName=$(MSBuildProjectName);CFBundleIdentifier=$(MSBuildProjectName);CFBundleInfoDictionaryVersion=7.1;CFBundleVersion=1.0.0.0;CFBundlePackageType=APPL;CFBundleSignature=????;LSRequiresIPhoneOS=true;CFBundleAllowMixedLocalizations=YES;CFBundleExecutable=$(MSBuildProjectName);UIDeviceFamily=iPhone & iPad;CFBundleResourceSpecification=ResourceRules.plist;NSLocationAlwaysUsageDescription=The reason for accessing the location information of the user;NSLocationWhenInUseUsageDescription=The reason for accessing the location information of the user;FMLocalNotificationPermission=false;UIBackgroundModes=</VerInfo_Keys> + <BT_BuildType>Debug</BT_BuildType> + <Base>true</Base> + <Base_iOSDevice>true</Base_iOSDevice> + <DCC_UsePackage>rtl;soaprtl;$(DCC_UsePackage);$(DCC_UsePackage)</DCC_UsePackage> + </PropertyGroup> + <PropertyGroup Condition="'$(Base_iOSDevice64)'!=''"> + <VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo> + <CfgParent>Base</CfgParent> + <VerInfo_BundleId>$(MSBuildProjectName)</VerInfo_BundleId> + <VerInfo_UIDeviceFamily>iPhoneAndiPad</VerInfo_UIDeviceFamily> + <VerInfo_Keys>CFBundleName=$(MSBuildProjectName);CFBundleDevelopmentRegion=en;CFBundleDisplayName=$(MSBuildProjectName);CFBundleIdentifier=$(MSBuildProjectName);CFBundleInfoDictionaryVersion=7.1;CFBundleVersion=1.0.0.0;CFBundlePackageType=APPL;CFBundleSignature=????;LSRequiresIPhoneOS=true;CFBundleAllowMixedLocalizations=YES;CFBundleExecutable=$(MSBuildProjectName);UIDeviceFamily=iPhone & iPad;CFBundleResourceSpecification=ResourceRules.plist;NSLocationAlwaysUsageDescription=The reason for accessing the location information of the user;NSLocationWhenInUseUsageDescription=The reason for accessing the location information of the user;FMLocalNotificationPermission=false;UIBackgroundModes=</VerInfo_Keys> + <BT_BuildType>Debug</BT_BuildType> + <Base>true</Base> + <Base_iOSDevice>true</Base_iOSDevice> + <DCC_UsePackage>rtl;soaprtl;$(DCC_UsePackage);$(DCC_UsePackage)</DCC_UsePackage> + </PropertyGroup> + <PropertyGroup Condition="'$(Base_iOSSimulator)'!=''"> + <DCC_UsePackage>rtl;soaprtl;$(DCC_UsePackage)</DCC_UsePackage> + </PropertyGroup> + <PropertyGroup Condition="'$(Base_Win32)'!=''"> + <VerInfo_Locale>1033</VerInfo_Locale> + <VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo> + <DCC_Namespace>Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace)</DCC_Namespace> + <DCC_UsePackage>rtl;vcl;soaprtl;$(DCC_UsePackage)</DCC_UsePackage> + <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=</VerInfo_Keys> + </PropertyGroup> + <PropertyGroup Condition="'$(Base_Win64)'!=''"> + <DCC_Namespace>Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;$(DCC_Namespace)</DCC_Namespace> + <VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo> + <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=</VerInfo_Keys> + <DCC_UsePackage>rtl;vcl;soaprtl;$(DCC_UsePackage)</DCC_UsePackage> + </PropertyGroup> + <PropertyGroup Condition="'$(Cfg_1)'!=''"> + <DCC_DebugInformation>0</DCC_DebugInformation> + <DCC_LocalDebugSymbols>false</DCC_LocalDebugSymbols> + <DCC_Define>RELEASE;$(DCC_Define)</DCC_Define> + <DCC_SymbolReferenceInfo>0</DCC_SymbolReferenceInfo> + </PropertyGroup> + <PropertyGroup Condition="'$(Cfg_2)'!=''"> + <DCC_GenerateStackFrames>true</DCC_GenerateStackFrames> + <DCC_Define>DEBUG;$(DCC_Define)</DCC_Define> + <DCC_Optimize>false</DCC_Optimize> + </PropertyGroup> + <PropertyGroup Condition="'$(Cfg_2_iOSDevice32)'!=''"> + <DCC_RemoteDebug>true</DCC_RemoteDebug> + </PropertyGroup> + <PropertyGroup Condition="'$(Cfg_2_iOSDevice64)'!=''"> + <DCC_RemoteDebug>true</DCC_RemoteDebug> + </PropertyGroup> + <PropertyGroup Condition="'$(Cfg_2_Win32)'!=''"> + <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=</VerInfo_Keys> + </PropertyGroup> + <ItemGroup> + <DelphiCompile Include="$(MainSource)"> + <MainSource>MainSource</MainSource> + </DelphiCompile> + <DCCReference Include="PaxCompiler.dcr"/> + <DCCReference Include="rtl.dcp"/> + <DCCReference Include="vcl.dcp"/> + <DCCReference Include="soaprtl.dcp"/> + <DCCReference Include="PaxCompilerRegister.pas"/> + <BuildConfiguration Include="Debug"> + <Key>Cfg_2</Key> + <CfgParent>Base</CfgParent> + </BuildConfiguration> + <BuildConfiguration Include="Base"> + <Key>Base</Key> + </BuildConfiguration> + <BuildConfiguration Include="Release"> + <Key>Cfg_1</Key> + <CfgParent>Base</CfgParent> + </BuildConfiguration> + </ItemGroup> + <ProjectExtensions> + <Borland.Personality>Delphi.Personality.12</Borland.Personality> + <Borland.ProjectType>Package</Borland.ProjectType> + <BorlandProject> + <Delphi.Personality> + <Source> + <Source Name="MainSource">paxcomp_D10_1.dpk</Source> + </Source> + </Delphi.Personality> + <Platforms> + <Platform value="Android">False</Platform> + <Platform value="iOSDevice32">False</Platform> + <Platform value="iOSDevice64">False</Platform> + <Platform value="iOSSimulator">False</Platform> + <Platform value="Win32">True</Platform> + <Platform value="Win64">False</Platform> + </Platforms> + <Deployment Version="3"> + <DeployFile LocalName="..\..\..\..\Public\Documents\Embarcadero\Studio\18.0\Bpl\paxcomp_D10_1.bpl" Configuration="Debug" Class="ProjectOutput"> + <Platform Name="Win32"> + <RemoteName>paxcomp_D10_1.bpl</RemoteName> + <Overwrite>true</Overwrite> + </Platform> + </DeployFile> + <DeployClass Name="ProjectiOSDeviceResourceRules"/> + <DeployClass Name="ProjectOSXResource"> + <Platform Name="OSX32"> + <RemoteDir>Contents\Resources</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="AndroidClassesDexFile"> + <Platform Name="Android"> + <RemoteDir>classes</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="AdditionalDebugSymbols"> + <Platform Name="Win32"> + <RemoteDir>Contents\MacOS</RemoteDir> + <Operation>0</Operation> + </Platform> + <Platform Name="OSX32"> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="iPad_Launch768"> + <Platform Name="iOSSimulator"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice64"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice32"> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="Android_LauncherIcon144"> + <Platform Name="Android"> + <RemoteDir>res\drawable-xxhdpi</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="AndroidLibnativeMipsFile"> + <Platform Name="Android"> + <RemoteDir>library\lib\mips</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Required="true" Name="ProjectOutput"> + <Platform Name="iOSDevice64"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice32"> + <Operation>1</Operation> + </Platform> + <Platform Name="Win32"> + <Operation>0</Operation> + </Platform> + <Platform Name="Linux64"> + <Operation>1</Operation> + </Platform> + <Platform Name="OSX32"> + <Operation>1</Operation> + </Platform> + <Platform Name="Android"> + <RemoteDir>library\lib\armeabi-v7a</RemoteDir> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSSimulator"> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="DependencyFramework"> + <Platform Name="Win32"> + <Operation>0</Operation> + </Platform> + <Platform Name="OSX32"> + <Operation>1</Operation> + <Extensions>.framework</Extensions> + </Platform> + </DeployClass> + <DeployClass Name="iPhone_Launch640"> + <Platform Name="iOSSimulator"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice64"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice32"> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="iPad_Launch1024"> + <Platform Name="iOSSimulator"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice64"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice32"> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="ProjectiOSDeviceDebug"> + <Platform Name="iOSDevice64"> + <RemoteDir>..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF</RemoteDir> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice32"> + <RemoteDir>..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="AndroidLibnativeX86File"/> + <DeployClass Name="iPhone_Launch320"> + <Platform Name="iOSSimulator"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice64"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice32"> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="ProjectiOSInfoPList"/> + <DeployClass Name="AndroidLibnativeArmeabiFile"> + <Platform Name="Android"> + <RemoteDir>library\lib\armeabi</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="DebugSymbols"> + <Platform Name="Win32"> + <Operation>0</Operation> + </Platform> + <Platform Name="iOSSimulator"> + <Operation>1</Operation> + </Platform> + <Platform Name="OSX32"> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="iPad_Launch1536"> + <Platform Name="iOSSimulator"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice64"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice32"> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="Android_SplashImage470"> + <Platform Name="Android"> + <RemoteDir>res\drawable-normal</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="Android_LauncherIcon96"> + <Platform Name="Android"> + <RemoteDir>res\drawable-xhdpi</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="Android_SplashImage640"> + <Platform Name="Android"> + <RemoteDir>res\drawable-large</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="iPhone_Launch640x1136"> + <Platform Name="iOSSimulator"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice64"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice32"> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="ProjectiOSEntitlements"/> + <DeployClass Name="Android_LauncherIcon72"> + <Platform Name="Android"> + <RemoteDir>res\drawable-hdpi</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="AndroidGDBServer"> + <Platform Name="Android"> + <RemoteDir>library\lib\armeabi-v7a</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="ProjectOSXInfoPList"/> + <DeployClass Name="ProjectOSXEntitlements"/> + <DeployClass Name="iPad_Launch2048"> + <Platform Name="iOSSimulator"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice64"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice32"> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="AndroidSplashStyles"> + <Platform Name="Android"> + <RemoteDir>res\values</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="Android_SplashImage426"> + <Platform Name="Android"> + <RemoteDir>res\drawable-small</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="AndroidSplashImageDef"> + <Platform Name="Android"> + <RemoteDir>res\drawable</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="ProjectiOSResource"> + <Platform Name="iOSSimulator"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice64"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice32"> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="ProjectAndroidManifest"> + <Platform Name="Android"> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="Android_DefaultAppIcon"> + <Platform Name="Android"> + <RemoteDir>res\drawable</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="File"> + <Platform Name="Win32"> + <Operation>0</Operation> + </Platform> + <Platform Name="iOSDevice64"> + <Operation>0</Operation> + </Platform> + <Platform Name="OSX32"> + <Operation>0</Operation> + </Platform> + <Platform Name="iOSDevice32"> + <Operation>0</Operation> + </Platform> + <Platform Name="Android"> + <Operation>0</Operation> + </Platform> + <Platform Name="iOSSimulator"> + <Operation>0</Operation> + </Platform> + </DeployClass> + <DeployClass Name="AndroidServiceOutput"> + <Platform Name="Android"> + <RemoteDir>library\lib\armeabi-v7a</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Required="true" Name="DependencyPackage"> + <Platform Name="Win32"> + <Operation>0</Operation> + <Extensions>.bpl</Extensions> + </Platform> + <Platform Name="iOSDevice64"> + <Operation>1</Operation> + <Extensions>.dylib</Extensions> + </Platform> + <Platform Name="OSX32"> + <Operation>1</Operation> + <Extensions>.dylib</Extensions> + </Platform> + <Platform Name="iOSDevice32"> + <Operation>1</Operation> + <Extensions>.dylib</Extensions> + </Platform> + <Platform Name="iOSSimulator"> + <Operation>1</Operation> + <Extensions>.dylib</Extensions> + </Platform> + </DeployClass> + <DeployClass Name="Android_LauncherIcon48"> + <Platform Name="Android"> + <RemoteDir>res\drawable-mdpi</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="Android_SplashImage960"> + <Platform Name="Android"> + <RemoteDir>res\drawable-xlarge</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="Android_LauncherIcon36"> + <Platform Name="Android"> + <RemoteDir>res\drawable-ldpi</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="DependencyModule"> + <Platform Name="Win32"> + <Operation>0</Operation> + <Extensions>.dll;.bpl</Extensions> + </Platform> + <Platform Name="OSX32"> + <Operation>1</Operation> + <Extensions>.dylib</Extensions> + </Platform> + </DeployClass> + <ProjectRoot Platform="iOSDevice64" Name="$(PROJECTNAME).app"/> + <ProjectRoot Platform="Win64" Name="$(PROJECTNAME)"/> + <ProjectRoot Platform="iOSDevice32" Name="$(PROJECTNAME).app"/> + <ProjectRoot Platform="Win32" Name="$(PROJECTNAME)"/> + <ProjectRoot Platform="Linux64" Name="$(PROJECTNAME)"/> + <ProjectRoot Platform="OSX32" Name="$(PROJECTNAME)"/> + <ProjectRoot Platform="Android" Name="$(PROJECTNAME)"/> + <ProjectRoot Platform="iOSSimulator" Name="$(PROJECTNAME).app"/> + </Deployment> + </BorlandProject> + <ProjectFileVersion>12</ProjectFileVersion> + </ProjectExtensions> + <Import Project="$(BDS)\Bin\CodeGear.Delphi.Targets" Condition="Exists('$(BDS)\Bin\CodeGear.Delphi.Targets')"/> + <Import Project="$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj" Condition="Exists('$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj')"/> + <Import Project="$(MSBuildProjectName).deployproj" Condition="Exists('$(MSBuildProjectName).deployproj')"/> +</Project> diff --git a/Sources/paxcomp_D10_1.otares b/Sources/paxcomp_D10_1.otares new file mode 100644 index 0000000..7435995 Binary files /dev/null and b/Sources/paxcomp_D10_1.otares differ diff --git a/Sources/paxcomp_D10_1.res b/Sources/paxcomp_D10_1.res new file mode 100644 index 0000000..a64cea3 Binary files /dev/null and b/Sources/paxcomp_D10_1.res differ diff --git a/Sources/paxcomp_D10_2.dpk b/Sources/paxcomp_D10_2.dpk new file mode 100644 index 0000000..dc6cbec --- /dev/null +++ b/Sources/paxcomp_D10_2.dpk @@ -0,0 +1,40 @@ +package paxcomp_D10_2; + +{$R *.res} +{$R *.otares} +{$R 'PaxCompiler.dcr'} +{$IFDEF IMPLICITBUILDING This IFDEF should not be used by users} +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO OFF} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION OFF} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES ON} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$DEFINE DEBUG} +{$ENDIF IMPLICITBUILDING} +{$IMPLICITBUILD ON} + +requires + rtl, + vcl, + soaprtl; + +contains + PaxCompilerRegister in 'PaxCompilerRegister.pas'; + +end. diff --git a/Sources/paxcomp_D10_2.dproj b/Sources/paxcomp_D10_2.dproj new file mode 100644 index 0000000..dd9df51 --- /dev/null +++ b/Sources/paxcomp_D10_2.dproj @@ -0,0 +1,563 @@ +<Project xmlns="http://schemas.microsoft.com/developer/msbuild/2003"> + <PropertyGroup> + <ProjectGuid>{D3E41B87-1FB2-4838-9992-AEE184233C8B}</ProjectGuid> + <MainSource>paxcomp_D10_2.dpk</MainSource> + <Base>True</Base> + <Config Condition="'$(Config)'==''">Debug</Config> + <TargetedPlatforms>3</TargetedPlatforms> + <AppType>Package</AppType> + <FrameworkType>VCL</FrameworkType> + <ProjectVersion>18.2</ProjectVersion> + <Platform Condition="'$(Platform)'==''">Win32</Platform> + </PropertyGroup> + <PropertyGroup Condition="'$(Config)'=='Base' or '$(Base)'!=''"> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="('$(Platform)'=='Android' and '$(Base)'=='true') or '$(Base_Android)'!=''"> + <Base_Android>true</Base_Android> + <CfgParent>Base</CfgParent> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="('$(Platform)'=='iOSDevice32' and '$(Base)'=='true') or '$(Base_iOSDevice32)'!=''"> + <Base_iOSDevice32>true</Base_iOSDevice32> + <CfgParent>Base</CfgParent> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="('$(Platform)'=='iOSDevice64' and '$(Base)'=='true') or '$(Base_iOSDevice64)'!=''"> + <Base_iOSDevice64>true</Base_iOSDevice64> + <CfgParent>Base</CfgParent> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="('$(Platform)'=='iOSSimulator' and '$(Base)'=='true') or '$(Base_iOSSimulator)'!=''"> + <Base_iOSSimulator>true</Base_iOSSimulator> + <CfgParent>Base</CfgParent> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="('$(Platform)'=='Win32' and '$(Base)'=='true') or '$(Base_Win32)'!=''"> + <Base_Win32>true</Base_Win32> + <CfgParent>Base</CfgParent> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="('$(Platform)'=='Win64' and '$(Base)'=='true') or '$(Base_Win64)'!=''"> + <Base_Win64>true</Base_Win64> + <CfgParent>Base</CfgParent> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="'$(Config)'=='Release' or '$(Cfg_1)'!=''"> + <Cfg_1>true</Cfg_1> + <CfgParent>Base</CfgParent> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="'$(Config)'=='Debug' or '$(Cfg_2)'!=''"> + <Cfg_2>true</Cfg_2> + <CfgParent>Base</CfgParent> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="('$(Platform)'=='iOSDevice32' and '$(Cfg_2)'=='true') or '$(Cfg_2_iOSDevice32)'!=''"> + <Cfg_2_iOSDevice32>true</Cfg_2_iOSDevice32> + <CfgParent>Cfg_2</CfgParent> + <Cfg_2>true</Cfg_2> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="('$(Platform)'=='iOSDevice64' and '$(Cfg_2)'=='true') or '$(Cfg_2_iOSDevice64)'!=''"> + <Cfg_2_iOSDevice64>true</Cfg_2_iOSDevice64> + <CfgParent>Cfg_2</CfgParent> + <Cfg_2>true</Cfg_2> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="('$(Platform)'=='Win32' and '$(Cfg_2)'=='true') or '$(Cfg_2_Win32)'!=''"> + <Cfg_2_Win32>true</Cfg_2_Win32> + <CfgParent>Cfg_2</CfgParent> + <Cfg_2>true</Cfg_2> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="'$(Base)'!=''"> + <DCC_F>false</DCC_F> + <SanitizedProjectName>paxcomp_D10_2</SanitizedProjectName> + <GenDll>true</GenDll> + <DCC_E>false</DCC_E> + <DCC_S>false</DCC_S> + <GenPackage>true</GenPackage> + <DCC_Namespace>Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;System;Xml;Data;Datasnap;Web;Soap;$(DCC_Namespace)</DCC_Namespace> + <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=;CFBundleName=</VerInfo_Keys> + <DCC_K>false</DCC_K> + <VerInfo_Locale>1033</VerInfo_Locale> + <DCC_N>false</DCC_N> + <DCC_ImageBase>00400000</DCC_ImageBase> + </PropertyGroup> + <PropertyGroup Condition="'$(Base_Android)'!=''"> + <EnabledSysJars>android-support-v4.dex.jar;apk-expansion.dex.jar;cloud-messaging.dex.jar;fmx.dex.jar;google-analytics-v2.dex.jar;google-play-billing.dex.jar;google-play-licensing.dex.jar;google-play-services.dex.jar</EnabledSysJars> + <BT_BuildType>Debug</BT_BuildType> + <VerInfo_Keys>package=com.embarcadero.$(MSBuildProjectName);label=$(MSBuildProjectName);versionCode=1;versionName=1.0.0;persistent=False;restoreAnyVersion=False;installLocation=preferExternal;largeHeap=False;theme=TitleBar;hardwareAccelerated=true</VerInfo_Keys> + <DCC_UsePackage>rtl;soaprtl;$(DCC_UsePackage)</DCC_UsePackage> + </PropertyGroup> + <PropertyGroup Condition="'$(Base_iOSDevice32)'!=''"> + <VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo> + <CfgParent>Base</CfgParent> + <VerInfo_BundleId>$(MSBuildProjectName)</VerInfo_BundleId> + <VerInfo_UIDeviceFamily>iPhoneAndiPad</VerInfo_UIDeviceFamily> + <VerInfo_Keys>CFBundleName=$(MSBuildProjectName);CFBundleDevelopmentRegion=en;CFBundleDisplayName=$(MSBuildProjectName);CFBundleIdentifier=$(MSBuildProjectName);CFBundleInfoDictionaryVersion=7.1;CFBundleVersion=1.0.0.0;CFBundlePackageType=APPL;CFBundleSignature=????;LSRequiresIPhoneOS=true;CFBundleAllowMixedLocalizations=YES;CFBundleExecutable=$(MSBuildProjectName);UIDeviceFamily=iPhone & iPad;CFBundleResourceSpecification=ResourceRules.plist;NSLocationAlwaysUsageDescription=The reason for accessing the location information of the user;NSLocationWhenInUseUsageDescription=The reason for accessing the location information of the user;FMLocalNotificationPermission=false;UIBackgroundModes=</VerInfo_Keys> + <BT_BuildType>Debug</BT_BuildType> + <Base>true</Base> + <Base_iOSDevice>true</Base_iOSDevice> + <DCC_UsePackage>rtl;soaprtl;$(DCC_UsePackage);$(DCC_UsePackage)</DCC_UsePackage> + </PropertyGroup> + <PropertyGroup Condition="'$(Base_iOSDevice64)'!=''"> + <VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo> + <CfgParent>Base</CfgParent> + <VerInfo_BundleId>$(MSBuildProjectName)</VerInfo_BundleId> + <VerInfo_UIDeviceFamily>iPhoneAndiPad</VerInfo_UIDeviceFamily> + <VerInfo_Keys>CFBundleName=$(MSBuildProjectName);CFBundleDevelopmentRegion=en;CFBundleDisplayName=$(MSBuildProjectName);CFBundleIdentifier=$(MSBuildProjectName);CFBundleInfoDictionaryVersion=7.1;CFBundleVersion=1.0.0.0;CFBundlePackageType=APPL;CFBundleSignature=????;LSRequiresIPhoneOS=true;CFBundleAllowMixedLocalizations=YES;CFBundleExecutable=$(MSBuildProjectName);UIDeviceFamily=iPhone & iPad;CFBundleResourceSpecification=ResourceRules.plist;NSLocationAlwaysUsageDescription=The reason for accessing the location information of the user;NSLocationWhenInUseUsageDescription=The reason for accessing the location information of the user;FMLocalNotificationPermission=false;UIBackgroundModes=</VerInfo_Keys> + <BT_BuildType>Debug</BT_BuildType> + <Base>true</Base> + <Base_iOSDevice>true</Base_iOSDevice> + <DCC_UsePackage>rtl;soaprtl;$(DCC_UsePackage);$(DCC_UsePackage)</DCC_UsePackage> + </PropertyGroup> + <PropertyGroup Condition="'$(Base_iOSSimulator)'!=''"> + <DCC_UsePackage>rtl;soaprtl;$(DCC_UsePackage)</DCC_UsePackage> + </PropertyGroup> + <PropertyGroup Condition="'$(Base_Win32)'!=''"> + <VerInfo_Locale>1033</VerInfo_Locale> + <VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo> + <DCC_Namespace>Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace)</DCC_Namespace> + <DCC_UsePackage>rtl;vcl;soaprtl;$(DCC_UsePackage)</DCC_UsePackage> + <VerInfo_Keys>CompanyName=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(MSBuildProjectName);FileDescription=$(MSBuildProjectName);ProductName=$(MSBuildProjectName)</VerInfo_Keys> + </PropertyGroup> + <PropertyGroup Condition="'$(Base_Win64)'!=''"> + <DCC_Namespace>Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;$(DCC_Namespace)</DCC_Namespace> + <VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo> + <VerInfo_Keys>CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProgramID=com.embarcadero.$(MSBuildProjectName);ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments=</VerInfo_Keys> + <DCC_UsePackage>rtl;vcl;soaprtl;$(DCC_UsePackage)</DCC_UsePackage> + <BT_BuildType>Debug</BT_BuildType> + </PropertyGroup> + <PropertyGroup Condition="'$(Cfg_1)'!=''"> + <DCC_DebugInformation>0</DCC_DebugInformation> + <DCC_LocalDebugSymbols>false</DCC_LocalDebugSymbols> + <DCC_Define>RELEASE;$(DCC_Define)</DCC_Define> + <DCC_SymbolReferenceInfo>0</DCC_SymbolReferenceInfo> + </PropertyGroup> + <PropertyGroup Condition="'$(Cfg_2)'!=''"> + <DCC_GenerateStackFrames>true</DCC_GenerateStackFrames> + <DCC_Define>DEBUG;$(DCC_Define)</DCC_Define> + <DCC_Optimize>false</DCC_Optimize> + </PropertyGroup> + <PropertyGroup Condition="'$(Cfg_2_iOSDevice32)'!=''"> + <DCC_RemoteDebug>true</DCC_RemoteDebug> + </PropertyGroup> + <PropertyGroup Condition="'$(Cfg_2_iOSDevice64)'!=''"> + <DCC_RemoteDebug>true</DCC_RemoteDebug> + </PropertyGroup> + <PropertyGroup Condition="'$(Cfg_2_Win32)'!=''"> + <VerInfo_Keys>CompanyName=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(MSBuildProjectName);FileDescription=$(MSBuildProjectName);ProductName=$(MSBuildProjectName)</VerInfo_Keys> + </PropertyGroup> + <ItemGroup> + <DelphiCompile Include="$(MainSource)"> + <MainSource>MainSource</MainSource> + </DelphiCompile> + <DCCReference Include="PaxCompiler.dcr"/> + <DCCReference Include="rtl.dcp"/> + <DCCReference Include="vcl.dcp"/> + <DCCReference Include="soaprtl.dcp"/> + <DCCReference Include="PaxCompilerRegister.pas"/> + <BuildConfiguration Include="Debug"> + <Key>Cfg_2</Key> + <CfgParent>Base</CfgParent> + </BuildConfiguration> + <BuildConfiguration Include="Base"> + <Key>Base</Key> + </BuildConfiguration> + <BuildConfiguration Include="Release"> + <Key>Cfg_1</Key> + <CfgParent>Base</CfgParent> + </BuildConfiguration> + </ItemGroup> + <ProjectExtensions> + <Borland.Personality>Delphi.Personality.12</Borland.Personality> + <Borland.ProjectType>Package</Borland.ProjectType> + <BorlandProject> + <Delphi.Personality> + <Source> + <Source Name="MainSource">paxcomp_D10_2.dpk</Source> + </Source> + </Delphi.Personality> + <Platforms> + <Platform value="Android">False</Platform> + <Platform value="iOSDevice32">False</Platform> + <Platform value="iOSDevice64">False</Platform> + <Platform value="iOSSimulator">False</Platform> + <Platform value="Win32">True</Platform> + <Platform value="Win64">True</Platform> + </Platforms> + <Deployment Version="3"> + <DeployFile LocalName="..\..\..\..\Public\Documents\Embarcadero\Studio\18.0\Bpl\paxcomp_D10_2.bpl" Configuration="Debug" Class="ProjectOutput"> + <Platform Name="Win32"> + <RemoteName>paxcomp_D10_2.bpl</RemoteName> + <Overwrite>true</Overwrite> + </Platform> + </DeployFile> + <DeployClass Name="AdditionalDebugSymbols"> + <Platform Name="OSX32"> + <Operation>1</Operation> + </Platform> + <Platform Name="Win32"> + <RemoteDir>Contents\MacOS</RemoteDir> + <Operation>0</Operation> + </Platform> + </DeployClass> + <DeployClass Name="AndroidClassesDexFile"> + <Platform Name="Android"> + <RemoteDir>classes</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="AndroidGDBServer"> + <Platform Name="Android"> + <RemoteDir>library\lib\armeabi-v7a</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="AndroidLibnativeArmeabiFile"> + <Platform Name="Android"> + <RemoteDir>library\lib\armeabi</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="AndroidLibnativeMipsFile"> + <Platform Name="Android"> + <RemoteDir>library\lib\mips</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="AndroidLibnativeX86File"/> + <DeployClass Name="AndroidServiceOutput"> + <Platform Name="Android"> + <RemoteDir>library\lib\armeabi-v7a</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="AndroidSplashImageDef"> + <Platform Name="Android"> + <RemoteDir>res\drawable</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="AndroidSplashStyles"> + <Platform Name="Android"> + <RemoteDir>res\values</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="Android_DefaultAppIcon"> + <Platform Name="Android"> + <RemoteDir>res\drawable</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="Android_LauncherIcon144"> + <Platform Name="Android"> + <RemoteDir>res\drawable-xxhdpi</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="Android_LauncherIcon36"> + <Platform Name="Android"> + <RemoteDir>res\drawable-ldpi</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="Android_LauncherIcon48"> + <Platform Name="Android"> + <RemoteDir>res\drawable-mdpi</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="Android_LauncherIcon72"> + <Platform Name="Android"> + <RemoteDir>res\drawable-hdpi</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="Android_LauncherIcon96"> + <Platform Name="Android"> + <RemoteDir>res\drawable-xhdpi</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="Android_SplashImage426"> + <Platform Name="Android"> + <RemoteDir>res\drawable-small</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="Android_SplashImage470"> + <Platform Name="Android"> + <RemoteDir>res\drawable-normal</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="Android_SplashImage640"> + <Platform Name="Android"> + <RemoteDir>res\drawable-large</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="Android_SplashImage960"> + <Platform Name="Android"> + <RemoteDir>res\drawable-xlarge</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="DebugSymbols"> + <Platform Name="iOSSimulator"> + <Operation>1</Operation> + </Platform> + <Platform Name="OSX32"> + <Operation>1</Operation> + </Platform> + <Platform Name="Win32"> + <Operation>0</Operation> + </Platform> + </DeployClass> + <DeployClass Name="DependencyFramework"> + <Platform Name="OSX32"> + <Operation>1</Operation> + <Extensions>.framework</Extensions> + </Platform> + <Platform Name="Win32"> + <Operation>0</Operation> + </Platform> + </DeployClass> + <DeployClass Name="DependencyModule"> + <Platform Name="OSX32"> + <Operation>1</Operation> + <Extensions>.dylib</Extensions> + </Platform> + <Platform Name="Win32"> + <Operation>0</Operation> + <Extensions>.dll;.bpl</Extensions> + </Platform> + </DeployClass> + <DeployClass Required="true" Name="DependencyPackage"> + <Platform Name="iOSDevice32"> + <Operation>1</Operation> + <Extensions>.dylib</Extensions> + </Platform> + <Platform Name="iOSDevice64"> + <Operation>1</Operation> + <Extensions>.dylib</Extensions> + </Platform> + <Platform Name="iOSSimulator"> + <Operation>1</Operation> + <Extensions>.dylib</Extensions> + </Platform> + <Platform Name="OSX32"> + <Operation>1</Operation> + <Extensions>.dylib</Extensions> + </Platform> + <Platform Name="Win32"> + <Operation>0</Operation> + <Extensions>.bpl</Extensions> + </Platform> + </DeployClass> + <DeployClass Name="File"> + <Platform Name="Android"> + <Operation>0</Operation> + </Platform> + <Platform Name="iOSDevice32"> + <Operation>0</Operation> + </Platform> + <Platform Name="iOSDevice64"> + <Operation>0</Operation> + </Platform> + <Platform Name="iOSSimulator"> + <Operation>0</Operation> + </Platform> + <Platform Name="OSX32"> + <Operation>0</Operation> + </Platform> + <Platform Name="Win32"> + <Operation>0</Operation> + </Platform> + </DeployClass> + <DeployClass Name="iPad_Launch1024"> + <Platform Name="iOSDevice32"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice64"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSSimulator"> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="iPad_Launch1536"> + <Platform Name="iOSDevice32"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice64"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSSimulator"> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="iPad_Launch2048"> + <Platform Name="iOSDevice32"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice64"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSSimulator"> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="iPad_Launch768"> + <Platform Name="iOSDevice32"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice64"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSSimulator"> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="iPhone_Launch320"> + <Platform Name="iOSDevice32"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice64"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSSimulator"> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="iPhone_Launch640"> + <Platform Name="iOSDevice32"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice64"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSSimulator"> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="iPhone_Launch640x1136"> + <Platform Name="iOSDevice32"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice64"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSSimulator"> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="ProjectAndroidManifest"> + <Platform Name="Android"> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="ProjectiOSDeviceDebug"> + <Platform Name="iOSDevice32"> + <RemoteDir>..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF</RemoteDir> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice64"> + <RemoteDir>..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="ProjectiOSDeviceResourceRules"/> + <DeployClass Name="ProjectiOSEntitlements"/> + <DeployClass Name="ProjectiOSInfoPList"/> + <DeployClass Name="ProjectiOSResource"> + <Platform Name="iOSDevice32"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice64"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSSimulator"> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="ProjectOSXEntitlements"/> + <DeployClass Name="ProjectOSXInfoPList"/> + <DeployClass Name="ProjectOSXResource"> + <Platform Name="OSX32"> + <RemoteDir>Contents\Resources</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Required="true" Name="ProjectOutput"> + <Platform Name="Android"> + <RemoteDir>library\lib\armeabi-v7a</RemoteDir> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice32"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice64"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSSimulator"> + <Operation>1</Operation> + </Platform> + <Platform Name="Linux64"> + <Operation>1</Operation> + </Platform> + <Platform Name="OSX32"> + <Operation>1</Operation> + </Platform> + <Platform Name="Win32"> + <Operation>0</Operation> + </Platform> + </DeployClass> + <DeployClass Name="ProjectUWPManifest"> + <Platform Name="Win32"> + <Operation>1</Operation> + </Platform> + <Platform Name="Win64"> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="UWP_DelphiLogo150"> + <Platform Name="Win32"> + <RemoteDir>Assets</RemoteDir> + <Operation>1</Operation> + </Platform> + <Platform Name="Win64"> + <RemoteDir>Assets</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="UWP_DelphiLogo44"> + <Platform Name="Win32"> + <RemoteDir>Assets</RemoteDir> + <Operation>1</Operation> + </Platform> + <Platform Name="Win64"> + <RemoteDir>Assets</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <ProjectRoot Platform="iOSDevice64" Name="$(PROJECTNAME).app"/> + <ProjectRoot Platform="Win64" Name="$(PROJECTNAME)"/> + <ProjectRoot Platform="iOSDevice32" Name="$(PROJECTNAME).app"/> + <ProjectRoot Platform="Win32" Name="$(PROJECTNAME)"/> + <ProjectRoot Platform="Linux64" Name="$(PROJECTNAME)"/> + <ProjectRoot Platform="OSX32" Name="$(PROJECTNAME)"/> + <ProjectRoot Platform="Android" Name="$(PROJECTNAME)"/> + <ProjectRoot Platform="iOSSimulator" Name="$(PROJECTNAME).app"/> + </Deployment> + </BorlandProject> + <ProjectFileVersion>12</ProjectFileVersion> + </ProjectExtensions> + <Import Project="$(BDS)\Bin\CodeGear.Delphi.Targets" Condition="Exists('$(BDS)\Bin\CodeGear.Delphi.Targets')"/> + <Import Project="$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj" Condition="Exists('$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj')"/> + <Import Project="$(MSBuildProjectName).deployproj" Condition="Exists('$(MSBuildProjectName).deployproj')"/> +</Project> diff --git a/Sources/paxcomp_D10_2.otares b/Sources/paxcomp_D10_2.otares new file mode 100644 index 0000000..7435995 Binary files /dev/null and b/Sources/paxcomp_D10_2.otares differ diff --git a/Sources/paxcomp_D10_2.res b/Sources/paxcomp_D10_2.res new file mode 100644 index 0000000..05098db Binary files /dev/null and b/Sources/paxcomp_D10_2.res differ diff --git a/Sources/paxcomp_Other.dpk b/Sources/paxcomp_Other.dpk new file mode 100644 index 0000000..7d3717e --- /dev/null +++ b/Sources/paxcomp_Other.dpk @@ -0,0 +1,102 @@ +package paxcomp_Other; + +{$R *.res} +{$R 'PaxCompiler.dcr'} +{$IFDEF IMPLICITBUILDING This IFDEF should not be used by users} +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO OFF} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION OFF} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES ON} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$DEFINE DEBUG} +{$ENDIF IMPLICITBUILDING} +{$RUNONLY} +{$IMPLICITBUILD ON} + +requires + rtl; + +contains + PAXCOMP_2010 in 'PAXCOMP_2010.pas', + PAXCOMP_2010REG in 'PAXCOMP_2010REG.pas', + PAXCOMP_ARM in 'PAXCOMP_ARM.pas', + PAXCOMP_BASERUNNER in 'PAXCOMP_BASERUNNER.pas', + PAXCOMP_BASESYMBOL_TABLE in 'PAXCOMP_BASESYMBOL_TABLE.pas', + PAXCOMP_Basic in 'PAXCOMP_Basic.pas', + PAXCOMP_BASIC_PARSER in 'PAXCOMP_BASIC_PARSER.pas', + PAXCOMP_BASIC_SCANNER in 'PAXCOMP_BASIC_SCANNER.pas', + PAXCOMP_BRIDGE in 'PAXCOMP_BRIDGE.pas', + PAXCOMP_BYTECODE in 'PAXCOMP_BYTECODE.pas', + PAXCOMP_CLASSFACT in 'PAXCOMP_CLASSFACT.pas', + PAXCOMP_CLASSLST in 'PAXCOMP_CLASSLST.pas', + PAXCOMP_CONSTANTS in 'PAXCOMP_CONSTANTS.pas', + PAXCOMP_ERROR in 'PAXCOMP_ERROR.pas', + PAXCOMP_EVAL in 'PAXCOMP_EVAL.pas', + PAXCOMP_EXTRASYMBOL_TABLE in 'PAXCOMP_EXTRASYMBOL_TABLE.pas', + PAXCOMP_FORBID in 'PAXCOMP_FORBID.pas', + PAXCOMP_FRAMEWORK in 'PAXCOMP_FRAMEWORK.pas', + PAXCOMP_GC in 'PAXCOMP_GC.pas', + PAXCOMP_GENERIC in 'PAXCOMP_GENERIC.pas', + PAXCOMP_HEADER_PARSER in 'PAXCOMP_HEADER_PARSER.pas', + PAXCOMP_INVOKE in 'PAXCOMP_INVOKE.pas', + PAXCOMP_JavaScript in 'PAXCOMP_JavaScript.pas', + PAXCOMP_JS_PARSER in 'PAXCOMP_JS_PARSER.pas', + PAXCOMP_JS_SCANNER in 'PAXCOMP_JS_SCANNER.pas', + PAXCOMP_KERNEL in 'PAXCOMP_KERNEL.pas', + PAXCOMP_LABEL_STACK in 'PAXCOMP_LABEL_STACK.pas', + PAXCOMP_LOCALSYMBOL_TABLE in 'PAXCOMP_LOCALSYMBOL_TABLE.pas', + PAXCOMP_MAP in 'PAXCOMP_MAP.pas', + PAXCOMP_MODULE in 'PAXCOMP_MODULE.pas', + PAXCOMP_OFFSET in 'PAXCOMP_OFFSET.pas', + PAXCOMP_OLE in 'PAXCOMP_OLE.pas', + PAXCOMP_PARSER in 'PAXCOMP_PARSER.pas', + PAXCOMP_PASCAL_PARSER in 'PAXCOMP_PASCAL_PARSER.pas', + PAXCOMP_PASCAL_SCANNER in 'PAXCOMP_PASCAL_SCANNER.pas', + PAXCOMP_PCU in 'PAXCOMP_PCU.pas', + PAXCOMP_PROGLIST in 'PAXCOMP_PROGLIST.pas', + PAXCOMP_RTI in 'PAXCOMP_RTI.pas', + PAXCOMP_SCANNER in 'PAXCOMP_SCANNER.pas', + PAXCOMP_STDLIB in 'PAXCOMP_STDLIB.pas', + PAXCOMP_SYMBOL_REC in 'PAXCOMP_SYMBOL_REC.pas', + PAXCOMP_SYMBOL_TABLE in 'PAXCOMP_SYMBOL_TABLE.pas', + PAXCOMP_SYS in 'PAXCOMP_SYS.pas', + PAXCOMP_TYPEINFO in 'PAXCOMP_TYPEINFO.pas', + PAXCOMP_TYPES in 'PAXCOMP_TYPES.pas', + PAXCOMP_VAROBJECT in 'PAXCOMP_VAROBJECT.pas', + PaxCompiler in 'PaxCompiler.pas', + PaxCompilerDebugger in 'PaxCompilerDebugger.pas', + PaxCompilerExplorer in 'PaxCompilerExplorer.pas', + PaxDllImport in 'PaxDllImport.pas', + PaxEval in 'PaxEval.pas', + PaxInfos in 'PaxInfos.pas', + PAXINT_CALL in 'PAXINT_CALL.pas', + PAXINT_CRT in 'PAXINT_CRT.pas', + PAXINT_PROCS in 'PAXINT_PROCS.pas', + PAXINT_RUNNER in 'PAXINT_RUNNER.pas', + PAXINT_SEH in 'PAXINT_SEH.pas', + PAXINT_SYS in 'PAXINT_SYS.pas', + PaxInterpreter in 'PaxInterpreter.pas', + PaxInvoke in 'PaxInvoke.pas', + PaxJavaScriptLanguage in 'PaxJavaScriptLanguage.pas', + PaxRegister in 'PaxRegister.pas', + PaxRunner in 'PaxRunner.pas', + RegExpr2 in 'RegExpr2.pas', + PaxCompilerRegister in 'PaxCompilerRegister.pas'; + +end. diff --git a/Sources/paxcomp_Other.dproj b/Sources/paxcomp_Other.dproj new file mode 100644 index 0000000..f22dafd --- /dev/null +++ b/Sources/paxcomp_Other.dproj @@ -0,0 +1,601 @@ +<Project xmlns="http://schemas.microsoft.com/developer/msbuild/2003"> + <PropertyGroup> + <ProjectGuid>{069F4EDE-B6F6-4957-9CBD-385BC3F8DB07}</ProjectGuid> + <MainSource>paxcomp_Other.dpk</MainSource> + <Base>True</Base> + <Config Condition="'$(Config)'==''">Debug</Config> + <TargetedPlatforms>1053</TargetedPlatforms> + <AppType>Package</AppType> + <FrameworkType>None</FrameworkType> + <ProjectVersion>18.1</ProjectVersion> + <Platform Condition="'$(Platform)'==''">OSX32</Platform> + </PropertyGroup> + <PropertyGroup Condition="'$(Config)'=='Base' or '$(Base)'!=''"> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="('$(Platform)'=='Android' and '$(Base)'=='true') or '$(Base_Android)'!=''"> + <Base_Android>true</Base_Android> + <CfgParent>Base</CfgParent> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="('$(Platform)'=='iOSSimulator' and '$(Base)'=='true') or '$(Base_iOSSimulator)'!=''"> + <Base_iOSSimulator>true</Base_iOSSimulator> + <CfgParent>Base</CfgParent> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="('$(Platform)'=='OSX32' and '$(Base)'=='true') or '$(Base_OSX32)'!=''"> + <Base_OSX32>true</Base_OSX32> + <CfgParent>Base</CfgParent> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="('$(Platform)'=='Win32' and '$(Base)'=='true') or '$(Base_Win32)'!=''"> + <Base_Win32>true</Base_Win32> + <CfgParent>Base</CfgParent> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="'$(Config)'=='Release' or '$(Cfg_1)'!=''"> + <Cfg_1>true</Cfg_1> + <CfgParent>Base</CfgParent> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="'$(Config)'=='Debug' or '$(Cfg_2)'!=''"> + <Cfg_2>true</Cfg_2> + <CfgParent>Base</CfgParent> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="('$(Platform)'=='Android' and '$(Cfg_2)'=='true') or '$(Cfg_2_Android)'!=''"> + <Cfg_2_Android>true</Cfg_2_Android> + <CfgParent>Cfg_2</CfgParent> + <Cfg_2>true</Cfg_2> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="('$(Platform)'=='iOSDevice64' and '$(Cfg_2)'=='true') or '$(Cfg_2_iOSDevice64)'!=''"> + <Cfg_2_iOSDevice64>true</Cfg_2_iOSDevice64> + <CfgParent>Cfg_2</CfgParent> + <Cfg_2>true</Cfg_2> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="('$(Platform)'=='iOSSimulator' and '$(Cfg_2)'=='true') or '$(Cfg_2_iOSSimulator)'!=''"> + <Cfg_2_iOSSimulator>true</Cfg_2_iOSSimulator> + <CfgParent>Cfg_2</CfgParent> + <Cfg_2>true</Cfg_2> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="('$(Platform)'=='OSX32' and '$(Cfg_2)'=='true') or '$(Cfg_2_OSX32)'!=''"> + <Cfg_2_OSX32>true</Cfg_2_OSX32> + <CfgParent>Cfg_2</CfgParent> + <Cfg_2>true</Cfg_2> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="('$(Platform)'=='Win32' and '$(Cfg_2)'=='true') or '$(Cfg_2_Win32)'!=''"> + <Cfg_2_Win32>true</Cfg_2_Win32> + <CfgParent>Cfg_2</CfgParent> + <Cfg_2>true</Cfg_2> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="'$(Base)'!=''"> + <DCC_F>false</DCC_F> + <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=;CFBundleName=</VerInfo_Keys> + <DCC_ImageBase>00400000</DCC_ImageBase> + <DCC_K>false</DCC_K> + <GenDll>true</GenDll> + <VerInfo_Locale>2052</VerInfo_Locale> + <GenPackage>true</GenPackage> + <DCC_N>false</DCC_N> + <RuntimeOnlyPackage>true</RuntimeOnlyPackage> + <SanitizedProjectName>paxcomp_Other</SanitizedProjectName> + <DCC_DcuOutput>..\Lib\$(platform)</DCC_DcuOutput> + <DCC_Namespace>System;Xml;Data;Datasnap;Web;Soap;Winapi;System.Win;FMX;$(DCC_Namespace)</DCC_Namespace> + <DCC_S>false</DCC_S> + <DCC_E>false</DCC_E> + </PropertyGroup> + <PropertyGroup Condition="'$(Base_Android)'!=''"> + <EnabledSysJars>android-support-v4.dex.jar;apk-expansion.dex.jar;cloud-messaging.dex.jar;fmx.dex.jar;google-analytics-v2.dex.jar;google-play-billing.dex.jar;google-play-licensing.dex.jar;google-play-services.dex.jar</EnabledSysJars> + <BT_BuildType>Debug</BT_BuildType> + <VerInfo_Keys>package=com.embarcadero.$(MSBuildProjectName);label=$(MSBuildProjectName);versionCode=1;versionName=1.0.0;persistent=False;restoreAnyVersion=False;installLocation=auto;largeHeap=False;theme=TitleBar;hardwareAccelerated=true;apiKey=</VerInfo_Keys> + </PropertyGroup> + <PropertyGroup Condition="'$(Base_iOSSimulator)'!=''"> + <VerInfo_Keys>CFBundleName=$(MSBuildProjectName);CFBundleDevelopmentRegion=en;CFBundleDisplayName=$(MSBuildProjectName);CFBundleIdentifier=$(MSBuildProjectName);CFBundleInfoDictionaryVersion=7.1;CFBundleVersion=1.0.0.0;CFBundlePackageType=APPL;CFBundleSignature=????;LSRequiresIPhoneOS=true;CFBundleAllowMixedLocalizations=YES;CFBundleExecutable=$(MSBuildProjectName);UIDeviceFamily=iPhone & iPad;CFBundleResourceSpecification=ResourceRules.plist;NSLocationAlwaysUsageDescription=The reason for accessing the location information of the user;NSLocationWhenInUseUsageDescription=The reason for accessing the location information of the user;FMLocalNotificationPermission=false;UIBackgroundModes=</VerInfo_Keys> + <VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo> + <VerInfo_UIDeviceFamily>iPhoneAndiPad</VerInfo_UIDeviceFamily> + </PropertyGroup> + <PropertyGroup Condition="'$(Base_OSX32)'!=''"> + <BT_BuildType>Debug</BT_BuildType> + <VerInfo_Keys>CFBundleName=$(MSBuildProjectName);CFBundleDisplayName=$(MSBuildProjectName);CFBundleIdentifier=$(MSBuildProjectName);CFBundleVersion=1.0.0;CFBundlePackageType=APPL;CFBundleSignature=????;CFBundleAllowMixedLocalizations=YES;CFBundleExecutable=$(MSBuildProjectName);NSHighResolutionCapable=true;LSApplicationCategoryType=public.app-category.utilities;NSLocationAlwaysUsageDescription=The reason for accessing the location information of the user;NSLocationWhenInUseUsageDescription=The reason for accessing the location information of the user</VerInfo_Keys> + </PropertyGroup> + <PropertyGroup Condition="'$(Base_Win32)'!=''"> + <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=</VerInfo_Keys> + <VerInfo_Locale>1033</VerInfo_Locale> + <VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo> + <DCC_Namespace>Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace)</DCC_Namespace> + </PropertyGroup> + <PropertyGroup Condition="'$(Cfg_1)'!=''"> + <DCC_LocalDebugSymbols>false</DCC_LocalDebugSymbols> + <DCC_DebugInformation>0</DCC_DebugInformation> + <DCC_SymbolReferenceInfo>0</DCC_SymbolReferenceInfo> + <DCC_Define>RELEASE;$(DCC_Define)</DCC_Define> + </PropertyGroup> + <PropertyGroup Condition="'$(Cfg_2)'!=''"> + <DCC_GenerateStackFrames>true</DCC_GenerateStackFrames> + <DCC_Define>DEBUG;$(DCC_Define)</DCC_Define> + <DCC_Optimize>false</DCC_Optimize> + </PropertyGroup> + <PropertyGroup Condition="'$(Cfg_2_Android)'!=''"> + <VerInfo_Build>1</VerInfo_Build> + <VerInfo_Keys>package=com.embarcadero.$(MSBuildProjectName);label=$(MSBuildProjectName);versionCode=1;versionName=1.0.0;persistent=False;restoreAnyVersion=False;installLocation=auto;largeHeap=False;theme=TitleBar;hardwareAccelerated=true;apiKey=</VerInfo_Keys> + </PropertyGroup> + <PropertyGroup Condition="'$(Cfg_2_iOSDevice64)'!=''"> + <BT_BuildType>Debug</BT_BuildType> + </PropertyGroup> + <PropertyGroup Condition="'$(Cfg_2_iOSSimulator)'!=''"> + <DCC_RemoteDebug>true</DCC_RemoteDebug> + </PropertyGroup> + <PropertyGroup Condition="'$(Cfg_2_OSX32)'!=''"> + <DCC_RemoteDebug>true</DCC_RemoteDebug> + </PropertyGroup> + <PropertyGroup Condition="'$(Cfg_2_Win32)'!=''"> + <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=</VerInfo_Keys> + <VerInfo_Locale>1033</VerInfo_Locale> + <VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo> + <DllSuffix>230</DllSuffix> + </PropertyGroup> + <ItemGroup> + <DelphiCompile Include="$(MainSource)"> + <MainSource>MainSource</MainSource> + </DelphiCompile> + <DCCReference Include="PaxCompiler.dcr"/> + <DCCReference Include="rtl.dcp"/> + <DCCReference Include="PAXCOMP_2010.pas"/> + <DCCReference Include="PAXCOMP_2010REG.pas"/> + <DCCReference Include="PAXCOMP_ARM.pas"/> + <DCCReference Include="PAXCOMP_BASERUNNER.pas"/> + <DCCReference Include="PAXCOMP_BASESYMBOL_TABLE.pas"/> + <DCCReference Include="PAXCOMP_Basic.pas"/> + <DCCReference Include="PAXCOMP_BASIC_PARSER.pas"/> + <DCCReference Include="PAXCOMP_BASIC_SCANNER.pas"/> + <DCCReference Include="PAXCOMP_BRIDGE.pas"/> + <DCCReference Include="PAXCOMP_BYTECODE.pas"/> + <DCCReference Include="PAXCOMP_CLASSFACT.pas"/> + <DCCReference Include="PAXCOMP_CLASSLST.pas"/> + <DCCReference Include="PAXCOMP_CONSTANTS.pas"/> + <DCCReference Include="PAXCOMP_ERROR.pas"/> + <DCCReference Include="PAXCOMP_EVAL.pas"/> + <DCCReference Include="PAXCOMP_EXTRASYMBOL_TABLE.pas"/> + <DCCReference Include="PAXCOMP_FORBID.pas"/> + <DCCReference Include="PAXCOMP_FRAMEWORK.pas"/> + <DCCReference Include="PAXCOMP_GC.pas"/> + <DCCReference Include="PAXCOMP_GENERIC.pas"/> + <DCCReference Include="PAXCOMP_HEADER_PARSER.pas"/> + <DCCReference Include="PAXCOMP_INVOKE.pas"/> + <DCCReference Include="PAXCOMP_JavaScript.pas"/> + <DCCReference Include="PAXCOMP_JS_PARSER.pas"/> + <DCCReference Include="PAXCOMP_JS_SCANNER.pas"/> + <DCCReference Include="PAXCOMP_KERNEL.pas"/> + <DCCReference Include="PAXCOMP_LABEL_STACK.pas"/> + <DCCReference Include="PAXCOMP_LOCALSYMBOL_TABLE.pas"/> + <DCCReference Include="PAXCOMP_MAP.pas"/> + <DCCReference Include="PAXCOMP_MODULE.pas"/> + <DCCReference Include="PAXCOMP_OFFSET.pas"/> + <DCCReference Include="PAXCOMP_OLE.pas"/> + <DCCReference Include="PAXCOMP_PARSER.pas"/> + <DCCReference Include="PAXCOMP_PASCAL_PARSER.pas"/> + <DCCReference Include="PAXCOMP_PASCAL_SCANNER.pas"/> + <DCCReference Include="PAXCOMP_PCU.pas"/> + <DCCReference Include="PAXCOMP_PROGLIST.pas"/> + <DCCReference Include="PAXCOMP_RTI.pas"/> + <DCCReference Include="PAXCOMP_SCANNER.pas"/> + <DCCReference Include="PAXCOMP_STDLIB.pas"/> + <DCCReference Include="PAXCOMP_SYMBOL_REC.pas"/> + <DCCReference Include="PAXCOMP_SYMBOL_TABLE.pas"/> + <DCCReference Include="PAXCOMP_SYS.pas"/> + <DCCReference Include="PAXCOMP_TYPEINFO.pas"/> + <DCCReference Include="PAXCOMP_TYPES.pas"/> + <DCCReference Include="PAXCOMP_VAROBJECT.pas"/> + <DCCReference Include="PaxCompiler.pas"/> + <DCCReference Include="PaxCompilerDebugger.pas"/> + <DCCReference Include="PaxCompilerExplorer.pas"/> + <DCCReference Include="PaxDllImport.pas"/> + <DCCReference Include="PaxEval.pas"/> + <DCCReference Include="PaxInfos.pas"/> + <DCCReference Include="PAXINT_CALL.pas"/> + <DCCReference Include="PAXINT_CRT.pas"/> + <DCCReference Include="PAXINT_PROCS.pas"/> + <DCCReference Include="PAXINT_RUNNER.pas"/> + <DCCReference Include="PAXINT_SEH.pas"/> + <DCCReference Include="PAXINT_SYS.pas"/> + <DCCReference Include="PaxInterpreter.pas"/> + <DCCReference Include="PaxInvoke.pas"/> + <DCCReference Include="PaxJavaScriptLanguage.pas"/> + <DCCReference Include="PaxRegister.pas"/> + <DCCReference Include="PaxRunner.pas"/> + <DCCReference Include="RegExpr2.pas"/> + <DCCReference Include="PaxCompilerRegister.pas"/> + <BuildConfiguration Include="Debug"> + <Key>Cfg_2</Key> + <CfgParent>Base</CfgParent> + </BuildConfiguration> + <BuildConfiguration Include="Base"> + <Key>Base</Key> + </BuildConfiguration> + <BuildConfiguration Include="Release"> + <Key>Cfg_1</Key> + <CfgParent>Base</CfgParent> + </BuildConfiguration> + </ItemGroup> + <ProjectExtensions> + <Borland.Personality>Delphi.Personality.12</Borland.Personality> + <Borland.ProjectType>Package</Borland.ProjectType> + <BorlandProject> + <Delphi.Personality> + <Source> + <Source Name="MainSource">paxcomp_Other.dpk</Source> + </Source> + <Excluded_Packages> + <Excluded_Packages Name="$(BDSBIN)\dcloffice2k230.bpl">Microsoft Office 2000 Sample Automation Server Wrapper Components</Excluded_Packages> + <Excluded_Packages Name="$(BDSBIN)\dclofficexp230.bpl">Microsoft Office XP Sample Automation Server Wrapper Components</Excluded_Packages> + </Excluded_Packages> + </Delphi.Personality> + <Platforms> + <Platform value="Android">True</Platform> + <Platform value="iOSDevice32">False</Platform> + <Platform value="iOSDevice64">True</Platform> + <Platform value="iOSSimulator">True</Platform> + <Platform value="OSX32">True</Platform> + <Platform value="Win32">True</Platform> + <Platform value="Win64">False</Platform> + </Platforms> + <Deployment Version="2"> + <DeployFile LocalName="$(BDS)\Redist\osx32\libcgunwind.1.0.dylib" Class="DependencyModule"> + <Platform Name="OSX32"> + <Overwrite>true</Overwrite> + </Platform> + </DeployFile> + <DeployFile LocalName="$(BDS)\Redist\iossimulator\libcgunwind.1.0.dylib" Class="DependencyModule"> + <Platform Name="iOSSimulator"> + <Overwrite>true</Overwrite> + </Platform> + </DeployFile> + <DeployFile LocalName="$(BDS)\Redist\iossimulator\libPCRE.dylib" Class="DependencyModule"> + <Platform Name="iOSSimulator"> + <Overwrite>true</Overwrite> + </Platform> + </DeployFile> + <DeployClass Name="ProjectiOSDeviceResourceRules"/> + <DeployClass Name="ProjectOSXResource"> + <Platform Name="OSX32"> + <RemoteDir>Contents\Resources</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="AndroidClassesDexFile"> + <Platform Name="Android"> + <RemoteDir>classes</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="AdditionalDebugSymbols"> + <Platform Name="Win32"> + <RemoteDir>Contents\MacOS</RemoteDir> + <Operation>0</Operation> + </Platform> + <Platform Name="OSX32"> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="iPad_Launch768"> + <Platform Name="iOSSimulator"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice64"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice32"> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="Android_LauncherIcon144"> + <Platform Name="Android"> + <RemoteDir>res\drawable-xxhdpi</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="AndroidLibnativeMipsFile"> + <Platform Name="Android"> + <RemoteDir>library\lib\mips</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Required="true" Name="ProjectOutput"> + <Platform Name="Win32"> + <Operation>0</Operation> + </Platform> + <Platform Name="iOSDevice64"> + <Operation>1</Operation> + </Platform> + <Platform Name="OSX32"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice32"> + <Operation>1</Operation> + </Platform> + <Platform Name="Android"> + <RemoteDir>library\lib\armeabi-v7a</RemoteDir> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSSimulator"> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="DependencyFramework"> + <Platform Name="Win32"> + <Operation>0</Operation> + </Platform> + <Platform Name="OSX32"> + <Operation>1</Operation> + <Extensions>.framework</Extensions> + </Platform> + </DeployClass> + <DeployClass Name="iPhone_Launch640"> + <Platform Name="iOSSimulator"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice64"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice32"> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="iPad_Launch1024"> + <Platform Name="iOSSimulator"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice64"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice32"> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="ProjectiOSDeviceDebug"> + <Platform Name="iOSDevice64"> + <RemoteDir>..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF</RemoteDir> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice32"> + <RemoteDir>..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="AndroidLibnativeX86File"> + <Platform Name="Android"> + <RemoteDir>library\lib\x86</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="iPhone_Launch320"> + <Platform Name="iOSSimulator"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice64"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice32"> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="ProjectiOSInfoPList"/> + <DeployClass Name="AndroidLibnativeArmeabiFile"> + <Platform Name="Android"> + <RemoteDir>library\lib\armeabi</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="DebugSymbols"> + <Platform Name="Win32"> + <Operation>0</Operation> + </Platform> + <Platform Name="iOSSimulator"> + <Operation>1</Operation> + </Platform> + <Platform Name="OSX32"> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="iPad_Launch1536"> + <Platform Name="iOSSimulator"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice64"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice32"> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="Android_SplashImage470"> + <Platform Name="Android"> + <RemoteDir>res\drawable-normal</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="Android_LauncherIcon96"> + <Platform Name="Android"> + <RemoteDir>res\drawable-xhdpi</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="Android_SplashImage640"> + <Platform Name="Android"> + <RemoteDir>res\drawable-large</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="iPhone_Launch640x1136"> + <Platform Name="iOSSimulator"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice64"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice32"> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="ProjectiOSEntitlements"/> + <DeployClass Name="Android_LauncherIcon72"> + <Platform Name="Android"> + <RemoteDir>res\drawable-hdpi</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="AndroidGDBServer"> + <Platform Name="Android"> + <RemoteDir>library\lib\armeabi-v7a</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="ProjectOSXInfoPList"/> + <DeployClass Name="ProjectOSXEntitlements"/> + <DeployClass Name="iPad_Launch2048"> + <Platform Name="iOSSimulator"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice64"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice32"> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="AndroidSplashStyles"> + <Platform Name="Android"> + <RemoteDir>res\values</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="Android_SplashImage426"> + <Platform Name="Android"> + <RemoteDir>res\drawable-small</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="AndroidSplashImageDef"> + <Platform Name="Android"> + <RemoteDir>res\drawable</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="ProjectiOSResource"> + <Platform Name="iOSSimulator"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice64"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice32"> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="ProjectAndroidManifest"> + <Platform Name="Android"> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="Android_DefaultAppIcon"> + <Platform Name="Android"> + <RemoteDir>res\drawable</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="File"> + <Platform Name="Win32"> + <Operation>0</Operation> + </Platform> + <Platform Name="iOSDevice64"> + <Operation>0</Operation> + </Platform> + <Platform Name="OSX32"> + <Operation>0</Operation> + </Platform> + <Platform Name="iOSDevice32"> + <Operation>0</Operation> + </Platform> + <Platform Name="Android"> + <Operation>0</Operation> + </Platform> + <Platform Name="iOSSimulator"> + <Operation>0</Operation> + </Platform> + </DeployClass> + <DeployClass Name="AndroidServiceOutput"> + <Platform Name="Android"> + <RemoteDir>library\lib\armeabi-v7a</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Required="true" Name="DependencyPackage"> + <Platform Name="Win32"> + <Operation>0</Operation> + <Extensions>.bpl</Extensions> + </Platform> + <Platform Name="iOSDevice64"> + <Operation>1</Operation> + <Extensions>.dylib</Extensions> + </Platform> + <Platform Name="OSX32"> + <Operation>1</Operation> + <Extensions>.dylib</Extensions> + </Platform> + <Platform Name="iOSDevice32"> + <Operation>1</Operation> + <Extensions>.dylib</Extensions> + </Platform> + <Platform Name="iOSSimulator"> + <Operation>1</Operation> + <Extensions>.dylib</Extensions> + </Platform> + </DeployClass> + <DeployClass Name="Android_LauncherIcon48"> + <Platform Name="Android"> + <RemoteDir>res\drawable-mdpi</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="Android_SplashImage960"> + <Platform Name="Android"> + <RemoteDir>res\drawable-xlarge</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="Android_LauncherIcon36"> + <Platform Name="Android"> + <RemoteDir>res\drawable-ldpi</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="DependencyModule"> + <Platform Name="Win32"> + <Operation>0</Operation> + <Extensions>.dll;.bpl</Extensions> + </Platform> + <Platform Name="OSX32"> + <Operation>1</Operation> + <Extensions>.dylib</Extensions> + </Platform> + </DeployClass> + <ProjectRoot Platform="iOSDevice64" Name="$(PROJECTNAME).app"/> + <ProjectRoot Platform="Win64" Name="$(PROJECTNAME)"/> + <ProjectRoot Platform="iOSDevice32" Name="$(PROJECTNAME).app"/> + <ProjectRoot Platform="Win32" Name="$(PROJECTNAME)"/> + <ProjectRoot Platform="OSX32" Name="$(PROJECTNAME)"/> + <ProjectRoot Platform="Android" Name="$(PROJECTNAME)"/> + <ProjectRoot Platform="iOSSimulator" Name="$(PROJECTNAME).app"/> + </Deployment> + </BorlandProject> + <ProjectFileVersion>12</ProjectFileVersion> + </ProjectExtensions> + <Import Project="$(BDS)\Bin\CodeGear.Delphi.Targets" Condition="Exists('$(BDS)\Bin\CodeGear.Delphi.Targets')"/> + <Import Project="$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj" Condition="Exists('$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj')"/> + <Import Project="$(MSBuildProjectName).deployproj" Condition="Exists('$(MSBuildProjectName).deployproj')"/> +</Project> diff --git a/Sources/paxcomp_Other.res b/Sources/paxcomp_Other.res new file mode 100644 index 0000000..36f26e2 Binary files /dev/null and b/Sources/paxcomp_Other.res differ diff --git a/Sources/paxcomp_VCL.dpk b/Sources/paxcomp_VCL.dpk new file mode 100644 index 0000000..30d09d2 --- /dev/null +++ b/Sources/paxcomp_VCL.dpk @@ -0,0 +1,116 @@ +package paxcomp_VCL; + +{$R *.res} +{$R 'PaxCompiler.dcr'} +{$IFDEF IMPLICITBUILDING This IFDEF should not be used by users} +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO OFF} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS OFF} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO OFF} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$DEFINE RELEASE} +{$ENDIF IMPLICITBUILDING} +{$LIBSUFFIX AUTO} +{$RUNONLY} +{$IMPLICITBUILD OFF} + +requires + rtl, + vcl, + soaprtl; + +contains + PaxBasicLanguage in 'PaxBasicLanguage.pas', + PAXCOMP_2010 in 'PAXCOMP_2010.pas', + PAXCOMP_2010REG in 'PAXCOMP_2010REG.pas', + PAXCOMP_BASERUNNER in 'PAXCOMP_BASERUNNER.pas', + PAXCOMP_BASESYMBOL_TABLE in 'PAXCOMP_BASESYMBOL_TABLE.pas', + PAXCOMP_Basic in 'PAXCOMP_Basic.pas', + PAXCOMP_BASIC_PARSER in 'PAXCOMP_BASIC_PARSER.pas', + PAXCOMP_BASIC_SCANNER in 'PAXCOMP_BASIC_SCANNER.pas', + PAXCOMP_BRIDGE in 'PAXCOMP_BRIDGE.pas', + PAXCOMP_BYTECODE in 'PAXCOMP_BYTECODE.pas', + PAXCOMP_CLASSFACT in 'PAXCOMP_CLASSFACT.pas', + PAXCOMP_CLASSLST in 'PAXCOMP_CLASSLST.pas', + PAXCOMP_CONSTANTS in 'PAXCOMP_CONSTANTS.pas', + PAXCOMP_DISASM in 'PAXCOMP_DISASM.pas', + PAXCOMP_EMIT in 'PAXCOMP_EMIT.pas', + PAXCOMP_ERROR in 'PAXCOMP_ERROR.pas', + PAXCOMP_EVAL in 'PAXCOMP_EVAL.pas', + PAXCOMP_EVENT in 'PAXCOMP_EVENT.pas', + PAXCOMP_EXTRASYMBOL_TABLE in 'PAXCOMP_EXTRASYMBOL_TABLE.pas', + PAXCOMP_FORBID in 'PAXCOMP_FORBID.pas', + PAXCOMP_FRAMEWORK in 'PAXCOMP_FRAMEWORK.pas', + PAXCOMP_GC in 'PAXCOMP_GC.pas', + PAXCOMP_GENERIC in 'PAXCOMP_GENERIC.pas', + PAXCOMP_HEADER_PARSER in 'PAXCOMP_HEADER_PARSER.pas', + PAXCOMP_INVOKE in 'PAXCOMP_INVOKE.pas', + PAXCOMP_JavaScript in 'PAXCOMP_JavaScript.pas', + PAXCOMP_JS_PARSER in 'PAXCOMP_JS_PARSER.pas', + PAXCOMP_JS_SCANNER in 'PAXCOMP_JS_SCANNER.pas', + PAXCOMP_KERNEL in 'PAXCOMP_KERNEL.pas', + PAXCOMP_LABEL_STACK in 'PAXCOMP_LABEL_STACK.pas', + PAXCOMP_LOCALSYMBOL_TABLE in 'PAXCOMP_LOCALSYMBOL_TABLE.pas', + PAXCOMP_MAP in 'PAXCOMP_MAP.pas', + PAXCOMP_MASKS in 'PAXCOMP_MASKS.pas', + PAXCOMP_MODULE in 'PAXCOMP_MODULE.pas', + PAXCOMP_OFFSET in 'PAXCOMP_OFFSET.pas', + PAXCOMP_OLE in 'PAXCOMP_OLE.pas', + PAXCOMP_PARSER in 'PAXCOMP_PARSER.pas', + PAXCOMP_PASCAL_PARSER in 'PAXCOMP_PASCAL_PARSER.pas', + PAXCOMP_PASCAL_SCANNER in 'PAXCOMP_PASCAL_SCANNER.pas', + PAXCOMP_PAUSE in 'PAXCOMP_PAUSE.pas', + PAXCOMP_PCU in 'PAXCOMP_PCU.pas', + PAXCOMP_PROG in 'PAXCOMP_PROG.pas', + PAXCOMP_PROGLIB in 'PAXCOMP_PROGLIB.pas', + PAXCOMP_PROGLIST in 'PAXCOMP_PROGLIST.pas', + PAXCOMP_RTI in 'PAXCOMP_RTI.pas', + PAXCOMP_SCANNER in 'PAXCOMP_SCANNER.pas', + PAXCOMP_SEH in 'PAXCOMP_SEH.pas', + PAXCOMP_STDLIB in 'PAXCOMP_STDLIB.pas', + PAXCOMP_SYMBOL_PROGRAM in 'PAXCOMP_SYMBOL_PROGRAM.pas', + PAXCOMP_SYMBOL_REC in 'PAXCOMP_SYMBOL_REC.pas', + PAXCOMP_SYMBOL_TABLE in 'PAXCOMP_SYMBOL_TABLE.pas', + PAXCOMP_SYS in 'PAXCOMP_SYS.pas', + PAXCOMP_TRYLST in 'PAXCOMP_TRYLST.pas', + PAXCOMP_TYPEINFO in 'PAXCOMP_TYPEINFO.pas', + PAXCOMP_TYPES in 'PAXCOMP_TYPES.pas', + PAXCOMP_VAROBJECT in 'PAXCOMP_VAROBJECT.pas', + PaxCompiler in 'PaxCompiler.pas', + PaxCompilerDebugger in 'PaxCompilerDebugger.pas', + PaxCompilerExplorer in 'PaxCompilerExplorer.pas', + PaxDllImport in 'PaxDllImport.pas', + PaxEval in 'PaxEval.pas', + PaxInfos in 'PaxInfos.pas', + PAXINT_CALL in 'PAXINT_CALL.pas', + PAXINT_CRT in 'PAXINT_CRT.pas', + PAXINT_PROCS in 'PAXINT_PROCS.pas', + PAXINT_RUNNER in 'PAXINT_RUNNER.pas', + PAXINT_SEH in 'PAXINT_SEH.pas', + PAXINT_SYS in 'PAXINT_SYS.pas', + PaxInterpreter in 'PaxInterpreter.pas', + PaxInvoke in 'PaxInvoke.pas', + PaxJavaScriptLanguage in 'PaxJavaScriptLanguage.pas', + PaxProgram in 'PaxProgram.pas', + PaxRegister in 'PaxRegister.pas', + PaxRunner in 'PaxRunner.pas', + RegExpr2 in 'RegExpr2.pas' {$IFDEF MSWINDOWS}, + PaxCompilerRegister in 'PaxCompilerRegister.pas' {$ENDIF}; + +end. diff --git a/Sources/paxcomp_VCL.dproj b/Sources/paxcomp_VCL.dproj new file mode 100644 index 0000000..5034ad2 --- /dev/null +++ b/Sources/paxcomp_VCL.dproj @@ -0,0 +1,1093 @@ +<Project xmlns="http://schemas.microsoft.com/developer/msbuild/2003"> + <PropertyGroup> + <ProjectGuid>{8A97AB77-0420-4C83-9EAD-D9AE8DC1319C}</ProjectGuid> + <MainSource>paxcomp_VCL.dpk</MainSource> + <Base>True</Base> + <Config Condition="'$(Config)'==''">Release</Config> + <TargetedPlatforms>3</TargetedPlatforms> + <AppType>Package</AppType> + <FrameworkType>VCL</FrameworkType> + <ProjectVersion>20.1</ProjectVersion> + <Platform Condition="'$(Platform)'==''">Win64</Platform> + </PropertyGroup> + <PropertyGroup Condition="'$(Config)'=='Base' or '$(Base)'!=''"> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="('$(Platform)'=='Win32' and '$(Base)'=='true') or '$(Base_Win32)'!=''"> + <Base_Win32>true</Base_Win32> + <CfgParent>Base</CfgParent> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="('$(Platform)'=='Win64' and '$(Base)'=='true') or '$(Base_Win64)'!=''"> + <Base_Win64>true</Base_Win64> + <CfgParent>Base</CfgParent> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="'$(Config)'=='Release' or '$(Cfg_1)'!=''"> + <Cfg_1>true</Cfg_1> + <CfgParent>Base</CfgParent> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="('$(Platform)'=='Win32' and '$(Cfg_1)'=='true') or '$(Cfg_1_Win32)'!=''"> + <Cfg_1_Win32>true</Cfg_1_Win32> + <CfgParent>Cfg_1</CfgParent> + <Cfg_1>true</Cfg_1> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="('$(Platform)'=='Win64' and '$(Cfg_1)'=='true') or '$(Cfg_1_Win64)'!=''"> + <Cfg_1_Win64>true</Cfg_1_Win64> + <CfgParent>Cfg_1</CfgParent> + <Cfg_1>true</Cfg_1> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="'$(Config)'=='Debug' or '$(Cfg_2)'!=''"> + <Cfg_2>true</Cfg_2> + <CfgParent>Base</CfgParent> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="('$(Platform)'=='Win32' and '$(Cfg_2)'=='true') or '$(Cfg_2_Win32)'!=''"> + <Cfg_2_Win32>true</Cfg_2_Win32> + <CfgParent>Cfg_2</CfgParent> + <Cfg_2>true</Cfg_2> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="'$(Base)'!=''"> + <DCC_DcuOutput>.\$(Platform)\$(Config)</DCC_DcuOutput> + <DCC_F>false</DCC_F> + <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=;CFBundleName=</VerInfo_Keys> + <DCC_ImageBase>00400000</DCC_ImageBase> + <DCC_K>false</DCC_K> + <GenDll>true</GenDll> + <VerInfo_Locale>2052</VerInfo_Locale> + <GenPackage>true</GenPackage> + <DCC_E>false</DCC_E> + <DCC_N>false</DCC_N> + <SanitizedProjectName>paxcomp_VCL</SanitizedProjectName> + <DCC_S>false</DCC_S> + <DllSuffix>230</DllSuffix> + <DCC_Namespace>Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;System;Xml;Data;Datasnap;Web;Soap;Winapi;System.Win;$(DCC_Namespace)</DCC_Namespace> + <DCC_OutputNeverBuildDcps>true</DCC_OutputNeverBuildDcps> + <RuntimeOnlyPackage>true</RuntimeOnlyPackage> + <DCC_BplOutput>.\$(Platform)\$(Config)</DCC_BplOutput> + </PropertyGroup> + <PropertyGroup Condition="'$(Base_Win32)'!=''"> + <DCC_UsePackage>rtl;vcl;soaprtl;$(DCC_UsePackage)</DCC_UsePackage> + <VerInfo_Keys>CompanyName=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(MSBuildProjectName);FileDescription=$(MSBuildProjectName);ProductName=$(MSBuildProjectName)</VerInfo_Keys> + <VerInfo_Locale>1033</VerInfo_Locale> + <VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo> + <DCC_Namespace>Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace)</DCC_Namespace> + </PropertyGroup> + <PropertyGroup Condition="'$(Base_Win64)'!=''"> + <VerInfo_Keys>CompanyName=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(MSBuildProjectName);FileDescription=$(MSBuildProjectName);ProductName=$(MSBuildProjectName)</VerInfo_Keys> + <VerInfo_Locale>1033</VerInfo_Locale> + <DCC_Namespace>Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;$(DCC_Namespace)</DCC_Namespace> + <DCC_UsePackage>rtl;vcl;soaprtl;$(DCC_UsePackage)</DCC_UsePackage> + <VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo> + </PropertyGroup> + <PropertyGroup Condition="'$(Cfg_1)'!=''"> + <DCC_LocalDebugSymbols>false</DCC_LocalDebugSymbols> + <DCC_DebugInformation>0</DCC_DebugInformation> + <DCC_SymbolReferenceInfo>0</DCC_SymbolReferenceInfo> + <DCC_Define>RELEASE;$(DCC_Define)</DCC_Define> + </PropertyGroup> + <PropertyGroup Condition="'$(Cfg_1_Win32)'!=''"> + <VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo> + <VerInfo_Locale>1033</VerInfo_Locale> + <VerInfo_Keys>CompanyName=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(MSBuildProjectName);FileDescription=$(MSBuildProjectName);ProductName=$(MSBuildProjectName)</VerInfo_Keys> + <DllSuffix>$(Auto)</DllSuffix> + </PropertyGroup> + <PropertyGroup Condition="'$(Cfg_1_Win64)'!=''"> + <VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo> + <VerInfo_Locale>1033</VerInfo_Locale> + <VerInfo_Keys>CompanyName=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(MSBuildProjectName);FileDescription=$(MSBuildProjectName);ProductName=$(MSBuildProjectName)</VerInfo_Keys> + <DllSuffix>$(Auto)</DllSuffix> + </PropertyGroup> + <PropertyGroup Condition="'$(Cfg_2)'!=''"> + <DCC_GenerateStackFrames>true</DCC_GenerateStackFrames> + <DCC_Define>DEBUG;$(DCC_Define)</DCC_Define> + <DCC_Optimize>false</DCC_Optimize> + </PropertyGroup> + <PropertyGroup Condition="'$(Cfg_2_Win32)'!=''"> + <DCC_Description>paxCompiler 4.2</DCC_Description> + <VerInfo_Locale>1033</VerInfo_Locale> + <VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo> + <VerInfo_Keys>CompanyName=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(MSBuildProjectName);FileDescription=$(MSBuildProjectName);ProductName=$(MSBuildProjectName)</VerInfo_Keys> + <DllSuffix>$(Auto)</DllSuffix> + <DCC_DcuOutput>.\$(Platform)\$(Config)</DCC_DcuOutput> + <DCC_BplOutput>.\$(Platform)\$(Config)</DCC_BplOutput> + </PropertyGroup> + <ItemGroup> + <DelphiCompile Include="$(MainSource)"> + <MainSource>MainSource</MainSource> + </DelphiCompile> + <DCCReference Include="PaxCompiler.dcr"/> + <DCCReference Include="rtl.dcp"/> + <DCCReference Include="vcl.dcp"/> + <DCCReference Include="soaprtl.dcp"/> + <DCCReference Include="PaxBasicLanguage.pas"/> + <DCCReference Include="PAXCOMP_2010.pas"/> + <DCCReference Include="PAXCOMP_2010REG.pas"/> + <DCCReference Include="PAXCOMP_BASERUNNER.pas"/> + <DCCReference Include="PAXCOMP_BASESYMBOL_TABLE.pas"/> + <DCCReference Include="PAXCOMP_Basic.pas"/> + <DCCReference Include="PAXCOMP_BASIC_PARSER.pas"/> + <DCCReference Include="PAXCOMP_BASIC_SCANNER.pas"/> + <DCCReference Include="PAXCOMP_BRIDGE.pas"/> + <DCCReference Include="PAXCOMP_BYTECODE.pas"/> + <DCCReference Include="PAXCOMP_CLASSFACT.pas"/> + <DCCReference Include="PAXCOMP_CLASSLST.pas"/> + <DCCReference Include="PAXCOMP_CONSTANTS.pas"/> + <DCCReference Include="PAXCOMP_DISASM.pas"/> + <DCCReference Include="PAXCOMP_EMIT.pas"/> + <DCCReference Include="PAXCOMP_ERROR.pas"/> + <DCCReference Include="PAXCOMP_EVAL.pas"/> + <DCCReference Include="PAXCOMP_EVENT.pas"/> + <DCCReference Include="PAXCOMP_EXTRASYMBOL_TABLE.pas"/> + <DCCReference Include="PAXCOMP_FORBID.pas"/> + <DCCReference Include="PAXCOMP_FRAMEWORK.pas"/> + <DCCReference Include="PAXCOMP_GC.pas"/> + <DCCReference Include="PAXCOMP_GENERIC.pas"/> + <DCCReference Include="PAXCOMP_HEADER_PARSER.pas"/> + <DCCReference Include="PAXCOMP_INVOKE.pas"/> + <DCCReference Include="PAXCOMP_JavaScript.pas"/> + <DCCReference Include="PAXCOMP_JS_PARSER.pas"/> + <DCCReference Include="PAXCOMP_JS_SCANNER.pas"/> + <DCCReference Include="PAXCOMP_KERNEL.pas"/> + <DCCReference Include="PAXCOMP_LABEL_STACK.pas"/> + <DCCReference Include="PAXCOMP_LOCALSYMBOL_TABLE.pas"/> + <DCCReference Include="PAXCOMP_MAP.pas"/> + <DCCReference Include="PAXCOMP_MASKS.pas"/> + <DCCReference Include="PAXCOMP_MODULE.pas"/> + <DCCReference Include="PAXCOMP_OFFSET.pas"/> + <DCCReference Include="PAXCOMP_OLE.pas"/> + <DCCReference Include="PAXCOMP_PARSER.pas"/> + <DCCReference Include="PAXCOMP_PASCAL_PARSER.pas"/> + <DCCReference Include="PAXCOMP_PASCAL_SCANNER.pas"/> + <DCCReference Include="PAXCOMP_PAUSE.pas"/> + <DCCReference Include="PAXCOMP_PCU.pas"/> + <DCCReference Include="PAXCOMP_PROG.pas"/> + <DCCReference Include="PAXCOMP_PROGLIB.pas"/> + <DCCReference Include="PAXCOMP_PROGLIST.pas"/> + <DCCReference Include="PAXCOMP_RTI.pas"/> + <DCCReference Include="PAXCOMP_SCANNER.pas"/> + <DCCReference Include="PAXCOMP_SEH.pas"/> + <DCCReference Include="PAXCOMP_STDLIB.pas"/> + <DCCReference Include="PAXCOMP_SYMBOL_PROGRAM.pas"/> + <DCCReference Include="PAXCOMP_SYMBOL_REC.pas"/> + <DCCReference Include="PAXCOMP_SYMBOL_TABLE.pas"/> + <DCCReference Include="PAXCOMP_SYS.pas"/> + <DCCReference Include="PAXCOMP_TRYLST.pas"/> + <DCCReference Include="PAXCOMP_TYPEINFO.pas"/> + <DCCReference Include="PAXCOMP_TYPES.pas"/> + <DCCReference Include="PAXCOMP_VAROBJECT.pas"/> + <DCCReference Include="PaxCompiler.pas"/> + <DCCReference Include="PaxCompilerDebugger.pas"/> + <DCCReference Include="PaxCompilerExplorer.pas"/> + <DCCReference Include="PaxDllImport.pas"/> + <DCCReference Include="PaxEval.pas"/> + <DCCReference Include="PaxInfos.pas"/> + <DCCReference Include="PAXINT_CALL.pas"/> + <DCCReference Include="PAXINT_CRT.pas"/> + <DCCReference Include="PAXINT_PROCS.pas"/> + <DCCReference Include="PAXINT_RUNNER.pas"/> + <DCCReference Include="PAXINT_SEH.pas"/> + <DCCReference Include="PAXINT_SYS.pas"/> + <DCCReference Include="PaxInterpreter.pas"/> + <DCCReference Include="PaxInvoke.pas"/> + <DCCReference Include="PaxJavaScriptLanguage.pas"/> + <DCCReference Include="PaxProgram.pas"/> + <DCCReference Include="PaxRegister.pas"/> + <DCCReference Include="PaxRunner.pas"/> + <DCCReference Include="RegExpr2.pas"> + <Form>$IFDEF MSWINDOWS</Form> + </DCCReference> + <DCCReference Include="PaxCompilerRegister.pas"> + <Form>$ENDIF</Form> + </DCCReference> + <BuildConfiguration Include="Base"> + <Key>Base</Key> + </BuildConfiguration> + <BuildConfiguration Include="Release"> + <Key>Cfg_1</Key> + <CfgParent>Base</CfgParent> + </BuildConfiguration> + <BuildConfiguration Include="Debug"> + <Key>Cfg_2</Key> + <CfgParent>Base</CfgParent> + </BuildConfiguration> + </ItemGroup> + <ProjectExtensions> + <Borland.Personality>Delphi.Personality.12</Borland.Personality> + <Borland.ProjectType>Package</Borland.ProjectType> + <BorlandProject> + <Delphi.Personality> + <Source> + <Source Name="MainSource">paxcomp_VCL.dpk</Source> + </Source> + <Excluded_Packages> + <Excluded_Packages Name="$(BDSBIN)\dcloffice2k290.bpl">Microsoft Office 2000 Sample Automation Server Wrapper Components</Excluded_Packages> + <Excluded_Packages Name="$(BDSBIN)\dclofficexp290.bpl">Microsoft Office XP Sample Automation Server Wrapper Components</Excluded_Packages> + </Excluded_Packages> + </Delphi.Personality> + <Platforms> + <Platform value="Win32">True</Platform> + <Platform value="Win64">True</Platform> + </Platforms> + <Deployment Version="4"> + <DeployFile LocalName="C:\Users\Public\Documents\Embarcadero\Studio\17.0\Bpl\paxcomp_VCL230.bpl" Configuration="Debug" Class="ProjectOutput"/> + <DeployClass Name="AdditionalDebugSymbols"> + <Platform Name="OSX32"> + <Operation>1</Operation> + </Platform> + <Platform Name="Win32"> + <Operation>0</Operation> + </Platform> + </DeployClass> + <DeployClass Name="AndroidClasses"> + <Platform Name="Android"> + <RemoteDir>classes</RemoteDir> + <Operation>64</Operation> + </Platform> + <Platform Name="Android64"> + <RemoteDir>classes</RemoteDir> + <Operation>64</Operation> + </Platform> + </DeployClass> + <DeployClass Name="AndroidFileProvider"> + <Platform Name="Android"> + <RemoteDir>res\xml</RemoteDir> + <Operation>1</Operation> + </Platform> + <Platform Name="Android64"> + <RemoteDir>res\xml</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="AndroidLibnativeArmeabiFile"> + <Platform Name="Android"> + <RemoteDir>library\lib\armeabi</RemoteDir> + <Operation>1</Operation> + </Platform> + <Platform Name="Android64"> + <RemoteDir>library\lib\armeabi</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="AndroidLibnativeArmeabiv7aFile"> + <Platform Name="Android64"> + <RemoteDir>library\lib\armeabi-v7a</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="AndroidLibnativeMipsFile"> + <Platform Name="Android"> + <RemoteDir>library\lib\mips</RemoteDir> + <Operation>1</Operation> + </Platform> + <Platform Name="Android64"> + <RemoteDir>library\lib\mips</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="AndroidServiceOutput"> + <Platform Name="Android"> + <RemoteDir>library\lib\armeabi-v7a</RemoteDir> + <Operation>1</Operation> + </Platform> + <Platform Name="Android64"> + <RemoteDir>library\lib\arm64-v8a</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="AndroidServiceOutput_Android32"> + <Platform Name="Android64"> + <RemoteDir>library\lib\armeabi-v7a</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="AndroidSplashImageDef"> + <Platform Name="Android"> + <RemoteDir>res\drawable</RemoteDir> + <Operation>1</Operation> + </Platform> + <Platform Name="Android64"> + <RemoteDir>res\drawable</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="AndroidSplashImageDefV21"> + <Platform Name="Android"> + <RemoteDir>res\drawable-anydpi-v21</RemoteDir> + <Operation>1</Operation> + </Platform> + <Platform Name="Android64"> + <RemoteDir>res\drawable-anydpi-v21</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="AndroidSplashStyles"> + <Platform Name="Android"> + <RemoteDir>res\values</RemoteDir> + <Operation>1</Operation> + </Platform> + <Platform Name="Android64"> + <RemoteDir>res\values</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="AndroidSplashStylesV21"> + <Platform Name="Android"> + <RemoteDir>res\values-v21</RemoteDir> + <Operation>1</Operation> + </Platform> + <Platform Name="Android64"> + <RemoteDir>res\values-v21</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="AndroidSplashStylesV31"> + <Platform Name="Android"> + <RemoteDir>res\values-v31</RemoteDir> + <Operation>1</Operation> + </Platform> + <Platform Name="Android64"> + <RemoteDir>res\values-v31</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="Android_AdaptiveIcon"> + <Platform Name="Android"> + <RemoteDir>res\drawable-anydpi-v26</RemoteDir> + <Operation>1</Operation> + </Platform> + <Platform Name="Android64"> + <RemoteDir>res\drawable-anydpi-v26</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="Android_AdaptiveIconBackground"> + <Platform Name="Android"> + <RemoteDir>res\drawable</RemoteDir> + <Operation>1</Operation> + </Platform> + <Platform Name="Android64"> + <RemoteDir>res\drawable</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="Android_AdaptiveIconForeground"> + <Platform Name="Android"> + <RemoteDir>res\drawable</RemoteDir> + <Operation>1</Operation> + </Platform> + <Platform Name="Android64"> + <RemoteDir>res\drawable</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="Android_AdaptiveIconMonochrome"> + <Platform Name="Android"> + <RemoteDir>res\drawable</RemoteDir> + <Operation>1</Operation> + </Platform> + <Platform Name="Android64"> + <RemoteDir>res\drawable</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="Android_AdaptiveIconV33"> + <Platform Name="Android"> + <RemoteDir>res\drawable-anydpi-v33</RemoteDir> + <Operation>1</Operation> + </Platform> + <Platform Name="Android64"> + <RemoteDir>res\drawable-anydpi-v33</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="Android_Colors"> + <Platform Name="Android"> + <RemoteDir>res\values</RemoteDir> + <Operation>1</Operation> + </Platform> + <Platform Name="Android64"> + <RemoteDir>res\values</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="Android_ColorsDark"> + <Platform Name="Android"> + <RemoteDir>res\values-night-v21</RemoteDir> + <Operation>1</Operation> + </Platform> + <Platform Name="Android64"> + <RemoteDir>res\values-night-v21</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="Android_DefaultAppIcon"> + <Platform Name="Android"> + <RemoteDir>res\drawable</RemoteDir> + <Operation>1</Operation> + </Platform> + <Platform Name="Android64"> + <RemoteDir>res\drawable</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="Android_LauncherIcon144"> + <Platform Name="Android"> + <RemoteDir>res\drawable-xxhdpi</RemoteDir> + <Operation>1</Operation> + </Platform> + <Platform Name="Android64"> + <RemoteDir>res\drawable-xxhdpi</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="Android_LauncherIcon192"> + <Platform Name="Android"> + <RemoteDir>res\drawable-xxxhdpi</RemoteDir> + <Operation>1</Operation> + </Platform> + <Platform Name="Android64"> + <RemoteDir>res\drawable-xxxhdpi</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="Android_LauncherIcon36"> + <Platform Name="Android"> + <RemoteDir>res\drawable-ldpi</RemoteDir> + <Operation>1</Operation> + </Platform> + <Platform Name="Android64"> + <RemoteDir>res\drawable-ldpi</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="Android_LauncherIcon48"> + <Platform Name="Android"> + <RemoteDir>res\drawable-mdpi</RemoteDir> + <Operation>1</Operation> + </Platform> + <Platform Name="Android64"> + <RemoteDir>res\drawable-mdpi</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="Android_LauncherIcon72"> + <Platform Name="Android"> + <RemoteDir>res\drawable-hdpi</RemoteDir> + <Operation>1</Operation> + </Platform> + <Platform Name="Android64"> + <RemoteDir>res\drawable-hdpi</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="Android_LauncherIcon96"> + <Platform Name="Android"> + <RemoteDir>res\drawable-xhdpi</RemoteDir> + <Operation>1</Operation> + </Platform> + <Platform Name="Android64"> + <RemoteDir>res\drawable-xhdpi</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="Android_NotificationIcon24"> + <Platform Name="Android"> + <RemoteDir>res\drawable-mdpi</RemoteDir> + <Operation>1</Operation> + </Platform> + <Platform Name="Android64"> + <RemoteDir>res\drawable-mdpi</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="Android_NotificationIcon36"> + <Platform Name="Android"> + <RemoteDir>res\drawable-hdpi</RemoteDir> + <Operation>1</Operation> + </Platform> + <Platform Name="Android64"> + <RemoteDir>res\drawable-hdpi</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="Android_NotificationIcon48"> + <Platform Name="Android"> + <RemoteDir>res\drawable-xhdpi</RemoteDir> + <Operation>1</Operation> + </Platform> + <Platform Name="Android64"> + <RemoteDir>res\drawable-xhdpi</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="Android_NotificationIcon72"> + <Platform Name="Android"> + <RemoteDir>res\drawable-xxhdpi</RemoteDir> + <Operation>1</Operation> + </Platform> + <Platform Name="Android64"> + <RemoteDir>res\drawable-xxhdpi</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="Android_NotificationIcon96"> + <Platform Name="Android"> + <RemoteDir>res\drawable-xxxhdpi</RemoteDir> + <Operation>1</Operation> + </Platform> + <Platform Name="Android64"> + <RemoteDir>res\drawable-xxxhdpi</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="Android_SplashImage426"> + <Platform Name="Android"> + <RemoteDir>res\drawable-small</RemoteDir> + <Operation>1</Operation> + </Platform> + <Platform Name="Android64"> + <RemoteDir>res\drawable-small</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="Android_SplashImage470"> + <Platform Name="Android"> + <RemoteDir>res\drawable-normal</RemoteDir> + <Operation>1</Operation> + </Platform> + <Platform Name="Android64"> + <RemoteDir>res\drawable-normal</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="Android_SplashImage640"> + <Platform Name="Android"> + <RemoteDir>res\drawable-large</RemoteDir> + <Operation>1</Operation> + </Platform> + <Platform Name="Android64"> + <RemoteDir>res\drawable-large</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="Android_SplashImage960"> + <Platform Name="Android"> + <RemoteDir>res\drawable-xlarge</RemoteDir> + <Operation>1</Operation> + </Platform> + <Platform Name="Android64"> + <RemoteDir>res\drawable-xlarge</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="Android_Strings"> + <Platform Name="Android"> + <RemoteDir>res\values</RemoteDir> + <Operation>1</Operation> + </Platform> + <Platform Name="Android64"> + <RemoteDir>res\values</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="Android_VectorizedNotificationIcon"> + <Platform Name="Android"> + <RemoteDir>res\drawable-anydpi-v24</RemoteDir> + <Operation>1</Operation> + </Platform> + <Platform Name="Android64"> + <RemoteDir>res\drawable-anydpi-v24</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="Android_VectorizedSplash"> + <Platform Name="Android"> + <RemoteDir>res\drawable</RemoteDir> + <Operation>1</Operation> + </Platform> + <Platform Name="Android64"> + <RemoteDir>res\drawable</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="Android_VectorizedSplashDark"> + <Platform Name="Android"> + <RemoteDir>res\drawable-night-anydpi-v21</RemoteDir> + <Operation>1</Operation> + </Platform> + <Platform Name="Android64"> + <RemoteDir>res\drawable-night-anydpi-v21</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="Android_VectorizedSplashV31"> + <Platform Name="Android"> + <RemoteDir>res\drawable-anydpi-v31</RemoteDir> + <Operation>1</Operation> + </Platform> + <Platform Name="Android64"> + <RemoteDir>res\drawable-anydpi-v31</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="Android_VectorizedSplashV31Dark"> + <Platform Name="Android"> + <RemoteDir>res\drawable-night-anydpi-v31</RemoteDir> + <Operation>1</Operation> + </Platform> + <Platform Name="Android64"> + <RemoteDir>res\drawable-night-anydpi-v31</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="DebugSymbols"> + <Platform Name="iOSSimulator"> + <Operation>1</Operation> + </Platform> + <Platform Name="OSX32"> + <Operation>1</Operation> + </Platform> + <Platform Name="Win32"> + <Operation>0</Operation> + </Platform> + </DeployClass> + <DeployClass Name="DependencyFramework"> + <Platform Name="OSX32"> + <Operation>1</Operation> + <Extensions>.framework</Extensions> + </Platform> + <Platform Name="OSX64"> + <Operation>1</Operation> + <Extensions>.framework</Extensions> + </Platform> + <Platform Name="OSXARM64"> + <Operation>1</Operation> + <Extensions>.framework</Extensions> + </Platform> + <Platform Name="Win32"> + <Operation>0</Operation> + </Platform> + </DeployClass> + <DeployClass Name="DependencyModule"> + <Platform Name="OSX32"> + <Operation>1</Operation> + <Extensions>.dylib</Extensions> + </Platform> + <Platform Name="OSX64"> + <Operation>1</Operation> + <Extensions>.dylib</Extensions> + </Platform> + <Platform Name="OSXARM64"> + <Operation>1</Operation> + <Extensions>.dylib</Extensions> + </Platform> + <Platform Name="Win32"> + <Operation>0</Operation> + <Extensions>.dll;.bpl</Extensions> + </Platform> + </DeployClass> + <DeployClass Required="true" Name="DependencyPackage"> + <Platform Name="iOSDevice32"> + <Operation>1</Operation> + <Extensions>.dylib</Extensions> + </Platform> + <Platform Name="iOSDevice64"> + <Operation>1</Operation> + <Extensions>.dylib</Extensions> + </Platform> + <Platform Name="iOSSimARM64"> + <Operation>1</Operation> + <Extensions>.dylib</Extensions> + </Platform> + <Platform Name="OSX32"> + <Operation>1</Operation> + <Extensions>.dylib</Extensions> + </Platform> + <Platform Name="OSX64"> + <Operation>1</Operation> + <Extensions>.dylib</Extensions> + </Platform> + <Platform Name="OSXARM64"> + <Operation>1</Operation> + <Extensions>.dylib</Extensions> + </Platform> + <Platform Name="Win32"> + <Operation>0</Operation> + <Extensions>.bpl</Extensions> + </Platform> + </DeployClass> + <DeployClass Name="File"> + <Platform Name="Android"> + <Operation>0</Operation> + </Platform> + <Platform Name="Android64"> + <Operation>0</Operation> + </Platform> + <Platform Name="iOSDevice32"> + <Operation>0</Operation> + </Platform> + <Platform Name="iOSDevice64"> + <Operation>0</Operation> + </Platform> + <Platform Name="iOSSimARM64"> + <Operation>0</Operation> + </Platform> + <Platform Name="OSX32"> + <Operation>0</Operation> + </Platform> + <Platform Name="OSX64"> + <Operation>0</Operation> + </Platform> + <Platform Name="OSXARM64"> + <Operation>0</Operation> + </Platform> + <Platform Name="Win32"> + <Operation>0</Operation> + </Platform> + </DeployClass> + <DeployClass Name="ProjectAndroidManifest"> + <Platform Name="Android"> + <Operation>1</Operation> + </Platform> + <Platform Name="Android64"> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="ProjectOSXDebug"/> + <DeployClass Name="ProjectOSXEntitlements"/> + <DeployClass Name="ProjectOSXInfoPList"/> + <DeployClass Name="ProjectOSXResource"> + <Platform Name="OSX32"> + <RemoteDir>Contents\Resources</RemoteDir> + <Operation>1</Operation> + </Platform> + <Platform Name="OSX64"> + <RemoteDir>Contents\Resources</RemoteDir> + <Operation>1</Operation> + </Platform> + <Platform Name="OSXARM64"> + <RemoteDir>Contents\Resources</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Required="true" Name="ProjectOutput"> + <Platform Name="Android"> + <RemoteDir>library\lib\armeabi-v7a</RemoteDir> + <Operation>1</Operation> + </Platform> + <Platform Name="Android64"> + <RemoteDir>library\lib\arm64-v8a</RemoteDir> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice32"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice64"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSSimARM64"> + <Operation>1</Operation> + </Platform> + <Platform Name="Linux64"> + <Operation>1</Operation> + </Platform> + <Platform Name="OSX32"> + <Operation>1</Operation> + </Platform> + <Platform Name="OSX64"> + <Operation>1</Operation> + </Platform> + <Platform Name="OSXARM64"> + <Operation>1</Operation> + </Platform> + <Platform Name="Win32"> + <Operation>0</Operation> + </Platform> + </DeployClass> + <DeployClass Name="ProjectOutput_Android32"> + <Platform Name="Android64"> + <RemoteDir>library\lib\armeabi-v7a</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="ProjectUWPManifest"> + <Platform Name="Win32"> + <Operation>1</Operation> + </Platform> + <Platform Name="Win64"> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="ProjectiOSDeviceDebug"> + <Platform Name="iOSDevice32"> + <RemoteDir>..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF</RemoteDir> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice64"> + <RemoteDir>..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF</RemoteDir> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSSimARM64"> + <RemoteDir>..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="ProjectiOSEntitlements"/> + <DeployClass Name="ProjectiOSInfoPList"/> + <DeployClass Name="ProjectiOSLaunchScreen"/> + <DeployClass Name="ProjectiOSResource"> + <Platform Name="iOSDevice32"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSDevice64"> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSSimARM64"> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="UWP_DelphiLogo150"> + <Platform Name="Win32"> + <RemoteDir>Assets</RemoteDir> + <Operation>1</Operation> + </Platform> + <Platform Name="Win64"> + <RemoteDir>Assets</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="UWP_DelphiLogo44"> + <Platform Name="Win32"> + <RemoteDir>Assets</RemoteDir> + <Operation>1</Operation> + </Platform> + <Platform Name="Win64"> + <RemoteDir>Assets</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="iOS_AppStore1024"> + <Platform Name="iOSDevice64"> + <RemoteDir>..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset</RemoteDir> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSSimARM64"> + <RemoteDir>..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="iPad_AppIcon152"> + <Platform Name="iOSDevice64"> + <RemoteDir>..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset</RemoteDir> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSSimARM64"> + <RemoteDir>..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="iPad_AppIcon167"> + <Platform Name="iOSDevice64"> + <RemoteDir>..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset</RemoteDir> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSSimARM64"> + <RemoteDir>..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="iPad_Launch2x"> + <Platform Name="iOSDevice64"> + <RemoteDir>..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset</RemoteDir> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSSimARM64"> + <RemoteDir>..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="iPad_LaunchDark2x"> + <Platform Name="iOSDevice64"> + <RemoteDir>..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset</RemoteDir> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSSimARM64"> + <RemoteDir>..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="iPad_Notification40"> + <Platform Name="iOSDevice64"> + <RemoteDir>..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset</RemoteDir> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSSimARM64"> + <RemoteDir>..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="iPad_Setting58"> + <Platform Name="iOSDevice64"> + <RemoteDir>..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset</RemoteDir> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSSimARM64"> + <RemoteDir>..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="iPad_SpotLight80"> + <Platform Name="iOSDevice64"> + <RemoteDir>..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset</RemoteDir> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSSimARM64"> + <RemoteDir>..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="iPhone_AppIcon120"> + <Platform Name="iOSDevice64"> + <RemoteDir>..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset</RemoteDir> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSSimARM64"> + <RemoteDir>..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="iPhone_AppIcon180"> + <Platform Name="iOSDevice64"> + <RemoteDir>..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset</RemoteDir> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSSimARM64"> + <RemoteDir>..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="iPhone_Launch2x"> + <Platform Name="iOSDevice64"> + <RemoteDir>..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset</RemoteDir> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSSimARM64"> + <RemoteDir>..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="iPhone_Launch3x"> + <Platform Name="iOSDevice64"> + <RemoteDir>..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset</RemoteDir> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSSimARM64"> + <RemoteDir>..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="iPhone_LaunchDark2x"> + <Platform Name="iOSDevice64"> + <RemoteDir>..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset</RemoteDir> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSSimARM64"> + <RemoteDir>..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="iPhone_LaunchDark3x"> + <Platform Name="iOSDevice64"> + <RemoteDir>..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset</RemoteDir> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSSimARM64"> + <RemoteDir>..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="iPhone_Notification40"> + <Platform Name="iOSDevice64"> + <RemoteDir>..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset</RemoteDir> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSSimARM64"> + <RemoteDir>..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="iPhone_Notification60"> + <Platform Name="iOSDevice64"> + <RemoteDir>..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset</RemoteDir> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSSimARM64"> + <RemoteDir>..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="iPhone_Setting58"> + <Platform Name="iOSDevice64"> + <RemoteDir>..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset</RemoteDir> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSSimARM64"> + <RemoteDir>..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="iPhone_Setting87"> + <Platform Name="iOSDevice64"> + <RemoteDir>..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset</RemoteDir> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSSimARM64"> + <RemoteDir>..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="iPhone_Spotlight120"> + <Platform Name="iOSDevice64"> + <RemoteDir>..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset</RemoteDir> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSSimARM64"> + <RemoteDir>..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <DeployClass Name="iPhone_Spotlight80"> + <Platform Name="iOSDevice64"> + <RemoteDir>..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset</RemoteDir> + <Operation>1</Operation> + </Platform> + <Platform Name="iOSSimARM64"> + <RemoteDir>..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset</RemoteDir> + <Operation>1</Operation> + </Platform> + </DeployClass> + <ProjectRoot Platform="Android" Name="$(PROJECTNAME)"/> + <ProjectRoot Platform="Android64" Name="$(PROJECTNAME)"/> + <ProjectRoot Platform="iOSDevice32" Name="$(PROJECTNAME).app"/> + <ProjectRoot Platform="iOSDevice64" Name="$(PROJECTNAME).app"/> + <ProjectRoot Platform="iOSSimARM64" Name="$(PROJECTNAME).app"/> + <ProjectRoot Platform="iOSSimulator" Name="$(PROJECTNAME).app"/> + <ProjectRoot Platform="Linux64" Name="$(PROJECTNAME)"/> + <ProjectRoot Platform="OSX32" Name="$(PROJECTNAME)"/> + <ProjectRoot Platform="OSX64" Name="$(PROJECTNAME)"/> + <ProjectRoot Platform="OSXARM64" Name="$(PROJECTNAME)"/> + <ProjectRoot Platform="Win32" Name="$(PROJECTNAME)"/> + <ProjectRoot Platform="Win64" Name="$(PROJECTNAME)"/> + </Deployment> + </BorlandProject> + <ProjectFileVersion>12</ProjectFileVersion> + </ProjectExtensions> + <Import Project="$(BDS)\Bin\CodeGear.Delphi.Targets" Condition="Exists('$(BDS)\Bin\CodeGear.Delphi.Targets')"/> + <Import Project="$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj" Condition="Exists('$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj')"/> + <Import Project="$(MSBuildProjectName).deployproj" Condition="Exists('$(MSBuildProjectName).deployproj')"/> +</Project> diff --git a/Sources/paxcomp_VCL.res b/Sources/paxcomp_VCL.res new file mode 100644 index 0000000..8b985b9 Binary files /dev/null and b/Sources/paxcomp_VCL.res differ diff --git a/Sources/paxcomp_centos32.pas b/Sources/paxcomp_centos32.pas new file mode 100644 index 0000000..889a27c --- /dev/null +++ b/Sources/paxcomp_centos32.pas @@ -0,0 +1,20 @@ +{ This file was automatically created by Lazarus. do not edit! + This source is only used to compile and install the package. + } + +unit paxcomp_centos32; + +interface + +uses + PaxCompilerRegister, LazarusPackageIntf; + +implementation + +procedure Register; +begin +end; + +initialization + RegisterPackage('paxcomp_centos32', @Register); +end. diff --git a/Sources/paxcomp_d2010.dpk b/Sources/paxcomp_d2010.dpk new file mode 100644 index 0000000..3b8b5a3 --- /dev/null +++ b/Sources/paxcomp_d2010.dpk @@ -0,0 +1,45 @@ +package paxcomp_d2010; + +{$R *.res} +{$R 'PaxCompiler.dcr'} +{$IFDEF IMPLICITBUILDING This IFDEF should not be used by users} +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION OFF} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO OFF} +{$SAFEDIVIDE OFF} +{$STACKFRAMES ON} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$DEFINE DEBUG} +{$DEFINE DEBUG} +{$DEFINE DEBUG} +{$DEFINE DEBUG} +{$DEFINE DEBUG} +{$DEFINE DEBUG} +{$DEFINE DEBUG} +{$ENDIF IMPLICITBUILDING} +{$IMPLICITBUILD ON} + +requires + rtl, + vcl, + soaprtl; + +contains + PaxCompilerRegister in 'PaxCompilerRegister.pas'; + +end. diff --git a/Sources/paxcomp_d2010.dproj b/Sources/paxcomp_d2010.dproj new file mode 100644 index 0000000..f959c22 --- /dev/null +++ b/Sources/paxcomp_d2010.dproj @@ -0,0 +1,154 @@ +<Project xmlns="http://schemas.microsoft.com/developer/msbuild/2003"> + <PropertyGroup> + <ProjectGuid>{9B88E776-7CE0-4F39-A17D-E2352EBA8756}</ProjectGuid> + <MainSource>paxcomp_d2010.dpk</MainSource> + <Base>True</Base> + <Config Condition="'$(Config)'==''">Debug</Config> + <TargetedPlatforms>1</TargetedPlatforms> + <AppType>Package</AppType> + <FrameworkType>VCL</FrameworkType> + <ProjectVersion>14.6</ProjectVersion> + <Platform Condition="'$(Platform)'==''">Win32</Platform> + </PropertyGroup> + <PropertyGroup Condition="'$(Config)'=='Base' or '$(Base)'!=''"> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="('$(Platform)'=='Win32' and '$(Base)'=='true') or '$(Base_Win32)'!=''"> + <Base_Win32>true</Base_Win32> + <CfgParent>Base</CfgParent> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="('$(Platform)'=='Win64' and '$(Base)'=='true') or '$(Base_Win64)'!=''"> + <Base_Win64>true</Base_Win64> + <CfgParent>Base</CfgParent> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="'$(Config)'=='Release' or '$(Cfg_1)'!=''"> + <Cfg_1>true</Cfg_1> + <CfgParent>Base</CfgParent> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="'$(Config)'=='Debug' or '$(Cfg_2)'!=''"> + <Cfg_2>true</Cfg_2> + <CfgParent>Base</CfgParent> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="'$(Base)'!=''"> + <GenPackage>true</GenPackage> + <DCC_Define>DEBUG;DEBUG;DEBUG;DEBUG;DEBUG;DEBUG;$(DCC_Define)</DCC_Define> + <DCC_F>false</DCC_F> + <DCC_E>false</DCC_E> + <DCC_S>false</DCC_S> + <DCC_N>false</DCC_N> + <GenDll>true</GenDll> + <DCC_ImageBase>00400000</DCC_ImageBase> + <DCC_Namespace>Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;System;Xml;Data;Datasnap;Web;Soap;$(DCC_Namespace)</DCC_Namespace> + <DCC_SymbolReferenceInfo>0</DCC_SymbolReferenceInfo> + <DCC_K>false</DCC_K> + <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=;CFBundleName=;CFBundleDisplayName=;UIDeviceFamily=;CFBundleIdentifier=;CFBundleVersion=;CFBundlePackageType=;CFBundleSignature=;CFBundleAllowMixedLocalizations=;UISupportedInterfaceOrientations=;CFBundleExecutable=;CFBundleResourceSpecification=;LSRequiresIPhoneOS=;CFBundleInfoDictionaryVersion=;CFBundleDevelopmentRegion=</VerInfo_Keys> + <VerInfo_Locale>1033</VerInfo_Locale> + </PropertyGroup> + <PropertyGroup Condition="'$(Base_Win32)'!=''"> + <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=</VerInfo_Keys> + <Icon_MainIcon>paxcomp_d2010_Icon.ico</Icon_MainIcon> + <VerInfo_Locale>1033</VerInfo_Locale> + <DCC_Namespace>Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace)</DCC_Namespace> + <VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo> + </PropertyGroup> + <PropertyGroup Condition="'$(Base_Win64)'!=''"> + <Icon_MainIcon>paxcomp_d2010_Icon.ico</Icon_MainIcon> + </PropertyGroup> + <PropertyGroup Condition="'$(Cfg_1)'!=''"> + <DCC_Define>RELEASE;$(DCC_Define)</DCC_Define> + <DCC_LocalDebugSymbols>false</DCC_LocalDebugSymbols> + <DCC_SymbolReferenceInfo>0</DCC_SymbolReferenceInfo> + <DCC_DebugInformation>false</DCC_DebugInformation> + </PropertyGroup> + <PropertyGroup Condition="'$(Cfg_2)'!=''"> + <DCC_Define>DEBUG;$(DCC_Define)</DCC_Define> + <DCC_Optimize>false</DCC_Optimize> + <DCC_GenerateStackFrames>true</DCC_GenerateStackFrames> + </PropertyGroup> + <ItemGroup> + <DelphiCompile Include="$(MainSource)"> + <MainSource>MainSource</MainSource> + </DelphiCompile> + <DCCReference Include="PaxCompiler.dcr"/> + <DCCReference Include="rtl.dcp"/> + <DCCReference Include="vcl.dcp"/> + <DCCReference Include="soaprtl.dcp"/> + <DCCReference Include="PaxCompilerRegister.pas"/> + <BuildConfiguration Include="Debug"> + <Key>Cfg_2</Key> + <CfgParent>Base</CfgParent> + </BuildConfiguration> + <BuildConfiguration Include="Base"> + <Key>Base</Key> + </BuildConfiguration> + <BuildConfiguration Include="Release"> + <Key>Cfg_1</Key> + <CfgParent>Base</CfgParent> + </BuildConfiguration> + </ItemGroup> + <ProjectExtensions> + <Borland.Personality>Delphi.Personality.12</Borland.Personality> + <Borland.ProjectType>Package</Borland.ProjectType> + <BorlandProject> + <Delphi.Personality> + <Source> + <Source Name="MainSource">paxcomp_d2010.dpk</Source> + </Source> + <VersionInfo> + <VersionInfo Name="IncludeVerInfo">False</VersionInfo> + <VersionInfo Name="AutoIncBuild">False</VersionInfo> + <VersionInfo Name="MajorVer">1</VersionInfo> + <VersionInfo Name="MinorVer">0</VersionInfo> + <VersionInfo Name="Release">0</VersionInfo> + <VersionInfo Name="Build">0</VersionInfo> + <VersionInfo Name="Debug">False</VersionInfo> + <VersionInfo Name="PreRelease">False</VersionInfo> + <VersionInfo Name="Special">False</VersionInfo> + <VersionInfo Name="Private">False</VersionInfo> + <VersionInfo Name="DLL">False</VersionInfo> + <VersionInfo Name="Locale">1033</VersionInfo> + <VersionInfo Name="CodePage">1252</VersionInfo> + </VersionInfo> + <VersionInfoKeys> + <VersionInfoKeys Name="CompanyName"/> + <VersionInfoKeys Name="FileDescription"/> + <VersionInfoKeys Name="FileVersion">1.0.0.0</VersionInfoKeys> + <VersionInfoKeys Name="InternalName"/> + <VersionInfoKeys Name="LegalCopyright"/> + <VersionInfoKeys Name="LegalTrademarks"/> + <VersionInfoKeys Name="OriginalFilename"/> + <VersionInfoKeys Name="ProductName"/> + <VersionInfoKeys Name="ProductVersion">1.0.0.0</VersionInfoKeys> + <VersionInfoKeys Name="Comments"/> + <VersionInfoKeys Name="CFBundleName"/> + <VersionInfoKeys Name="CFBundleDisplayName"/> + <VersionInfoKeys Name="UIDeviceFamily"/> + <VersionInfoKeys Name="CFBundleIdentifier"/> + <VersionInfoKeys Name="CFBundleVersion"/> + <VersionInfoKeys Name="CFBundlePackageType"/> + <VersionInfoKeys Name="CFBundleSignature"/> + <VersionInfoKeys Name="CFBundleAllowMixedLocalizations"/> + <VersionInfoKeys Name="UISupportedInterfaceOrientations"/> + <VersionInfoKeys Name="CFBundleExecutable"/> + <VersionInfoKeys Name="CFBundleResourceSpecification"/> + <VersionInfoKeys Name="LSRequiresIPhoneOS"/> + <VersionInfoKeys Name="CFBundleInfoDictionaryVersion"/> + <VersionInfoKeys Name="CFBundleDevelopmentRegion"/> + </VersionInfoKeys> + </Delphi.Personality> + <Platforms> + <Platform value="iOSDevice">False</Platform> + <Platform value="iOSSimulator">False</Platform> + <Platform value="Win32">True</Platform> + <Platform value="Win64">False</Platform> + </Platforms> + </BorlandProject> + <ProjectFileVersion>12</ProjectFileVersion> + </ProjectExtensions> + <Import Project="$(BDS)\Bin\CodeGear.Delphi.Targets" Condition="Exists('$(BDS)\Bin\CodeGear.Delphi.Targets')"/> + <Import Project="$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj" Condition="Exists('$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj')"/> +</Project> diff --git a/Sources/paxcomp_d2010.res b/Sources/paxcomp_d2010.res new file mode 100644 index 0000000..ff56d05 Binary files /dev/null and b/Sources/paxcomp_d2010.res differ diff --git a/Sources/paxcomp_d2010_Icon.ico b/Sources/paxcomp_d2010_Icon.ico new file mode 100644 index 0000000..0a29c9c Binary files /dev/null and b/Sources/paxcomp_d2010_Icon.ico differ diff --git a/Sources/paxcomp_lazaruz.pas b/Sources/paxcomp_lazaruz.pas new file mode 100644 index 0000000..90968a1 --- /dev/null +++ b/Sources/paxcomp_lazaruz.pas @@ -0,0 +1,22 @@ +{ Ýòîò ôàéë áûë àâòîìàòè÷åñêè ñîçäàí Lazarus. Íå ðåäàêòèðîâàòü! +Èñõîäíûé êîä èñïîëüçóåòñÿ òîëüêî äëÿ êîìïèëÿöèè è óñòàíîâêè ïàêåòà. + } + +unit paxcomp_lazaruz; + +interface + +uses + PaxCompiler, PaxProgram, PaxInvoke, PaxCompilerExplorer, PaxCompilerDebugger, + LazarusPackageIntf; + +implementation + +procedure Register; +begin + RegisterUnit('PaxCompiler', @PaxCompiler.Register); +end; + +initialization + RegisterPackage('paxcomp_lazaruz', @Register); +end. diff --git a/Sources/paxcomp_xe.dpk b/Sources/paxcomp_xe.dpk new file mode 100644 index 0000000..44412c9 --- /dev/null +++ b/Sources/paxcomp_xe.dpk @@ -0,0 +1,36 @@ +package paxcomp_xe; + +{$R *.res} +{$R 'PaxCompiler.dcr'} +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO OFF} +{$SAFEDIVIDE OFF} +{$STACKFRAMES OFF} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$IMPLICITBUILD ON} + +requires + rtl, + vcl, + soaprtl; + +contains + PaxCompilerRegister in 'PaxCompilerRegister.pas'; + +end. diff --git a/Sources/paxcomp_xe.dproj b/Sources/paxcomp_xe.dproj new file mode 100644 index 0000000..fe89a5a --- /dev/null +++ b/Sources/paxcomp_xe.dproj @@ -0,0 +1,598 @@ + <Project xmlns="http://schemas.microsoft.com/developer/msbuild/2003"> + <PropertyGroup> + <ProjectGuid>{BC55B937-EB82-4EDE-9EE0-6C934772D4CC}</ProjectGuid> + <MainSource>paxcomp_xe.dpk</MainSource> + <Base>True</Base> + <Config Condition="'$(Config)'==''">Debug</Config> + <Platform>Win32</Platform> + <AppType>Package</AppType> + <FrameworkType>VCL</FrameworkType> + <DCC_DCCCompiler>DCC32</DCC_DCCCompiler> + <ProjectVersion>12.3</ProjectVersion> + </PropertyGroup> + <PropertyGroup Condition="'$(Config)'=='Base' or '$(Base)'!=''"> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="'$(Config)'=='Release' or '$(Cfg_1)'!=''"> + <Cfg_1>true</Cfg_1> + <CfgParent>Base</CfgParent> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="'$(Config)'=='Debug' or '$(Cfg_2)'!=''"> + <Cfg_2>true</Cfg_2> + <CfgParent>Base</CfgParent> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="'$(Base)'!=''"> + <GenPackage>true</GenPackage> + <DCC_E>false</DCC_E> + <DCC_SymbolReferenceInfo>0</DCC_SymbolReferenceInfo> + <DCC_UnitAlias>WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE;WinTypes=Windows;WinProcs=Windows;$(DCC_UnitAlias)</DCC_UnitAlias> + <DCC_ImageBase>00400000</DCC_ImageBase> + <DCC_S>false</DCC_S> + <GenDll>true</GenDll> + <DCC_N>false</DCC_N> + <DCC_F>false</DCC_F> + <DCC_K>false</DCC_K> + </PropertyGroup> + <PropertyGroup Condition="'$(Cfg_1)'!=''"> + <DCC_Define>RELEASE;$(DCC_Define)</DCC_Define> + <DCC_LocalDebugSymbols>false</DCC_LocalDebugSymbols> + <DCC_DebugInformation>false</DCC_DebugInformation> + </PropertyGroup> + <PropertyGroup Condition="'$(Cfg_2)'!=''"> + <DCC_Define>DEBUG;$(DCC_Define)</DCC_Define> + <DCC_Optimize>false</DCC_Optimize> + <DCC_GenerateStackFrames>true</DCC_GenerateStackFrames> + </PropertyGroup> + <ItemGroup> + <DelphiCompile Include="paxcomp_xe.dpk"> + <MainSource>MainSource</MainSource> + </DelphiCompile> + <DCCReference Include="PaxCompiler.dcr"/> + <DCCReference Include="rtl.dcp"/> + <DCCReference Include="vcl.dcp"/> + <DCCReference Include="soaprtl.dcp"/> + <DCCReference Include="PaxCompilerRegister.pas"/> + <BuildConfiguration Include="Debug"> + <Key>Cfg_2</Key> + <CfgParent>Base</CfgParent> + </BuildConfiguration> + <BuildConfiguration Include="Base"> + <Key>Base</Key> + </BuildConfiguration> + <BuildConfiguration Include="Release"> + <Key>Cfg_1</Key> + <CfgParent>Base</CfgParent> + </BuildConfiguration> + </ItemGroup> + <Import Condition="Exists('$(BDS)\Bin\CodeGear.Delphi.Targets')" Project="$(BDS)\Bin\CodeGear.Delphi.Targets"/> + <Import Condition="Exists('$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj')" Project="$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj"/> + <ProjectExtensions> + <Borland.Personality>Delphi.Personality.12</Borland.Personality> + <Borland.ProjectType>Package</Borland.ProjectType> + <BorlandProject> + <Delphi.Personality> + <Source> + <Source Name="MainSource">paxcomp_xe.dpk</Source> + </Source> + <VersionInfo> + <VersionInfo Name="IncludeVerInfo">False</VersionInfo> + <VersionInfo Name="AutoIncBuild">False</VersionInfo> + <VersionInfo Name="MajorVer">1</VersionInfo> + <VersionInfo Name="MinorVer">0</VersionInfo> + <VersionInfo Name="Release">0</VersionInfo> + <VersionInfo Name="Build">0</VersionInfo> + <VersionInfo Name="Debug">False</VersionInfo> + <VersionInfo Name="PreRelease">False</VersionInfo> + <VersionInfo Name="Special">False</VersionInfo> + <VersionInfo Name="Private">False</VersionInfo> + <VersionInfo Name="DLL">False</VersionInfo> + <VersionInfo Name="Locale">1033</VersionInfo> + <VersionInfo Name="CodePage">1252</VersionInfo> + </VersionInfo> + <VersionInfoKeys> + <VersionInfoKeys Name="CompanyName"/> + <VersionInfoKeys Name="FileDescription"/> + <VersionInfoKeys Name="FileVersion">1.0.0.0</VersionInfoKeys> + <VersionInfoKeys Name="InternalName"/> + <VersionInfoKeys Name="LegalCopyright"/> + <VersionInfoKeys Name="LegalTrademarks"/> + <VersionInfoKeys Name="OriginalFilename"/> + <VersionInfoKeys Name="ProductName"/> + <VersionInfoKeys Name="ProductVersion">1.0.0.0</VersionInfoKeys> + <VersionInfoKeys Name="Comments"/> + </VersionInfoKeys> + </Delphi.Personality> + <Platforms> + <Platform value="Win32">True</Platform> + </Platforms> + </BorlandProject> + <ProjectFileVersion>12</ProjectFileVersion> + </ProjectExtensions> + </Project> + +<!-- EurekaLog First Line +[Exception Log] +EurekaLog Version=6101 +Activate=0 +Activate Handle=1 +Save Log File=1 +Foreground Tab=0 +Freeze Activate=0 +Freeze Timeout=60 +SMTP From=eurekalog@email.com +SMTP Host= +SMTP Port=25 +SMTP UserID= +SMTP Password= +Append to Log=0 +TerminateBtn Operation=2 +Errors Number=32 +Errors Terminate=3 +Email Address= +Email Object= +Email Send Options=0 +Output Path= +Encrypt Password= +AutoCloseDialogSecs=0 +WebSendMode=0 +SupportULR= +HTMLLayout Count=15 +HTMLLine0="%U003Chtml%U003E" +HTMLLine1=" %U003Chead%U003E" +HTMLLine2=" %U003C/head%U003E" +HTMLLine3=" %U003Cbody TopMargin=10 LeftMargin=10%U003E" +HTMLLine4=" %U003Ctable width="100%%" border="0"%U003E" +HTMLLine5=" %U003Ctr%U003E" +HTMLLine6=" %U003Ctd nowrap%U003E" +HTMLLine7=" %U003Cfont face="Lucida Console, Courier" size="2"%U003E" +HTMLLine8=" %U003C%%HTML_TAG%%%U003E" +HTMLLine9=" %U003C/font%U003E" +HTMLLine10=" %U003C/td%U003E" +HTMLLine11=" %U003C/tr%U003E" +HTMLLine12=" %U003C/table%U003E" +HTMLLine13=" %U003C/body%U003E" +HTMLLine14="%U003C/html%U003E" +AutoCrashOperation=2 +AutoCrashNumber=10 +AutoCrashMinutes=1 +WebURL= +WebUserID= +WebPassword= +WebPort=0 +AttachedFiles= +ProxyURL= +ProxyUser= +ProxyPassword= +ProxyPort=8080 +TrakerUser= +TrakerPassword= +TrakerAssignTo= +TrakerProject= +TrakerCategory= +TrakerTrialID= +ZipPassword= +PreBuildEvent= +PostSuccessfulBuildEvent= +PostFailureBuildEvent= +ExceptionDialogType=2 +Count=0 +EMail Message Line Count=0 +loNoDuplicateErrors=0 +loAppendReproduceText=0 +loDeleteLogAtVersionChange=0 +loAddComputerNameInLogFileName=0 +loSaveModulesAndProcessesSections=1 +loSaveAssemblerAndCPUSections=1 +soAppStartDate=1 +soAppName=1 +soAppVersionNumber=1 +soAppParameters=1 +soAppCompilationDate=1 +soAppUpTime=1 +soExcDate=1 +soExcAddress=1 +soExcModuleName=1 +soExcModuleVersion=1 +soExcType=1 +soExcMessage=1 +soExcID=1 +soExcCount=1 +soExcStatus=1 +soExcNote=1 +soUserID=1 +soUserName=1 +soUserEmail=1 +soUserPrivileges=1 +soUserCompany=1 +soActCtlsFormClass=1 +soActCtlsFormText=1 +soActCtlsControlClass=1 +soActCtlsControlText=1 +soCmpName=1 +soCmpTotalMemory=1 +soCmpFreeMemory=1 +soCmpTotalDisk=1 +soCmpFreeDisk=1 +soCmpSysUpTime=1 +soCmpProcessor=1 +soCmpDisplayMode=1 +soCmpDisplayDPI=1 +soCmpVideoCard=1 +soCmpPrinter=1 +soOSType=1 +soOSBuildN=1 +soOSUpdate=1 +soOSLanguage=1 +soOSCharset=1 +soNetIP=1 +soNetSubmask=1 +soNetGateway=1 +soNetDNS1=1 +soNetDNS2=1 +soNetDHCP=1 +soCustomData=1 +sndShowSendDialog=1 +sndShowSuccessFailureMsg=0 +sndSendEntireLog=0 +sndSendXMLLogCopy=0 +sndSendScreenshot=1 +sndUseOnlyActiveWindow=0 +sndSendLastHTMLPage=1 +sndSendInSeparatedThread=0 +sndAddDateInFileName=0 +sndAddComputerNameInFileName=0 +edoSendErrorReportChecked=1 +edoAttachScreenshotChecked=1 +edoShowCopyToClipOption=1 +edoShowDetailsButton=1 +edoShowInDetailedMode=0 +edoShowInTopMostMode=0 +edoUseEurekaLogLookAndFeel=0 +edoShowSendErrorReportOption=1 +edoShowAttachScreenshotOption=1 +edoShowCustomButton=0 +csoShowDLLs=1 +csoShowBPLs=1 +csoShowBorlandThreads=1 +csoShowWindowsThreads=1 +csoDoNotStoreProcNames=0 +boPauseBorlandThreads=0 +boDoNotPauseMainThread=0 +boPauseWindowsThreads=0 +boUseMainModuleOptions=1 +boCopyLogInCaseOfError=1 +boSaveCompressedCopyInCaseOfError=0 +boHandleSafeCallExceptions=1 +boCallRTLExceptionEvent=0 +boCatchHandledExceptions=0 +loCatchLeaks=0 +loGroupsSonLeaks=1 +loHideBorlandLeaks=1 +loFreeAllLeaks=1 +loCatchLeaksExceptions=1 +cfoReduceFileSize=1 +cfoCheckFileCorruption=0 +cfoUseEL7=0 +Count mtInformationMsgCaption=1 +mtInformationMsgCaption0="Information." +Count mtQuestionMsgCaption=1 +mtQuestionMsgCaption0="Question." +Count mtErrorMsgCaption=1 +mtErrorMsgCaption0="Error." +Count mtDialog_Caption=1 +mtDialog_Caption0="Error occurred" +Count mtDialog_ErrorMsgCaption=2 +mtDialog_ErrorMsgCaption0="An error has occurred during program execution." +mtDialog_ErrorMsgCaption1="Please read the following information for further details." +Count mtDialog_GeneralCaption=1 +mtDialog_GeneralCaption0="General" +Count mtDialog_GeneralHeader=1 +mtDialog_GeneralHeader0="General Information" +Count mtDialog_CallStackCaption=1 +mtDialog_CallStackCaption0="Call Stack" +Count mtDialog_CallStackHeader=1 +mtDialog_CallStackHeader0="Call Stack Information" +Count mtDialog_ModulesCaption=1 +mtDialog_ModulesCaption0="Modules" +Count mtDialog_ModulesHeader=1 +mtDialog_ModulesHeader0="Modules Information" +Count mtDialog_ProcessesCaption=1 +mtDialog_ProcessesCaption0="Processes" +Count mtDialog_ProcessesHeader=1 +mtDialog_ProcessesHeader0="Processes Information" +Count mtDialog_AsmCaption=1 +mtDialog_AsmCaption0="Assembler" +Count mtDialog_AsmHeader=1 +mtDialog_AsmHeader0="Assembler Information" +Count mtDialog_CPUCaption=1 +mtDialog_CPUCaption0="CPU" +Count mtDialog_CPUHeader=1 +mtDialog_CPUHeader0="CPU Information" +Count mtDialog_OKButtonCaption=1 +mtDialog_OKButtonCaption0="%U0026OK" +Count mtDialog_TerminateButtonCaption=1 +mtDialog_TerminateButtonCaption0="%U0026Terminate" +Count mtDialog_RestartButtonCaption=1 +mtDialog_RestartButtonCaption0="%U0026Restart" +Count mtDialog_DetailsButtonCaption=1 +mtDialog_DetailsButtonCaption0="%U0026Details" +Count mtDialog_CustomButtonCaption=1 +mtDialog_CustomButtonCaption0="%U0026Help" +Count mtDialog_SendMessage=1 +mtDialog_SendMessage0="%U0026Send this error via Internet" +Count mtDialog_ScreenshotMessage=1 +mtDialog_ScreenshotMessage0="%U0026Attach a Screenshot image" +Count mtDialog_CopyMessage=1 +mtDialog_CopyMessage0="%U0026Copy to Clipboard" +Count mtDialog_SupportMessage=1 +mtDialog_SupportMessage0="Go to the Support Page" +Count mtMSDialog_ErrorMsgCaption=1 +mtMSDialog_ErrorMsgCaption0="The application has encountered a problem. We are sorry for the inconvenience." +Count mtMSDialog_RestartCaption=1 +mtMSDialog_RestartCaption0="Restart application." +Count mtMSDialog_TerminateCaption=1 +mtMSDialog_TerminateCaption0="Terminate application." +Count mtMSDialog_PleaseCaption=1 +mtMSDialog_PleaseCaption0="Please tell us about this problem." +Count mtMSDialog_DescriptionCaption=1 +mtMSDialog_DescriptionCaption0="We have created an error report that you can send to us. We will treat this report as confidential and anonymous." +Count mtMSDialog_SeeDetailsCaption=1 +mtMSDialog_SeeDetailsCaption0="To see what data the error report contains," +Count mtMSDialog_SeeClickCaption=1 +mtMSDialog_SeeClickCaption0="click here." +Count mtMSDialog_HowToReproduceCaption=1 +mtMSDialog_HowToReproduceCaption0="What were you doing when the problem happened (optional)?" +Count mtMSDialog_EmailCaption=1 +mtMSDialog_EmailCaption0="Email address (optional):" +Count mtMSDialog_SendButtonCaption=1 +mtMSDialog_SendButtonCaption0="%U0026Send Error Report" +Count mtMSDialog_NoSendButtonCaption=1 +mtMSDialog_NoSendButtonCaption0="%U0026Don't Send" +Count mtLog_AppHeader=1 +mtLog_AppHeader0="Application" +Count mtLog_AppStartDate=1 +mtLog_AppStartDate0="Start Date" +Count mtLog_AppName=1 +mtLog_AppName0="Name/Description" +Count mtLog_AppVersionNumber=1 +mtLog_AppVersionNumber0="Version Number" +Count mtLog_AppParameters=1 +mtLog_AppParameters0="Parameters" +Count mtLog_AppCompilationDate=1 +mtLog_AppCompilationDate0="Compilation Date" +Count mtLog_AppUpTime=1 +mtLog_AppUpTime0="Up Time" +Count mtLog_ExcHeader=1 +mtLog_ExcHeader0="Exception" +Count mtLog_ExcDate=1 +mtLog_ExcDate0="Date" +Count mtLog_ExcAddress=1 +mtLog_ExcAddress0="Address" +Count mtLog_ExcModuleName=1 +mtLog_ExcModuleName0="Module Name" +Count mtLog_ExcModuleVersion=1 +mtLog_ExcModuleVersion0="Module Version" +Count mtLog_ExcType=1 +mtLog_ExcType0="Type" +Count mtLog_ExcMessage=1 +mtLog_ExcMessage0="Message" +Count mtLog_ExcID=1 +mtLog_ExcID0="ID" +Count mtLog_ExcCount=1 +mtLog_ExcCount0="Count" +Count mtLog_ExcStatus=1 +mtLog_ExcStatus0="Status" +Count mtLog_ExcNote=1 +mtLog_ExcNote0="Note" +Count mtLog_UserHeader=1 +mtLog_UserHeader0="User" +Count mtLog_UserID=1 +mtLog_UserID0="ID" +Count mtLog_UserName=1 +mtLog_UserName0="Name" +Count mtLog_UserEmail=1 +mtLog_UserEmail0="Email" +Count mtLog_UserCompany=1 +mtLog_UserCompany0="Company" +Count mtLog_UserPrivileges=1 +mtLog_UserPrivileges0="Privileges" +Count mtLog_ActCtrlsHeader=1 +mtLog_ActCtrlsHeader0="Active Controls" +Count mtLog_ActCtrlsFormClass=1 +mtLog_ActCtrlsFormClass0="Form Class" +Count mtLog_ActCtrlsFormText=1 +mtLog_ActCtrlsFormText0="Form Text" +Count mtLog_ActCtrlsControlClass=1 +mtLog_ActCtrlsControlClass0="Control Class" +Count mtLog_ActCtrlsControlText=1 +mtLog_ActCtrlsControlText0="Control Text" +Count mtLog_CmpHeader=1 +mtLog_CmpHeader0="Computer" +Count mtLog_CmpName=1 +mtLog_CmpName0="Name" +Count mtLog_CmpTotalMemory=1 +mtLog_CmpTotalMemory0="Total Memory" +Count mtLog_CmpFreeMemory=1 +mtLog_CmpFreeMemory0="Free Memory" +Count mtLog_CmpTotalDisk=1 +mtLog_CmpTotalDisk0="Total Disk" +Count mtLog_CmpFreeDisk=1 +mtLog_CmpFreeDisk0="Free Disk" +Count mtLog_CmpSystemUpTime=1 +mtLog_CmpSystemUpTime0="System Up Time" +Count mtLog_CmpProcessor=1 +mtLog_CmpProcessor0="Processor" +Count mtLog_CmpDisplayMode=1 +mtLog_CmpDisplayMode0="Display Mode" +Count mtLog_CmpDisplayDPI=1 +mtLog_CmpDisplayDPI0="Display DPI" +Count mtLog_CmpVideoCard=1 +mtLog_CmpVideoCard0="Video Card" +Count mtLog_CmpPrinter=1 +mtLog_CmpPrinter0="Printer" +Count mtLog_OSHeader=1 +mtLog_OSHeader0="Operating System" +Count mtLog_OSType=1 +mtLog_OSType0="Type" +Count mtLog_OSBuildN=1 +mtLog_OSBuildN0="Build #" +Count mtLog_OSUpdate=1 +mtLog_OSUpdate0="Update" +Count mtLog_OSLanguage=1 +mtLog_OSLanguage0="Language" +Count mtLog_OSCharset=1 +mtLog_OSCharset0="Charset" +Count mtLog_NetHeader=1 +mtLog_NetHeader0="Network" +Count mtLog_NetIP=1 +mtLog_NetIP0="IP Address" +Count mtLog_NetSubmask=1 +mtLog_NetSubmask0="Submask" +Count mtLog_NetGateway=1 +mtLog_NetGateway0="Gateway" +Count mtLog_NetDNS1=1 +mtLog_NetDNS10="DNS 1" +Count mtLog_NetDNS2=1 +mtLog_NetDNS20="DNS 2" +Count mtLog_NetDHCP=1 +mtLog_NetDHCP0="DHCP" +Count mtLog_CustInfoHeader=1 +mtLog_CustInfoHeader0="Custom Information" +Count mtCallStack_Address=1 +mtCallStack_Address0="Address" +Count mtCallStack_Name=1 +mtCallStack_Name0="Module" +Count mtCallStack_Unit=1 +mtCallStack_Unit0="Unit" +Count mtCallStack_Class=1 +mtCallStack_Class0="Class" +Count mtCallStack_Procedure=1 +mtCallStack_Procedure0="Procedure/Method" +Count mtCallStack_Line=1 +mtCallStack_Line0="Line" +Count mtCallStack_MainThread=1 +mtCallStack_MainThread0="Main" +Count mtCallStack_ExceptionThread=1 +mtCallStack_ExceptionThread0="Exception Thread" +Count mtCallStack_RunningThread=1 +mtCallStack_RunningThread0="Running Thread" +Count mtCallStack_CallingThread=1 +mtCallStack_CallingThread0="Calling Thread" +Count mtCallStack_ThreadID=1 +mtCallStack_ThreadID0="ID" +Count mtCallStack_ThreadPriority=1 +mtCallStack_ThreadPriority0="Priority" +Count mtCallStack_ThreadClass=1 +mtCallStack_ThreadClass0="Class" +Count mtCallStack_LeakCaption=1 +mtCallStack_LeakCaption0="Memory Leak" +Count mtCallStack_LeakData=1 +mtCallStack_LeakData0="Data" +Count mtCallStack_LeakType=1 +mtCallStack_LeakType0="Type" +Count mtCallStack_LeakSize=1 +mtCallStack_LeakSize0="Total size" +Count mtCallStack_LeakCount=1 +mtCallStack_LeakCount0="Count" +Count mtSendDialog_Caption=1 +mtSendDialog_Caption0="Send." +Count mtSendDialog_Message=1 +mtSendDialog_Message0="Message" +Count mtSendDialog_Resolving=1 +mtSendDialog_Resolving0="Resolving DNS..." +Count mtSendDialog_Login=1 +mtSendDialog_Login0="Login..." +Count mtSendDialog_Connecting=1 +mtSendDialog_Connecting0="Connecting with server..." +Count mtSendDialog_Connected=1 +mtSendDialog_Connected0="Connected with server." +Count mtSendDialog_Sending=1 +mtSendDialog_Sending0="Sending message..." +Count mtSendDialog_Sent=1 +mtSendDialog_Sent0="Message sent." +Count mtSendDialog_SelectProject=1 +mtSendDialog_SelectProject0="Select project..." +Count mtSendDialog_Searching=1 +mtSendDialog_Searching0="Searching..." +Count mtSendDialog_Modifying=1 +mtSendDialog_Modifying0="Modifying..." +Count mtSendDialog_Disconnecting=1 +mtSendDialog_Disconnecting0="Disconnecting..." +Count mtSendDialog_Disconnected=1 +mtSendDialog_Disconnected0="Disconnected." +Count mtReproduceDialog_Caption=1 +mtReproduceDialog_Caption0="Request" +Count mtReproduceDialog_Request=1 +mtReproduceDialog_Request0="Please describe the steps to reproduce the error:" +Count mtReproduceDialog_OKButtonCaption=1 +mtReproduceDialog_OKButtonCaption0="%U0026OK" +Count mtModules_Handle=1 +mtModules_Handle0="Handle" +Count mtModules_Name=1 +mtModules_Name0="Name" +Count mtModules_Description=1 +mtModules_Description0="Description" +Count mtModules_Version=1 +mtModules_Version0="Version" +Count mtModules_Size=1 +mtModules_Size0="Size" +Count mtModules_LastModified=1 +mtModules_LastModified0="Modified" +Count mtModules_Path=1 +mtModules_Path0="Path" +Count mtProcesses_ID=1 +mtProcesses_ID0="ID" +Count mtProcesses_Name=1 +mtProcesses_Name0="Name" +Count mtProcesses_Description=1 +mtProcesses_Description0="Description" +Count mtProcesses_Version=1 +mtProcesses_Version0="Version" +Count mtProcesses_Memory=1 +mtProcesses_Memory0="Memory" +Count mtProcesses_Priority=1 +mtProcesses_Priority0="Priority" +Count mtProcesses_Threads=1 +mtProcesses_Threads0="Threads" +Count mtProcesses_Path=1 +mtProcesses_Path0="Path" +Count mtCPU_Registers=1 +mtCPU_Registers0="Registers" +Count mtCPU_Stack=1 +mtCPU_Stack0="Stack" +Count mtCPU_MemoryDump=1 +mtCPU_MemoryDump0="Memory Dump" +Count mtSend_SuccessMsg=1 +mtSend_SuccessMsg0="The message was sent successfully." +Count mtSend_FailureMsg=1 +mtSend_FailureMsg0="Sorry, sending the message didn't work." +Count mtSend_BugClosedMsg=2 +mtSend_BugClosedMsg0="These BUG is just closed." +mtSend_BugClosedMsg1="Contact the program support to obtain an update." +Count mtSend_UnknownErrorMsg=1 +mtSend_UnknownErrorMsg0="Unknown error." +Count mtSend_InvalidLoginMsg=1 +mtSend_InvalidLoginMsg0="Invalid login request." +Count mtSend_InvalidSearchMsg=1 +mtSend_InvalidSearchMsg0="Invalid search request." +Count mtSend_InvalidSelectionMsg=1 +mtSend_InvalidSelectionMsg0="Invalid selection request." +Count mtSend_InvalidInsertMsg=1 +mtSend_InvalidInsertMsg0="Invalid insert request." +Count mtSend_InvalidModifyMsg=1 +mtSend_InvalidModifyMsg0="Invalid modify request." +Count mtFileCrackedMsg=2 +mtFileCrackedMsg0="This file is cracked." +mtFileCrackedMsg1="The application will be closed." +Count mtException_LeakMultiFree=1 +mtException_LeakMultiFree0="Multi Free memory leak." +Count mtException_LeakMemoryOverrun=1 +mtException_LeakMemoryOverrun0="Memory Overrun leak." +Count mtException_AntiFreeze=1 +mtException_AntiFreeze0="The application seems to be frozen." +Count mtInvalidEmailMsg=1 +mtInvalidEmailMsg0="Invalid email." +TextsCollection=English +EurekaLog Last Line --> diff --git a/Sources/paxcomp_xe.res b/Sources/paxcomp_xe.res new file mode 100644 index 0000000..fe53ea1 Binary files /dev/null and b/Sources/paxcomp_xe.res differ diff --git a/Sources/paxcomp_xe2.dpk b/Sources/paxcomp_xe2.dpk new file mode 100644 index 0000000..8585c91 --- /dev/null +++ b/Sources/paxcomp_xe2.dpk @@ -0,0 +1,39 @@ +package paxcomp_xe2; + +{$R *.res} +{$R 'PaxCompiler.dcr'} +{$IFDEF IMPLICITBUILDING This IFDEF should not be used by users} +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION OFF} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO OFF} +{$SAFEDIVIDE OFF} +{$STACKFRAMES ON} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$DEFINE DEBUG} +{$ENDIF IMPLICITBUILDING} +{$IMPLICITBUILD ON} + +requires + rtl, + vcl, + soaprtl; + +contains + PaxCompilerRegister in 'PaxCompilerRegister.pas'; + +end. diff --git a/Sources/paxcomp_xe2.res b/Sources/paxcomp_xe2.res new file mode 100644 index 0000000..a64cea3 Binary files /dev/null and b/Sources/paxcomp_xe2.res differ diff --git a/Sources/paxcomp_xe3.dpk b/Sources/paxcomp_xe3.dpk new file mode 100644 index 0000000..4c2319d --- /dev/null +++ b/Sources/paxcomp_xe3.dpk @@ -0,0 +1,38 @@ +package paxcomp_xe3; + +{$R *.res} +{$IFDEF IMPLICITBUILDING This IFDEF should not be used by users} +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION OFF} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES ON} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$DEFINE DEBUG} +{$ENDIF IMPLICITBUILDING} +{$IMPLICITBUILD ON} + +requires + rtl, + vcl, + soaprtl; + +contains + PaxCompilerRegister in 'PaxCompilerRegister.pas'; + +end. diff --git a/Sources/paxcomp_xe3.res b/Sources/paxcomp_xe3.res new file mode 100644 index 0000000..a64cea3 Binary files /dev/null and b/Sources/paxcomp_xe3.res differ diff --git a/Sources/paxcomp_xe4.dpk b/Sources/paxcomp_xe4.dpk new file mode 100644 index 0000000..1a366e1 --- /dev/null +++ b/Sources/paxcomp_xe4.dpk @@ -0,0 +1,39 @@ +package paxcomp_xe4; + +{$R *.res} +{$R 'PaxCompiler.dcr'} +{$IFDEF IMPLICITBUILDING This IFDEF should not be used by users} +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION OFF} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES ON} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$DEFINE DEBUG} +{$ENDIF IMPLICITBUILDING} +{$IMPLICITBUILD ON} + +requires + rtl, + vcl, + soaprtl; + +contains + PaxCompilerRegister in 'PaxCompilerRegister.pas'; + +end. diff --git a/Sources/paxcomp_xe4.res b/Sources/paxcomp_xe4.res new file mode 100644 index 0000000..a64cea3 Binary files /dev/null and b/Sources/paxcomp_xe4.res differ diff --git a/Sources/paxcomp_xe5.dpk b/Sources/paxcomp_xe5.dpk new file mode 100644 index 0000000..77911a9 --- /dev/null +++ b/Sources/paxcomp_xe5.dpk @@ -0,0 +1,40 @@ +package paxcomp_xe5; + +{$R *.res} +{$R *.otares} +{$R 'PaxCompiler.dcr'} +{$IFDEF IMPLICITBUILDING This IFDEF should not be used by users} +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION OFF} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES ON} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$DEFINE DEBUG} +{$ENDIF IMPLICITBUILDING} +{$IMPLICITBUILD ON} + +requires + rtl, + vcl, + soaprtl; + +contains + PaxCompilerRegister in 'PaxCompilerRegister.pas'; + +end. diff --git a/Sources/paxcomp_xe5.res b/Sources/paxcomp_xe5.res new file mode 100644 index 0000000..8b39f81 Binary files /dev/null and b/Sources/paxcomp_xe5.res differ diff --git a/Sources/paxcomp_xe6.dpk b/Sources/paxcomp_xe6.dpk new file mode 100644 index 0000000..2d70227 --- /dev/null +++ b/Sources/paxcomp_xe6.dpk @@ -0,0 +1,40 @@ +package paxcomp_xe6; + +{$R *.res} +{$R *.otares} +{$R 'PaxCompiler.dcr'} +{$IFDEF IMPLICITBUILDING This IFDEF should not be used by users} +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO OFF} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION OFF} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES ON} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$DEFINE DEBUG} +{$ENDIF IMPLICITBUILDING} +{$IMPLICITBUILD ON} + +requires + rtl, + vcl, + soaprtl; + +contains + PaxCompilerRegister in 'PaxCompilerRegister.pas'; + +end. diff --git a/Sources/paxcomp_xe6.dproj b/Sources/paxcomp_xe6.dproj new file mode 100644 index 0000000..c733ddc --- /dev/null +++ b/Sources/paxcomp_xe6.dproj @@ -0,0 +1,139 @@ +<Project xmlns="http://schemas.microsoft.com/developer/msbuild/2003"> + <PropertyGroup> + <ProjectGuid>{6D169D17-B0B7-4557-BDE2-DB0CDE135DFB}</ProjectGuid> + <MainSource>paxcomp_xe6.dpk</MainSource> + <Base>True</Base> + <Config Condition="'$(Config)'==''">Debug</Config> + <TargetedPlatforms>1</TargetedPlatforms> + <AppType>Package</AppType> + <FrameworkType>VCL</FrameworkType> + <ProjectVersion>15.4</ProjectVersion> + <Platform Condition="'$(Platform)'==''">Win32</Platform> + </PropertyGroup> + <PropertyGroup Condition="'$(Config)'=='Base' or '$(Base)'!=''"> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="('$(Platform)'=='Android' and '$(Base)'=='true') or '$(Base_Android)'!=''"> + <Base_Android>true</Base_Android> + <CfgParent>Base</CfgParent> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="('$(Platform)'=='iOSDevice' and '$(Base)'=='true') or '$(Base_iOSDevice)'!=''"> + <Base_iOSDevice>true</Base_iOSDevice> + <CfgParent>Base</CfgParent> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="('$(Platform)'=='iOSSimulator' and '$(Base)'=='true') or '$(Base_iOSSimulator)'!=''"> + <Base_iOSSimulator>true</Base_iOSSimulator> + <CfgParent>Base</CfgParent> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="('$(Platform)'=='Win32' and '$(Base)'=='true') or '$(Base_Win32)'!=''"> + <Base_Win32>true</Base_Win32> + <CfgParent>Base</CfgParent> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="('$(Platform)'=='Win64' and '$(Base)'=='true') or '$(Base_Win64)'!=''"> + <Base_Win64>true</Base_Win64> + <CfgParent>Base</CfgParent> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="'$(Config)'=='Release' or '$(Cfg_1)'!=''"> + <Cfg_1>true</Cfg_1> + <CfgParent>Base</CfgParent> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="'$(Config)'=='Debug' or '$(Cfg_2)'!=''"> + <Cfg_2>true</Cfg_2> + <CfgParent>Base</CfgParent> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="'$(Base)'!=''"> + <DCC_ImageBase>00400000</DCC_ImageBase> + <DCC_Namespace>Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;System;Xml;Data;Datasnap;Web;Soap;$(DCC_Namespace)</DCC_Namespace> + <VerInfo_Locale>1033</VerInfo_Locale> + <GenPackage>true</GenPackage> + <DCC_K>false</DCC_K> + <GenDll>true</GenDll> + <DCC_S>false</DCC_S> + <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=;CFBundleName=</VerInfo_Keys> + <DCC_F>false</DCC_F> + <SanitizedProjectName>paxcomp_xe6</SanitizedProjectName> + <DCC_E>false</DCC_E> + <DCC_N>false</DCC_N> + </PropertyGroup> + <PropertyGroup Condition="'$(Base_Android)'!=''"> + <DCC_UsePackage>rtl;soaprtl;$(DCC_UsePackage)</DCC_UsePackage> + <BT_BuildType>Debug</BT_BuildType> + <VerInfo_Keys>package=com.embarcadero.$(MSBuildProjectName);label=$(MSBuildProjectName);versionCode=1;versionName=1.0.0;persistent=False;restoreAnyVersion=False;installLocation=preferExternal;largeHeap=False;theme=TitleBar;hardwareAccelerated=true</VerInfo_Keys> + </PropertyGroup> + <PropertyGroup Condition="'$(Base_iOSDevice)'!=''"> + <DCC_UsePackage>rtl;soaprtl;$(DCC_UsePackage)</DCC_UsePackage> + </PropertyGroup> + <PropertyGroup Condition="'$(Base_iOSSimulator)'!=''"> + <DCC_UsePackage>rtl;soaprtl;$(DCC_UsePackage)</DCC_UsePackage> + </PropertyGroup> + <PropertyGroup Condition="'$(Base_Win32)'!=''"> + <DCC_Namespace>Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace)</DCC_Namespace> + <DCC_UsePackage>rtl;vcl;soaprtl;$(DCC_UsePackage)</DCC_UsePackage> + <VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo> + <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=</VerInfo_Keys> + <VerInfo_Locale>1033</VerInfo_Locale> + </PropertyGroup> + <PropertyGroup Condition="'$(Base_Win64)'!=''"> + <DCC_UsePackage>rtl;vcl;soaprtl;$(DCC_UsePackage)</DCC_UsePackage> + </PropertyGroup> + <PropertyGroup Condition="'$(Cfg_1)'!=''"> + <DCC_Define>RELEASE;$(DCC_Define)</DCC_Define> + <DCC_SymbolReferenceInfo>0</DCC_SymbolReferenceInfo> + <DCC_LocalDebugSymbols>false</DCC_LocalDebugSymbols> + <DCC_DebugInformation>0</DCC_DebugInformation> + </PropertyGroup> + <PropertyGroup Condition="'$(Cfg_2)'!=''"> + <DCC_GenerateStackFrames>true</DCC_GenerateStackFrames> + <DCC_Define>DEBUG;$(DCC_Define)</DCC_Define> + <DCC_Optimize>false</DCC_Optimize> + </PropertyGroup> + <ItemGroup> + <DelphiCompile Include="$(MainSource)"> + <MainSource>MainSource</MainSource> + </DelphiCompile> + <DCCReference Include="PaxCompiler.dcr"/> + <DCCReference Include="rtl.dcp"/> + <DCCReference Include="vcl.dcp"/> + <DCCReference Include="soaprtl.dcp"/> + <DCCReference Include="PaxCompilerRegister.pas"/> + <BuildConfiguration Include="Debug"> + <Key>Cfg_2</Key> + <CfgParent>Base</CfgParent> + </BuildConfiguration> + <BuildConfiguration Include="Base"> + <Key>Base</Key> + </BuildConfiguration> + <BuildConfiguration Include="Release"> + <Key>Cfg_1</Key> + <CfgParent>Base</CfgParent> + </BuildConfiguration> + </ItemGroup> + <ProjectExtensions> + <Borland.Personality>Delphi.Personality.12</Borland.Personality> + <Borland.ProjectType>Package</Borland.ProjectType> + <BorlandProject> + <Delphi.Personality> + <Source> + <Source Name="MainSource">paxcomp_xe6.dpk</Source> + </Source> + </Delphi.Personality> + <Platforms> + <Platform value="Android">False</Platform> + <Platform value="iOSDevice">False</Platform> + <Platform value="iOSSimulator">False</Platform> + <Platform value="Win32">True</Platform> + <Platform value="Win64">False</Platform> + </Platforms> + </BorlandProject> + <ProjectFileVersion>12</ProjectFileVersion> + </ProjectExtensions> + <Import Project="$(BDS)\Bin\CodeGear.Delphi.Targets" Condition="Exists('$(BDS)\Bin\CodeGear.Delphi.Targets')"/> + <Import Project="$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj" Condition="Exists('$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj')"/> +</Project> diff --git a/Sources/paxcomp_xe6.otares b/Sources/paxcomp_xe6.otares new file mode 100644 index 0000000..5e952b5 Binary files /dev/null and b/Sources/paxcomp_xe6.otares differ diff --git a/Sources/paxcomp_xe6.res b/Sources/paxcomp_xe6.res new file mode 100644 index 0000000..a64cea3 Binary files /dev/null and b/Sources/paxcomp_xe6.res differ diff --git a/Sources/paxcomp_xe6_x64.dpk b/Sources/paxcomp_xe6_x64.dpk new file mode 100644 index 0000000..b16e390 --- /dev/null +++ b/Sources/paxcomp_xe6_x64.dpk @@ -0,0 +1,40 @@ +package paxcomp_xe6_x64; + +{$R *.res} +{$R *.otares} +{$R 'PaxCompiler.dcr'} +{$IFDEF IMPLICITBUILDING This IFDEF should not be used by users} +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO OFF} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION OFF} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES ON} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$DEFINE DEBUG} +{$ENDIF IMPLICITBUILDING} +{$IMPLICITBUILD ON} + +requires + rtl, + vcl, + soaprtl; + +contains + PaxCompilerRegister in 'PaxCompilerRegister.pas'; + +end. diff --git a/Sources/paxcomp_xe6_x64.dproj b/Sources/paxcomp_xe6_x64.dproj new file mode 100644 index 0000000..ae81c6c --- /dev/null +++ b/Sources/paxcomp_xe6_x64.dproj @@ -0,0 +1,123 @@ +<Project xmlns="http://schemas.microsoft.com/developer/msbuild/2003"> + <PropertyGroup> + <ProjectGuid>{DF1C9D8F-5EDA-4282-A6D4-C064BA18EF69}</ProjectGuid> + <MainSource>paxcomp_xe6_x64.dpk</MainSource> + <Base>True</Base> + <Config Condition="'$(Config)'==''">Debug</Config> + <TargetedPlatforms>3</TargetedPlatforms> + <AppType>Package</AppType> + <FrameworkType>VCL</FrameworkType> + <ProjectVersion>15.4</ProjectVersion> + <Platform Condition="'$(Platform)'==''">Win64</Platform> + </PropertyGroup> + <PropertyGroup Condition="'$(Config)'=='Base' or '$(Base)'!=''"> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="('$(Platform)'=='Android' and '$(Base)'=='true') or '$(Base_Android)'!=''"> + <Base_Android>true</Base_Android> + <CfgParent>Base</CfgParent> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="('$(Platform)'=='Win32' and '$(Base)'=='true') or '$(Base_Win32)'!=''"> + <Base_Win32>true</Base_Win32> + <CfgParent>Base</CfgParent> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="('$(Platform)'=='Win64' and '$(Base)'=='true') or '$(Base_Win64)'!=''"> + <Base_Win64>true</Base_Win64> + <CfgParent>Base</CfgParent> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="'$(Config)'=='Release' or '$(Cfg_1)'!=''"> + <Cfg_1>true</Cfg_1> + <CfgParent>Base</CfgParent> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="'$(Config)'=='Debug' or '$(Cfg_2)'!=''"> + <Cfg_2>true</Cfg_2> + <CfgParent>Base</CfgParent> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="'$(Base)'!=''"> + <DCC_ImageBase>00400000</DCC_ImageBase> + <DCC_Namespace>Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;System;Xml;Data;Datasnap;Web;Soap;$(DCC_Namespace)</DCC_Namespace> + <VerInfo_Locale>1033</VerInfo_Locale> + <GenPackage>true</GenPackage> + <DCC_K>false</DCC_K> + <GenDll>true</GenDll> + <DCC_S>false</DCC_S> + <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=;CFBundleName=</VerInfo_Keys> + <DCC_F>false</DCC_F> + <SanitizedProjectName>paxcomp_xe6_x64</SanitizedProjectName> + <DCC_E>false</DCC_E> + <DCC_N>false</DCC_N> + </PropertyGroup> + <PropertyGroup Condition="'$(Base_Android)'!=''"> + <BT_BuildType>Debug</BT_BuildType> + <VerInfo_Keys>package=com.embarcadero.$(MSBuildProjectName);label=$(MSBuildProjectName);versionCode=1;versionName=1.0.0;persistent=False;restoreAnyVersion=False;installLocation=preferExternal;largeHeap=False;theme=TitleBar;hardwareAccelerated=true</VerInfo_Keys> + </PropertyGroup> + <PropertyGroup Condition="'$(Base_Win32)'!=''"> + <VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo> + <DCC_Namespace>Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace)</DCC_Namespace> + <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=</VerInfo_Keys> + <VerInfo_Locale>1033</VerInfo_Locale> + </PropertyGroup> + <PropertyGroup Condition="'$(Base_Win64)'!=''"> + <DCC_Namespace>Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;$(DCC_Namespace)</DCC_Namespace> + <VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo> + <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=</VerInfo_Keys> + </PropertyGroup> + <PropertyGroup Condition="'$(Cfg_1)'!=''"> + <DCC_Define>RELEASE;$(DCC_Define)</DCC_Define> + <DCC_SymbolReferenceInfo>0</DCC_SymbolReferenceInfo> + <DCC_LocalDebugSymbols>false</DCC_LocalDebugSymbols> + <DCC_DebugInformation>0</DCC_DebugInformation> + </PropertyGroup> + <PropertyGroup Condition="'$(Cfg_2)'!=''"> + <DCC_GenerateStackFrames>true</DCC_GenerateStackFrames> + <DCC_Define>DEBUG;$(DCC_Define)</DCC_Define> + <DCC_Optimize>false</DCC_Optimize> + </PropertyGroup> + <ItemGroup> + <DelphiCompile Include="$(MainSource)"> + <MainSource>MainSource</MainSource> + </DelphiCompile> + <DCCReference Include="PaxCompiler.dcr"/> + <DCCReference Include="rtl.dcp"/> + <DCCReference Include="vcl.dcp"/> + <DCCReference Include="soaprtl.dcp"/> + <DCCReference Include="PaxCompilerRegister.pas"/> + <BuildConfiguration Include="Debug"> + <Key>Cfg_2</Key> + <CfgParent>Base</CfgParent> + </BuildConfiguration> + <BuildConfiguration Include="Base"> + <Key>Base</Key> + </BuildConfiguration> + <BuildConfiguration Include="Release"> + <Key>Cfg_1</Key> + <CfgParent>Base</CfgParent> + </BuildConfiguration> + </ItemGroup> + <ProjectExtensions> + <Borland.Personality>Delphi.Personality.12</Borland.Personality> + <Borland.ProjectType>Package</Borland.ProjectType> + <BorlandProject> + <Delphi.Personality> + <Source> + <Source Name="MainSource">paxcomp_xe6_x64.dpk</Source> + </Source> + </Delphi.Personality> + <Platforms> + <Platform value="Android">False</Platform> + <Platform value="iOSDevice">False</Platform> + <Platform value="iOSSimulator">False</Platform> + <Platform value="Win32">True</Platform> + <Platform value="Win64">True</Platform> + </Platforms> + </BorlandProject> + <ProjectFileVersion>12</ProjectFileVersion> + </ProjectExtensions> + <Import Project="$(BDS)\Bin\CodeGear.Delphi.Targets" Condition="Exists('$(BDS)\Bin\CodeGear.Delphi.Targets')"/> + <Import Project="$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj" Condition="Exists('$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj')"/> +</Project> diff --git a/Sources/paxcomp_xe6_x64.otares b/Sources/paxcomp_xe6_x64.otares new file mode 100644 index 0000000..93e7e94 Binary files /dev/null and b/Sources/paxcomp_xe6_x64.otares differ diff --git a/Sources/paxcomp_xe6_x64.res b/Sources/paxcomp_xe6_x64.res new file mode 100644 index 0000000..27efe49 Binary files /dev/null and b/Sources/paxcomp_xe6_x64.res differ diff --git a/Sources/paxcomp_xe7.dpk b/Sources/paxcomp_xe7.dpk new file mode 100644 index 0000000..a9124e6 --- /dev/null +++ b/Sources/paxcomp_xe7.dpk @@ -0,0 +1,40 @@ +package paxcomp_xe7; + +{$R *.res} +{$R *.otares} +{$R 'PaxCompiler.dcr'} +{$IFDEF IMPLICITBUILDING This IFDEF should not be used by users} +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO OFF} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION OFF} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES ON} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$DEFINE DEBUG} +{$ENDIF IMPLICITBUILDING} +{$IMPLICITBUILD ON} + +requires + rtl, + vcl, + soaprtl; + +contains + PaxCompilerRegister in 'PaxCompilerRegister.pas'; + +end. diff --git a/Sources/paxcomp_xe7.dproj b/Sources/paxcomp_xe7.dproj new file mode 100644 index 0000000..3c6f05a --- /dev/null +++ b/Sources/paxcomp_xe7.dproj @@ -0,0 +1,142 @@ +<Project xmlns="http://schemas.microsoft.com/developer/msbuild/2003"> + <PropertyGroup> + <ProjectGuid>{D3E41B87-1FB2-4838-9992-AEE184233C8B}</ProjectGuid> + <MainSource>paxcomp_xe7.dpk</MainSource> + <Base>True</Base> + <Config Condition="'$(Config)'==''">Debug</Config> + <TargetedPlatforms>1</TargetedPlatforms> + <AppType>Package</AppType> + <FrameworkType>VCL</FrameworkType> + <ProjectVersion>16.0</ProjectVersion> + <Platform Condition="'$(Platform)'==''">Win32</Platform> + </PropertyGroup> + <PropertyGroup Condition="'$(Config)'=='Base' or '$(Base)'!=''"> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="('$(Platform)'=='Android' and '$(Base)'=='true') or '$(Base_Android)'!=''"> + <Base_Android>true</Base_Android> + <CfgParent>Base</CfgParent> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="('$(Platform)'=='iOSDevice' and '$(Base)'=='true') or '$(Base_iOSDevice)'!=''"> + <Base_iOSDevice>true</Base_iOSDevice> + <CfgParent>Base</CfgParent> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="('$(Platform)'=='iOSSimulator' and '$(Base)'=='true') or '$(Base_iOSSimulator)'!=''"> + <Base_iOSSimulator>true</Base_iOSSimulator> + <CfgParent>Base</CfgParent> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="('$(Platform)'=='Win32' and '$(Base)'=='true') or '$(Base_Win32)'!=''"> + <Base_Win32>true</Base_Win32> + <CfgParent>Base</CfgParent> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="('$(Platform)'=='Win64' and '$(Base)'=='true') or '$(Base_Win64)'!=''"> + <Base_Win64>true</Base_Win64> + <CfgParent>Base</CfgParent> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="'$(Config)'=='Release' or '$(Cfg_1)'!=''"> + <Cfg_1>true</Cfg_1> + <CfgParent>Base</CfgParent> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="'$(Config)'=='Debug' or '$(Cfg_2)'!=''"> + <Cfg_2>true</Cfg_2> + <CfgParent>Base</CfgParent> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="'$(Base)'!=''"> + <DCC_F>false</DCC_F> + <SanitizedProjectName>paxcomp_xe7</SanitizedProjectName> + <GenDll>true</GenDll> + <DCC_E>false</DCC_E> + <DCC_S>false</DCC_S> + <GenPackage>true</GenPackage> + <DCC_Namespace>Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;System;Xml;Data;Datasnap;Web;Soap;$(DCC_Namespace)</DCC_Namespace> + <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=;CFBundleName=</VerInfo_Keys> + <DCC_K>false</DCC_K> + <VerInfo_Locale>1033</VerInfo_Locale> + <DCC_N>false</DCC_N> + <DCC_ImageBase>00400000</DCC_ImageBase> + </PropertyGroup> + <PropertyGroup Condition="'$(Base_Android)'!=''"> + <BT_BuildType>Debug</BT_BuildType> + <VerInfo_Keys>package=com.embarcadero.$(MSBuildProjectName);label=$(MSBuildProjectName);versionCode=1;versionName=1.0.0;persistent=False;restoreAnyVersion=False;installLocation=preferExternal;largeHeap=False;theme=TitleBar;hardwareAccelerated=true</VerInfo_Keys> + <DCC_UsePackage>rtl;soaprtl;$(DCC_UsePackage)</DCC_UsePackage> + </PropertyGroup> + <PropertyGroup Condition="'$(Base_iOSDevice)'!=''"> + <DCC_UsePackage>rtl;soaprtl;$(DCC_UsePackage)</DCC_UsePackage> + </PropertyGroup> + <PropertyGroup Condition="'$(Base_iOSSimulator)'!=''"> + <DCC_UsePackage>rtl;soaprtl;$(DCC_UsePackage)</DCC_UsePackage> + </PropertyGroup> + <PropertyGroup Condition="'$(Base_Win32)'!=''"> + <VerInfo_Locale>1033</VerInfo_Locale> + <VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo> + <DCC_Namespace>Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace)</DCC_Namespace> + <DCC_UsePackage>rtl;vcl;soaprtl;$(DCC_UsePackage)</DCC_UsePackage> + <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=</VerInfo_Keys> + </PropertyGroup> + <PropertyGroup Condition="'$(Base_Win64)'!=''"> + <DCC_Namespace>Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;$(DCC_Namespace)</DCC_Namespace> + <VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo> + <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=</VerInfo_Keys> + <DCC_UsePackage>rtl;vcl;soaprtl;$(DCC_UsePackage)</DCC_UsePackage> + </PropertyGroup> + <PropertyGroup Condition="'$(Cfg_1)'!=''"> + <DCC_DebugInformation>0</DCC_DebugInformation> + <DCC_LocalDebugSymbols>false</DCC_LocalDebugSymbols> + <DCC_Define>RELEASE;$(DCC_Define)</DCC_Define> + <DCC_SymbolReferenceInfo>0</DCC_SymbolReferenceInfo> + </PropertyGroup> + <PropertyGroup Condition="'$(Cfg_2)'!=''"> + <DCC_GenerateStackFrames>true</DCC_GenerateStackFrames> + <DCC_Define>DEBUG;$(DCC_Define)</DCC_Define> + <DCC_Optimize>false</DCC_Optimize> + </PropertyGroup> + <ItemGroup> + <DelphiCompile Include="$(MainSource)"> + <MainSource>MainSource</MainSource> + </DelphiCompile> + <DCCReference Include="PaxCompiler.dcr"/> + <DCCReference Include="rtl.dcp"/> + <DCCReference Include="vcl.dcp"/> + <DCCReference Include="soaprtl.dcp"/> + <DCCReference Include="PaxCompilerRegister.pas"/> + <BuildConfiguration Include="Debug"> + <Key>Cfg_2</Key> + <CfgParent>Base</CfgParent> + </BuildConfiguration> + <BuildConfiguration Include="Base"> + <Key>Base</Key> + </BuildConfiguration> + <BuildConfiguration Include="Release"> + <Key>Cfg_1</Key> + <CfgParent>Base</CfgParent> + </BuildConfiguration> + </ItemGroup> + <ProjectExtensions> + <Borland.Personality>Delphi.Personality.12</Borland.Personality> + <Borland.ProjectType>Package</Borland.ProjectType> + <BorlandProject> + <Delphi.Personality> + <Source> + <Source Name="MainSource">paxcomp_xe7.dpk</Source> + </Source> + </Delphi.Personality> + <Platforms> + <Platform value="Android">False</Platform> + <Platform value="iOSDevice">False</Platform> + <Platform value="iOSSimulator">False</Platform> + <Platform value="Win32">True</Platform> + <Platform value="Win64">False</Platform> + </Platforms> + </BorlandProject> + <ProjectFileVersion>12</ProjectFileVersion> + </ProjectExtensions> + <Import Project="$(BDS)\Bin\CodeGear.Delphi.Targets" Condition="Exists('$(BDS)\Bin\CodeGear.Delphi.Targets')"/> + <Import Project="$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj" Condition="Exists('$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj')"/> +</Project> diff --git a/Sources/paxcomp_xe7.otares b/Sources/paxcomp_xe7.otares new file mode 100644 index 0000000..7435995 Binary files /dev/null and b/Sources/paxcomp_xe7.otares differ diff --git a/Sources/paxcomp_xe7.res b/Sources/paxcomp_xe7.res new file mode 100644 index 0000000..a64cea3 Binary files /dev/null and b/Sources/paxcomp_xe7.res differ diff --git a/Sources/paxcomp_xe7_x64.dpk b/Sources/paxcomp_xe7_x64.dpk new file mode 100644 index 0000000..7ffd7f5 --- /dev/null +++ b/Sources/paxcomp_xe7_x64.dpk @@ -0,0 +1,40 @@ +package paxcomp_xe7_x64; + +{$R *.res} +{$R *.otares} +{$R 'PaxCompiler.dcr'} +{$IFDEF IMPLICITBUILDING This IFDEF should not be used by users} +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO OFF} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION OFF} +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES ON} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST OFF} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$DEFINE DEBUG} +{$ENDIF IMPLICITBUILDING} +{$IMPLICITBUILD ON} + +requires + rtl, + vcl, + soaprtl; + +contains + PaxCompilerRegister in 'PaxCompilerRegister.pas'; + +end. diff --git a/Sources/paxcomp_xe7_x64.dproj b/Sources/paxcomp_xe7_x64.dproj new file mode 100644 index 0000000..43f6c5b --- /dev/null +++ b/Sources/paxcomp_xe7_x64.dproj @@ -0,0 +1,123 @@ +<Project xmlns="http://schemas.microsoft.com/developer/msbuild/2003"> + <PropertyGroup> + <ProjectGuid>{8FD9E560-B6A8-4CF9-B8D7-9F74E7A62DE0}</ProjectGuid> + <MainSource>paxcomp_xe7_x64.dpk</MainSource> + <Base>True</Base> + <Config Condition="'$(Config)'==''">Debug</Config> + <TargetedPlatforms>3</TargetedPlatforms> + <AppType>Package</AppType> + <FrameworkType>VCL</FrameworkType> + <ProjectVersion>16.0</ProjectVersion> + <Platform Condition="'$(Platform)'==''">Win64</Platform> + </PropertyGroup> + <PropertyGroup Condition="'$(Config)'=='Base' or '$(Base)'!=''"> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="('$(Platform)'=='Android' and '$(Base)'=='true') or '$(Base_Android)'!=''"> + <Base_Android>true</Base_Android> + <CfgParent>Base</CfgParent> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="('$(Platform)'=='Win32' and '$(Base)'=='true') or '$(Base_Win32)'!=''"> + <Base_Win32>true</Base_Win32> + <CfgParent>Base</CfgParent> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="('$(Platform)'=='Win64' and '$(Base)'=='true') or '$(Base_Win64)'!=''"> + <Base_Win64>true</Base_Win64> + <CfgParent>Base</CfgParent> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="'$(Config)'=='Release' or '$(Cfg_1)'!=''"> + <Cfg_1>true</Cfg_1> + <CfgParent>Base</CfgParent> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="'$(Config)'=='Debug' or '$(Cfg_2)'!=''"> + <Cfg_2>true</Cfg_2> + <CfgParent>Base</CfgParent> + <Base>true</Base> + </PropertyGroup> + <PropertyGroup Condition="'$(Base)'!=''"> + <DCC_F>false</DCC_F> + <SanitizedProjectName>paxcomp_xe7_x64</SanitizedProjectName> + <GenDll>true</GenDll> + <DCC_E>false</DCC_E> + <DCC_S>false</DCC_S> + <GenPackage>true</GenPackage> + <DCC_Namespace>Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;System;Xml;Data;Datasnap;Web;Soap;$(DCC_Namespace)</DCC_Namespace> + <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=;CFBundleName=</VerInfo_Keys> + <DCC_K>false</DCC_K> + <VerInfo_Locale>1033</VerInfo_Locale> + <DCC_N>false</DCC_N> + <DCC_ImageBase>00400000</DCC_ImageBase> + </PropertyGroup> + <PropertyGroup Condition="'$(Base_Android)'!=''"> + <BT_BuildType>Debug</BT_BuildType> + <VerInfo_Keys>package=com.embarcadero.$(MSBuildProjectName);label=$(MSBuildProjectName);versionCode=1;versionName=1.0.0;persistent=False;restoreAnyVersion=False;installLocation=preferExternal;largeHeap=False;theme=TitleBar;hardwareAccelerated=true</VerInfo_Keys> + </PropertyGroup> + <PropertyGroup Condition="'$(Base_Win32)'!=''"> + <VerInfo_Locale>1033</VerInfo_Locale> + <VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo> + <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=</VerInfo_Keys> + <DCC_Namespace>Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace)</DCC_Namespace> + </PropertyGroup> + <PropertyGroup Condition="'$(Base_Win64)'!=''"> + <VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo> + <DCC_Namespace>Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;$(DCC_Namespace)</DCC_Namespace> + <VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=</VerInfo_Keys> + </PropertyGroup> + <PropertyGroup Condition="'$(Cfg_1)'!=''"> + <DCC_DebugInformation>0</DCC_DebugInformation> + <DCC_LocalDebugSymbols>false</DCC_LocalDebugSymbols> + <DCC_Define>RELEASE;$(DCC_Define)</DCC_Define> + <DCC_SymbolReferenceInfo>0</DCC_SymbolReferenceInfo> + </PropertyGroup> + <PropertyGroup Condition="'$(Cfg_2)'!=''"> + <DCC_GenerateStackFrames>true</DCC_GenerateStackFrames> + <DCC_Define>DEBUG;$(DCC_Define)</DCC_Define> + <DCC_Optimize>false</DCC_Optimize> + </PropertyGroup> + <ItemGroup> + <DelphiCompile Include="$(MainSource)"> + <MainSource>MainSource</MainSource> + </DelphiCompile> + <DCCReference Include="PaxCompiler.dcr"/> + <DCCReference Include="rtl.dcp"/> + <DCCReference Include="vcl.dcp"/> + <DCCReference Include="soaprtl.dcp"/> + <DCCReference Include="PaxCompilerRegister.pas"/> + <BuildConfiguration Include="Debug"> + <Key>Cfg_2</Key> + <CfgParent>Base</CfgParent> + </BuildConfiguration> + <BuildConfiguration Include="Base"> + <Key>Base</Key> + </BuildConfiguration> + <BuildConfiguration Include="Release"> + <Key>Cfg_1</Key> + <CfgParent>Base</CfgParent> + </BuildConfiguration> + </ItemGroup> + <ProjectExtensions> + <Borland.Personality>Delphi.Personality.12</Borland.Personality> + <Borland.ProjectType>Package</Borland.ProjectType> + <BorlandProject> + <Delphi.Personality> + <Source> + <Source Name="MainSource">paxcomp_xe7_x64.dpk</Source> + </Source> + </Delphi.Personality> + <Platforms> + <Platform value="Android">False</Platform> + <Platform value="iOSDevice">False</Platform> + <Platform value="iOSSimulator">False</Platform> + <Platform value="Win32">True</Platform> + <Platform value="Win64">True</Platform> + </Platforms> + </BorlandProject> + <ProjectFileVersion>12</ProjectFileVersion> + </ProjectExtensions> + <Import Project="$(BDS)\Bin\CodeGear.Delphi.Targets" Condition="Exists('$(BDS)\Bin\CodeGear.Delphi.Targets')"/> + <Import Project="$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj" Condition="Exists('$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj')"/> +</Project> diff --git a/Sources/paxcomp_xe7_x64.otares b/Sources/paxcomp_xe7_x64.otares new file mode 100644 index 0000000..93e7e94 Binary files /dev/null and b/Sources/paxcomp_xe7_x64.otares differ diff --git a/Sources/paxcomp_xe7_x64.res b/Sources/paxcomp_xe7_x64.res new file mode 100644 index 0000000..27efe49 Binary files /dev/null and b/Sources/paxcomp_xe7_x64.res differ diff --git a/Sources/paxcompiler.dcr b/Sources/paxcompiler.dcr new file mode 100644 index 0000000..4bcc339 Binary files /dev/null and b/Sources/paxcompiler.dcr differ diff --git a/Sources/uses.def b/Sources/uses.def new file mode 100644 index 0000000..c72e3b7 --- /dev/null +++ b/Sources/uses.def @@ -0,0 +1,58 @@ +{$IFDEF MACOS} + {$DEFINE FMX} +{$ENDIF} +{$IFDEF ANDROID} + {$DEFINE FMX} +{$ENDIF} + +{$IFDEF LINUX} + {$IFDEF FPC} + DynLibs, + uuid, // in hash folder + {$ELSE} + QForms, + {$ENDIF} +{$ENDIF} + +{$IFDEF MSWINDOWS} + {$IFDEF DPULSAR} + Winapi.Windows, + Winapi.Messages, + System.Win.ComObj, + Winapi.ActiveX, + {$IFDEF FMX} + Fmx.Forms, + Fmx.Dialogs, + {$ELSE} + Vcl.Forms, + Vcl.Dialogs, + {$ENDIF} + {$ELSE} + Windows, + Messages, + {$IFNDEF FPC} + Forms, + Dialogs, + {$ENDIF} + ComObj, + ActiveX, + {$ENDIF} +{$ENDIF} + + {$IFDEF MACOS} + Fmx.Forms, + Fmx.Dialogs, + {$ENDIF} + + {$IFDEF ANDROID} + Fmx.Forms, + Fmx.Dialogs, + {$ENDIF} + + {$IFDEF VARIANTS} + Variants, + {$ENDIF} + + {$IFDEF ARC} + System.Generics.Collections, + {$ENDIF} diff --git a/help/about.htm b/help/about.htm new file mode 100644 index 0000000..8754e50 --- /dev/null +++ b/help/about.htm @@ -0,0 +1,112 @@ +<html> +<head> +<link rel=stylesheet type="text/css" href="styles.css"> +</head> +<body> + + +<font face="Arial, Helvetica"> + +<h4>What's New</h4> + +<ul> + +<li><font color="red"><b>24 June 2014. paxCompiler v4.0. Support of Android and iOS Device platforms.</b></font> + +<ul> +<li>Consequently, paxCompiler is running on all platforms supported by Delphi XE6. +</ul> + +<li> +<font color="red"><b>29 May 2014. paxCompiler Importer, v1.1.</b></font> +<ul> +<li>You can use importer in batch files. +<li>Thread-safe import of global members of Delphi units. +<li>Bug fixes. +</ul> +<li> +<font color="red"><b>14 May 2014. paxCompiler Importer, v1.0</b></font> +<A HREF="http://www.paxcompiler.com/importer.htm">paxCompiler importer</A> (paxImp.exe) is a freeware program that generates +import units from source code units of your application, +so all members defined in your application become accessible +for your paxCompiler scripts. You can create import files for all Delphi +versions starting with Delphi 5 (D5, D6, D7, ..., XE5, XE6). (<A HREF="http://www.paxcompiler.com/importer.htm">More...</A>) + +<li><font color="red"><b>20 April 2014. paxCompiler v3.2.3. +</b></font> +<ul> +<li> Support of Delphi XE6. +<li> Support of CentOS Linux 32-bit. +<li> Added properties OnVirtualObjectMethodCall, OnVirtualObjectPutProperty to +TPaxRunner class. +<li> Added events to Pascal parser. You can parse interface part +of XE5-XE6 units. +<li> Improvements and bug fixes in JavaScript implementation. + +</ul> + + +<li> +<font color="red"><b>9 January 2014. paxCompiler, v3.2.2. Support of iOS Simulator. +</b></font> + + + +<li> +<font color="red"><b>28 October 2013. Mac OS support for paxCompiler/paxInterpreter. </b></font> + +<li> +<font color="red"><b>22 October 2013. paxCompiler, v3.2.1. </b></font> + +<ul> +<li>Automatic import of Delphi units (Delphi XE2-XE5). +<li>Support of Free Pascal 2.6.2 and Lazarus (Win32/Win64). +</ul> + +<li> +<font color="red"><b>22 September 2013. paxCompiler, v3.2. Cross-platform paxInterpreter.</b></font> + +<h2> +About paxCompiler +</h2> +<hr> + +paxCompiler is an embedable compiler of the Object Pascal, Basic and JavaScript programming languages. The key features of the paxCompiler are: + +<ul TYPE=CIRCLE> + +<li>The compiler generates machine code for Intel compatible processors (IA-32/64 architecture). +<li>The second script runner is a cross-platform interpreter based on intermediate code. Supported platforms are Win32/Win64, Linux, Android, Mac OS, iOS Simulator, iOS Device. +<li>The compiler is written in Delphi and it is compatible with Free Pascal/Lazarus 32/64 bit. +<li>It is possible to use the compiler as a scripting engine, so you can customize and extend the application without having to recompile it. +<li>The compiler supports Object Pascal language based on the Delphi 7 standard and extends it with +generic types, operator overloading, anonymous functions and closures, lambda-expressions. +Syntax of Basic language is similar to VB.NET. JavaScript implementation is based on ECMA-262 standard. +<li>Cross-language programming support. You can use Pascal units in Basic and JavaScript programs and vice versa. +<li>COM support. +<li>paxCompiler components allows you to implement debugger and code explorer. +<li>Script-defined types support run-time information (RTTI). +<li>You can bind instances of script-defined classes with dfm files. +<li>You can import host-defined types with paxCompiler importer. Automatic import of host-defined types is available for Delphi XE2-XE5. +<li>You can create stand alone executable files and dlls. +<li>Support of compiled units and run-time packages. +<li>paxCompiler engine is thread safe. +<li>The roadmap of the compiler includes: Java compiler, C++ compiler, built-in assembler. + +</ul> + +<H3>Feedback</H3> + +<A HREF="mailto:paxscript@gmail.com">paxscript@gmail.com</A>. +<p> +<i>Alexander Baranovsky, CEO of VIRT Laboratory.</i> +</p> + +<p> +<HR> +<font size = 1 color ="gray"> +Copyright © 2006-2014 +VIRT Laboratory. All rights reserved. +</font> +</body> +</html> diff --git a/help/about.jpg b/help/about.jpg new file mode 100644 index 0000000..6cbed4c Binary files /dev/null and b/help/about.jpg differ diff --git a/help/awards.htm b/help/awards.htm new file mode 100644 index 0000000..f050756 --- /dev/null +++ b/help/awards.htm @@ -0,0 +1,278 @@ +<html> +<html> +<head> +<link rel=stylesheet type="text/css" href="styles.css"> +</head> +<body> +<H2> +paxCompiler Awards +</H2> +<hr> + + +<table> + +<tr> + +<td> +<a href='http://www.filesrepository.com/preview/virt-laboratory/paxcompiler.html'><img src='award.gif' border=0 width="131"></a> +</td> + +<td> +<p> +<!-- ------Start Cut Here----- --> +<a href="http://www.bluesofts.com/download/371/34283/paxCompiler.html"> +<img border="0" src="http://www.bluesofts.com/images/5starsaward.gif" alt=" : 5 Stars Award at bluesofts.com !" width="131" height="70"></a> +<!-- ------End Cut Here----- --> +</td> + +<td> +<a href="http://www.freesharewarecenter.com/paxCompiler-42409.html"><img src="http://www.freesharewarecenter.com/shareaward.gif" border=0 width="131"></a> +</td> + + + + + + + + +<tr> + +<td> +<a href="http://www.maxxdownload.com/paxCompiler.html" target="_blank"><img src="5starsaward_max.gif" alt="Rated by 5 points award on maxxdownload.com" border="0" width="131"></a> +</td> + +<td> +<a href='http://www.freewarelive.com'><img src='http://www.freewarelive.com/banners/5flive.jpg' border=0 width="131"></a> +</td> + +<td> +<a href="http://www.downloadready.com/dl/download_39954.htm" target="_blank"><img src="http://www.downloadready.com/images/dr-5.png" alt="Rated by 5 points award on download ready" border="0" width="131"></a> +</td> + + +</tr> + + + + +<tr> + +<td> +<a href="http://www.shareware-list.com/download-258-42688.html" target="_blank"><img src="5stars.gif" alt="Rated by 5 points award on shareware-list.com" border="0" width="131"></a> +</td> + +<td> +<a href="http://www.softsland.com/paxCompiler.html" target="_blank"><img src="award5stars_softsland.gif" alt="Rated by 5 points award on softiland.com" border="0" width="131"></a> +</td> + + +<td> +<a href="http://www.dailysofts.com/program/970/34139/paxCompiler.html" target="_blank"><img src="5starsaward.gif" alt="Rated by 5 points award on dailysofts.com" border="0" width="131"></a> +</td> + +</tr> + + + + + + + + + +<tr> + +<td> +<a href="http://www.downloadsofts.com/download/Development/Compilers-Interpreters/paxCompiler-download-details.html" target="_blank"><img src="award_paxCompiler.png" alt="Rated by 5 points award on downloadsofts.com" border="0" width="131"></a> +</td> + +<td> +<!-- ------Start Cut Here----- --> +<a href="http://www.softs.info/download/83/40117/paxCompiler.html"> +<img border="0" src="http://www.softs.info/5stars.gif" alt=" : 5 Stars Award at SOFTS.info !" width="151" height="70"></a> +<!-- ------End Cut Here----- --> +</td> + + +<td> +<a href="<a href="http://www.vista-files.org/programs/virt-laboratory/paxcompiler.html" target="_blank"><img src="award_200.jpg" alt="Rated by 5 points award on wistafiles.com" border="0" width="131"></a> +</td> + +</tr> + + +<tr> + +<td> +<a href="http://www.bestvistadownloads.com/software/t-free-paxcompiler-download-gkfjtlwq.html" target="_blank"><img src="award_5.gif" alt="Rated by 5 points award on bestvistadownloads.com" border="0" width="131"></a> +</td> + +<td> +<a href="http://www.efreedown.com/soft_160771.html" target="_blank"><img src="pick.gif" alt="Rated by 5 points award on EfreeDown.com" border="0" width="131"></a> +</td> + + +<td> +<a href="http://www.download25.com/paxcompiler-download.html"><img src="http://www.download25.com/media/awards/5stars.jpg" border="0" alt="5 stars award from www.download25.com"></a> + + +</td> + +</tr> + + +<!--------------------------------> + +<tr> + +<td> +<!-- Discoveres Award HTML Codes Begin --> +<a href='http://www.discoveres.com' target='_blank'><img src='http://www.discoveres.com/paxCompiler_SRIAL_43221.jpg' alt='Cool award from Discoveres.com' border='0'></a> +<!-- Discoveres Award HTML Codes End --> +</td> + +<td> +<a href="http://www.downloadmost.com/shareware/software/?paxCompiler-6582.html"><img src="5star-2.gif" border="0" alt="5 stars award from www.downloadmost.com"></a> +</td> + + +<td> +<a href=" http://www.gtdownload.com/free-download/Development-category/Compilers-Interpreters-subcategory/paxCompiler-view-details.html"> +<img src=" http://www.gtdownload.com/free-download/images/award_paxCompiler.jpg" border="0" alt="5 stars award from www.gtdownload.com"></a> +</td> + +</tr> + +<!--------------------------------> + + + + +<!--------------------------------> + +<tr> + +<td> +<a href=" http://www.filehungry.com/english/product/windows_software/programming/delphi_utilities/paxcompiler"><img src="http://www.filehungry.com/resources/logo/5star_2.gif" border="0" alt="5 stars award from www.filehungry.com"></a> +</td> + +<td> +<a href="http://rbytes.net/software/paxcompiler-review/"><img src="http://static.rbytes.net/awards/5.gif" border="0" alt="5 stars award from rbytes.net"></a> +</td> + + +<td> + +<a href="http://www.downloadfast.net/download6957.html" target=new><img src="http://www.downloadfast.net/5star_dlfast.jpg" border=0></a></td></tr><tr><td><a href="http://www.downloadfast.net" target=new></a> + +</td> +</tr> + +<!--------------------------------> + + +<tr> + +<td> +<a href="http://www.softarea51.com/windows/Development_Tools/Compilers_Interpreters/Review-paxCompiler.html" target="_blank"> +<img src="softarea51_award_b.gif" border="0" alt="5 stars award from www.softarea51.com"></a> +</td> + +<td> +<a href="http://www.downloadpipe.com/review_877921.html" title="paxCompiler awarded + 5 Stars at the DownloadPipe Software Library"> + <img border="0" src="http://www.downloadpipe.com/images/5star.gif" width="90" height="106"></a> +</td> + +<td> +<a href="http://www.fileaward.com/Software-Development/Compilers-Interpreters/paxcompiler.html"><img border="0" src="http://www.fileaward.com/images/award_150x75.gif" width="150" height="75"></a> +</td> + +<tr> + +<!--------------------------------> + + +<tr> + +<td> +<a href="http://www.seek4software.com/software-info/5126_paxcompiler.html" target="_blank"> +<img src="seek4award_5.gif" border="0" alt="5 stars award from www.see4software.com"></a> +</td> + +<td> +<a href="http://www.bestsoftware4download.com/software/t-free-paxcompiler-download-exumxgnp.html" target="_blank"> +<img src="BS4D_rate5.png" alt="Best Software Downloads" border="0"/></a> + +</td> + +<td> +<a href="http://www.bestsoftdownload.com/download7060.html" target=new><img src="http://www.bestsoftdownload.com/images/editor.jpg" border=0></a> +</td> + +<tr> + + + +<tr> + +<td> +<a href="http://www.best-software4u.com/download7060.html" target=new><img src="http://www.best-software4u.com/images/editor.jpg" border=0></a> +</td> + +<td> +<a href="http://www.dlguide.net/download7060.html" target=new><img src="http://www.dlguide.net/images/cool.jpg" border=0></a> +</td> + +<td> +<a href="http://www.freevistafiles.com/VIRT-Laboratory+paxCompiler.html"><img src="http://www.freevistafiles.com/images/freevistafiles_5st_award_160x80.png" border="0" alt="paxCompiler Best download"></a> +</td> + +<tr> + +<tr> + +<td> +<a href="http://www.soft4each.com/download7060.html" target=new><img src="http://www.soft4each.com/images/award.gif" border=0></a> +</td> + +<td> +<a href="http://www.softsoft.ru/development/compilers-interpreters/27830.htm"><img src="http://www.softsoft.ru/images/award5stars.gif" border="0" alt="5 stars award from www.softsoft.ru"></a> +</td> + +<td> +<a href="http://paxcompiler.lastdownload.com/"><img src="http://www.lastdownload.com/graphics/5StarAward.gif" border="0" width="120" height="65"> </a> +</td> + + +<tr> + +<td> +<a href="http://www.trialware3k.com.com/download7060.html" target=new><img src="http://www.trialware3k.com/images/5star.gif" border=0></a> +</td> + +<td> +<a href="http://www.geardownload.com/development/paxcompiler.html" target=new><img src="http://www.geardownload.com/images/5starsc.jpg" border=0></a> +</td> + +<td> +<a href="http://www.top4download.com/" target="_blank"><img src="http://www.top4download.com/templates/T4D/images/award_5.gif" alt="Top 4 Download" border="0"/></a> +</td> + + +<tr> + + +</table> + +<p> +<HR> +<font size = 1 color ="gray"> +Copyright © 2006-2009 +VIRT Laboratory. All rights reserved. +</font> +</body> +</html> +<html> diff --git a/help/basic_class_types.htm b/help/basic_class_types.htm new file mode 100644 index 0000000..4ea9d31 --- /dev/null +++ b/help/basic_class_types.htm @@ -0,0 +1,61 @@ +<html> +<head> +<link rel=stylesheet type="text/css" href="styles.css"> +</head> +<body> +<H2> +Basic samples. Class types. +</H2> +<hr> + + +<blockquote> +<pre> + +<font color="blue"><b>Imports</b></font> Classes + +<font color="blue"><b>Class</b></font> MyStrings + + <font color="blue"><b>Inherits</b></font> TStringList + + <font color="blue"><b>Private</b></font> fLastPos <font color="blue"><b>As</b></font> <font color="blue"><b>Integer</b></font> = -1 + + <font color="blue"><b>Public</b></font> Overrides <font color="blue"><b>Function</b></font> IndexOf(S <font color="blue"><b>As</b></font> <font color="blue"><b>String</b></font>) <font color="blue"><b>As</b></font> <font color="blue"><b>Integer</b></font> + fLastPos = <font color="blue"><b>MyBase</b></font>.IndexOf(S) + <font color="blue"><b>return</b></font> fLastPos + <font color="blue"><b>End</b></font> <font color="blue"><b>Function</b></font> + + <font color="blue"><b>Public</b></font> <font color="blue"><b>Property</b></font> LastPos + <font color="blue"><b>Get</b></font> + <font color="blue"><b>return</b></font> fLastPos + <font color="blue"><b>End</b></font> <font color="blue"><b>Get</b></font> + <font color="blue"><b>End</b></font> <font color="blue"><b>Property</b></font> +<font color="blue"><b>End</b></font> <font color="blue"><b>Class</b></font> + +<font color="blue"><b>Dim</b></font> l <font color="blue"><b>As</b></font> MyStrings = <font color="blue"><b>New</b></font> MyStrings() +<font color="blue"><b>Dim</b></font> P <font color="blue"><b>As</b></font> <font color="blue"><b>Integer</b></font> +<font color="blue"><b>Try</b></font> + l.Add(<font color="Red">"abc"</font>) + l.Add(<font color="Red">"pqr"</font>) + l.Add(<font color="Red">"xyz"</font>) + <font color="blue"><b>println</b></font> l.LastPos + P = l.IndexOf(<font color="Red">"pqr"</font>) + <font color="blue"><b>println</b></font> P + <font color="blue"><b>println</b></font> l.LastPos +<font color="blue"><b>Finally</b></font> + l.Free +<font color="blue"><b>End</b></font> <font color="blue"><b>Try</b></font> + + +</pre> +</blockquote> + + +<p> +<HR> +<font size = 1 color ="gray"> +Copyright © 2006-2009 +VIRT Laboratory. All rights reserved. +</font> +</body> +</html> diff --git a/help/basic_exception.htm b/help/basic_exception.htm new file mode 100644 index 0000000..1e2dc49 --- /dev/null +++ b/help/basic_exception.htm @@ -0,0 +1,36 @@ +<html> +<head> +<link rel=stylesheet type="text/css" href="styles.css"> +</head> +<body> +<H2> +Basic samples. Exception handling. +</H2> +<hr> + + +<blockquote> +<pre> + +<font color="blue"><b>Imports</b></font> SysUtils +<font color="blue"><b>Dim</b></font> X <font color="blue"><b>As</b></font> single = 0 +<font color="blue"><b>Try</b></font> + X = X / X + <font color="blue"><b>Catch</b></font> E <font color="blue"><b>As</b></font> Exception + <font color="blue"><b>println</b></font> E.Message + <font color="blue"><b>Finally</b></font> + <font color="blue"><b>println</b></font> <font color="Red">"ok"</font> +<font color="blue"><b>End</b></font> <font color="blue"><b>Try</b></font> + +</pre> +</blockquote> + + +<p> +<HR> +<font size = 1 color ="gray"> +Copyright © 2006-2009 +VIRT Laboratory. All rights reserved. +</font> +</body> +</html> diff --git a/help/basic_gui.htm b/help/basic_gui.htm new file mode 100644 index 0000000..aa79615 --- /dev/null +++ b/help/basic_gui.htm @@ -0,0 +1,59 @@ +<html> +<head> +<link rel=stylesheet type="text/css" href="styles.css"> +</head> +<body> +<H2> +Basic samples. Simple GUI application. +</H2> +<hr> + + +<blockquote> +<pre> + +<font color="blue"><b>Imports</b></font> Controls, StdCtrls, Forms, Dialogs +<font color="blue"><b>Class</b></font> MyForm + <font color="blue"><b>Inherits</b></font> TForm + + <font color="blue"><b>Published</b></font> Button1 <font color="blue"><b>As</b></font> TButton + + <font color="blue"><b>Sub</b></font> Button1Click(Sender <font color="blue"><b>As</b></font> TObject) + ShowMessage(<font color="Red">"Hello!"</font>) + <font color="blue"><b>End</b></font> <font color="blue"><b>Sub</b></font> + + <font color="blue"><b>Sub</b></font> <font color="blue"><b>New</b></font> + <font color="blue"><b>MyBase</b></font>.Create(<font color="blue"><b>null</b></font>) + Caption = <font color="Red">"My second paxCompiler GUI Application"</font> + Button1 = <font color="blue"><b>New</b></font> TButton(<font color="blue"><b>Me</b></font>) + <font color="blue"><b>With</b></font> Button1 + .Parent = <font color="blue"><b>Me</b></font> + .Caption = <font color="Red">"Click Me"</font> + .Name = <font color="Red">"Button1"</font> + .Left = 10 + .Top = 20 + .OnClick = Button1Click + <font color="blue"><b>End</b></font> <font color="blue"><b>With</b></font> + <font color="blue"><b>End</b></font> <font color="blue"><b>Sub</b></font> + +<font color="blue"><b>End</b></font> <font color="blue"><b>Class</b></font> + +<font color="blue"><b>Dim</b></font> F <font color="blue"><b>As</b></font> MyForm = <font color="blue"><b>New</b></font> MyForm +<font color="blue"><b>Try</b></font> + F.ShowModal +<font color="blue"><b>Finally</b></font> + F.Free +<font color="blue"><b>End</b></font> <font color="blue"><b>Try</b></font> + +</pre> +</blockquote> + + +<p> +<HR> +<font size = 1 color ="gray"> +Copyright © 2006-2009 +VIRT Laboratory. All rights reserved. +</font> +</body> +</html> diff --git a/help/basic_interface_types.htm b/help/basic_interface_types.htm new file mode 100644 index 0000000..9ee022e --- /dev/null +++ b/help/basic_interface_types.htm @@ -0,0 +1,51 @@ +<html> +<head> +<link rel=stylesheet type="text/css" href="styles.css"> +</head> +<body> +<H2> +Basic samples. Interface types. +</H2> +<hr> + + +<blockquote> +<pre> + +<font color="blue"><b>Interface</b></font> IMyInterface + <font color="blue"><b>Sub</b></font> P(X <font color="blue"><b>As</b></font> <font color="blue"><b>Integer</b></font>, Y <font color="blue"><b>As</b></font> <font color="blue"><b>Integer</b></font>) +<font color="blue"><b>End</b></font> <font color="blue"><b>Interface</b></font> + +<font color="blue"><b>Class</b></font> TMyClass + + <font color="blue"><b>Inherits</b></font> TInterfacedObject, IMyInterface + + <font color="blue"><b>Sub</b></font> P(X <font color="blue"><b>As</b></font> <font color="blue"><b>Integer</b></font>, Y <font color="blue"><b>As</b></font> <font color="blue"><b>Integer</b></font>) + <font color="blue"><b>println</b></font> <font color="blue"><b>Me</b></font>.ClassName + <font color="blue"><b>println</b></font> X, <font color="Red">" "</font>, Y + <font color="blue"><b>End</b></font> <font color="blue"><b>Sub</b></font> + + <font color="blue"><b>Sub</b></font> Finalize + <font color="blue"><b>println</b></font> <font color="Red">"Done"</font> + <font color="blue"><b>MyBase</b></font>.Destroy + <font color="blue"><b>End</b></font> <font color="blue"><b>Sub</b></font> + +<font color="blue"><b>End</b></font> <font color="blue"><b>Class</b></font> + +<font color="blue"><b>Dim</b></font> X <font color="blue"><b>As</b></font> TMyClass = <font color="blue"><b>New</b></font> TMyClass +<font color="blue"><b>Dim</b></font> I <font color="blue"><b>As</b></font> IMyInterface = X +I.P(3, 4) + + +</pre> +</blockquote> + + +<p> +<HR> +<font size = 1 color ="gray"> +Copyright © 2006-2009 +VIRT Laboratory. All rights reserved. +</font> +</body> +</html> diff --git a/help/basic_structure_types.htm b/help/basic_structure_types.htm new file mode 100644 index 0000000..6b8e6fc --- /dev/null +++ b/help/basic_structure_types.htm @@ -0,0 +1,59 @@ +<html> +<head> +<link rel=stylesheet type="text/css" href="styles.css"> +</head> +<body> +<H2> +Basic samples. Structure types. +</H2> +<hr> + + +<blockquote> +<pre> +<font color="blue"><b>Structure</b></font> MyStruct + <font color="blue"><b>Public</b></font> S <font color="blue"><b>As</b></font> <font color="blue"><b>String</b></font> + <font color="blue"><b>Public</b></font> Y <font color="blue"><b>As</b></font> <font color="blue"><b>Integer</b></font> = 5 + <font color="blue"><b>Public</b></font> Z(10) <font color="blue"><b>As</b></font> <font color="blue"><b>Double</b></font> + + <font color="blue"><b>Sub</b></font> <font color="blue"><b>New</b></font> + <font color="blue"><b>Dim</b></font> I <font color="blue"><b>As</b></font> <font color="blue"><b>Integer</b></font> + <font color="blue"><b>For</b></font> I = 0 <font color="blue"><b>to</b></font> Length(Z) - 1 + Z(I) = I + <font color="blue"><b>Next</b></font> + S = <font color="Red">"abbcabbcc"</font> + <font color="blue"><b>End</b></font> <font color="blue"><b>Sub</b></font> + + <font color="blue"><b>Sub</b></font> Finalize + <font color="blue"><b>println</b></font> <font color="Red">"Done"</font> + <font color="blue"><b>End</b></font> <font color="blue"><b>Sub</b></font> + + <font color="blue"><b>Function</b></font> CountB() <font color="blue"><b>As</b></font> <font color="blue"><b>Integer</b></font> + <font color="blue"><b>Dim</b></font> I <font color="blue"><b>As</b></font> <font color="blue"><b>Integer</b></font>, Result <font color="blue"><b>As</b></font> <font color="blue"><b>Integer</b></font> = 0 + <font color="blue"><b>For</b></font> I = 1 <font color="blue"><b>to</b></font> Length(S) + <font color="blue"><b>If</b></font> S[I] = <font color="Red">"b"</font> <font color="blue"><b>Then</b></font> + result += 1 + <font color="blue"><b>End</b></font> <font color="blue"><b>If</b></font> + <font color="blue"><b>Next</b></font> + <font color="blue"><b>Return</b></font> Result + <font color="blue"><b>End</b></font> <font color="blue"><b>Function</b></font> + +<font color="blue"><b>End</b></font> <font color="blue"><b>Structure</b></font> + +<font color="blue"><b>Dim</b></font> P <font color="blue"><b>As</b></font> MyStruct +<font color="blue"><b>println</b></font> P.Y +<font color="blue"><b>println</b></font> P.Z(4) +<font color="blue"><b>println</b></font> Length(P.Z) +<font color="blue"><b>println</b></font> P.CountB() +</pre> +</blockquote> + + +<p> +<HR> +<font size = 1 color ="gray"> +Copyright © 2006-2009 +VIRT Laboratory. All rights reserved. +</font> +</body> +</html> diff --git a/help/demo_access_script_vars.htm b/help/demo_access_script_vars.htm new file mode 100644 index 0000000..870b7e1 --- /dev/null +++ b/help/demo_access_script_vars.htm @@ -0,0 +1,89 @@ +<html> +<head> +<link rel=stylesheet type="text/css" href="styles.css"> +</head> +<body> +<H2> +paxCompiler for Delphi. Access to script-defined variables. +</H2> +<hr> + +<blockquote> +<pre> +<font color="blue"><b>unit</b></font> Unit1; + +<font color="blue"><b>interface</b></font> + +<font color="blue"><b>uses</b></font> + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, PaxCompiler, PaxProgram; +<font color="blue"><b>type</b></font> + TForm1 = <font color="blue"><b>class</b></font>(TForm) + PaxCompiler1: TPaxCompiler; + PaxPascalLanguage1: TPaxPascalLanguage; + PaxProgram1: TPaxProgram; + Button1: TButton; + <font color="blue"><b>procedure</b></font> Button1Click(Sender: TObject); + <font color="blue"><b>private</b></font> + { Private declarations } + <font color="blue"><b>public</b></font> + { Public declarations } + <font color="blue"><b>end</b></font>; + +<font color="blue"><b>var</b></font> + Form1: TForm1; + +<font color="blue"><b>implementation</b></font> + +{$R *.dfm} + +<font color="blue"><b>procedure</b></font> TForm1.Button1Click(Sender: TObject); +<font color="blue"><b>var</b></font> + H_X: Integer; + P: Pointer; + I: Integer; +<font color="blue"><b>begin</b></font> + {$O-} + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + + PaxCompiler1.RegisterHeader(0, <font color="Red">'procedure ShowMessage(const Msg: string);'</font>, @ShowMessage); + PaxCompiler1.RegisterHeader(0, <font color="Red">'function IntToStr(Value: Integer): string;'</font>, @IntToStr); + + PaxCompiler1.AddModule(<font color="Red">'1'</font>, PaxPascalLanguage1.LanguageName); + PaxCompiler1.AddCode(<font color="Red">'1'</font>, <font color="Red">'var x: Integer = 5;'</font>); + PaxCompiler1.AddCode(<font color="Red">'1'</font>, <font color="Red">'begin'</font>); + PaxCompiler1.AddCode(<font color="Red">'1'</font>, <font color="Red">' ShowMessage('</font><font color="Red">'script:'</font><font color="Red">' + IntToStr(x));'</font>); + PaxCompiler1.AddCode(<font color="Red">'1'</font>, <font color="Red">'end.'</font>); + + <font color="blue"><b>if</b></font> PaxCompiler1.Compile(PaxProgram1) <font color="blue"><b>then</b></font> + <font color="blue"><b>begin</b></font> + H_X := PaxCompiler1.GetHandle(0, <font color="Red">'x'</font>, true); + PaxProgram1.Run; // the first run + <font color="blue"><b>if</b></font> H_X <> 0 <font color="blue"><b>then</b></font> + <font color="blue"><b>begin</b></font> + P := PaxProgram1.GetAddress(H_X); + ShowMessage(<font color="Red">'host:'</font> + IntToStr(Integer(P^))); // show script-defined var + <font color="blue"><b>end</b></font>; + Integer(P^) := 30; // change script-defind variable + PaxProgram1.Run; // the second run + <font color="blue"><b>end</b></font> + <font color="blue"><b>else</b></font> + <font color="blue"><b>for</b></font> I:=0 <font color="blue"><b>to</b></font> PaxCompiler1.ErrorCount <font color="blue"><b>do</b></font> + ShowMessage(PaxCompiler1.ErrorMessage[I]); +<font color="blue"><b>end</b></font>; + +<font color="blue"><b>end</b></font>. +</pre> +</blockquote> + + + +<p> +<HR> +<font size = 1 color ="gray"> +Copyright © 2006-2009 +VIRT Laboratory. All rights reserved. +</font> +</body> +</html> diff --git a/help/demo_call_routine.htm b/help/demo_call_routine.htm new file mode 100644 index 0000000..080f63d --- /dev/null +++ b/help/demo_call_routine.htm @@ -0,0 +1,100 @@ +<html> +<head> +<link rel=stylesheet type="text/css" href="styles.css"> +</head> +<body> +<H2> +paxCompiler for Delphi. Call a script-defined procedure. +</H2> +<hr> + +<blockquote> + +<pre> +<font color="blue"><b>unit</b></font> Unit1; + +<font color="blue"><b>interface</b></font> + +<font color="blue"><b>uses</b></font> + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, PaxCompiler; + +<font color="blue"><b>type</b></font> + TForm1 = <font color="blue"><b>class</b></font>(TForm) + PaxCompiler1: TPaxCompiler; + PaxPascalLanguage1: TPaxPascalLanguage; + PaxProgram1: TPaxProgram; + Button1: TButton; + <font color="blue"><b>procedure</b></font> Button1Click(Sender: TObject); + <font color="blue"><b>procedure</b></font> FormCreate(Sender: TObject); + <font color="blue"><b>private</b></font> + Y: Integer; + { <font color="blue"><b>Private</b></font> declarations } + <font color="blue"><b>public</b></font> + { <font color="blue"><b>Public</b></font> declarations } + <font color="blue"><b>end</b></font>; + +<font color="blue"><b>var</b></font> + Form1: TForm1; + +<font color="blue"><b>implementation</b></font> + +{$R *.dfm} + +// declare procedural type that conforms to a script-defined procedure +<font color="blue"><b>type</b></font> + TProcP = <font color="blue"><b>procedure</b></font> (X: Integer); <font color="blue"><b>stdcall</b></font>; + +<font color="blue"><b>procedure</b></font> TForm1.Button1Click(Sender: TObject); +<font color="blue"><b>var</b></font> + H_Y, H_P: Integer; + I: Integer; + P: Pointer; +<font color="blue"><b>begin</b></font> + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + + H_Y := PaxCompiler1.RegisterVariable(0, <font color="Red">'Y'</font>, _typeINTEGER); + + PaxCompiler1.AddModule(<font color="Red">'1'</font>, PaxPascalLanguage1.LanguageName); + PaxCompiler1.AddCode(<font color="Red">'1'</font>, <font color="Red">'procedure P(X: Integer);'</font>); + PaxCompiler1.AddCode(<font color="Red">'1'</font>, <font color="Red">'begin'</font>); + PaxCompiler1.AddCode(<font color="Red">'1'</font>, <font color="Red">' Y := Y + X;'</font>); + PaxCompiler1.AddCode(<font color="Red">'1'</font>, <font color="Red">'end;'</font>); + PaxCompiler1.AddCode(<font color="Red">'1'</font>, <font color="Red">'begin'</font>); + PaxCompiler1.AddCode(<font color="Red">'1'</font>, <font color="Red">'end.'</font>); + + <font color="blue"><b>if</b></font> PaxCompiler1.Compile(PaxProgram1) <font color="blue"><b>then</b></font> + <font color="blue"><b>begin</b></font> + H_P := PaxCompiler1.GetHandle(0, <font color="Red">'P'</font>, true); + P := PaxProgram1.GetAddress(H_P); // get address of script-defined procedure + PaxProgram1.SetAddress(H_Y, @Y); + + TProcP(P)(10); + ShowMessage(IntToStr(Y)); + + TProcP(P)(20); + ShowMessage(IntToStr(Y)); + <font color="blue"><b>end</b></font> + <font color="blue"><b>else</b></font> + <font color="blue"><b>for</b></font> I:=0 <font color="blue"><b>to</b></font> PaxCompiler1.ErrorCount <font color="blue"><b>do</b></font> + ShowMessage(PaxCompiler1.ErrorMessage[I]); +<font color="blue"><b>end</b></font>; + +<font color="blue"><b>procedure</b></font> TForm1.FormCreate(Sender: TObject); +<font color="blue"><b>begin</b></font> + Y := 0; +<font color="blue"><b>end</b></font>; + +<font color="blue"><b>end</b></font>. +</pre> +</blockquote> + +<p> +<HR> +<font size = 1 color ="gray"> +Copyright © 2006-2009 +VIRT Laboratory. All rights reserved. +</font> +</body> +</html> diff --git a/help/demo_call_routine_ex.htm b/help/demo_call_routine_ex.htm new file mode 100644 index 0000000..1ffb96d --- /dev/null +++ b/help/demo_call_routine_ex.htm @@ -0,0 +1,79 @@ +<html> +<head> +<link rel=stylesheet type="text/css" href="styles.css"> +</head> +<body> +<H2> +paxCompiler for Delphi. Using TPaxInvoke component to call a script-defined function. +</H2> +<hr> + +<blockquote> + +<pre> +<font color="blue"><b>procedure</b></font> Print(<font color="blue"><b>const</b></font> S: <font color="blue"><b>String</b></font>); +<font color="blue"><b>begin</b></font> + ShowMessage(S); +<font color="blue"><b>end</b></font>; + +<font color="blue"><b>var</b></font> + H_MyFunc: Integer; + I: Integer; + P: Pointer; +<font color="blue"><b>begin</b></font> +{$O-} + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + PaxCompiler1.RegisterHeader(0, <font color="Red">'procedure Print(const S: String);'</font>, @Print); + + PaxCompiler1.AddModule(<font color="Red">'1'</font>, PaxPascalLanguage1.LanguageName); + PaxCompiler1.AddCode(<font color="Red">'1'</font>, <font color="Red">'uses SysUtils;'</font>); + PaxCompiler1.AddCode(<font color="Red">'1'</font>, <font color="Red">'function MyFunc(U, V: Integer): Currency; cdecl;'</font>); + PaxCompiler1.AddCode(<font color="Red">'1'</font>, <font color="Red">'begin'</font>); + PaxCompiler1.AddCode(<font color="Red">'1'</font>, <font color="Red">' try'</font>); + PaxCompiler1.AddCode(<font color="Red">'1'</font>, <font color="Red">' result := U / V;'</font>); + PaxCompiler1.AddCode(<font color="Red">'1'</font>, <font color="Red">' except'</font>); + PaxCompiler1.AddCode(<font color="Red">'1'</font>, <font color="Red">' on E: Exception do'</font>); + PaxCompiler1.AddCode(<font color="Red">'1'</font>, <font color="Red">' begin'</font>); + PaxCompiler1.AddCode(<font color="Red">'1'</font>, <font color="Red">' print(E.Message);'</font>); + PaxCompiler1.AddCode(<font color="Red">'1'</font>, <font color="Red">' result := 7;'</font>); + PaxCompiler1.AddCode(<font color="Red">'1'</font>, <font color="Red">' end;'</font>); + PaxCompiler1.AddCode(<font color="Red">'1'</font>, <font color="Red">' end;'</font>); + PaxCompiler1.AddCode(<font color="Red">'1'</font>, <font color="Red">'end;'</font>); + PaxCompiler1.AddCode(<font color="Red">'1'</font>, <font color="Red">'begin'</font>); + PaxCompiler1.AddCode(<font color="Red">'1'</font>, <font color="Red">'end.'</font>); + + <font color="blue"><b>if</b></font> PaxCompiler1.Compile(PaxProgram1) <font color="blue"><b>then</b></font> + <font color="blue"><b>begin</b></font> + H_MyFunc := PaxCompiler1.GetHandle(0, <font color="Red">'MyFunc'</font>, true); + + P := PaxProgram1.GetAddress(H_MyFunc); // get address of script-defined function + + PaxInvoke1.Address := P; + PaxInvoke1.This := <font color="blue"><b>nil</b></font>; // this is not a method, but global function. + PaxInvoke1.ClearArguments; + PaxInvoke1.AddArgAsInteger(8) + PaxInvoke1.AddArgAsInteger(2); + PaxInvoke1.SetResultAsCurrency; + PaxInvoke1.CallConv := _ccCDECL; + + PaxProgram1.SetEntryPoint(PaxInvoke1); + PaxProgram1.Run; + + ShowMessage(CurrToStr(Currency(PaxInvoke1.GetResultPtr^))); + <font color="blue"><b>end</b></font> + <font color="blue"><b>else</b></font> + <font color="blue"><b>for</b></font> I:=0 <font color="blue"><b>to</b></font> PaxCompiler1.ErrorCount <font color="blue"><b>do</b></font> + ShowMessage(PaxCompiler1.ErrorMessage[I]); +<font color="blue"><b>end</b></font>; +</pre> +</blockquote> + +<p> +<HR> +<font size = 1 color ="gray"> +Copyright © 2006-2009 +VIRT Laboratory. All rights reserved. +</font> +</body> +</html> diff --git a/help/demo_debug.htm b/help/demo_debug.htm new file mode 100644 index 0000000..c9d752d --- /dev/null +++ b/help/demo_debug.htm @@ -0,0 +1,289 @@ +<html> +<head> +<link rel=stylesheet type="text/css" href="styles.css"> +</head> +<body> +<H2> +paxCompiler for Delphi. Debug demo. +</H2> +<hr> + +<img src="debug.jpg" border="0" alt ="Debug demo" ></img> + +<blockquote> + +<pre> +<font color="blue"><b>unit</b></font> Unit1; + +<font color="blue"><b>interface</b></font> + +<font color="blue"><b>uses</b></font> + Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, PaxProgram, PaxCompiler, PaxCompilerDebugger, + PaxCompilerExplorer; + +<font color="blue"><b>type</b></font> + TForm1 = <font color="blue"><b>class</b></font>(TForm) + Memo1: TMemo; + Memo2: TMemo; + Label1: TLabel; + Label2: TLabel; + Button1: TButton; + PaxCompiler1: TPaxCompiler; + PaxPascalLanguage1: TPaxPascalLanguage; + PaxProgram1: TPaxProgram; + Button2: TButton; + Button3: TButton; + Button4: TButton; + Button5: TButton; + PaxCompilerDebugger1: TPaxCompilerDebugger; + PaxCompilerExplorer1: TPaxCompilerExplorer; + <font color="blue"><b>procedure</b></font> Button1Click(Sender: TObject); + <font color="blue"><b>procedure</b></font> Button2Click(Sender: TObject); + <font color="blue"><b>procedure</b></font> Button3Click(Sender: TObject); + <font color="blue"><b>procedure</b></font> Button4Click(Sender: TObject); + <font color="blue"><b>procedure</b></font> Button5Click(Sender: TObject); + <font color="blue"><b>private</b></font> + { Private declarations } + <font color="blue"><b>procedure</b></font> Trace(RunMode: Integer); + <font color="blue"><b>public</b></font> + { Public declarations } + <font color="blue"><b>end</b></font>; + +<font color="blue"><b>var</b></font> + Form1: TForm1; + +<font color="blue"><b>implementation</b></font> + +<font color="blue"><b>uses</b></font> IMPORT_Classes, Unit2; + +{$R *.dfm} + +<font color="blue"><b>procedure</b></font> TForm1.Button1Click(Sender: TObject); +<font color="blue"><b>var</b></font> + I: Integer; +<font color="blue"><b>begin</b></font> + PaxCompiler1.Reset; + + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + PaxCompiler1.AddModule(<font color="Red">'1'</font>, PaxPascalLanguage1.LanguageName); + PaxCompiler1.AddCode(<font color="Red">'1'</font>, Memo1.Lines.Text); + + PaxCompiler1.DebugMode := true; + + <font color="blue"><b>if</b></font> PaxCompiler1.Compile(PaxProgram1) <font color="blue"><b>then</b></font> + <font color="blue"><b>begin</b></font> + ShowMessage(<font color="Red">'Script has been successfully recompiled.'</font>); + PaxCompilerExplorer1.RegisterCompiler(PaxCompiler1); + PaxCompilerDebugger1.RegisterCompiler(PaxCompiler1, PaxProgram1); + <font color="blue"><b>end</b></font> + <font color="blue"><b>else</b></font> + <font color="blue"><b>for</b></font> I:=0 <font color="blue"><b>to</b></font> PaxCompiler1.ErrorCount - 1 <font color="blue"><b>do</b></font> + ShowMessage(PaxCompiler1.ErrorMessage[I]); +<font color="blue"><b>end</b></font>; + +<font color="blue"><b>procedure</b></font> TForm1.Button2Click(Sender: TObject); +<font color="blue"><b>begin</b></font> + Trace(_rmRUN); +<font color="blue"><b>end</b></font>; + +<font color="blue"><b>procedure</b></font> TForm1.Button3Click(Sender: TObject); +<font color="blue"><b>begin</b></font> + Trace(_rmTRACE_INTO); +<font color="blue"><b>end</b></font>; + +<font color="blue"><b>procedure</b></font> TForm1.Button4Click(Sender: TObject); +<font color="blue"><b>begin</b></font> + Trace(_rmSTEP_OVER); +<font color="blue"><b>end</b></font>; + +<font color="blue"><b>procedure</b></font> TForm1.Button5Click(Sender: TObject); +<font color="blue"><b>begin</b></font> + <font color="blue"><b>if</b></font> <font color="blue"><b>not</b></font> PaxCompilerDebugger1.Valid <font color="blue"><b>then</b></font> + <font color="blue"><b>begin</b></font> + ShowMessage(<font color="Red">'You have to compile script. Press <font color="Red">"Compile"</font> button.'</font>); + Exit; + <font color="blue"><b>end</b></font>; + + Form2.ShowModal; + + <font color="blue"><b>if</b></font> Form2.ModalResult = mrOK <font color="blue"><b>then</b></font> + Trace(_rmRUN_TO_CURSOR); +<font color="blue"><b>end</b></font>; + +<font color="blue"><b>procedure</b></font> TForm1.Trace(RunMode: Integer); + +<font color="blue"><b>procedure</b></font> AddFields(StackFrameNumber, Id: Integer); +<font color="blue"><b>var</b></font> + I, K: Integer; + OwnerName, S: <font color="blue"><b>String</b></font>; +<font color="blue"><b>begin</b></font> + K := PaxCompilerExplorer1.GetFieldCount(Id); + <font color="blue"><b>if</b></font> K = 0 <font color="blue"><b>then</b></font> + Exit; + + OwnerName := PaxCompilerExplorer1.Names[Id]; + <font color="blue"><b>if</b></font> PaxCompilerDebugger1.GetValueAsString(Id) = <font color="Red">'nil'</font> <font color="blue"><b>then</b></font> + Exit; + + <font color="blue"><b>for</b></font> I:=0 <font color="blue"><b>to</b></font> K - 1 <font color="blue"><b>do</b></font> + <font color="blue"><b>begin</b></font> + S := OwnerName + <font color="Red">'.'</font> + PaxCompilerExplorer1.GetFieldName(Id, I); + S := <font color="Red">' '</font> + S + <font color="Red">'='</font> + PaxCompilerDebugger1.GetFieldValueAsString( + StackFrameNumber, Id, I); + Memo2.Lines.Add(S); + <font color="blue"><b>end</b></font>; +<font color="blue"><b>end</b></font>; + +<font color="blue"><b>procedure</b></font> AddArrayElements(StackFrameNumber, Id: Integer); +<font color="blue"><b>var</b></font> + I, K1, K2: Integer; + OwnerName, S: <font color="blue"><b>String</b></font>; +<font color="blue"><b>begin</b></font> + <font color="blue"><b>if</b></font> <font color="blue"><b>not</b></font> PaxCompilerExplorer1.HasArrayType(Id) <font color="blue"><b>then</b></font> + Exit; + + K1 := PaxCompilerExplorer1.GetArrayLowBound(Id); + K2 := PaxCompilerExplorer1.GetArrayHighBound(Id); + + OwnerName := PaxCompilerExplorer1.Names[Id]; + + <font color="blue"><b>for</b></font> I:=K1 <font color="blue"><b>to</b></font> K2 <font color="blue"><b>do</b></font> + <font color="blue"><b>begin</b></font> + S := OwnerName + <font color="Red">'['</font> + IntToStr(I) + <font color="Red">']'</font>; + S := <font color="Red">' '</font> + S + <font color="Red">'='</font> + PaxCompilerDebugger1.GetArrayItemValueAsString( + StackFrameNumber, Id, I); + Memo2.Lines.Add(S); + <font color="blue"><b>end</b></font>; +<font color="blue"><b>end</b></font>; + +<font color="blue"><b>procedure</b></font> AddDynArrayElements(StackFrameNumber, Id: Integer); +<font color="blue"><b>var</b></font> + I, L: Integer; + OwnerName, S: <font color="blue"><b>String</b></font>; +<font color="blue"><b>begin</b></font> + <font color="blue"><b>if</b></font> <font color="blue"><b>not</b></font> PaxCompilerExplorer1.HasDynArrayType(Id) <font color="blue"><b>then</b></font> + Exit; + + L := PaxCompilerDebugger1.GetDynArrayLength(StackFrameNumber, Id); + + OwnerName := PaxCompilerExplorer1.Names[Id]; + + <font color="blue"><b>for</b></font> I:=0 <font color="blue"><b>to</b></font> L - 1 <font color="blue"><b>do</b></font> + <font color="blue"><b>begin</b></font> + S := OwnerName + <font color="Red">'['</font> + IntToStr(I) + <font color="Red">']'</font>; + S := <font color="Red">' '</font> + S + <font color="Red">'='</font> + PaxCompilerDebugger1.GetDynArrayItemValueAsString( + StackFrameNumber, Id, I); + Memo2.Lines.Add(S); + <font color="blue"><b>end</b></font>; +<font color="blue"><b>end</b></font>; + +<font color="blue"><b>var</b></font> + SourceLineNumber: Integer; + ModuleName: <font color="blue"><b>String</b></font>; + StackFrameNumber, J, K, SubId, Id: Integer; + S, V: <font color="blue"><b>String</b></font>; +<font color="blue"><b>begin</b></font> + <font color="blue"><b>if</b></font> <font color="blue"><b>not</b></font> PaxCompilerDebugger1.Valid <font color="blue"><b>then</b></font> + <font color="blue"><b>begin</b></font> + ShowMessage(<font color="Red">'You have to compile script. Press <font color="Red">"Compile"</font> button.'</font>); + Exit; + <font color="blue"><b>end</b></font>; + + PaxCompilerDebugger1.RunMode := RunMode; + PaxCompilerDebugger1.Run; + + Memo2.Lines.Clear; + <font color="blue"><b>if</b></font> PaxCompilerDebugger1.IsPaused <font color="blue"><b>then</b></font> + <font color="blue"><b>begin</b></font> + ModuleName := PaxCompilerDebugger1.ModuleName; + SourceLineNumber := PaxCompilerDebugger1.SourceLineNumber; + + Memo2.Lines.Add(<font color="Red">'Paused at line '</font> + IntTosTr(SourceLineNumber)); + Memo2.Lines.Add(PaxCompiler1.Modules[ModuleName][SourceLineNumber]); + Memo2.Lines.Add(<font color="Red">'------------------------------------------------------'</font>); + + <font color="blue"><b>if</b></font> PaxCompilerDebugger1.CallStackCount > 0 <font color="blue"><b>then</b></font> + <font color="blue"><b>begin</b></font> + Memo2.Lines.Add(<font color="Red">'Call stack:'</font>); + <font color="blue"><b>for</b></font> StackFrameNumber:=0 <font color="blue"><b>to</b></font> PaxCompilerDebugger1.CallStackCount - 1 <font color="blue"><b>do</b></font> + <font color="blue"><b>begin</b></font> + SubId := PaxCompilerDebugger1.CallStack[StackFrameNumber]; + S := <font color="Red">'('</font>; + K := PaxCompilerExplorer1.GetParamCount(SubId); + <font color="blue"><b>for</b></font> J:=0 <font color="blue"><b>to</b></font> K - 1 <font color="blue"><b>do</b></font> + <font color="blue"><b>begin</b></font> + Id := PaxCompilerExplorer1.GetParamId(SubId, J); + V := PaxCompilerDebugger1.GetValueAsString(StackFrameNumber, Id); + S := S + V; + <font color="blue"><b>if</b></font> J < K - 1 <font color="blue"><b>then</b></font> + S := S + <font color="Red">','</font>; + <font color="blue"><b>end</b></font>; + S := PaxCompilerExplorer1.Names[SubId] + S + <font color="Red">')'</font>; + Memo2.Lines.Add(S); + <font color="blue"><b>end</b></font>; + Memo2.Lines.Add(<font color="Red">'------------------------------------------------------'</font>); + + Memo2.Lines.Add(<font color="Red">'Local scope:'</font>); + StackFrameNumber := PaxCompilerDebugger1.CallStackCount - 1; + SubId := PaxCompilerDebugger1.CallStack[StackFrameNumber]; + K := PaxCompilerExplorer1.GetLocalCount(SubId); + <font color="blue"><b>for</b></font> J:=0 <font color="blue"><b>to</b></font> K - 1 <font color="blue"><b>do</b></font> + <font color="blue"><b>begin</b></font> + Id := PaxCompilerExplorer1.GetLocalId(SubId, J); + V := PaxCompilerDebugger1.GetValueAsString(StackFrameNumber, Id); + S := PaxCompilerExplorer1.Names[Id] + <font color="Red">'='</font> + V; + Memo2.Lines.Add(S); + + AddFields(StackFrameNumber, Id); + AddArrayElements(StackFrameNumber, Id); + AddDynArrayElements(StackFrameNumber, Id); + <font color="blue"><b>end</b></font>; + Memo2.Lines.Add(<font color="Red">'------------------------------------------------------'</font>); + <font color="blue"><b>end</b></font>; + + Memo2.Lines.Add(<font color="Red">'Global scope:'</font>); + K := PaxCompilerExplorer1.GetGlobalCount(0); + <font color="blue"><b>for</b></font> J:=0 <font color="blue"><b>to</b></font> K - 1 <font color="blue"><b>do</b></font> + <font color="blue"><b>begin</b></font> + Id := PaxCompilerExplorer1.GetGlobalId(0, J); + V := PaxCompilerDebugger1.GetValueAsString(Id); + S := PaxCompilerExplorer1.Names[Id] + <font color="Red">'='</font> + V; + Memo2.Lines.Add(S); + + AddFields(0, Id); + AddArrayElements(0, Id); + AddDynArrayElements(0, Id); + <font color="blue"><b>end</b></font>; + Memo2.Lines.Add(<font color="Red">'------------------------------------------------------'</font>); + + <font color="blue"><b>end</b></font> + <font color="blue"><b>else</b></font> + Memo2.Lines.Add(<font color="Red">'Finished'</font>); + + Memo2.SelStart := 0; + Memo2.SelLength := 0; +<font color="blue"><b>end</b></font>; + +<font color="blue"><b>procedure</b></font> Print(I: Integer); +<font color="blue"><b>begin</b></font> + ShowMessage(IntToStr(I)); +<font color="blue"><b>end</b></font>; + +<font color="blue"><b>initialization</b></font> + +RegisterHeader(0, <font color="Red">'procedure Print(I: Integer);'</font>, @Print); + +<font color="blue"><b>end</b></font>. +</pre> +</blockquote> + + +<p> +<HR> +<font size = 1 color ="gray"> +Copyright © 2006-2009 +VIRT Laboratory. All rights reserved. +</font> +</body> +</html> diff --git a/help/demo_dll.htm b/help/demo_dll.htm new file mode 100644 index 0000000..5fe21ab --- /dev/null +++ b/help/demo_dll.htm @@ -0,0 +1,70 @@ +<html> +<head> +<link rel=stylesheet type="text/css" href="styles.css"> +</head> +<body> +<H2> +paxCompiler for Delphi. Support of dll-defined functions written in Microsoft Visual Studio C++. +</H2> +<hr> + +<blockquote> + +<pre> +<font color="blue"><b>type</b></font> + PMyPoint = ^TMyPoint; + TMyPoint = <font color="blue"><b>record</b></font> + x, y, z: Integer; + <font color="blue"><b>end</b></font>; + +// int __msfastcall cube(int num); +<font color="blue"><b>function</b></font> cub(X: Integer): Integer; <font color="blue"><b>msfastcall</b></font>; +<font color="blue"><b>external</b></font> <font color="Red">'CppDll.dll'</font> name <font color="Red">'cube'</font>; + +// double __msfastcall arr(double a[], int i, int j, float f); +<font color="blue"><b>function</b></font> arr(A: Pointer; X, Y: Integer; S: Single): Double; <font color="blue"><b>msfastcall</b></font>; +<font color="blue"><b>external</b></font> <font color="Red">'CppDll.dll'</font>; + +// Point __msfastcall ret_struct(int x, int y, int z); +<font color="blue"><b>function</b></font> ret_struct(X, Y, Z: Integer): TMyPoint; <font color="blue"><b>msfastcall</b></font>; +<font color="blue"><b>external</b></font> <font color="Red">'CppDll.dll'</font>; + +// MyPoint __msfastcall pass_struct(const MyPoint & q); +<font color="blue"><b>function</b></font> pass_struct(P: PMyPoint): TMyPoint; <font color="blue"><b>msfastcall</b></font>; +<font color="blue"><b>external</b></font> <font color="Red">'CppDll.dll'</font>; + +// char __msfastcall ret_char(char * s) +<font color="blue"><b>function</b></font> ret_char(s: PChar): Char; <font color="blue"><b>msfastcall</b></font>; +<font color="blue"><b>external</b></font> <font color="Red">'CppDll.dll'</font>; + +<font color="blue"><b>var</b></font> + p: TMyPoint; + a: <font color="blue"><b>array</b></font>[0..5] <font color="blue"><b>of</b></font> double; +<font color="blue"><b>begin</b></font> + a[0] := 5.3; + a[1] := 10.1; + + writeln(cub(2)); + writeln(arr(@a, 2, 3, 6.8)); + + p := ret_struct(2, 3, 5); + writeln(p.x, <font color="Red">' '</font>, p.y, <font color="Red">' '</font>, p.z); + + p := pass_struct(@p); + writeln(p.x, <font color="Red">' '</font>, p.y, <font color="Red">' '</font>, p.z); + + writeln(ret_char(<font color="Red">'abc'</font>)); +<font color="blue"><b>end</b></font>. +</pre> +</blockquote> + + + +<p> +<HR> +<font size = 1 color ="gray"> +Copyright © 2006-2009 +VIRT Laboratory. All rights reserved. +</font> +</body> +</html> diff --git a/help/demo_eval_expression.htm b/help/demo_eval_expression.htm new file mode 100644 index 0000000..7202228 --- /dev/null +++ b/help/demo_eval_expression.htm @@ -0,0 +1,143 @@ +<html> +<head> +<link rel=stylesheet type="text/css" href="styles.css"> +</head> +<body> +<H2> +paxCompiler for Delphi. Evaluate expression. +</H2> +<hr> + + +<blockquote> + +<pre> +<font color="blue"><b>unit</b></font> Unit1; + +<font color="blue"><b>interface</b></font> + +<font color="blue"><b>uses</b></font> + Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, PaxCompiler; + +<font color="blue"><b>type</b></font> + TForm1 = <font color="blue"><b>class</b></font>(TForm) + Button1: TButton; + Button2: TButton; + <font color="blue"><b>procedure</b></font> Button1Click(Sender: TObject); + <font color="blue"><b>procedure</b></font> Button2Click(Sender: TObject); + <font color="blue"><b>procedure</b></font> FormCreate(Sender: TObject); + <font color="blue"><b>private</b></font> + { Private declarations } + arr_x, arr_y: <font color="blue"><b>array</b></font>[1..3] <font color="blue"><b>of</b></font> Double; + h_norm, h_x, h_y: Integer; + + buff: <font color="blue"><b>array</b></font>[1..4096] <font color="blue"><b>of</b></font> Byte; + <font color="blue"><b>public</b></font> + { Public declarations } + <font color="blue"><b>end</b></font>; + +<font color="blue"><b>var</b></font> + Form1: TForm1; + +<font color="blue"><b>implementation</b></font> + +{$R *.dfm} + +<font color="blue"><b>function</b></font> Norm(x, y: Double): Double; +<font color="blue"><b>begin</b></font> + result := Sqrt(x * x + y * y); +<font color="blue"><b>end</b></font>; + +<font color="blue"><b>procedure</b></font> TForm1.Button1Click(Sender: TObject); +<font color="blue"><b>var</b></font> + PaxCompiler1: TPaxCompiler; + PaxPascalLanguage1: TPaxPascalLanguage; + PaxProgram1: TPaxProgram; + I: Integer; +<font color="blue"><b>begin</b></font> + PaxCompiler1 := TPaxCompiler.Create(<font color="blue"><b>nil</b></font>); + PaxPascalLanguage1 := TPaxPascalLanguage.Create(<font color="blue"><b>nil</b></font>); + PaxProgram1 := TPaxProgram.Create(<font color="blue"><b>nil</b></font>); + + <font color="blue"><b>try</b></font> + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + + h_norm := PaxCompiler1.RegisterRoutine(0, <font color="Red">'Norm'</font>, _typeDOUBLE, _ccREGISTER); + PaxCompiler1.RegisterParameter(h_norm, _typeDOUBLE, Unassigned); + PaxCompiler1.RegisterParameter(h_norm, _typeDOUBLE, Unassigned); + + h_x := PaxCompiler1.RegisterVariable(0, <font color="Red">'x'</font>, _typeDOUBLE); + h_y := PaxCompiler1.RegisterVariable(0, <font color="Red">'y'</font>, _typeDOUBLE); + + <font color="blue"><b>if</b></font> PaxCompiler1.CompileExpression(<font color="Red">'Norm(x, y)'</font>, PaxProgram1) <font color="blue"><b>then</b></font> + <font color="blue"><b>begin</b></font> + PaxProgram1.SaveToBuff(buff); + ShowMessage(<font color="Red">'Compiled expression has been created!'</font>); + <font color="blue"><b>end</b></font> + <font color="blue"><b>else</b></font> + <font color="blue"><b>for</b></font> I:=0 <font color="blue"><b>to</b></font> PaxCompiler1.ErrorCount - 1 <font color="blue"><b>do</b></font> + ShowMessage(PaxCompiler1.ErrorMessage[I]); + <font color="blue"><b>finally</b></font> + PaxCompiler1.Free; + PaxPascalLanguage1.Free; + PaxProgram1.Free; + <font color="blue"><b>end</b></font>; +<font color="blue"><b>end</b></font>; + +<font color="blue"><b>procedure</b></font> TForm1.Button2Click(Sender: TObject); +<font color="blue"><b>var</b></font> + PaxProgram1: TPaxProgram; + ResValue: Double; + I: Integer; +<font color="blue"><b>begin</b></font> +{$O-} + <font color="blue"><b>if</b></font> h_x <> 0 <font color="blue"><b>then</b></font> + <font color="blue"><b>begin</b></font> + PaxProgram1 := TPaxProgram.Create(<font color="blue"><b>nil</b></font>); + <font color="blue"><b>try</b></font> + PaxProgram1.LoadFromBuff(buff); + + PaxProgram1.SetAddress(h_norm, @norm); + + <font color="blue"><b>for</b></font> I:=1 <font color="blue"><b>to</b></font> 3 <font color="blue"><b>do</b></font> + <font color="blue"><b>begin</b></font> + PaxProgram1.SetAddress(h_x, @arr_x[I]); + PaxProgram1.SetAddress(h_y, @arr_y[I]); + + PaxProgram1.Run; + + ResValue := Double(PaxProgram1.ResultPtr^); + ShowMessage(FloatToStr(ResValue)); + <font color="blue"><b>end</b></font>; + + <font color="blue"><b>finally</b></font> + PaxProgram1.Free; + <font color="blue"><b>end</b></font>; + <font color="blue"><b>end</b></font> + <font color="blue"><b>else</b></font> + ShowMessage(<font color="Red">'Press the first button to create compiled script.'</font>); +<font color="blue"><b>end</b></font>; + +<font color="blue"><b>procedure</b></font> TForm1.FormCreate(Sender: TObject); +<font color="blue"><b>begin</b></font> + h_x := 0; h_y := 0; h_norm := 0; + arr_x[1] := 4.2; arr_y[1] := -5.2; + arr_x[2] := -0.4; arr_y[2] := 3.2; + arr_x[3] := 2.0; arr_y[3] := 3; +<font color="blue"><b>end</b></font>; + +<font color="blue"><b>end</b></font>. +</pre> +</blockquote> + + +<p> +<HR> +<font size = 1 color ="gray"> +Copyright © 2006-2009 +VIRT Laboratory. All rights reserved. +</font> +</body> +</html> diff --git a/help/demo_event_handlers.htm b/help/demo_event_handlers.htm new file mode 100644 index 0000000..570c57f --- /dev/null +++ b/help/demo_event_handlers.htm @@ -0,0 +1,181 @@ +<html> +<head> +<link rel=stylesheet type="text/css" href="styles.css"> +</head> +<body> +<H2> +paxCompiler for Delphi. Script-defined event handlers. +</H2> +<hr> + +<h4>Script</h4> + +<blockquote> +<pre> +<font color="blue"><b>type</b></font> + TMyHandler = <font color="blue"><b>class</b></font> + <font color="blue"><b>procedure</b></font> Handle(Sender: TObject); + <font color="blue"><b>end</b></font>; + +<font color="blue"><b>procedure</b></font> TMyHandler.Handle(Sender: TObject); +<font color="blue"><b>begin</b></font> + ShowMessage(<font color="Red">'Script-defined handler. Sender: '</font> + Sender.ClassName); +<font color="blue"><b>end</b></font>; + +<font color="blue"><b>procedure</b></font> TMyHandler.Dispose(Sender: TObject); +<font color="blue"><b>begin</b></font> + Free; +<font color="blue"><b>end</b></font>; + +<font color="blue"><b>var</b></font> + X: TMyHandler; + E: TNotifyEvent; + +<font color="blue"><b>procedure</b></font> SetHandler; +<font color="blue"><b>begin</b></font> + E := ClickMe.OnClick; + ClickMe.OnClick := X.Handle; +<font color="blue"><b>end</b></font>; + +<font color="blue"><b>procedure</b></font> RestoreHandler; +<font color="blue"><b>begin</b></font> + ClickMe.OnClick := E; +<font color="blue"><b>end</b></font>; + +<font color="blue"><b>begin</b></font> + X := TMyHandler.Create; + + Form1.OnDestroy := X.Dispose; + ShowMessage(<font color="Red">'The script was compiled and initialized successfully.'</font>); +<font color="blue"><b>end</b></font>. +</pre> +</blockquote> + + +<h4>Delphi Application</h4> + +<blockquote> +<pre> +<font color="blue"><b>unit</b></font> Unit1; + +<font color="blue"><b>interface</b></font> + +<font color="blue"><b>uses</b></font> + Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, PaxProgram, PaxCompiler; + +<font color="blue"><b>type</b></font> + TForm1 = <font color="blue"><b>class</b></font>(TForm) + Button1: TButton; + Button2: TButton; + Button3: TButton; + Memo1: TMemo; + ClickMe: TButton; + PaxCompiler1: TPaxCompiler; + PaxPascalLanguage1: TPaxPascalLanguage; + PaxProgram1: TPaxProgram; + <font color="blue"><b>procedure</b></font> Button1Click(Sender: TObject); + <font color="blue"><b>procedure</b></font> ClickMeClick(Sender: TObject); + <font color="blue"><b>procedure</b></font> Button2Click(Sender: TObject); + <font color="blue"><b>procedure</b></font> Button3Click(Sender: TObject); + <font color="blue"><b>private</b></font> + { Private declarations } + P_SetHandler: Pointer; + P_RestoreHandler: Pointer; + <font color="blue"><b>public</b></font> + { Public declarations } + <font color="blue"><b>end</b></font>; + +<font color="blue"><b>var</b></font> + Form1: TForm1; + +<font color="blue"><b>implementation</b></font> + +{$R *.dfm} + +<font color="blue"><b>var</b></font> + H_TButton, H_TForm1: Integer; + +<font color="blue"><b>type</b></font> + TProcP = <font color="blue"><b>procedure</b></font>; + +// create compiled-script +<font color="blue"><b>procedure</b></font> TForm1.Button1Click(Sender: TObject); +<font color="blue"><b>var</b></font> + I: Integer; + H: Integer; +<font color="blue"><b>begin</b></font> + <font color="blue"><b>if</b></font> PaxProgram1.DataSize > 0 <font color="blue"><b>then</b></font> + <font color="blue"><b>begin</b></font> + ShowMessage(<font color="Red">'Script is already compiled.'</font>); + <font color="blue"><b>Exit</b></font>; + <font color="blue"><b>end</b></font>; + + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + PaxCompiler1.AddModule(<font color="Red">'1'</font>, <font color="Red">'Pascal'</font>); + PaxCompiler1.AddCode(<font color="Red">'1'</font>, Memo1.Lines.Text); + PaxCompiler1.RegisterVariable(0, <font color="Red">'ClickMe'</font>, H_TButton, @ClickMe); + PaxCompiler1.RegisterVariable(0, <font color="Red">'Form1'</font>, H_TForm1, @Form1); + + PaxPascalLanguage1.SetCallConv(_ccREGISTER); + + <font color="blue"><b>if</b></font> PaxCompiler1.Compile(PaxProgram1) <font color="blue"><b>then</b></font> + <font color="blue"><b>begin</b></font> + H := PaxCompiler1.GetHandle(0, <font color="Red">'SetHandler'</font>, true); + P_SetHandler := PaxProgram1.GetAddress(H); + + H := PaxCompiler1.GetHandle(0, <font color="Red">'RestoreHandler'</font>, true); + P_RestoreHandler := PaxProgram1.GetAddress(H); + + PaxProgram1.Run; + <font color="blue"><b>end</b></font> + <font color="blue"><b>else</b></font> + <font color="blue"><b>for</b></font> I:=0 <font color="blue"><b>to</b></font> PaxCompiler1.ErrorCount - 1 <font color="blue"><b>do</b></font> + ShowMessage(PaxCompiler1.ErrorMessage[I]); +<font color="blue"><b>end</b></font>; + +// set up script-defined event handler +<font color="blue"><b>procedure</b></font> TForm1.Button2Click(Sender: TObject); +<font color="blue"><b>begin</b></font> + PaxProgram1.BeginCall; + TProcP(P_SetHandler); + PaxProgram1.EndCall; + + ShowMessage(<font color="Red">'ClickMe contains script-defined event handler now.'</font>); +<font color="blue"><b>end</b></font>; + +// restore host-defined event handler +<font color="blue"><b>procedure</b></font> TForm1.Button3Click(Sender: TObject); +<font color="blue"><b>begin</b></font> + PaxProgram1.BeginCall; + TProcP(P_RestoreHandler); + PaxProgram1.EndCall; + + ShowMessage(<font color="Red">'Host-defined handler is restored.'</font>); +<font color="blue"><b>end</b></font>; + +<font color="blue"><b>procedure</b></font> TForm1.ClickMeClick(Sender: TObject); +<font color="blue"><b>begin</b></font> + ShowMessage(<font color="Red">'Host-defined event handler. Sender: '</font> + Sender.ClassName); +<font color="blue"><b>end</b></font>; + +<font color="blue"><b>initialization</b></font> + + H_TButton := RegisterClassType(0, TButton); + H_TForm1 := RegisterClassType(0, TForm1); + RegisterHeader(0, <font color="Red">'procedure ShowMessage(const Msg: string);'</font>, @ShowMessage); + +<font color="blue"><b>end</b></font>. +</pre> +</blockquote> + + +<p> +<HR> +<font size = 1 color ="gray"> +Copyright © 2006-2009 +VIRT Laboratory. All rights reserved. +</font> +</body> +</html> diff --git a/help/demo_explorer.htm b/help/demo_explorer.htm new file mode 100644 index 0000000..3fe4262 --- /dev/null +++ b/help/demo_explorer.htm @@ -0,0 +1,269 @@ +<html> +<head> +<link rel=stylesheet type="text/css" href="styles.css"> +</head> +<body> +<H2> +paxCompiler for Delphi. Code explorer. +</H2> +<hr> + +<img src="code_expl.jpg" border="0" alt ="Code explorer" ></img> + +<blockquote> + +<pre> +<font color="blue"><b>unit</b></font> Unit1; + +<font color="blue"><b>interface</b></font> + +<font color="blue"><b>uses</b></font> + Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, + Dialogs, PaxCompilerExplorer, PaxCompiler, StdCtrls, ExtCtrls, ComCtrls, + IMPORT_Classes; + +<font color="blue"><b>type</b></font> + TForm1 = <font color="blue"><b>class</b></font>(TForm) + Panel1: TPanel; + Memo1: TMemo; + Button1: TButton; + PaxCompiler1: TPaxCompiler; + PaxPascalLanguage1: TPaxPascalLanguage; + PaxCompilerExplorer1: TPaxCompilerExplorer; + TreeView1: TTreeView; + <font color="blue"><b>procedure</b></font> Button1Click(Sender: TObject); + <font color="blue"><b>procedure</b></font> TreeView1DblClick(Sender: TObject); + <font color="blue"><b>private</b></font> + { Private declarations } + L: TList; + <font color="blue"><b>public</b></font> + { Public declarations } + <font color="blue"><b>procedure</b></font> BuildTree; + <font color="blue"><b>procedure</b></font> EnumProc(Id: Integer; + Host: Boolean; + Kind: TMemberKind; + Data: Pointer); + <font color="blue"><b>end</b></font>; + +<font color="blue"><b>var</b></font> + Form1: TForm1; + +<font color="blue"><b>implementation</b></font> + +{$R *.dfm} + +<font color="blue"><b>procedure</b></font> TForm1.Button1Click(Sender: TObject); +<font color="blue"><b>var</b></font> + I: Integer; +<font color="blue"><b>begin</b></font> + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + PaxCompiler1.AddModule(<font color="Red">'1'</font>, <font color="Red">'Pascal'</font>); + PaxCompiler1.AddCode(<font color="Red">'1'</font>, Memo1.Lines.Text); + <font color="blue"><b>if</b></font> PaxCompiler1.Compile <font color="blue"><b>then</b></font> + <font color="blue"><b>begin</b></font> + PaxCompilerExplorer1.RegisterCompiler(PaxCompiler1); + BuildTree; + <font color="blue"><b>end</b></font> + <font color="blue"><b>else</b></font> + <font color="blue"><b>for</b></font> I:=0 <font color="blue"><b>to</b></font> PaxCompiler1.ErrorCount - 1 <font color="blue"><b>do</b></font> + ShowMessage(PaxCompiler1.ErrorMessage[I]); +<font color="blue"><b>end</b></font>; + +<font color="blue"><b>procedure</b></font> TForm1.BuildTree; +<font color="blue"><b>var</b></font> + N, N2: TTreeNode; + I: Integer; +<font color="blue"><b>begin</b></font> + L := TList.Create; + <font color="blue"><b>try</b></font> + TreeView1.Items.Clear; + + N := TreeView1.Items.Add(<font color="blue"><b>nil</b></font>, <font color="Red">'Used namespaces'</font>); + L.Add(N); + PaxCompilerExplorer1.EnumMembers(0, true, mkNamespace, EnumProc, N); + PaxCompilerExplorer1.EnumMembers(0, false, mkNamespace, EnumProc, N); + + N := TreeView1.Items.Add(<font color="blue"><b>nil</b></font>, <font color="Red">'Noname namespace'</font>); + + N2 := TreeView1.Items.AddChild(N, <font color="Red">'Types'</font>); + L.Add(N2); + PaxCompilerExplorer1.EnumMembers(0, false, mkType, EnumProc, N2); + + N2 := TreeView1.Items.AddChild(N, <font color="Red">'Procedures'</font>); + L.Add(N2); + PaxCompilerExplorer1.EnumMembers(0, false, mkProcedure, EnumProc, N2); + + N2 := TreeView1.Items.AddChild(N, <font color="Red">'Functions'</font>); + L.Add(N2); + PaxCompilerExplorer1.EnumMembers(0, false, mkFunction, EnumProc, N2); + + N2 := TreeView1.Items.AddChild(N, <font color="Red">'Constants'</font>); + L.Add(N2); + PaxCompilerExplorer1.EnumMembers(0, false, mkConst, EnumProc, N2); + + N2 := TreeView1.Items.AddChild(N, <font color="Red">'Variables'</font>); + L.Add(N2); + PaxCompilerExplorer1.EnumMembers(0, false, mkVar, EnumProc, N2); + + <font color="blue"><b>finally</b></font> + <font color="blue"><b>for</b></font> I := L.Count - 1 <font color="blue"><b>downto</b></font> 0 <font color="blue"><b>do</b></font> + <font color="blue"><b>begin</b></font> + N2 := TTreeNode(L[I]); + <font color="blue"><b>if</b></font> N2.Count = 0 <font color="blue"><b>then</b></font> + N2.Delete; + <font color="blue"><b>end</b></font>; + + L.Free; + <font color="blue"><b>end</b></font>; +<font color="blue"><b>end</b></font>; + +<font color="blue"><b>procedure</b></font> TForm1.EnumProc(Id: Integer; + Host: Boolean; + Kind: TMemberKind; + Data: Pointer); +<font color="blue"><b>var</b></font> + N, N2, N3: TTreeNode; + Name: <font color="blue"><b>String</b></font>; + TypeName: <font color="blue"><b>String</b></font>; +<font color="blue"><b>begin</b></font> + N := TTreeNode(Data); + + Name := PaxCompilerExplorer1.Names[Id]; + TypeName := PaxCompilerExplorer1.TypeNames[Id]; + + <font color="blue"><b>with</b></font> TreeView1.Items <font color="blue"><b>do</b></font> + <font color="blue"><b>case</b></font> Kind <font color="blue"><b>of</b></font> + mkProcedure, mkFunction, mkConstructor, mkDestructor: + <font color="blue"><b>begin</b></font> + N2 := AddChildObject(N, Name, TObject(Id)); + + N3 := AddChild(N2, <font color="Red">'Parameters'</font>); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, Host, mkParam, EnumProc, N3); + + N3 := AddChild(N2, <font color="Red">'Local variables'</font>); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, Host, mkVar, EnumProc, N3); + + N3 := AddChild(N2, <font color="Red">'Local constants'</font>); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, Host, mkConst, EnumProc, N3); + + N3 := AddChild(N2, <font color="Red">'Local types'</font>); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, Host, mkType, EnumProc, N3); + + N3 := TreeView1.Items.AddChild(N2, <font color="Red">'Nested procedures'</font>); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, false, mkProcedure, EnumProc, N3); + + N3 := TreeView1.Items.AddChild(N2, <font color="Red">'Nested functions'</font>); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, false, mkFunction, EnumProc, N3); + + <font color="blue"><b>end</b></font>; + mkParam: AddChildObject(N, Name + <font color="Red">': '</font> + TypeName, TObject(Id)); + mkVar: AddChildObject(N, Name + <font color="Red">': '</font> + TypeName, TObject(Id)); + mkConst: AddChildObject(N, Name + <font color="Red">': '</font> + TypeName, TObject(Id)); + mkField: AddChildObject(N, Name + <font color="Red">': '</font> + TypeName, TObject(Id)); + mkProperty: AddChildObject(N, Name + <font color="Red">': '</font> + TypeName, TObject(Id)); + mkType: + <font color="blue"><b>begin</b></font> + N2 := AddChildObject(N, Name, TObject(Id)); + <font color="blue"><b>if</b></font> PaxCompilerExplorer1.IsRecordType(Id) <font color="blue"><b>then</b></font> + <font color="blue"><b>begin</b></font> + N3 := AddChild(N2, <font color="Red">'Fields'</font>); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, Host, mkField, EnumProc, N3); + <font color="blue"><b>end</b></font> + <font color="blue"><b>else</b></font> <font color="blue"><b>if</b></font> PaxCompilerExplorer1.IsClassType(Id) <font color="blue"><b>then</b></font> + <font color="blue"><b>begin</b></font> + N3 := AddChild(N2, <font color="Red">'Fields'</font>); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, Host, mkField, EnumProc, N3); + + N3 := AddChild(N2, <font color="Red">'Properties'</font>); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, Host, mkProperty, EnumProc, N3); + + N3 := TreeView1.Items.AddChild(N2, <font color="Red">'Constructors'</font>); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, false, mkConstructor, EnumProc, N3); + + N3 := TreeView1.Items.AddChild(N2, <font color="Red">'Destructor'</font>); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, false, mkDestructor, EnumProc, N3); + + N3 := TreeView1.Items.AddChild(N2, <font color="Red">'Class procedures'</font>); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, false, mkProcedure, EnumProc, N3); + + N3 := TreeView1.Items.AddChild(N2, <font color="Red">'Class functions'</font>); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, false, mkFunction, EnumProc, N3); + <font color="blue"><b>end</b></font>; + <font color="blue"><b>end</b></font>; + mkNamespace: + <font color="blue"><b>begin</b></font> + N2 := AddChildObject(N, Name, TObject(Id)); + + N3 := AddChild(N2, <font color="Red">'Constants'</font>); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, Host, mkConst, EnumProc, N3); + + N3 := AddChild(N2, <font color="Red">'Variables'</font>); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, Host, mkVar, EnumProc, N3); + + N3 := AddChild(N2, <font color="Red">'Procedures'</font>); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, Host, mkProcedure, EnumProc, N3); + + N3 := AddChild(N2, <font color="Red">'Types'</font>); + L.Add(N3); + PaxCompilerExplorer1.EnumMembers(Id, Host, mkType, EnumProc, N3); + <font color="blue"><b>end</b></font>; + <font color="blue"><b>end</b></font>; +<font color="blue"><b>end</b></font>; + +<font color="blue"><b>procedure</b></font> TForm1.TreeView1DblClick(Sender: TObject); +<font color="blue"><b>var</b></font> + N: TTreeNode; + Id, Position: Integer; + S: <font color="blue"><b>String</b></font>; +<font color="blue"><b>begin</b></font> + N := TTreeView(Sender).Selected; + + <font color="blue"><b>if</b></font> N = <font color="blue"><b>nil</b></font> <font color="blue"><b>then</b></font> + Exit; + + Id := Integer(N.Data); + + <font color="blue"><b>if</b></font> Id = 0 <font color="blue"><b>then</b></font> + Exit; + + S := PaxCompilerExplorer1.Names[Id]; + Position := PaxCompilerExplorer1.Positions[Id]; + + <font color="blue"><b>if</b></font> Id <> 0 <font color="blue"><b>then</b></font> + <font color="blue"><b>with</b></font> Memo1 <font color="blue"><b>do</b></font> + <font color="blue"><b>begin</b></font> + SetFocus; + SelStart := Position; + SelLength := Length(S); + <font color="blue"><b>end</b></font>; +<font color="blue"><b>end</b></font>; + +<font color="blue"><b>end</b></font>. +</pre> +</blockquote> + +<p> +<HR> +<font size = 1 color ="gray"> +Copyright © 2006-2009 +VIRT Laboratory. All rights reserved. +</font> +</body> +</html> diff --git a/help/demo_hello_app.htm b/help/demo_hello_app.htm new file mode 100644 index 0000000..ebd79cf --- /dev/null +++ b/help/demo_hello_app.htm @@ -0,0 +1,73 @@ +<html> +<head> +<link rel=stylesheet type="text/css" href="styles.css"> +</head> +<body> +<H2> +paxCompiler for Delphi. "Hello" application. +</H2> +<hr> + +<blockquote> +<pre> +<font color="blue"><b>unit</b></font> Unit1; + +<font color="blue"><b>interface</b></font> + +<font color="blue"><b>uses</b></font> + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, PaxCompiler, PaxProgram; +<font color="blue"><b>type</b></font> + TForm1 = <font color="blue"><b>class</b></font>(TForm) + PaxCompiler1: TPaxCompiler; + PaxPascalLanguage1: TPaxPascalLanguage; + PaxProgram1: TPaxProgram; + Button1: TButton; + <font color="blue"><b>procedure</b></font> Button1Click(Sender: TObject); + <font color="blue"><b>private</b></font> + { Private declarations } + <font color="blue"><b>public</b></font> + { Public declarations } + <font color="blue"><b>end</b></font>; + +<font color="blue"><b>var</b></font> + Form1: TForm1; + +<font color="blue"><b>implementation</b></font> + +{$R *.dfm} + +<font color="blue"><b>procedure</b></font> TForm1.Button1Click(Sender: TObject); +<font color="blue"><b>var</b></font> + I, H_TButton: Integer; +<font color="blue"><b>begin</b></font> + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + + H_TButton := PaxCompiler1.RegisterClassType(0, TButton); + PaxCompiler1.RegisterVariable(0, <font color="Red">'Button1'</font>, H_TButton, @Button1); + + PaxCompiler1.AddModule(<font color="Red">'1'</font>, PaxPascalLanguage1.LanguageName); + PaxCompiler1.AddCode(<font color="Red">'1'</font>, <font color="Red">'begin'</font>); + PaxCompiler1.AddCode(<font color="Red">'1'</font>, <font color="Red">' Button1.Caption := '</font><font color="Red">'Hello'</font><font color="Red">';'</font>); + PaxCompiler1.AddCode(<font color="Red">'1'</font>, <font color="Red">'end.'</font>); + + <font color="blue"><b>if</b></font> PaxCompiler1.Compile(PaxProgram1) <font color="blue"><b>then</b></font> + PaxProgram1.Run + <font color="blue"><b>else</b></font> + <font color="blue"><b>for</b></font> I:=0 <font color="blue"><b>to</b></font> PaxCompiler1.ErrorCount - 1 <font color="blue"><b>do</b></font> + ShowMessage(PaxCompiler1.ErrorMessage[I]); +<font color="blue"><b>end</b></font>; + +<font color="blue"><b>end</b></font>. +</pre> +</blockquote> + +<p> +<HR> +<font size = 1 color ="gray"> +Copyright © 2006-2009 +VIRT Laboratory. All rights reserved. +</font> +</body> +</html> diff --git a/help/demo_inheritance.htm b/help/demo_inheritance.htm new file mode 100644 index 0000000..b675a8b --- /dev/null +++ b/help/demo_inheritance.htm @@ -0,0 +1,173 @@ +<html> +<head> +<link rel=stylesheet type="text/css" href="styles.css"> +</head> +<body> +<H2> +paxCompiler for Delphi. Inheritance of host-defined classes. +</H2> +<hr> + +<h4>Script</h4> + +<blockquote> +<pre> +<font color="blue"><b>uses</b></font> + Classes; +<font color="blue"><b>type</b></font> + TMyForm = <font color="blue"><b>class</b></font>(TForm) + <font color="blue"><b>private</b></font> + Button1: TButton; + <font color="blue"><b>public</b></font> + <font color="blue"><b>constructor</b></font> Create(AOwner: TComponent); + <font color="blue"><b>procedure</b></font> Button1Click(Sender: TObject); + <font color="blue"><b>end</b></font>; + +<font color="blue"><b>constructor</b></font> TMyForm.Create(AOwner: TComponent); +<font color="blue"><b>begin</b></font> + <font color="blue"><b>inherited</b></font>; + Top := 100; + Left := 200; + Caption := <font color="Red">'Script-defined form MyForm'</font>; + Button1 := TButton.Create(Self); + Button1.Parent := Self; + Button1.Top := 50; + Button1.Left := 50; + Button1.Caption := <font color="Red">'Click me'</font>; + Button1.OnClick := Button1Click; +<font color="blue"><b>end</b></font>; + +<font color="blue"><b>procedure</b></font> TMyForm.Button1Click(Sender: TObject); +<font color="blue"><b>begin</b></font> + ShowMessage(<font color="Red">'Hello!'</font>); + ShowMessage(<font color="Red">'Sender: '</font> + Sender.ClassName); +<font color="blue"><b>end</b></font>; + +<font color="blue"><b>var</b></font> + F: TMyForm; +<font color="blue"><b>begin</b></font> + F := TMyForm.Create(Self); + F.Show; +<font color="blue"><b>end</b></font>. +</pre> +</blockquote> + + +<h4>Delphi Application</h4> + +<blockquote> +<pre> +<font color="blue"><b>unit</b></font> Unit1; + +<font color="blue"><b>interface</b></font> + +<font color="blue"><b>uses</b></font> + Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, + Dialogs, PaxProgram, PaxCompiler, StdCtrls; + +<font color="blue"><b>type</b></font> + TForm1 = <font color="blue"><b>class</b></font>(TForm) + Button1: TButton; + PaxCompiler1: TPaxCompiler; + PaxPascalLanguage1: TPaxPascalLanguage; + PaxProgram1: TPaxProgram; + Memo1: TMemo; + <font color="blue"><b>procedure</b></font> Button1Click(Sender: TObject); + <font color="blue"><b>procedure</b></font> PaxProgram1UnhandledException(Sender: TPaxProgram; + E: Exception; <font color="blue"><b>const</b></font> ModuleName: <font color="blue"><b>String</b></font>; SourceLineNumber: Integer); + <font color="blue"><b>private</b></font> + { Private declarations } + <font color="blue"><b>public</b></font> + { Public declarations } + <font color="blue"><b>end</b></font>; + +<font color="blue"><b>var</b></font> + Form1: TForm1; + +<font color="blue"><b>implementation</b></font> + +{$R *.dfm} + +<font color="blue"><b>uses</b></font> + IMPORT_Classes; + +<font color="blue"><b>var</b></font> + H_TForm: Integer; + +<font color="blue"><b>procedure</b></font> TForm1.Button1Click(Sender: TObject); +<font color="blue"><b>var</b></font> + I: Integer; +<font color="blue"><b>begin</b></font> + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + PaxCompiler1.AddModule(<font color="Red">'1'</font>, <font color="Red">'Pascal'</font>); + PaxCompiler1.AddCode(<font color="Red">'1'</font>, Memo1.Lines.Text); + PaxCompiler1.RegisterVariable(0, <font color="Red">'Self'</font>, H_TForm, @Form1); + + PaxPascalLanguage1.SetCallConv(_ccREGISTER); + + <font color="blue"><b>if</b></font> PaxCompiler1.Compile(PaxProgram1) <font color="blue"><b>then</b></font> + <font color="blue"><b>begin</b></font> + PaxProgram1.Run; + <font color="blue"><b>end</b></font> + <font color="blue"><b>else</b></font> + <font color="blue"><b>for</b></font> I:=0 <font color="blue"><b>to</b></font> PaxCompiler1.ErrorCount - 1 <font color="blue"><b>do</b></font> + ShowMessage(PaxCompiler1.ErrorMessage[I]); +<font color="blue"><b>end</b></font>; + +<font color="blue"><b>procedure</b></font> TForm1.PaxProgram1UnhandledException(Sender: TPaxProgram; + E: Exception; <font color="blue"><b>const</b></font> ModuleName: <font color="blue"><b>String</b></font>; SourceLineNumber: Integer); +<font color="blue"><b>begin</b></font> + ShowMessage( + <font color="Red">'Exception ('</font> + E.Message + + <font color="Red">') raised at line '</font> + IntToStr(SourceLineNumber) + <font color="Red">':'</font> + + PaxCompiler1.Modules[ModuleName][SourceLineNumber] + ); +<font color="blue"><b>end</b></font>; + +<font color="blue"><b>function</b></font> TControl_GetParent(Self: TControl): TWinControl; +<font color="blue"><b>begin</b></font> + result := Self.Parent; +<font color="blue"><b>end</b></font>; + +<font color="blue"><b>procedure</b></font> TControl_SetParent(Self: TControl; Value: TWinControl); +<font color="blue"><b>begin</b></font> + Self.Parent := Value; +<font color="blue"><b>end</b></font>; + +<font color="blue"><b>var</b></font> + H: Integer; + +<font color="blue"><b>initialization</b></font> + + H := RegisterClassType(0, TControl); + RegisterClassType(0, TWinControl); + RegisterHeader(H, <font color="Red">'function _GetParent: TWinControl;'</font>, @TControl_GetParent); + RegisterHeader(H, <font color="Red">'procedure _SetParent(Value: TWinControl);'</font>, @TControl_SetParent); + RegisterProperty(H, <font color="Red">'property Parent: TWinControl read _GetParent write _SetParent;'</font>); + + H_TForm := RegisterClassType(0, TForm); + RegisterHeader(H_TForm, <font color="Red">'constructor Create(AOwner: TComponent); override;'</font>, + @TForm.Create); + RegisterHeader(H_TForm, <font color="Red">'procedure Show;'</font>, @TForm.Show); + + H := RegisterClassType(0, TButton); + RegisterHeader(H, <font color="Red">'constructor Create(AOwner: TComponent); override;'</font>, + @TButton.Create); + + RegisterHeader(0, <font color="Red">'procedure ShowMessage(const Msg: string);'</font>, @ShowMessage); + + +<font color="blue"><b>end</b></font>. +</pre> +</blockquote> + + +<p> +<HR> +<font size = 1 color ="gray"> +Copyright © 2006-2009 +VIRT Laboratory. All rights reserved. +</font> +</body> +</html> diff --git a/help/demo_load_compiled.htm b/help/demo_load_compiled.htm new file mode 100644 index 0000000..9f95013 --- /dev/null +++ b/help/demo_load_compiled.htm @@ -0,0 +1,123 @@ +<html> +<head> +<link rel=stylesheet type="text/css" href="styles.css"> +</head> +<body> +<H2> +paxCompiler for Delphi. Loading compiled scripts. +</H2> +<hr> + + +<blockquote> +<pre> +<font color="blue"><b>unit</b></font> Unit1; + +<font color="blue"><b>interface</b></font> + +<font color="blue"><b>uses</b></font> + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, PaxCompiler, PaxProgram; +<font color="blue"><b>type</b></font> + TForm1 = <font color="blue"><b>class</b></font>(TForm) + Button1: TButton; + Button2: TButton; + <font color="blue"><b>procedure</b></font> Button1Click(Sender: TObject); + <font color="blue"><b>procedure</b></font> Button2Click(Sender: TObject); + <font color="blue"><b>procedure</b></font> FormCreate(Sender: TObject); + <font color="blue"><b>private</b></font> + H_ShowMessage: Integer; + H_S: Integer; + S: AnsiString; + { Private declarations } + <font color="blue"><b>public</b></font> + { Public declarations } + <font color="blue"><b>end</b></font>; + +<font color="blue"><b>var</b></font> + Form1: TForm1; + +<font color="blue"><b>implementation</b></font> + +{$R *.dfm} + +<font color="blue"><b>procedure</b></font> TForm1.Button1Click(Sender: TObject); +<font color="blue"><b>var</b></font> + I: Integer; + PaxCompiler1: TPaxCompiler; + PaxPascalLanguage1: TPaxPascalLanguage; + PaxProgram1: TPaxProgram; +<font color="blue"><b>begin</b></font> + PaxCompiler1 := TPaxCompiler.Create(<font color="blue"><b>nil</b></font>); + PaxPascalLanguage1 := TPaxPascalLanguage.Create(<font color="blue"><b>nil</b></font>); + PaxProgram1 := TPaxProgram.Create(<font color="blue"><b>nil</b></font>); + + <font color="blue"><b>try</b></font> + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + + // register routine ShowMessage + H_ShowMessage := PaxCompiler1.RegisterHeader(0, <font color="Red">'procedure ShowMessage(const Msg: string);'</font>); + + // register variable S + H_S := PaxCompiler1.RegisterVariable(0, <font color="Red">'S'</font>, _typeSTRING); + + PaxCompiler1.AddModule(<font color="Red">'1'</font>, PaxPascalLanguage1.LanguageName); + PaxCompiler1.AddCode(<font color="Red">'1'</font>, <font color="Red">'begin'</font>); + PaxCompiler1.AddCode(<font color="Red">'1'</font>, <font color="Red">' ShowMessage(S);'</font>); + PaxCompiler1.AddCode(<font color="Red">'1'</font>, <font color="Red">'end.'</font>); + + <font color="blue"><b>if</b></font> PaxCompiler1.Compile(PaxProgram1) <font color="blue"><b>then</b></font> + <font color="blue"><b>begin</b></font> + PaxProgram1.SaveToFile(<font color="Red">'1.bin'</font>); + ShowMessage(<font color="Red">'Compiled script has been created!'</font>); + <font color="blue"><b>end</b></font> + <font color="blue"><b>else</b></font> + <font color="blue"><b>for</b></font> I:=0 <font color="blue"><b>to</b></font> PaxCompiler1.ErrorCount - 1 <font color="blue"><b>do</b></font> + ShowMessage(PaxCompiler1.ErrorMessage[I]); + <font color="blue"><b>finally</b></font> + PaxCompiler1.Free; + PaxPascalLanguage1.Free; + PaxProgram1.Free; + <font color="blue"><b>end</b></font>; +<font color="blue"><b>end</b></font>; + +<font color="blue"><b>procedure</b></font> TForm1.Button2Click(Sender: TObject); +<font color="blue"><b>var</b></font> + PaxProgram1: TPaxProgram; +<font color="blue"><b>begin</b></font> + <font color="blue"><b>if</b></font> FileExists(<font color="Red">'1.bin'</font>) <font color="blue"><b>and</b></font> (H_ShowMessage <> 0) <font color="blue"><b>and</b></font> (H_S <> 0) <font color="blue"><b>then</b></font> + <font color="blue"><b>begin</b></font> + PaxProgram1 := TPaxProgram.Create(<font color="blue"><b>nil</b></font>); + <font color="blue"><b>try</b></font> + PaxProgram1.LoadFromFile(<font color="Red">'1.bin'</font>); + PaxProgram1.SetAddress(H_ShowMessage, @ShowMessage); + PaxProgram1.SetAddress(H_S, @S); + PaxProgram1.Run; + <font color="blue"><b>finally</b></font> + PaxProgram1.Free; + <font color="blue"><b>end</b></font>; + <font color="blue"><b>end</b></font> + <font color="blue"><b>else</b></font> + ShowMessage(<font color="Red">'Press the first button to create compiled script.'</font>); +<font color="blue"><b>end</b></font>; + +<font color="blue"><b>procedure</b></font> TForm1.FormCreate(Sender: TObject); +<font color="blue"><b>begin</b></font> + H_ShowMessage := 0; + H_S := 0; + S := <font color="Red">'Hello'</font>; +<font color="blue"><b>end</b></font>; + +<font color="blue"><b>end</b></font>. +</pre> +</blockquote> + + +<p> +<HR> +<font size = 1 color ="gray"> +Copyright © 2006-2009 +VIRT Laboratory. All rights reserved. +</font> +</body> +</html> diff --git a/help/demo_on_used_unit.htm b/help/demo_on_used_unit.htm new file mode 100644 index 0000000..994807e --- /dev/null +++ b/help/demo_on_used_unit.htm @@ -0,0 +1,96 @@ +<html> +<head> +<link rel=stylesheet type="text/css" href="styles.css"> +</head> +<body> +<H2> +paxCompiler for Delphi. OnUsedEvent demo. +</H2> +<hr> + +<blockquote> +<pre> +<font color="blue"><b>unit</b></font> Unit1; + +<font color="blue"><b>interface</b></font> + +<font color="blue"><b>uses</b></font> + Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, + Dialogs, PaxProgram, PaxCompiler, StdCtrls; + +<font color="blue"><b>type</b></font> + TForm1 = <font color="blue"><b>class</b></font>(TForm) + Button1: TButton; + PaxCompiler1: TPaxCompiler; + PaxPascalLanguage1: TPaxPascalLanguage; + PaxProgram1: TPaxProgram; + <font color="blue"><b>procedure</b></font> Button1Click(Sender: TObject); + <font color="blue"><b>function</b></font> PaxCompiler1UsedUnit(Sender: TPaxCompiler; + <font color="blue"><b>const</b></font> UnitName: <font color="blue"><b>String</b></font>; <font color="blue"><b>var</b></font> SourceCode: <font color="blue"><b>String</b></font>): Boolean; + <font color="blue"><b>private</b></font> + { Private declarations } + <font color="blue"><b>public</b></font> + { Public declarations } + <font color="blue"><b>end</b></font>; + +<font color="blue"><b>var</b></font> + Form1: TForm1; + +<font color="blue"><b>implementation</b></font> + +{$R *.dfm} + +<font color="blue"><b>procedure</b></font> TForm1.Button1Click(Sender: TObject); +<font color="blue"><b>begin</b></font> + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + PaxCompiler1.AddModule(<font color="Red">'main'</font>, <font color="Red">'Pascal'</font>); + PaxCompiler1.AddCode(<font color="Red">'main'</font>, <font color="Red">'uses SomeUnit;'</font>); + PaxCompiler1.AddCode(<font color="Red">'main'</font>, <font color="Red">'begin'</font>); + PaxCompiler1.AddCode(<font color="Red">'main'</font>, <font color="Red">' P;'</font>); + PaxCompiler1.AddCode(<font color="Red">'main'</font>, <font color="Red">'end.'</font>); + <font color="blue"><b>if</b></font> PaxCompiler1.Compile(PaxProgram1) <font color="blue"><b>then</b></font> + <font color="blue"><b>begin</b></font> + PaxProgram1.Run; + <font color="blue"><b>end</b></font> + <font color="blue"><b>else</b></font> + ShowMessage(PaxCompiler1.ErrorMessage[0]); +<font color="blue"><b>end</b></font>; + +<font color="blue"><b>function</b></font> TForm1.PaxCompiler1UsedUnit(Sender: TPaxCompiler; + <font color="blue"><b>const</b></font> UnitName: <font color="blue"><b>String</b></font>; <font color="blue"><b>var</b></font> SourceCode: <font color="blue"><b>String</b></font>): Boolean; +<font color="blue"><b>begin</b></font> + <font color="blue"><b>if</b></font> UnitName = <font color="Red">'SomeUnit'</font> <font color="blue"><b>then</b></font> + <font color="blue"><b>begin</b></font> + result := true; + SourceCode := + + <font color="Red">'unit SomeUnit;'</font> + #13#10 + + <font color="Red">'interface'</font> + #13#10 + + <font color="Red">'procedure P;'</font> + #13#10 + + <font color="Red">'implementation'</font> + #13#10 + + <font color="Red">'procedure P;'</font> + #13#10 + + <font color="Red">'begin'</font> + #13#10 + + <font color="Red">' ShowMessage('</font><font color="Red">'Hello'</font><font color="Red">');'</font> + #13#10 + + <font color="Red">'end;'</font> + #13#10 + + <font color="Red">'end.'</font> + #13#10; + + <font color="blue"><b>end</b></font> + <font color="blue"><b>else</b></font> + result := false; // default processing +<font color="blue"><b>end</b></font>; + +<font color="blue"><b>initialization</b></font> + RegisterHeader(0, <font color="Red">'procedure ShowMessage(const Msg: string);'</font>, @ShowMessage); +<font color="blue"><b>end</b></font>. +</pre> +</blockquote> + +<p> +<HR> +<font size = 1 color ="gray"> +Copyright © 2006-2009 +VIRT Laboratory. All rights reserved. +</font> +</body> +</html> diff --git a/help/demo_register_host_vars.htm b/help/demo_register_host_vars.htm new file mode 100644 index 0000000..586623f --- /dev/null +++ b/help/demo_register_host_vars.htm @@ -0,0 +1,93 @@ +<html> +<head> +<link rel=stylesheet type="text/css" href="styles.css"> +</head> +<body> +<H2> +paxCompiler for Delphi. Register host-defined variables. +</H2> +<hr> + +<blockquote> +<pre> +<font color="blue"><b>unit</b></font> Unit1; + +<font color="blue"><b>interface</b></font> + +<font color="blue"><b>uses</b></font> + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, + Dialogs, StdCtrls, PaxCompiler, PaxProgram; + +<font color="blue"><b>type</b></font> + TForm1 = <font color="blue"><b>class</b></font>(TForm) + PaxCompiler1: TPaxCompiler; + PaxPascalLanguage1: TPaxPascalLanguage; + PaxProgram1: TPaxProgram; + Button1: TButton; + <font color="blue"><b>procedure</b></font> Button1Click(Sender: TObject); + <font color="blue"><b>private</b></font> + { Private declarations } + <font color="blue"><b>public</b></font> + { Public declarations } + <font color="blue"><b>end</b></font>; + +<font color="blue"><b>var</b></font> + Form1: TForm1; + +<font color="blue"><b>implementation</b></font> + +{$R *.dfm} + +<font color="blue"><b>type</b></font> + TMyPoint = packed <font color="blue"><b>record</b></font> + x, y: Integer; + <font color="blue"><b>end</b></font>; + +<font color="blue"><b>procedure</b></font> TForm1.Button1Click(Sender: TObject); +<font color="blue"><b>var</b></font> + H_TMyPoint, H_MyPoint: Integer; + MyPoint: TMyPoint; + I: Integer; +<font color="blue"><b>begin</b></font> + MyPoint.X := 60; + MyPoint.Y := 23; + + PaxCompiler1.Reset; + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + + // register host-defined type + H_TMyPoint := PaxCompiler1.RegisterRecordType(0, <font color="Red">'TMyPoint'</font>); + PaxCompiler1.RegisterRecordTypeField(H_TMyPoint, <font color="Red">'X'</font>, _typeINTEGER); + PaxCompiler1.RegisterRecordTypeField(H_TMyPoint, <font color="Red">'Y'</font>, _typeINTEGER); + + // register host-defined variable + H_MyPoint := PaxCompiler1.RegisterVariable(0, <font color="Red">'MyPoint'</font>, H_TMyPoint, @MyPoint); + + PaxCompiler1.AddModule(<font color="Red">'1'</font>, PaxPascalLanguage1.LanguageName); + PaxCompiler1.AddCode(<font color="Red">'1'</font>, <font color="Red">'begin'</font>); + PaxCompiler1.AddCode(<font color="Red">'1'</font>, <font color="Red">' MyPoint.Y := 8;'</font>); + PaxCompiler1.AddCode(<font color="Red">'1'</font>, <font color="Red">'end.'</font>); + + <font color="blue"><b>if</b></font> PaxCompiler1.Compile(PaxProgram1) <font color="blue"><b>then</b></font> + <font color="blue"><b>begin</b></font> + PaxProgram1.Run; + ShowMessage(IntToStr(MyPoint.Y)); + <font color="blue"><b>end</b></font> + <font color="blue"><b>else</b></font> + <font color="blue"><b>for</b></font> I:=0 <font color="blue"><b>to</b></font> PaxCompiler1.ErrorCount <font color="blue"><b>do</b></font> + ShowMessage(PaxCompiler1.ErrorMessage[I]); +<font color="blue"><b>end</b></font>; + +<font color="blue"><b>end</b></font>. +</pre> +</blockquote> + + +<p> +<HR> +<font size = 1 color ="gray"> +Copyright © 2006-2009 +VIRT Laboratory. All rights reserved. +</font> +</body> +</html> diff --git a/help/faq.htm b/help/faq.htm new file mode 100644 index 0000000..77aa2bc --- /dev/null +++ b/help/faq.htm @@ -0,0 +1,436 @@ +<html> +<head> +<link rel=stylesheet type="text/css" href="styles.css"> +</head> + +<body> + +<font face="Arial, Helvetica"> + +<h2> +paxCompiler FAQ +</h2> +<hr> + +<ul> + +<li> <h3>1</h3> +<blockquote> +<h3> +Request +</h3> + +Can I import abstract classes? + +<h3> +Solution +</h3> + +Yes. The following demo illustrates it. + +<blockquote> +<pre> +{$APPTYPE CONSOLE} +<font color="blue"><b>program</b></font> Project1; +<font color="blue"><b>uses</b></font> + PaxCompiler, PaxInterpreter, PaxRegister; +<font color="blue"><b>type</b></font> + TMyHostClass = <font color="blue"><b>class</b></font> + <font color="blue"><b>public</b></font> + <font color="blue"><b>constructor</b></font> Create; <font color="blue"><b>virtual</b></font>; <font color="blue"><b>abstract</b></font>; + <font color="blue"><b>procedure</b></font> P; <font color="blue"><b>virtual</b></font>; <font color="blue"><b>abstract</b></font>; + <font color="blue"><b>end</b></font>; + TMyHostClassClass = <font color="blue"><b>class</b></font> <font color="blue"><b>of</b></font> TMyHostClass; + +<font color="blue"><b>var</b></font> + PaxCompiler1: TPaxCompiler; + PaxInterpreter1: TPaxInterpreter; + PaxPascalLanguage1: TPaxPascalLanguage; + I: Integer; + + C: TMyHostClassClass; + X: TMyHostClass; +<font color="blue"><b>begin</b></font> + I := RegisterClassType(0, TMyHostClass); +// Note, you have to register abstract members in order of appearance in the class definition above. + RegisterHeader(I, + <font color="Red">'constructor Create; virtual; abstract;'</font>, + <font color="blue"><b>nil</b></font>); + RegisterHeader(I, + <font color="Red">'procedure P; virtual; abstract;'</font>, + <font color="blue"><b>nil</b></font>); + + PaxCompiler1 := TPaxCompiler.Create(<font color="blue"><b>nil</b></font>); + PaxInterpreter1 := TPaxInterpreter.Create(<font color="blue"><b>nil</b></font>); + PaxPascalLanguage1 := TPaxPascalLanguage.Create(<font color="blue"><b>nil</b></font>); + <font color="blue"><b>try</b></font> + PaxCompiler1.RegisterLanguage(PaxPascalLanguage1); + PaxCompiler1.AddModule(<font color="Red">'1'</font>, <font color="Red">'Pascal'</font>); + PaxCompiler1.AddCodeFromFile(<font color="Red">'1'</font>, <font color="Red">'script.txt'</font>); + <font color="blue"><b>if</b></font> PaxCompiler1.Compile(PaxInterpreter1) <font color="blue"><b>then</b></font> + <font color="blue"><b>begin</b></font> + PaxInterpreter1.RunInitialization; + +// Create script-defined object at host side. + + C := TMyHostClassClass(PaxInterpreter1.GetAddress(<font color="Red">'TMyScriptClass'</font>)^); + X := C.Create; + X.P; + X.Free; + <font color="blue"><b>end</b></font> + <font color="blue"><b>else</b></font> + <font color="blue"><b>begin</b></font> + writeln(PaxCompiler1.ErrorMessage[0]); + writeln(PaxCompiler1.ErrorLineNumber[0]); + writeln(PaxCompiler1.ErrorLine[0]); + <font color="blue"><b>end</b></font>; + + <font color="blue"><b>for</b></font> I:=0 <font color="blue"><b>to</b></font> PaxCompiler1.WarningCount - 1 <font color="blue"><b>do</b></font> + <font color="blue"><b>begin</b></font> + writeln(PaxCompiler1.WarningMessage[I]); + writeln(PaxCompiler1.WarningLineNumber[I]); + writeln(PaxCompiler1.WarningLine[I]); + <font color="blue"><b>end</b></font>; + + <font color="blue"><b>finally</b></font> + PaxCompiler1.Free; + PaxInterpreter1.Free; + PaxPascalLanguage1.Free; + <font color="blue"><b>end</b></font>; + writeln(<font color="Red">'Press any key...'</font>); + Readln; +<font color="blue"><b>end</b></font>. +</pre> +</blockquote> + +Script: + +<blockquote> +<pre> +<font color="blue"><b>type</b></font> + TMyScriptClass = <font color="blue"><b>class</b></font>(TMyHostClass) + <font color="blue"><b>constructor</b></font> Create; <font color="blue"><b>override</b></font>; + <font color="blue"><b>procedure</b></font> P; <font color="blue"><b>override</b></font>; + <font color="blue"><b>end</b></font>; + +<font color="blue"><b>constructor</b></font> TMyScriptClass.Create; +<font color="blue"><b>begin</b></font> + <font color="blue"><b>print</b></font> <font color="Red">'Script object of '</font> + ClassName + <font color="Red">' is created.'</font>; +<font color="blue"><b>end</b></font>; + +<font color="blue"><b>procedure</b></font> TMyScriptClass.P; +<font color="blue"><b>begin</b></font> + <font color="blue"><b>print</b></font> <font color="Red">'Hello from script!'</font>; +<font color="blue"><b>end</b></font>; + +<font color="blue"><b>begin</b></font> +<font color="blue"><b>end</b></font>. +</pre> +</blockquote> + +<li> <h3>2</h3> +<blockquote> +<h3> +Request +</h3> + +How I could register an overloadesd procedure/function for scripting engine? + +<h3> +Solution +</h3> + +You need to find out address of the procedure (function). It is more easy to explain it +on an example. Let's suppose we have 2 overloaded procedures: + +<blockquote> + +<pre> +<font color="blue"><b>procedure</b></font> MyProc(<font color="blue"><b>const</b></font> S: <font color="blue"><b>String</b></font>); <font color="blue"><b>overload</b></font>; +<font color="blue"><b>begin</b></font> + writeln(1); +<font color="blue"><b>end</b></font>; + +<font color="blue"><b>procedure</b></font> MyProc(I : Integer); <font color="blue"><b>overload</b></font>; +<font color="blue"><b>begin</b></font> + writeln(2); +<font color="blue"><b>end</b></font>; +</pre> +</blockquote> + +You can use the following code to obtain the addresses: + +<blockquote> + +<pre> +<font color="blue"><b>function</b></font> Address1: Pointer; +<font color="blue"><b>type</b></font> + TMyProc = <font color="blue"><b>procedure</b></font> (<font color="blue"><b>const</b></font> S: <font color="blue"><b>String</b></font>); +<font color="blue"><b>var</b></font> + P: TMyProc; +<font color="blue"><b>begin</b></font> + P := MyProc; + Move(P, result, 4); +<font color="blue"><b>end</b></font>; + +<font color="blue"><b>function</b></font> Address2: Pointer; +<font color="blue"><b>type</b></font> + TMyProc = <font color="blue"><b>procedure</b></font> (I: Integer); +<font color="blue"><b>var</b></font> + P: TMyProc; +<font color="blue"><b>begin</b></font> + P := MyProc; + Move(P, result, 4); +<font color="blue"><b>end</b></font>; +</pre> +</blockquote> +</body> + +Now you can register the overloaded procedures for paxCompiler engine: + +<blockquote> + +<pre> +RegisterHeader(0, <font color="Red">'procedure MyProc(const S: String); overload;'</font>, + Address1); + RegisterHeader(0, <font color="Red">'procedure MyProc(I : Integer); overload;'</font>, + Address2); +</pre> +</blockquote> + + +</blockquote> +</li> + + + +<li> <h3>3</h3> +<blockquote> +<h3> +Request +</h3> + +How I could register an overloadesd method for scripting engine? In particular, how I could +register an overloaded virtual method? + +<h3> +Solution +</h3> + +Let's suppose we have a class: + +<blockquote> + +<pre> +<font color="blue"><b>type</b></font> + TMyClass = <font color="blue"><b>class</b></font> + <font color="blue"><b>procedure</b></font> MyProc(<font color="blue"><b>const</b></font> S: <font color="blue"><b>String</b></font>); <font color="blue"><b>overload</b></font>; <font color="blue"><b>virtual</b></font>; + <font color="blue"><b>procedure</b></font> MyProc(I : Integer); <font color="blue"><b>overload</b></font>; <font color="blue"><b>virtual</b></font>; + <font color="blue"><b>end</b></font>; +</pre> +</blockquote> + +You can use the following code to obtain the addresses of methods: + +<blockquote> + +<pre> +<font color="blue"><b>function</b></font> MethodAddress1: Pointer; +<font color="blue"><b>type</b></font> + TMyProc = <font color="blue"><b>procedure</b></font> (<font color="blue"><b>const</b></font> S: <font color="blue"><b>String</b></font>) <font color="blue"><b>of</b></font> object; +<font color="blue"><b>var</b></font> + P: TMyProc; + X: TMyClass; + M: TMethod; +<font color="blue"><b>begin</b></font> + GetMem(Pointer(X), 4); + Pointer(Pointer(X)^) := TMyClass; + P := X.MyProc; + Move(P, M, SizeOf(TMethod)); + result := M.Code; + FreeMem(Pointer(X), 4); +<font color="blue"><b>end</b></font>; + +<font color="blue"><b>function</b></font> MethodAddress2: Pointer; +<font color="blue"><b>type</b></font> + TMyProc = <font color="blue"><b>procedure</b></font> (I: Integer) <font color="blue"><b>of</b></font> object; +<font color="blue"><b>var</b></font> + P: TMyProc; + X: TMyClass; + M: TMethod; +<font color="blue"><b>begin</b></font> + GetMem(Pointer(X), 4); + Pointer(Pointer(X)^) := TMyClass; + P := X.MyProc; + Move(P, M, SizeOf(TMethod)); + result := M.Code; + FreeMem(Pointer(X), 4); +<font color="blue"><b>end</b></font>; +</pre> +</blockquote> + + +After optimization, we can get improved versions of the address functions: + +<blockquote> + +<pre> +<font color="blue"><b>function</b></font> MethodAddress1_Op: Pointer; +<font color="blue"><b>type</b></font> + TMyProc = <font color="blue"><b>procedure</b></font> (<font color="blue"><b>const</b></font> S: <font color="blue"><b>String</b></font>) <font color="blue"><b>of</b></font> object; +<font color="blue"><b>var</b></font> + P: TMyProc; + X: TMyClass; + M: TMethod; + V: TClass; +<font color="blue"><b>begin</b></font> + V := TMyClass; + X := @V; + P := X.MyProc; + Move(P, M, SizeOf(TMethod)); + result := M.Code; +<font color="blue"><b>end</b></font>; + +<font color="blue"><b>function</b></font> MethodAddress2_Op: Pointer; +<font color="blue"><b>type</b></font> + TMyProc = <font color="blue"><b>procedure</b></font> (I: Integer) <font color="blue"><b>of</b></font> object; +<font color="blue"><b>var</b></font> + P: TMyProc; + X: TMyClass; + M: TMethod; + V: TClass; +<font color="blue"><b>begin</b></font> + V := TMyClass; + X := @V; + P := X.MyProc; + Move(P, M, SizeOf(TMethod)); + result := M.Code; +<font color="blue"><b>end</b></font>; +</pre> +</blockquote> + +Now we can registerTMyClass type for paxCompiler: + +<blockquote> + +<pre> + G := RegisterClassType(0, TMyClass); + RegisterHeader(G, <font color="Red">'procedure MyProc(const S: String); overload; virtual;'</font>, + MethodAddress1_Op); + RegisterHeader(G, <font color="Red">'procedure MyProc(I : Integer); overload; virtual;'</font>, + MethodAddress2_Op); +</pre> +</blockquote> + +</blockquote> +</li> + + + +<li> <h3>4</h3> +<blockquote> +<h3> +Request +</h3> + +How I could register an overloadesd constructor for scripting engine? + +<h3> +Solution +</h3> + +Let's suppose weI have a host class: + +<blockquote> +<pre> + +type + TMyClass = class + constructor Create; overload; + constructor Create(I: Integer); overload; virtual; + end; +</pre> +</blockquote> + +Then + +<blockquote> +<pre> +P := @TMyClass.Create; +</pre> +</blockquote> + + +returns address of the first overloaded constructor. + +To find address of the second constructor we create an inherited class + +<blockquote> +<pre> +TMyClass2 = class(TMyClass) + constructor Create(I: Integer); override; + end; +</pre> +</blockquote> + +Then + +<blockquote> +<pre> +P := @TMyClass2.Create; +</pre> +</blockquote> + +returns address of non-overloaded constructor of this class. + +After that we apply 2 functions: + +<blockquote> +<pre> +const + MaxVirtuals = 1000; +type + PPointerArray = ^TPointerArray; + TPointerArray = array[0..MaxVirtuals] of pointer; + +function GetMethodIndex(C: TClass; Address: Pointer): Integer; +var + I: Integer; +begin + result := -1; + for I := 0 to MaxVirtuals do + if PPointerArray(C)[I] = Address then + begin + result := I; + Exit; + end; +end; + +function GetMethodAddress(C: TClass; Index: Integer): Pointer; +begin + result := PPointerArray(C)[Index]; +end; +</pre> +</blockquote> + +to find address of the second constructor of TMyClass: + +<blockquote> +<pre> + + I := GetMethodIndex(TMyClass2, P); + P := GetMethodAddress(TMyClass, I); +</pre> +</blockquote> + + +</ul> + +<p> +<HR> +<font size = 1 color ="gray"> +Copyright © 2006-2014 +VIRT Laboratory. All rights reserved. +</font> +</body> +</html> diff --git a/help/faq.jpg b/help/faq.jpg new file mode 100644 index 0000000..8fd9c67 Binary files /dev/null and b/help/faq.jpg differ diff --git a/help/import_classes.htm b/help/import_classes.htm new file mode 100644 index 0000000..5ae1ca2 --- /dev/null +++ b/help/import_classes.htm @@ -0,0 +1,781 @@ +<html> +<head> +<link rel=stylesheet type="text/css" href="styles.css"> +</head> +<body> +<H2> +paxCompiler for Delphi. Import unit IMPORT_Classes.pas. +</H2> +<hr> + +<blockquote> +<pre> +<font color="blue"><b>unit</b></font> IMPORT_Classes; +<font color="blue"><b>interface</b></font> +<font color="blue"><b>uses</b></font> + Classes, + PaxCompiler; + +<font color="blue"><b>procedure</b></font> Register_Classes; + +<font color="blue"><b>implementation</b></font> + +// TList ----------------------------------------------------------------------- + +<font color="blue"><b>function</b></font> TList_GetCapacity(Self: TList): Integer; +<font color="blue"><b>begin</b></font> + result := Self.Capacity; +<font color="blue"><b>end</b></font>; + +<font color="blue"><b>procedure</b></font> TList_SetCapacity(Self: TList; Value: Integer); +<font color="blue"><b>begin</b></font> + Self.Capacity := Value; +<font color="blue"><b>end</b></font>; + +<font color="blue"><b>function</b></font> TList_GetCount(Self: TList): Integer; +<font color="blue"><b>begin</b></font> + result := Self.Count; +<font color="blue"><b>end</b></font>; + +<font color="blue"><b>function</b></font> TList_GetItem(Self: TList; I: Integer): Pointer; +<font color="blue"><b>begin</b></font> + result := Self.Items[I]; +<font color="blue"><b>end</b></font>; + +<font color="blue"><b>procedure</b></font> TList_SetItem(Self: TList; I: Integer; Value: Pointer); +<font color="blue"><b>begin</b></font> + Self.Items[I] := Value; +<font color="blue"><b>end</b></font>; + +<font color="blue"><b>function</b></font> TList_GetList(Self: TList): PPointerList; +<font color="blue"><b>begin</b></font> + result := Self.List; +<font color="blue"><b>end</b></font>; + +// TBits ----------------------------------------------------------------------- + +<font color="blue"><b>function</b></font> TBits_GetBit(Self: TBits; I: Integer): Boolean; +<font color="blue"><b>begin</b></font> + result := Self.Bits[I]; +<font color="blue"><b>end</b></font>; + +<font color="blue"><b>procedure</b></font> TBits_SetBit(Self: TBits; I: Integer; Value: Boolean); +<font color="blue"><b>begin</b></font> + Self.Bits[I] := Value; +<font color="blue"><b>end</b></font>; + +<font color="blue"><b>function</b></font> TBits_GetSize(Self: TBits): Integer; +<font color="blue"><b>begin</b></font> + result := Self.Size; +<font color="blue"><b>end</b></font>; + +// TCollectionItem ------------------------------------------------------------- + +<font color="blue"><b>function</b></font> TCollectionItem_GetCollection(Self: TCollectionItem): TCollection; +<font color="blue"><b>begin</b></font> + result := Self.Collection; +<font color="blue"><b>end</b></font>; + +<font color="blue"><b>procedure</b></font> TCollectionItem_SetCollection(Self: TCollectionItem; Value: TCollection); +<font color="blue"><b>begin</b></font> + Self.Collection := Value; +<font color="blue"><b>end</b></font>; + +<font color="blue"><b>function</b></font> TCollectionItem_GetID(Self: TCollectionItem): Integer; +<font color="blue"><b>begin</b></font> + result := Self.ID; +<font color="blue"><b>end</b></font>; + +<font color="blue"><b>function</b></font> TCollectionItem_GetIndex(Self: TCollectionItem): Integer; +<font color="blue"><b>begin</b></font> + result := Self.Index; +<font color="blue"><b>end</b></font>; + +<font color="blue"><b>procedure</b></font> TCollectionItem_SetIndex(Self: TCollectionItem; Value: Integer); +<font color="blue"><b>begin</b></font> + Self.Index := Value; +<font color="blue"><b>end</b></font>; + +<font color="blue"><b>function</b></font> TCollectionItem_GetDisplayName(Self: TCollectionItem): <font color="blue"><b>String</b></font>; +<font color="blue"><b>begin</b></font> + result := Self.DisplayName; +<font color="blue"><b>end</b></font>; + +<font color="blue"><b>procedure</b></font> TCollectionItem_SetDisplayName(Self: TCollectionItem; <font color="blue"><b>const</b></font> Value: <font color="blue"><b>String</b></font>); +<font color="blue"><b>begin</b></font> + Self.DisplayName := Value; +<font color="blue"><b>end</b></font>; + +// TCollection ----------------------------------------------------------------- + +<font color="blue"><b>function</b></font> TCollection_GetCount(Self: TCollection): Integer; +<font color="blue"><b>begin</b></font> + result := Self.Count; +<font color="blue"><b>end</b></font>; + +<font color="blue"><b>function</b></font> TCollection_GetItemClass(Self: TCollection): TCollectionItemClass; +<font color="blue"><b>begin</b></font> + result := Self.ItemClass; +<font color="blue"><b>end</b></font>; + +<font color="blue"><b>function</b></font> TCollection_GetItem(Self: TCollection; I: Integer): TCollectionItem; +<font color="blue"><b>begin</b></font> + result := Self.Items[I]; +<font color="blue"><b>end</b></font>; + +<font color="blue"><b>procedure</b></font> TCollection_SetItem(Self: TCollection; I: Integer; Value: TCollectionItem); +<font color="blue"><b>begin</b></font> + Self.Items[I] := Value; +<font color="blue"><b>end</b></font>; + +// TStrings -------------------------------------------------------------------- + +<font color="blue"><b>function</b></font> TStrings_GetCapacity(Self: TStrings): Integer; +<font color="blue"><b>begin</b></font> + result := Self.Capacity; +<font color="blue"><b>end</b></font>; + +<font color="blue"><b>procedure</b></font> TStrings_SetCapacity(Self: TStrings; Value: Integer); +<font color="blue"><b>begin</b></font> + Self.Capacity := Value; +<font color="blue"><b>end</b></font>; + +<font color="blue"><b>function</b></font> TStrings_GetCommaText(Self: TStrings): <font color="blue"><b>String</b></font>; +<font color="blue"><b>begin</b></font> + result := Self.CommaText; +<font color="blue"><b>end</b></font>; + +<font color="blue"><b>procedure</b></font> TStrings_SetCommaText(Self: TStrings; <font color="blue"><b>const</b></font> Value: <font color="blue"><b>String</b></font>); +<font color="blue"><b>begin</b></font> + Self.CommaText := Value; +<font color="blue"><b>end</b></font>; + +<font color="blue"><b>function</b></font> TStrings_GetCount(Self: TStrings): Integer; +<font color="blue"><b>begin</b></font> + result := Self.Count; +<font color="blue"><b>end</b></font>; + +<font color="blue"><b>function</b></font> TStrings_GetName(Self: TStrings; I: Integer): <font color="blue"><b>String</b></font>; +<font color="blue"><b>begin</b></font> + result := Self.Names[I]; +<font color="blue"><b>end</b></font>; + +<font color="blue"><b>function</b></font> TStrings_GetObject(Self: TStrings; I: Integer): TObject; +<font color="blue"><b>begin</b></font> + result := Self.Objects[I]; +<font color="blue"><b>end</b></font>; + +<font color="blue"><b>procedure</b></font> TStrings_SetObject(Self: TStrings; I: Integer; Value: TObject); +<font color="blue"><b>begin</b></font> + Self.Objects[I] := Value; +<font color="blue"><b>end</b></font>; + +<font color="blue"><b>function</b></font> TStrings_GetValue(Self: TStrings; <font color="blue"><b>const</b></font> I: <font color="blue"><b>String</b></font>): <font color="blue"><b>String</b></font>; +<font color="blue"><b>begin</b></font> + result := Self.Values[I]; +<font color="blue"><b>end</b></font>; + +<font color="blue"><b>procedure</b></font> TStrings_SetValue(Self: TStrings; <font color="blue"><b>const</b></font> I: <font color="blue"><b>String</b></font>; <font color="blue"><b>const</b></font> Value: <font color="blue"><b>String</b></font>); +<font color="blue"><b>begin</b></font> + Self.Values[I] := Value; +<font color="blue"><b>end</b></font>; + +<font color="blue"><b>function</b></font> TStrings_GetString(Self: TStrings; I: Integer): <font color="blue"><b>String</b></font>; +<font color="blue"><b>begin</b></font> + result := Self.Strings[I]; +<font color="blue"><b>end</b></font>; + +<font color="blue"><b>procedure</b></font> TStrings_SetString(Self: TStrings; I: Integer; <font color="blue"><b>const</b></font> Value: <font color="blue"><b>String</b></font>); +<font color="blue"><b>begin</b></font> + Self.Strings[I] := Value; +<font color="blue"><b>end</b></font>; + +<font color="blue"><b>function</b></font> TStrings_GetText(Self: TStrings): <font color="blue"><b>String</b></font>; +<font color="blue"><b>begin</b></font> + result := Self.Text; +<font color="blue"><b>end</b></font>; + +<font color="blue"><b>procedure</b></font> TStrings_SetText(Self: TStrings; <font color="blue"><b>const</b></font> Value: <font color="blue"><b>String</b></font>); +<font color="blue"><b>begin</b></font> + Self.Text := Value; +<font color="blue"><b>end</b></font>; + +// TStringList ----------------------------------------------------------------- + +<font color="blue"><b>function</b></font> TStringList_GetDuplicates(Self: TStringList): TDuplicates; +<font color="blue"><b>begin</b></font> + result := Self.Duplicates; +<font color="blue"><b>end</b></font>; + +<font color="blue"><b>procedure</b></font> TStringList_SetDuplicates(Self: TStringList; Value: TDuplicates); +<font color="blue"><b>begin</b></font> + Self.Duplicates := Value; +<font color="blue"><b>end</b></font>; + +<font color="blue"><b>function</b></font> TStringList_GetSorted(Self: TStringList): Boolean; +<font color="blue"><b>begin</b></font> + result := Self.Sorted; +<font color="blue"><b>end</b></font>; + +<font color="blue"><b>procedure</b></font> TStringList_SetSorted(Self: TStringList; Value: Boolean); +<font color="blue"><b>begin</b></font> + Self.Sorted := Value; +<font color="blue"><b>end</b></font>; + +// TStream --------------------------------------------------------------------- + +<font color="blue"><b>function</b></font> TStream_GetPosition(Self: TStream): Integer; +<font color="blue"><b>begin</b></font> + result := Self.Position; +<font color="blue"><b>end</b></font>; + +<font color="blue"><b>procedure</b></font> TStream_SetPosition(Self: TStream; Value: Integer); +<font color="blue"><b>begin</b></font> + Self.Position := Value; +<font color="blue"><b>end</b></font>; + +<font color="blue"><b>function</b></font> TStream_GetSize(Self: TStream): Longint; +<font color="blue"><b>begin</b></font> + result := Self.Size; +<font color="blue"><b>end</b></font>; + +<font color="blue"><b>procedure</b></font> TStream_SetSize(Self: TStream; Value: Longint); +<font color="blue"><b>begin</b></font> + Self.Size := Value; +<font color="blue"><b>end</b></font>; + +// TStream --------------------------------------------------------------------- + +<font color="blue"><b>function</b></font> THandleStream_GetHandle(Self: THandleStream): Integer; +<font color="blue"><b>begin</b></font> + result := Self.Handle; +<font color="blue"><b>end</b></font>; + +// TCustomMemoryStream --------------------------------------------------------- + +<font color="blue"><b>function</b></font> TCustomMemoryStream_GetMemory(Self: TCustomMemoryStream): Pointer; +<font color="blue"><b>begin</b></font> + result := Self.Memory; +<font color="blue"><b>end</b></font>; + +// TStringStream --------------------------------------------------------------- + +<font color="blue"><b>function</b></font> TStringStream_GetDataString(Self: TStringStream): <font color="blue"><b>String</b></font>; +<font color="blue"><b>begin</b></font> + result := Self.DataString; +<font color="blue"><b>end</b></font>; + +// TParser --------------------------------------------------------------------- + +<font color="blue"><b>function</b></font> TParser_GetFloatType(Self: TParser): Char; +<font color="blue"><b>begin</b></font> + result := Self.FloatType; +<font color="blue"><b>end</b></font>; + +<font color="blue"><b>function</b></font> TParser_GetSourceLine(Self: TParser): Integer; +<font color="blue"><b>begin</b></font> + result := Self.SourceLine; +<font color="blue"><b>end</b></font>; + +<font color="blue"><b>function</b></font> TParser_GetToken(Self: TParser): Char; +<font color="blue"><b>begin</b></font> + result := Self.Token; +<font color="blue"><b>end</b></font>; + +// TComponent ------------------------------------------------------------------ + +<font color="blue"><b>function</b></font> TComponent_GetComponent(Self: TComponent; I: Integer): TComponent; +<font color="blue"><b>begin</b></font> + result := Self.Components[I]; +<font color="blue"><b>end</b></font>; + +<font color="blue"><b>function</b></font> TComponent_GetComponentCount(Self: TComponent): Integer; +<font color="blue"><b>begin</b></font> + result := Self.ComponentCount; +<font color="blue"><b>end</b></font>; + +<font color="blue"><b>function</b></font> TComponent_GetComponentIndex(Self: TComponent): Integer; +<font color="blue"><b>begin</b></font> + result := Self.ComponentIndex; +<font color="blue"><b>end</b></font>; + +<font color="blue"><b>procedure</b></font> TComponent_SetComponentIndex(Self: TComponent; Value: Integer); +<font color="blue"><b>begin</b></font> + Self.ComponentIndex := Value; +<font color="blue"><b>end</b></font>; + +<font color="blue"><b>function</b></font> TComponent_GetComponentState(Self: TComponent): TComponentState; +<font color="blue"><b>begin</b></font> + result := Self.ComponentState; +<font color="blue"><b>end</b></font>; + +<font color="blue"><b>function</b></font> TComponent_GetComponentStyle(Self: TComponent): TComponentStyle; +<font color="blue"><b>begin</b></font> + result := Self.ComponentStyle; +<font color="blue"><b>end</b></font>; + +<font color="blue"><b>function</b></font> TComponent_GetDesignInfo(Self: TComponent): Integer; +<font color="blue"><b>begin</b></font> + result := Self.DesignInfo; +<font color="blue"><b>end</b></font>; + +<font color="blue"><b>procedure</b></font> TComponent_SetDesignInfo(Self: TComponent; Value: Integer); +<font color="blue"><b>begin</b></font> + Self.DesignInfo := Value; +<font color="blue"><b>end</b></font>; + +<font color="blue"><b>function</b></font> TComponent_GetOwner(Self: TComponent): TComponent; +<font color="blue"><b>begin</b></font> + result := Self.Owner; +<font color="blue"><b>end</b></font>; + +//------------------------------------------------------------------------------ + +<font color="blue"><b>procedure</b></font> Register_Classes; +<font color="blue"><b>var</b></font> + H, G: Integer; +<font color="blue"><b>begin</b></font> + RegisterTypeAlias(0, <font color="Red">'Longint'</font>, _typeINTEGER); + + H := RegisterNamespace(0, <font color="Red">'Classes'</font>); + +{ Maximum TList size } + + RegisterConstant(H, <font color="Red">'MaxListSize'</font>, MaxListSize); + +{ TStream seek origins } + + RegisterConstant(H, <font color="Red">'soFromBeginning'</font>, soFromBeginning); + RegisterConstant(H, <font color="Red">'soFromCurrent'</font>, soFromCurrent); + RegisterConstant(H, <font color="Red">'soFromEnd'</font>, soFromEnd); + +{ TFileStream create mode } + + RegisterConstant(H, <font color="Red">'fmCreate'</font>, fmCreate); + +{ TParser special tokens } + + RegisterConstant(H, <font color="Red">'toEOF'</font>, toEOF); + RegisterConstant(H, <font color="Red">'toSymbol'</font>, toSymbol); + RegisterConstant(H, <font color="Red">'toString'</font>, toString); + RegisterConstant(H, <font color="Red">'toInteger'</font>, toInteger); + RegisterConstant(H, <font color="Red">'toFloat'</font>, toFloat); + RegisterConstant(H, <font color="Red">'toWString'</font>, toWString); + +{ Text alignment types } + + RegisterRTTIType(H, TypeInfo(TAlignment)); + RegisterRTTIType(H, TypeInfo(TLeftRight)); + RegisterRTTIType(H, TypeInfo(TBiDiMode)); + +{ Types used by standard events } + + RegisterRTTIType(H, TypeInfo(TShiftState)); + RegisterRTTIType(H, TypeInfo(THelpContext)); + +{ Duplicate management } + + RegisterRTTIType(H, TypeInfo(TDuplicates)); + + RegisterClassType(H, TComponent); + RegisterClassType(H, TStream); + RegisterClassType(H, TFiler); + RegisterClassType(H, TReader); + RegisterClassType(H, TWriter); + +// TList ----------------------------------------------------------------------- + + G := RegisterArrayType(H, <font color="Red">'TPointerList'</font>, + RegisterSubrangeType(H, <font color="Red">''</font>, _typeINTEGER, 0, MaxListSize - 1), + _typePOINTER); + RegisterPointerType(H, <font color="Red">'PPointerList'</font>, G); + + G := RegisterHeader(H, <font color="Red">'function __TListSortCompare(Item1, Item2: Pointer): Integer;'</font>, <font color="blue"><b>nil</b></font>); + RegisterProceduralType(H, <font color="Red">'TListSortCompare'</font>, G); + RegisterRTTIType(H, TypeInfo(TListNotification)); + + G := RegisterClassType(H, TList); + + RegisterHeader(G, <font color="Red">'constructor Create;'</font>, @TList.Create); + RegisterHeader(G, <font color="Red">'function Add(Item: Pointer): Integer;'</font>, @TList.Add); + RegisterHeader(G, <font color="Red">'procedure Clear; virtual;'</font>, @TList.Clear); + RegisterHeader(G, <font color="Red">'procedure Delete(Index: Integer);'</font>, @TList.<font color="blue"><b>Delete</b></font>); + RegisterHeader(G, <font color="Red">'procedure Exchange(Index1, Index2: Integer);'</font>, @TList.Exchange); + RegisterHeader(G, <font color="Red">'function Expand: TList;'</font>, @TList.Expand); + RegisterHeader(G, <font color="Red">'function Extract(Item: Pointer): Pointer;'</font>, @TList.Extract); + RegisterHeader(G, <font color="Red">'function First: Pointer;'</font>, @TList.First); + RegisterHeader(G, <font color="Red">'function IndexOf(Item: Pointer): Integer;'</font>, @TList.IndexOf); + RegisterHeader(G, <font color="Red">'procedure Insert(Index: Integer; Item: Pointer);'</font>, @TList.Insert); + RegisterHeader(G, <font color="Red">'function Last: Pointer;'</font>, @TList.Last); + RegisterHeader(G, <font color="Red">'procedure Move(CurIndex, NewIndex: Integer);'</font>, @TList.Move); + RegisterHeader(G, <font color="Red">'function Remove(Item: Pointer): Integer;'</font>, @TList.Remove); + RegisterHeader(G, <font color="Red">'procedure Pack;'</font>, @TList.Pack); + RegisterHeader(G, <font color="Red">'procedure Sort(Compare: TListSortCompare);'</font>, @TList.Sort); + + RegisterHeader(G, <font color="Red">'function _GetCapacity: Integer;'</font>, @TList_GetCapacity); + RegisterHeader(G, <font color="Red">'procedure _SetCapacity(Value: Integer);'</font>, @TList_SetCapacity); + RegisterProperty(G, <font color="Red">'property Capacity: Integer read _GetCapacity write _SetCapacity;'</font>); + + RegisterHeader(G, <font color="Red">'function _GetCount: Integer;'</font>, @TList_GetCount); + RegisterProperty(G, <font color="Red">'property Count: Integer read _GetCount;'</font>); + + RegisterHeader(G, <font color="Red">'function _GetItem(I: Integer): Pointer;'</font>, @TList_GetItem); + RegisterHeader(G, <font color="Red">'procedure _SetItem(I: Integer; Value: Pointer);'</font>, @TList_SetItem); + RegisterProperty(G, <font color="Red">'property Items[Index: Integer]: Pointer read _GetItem write _SetItem; default;'</font>); + + RegisterHeader(G, <font color="Red">'function _GetList: PPointerList;'</font>, @TList_GetList); + RegisterProperty(G, <font color="Red">'property List: PPointerList read _GetList;'</font>); + +// TBits ----------------------------------------------------------------------- + + G := RegisterClassType(H, TBits); + RegisterHeader(G, <font color="Red">'constructor Create;'</font>, @TBits.Create); + RegisterHeader(G, <font color="Red">'function OpenBit: Integer;'</font>, @TBits.OpenBit); + + RegisterHeader(G, <font color="Red">'function _GetBit(I: Integer): Boolean;'</font>, @TBits_GetBit); + RegisterHeader(G, <font color="Red">'procedure _SetBit(I: Integer; Value: Boolean);'</font>, @TBits_SetBit); + RegisterProperty(G, <font color="Red">'property Bits[Index: Integer]: Boolean read _GetBit write _SetBit; default;'</font>); + + RegisterHeader(G, <font color="Red">'function _GetSize: Integer;'</font>, @TBits_GetSize); + RegisterProperty(G, <font color="Red">'property Size: Integer read _GetSize;'</font>); + +// TPersistent ----------------------------------------------------------------- + + G := RegisterClassType(H, TPersistent); + RegisterClassReferenceType(H, <font color="Red">'TPersistentClass'</font>, G); + + RegisterHeader(G, <font color="Red">'constructor Create;'</font>, @TPersistent.Create); + RegisterHeader(G, <font color="Red">'procedure Assign(Source: TPersistent); virtual;'</font>, @TPersistent.Assign); + RegisterHeader(G, <font color="Red">'function GetNamePath: string; dynamic;'</font>, @TPersistent.GetNamePath); + +// TCollectionItem ------------------------------------------------------------- + + RegisterClassType(H, TCollection); + G := RegisterClassType(H, TCollectionItem); + RegisterClassReferenceType(H, <font color="Red">'TCollectionItemClass'</font>, G); + + RegisterHeader(G, <font color="Red">'constructor Create(Collection: TCollection); virtual;'</font>, @TCollectionItem.Create); + RegisterHeader(G, <font color="Red">'function GetNamePath: string; override;'</font>, @TCollectionItem.GetNamePath); + + RegisterHeader(G, <font color="Red">'function _GetCollection: TCollection;'</font>, @TCollectionItem_GetCollection); + RegisterHeader(G, <font color="Red">'procedure _SetCollection(Value: TCollection);'</font>, @TCollectionItem_SetCollection); + RegisterProperty(G, <font color="Red">'property Collection: TCollection read _GetCollection write _SetCollection;'</font>); + + RegisterHeader(G, <font color="Red">'function _GetID: Integer;'</font>, @TCollectionItem_GetID); + RegisterProperty(G, <font color="Red">'property ID: Integer read _GetID;'</font>); + + RegisterHeader(G, <font color="Red">'function _GetIndex: Integer;'</font>, @TCollectionItem_GetIndex); + RegisterHeader(G, <font color="Red">'procedure _SetIndex(Value: Integer);'</font>, @TCollectionItem_SetIndex); + RegisterProperty(G, <font color="Red">'property Index: Integer read _GetIndex write _SetIndex;'</font>); + + RegisterHeader(G, <font color="Red">'function _GetDisplayName: String;'</font>, @TCollectionItem_GetDisplayName); + RegisterHeader(G, <font color="Red">'procedure _SetDisplayName(const Value: String);'</font>, @TCollectionItem_SetDisplayName); + RegisterProperty(G, <font color="Red">'property DisplayName: string read _GetDisplayName write _SetDisplayName;'</font>); + +// TCollection ----------------------------------------------------------------- + + G := RegisterClassType(H, TCollection); + + RegisterHeader(G, <font color="Red">'constructor Create(ItemClass: TCollectionItemClass);'</font>, @TCollection.Create); + RegisterHeader(G, <font color="Red">'function Add: TCollectionItem;'</font>, @TCollection.Add); + RegisterHeader(G, <font color="Red">'procedure Assign(Source: TPersistent); override;'</font>, @TCollection.Assign); + RegisterHeader(G, <font color="Red">'procedure BeginUpdate; virtual;'</font>, @TCollection.BeginUpdate); + RegisterHeader(G, <font color="Red">'procedure Clear;'</font>, @TCollection.Clear); + RegisterHeader(G, <font color="Red">'procedure Delete(Index: Integer);'</font>, @TCollection.<font color="blue"><b>Delete</b></font>); + RegisterHeader(G, <font color="Red">'procedure EndUpdate; virtual;'</font>, @TCollection.EndUpdate); + RegisterHeader(G, <font color="Red">'function FindItemID(ID: Integer): TCollectionItem;'</font>, @TCollection.FindItemId); + RegisterHeader(G, <font color="Red">'function GetNamePath: string; override;'</font>, @TCollection.GetNamePath); + RegisterHeader(G, <font color="Red">'function Insert(Index: Integer): TCollectionItem;'</font>, @TCollection.Insert); + + RegisterHeader(G, <font color="Red">'function _GetCount: Integer;'</font>, @TCollection_GetCount); + RegisterProperty(G, <font color="Red">'property Count: Integer read _GetCount;'</font>); + + RegisterHeader(G, <font color="Red">'function _GetItemClass: TCollectionItemClass;'</font>, + @TCollection_GetItemClass); + RegisterProperty(G, <font color="Red">'property ItemClass: TCollectionItemClass read _GetItemClass;'</font>); + + RegisterHeader(G, <font color="Red">'function _GetItem(I: Integer): TCollectionItem;'</font>, @TCollection_GetItem); + RegisterHeader(G, <font color="Red">'procedure _SetItem(I: Integer; Value: TCollectionItem);'</font>, @TCollection_SetItem); + RegisterProperty(G, <font color="Red">'property Items[Index: Integer]: TCollectionItem read _GetItem write _SetItem;'</font>); + +// TStrings -------------------------------------------------------------------- + + G := RegisterClassType(H, TStrings); + + RegisterHeader(G, <font color="Red">'constructor Create;'</font>, @TStrings.Create); + RegisterHeader(G, <font color="Red">'function Add(const S: string): Integer; virtual;'</font>, @TStrings.Add); + RegisterHeader(G, <font color="Red">'function AddObject(const S: string; AObject: TObject): Integer; virtual;'</font>, @TStrings.AddObject); + RegisterHeader(G, <font color="Red">'procedure Append(const S: string);'</font>, @TStrings.Append); + RegisterHeader(G, <font color="Red">'procedure AddStrings(Strings: TStrings); virtual;'</font>, @TStrings.AddStrings); + RegisterHeader(G, <font color="Red">'procedure Assign(Source: TPersistent); override;'</font>, @TStrings.Assign); + RegisterHeader(G, <font color="Red">'procedure BeginUpdate;'</font>, @TStrings.BeginUpdate); + RegisterHeader(G, <font color="Red">'procedure Clear; virtual; abstract;'</font>, <font color="blue"><b>nil</b></font>); + RegisterHeader(G, <font color="Red">'procedure Delete(Index: Integer); virtual; abstract;'</font>, <font color="blue"><b>nil</b></font>); + RegisterHeader(G, <font color="Red">'procedure EndUpdate;'</font>, @TStrings.EndUpdate); + RegisterHeader(G, <font color="Red">'function Equals(Strings: TStrings): Boolean;'</font>, @TStrings.Equals); + RegisterHeader(G, <font color="Red">'procedure Exchange(Index1, Index2: Integer); virtual;'</font>, @TStrings.Exchange); + RegisterHeader(G, <font color="Red">'function GetText: PChar; virtual;'</font>, @TStrings.GetText); + RegisterHeader(G, <font color="Red">'function IndexOf(const S: string): Integer; virtual;'</font>, @TStrings.IndexOf); + RegisterHeader(G, <font color="Red">'function IndexOfName(const Name: string): Integer;'</font>, @TStrings.IndexOfName); + RegisterHeader(G, <font color="Red">'function IndexOfObject(AObject: TObject): Integer;'</font>, @TStrings.IndexOfObject); + RegisterHeader(G, <font color="Red">'procedure Insert(Index: Integer; const S: string); virtual; abstract;'</font>, <font color="blue"><b>nil</b></font>); + RegisterHeader(G, <font color="Red">'procedure InsertObject(Index: Integer; const S: string; AObject: TObject);'</font>, @TStrings.InsertObject); + RegisterHeader(G, <font color="Red">'procedure LoadFromFile(const FileName: string); virtual;'</font>, @TStrings.LoadFromFile); + RegisterHeader(G, <font color="Red">'procedure LoadFromStream(Stream: TStream); virtual;'</font>, @TStrings.LoadFromStream); + RegisterHeader(G, <font color="Red">'procedure Move(CurIndex, NewIndex: Integer); virtual;'</font>, @TStrings.Move); + RegisterHeader(G, <font color="Red">'procedure SaveToFile(const FileName: string); virtual;'</font>, @TStrings.SaveToFile); + RegisterHeader(G, <font color="Red">'procedure SaveToStream(Stream: TStream); virtual;'</font>, @TStrings.SaveToStream); + RegisterHeader(G, <font color="Red">'procedure SetText(Text: PChar); virtual;'</font>, @TStrings.SetText); + + RegisterHeader(G, <font color="Red">'function _GetCapacity: Integer;'</font>, @TStrings_GetCapacity); + RegisterHeader(G, <font color="Red">'procedure _SetCapacity(Value: Integer);'</font>, @TStrings_SetCapacity); + RegisterProperty(G, <font color="Red">'property Capacity: Integer read _GetCapacity write _SetCapacity;'</font>); + + RegisterHeader(G, <font color="Red">'function _GetCommaText: String;'</font>, @TStrings_GetCommaText); + RegisterHeader(G, <font color="Red">'procedure _SetCommaText(const Value: String);'</font>, @TStrings_SetCommaText); + RegisterProperty(G, <font color="Red">'property CommaText: string read _GetCommaText write _SetCommaText;'</font>); + + RegisterHeader(G, <font color="Red">'function _GetCount: Integer;'</font>, @TStrings_GetCount); + RegisterProperty(G, <font color="Red">'property Count: Integer read _GetCount;'</font>); + + RegisterHeader(G, <font color="Red">'function _GetName(I: Integer): String;'</font>, @TStrings_GetName); + RegisterProperty(G, <font color="Red">'property Names[Index: Integer]: string read _GetName;'</font>); + + RegisterHeader(G, <font color="Red">'function _GetObject(I: Integer): TObject;'</font>, @TStrings_GetObject); + RegisterHeader(G, <font color="Red">'procedure _SetObject(I: Integer; Value: TObject);'</font>, @TStrings_SetObject); + RegisterProperty(G, <font color="Red">'property Objects[Index: Integer]: TObject read _GetObject write _SetObject;'</font>); + + RegisterHeader(G, <font color="Red">'function _GetValue(const I: String): String;'</font>, @TStrings_GetValue); + RegisterHeader(G, <font color="Red">'procedure _SetValue(const I: String; const Value: String);'</font>, @TStrings_GetValue); + RegisterProperty(G, <font color="Red">'property Values[const Name: string]: string read _GetValue write _SetValue;'</font>); + + RegisterHeader(G, <font color="Red">'function _GetString(I: Integer): String;'</font>, @TStrings_GetString); + RegisterHeader(G, <font color="Red">'procedure _SetString(I: Integer; const Value: String);'</font>, @TStrings_SetString); + RegisterProperty(G, <font color="Red">'property Strings[Index: Integer]: string read _GetString write _SetString; default;'</font>); + + RegisterHeader(G, <font color="Red">'function _GetText: String;'</font>, @TStrings_GetText); + RegisterHeader(G, <font color="Red">'procedure _SetText(const Value: String);'</font>, @TStrings_SetText); + RegisterProperty(G, <font color="Red">'property Text: string read _GetText write _SetText;'</font>); + +// TStringList ----------------------------------------------------------------- + + G := RegisterClassType(H, TStringList); + RegisterProceduralType(H, <font color="Red">'TStringListSortCompare'</font>, RegisterHeader(H, <font color="Red">'function __TStringListSortCompare(List: TStringList; Index1, Index2: Integer): Integer;'</font>, <font color="blue"><b>nil</b></font>)); + + RegisterHeader(G, <font color="Red">'constructor Create;'</font>, @TStringList.Create); + RegisterHeader(G, <font color="Red">'function Add(const S: string): Integer; override;'</font>, @TStringList.Add); + RegisterHeader(G, <font color="Red">'procedure Clear; override;'</font>, @TStringList.Clear); + RegisterHeader(G, <font color="Red">'procedure Delete(Index: Integer); override;'</font>, @TStringList.<font color="blue"><b>Delete</b></font>); + RegisterHeader(G, <font color="Red">'procedure Exchange(Index1, Index2: Integer); override;'</font>, @TStringList.Exchange); + RegisterHeader(G, <font color="Red">'function Find(const S: string; var Index: Integer): Boolean; virtual;'</font>, @TStringList.Find); + RegisterHeader(G, <font color="Red">'function IndexOf(const S: string): Integer; override;'</font>, @TStringList.IndexOf); + RegisterHeader(G, <font color="Red">'procedure Insert(Index: Integer; const S: string); override;'</font>, @TStringList.Insert); + RegisterHeader(G, <font color="Red">'procedure Sort; virtual;'</font>, @TStringList.Sort); + RegisterHeader(G, <font color="Red">'procedure CustomSort(Compare: TStringListSortCompare); virtual;'</font>, @TStringList.CustomSort); + + RegisterHeader(G, <font color="Red">'function _GetDuplicates: TDuplicates;'</font>, @TStringList_GetDuplicates); + RegisterHeader(G, <font color="Red">'procedure _SetDuplicates(Value: TDuplicates);'</font>, @TStringList_SetDuplicates); + RegisterProperty(G, <font color="Red">'property Duplicates: TDuplicates read _GetDuplicates write _SetDuplicates;'</font>); + + RegisterHeader(G, <font color="Red">'function _GetSorted: Boolean;'</font>, @TStringList_GetSorted); + RegisterHeader(G, <font color="Red">'procedure _SetSorted(Value: Boolean);'</font>, @TStringList_SetSorted); + RegisterProperty(G, <font color="Red">'property Sorted: Boolean read _GetSorted write _SetSorted;'</font>); + +// TStream --------------------------------------------------------------------- + + G := RegisterClassType(H, TStream); + + RegisterHeader(G, <font color="Red">'constructor Create;'</font>, @TStream.Create); + RegisterHeader(G, <font color="Red">'function Read(var Buffer; Count: Longint): Longint; virtual; abstract;'</font>, <font color="blue"><b>nil</b></font>); + RegisterHeader(G, <font color="Red">'function Write(const Buffer; Count: Longint): Longint; virtual; abstract;'</font>, <font color="blue"><b>nil</b></font>); + RegisterHeader(G, <font color="Red">'function Seek(Offset: Longint; Origin: Word): Longint; virtual; abstract;'</font>, <font color="blue"><b>nil</b></font>); + RegisterHeader(G, <font color="Red">'procedure ReadBuffer(var Buffer; Count: Longint);'</font>, @TStream.ReadBuffer); + RegisterHeader(G, <font color="Red">'procedure WriteBuffer(const Buffer; Count: Longint);'</font>, @TStream.WriteBuffer); + RegisterHeader(G, <font color="Red">'function CopyFrom(Source: TStream; Count: Longint): Longint;'</font>, @TStream.CopyFrom); + RegisterHeader(G, <font color="Red">'function ReadComponent(Instance: TComponent): TComponent;'</font>, @TStream.ReadComponent); + RegisterHeader(G, <font color="Red">'function ReadComponentRes(Instance: TComponent): TComponent;'</font>, @TStream.ReadComponentRes); + RegisterHeader(G, <font color="Red">'procedure WriteComponent(Instance: TComponent);'</font>, @TStream.WriteComponent); + RegisterHeader(G, <font color="Red">'procedure WriteResourceHeader(const ResName: string; out FixupInfo: Integer);'</font>, @TStream.WriteResourceHeader); + RegisterHeader(G, <font color="Red">'procedure FixupResourceHeader(FixupInfo: Integer);'</font>, @TStream.FixupResourceHeader); + RegisterHeader(G, <font color="Red">'procedure ReadResHeader;'</font>, @TStream.ReadResHeader); + + RegisterHeader(G, <font color="Red">'function _GetPosition: Integer;'</font>, @TStream_GetPosition); + RegisterHeader(G, <font color="Red">'procedure _SetPosition(Value: Integer);'</font>, @TStream_SetPosition); + RegisterProperty(G, <font color="Red">'property Position: Longint read _GetPosition write _SetPosition;'</font>); + + RegisterHeader(G, <font color="Red">'function _GetSize: Longint;'</font>, @TStream_GetSize); + RegisterHeader(G, <font color="Red">'procedure _SetSize(Value: Longint);'</font>, @TStream_SetSize); + RegisterProperty(G, <font color="Red">'property Size: Longint read _GetSize write _SetSize;'</font>); + +// THandleStream --------------------------------------------------------------- + + G := RegisterClassType(H, THandleStream); + + RegisterHeader(G, <font color="Red">'constructor Create(AHandle: Integer);'</font>, @THandleStream.Create); + RegisterHeader(G, <font color="Red">'function Read(var Buffer; Count: Longint): Longint; override;'</font>, @THandleStream.Read); + RegisterHeader(G, <font color="Red">'function Write(const Buffer; Count: Longint): Longint; override;'</font>, @THandleStream.Write); + RegisterHeader(G, <font color="Red">'function Seek(Offset: Longint; Origin: Word): Longint; override;'</font>, @THandleStream.Seek); + + RegisterHeader(G, <font color="Red">'function _GetHandle: Integer;'</font>, @THandleStream_GetHandle); + RegisterProperty(G, <font color="Red">'property Handle: Integer read _GetHandle;'</font>); + +// TFileStream ----------------------------------------------------------------- + + G := RegisterClassType(H, TFileStream); + + RegisterHeader(G, <font color="Red">'constructor Create(const FileName: string; Mode: Word);'</font>, @TFileStream.Create); + +// TCustomMemoryStream --------------------------------------------------------- + + G := RegisterClassType(H, TCustomMemoryStream); + + RegisterHeader(G, <font color="Red">'constructor Create;'</font>, @TCustomMemoryStream.Create); + RegisterHeader(G, <font color="Red">'function Read(var Buffer; Count: Longint): Longint; override;'</font>, @TCustomMemoryStream.Read); + RegisterHeader(G, <font color="Red">'function Seek(Offset: Longint; Origin: Word): Longint; override;'</font>, @TCustomMemoryStream.Seek); + RegisterHeader(G, <font color="Red">'procedure SaveToStream(Stream: TStream);'</font>, @TCustomMemoryStream.SaveToStream); + RegisterHeader(G, <font color="Red">'procedure SaveToFile(const FileName: string);'</font>, @TCustomMemoryStream.SaveToFile); + + RegisterHeader(G, <font color="Red">'function _GetMemory: Pointer;'</font>, @TCustomMemoryStream_GetMemory); + RegisterProperty(G, <font color="Red">'property Memory: Pointer read _GetMemory;'</font>); + +// TMemoryStream --------------------------------------------------------------- + + G := RegisterClassType(H, TMemoryStream); + + RegisterHeader(G, <font color="Red">'constructor Create;'</font>, @TMemoryStream.Create); + RegisterHeader(G, <font color="Red">'procedure Clear;'</font>, @TMemoryStream.Clear); + RegisterHeader(G, <font color="Red">'procedure LoadFromStream(Stream: TStream);'</font>, @TMemoryStream.LoadFromStream); + RegisterHeader(G, <font color="Red">'procedure LoadFromFile(const FileName: string);'</font>, @TMemoryStream.LoadFromFile); + RegisterHeader(G, <font color="Red">'procedure SetSize(NewSize: Longint); override;'</font>, @TMemoryStream.SetSize); + RegisterHeader(G, <font color="Red">'function Write(const Buffer; Count: Longint): Longint; override;'</font>, @TMemoryStream.Write); + +// TStringStream --------------------------------------------------------------- + + G := RegisterClassType(H, TStringStream); + + RegisterHeader(G, <font color="Red">'constructor Create(const AString: string);'</font>, @TStringStream.Create); + RegisterHeader(G, <font color="Red">'function Read(var Buffer; Count: Longint): Longint; override;'</font>, @TStringStream.Read); + RegisterHeader(G, <font color="Red">'function ReadString(Count: Longint): string;'</font>, @TStringStream.ReadString); + RegisterHeader(G, <font color="Red">'function Seek(Offset: Longint; Origin: Word): Longint; override;'</font>, @TStringStream.Seek); + RegisterHeader(G, <font color="Red">'function Write(const Buffer; Count: Longint): Longint; override;'</font>, @TStringStream.Write); + RegisterHeader(G, <font color="Red">'procedure WriteString(const AString: string);'</font>, @TStringStream.WriteString); + + RegisterHeader(G, <font color="Red">'function _GetDataString: String;'</font>, @TStringStream_GetDataString); + RegisterProperty(G, <font color="Red">'property DataString: string read _GetDataString;'</font>); + +// TResourceStream ------------------------------------------------------------- + + G := RegisterClassType(H, TResourceStream); + + RegisterTypeAlias(0, <font color="Red">'THandle'</font>, _typeINTEGER); + + RegisterHeader(G, <font color="Red">'constructor Create(Instance: THandle; const ResName: string; ResType: PChar);'</font>, @TResourceStream.Create); + RegisterHeader(G, <font color="Red">'constructor CreateFromID(Instance: THandle; ResID: Integer; ResType: PChar);'</font>, @TResourceStream.CreateFromID); + RegisterHeader(G, <font color="Red">'function Write(const Buffer; Count: Longint): Longint; override;'</font>, @TResourceStream.Write); + +// TParser --------------------------------------------------------------------- + + G := RegisterClassType(H, TParser); + + RegisterHeader(G, <font color="Red">'constructor Create(Stream: TStream);'</font>, @TParser.Create); + RegisterHeader(G, <font color="Red">'procedure CheckToken(T: Char);'</font>, @TParser.CheckToken); + RegisterHeader(G, <font color="Red">'procedure CheckTokenSymbol(const S: string);'</font>, @TParser.CheckTokenSymbol); + RegisterHeader(G, <font color="Red">'procedure Error(const Ident: string);'</font>, @TParser.Error); + RegisterHeader(G, <font color="Red">'procedure ErrorStr(const Message: string);'</font>, @TParser.ErrorStr); + RegisterHeader(G, <font color="Red">'procedure HexToBinary(Stream: TStream);'</font>, @TParser.HexToBinary); + RegisterHeader(G, <font color="Red">'function NextToken: Char;'</font>, @TParser.NextToken); + RegisterHeader(G, <font color="Red">'function SourcePos: Longint;'</font>, @TParser.SourcePos); + RegisterHeader(G, <font color="Red">'function TokenComponentIdent: string;'</font>, @TParser.TokenComponentIdent); + RegisterHeader(G, <font color="Red">'function TokenFloat: Extended;'</font>, @TParser.TokenFloat); + RegisterHeader(G, <font color="Red">'function TokenString: string;'</font>, @TParser.TokenString); + RegisterHeader(G, <font color="Red">'function TokenSymbolIs(const S: string): Boolean;'</font>, @TParser.TokenSymbolIs); + + RegisterHeader(G, <font color="Red">'function _GetFloatType: Char;'</font>, @TParser_GetFloatType); + RegisterProperty(G, <font color="Red">'property FloatType: Char read _GetFloatType;'</font>); + + RegisterHeader(G, <font color="Red">'function _GetSourceLine: Integer;'</font>, @TParser_GetSourceLine); + RegisterProperty(G, <font color="Red">'property SourceLine: Integer read _GetSourceLine;'</font>); + + RegisterHeader(G, <font color="Red">'function _GetToken: Char;'</font>, @TParser_GetToken); + RegisterProperty(G, <font color="Red">'property Token: Char read _GetToken;'</font>); + +// TComponent ------------------------------------------------------------------ + + RegisterClassType(H, TBasicAction); + RegisterRTTIType(H, TypeInfo(TComponentState)); + RegisterRTTIType(H, TypeInfo(TComponentStyle)); + RegisterTypeAlias(0, <font color="Red">'HRESULT'</font>, _typeINTEGER); + + G := RegisterClassType(H, TComponent); + + RegisterHeader(G, <font color="Red">'constructor Create(AOwner: TComponent); virtual;'</font>, @TComponent.Create); + RegisterHeader(G, <font color="Red">'procedure BeforeDestruction; override;'</font>, @TComponent.BeforeDestruction); + RegisterHeader(G, <font color="Red">'procedure DestroyComponents;'</font>, @TComponent.DestroyComponents); + RegisterHeader(G, <font color="Red">'procedure Destroying;'</font>, @TComponent.Destroying); + RegisterHeader(G, <font color="Red">'function ExecuteAction(Action: TBasicAction): Boolean; dynamic;'</font>, @TComponent.ExecuteAction); + RegisterHeader(G, <font color="Red">'function FindComponent(const AName: string): TComponent;'</font>, @TComponent.FindComponent); + RegisterHeader(G, <font color="Red">'procedure FreeNotification(AComponent: TComponent);'</font>, @TComponent.FreeNotification); + RegisterHeader(G, <font color="Red">'procedure RemoveFreeNotification(AComponent: TComponent);'</font>, @TComponent.RemoveFreeNotification); + RegisterHeader(G, <font color="Red">'procedure FreeOnRelease;'</font>, @TComponent.FreeOnRelease); + RegisterHeader(G, <font color="Red">'function GetParentComponent: TComponent; dynamic;'</font>, @TComponent.GetParentComponent); + RegisterHeader(G, <font color="Red">'function GetNamePath: string; override;'</font>, @TComponent.GetNamePath); + RegisterHeader(G, <font color="Red">'function HasParent: Boolean; dynamic;'</font>, @TComponent.HasParent); + RegisterHeader(G, <font color="Red">'procedure InsertComponent(AComponent: TComponent);'</font>, @TComponent.InsertComponent); + RegisterHeader(G, <font color="Red">'procedure RemoveComponent(AComponent: TComponent);'</font>, @TComponent.RemoveComponent); + RegisterHeader(G, <font color="Red">'function SafeCallException(ExceptObject: TObject; ExceptAddr: Pointer): HResult; override;'</font>, @TComponent.SafeCallException); + RegisterHeader(G, <font color="Red">'function UpdateAction(Action: TBasicAction): Boolean; dynamic;'</font>, @TComponent.UpdateAction); + + RegisterHeader(G, <font color="Red">'function _GetComponent(I: Integer): TComponent;'</font>, @TComponent_GetComponent); + RegisterProperty(G, <font color="Red">'property Components[Index: Integer]: TComponent read _GetComponent;'</font>); + + RegisterHeader(G, <font color="Red">'function _GetComponentCount: Integer;'</font>, @TComponent_GetComponentCount); + RegisterProperty(G, <font color="Red">'property ComponentCount: Integer read _GetComponentCount;'</font>); + + RegisterHeader(G, <font color="Red">'function _GetComponentIndex: Integer;'</font>, @TComponent_GetComponentIndex); + RegisterHeader(G, <font color="Red">'procedure _SetComponentIndex(Value: Integer);'</font>, @TComponent_SetComponentIndex); + RegisterProperty(G, <font color="Red">'property ComponentIndex: Integer read _GetComponentIndex write _SetComponentIndex;'</font>); + + RegisterHeader(G, <font color="Red">'function _GetComponentState: TComponentState;'</font>, @TComponent_GetComponentState); + RegisterProperty(G, <font color="Red">'property ComponentState: TComponentState read _GetComponentState;'</font>); + + RegisterHeader(G, <font color="Red">'function _GetComponentStyle: TComponentStyle;'</font>, @TComponent_GetComponentStyle); + RegisterProperty(G, <font color="Red">'property ComponentStyle: TComponentStyle read _GetComponentStyle;'</font>); + + RegisterHeader(G, <font color="Red">'function _GetDesignInfo: Integer;'</font>, @TComponent_GetDesignInfo); + RegisterHeader(G, <font color="Red">'procedure _SetDesignInfo(Value: Integer);'</font>, @TComponent_SetDesignInfo); + RegisterProperty(G, <font color="Red">'property DesignInfo: Longint read _GetDesignInfo write _SetDesignInfo;'</font>); + + RegisterHeader(G, <font color="Red">'function _GetOwner: TComponent;'</font>, @TComponent_GetOwner); + RegisterProperty(G, <font color="Red">'property Owner: TComponent read _GetOwner;'</font>); + +{ Point and rectangle constructors } + + RegisterHeader(H, <font color="Red">'function Point(AX, AY: Integer): TPoint;'</font>, @Point); + RegisterHeader(H, <font color="Red">'function Rect(ALeft, ATop, ARight, ABottom: Integer): TRect;'</font>, @Rect); + RegisterHeader(H, <font color="Red">'function Bounds(ALeft, ATop, AWidth, AHeight: Integer): TRect;'</font>, @Bounds); + +{ Class registration routines } + + RegisterHeader(H, <font color="Red">'procedure RegisterClass(AClass: TPersistentClass);'</font>, @RegisterClass); + RegisterHeader(H, <font color="Red">'procedure UnRegisterClass(AClass: TPersistentClass);'</font>, @UnRegisterClass); + RegisterHeader(H, <font color="Red">'function FindClass(const ClassName: string): TPersistentClass;'</font>, @FindClass); + RegisterHeader(H, <font color="Red">'function GetClass(const AClassName: string): TPersistentClass;'</font>, @GetClass); +<font color="blue"><b>end</b></font>; + +<font color="blue"><b>initialization</b></font> + +Register_Classes; + +<font color="blue"><b>end</b></font>. +</pre> +</blockquote> + + +<p> +<HR> +<font size = 1 color ="gray"> +Copyright © 2006-2009 +VIRT Laboratory. All rights reserved. +</font> +</body> +</html> diff --git a/help/import_sysutils.htm b/help/import_sysutils.htm new file mode 100644 index 0000000..c1902fd --- /dev/null +++ b/help/import_sysutils.htm @@ -0,0 +1,403 @@ +<html> +<head> +<link rel=stylesheet type="text/css" href="styles.css"> +</head> +<body> +<H2> +paxCompiler for Delphi. Import unit IMPORT_SysUtils.pas. +</H2> +<hr> + +<blockquote> +<pre> +<font color="blue"><b>unit</b></font> IMPORT_SysUtils; +<font color="blue"><b>interface</b></font> +<font color="blue"><b>uses</b></font> + SysUtils, + PaxCompiler; + +<font color="blue"><b>procedure</b></font> Register_SysUtils; + +<font color="blue"><b>implementation</b></font> + +<font color="blue"><b>function</b></font> _Format(<font color="blue"><b>const</b></font> S: <font color="blue"><b>string</b></font>; <font color="blue"><b>const</b></font> Args: <font color="blue"><b>array</b></font> <font color="blue"><b>of</b></font> <font color="blue"><b>const</b></font>): <font color="blue"><b>string</b></font>; +<font color="blue"><b>begin</b></font> + result := Format(S, Args); +<font color="blue"><b>end</b></font>; + +// Exception ------------------------------------------------------------------- + +<font color="blue"><b>function</b></font> Exception_GetMessage(Self: Exception): <font color="blue"><b>String</b></font>; +<font color="blue"><b>begin</b></font> + result := Self.Message; +<font color="blue"><b>end</b></font>; + +<font color="blue"><b>procedure</b></font> Exception_SetMessage(Self: Exception; <font color="blue"><b>const</b></font> Value: <font color="blue"><b>String</b></font>); +<font color="blue"><b>begin</b></font> + Self.Message := Value; +<font color="blue"><b>end</b></font>; + +<font color="blue"><b>function</b></font> Exception_GetHelpContext(Self: Exception): Integer; +<font color="blue"><b>begin</b></font> + result := Self.HelpContext; +<font color="blue"><b>end</b></font>; + +<font color="blue"><b>procedure</b></font> Exception_SetHelpContext(Self: Exception; Value: Integer); +<font color="blue"><b>begin</b></font> + Self.HelpContext := Value; +<font color="blue"><b>end</b></font>; + + +<font color="blue"><b>procedure</b></font> Register_SysUtils; +<font color="blue"><b>var</b></font> + H, G: Integer; +<font color="blue"><b>begin</b></font> + RegisterTypeAlias(0, <font color="Red">'TDateTime'</font>, _typeDOUBLE); + + H := RegisterNamespace(0, <font color="Red">'SysUtils'</font>); + + RegisterRTTIType(H, TypeInfo(TReplaceFlags)); + + G := RegisterRecordType(H, <font color="Red">'TTimeStamp'</font>); + RegisterRecordTypeField(G, <font color="Red">'Time'</font>, _typeINTEGER); + RegisterRecordTypeField(G, <font color="Red">'Date'</font>, _typeINTEGER); + + G := RegisterRecordType(H, <font color="Red">'TSystemTime'</font>); + RegisterRecordTypeField(G, <font color="Red">'wYear'</font>, _typeWORD); + RegisterRecordTypeField(G, <font color="Red">'wMonth'</font>, _typeWORD); + RegisterRecordTypeField(G, <font color="Red">'wDayOfWeek'</font>, _typeWORD); + RegisterRecordTypeField(G, <font color="Red">'wDay'</font>, _typeWORD); + RegisterRecordTypeField(G, <font color="Red">'wHour'</font>, _typeWORD); + RegisterRecordTypeField(G, <font color="Red">'wMinute'</font>, _typeWORD); + RegisterRecordTypeField(G, <font color="Red">'wSecond'</font>, _typeWORD); + RegisterRecordTypeField(G, <font color="Red">'wMilliSecond'</font>, _typeWORD); + +{ File open modes } + + RegisterConstant(H, <font color="Red">'fmOpenRead'</font>, fmOpenRead); + RegisterConstant(H, <font color="Red">'fmOpenWrite'</font>, fmOpenWrite); + RegisterConstant(H, <font color="Red">'fmOpenReadWrite'</font>, fmOpenReadWrite); + RegisterConstant(H, <font color="Red">'fmShareCompat'</font>, fmShareCompat); + RegisterConstant(H, <font color="Red">'fmShareExclusive'</font>, fmShareExclusive); + RegisterConstant(H, <font color="Red">'fmShareDenyWrite'</font>, fmShareDenyWrite); + RegisterConstant(H, <font color="Red">'fmShareDenyRead'</font>, fmShareDenyRead); + RegisterConstant(H, <font color="Red">'fmShareDenyNone'</font>, fmShareDenyNone); + +{ File attribute constants } + + RegisterConstant(H, <font color="Red">'faReadOnly'</font>, faReadOnly); + RegisterConstant(H, <font color="Red">'faHidden'</font>, faHidden); + RegisterConstant(H, <font color="Red">'faSysFile'</font>, faSysFile); + RegisterConstant(H, <font color="Red">'faVolumeID'</font>, faVolumeID); + RegisterConstant(H, <font color="Red">'faDirectory'</font>, faDirectory); + RegisterConstant(H, <font color="Red">'faArchive'</font>, faArchive); + RegisterConstant(H, <font color="Red">'faAnyFile'</font>, faAnyFile); + +{ File mode magic numbers } + + RegisterConstant(H, <font color="Red">'fmClosed'</font>, fmClosed); + RegisterConstant(H, <font color="Red">'fmInput'</font>, fmInput); + RegisterConstant(H, <font color="Red">'fmOutput'</font>, fmOutput); + RegisterConstant(H, <font color="Red">'fmInOut'</font>, fmInOut); + +{ Seconds and milliseconds per day } + + RegisterConstant(H, <font color="Red">'SecsPerDay'</font>, SecsPerDay); + RegisterConstant(H, <font color="Red">'MSecsPerDay'</font>, MSecsPerDay); + +{ Days between 1/1/0001 and 12/31/1899 } + + RegisterConstant(H, <font color="Red">'DateDelta'</font>, DateDelta); + + RegisterTypeAlias(0, <font color="Red">'cardinal'</font>, _typeINTEGER); + RegisterTypeAlias(0, <font color="Red">'LongWord'</font>, _typeINTEGER); + + RegisterHeader(H, <font color="Red">'function UpperCase(const S: string): string;'</font>, @UpperCase); + RegisterHeader(H, <font color="Red">'function LowerCase(const S: string): string;'</font>, @LowerCase); + RegisterHeader(H, <font color="Red">'function CompareStr(const S1, S2: string): Integer;'</font>, @CompareStr); + RegisterHeader(H, <font color="Red">'function CompareMem(P1, P2: Pointer; Length: Integer): Boolean;'</font>, @CompareMem); + RegisterHeader(H, <font color="Red">'function CompareText(const S1, S2: string): Integer;'</font>, @CompareText); + RegisterHeader(H, <font color="Red">'function SameText(const S1, S2: string): Boolean;'</font>, @SameText); + RegisterHeader(H, <font color="Red">'function AnsiUpperCase(const S: string): string;'</font>, @AnsiUpperCase); + RegisterHeader(H, <font color="Red">'function AnsiLowerCase(const S: string): string;'</font>, @AnsiLowerCase); + RegisterHeader(H, <font color="Red">'function AnsiCompareStr(const S1, S2: string): Integer;'</font>, @AnsiCompareStr); + RegisterHeader(H, <font color="Red">'function AnsiSameStr(const S1, S2: string): Boolean;'</font>, @AnsiSameStr); + RegisterHeader(H, <font color="Red">'function AnsiCompareText(const S1, S2: string): Integer;'</font>, @AnsiCompareText); + RegisterHeader(H, <font color="Red">'function AnsiSameText(const S1, S2: string): Boolean;'</font>, @AnsiSameText); + RegisterHeader(H, <font color="Red">'function AnsiStrComp(S1, S2: PChar): Integer;'</font>, @AnsiStrComp); + RegisterHeader(H, <font color="Red">'function AnsiStrIComp(S1, S2: PChar): Integer;'</font>, @AnsiStrIComp); + RegisterHeader(H, <font color="Red">'function AnsiStrLComp(S1, S2: PChar; MaxLen: Cardinal): Integer;'</font>, @AnsiStrLComp); + RegisterHeader(H, <font color="Red">'function AnsiStrLIComp(S1, S2: PChar; MaxLen: Cardinal): Integer;'</font>, @AnsiStrLIComp); + RegisterHeader(H, <font color="Red">'function AnsiStrLower(Str: PChar): PChar;'</font>, @AnsiStrLower); + RegisterHeader(H, <font color="Red">'function AnsiStrUpper(Str: PChar): PChar;'</font>, @AnsiStrUpper); + RegisterHeader(H, <font color="Red">'function AnsiLastChar(const S: string): PChar;'</font>, @AnsiLastChar); + RegisterHeader(H, <font color="Red">'function AnsiStrLastChar(P: PChar): PChar;'</font>, @AnsiStrLastChar); + RegisterHeader(H, <font color="Red">'function Trim(const S: string): string;'</font>, @Trim); + RegisterHeader(H, <font color="Red">'function TrimLeft(const S: string): string;'</font>, @TrimLeft); + RegisterHeader(H, <font color="Red">'function TrimRight(const S: string): string;'</font>, @TrimRight); + RegisterHeader(H, <font color="Red">'function QuotedStr(const S: string): string;'</font>, @QuotedStr); + RegisterHeader(H, <font color="Red">'function AnsiQuotedStr(const S: string; Quote: Char): string;'</font>, @AnsiQuotedStr); + RegisterHeader(H, <font color="Red">'function AnsiExtractQuotedStr(var Src: PChar; Quote: Char): string;'</font>, @AnsiExtractQuotedStr); + RegisterHeader(H, <font color="Red">'function AdjustLineBreaks(const S: string): string;'</font>, @AdjustLineBreaks); + RegisterHeader(H, <font color="Red">'function IsValidIdent(const Ident: string): Boolean;'</font>, @IsValidIdent); + RegisterHeader(H, <font color="Red">'function IntToStr(Value: Integer): string;'</font>, @IntToStr); + RegisterHeader(H, <font color="Red">'function IntToHex(Value: Integer; Digits: Integer): string;'</font>, @IntToHex); + RegisterHeader(H, <font color="Red">'function StrToInt(const S: string): Integer;'</font>, @StrToInt); + RegisterHeader(H, <font color="Red">'function StrToIntDef(const S: string; Default: Integer): Integer;'</font>, @StrToIntDef); + RegisterHeader(H, <font color="Red">'function LoadStr(Ident: Integer): string;'</font>, @LoadStr); + RegisterHeader(H, <font color="Red">'function FileOpen(const FileName: string; Mode: LongWord): Integer;'</font>, @FileOpen); + RegisterHeader(H, <font color="Red">'function FileCreate(const FileName: string): Integer;'</font>, @FileCreate); + RegisterHeader(H, <font color="Red">'function FileRead(Handle: Integer; var Buffer; Count: LongWord): Integer;'</font>, @FileRead); + RegisterHeader(H, <font color="Red">'function FileWrite(Handle: Integer; const Buffer; Count: LongWord): Integer;'</font>, @FileWrite); + RegisterHeader(H, <font color="Red">'function FileSeek(Handle, Offset, Origin: Integer): Integer;'</font>, @FileSeek); + RegisterHeader(H, <font color="Red">'procedure FileClose(Handle: Integer);'</font>, @FileClose); + RegisterHeader(H, <font color="Red">'function FileAge(const FileName: string): Integer;'</font>, @FileAge); + RegisterHeader(H, <font color="Red">'function FileExists(const FileName: string): Boolean;'</font>, @FileExists); + RegisterHeader(H, <font color="Red">'function FileGetDate(Handle: Integer): Integer;'</font>, @FileGetDate); + RegisterHeader(H, <font color="Red">'function FileSetDate(Handle: Integer; Age: Integer): Integer;'</font>, @FileSetDate); + RegisterHeader(H, <font color="Red">'function FileGetAttr(const FileName: string): Integer;'</font>, @FileGetAttr); + RegisterHeader(H, <font color="Red">'function FileSetAttr(const FileName: string; Attr: Integer): Integer;'</font>, @FileSetAttr); + RegisterHeader(H, <font color="Red">'function DeleteFile(const FileName: string): Boolean;'</font>, @DeleteFile); + RegisterHeader(H, <font color="Red">'function RenameFile(const OldName, NewName: string): Boolean;'</font>, @RenameFile); + RegisterHeader(H, <font color="Red">'function ChangeFileExt(const FileName, Extension: string): string;'</font>, @ChangeFileExt); + RegisterHeader(H, <font color="Red">'function ExtractFilePath(const FileName: string): string;'</font>, @ExtractFilePath); + RegisterHeader(H, <font color="Red">'function ExtractFileDir(const FileName: string): string;'</font>, @ExtractFileDir); + RegisterHeader(H, <font color="Red">'function ExtractFileDrive(const FileName: string): string;'</font>, @ExtractFileDrive); + RegisterHeader(H, <font color="Red">'function ExtractFileName(const FileName: string): string;'</font>, @ExtractFileName); + RegisterHeader(H, <font color="Red">'function ExtractFileExt(const FileName: string): string;'</font>, @ExtractFileExt); + RegisterHeader(H, <font color="Red">'function ExpandFileName(const FileName: string): string;'</font>, @ExpandFileName); + RegisterHeader(H, <font color="Red">'function ExpandUNCFileName(const FileName: string): string;'</font>, @ExpandUNCFileName); + RegisterHeader(H, <font color="Red">'function ExtractRelativePath(const BaseName, DestName: string): string;'</font>, @ExtractRelativePath); + RegisterHeader(H, <font color="Red">'function ExtractShortPathName(const FileName: string): string;'</font>, @ExtractShortPathName); + RegisterHeader(H, <font color="Red">'function FileSearch(const Name, DirList: string): string;'</font>, @FileSearch); + RegisterHeader(H, <font color="Red">'function GetCurrentDir: string;'</font>, @GetCurrentDir); + RegisterHeader(H, <font color="Red">'function SetCurrentDir(const Dir: string): Boolean;'</font>, @SetCurrentDir); + RegisterHeader(H, <font color="Red">'function CreateDir(const Dir: string): Boolean;'</font>, @CreateDir); + RegisterHeader(H, <font color="Red">'function RemoveDir(const Dir: string): Boolean;'</font>, @RemoveDir); + + RegisterHeader(H, <font color="Red">'function StrLen(const Str: PChar): Cardinal;'</font>, @StrLen); + RegisterHeader(H, <font color="Red">'function StrEnd(const Str: PChar): PChar;'</font>, @StrEnd); + RegisterHeader(H, <font color="Red">'function StrMove(Dest: PChar; const Source: PChar; Count: Cardinal): PChar;'</font>, @StrMove); + RegisterHeader(H, <font color="Red">'function StrCopy(Dest: PChar; const Source: PChar): PChar;'</font>, @StrCopy); + RegisterHeader(H, <font color="Red">'function StrECopy(Dest:PChar; const Source: PChar): PChar;'</font>, @StrECopy); + RegisterHeader(H, <font color="Red">'function StrLCopy(Dest: PChar; const Source: PChar; MaxLen: Cardinal): PChar;'</font>, @StrLCopy); + RegisterHeader(H, <font color="Red">'function StrPCopy(Dest: PChar; const Source: string): PChar;'</font>, @StrPCopy); + RegisterHeader(H, <font color="Red">'function StrPLCopy(Dest: PChar; const Source: string; MaxLen: Cardinal): PChar;'</font>, @StrPLCopy); + RegisterHeader(H, <font color="Red">'function StrCat(Dest: PChar; const Source: PChar): PChar;'</font>, @StrCat); + RegisterHeader(H, <font color="Red">'function StrLCat(Dest: PChar; const Source: PChar; MaxLen: Cardinal): PChar;'</font>, @StrLCat); + RegisterHeader(H, <font color="Red">'function StrComp(const Str1, Str2: PChar): Integer;'</font>, @StrComp); + RegisterHeader(H, <font color="Red">'function StrIComp(const Str1, Str2: PChar): Integer;'</font>, @StrIComp); + RegisterHeader(H, <font color="Red">'function StrLComp(const Str1, Str2: PChar; MaxLen: Cardinal): Integer;'</font>, @StrLComp); + RegisterHeader(H, <font color="Red">'function StrLIComp(const Str1, Str2: PChar; MaxLen: Cardinal): Integer;'</font>, @StrLIComp); + RegisterHeader(H, <font color="Red">'function StrScan(const Str: PChar; Chr: Char): PChar;'</font>, @StrScan); + RegisterHeader(H, <font color="Red">'function StrRScan(const Str: PChar; Chr: Char): PChar;'</font>, @StrRScan); + RegisterHeader(H, <font color="Red">'function StrPos(const Str1, Str2: PChar): PChar;'</font>, @StrPos); + RegisterHeader(H, <font color="Red">'function StrUpper(Str: PChar): PChar;'</font>, @StrUpper); + RegisterHeader(H, <font color="Red">'function StrLower(Str: PChar): PChar;'</font>, @StrLower); + RegisterHeader(H, <font color="Red">'function StrPas(const Str: PChar): string;'</font>, @StrPas); + RegisterHeader(H, <font color="Red">'function StrAlloc(Size: Cardinal): PChar;'</font>, @StrAlloc); + RegisterHeader(H, <font color="Red">'function StrBufSize(const Str: PChar): Cardinal;'</font>, @StrBufSize); + RegisterHeader(H, <font color="Red">'function StrNew(const Str: PChar): PChar;'</font>, @StrNew); + RegisterHeader(H, <font color="Red">'procedure StrDispose(Str: PChar);'</font>, @StrDispose); + + RegisterHeader(H, <font color="Red">'function FloatToStr(Value: Extended): string;'</font>, @FloatToStr); + RegisterHeader(H, <font color="Red">'function FormatFloat(const Format: string; Value: Extended): string;'</font>, @FormatFloat); + RegisterHeader(H, <font color="Red">'function StrToFloat(const S: string): Extended;'</font>, @StrToFloat); + + RegisterHeader(H, <font color="Red">'function DateTimeToTimeStamp(DateTime: TDateTime): TTimeStamp;'</font>, @DateTimeToTimeStamp); + RegisterHeader(H, <font color="Red">'function TimeStampToDateTime(const TimeStamp: TTimeStamp): TDateTime;'</font>, @TimeStampToDateTime); + RegisterHeader(H, <font color="Red">'function EncodeDate(Year, Month, Day: Word): TDateTime;'</font>, @EncodeDate); + RegisterHeader(H, <font color="Red">'function EncodeTime(Hour, Min, Sec, MSec: Word): TDateTime;'</font>, @EncodeTime); + RegisterHeader(H, <font color="Red">'procedure DecodeDate(Date: TDateTime; var Year, Month, Day: Word);'</font>, @DecodeDate); + RegisterHeader(H, <font color="Red">'procedure DecodeTime(Time: TDateTime; var Hour, Min, Sec, MSec: Word);'</font>, @DecodeTime); + RegisterHeader(H, <font color="Red">'procedure DateTimeToSystemTime(DateTime: TDateTime; var SystemTime: TSystemTime);'</font>, @DateTimeToSystemTime); + RegisterHeader(H, <font color="Red">'function SystemTimeToDateTime(const SystemTime: TSystemTime): TDateTime;'</font>, @SystemTimeToDateTime); + RegisterHeader(H, <font color="Red">'function DayOfWeek(Date: TDateTime): Integer;'</font>, @DayOfWeek); + RegisterHeader(H, <font color="Red">'function Date: TDateTime;'</font>, @Date); + RegisterHeader(H, <font color="Red">'function Time: TDateTime;'</font>, @Time); + RegisterHeader(H, <font color="Red">'function Now: TDateTime;'</font>, @Now); + RegisterHeader(H, <font color="Red">'function IncMonth(const Date: TDateTime; NumberOfMonths: Integer): TDateTime;'</font>, @IncMonth); + RegisterHeader(H, <font color="Red">'procedure ReplaceTime(var DateTime: TDateTime; const NewTime: TDateTime);'</font>, @ReplaceTime); + RegisterHeader(H, <font color="Red">'procedure ReplaceDate(var DateTime: TDateTime; const NewDate: TDateTime);'</font>, @ReplaceDate); + RegisterHeader(H, <font color="Red">'function IsLeapYear(Year: Word): Boolean;'</font>, @IsLeapYear); + RegisterHeader(H, <font color="Red">'function DateToStr(Date: TDateTime): string;'</font>, @DateToStr); + RegisterHeader(H, <font color="Red">'function TimeToStr(Time: TDateTime): string;'</font>, @TimeToStr); + RegisterHeader(H, <font color="Red">'function DateTimeToStr(DateTime: TDateTime): string;'</font>, @DateTimeToStr); + RegisterHeader(H, <font color="Red">'function StrToDate(const S: string): TDateTime;'</font>, @StrToDate); + RegisterHeader(H, <font color="Red">'function StrToTime(const S: string): TDateTime;'</font>, @StrToTime); + RegisterHeader(H, <font color="Red">'function StrToDateTime(const S: string): TDateTime;'</font>, @StrToDateTime); + + RegisterHeader(H, <font color="Red">'function FormatDateTime(const Format: string; DateTime: TDateTime): string;'</font>, @FormatDateTime); + RegisterHeader(H, <font color="Red">'procedure GetFormatSettings;'</font>, @GetFormatSettings); + + RegisterHeader(H, <font color="Red">'function StringReplace(const S, OldPattern, NewPattern: string; Flags: TReplaceFlags): string;'</font>, @StringReplace); + + RegisterHeader(H, <font color="Red">'procedure FreeAndNil(var Obj);'</font>, @FreeAndNil); + + RegisterHeader(H, <font color="Red">'function Format(const S: string; const Args: array of const): string;'</font>, + @_Format); + +// Exception ------------------------------------------------------------------- + + G := RegisterClassType(H, Exception); + RegisterClassReferenceType(H, <font color="Red">'ExceptClass'</font>, G); + + RegisterHeader(G, <font color="Red">'constructor Create(const Msg: string);'</font>, @Exception.Create); + + RegisterHeader(G, <font color="Red">'function _GetMessage: String;'</font>, @Exception_GetMessage); + RegisterHeader(G, <font color="Red">'procedure _SetMessage(const Value: String);'</font>, @Exception_SetMessage); + RegisterProperty(G, <font color="Red">'property Message: string read _GetMessage write _SetMessage;'</font>); + + RegisterHeader(G, <font color="Red">'function _GetHelpContext: Integer;'</font>, @Exception_GetHelpContext); + RegisterHeader(G, <font color="Red">'procedure _SetHelpContext(Value: Integer);'</font>, @Exception_SetHelpContext); + RegisterProperty(G, <font color="Red">'property HelpContext: Integer read _GetHelpContext write _SetHelpContext;'</font>); + +// EAbort ---------------------------------------------------------------------- + + G := RegisterClassType(H, EAbort); + RegisterHeader(G, <font color="Red">'constructor Create(const Msg: string);'</font>, @EAbort.Create); + +// EOutOfMemory ---------------------------------------------------------------- + + G := RegisterClassType(H, EOutOfMemory); + RegisterHeader(G, <font color="Red">'constructor Create(const Msg: string);'</font>, @EOutOfMemory.Create); + +// EInOutError ----------------------------------------------------------------- + + G := RegisterClassType(H, EInOutError); + RegisterHeader(G, <font color="Red">'constructor Create(const Msg: string);'</font>, @EInOutError.Create); + RegisterClassTypeField(G, <font color="Red">'ErrorCode'</font>, _typeINTEGER, Integer(@EInOutError(<font color="blue"><b>nil</b></font>).ErrorCode)); + +// EExternal ------------------------------------------------------------------- + + G := RegisterClassType(H, EExternal); + RegisterHeader(G, <font color="Red">'constructor Create(const Msg: string);'</font>, @EExternal.Create); + +// EExternalException ---------------------------------------------------------- + + G := RegisterClassType(H, EExternalException); + RegisterHeader(G, <font color="Red">'constructor Create(const Msg: string);'</font>, @EExternalException.Create); + +// EIntError ------------------------------------------------------------------- + + G := RegisterClassType(H, EIntError); + RegisterHeader(G, <font color="Red">'constructor Create(const Msg: string);'</font>, @EIntError.Create); + +// EDivByZero ------------------------------------------------------------------ + + G := RegisterClassType(H, EDivByZero); + RegisterHeader(G, <font color="Red">'constructor Create(const Msg: string);'</font>, @EDivByZero.Create); + +// ERangeError ----------------------------------------------------------------- + + G := RegisterClassType(H, ERangeError); + RegisterHeader(G, <font color="Red">'constructor Create(const Msg: string);'</font>, @ERangeError.Create); + +// EIntOverflow ---------------------------------------------------------------- + + G := RegisterClassType(H, EIntOverflow); + RegisterHeader(G, <font color="Red">'constructor Create(const Msg: string);'</font>, @EIntOverflow.Create); + +// EMathError ------------------------------------------------------------------ + + G := RegisterClassType(H, EMathError); + RegisterHeader(G, <font color="Red">'constructor Create(const Msg: string);'</font>, @EMathError.Create); + +// EInvalidOp ------------------------------------------------------------------ + + G := RegisterClassType(H, EInvalidOp); + RegisterHeader(G, <font color="Red">'constructor Create(const Msg: string);'</font>, @EInvalidOp.Create); + +// EZeroDivide ----------------------------------------------------------------- + + G := RegisterClassType(H, EZeroDivide); + RegisterHeader(G, <font color="Red">'constructor Create(const Msg: string);'</font>, @EZeroDivide.Create); + +// EOverflow ------------------------------------------------------------------- + + G := RegisterClassType(H, EOverflow); + RegisterHeader(G, <font color="Red">'constructor Create(const Msg: string);'</font>, @EOverflow.Create); + +// EUnderflow ------------------------------------------------------------------ + + G := RegisterClassType(H, EUnderflow); + RegisterHeader(G, <font color="Red">'constructor Create(const Msg: string);'</font>, @EUnderflow.Create); + +// EInvalidPointer ------------------------------------------------------------- + + G := RegisterClassType(H, EInvalidPointer); + RegisterHeader(G, <font color="Red">'constructor Create(const Msg: string);'</font>, @EInvalidPointer.Create); + +// EInvalidCast ---------------------------------------------------------------- + + G := RegisterClassType(H, EInvalidCast); + RegisterHeader(G, <font color="Red">'constructor Create(const Msg: string);'</font>, @EInvalidCast.Create); + +// EConvertError --------------------------------------------------------------- + + G := RegisterClassType(H, EConvertError); + RegisterHeader(G, <font color="Red">'constructor Create(const Msg: string);'</font>, @EConvertError.Create); + +// EAccessViolation --------------------------------------------------------------- + + G := RegisterClassType(H, EAccessViolation); + RegisterHeader(G, <font color="Red">'constructor Create(const Msg: string);'</font>, @EAccessViolation.Create); + +// EPrivilege ------------------------------------------------------------------ + + G := RegisterClassType(H, EPrivilege); + RegisterHeader(G, <font color="Red">'constructor Create(const Msg: string);'</font>, @EPrivilege.Create); + +// EStackOverflow ------------------------------------------------------------------ + + G := RegisterClassType(H, EStackOverflow); + RegisterHeader(G, <font color="Red">'constructor Create(const Msg: string);'</font>, @EStackOverflow.Create); + +// EControlC ------------------------------------------------------------------- + + G := RegisterClassType(H, EControlC); + RegisterHeader(G, <font color="Red">'constructor Create(const Msg: string);'</font>, @EControlC.Create); + +// EVariantError --------------------------------------------------------------- + + G := RegisterClassType(H, EVariantError); + RegisterHeader(G, <font color="Red">'constructor Create(const Msg: string);'</font>, @EVariantError.Create); + +// EPropReadOnly --------------------------------------------------------------- + + G := RegisterClassType(H, EPropReadOnly); + RegisterHeader(G, <font color="Red">'constructor Create(const Msg: string);'</font>, @EPropReadOnly.Create); + +// EPropWriteOnly -------------------------------------------------------------- + + G := RegisterClassType(H, EPropWriteOnly); + RegisterHeader(G, <font color="Red">'constructor Create(const Msg: string);'</font>, @EPropWriteOnly.Create); + +// EAssertionFailed ------------------------------------------------------------ + + G := RegisterClassType(H, EAssertionFailed); + RegisterHeader(G, <font color="Red">'constructor Create(const Msg: string);'</font>, @EAssertionFailed.Create); + +// EAbstractError -------------------------------------------------------------- + + G := RegisterClassType(H, EAbstractError); + RegisterHeader(G, <font color="Red">'constructor Create(const Msg: string);'</font>, @EAbstractError.Create); +<font color="blue"><b>end</b></font>; + +<font color="blue"><b>initialization</b></font> + +Register_SysUtils; + +<font color="blue"><b>end</b></font>. +</pre> +</blockquote> + + +<p> +<HR> +<font size = 1 color ="gray"> +Copyright © 2006-2009 +VIRT Laboratory. All rights reserved. +</font> +</body> +</html> diff --git a/help/importer.htm b/help/importer.htm new file mode 100644 index 0000000..f5d8d57 --- /dev/null +++ b/help/importer.htm @@ -0,0 +1,375 @@ +<html> +<HEAD> +<TITLE> + + + + + +

+paxCompiler Importer +

+
+ + + + + + +
+importe.jpg +
+ +

+

+ +paxCompiler importer (paxImp.exe) is a freeware program that generates import units +from source code units of your application, so all members defined in your +application become accessible for your paxCompiler scripts. You can +create import files for all Delphi versions starting with Delphi 5 (D5-XE6). + +

+(Click here to download the importer). + +

+paxCompiler importer works in 2 modes. + +

    +
  • You can create import files to import all members of source units (types, functions, procedures, variables and constants). +These members become accessible for all TPaxCompiler instances in your application. +
  • You can import only global members (functions, procedures, variables and constants) of source +files. This mode can be used with automatic import of Delphi units which is available for XE2-XE6. +These Delphi versions provide information about types of your application via RTTI. paxCompiler +uses this information to import types automatically during script compilation. +Global members have not RTTI. They can be accessible with help of generated import files. +You include these files into your application and bind it with TPaxCompiler instance using +OnImportGlobalMembers event. +
+ +

AnsiChars option permits you to create import files for old Delphi +versions which does not support UnicodeStrings. You can assign directives of +conditional compilation to importer to provide proper parsing of source units. +You can also introduce some restrictions on list of source files to help +importer to select suitable files from the list. + +

+Demo +

+ +

+Let's consider how it works on a very simple demo. Let's suppose we have a +source code unit MyUnit.pas: + +

+
+ +
+
+unit MyUnit;
+interface
+uses
+  Classes;
+const
+  Comm = '\\';
+type
+  TLang = (wEnglish, wFrench, wAll);
+  TMyClass = class(TStringList)
+  public
+    procedure CountWords(const Pattern: String; Lang: TLang);
+  end;
+  function Deliver(C: Integer): Boolean;
+var
+  LastCount: Integer;
+implementation
+..........................
+
+
+ +
+

+ +

+Mode 1 - global import +

+ +Applying importer to 2 files System.Classes.pas and MyUnit.pas we get 3 +output files IMP_System.Classes.pas, IMP_MyUnit.pas and IMPORT_Common.pas. +The IMPORT_Common.pas content is: + +

+
+
+
+unit IMPORT_Common;
+interface
+procedure Register_Common;
+implementation
+uses
+  IMP_System.Classes,
+  IMP_MyUnit;
+procedure Register_Common;
+begin
+  Register_System_Classes;
+  Register_MyUnit;
+end;
+end.
+
+
+
+

+ +All members of System.Classes.pas and MyUnit.pas are available for +your application via content of IMP_System.Classes.pas and IMP_MyUnit.pas. + +

+IMP_MyUnit.pas has view: + +

+
+
+
+unit IMP_MyUnit;
+interface
+
+function Register_MyUnit: Integer;
+
+implementation
+
+uses
+  PAXCOMP_STDLIB,
+  PaxRegister,
+  System.Classes,
+  MyUnit;
+
+// procedure CountWords(const Pattern: String; Lang: TLang);
+function RegisterMethodProcedure_TMyClass_CountWords(H: Integer): Integer;
+begin
+  result := RegisterMethod(H, 'CountWords'
+    , _typeVOID // result type
+    , @ TMyClass.CountWords // address
+    );
+  RegisterParameter(result, 'Pattern', _typeUNICSTRING, _parCONST);
+  RegisterParameter(result, 'Lang', 'TLang', _parVAL);
+end;
+
+function RegisterConstant_Comm(H: Integer): Integer;
+begin
+  result := RegisterConstant(H, 'Comm = ''\\'';');
+end;
+
+function RegisterEnumType_TLang(H: Integer): Integer;
+begin
+  result := RegisterEnumType(H, 'TLang');
+  RegisterEnumValue(result, 'wEnglish', 0);
+  RegisterEnumValue(result, 'wFrench', 1);
+  RegisterEnumValue(result, 'wAll', 2);
+end;
+
+function RegisterClassType_TMyClass(H: Integer): Integer;
+begin
+  result := RegisterClassType(H, TMyClass);
+  RegisterMethodProcedure_TMyClass_CountWords(result);
+end;
+
+// function Deliver(C: Integer): Boolean;
+function RegisterFunction_Deliver(H: Integer): Integer;
+begin
+  result := RegisterRoutine(H, 'Deliver'
+    , _typeBOOLEAN // result type
+    , @ Deliver // address
+    );
+  RegisterParameter(result, 'C', _typeINTEGER, _parVAL);
+end;
+
+function RegisterVariable_LastCount(H: Integer): Integer;
+var
+  T: Integer;
+begin
+  T := _typeINTEGER;
+  result := RegisterVariable(H, 'LastCount', T, @LastCount);
+end;
+
+procedure Part1(result: Integer);
+begin
+  RegisterConstant_Comm(result);
+  RegisterEnumType_TLang(result);
+  RegisterClassType_TMyClass(result);
+  RegisterFunction_Deliver(result);
+  RegisterVariable_LastCount(result);
+end;
+
+function Register_MyUnit: Integer;
+begin
+  result := RegisterNamespace(0, 'MyUnit');
+  RegisterUsingNamespace('System.Classes');
+  Part1(result);
+  UnregisterUsingNamespaces;
+end;
+
+end.
+
+
+
+

+ + +To make host-defined members to be accessible in your scripts, you have to call +procedure Register_Common before you create first instance +of TPaxCompiler class: + +

+
+
+
+Register_Common;
+.................
+PaxCompiler1 := TPaxCompiler.Create(nil);
+
+
+
+

+ + +If you are using TPaxCompiler instance as component in a form designer, +the best way is to place Register_Common call in the initialization section +of a unit of your application. + +

+Mode 2- import global members only +

+ +You have to switch on "Import global members only" +check box on the panel of importer. Generated IMPORT_Common.pas is + +

+
+
+
+unit IMPORT_Common;
+interface
+uses
+  PaxCompiler;
+procedure Register_Common(compiler: TPaxCompiler);
+implementation
+uses
+  IMP_System.Classes,
+  IMP_MyUnit;
+procedure Register_Common(compiler: TPaxCompiler);
+begin
+  Register_System_Classes(compiler);
+  Register_MyUnit(compiler);
+end;
+end.
+
+
+
+

+ + +As you can see, parameter compiler has been added to all procedures. +Import unit IMP_MyUnit.pas has view: + +

+
+
+ +
+unit IMP_MyUnit;
+interface
+uses
+  PaxCompiler;
+
+function Register_MyUnit(compiler: TPaxCompiler): Integer;
+
+implementation
+
+uses
+  PAXCOMP_STDLIB,
+  PaxRegister,
+  System.Classes,
+  MyUnit;
+
+function RegisterConstant__Comm(H: Integer; compiler: TPaxCompiler): Integer;
+begin
+  if not Compiler.InScript('Comm') then begin result := 0; Exit; end;
+  result := compiler.RegisterConstant(H, 'Comm = ''\\'';');
+end;
+
+// function Deliver(C: Integer): Boolean;
+function RegisterFunction_Deliver(H: Integer; compiler: TPaxCompiler): Integer;
+begin
+  if not Compiler.InScript('Deliver') then begin result := 0; Exit; end;
+  result := compiler.RegisterRoutine(H, 'Deliver'
+    , _typeBOOLEAN // result type
+    , @ Deliver // address
+    );
+  compiler.RegisterParameter(result, 'C', _typeINTEGER, _parVAL);
+end;
+
+function RegisterVariable_LastCount(H: Integer; compiler: TPaxCompiler): Integer;
+var
+  T: Integer;
+begin
+  if not Compiler.InScript('LastCount') then begin result := 0; Exit; end;
+  T := _typeINTEGER;
+  result := compiler.RegisterVariable(H, 'LastCount', T, @LastCount);
+end;
+
+procedure Part1(result: Integer; compiler: TPaxCompiler);
+begin
+  RegisterConstant__Comm(result, compiler);
+  RegisterFunction_Deliver(result, compiler);
+  RegisterVariable_LastCount(result, compiler);
+end;
+
+function Register_MyUnit(compiler: TPaxCompiler): Integer;
+begin
+  if not compiler.InScript('MyUnit') then Exit;
+  result := compiler.RegisterNamespace(0, 'MyUnit');
+  compiler.RegisterUsingNamespace('System.Classes');
+  Part1(result, compiler);
+  compiler.UnregisterUsingNamespaces;
+end;
+
+end.
+
+
+
+

+ +As it was said above, all types are imported automatically via Delphi RTTI, +the unit contains import of global members only. It is necessary to add, +that call of Register_Common should be applied after paxCompiler ends +the parsing stage of compilation process. Therefore paxCompiler +already knows all identifiers which must be evaluated. +The call of Register_Common must be placed into body of +OnImportGlobalMembers event handler: + +

+
+
+
+PaxCompiler1.OnImportGlobalMembers := Handler.DoImportGlobalMembers;
+
+......................................
+
+procedure THandler.DoImportGlobalMembers(Sender: TPaxCompiler);
+begin
+  Register_Common(Sender);
+end;
+
+
+
+

+ + +

+

+ +Copyright © 2014 +VIRT Laboratory. All rights reserved. + + + + + diff --git a/help/importer.jpg b/help/importer.jpg new file mode 100644 index 0000000..6c1061c Binary files /dev/null and b/help/importer.jpg differ diff --git a/help/index.htm b/help/index.htm new file mode 100644 index 0000000..5602ab0 --- /dev/null +++ b/help/index.htm @@ -0,0 +1,32 @@ + + + + + + + + + +paxCompiler + + + + + + + + + + + + +Your browser do not show frames. + + + + diff --git a/help/js_cross.htm b/help/js_cross.htm new file mode 100644 index 0000000..d7b1e81 --- /dev/null +++ b/help/js_cross.htm @@ -0,0 +1,84 @@ + + + + + +

+JavaScript samples. Cross-language programming. +

+
+ + +
+
+using Forms, MyPascalUnit in "MyPascalUnit.pas";
+
+f = new TMyForm()
+try
+{
+  f.ShowModal()
+}
+finally
+{
+  f.Free()
+}
+
+
+ + +

+MyPascalUnit: +

+
+
+unit MyPascalUnit;
+interface
+uses
+  Controls, StdCtrls, Forms, Dialogs;
+type
+  TMyForm = class(TForm)
+    Button1: TButton;
+  private
+    procedure Button1Click(Sender: TObject);
+  public
+    constructor Create;
+  end;
+
+implementation
+
+constructor TMyForm.Create;
+begin
+  inherited Create(nil);
+  Caption := 'My form created in Pascal';
+  Button1 := TButton.Create(Self);
+  with Button1 do
+  begin
+    Parent := Self; 
+    Caption := 'Click Me';
+    Name := 'Button1';
+    Left := 10;
+    Top := 20;  
+    OnClick := Button1Click; 
+  end;
+end;
+
+procedure TMyForm.Button1Click(Sender: TObject);
+begin
+  ShowMessage('Hello!');
+end;
+
+end.
+
+
+ + + + +

+

+ +Copyright © 2006-2009 +VIRT Laboratory. All rights reserved. + + + diff --git a/help/js_sieve.htm b/help/js_sieve.htm new file mode 100644 index 0000000..9ec57de --- /dev/null +++ b/help/js_sieve.htm @@ -0,0 +1,57 @@ + + + + + +

+JavaScript samples. Sieve of Eratosthenes. +

+
+ + +
+
+println("Eratosthenes Sieve prime number calculation");
+ 
+size = 8190;
+sizepl = 8191;
+
+var flags = new Array(sizepl);
+
+var i, prime, k, count, iter;
+
+alert("10 iterations");
+starttime = new Date();
+for (iter = 1; iter <= 10; iter++)
+{   count = 0;
+    for (i = 0; i <= size; i++)
+	flags[i] = true;
+    for (i = 0; i <= size; i++)
+    {   if (flags[i])
+	{   prime = i + i + 3;
+	    k = i + prime;
+	    while (k <= size)
+	    {
+		flags[k] = false;
+		k += prime;
+	    }
+	    count += 1;
+	}
+    }
+}
+
+elapsedtime = new Date() - starttime;
+println(count + " primes");
+println("elapsed time = " + elapsedtime);
+
+
+ + +

+

+ +Copyright © 2006-2009 +VIRT Laboratory. All rights reserved. + + + diff --git a/help/lib_demo_access_script_vars.htm b/help/lib_demo_access_script_vars.htm new file mode 100644 index 0000000..e746c8f --- /dev/null +++ b/help/lib_demo_access_script_vars.htm @@ -0,0 +1,78 @@ + + + + + +

+paxCompiler for MS VC++. Access to script-defined variables. +

+
+ +
+
+#include "stdafx.h"
+#include "paxcompilerlib.h"
+
+int main(int argc, char* argv[])
+{
+        HMODULE h_lib = LoadPaxCompilerLib();
+        if (h_lib != 0)
+        {
+                DWORD hc = PaxCompiler_Create();
+                DWORD hl = PaxPascalLanguage_Create();
+                DWORD hp = PaxProgram_Create();
+
+                PaxCompiler_Reset(hc);
+                PaxCompiler_RegisterLanguage(hc, hl);
+
+                PaxCompiler_AddModule(hc, "1", "Pascal");
+                PaxCompiler_AddCode(hc, "1", "var x: Integer = 5;");
+                PaxCompiler_AddCode(hc, "1", "begin");
+                PaxCompiler_AddCode(hc, "1", " writeln('script:', x);");
+                PaxCompiler_AddCode(hc, "1", "end.");
+
+                if (PaxCompiler_Compile(hc, hp))
+                {
+			DWORD h_x = PaxCompiler_GetHandle(hc, 0, "x", true);
+
+			printf("the first run\n");
+                        PaxProgram_Run(hp);       
+
+			int * p = (int*) PaxProgram_GetAddress(hp, h_x);
+			printf("host: %d\n", *p); // show script-defined var
+			*p = 30;                  // change script-defind variable
+
+			printf("the second run\n");
+                        PaxProgram_Run(hp);      
+                }
+                else
+                {
+                        printf("there are errors:\n");
+                        for (int i = 0; i < PaxCompiler_GetErrorCount(hc); i++)
+                        {
+                                printf(PaxCompiler_GetErrorMessage(hc, i));
+                        }
+                }
+
+                PaxProgram_Destroy(hp);
+                PaxPascalLanguage_Destroy(hl);
+                PaxCompiler_Destroy(hc);
+        }
+        FreePaxCompilerLib(h_lib);
+
+        getchar();
+        return 0;
+}
+
+
+ + + +

+

+ +Copyright © 2006-2009 +VIRT Laboratory. All rights reserved. + + + diff --git a/help/lib_demo_call_routine.htm b/help/lib_demo_call_routine.htm new file mode 100644 index 0000000..dc527e0 --- /dev/null +++ b/help/lib_demo_call_routine.htm @@ -0,0 +1,86 @@ + + + + + +

+paxCompiler for MS VC++. Call a script-defined procedure. +

+
+ +
+
+#include "stdafx.h"
+#include "paxcompilerlib.h"
+
+long y = 5;
+
+int main(int argc, char* argv[])
+{
+        HMODULE h_lib = LoadPaxCompilerLib();
+        if (h_lib != 0)
+        {
+                DWORD hc = PaxCompiler_Create();
+                DWORD hl = PaxPascalLanguage_Create();
+                DWORD hp = PaxProgram_Create();
+
+                PaxCompiler_Reset(hc);
+                PaxCompiler_RegisterLanguage(hc, hl);
+
+		DWORD h_y = PaxCompiler_RegisterVariable(hc, 0, "Y", PaxTypeLONG);
+
+                PaxCompiler_AddModule(hc, "1", "Pascal");
+                PaxCompiler_AddCode(hc, "1", "procedure ScriptProc(X: Integer);");
+                PaxCompiler_AddCode(hc, "1", "begin");
+                PaxCompiler_AddCode(hc, "1", "  Y := Y + X;");
+                PaxCompiler_AddCode(hc, "1", "end;");
+                PaxCompiler_AddCode(hc, "1", "begin");
+                PaxCompiler_AddCode(hc, "1", "end.");
+
+                if (PaxCompiler_Compile(hc, hp))
+                {
+
+	  	        DWORD h_ScriptProc = PaxCompiler_GetHandle(hc, 0, "ScriptProc", true);
+			void * p = PaxProgram_GetAddress(hp, h_ScriptProc); // get address of script-defined procedure
+
+    			PaxProgram_SetAddress(hp, h_y, &y);
+
+			__asm
+			{
+				push 10 // push parameter
+				call p // call script-defined procedure
+			}
+
+			printf("y = %d", y);
+
+                }
+                else
+                {
+                        printf("there are errors:\n");
+                        for (int i = 0; i < PaxCompiler_GetErrorCount(hc); i++)
+                        {
+                                printf(PaxCompiler_GetErrorMessage(hc, i));
+                        }
+                }
+
+                PaxProgram_Destroy(hp);
+                PaxPascalLanguage_Destroy(hl);
+                PaxCompiler_Destroy(hc);
+        }
+        FreePaxCompilerLib(h_lib);
+
+        getchar();
+        return 0;
+}
+
+
+ + +

+

+ +Copyright © 2006-2009 +VIRT Laboratory. All rights reserved. + + + diff --git a/help/lib_demo_hello_app.htm b/help/lib_demo_hello_app.htm new file mode 100644 index 0000000..0ba87e9 --- /dev/null +++ b/help/lib_demo_hello_app.htm @@ -0,0 +1,66 @@ + + + + + +

+paxCompiler for MS VC++. "Hello" application. +

+
+ +
+
+#include "stdafx.h"
+#include "paxcompilerlib.h"
+
+int main(int argc, char* argv[])
+{
+        HMODULE h_lib = LoadPaxCompilerLib();
+        if (h_lib != 0)
+        {
+                DWORD hc = PaxCompiler_Create();
+                DWORD hl = PaxPascalLanguage_Create();
+                DWORD hp = PaxProgram_Create();
+
+                PaxCompiler_Reset(hc);
+                PaxCompiler_RegisterLanguage(hc, hl);
+
+                PaxCompiler_AddModule(hc, "1", "Pascal");
+                PaxCompiler_AddCode(hc, "1", "begin");
+                PaxCompiler_AddCode(hc, "1", "  writeln('Hello');");
+                PaxCompiler_AddCode(hc, "1", "end.");
+
+                if (PaxCompiler_Compile(hc, hp))
+                {
+                        PaxProgram_Run(hp);
+                }
+                else
+                {
+                        printf("there are errors:\n");
+                        for (int i = 0; i < PaxCompiler_GetErrorCount(hc); i++)
+                        {
+                                printf(PaxCompiler_GetErrorMessage(hc, i));
+                        }
+                }
+
+                PaxProgram_Destroy(hp);
+                PaxPascalLanguage_Destroy(hl);
+                PaxCompiler_Destroy(hc);
+        }
+        FreePaxCompilerLib(h_lib);
+
+        getchar();
+        return 0;
+}
+
+
+ + +

+

+ +Copyright © 2006-2009 +VIRT Laboratory. All rights reserved. + + + diff --git a/help/lib_demo_load_compiled.htm b/help/lib_demo_load_compiled.htm new file mode 100644 index 0000000..f689e4e --- /dev/null +++ b/help/lib_demo_load_compiled.htm @@ -0,0 +1,93 @@ + + + + + +

+paxCompiler for MS VC++. Loading compiled scripts. +

+
+ +
+
+#include "stdafx.h"
+#include "paxcompilerlib.h"
+
+DWORD h_show_message;
+
+void show_message(char * s)
+{
+    printf(s);
+}
+
+void create_compiled_script()
+{
+    DWORD hc = PaxCompiler_Create();
+    DWORD hl = PaxPascalLanguage_Create();
+    DWORD hp = PaxProgram_Create();
+
+    PaxCompiler_Reset(hc);
+    PaxCompiler_RegisterLanguage(hc, hl);
+
+    h_show_message = PaxCompiler_RegisterRoutineEx(hc, 0, "ShowMessage", PaxTypeVOID, ccCDECL);
+    PaxCompiler_RegisterParameter(hc, h_show_message, PaxTypePCHAR, false);
+
+    PaxCompiler_AddModule(hc, "1", "Pascal");
+    PaxCompiler_AddCode(hc, "1", "begin");
+    PaxCompiler_AddCode(hc, "1", "  ShowMessage('Hello');");
+    PaxCompiler_AddCode(hc, "1", "end.");
+
+    if (PaxCompiler_Compile(hc, hp))
+    {
+	PaxProgram_SaveToFile(hp, "1.bin");
+	printf("Compiled script has been created!\n");
+    }
+    else
+    {
+        printf("there are errors:\n");
+        for (int i = 0; i < PaxCompiler_GetErrorCount(hc); i++)
+        {
+		printf(PaxCompiler_GetErrorMessage(hc, i));
+        }
+    }
+
+    PaxProgram_Destroy(hp);
+    PaxPascalLanguage_Destroy(hl);
+    PaxCompiler_Destroy(hc);
+}
+
+void load_compiled_script()
+{
+    DWORD hp = PaxProgram_Create();
+    PaxProgram_LoadFromFile(hp, "1.bin");
+    PaxProgram_SetAddress(hp, h_show_message, &show_message);
+    PaxProgram_Run(hp);
+    PaxProgram_Destroy(hp);
+}
+
+int main(int argc, char* argv[])
+{
+        HMODULE h_lib = LoadPaxCompilerLib();
+        if (h_lib != 0)
+        {
+			create_compiled_script();
+			printf("Load and run compiled script:\n");
+			load_compiled_script();
+        }
+        FreePaxCompilerLib(h_lib);
+
+        getchar();
+        return 0;
+}
+
+
+ + +

+

+ +Copyright © 2006-2009 +VIRT Laboratory. All rights reserved. + + + diff --git a/help/lib_demo_register_host_vars.htm b/help/lib_demo_register_host_vars.htm new file mode 100644 index 0000000..e544aee --- /dev/null +++ b/help/lib_demo_register_host_vars.htm @@ -0,0 +1,89 @@ + + + + + +

+paxCompiler MS VC++. Register host-defined types and variables. +

+
+ +
+
+#include "stdafx.h"
+#include "paxcompilerlib.h"
+
+struct TMyPoint
+{
+  long  x;
+  long  y;
+};
+
+int main(int argc, char* argv[])
+{
+        HMODULE h_lib = LoadPaxCompilerLib();
+        if (h_lib != 0)
+        {
+
+		TMyPoint MyPoint;
+		MyPoint.x = 60;
+		MyPoint.y = 23;
+
+                DWORD hc = PaxCompiler_Create();
+                DWORD hl = PaxPascalLanguage_Create();
+                DWORD hp = PaxProgram_Create();
+
+                PaxCompiler_Reset(hc);
+                PaxCompiler_RegisterLanguage(hc, hl);
+
+		// register host-defined type
+		DWORD H_TMyPoint = PaxCompiler_RegisterRecordType(hc, 0, "TMyPoint");
+		PaxCompiler_RegisterRecordTypeField(hc, H_TMyPoint, "X", PaxTypeLONG);
+		PaxCompiler_RegisterRecordTypeField(hc, H_TMyPoint, "Y", PaxTypeLONG);
+
+		// register host-defined variable
+		DWORD H_MyPoint = PaxCompiler_RegisterVariable(hc, 0, "MyPoint", H_TMyPoint);
+
+                PaxCompiler_AddModule(hc, "1", "Pascal");
+                PaxCompiler_AddCode(hc, "1", "begin");
+                PaxCompiler_AddCode(hc, "1", "  MyPoint.Y := 8;");
+                PaxCompiler_AddCode(hc, "1", "end.");
+
+                if (PaxCompiler_Compile(hc, hp))
+                {
+			// set address of the variable
+			PaxProgram_SetAddress(hp, H_MyPoint, &MyPoint);
+                        PaxProgram_Run(hp);
+			printf("MyPoint.y = %d\n", MyPoint.y);
+                }
+                else
+                {
+                        printf("there are errors:\n");
+                        for (int i = 0; i < PaxCompiler_GetErrorCount(hc); i++)
+                        {
+                                printf(PaxCompiler_GetErrorMessage(hc, i));
+                        }
+                }
+
+                PaxProgram_Destroy(hp);
+                PaxPascalLanguage_Destroy(hl);
+                PaxCompiler_Destroy(hc);
+        }
+        FreePaxCompilerLib(h_lib);
+
+        getchar();
+        return 0;
+}
+
+
+ + + +

+

+ +Copyright © 2006-2009 +VIRT Laboratory. All rights reserved. + + + diff --git a/help/lib_routines.htm b/help/lib_routines.htm new file mode 100644 index 0000000..c929124 --- /dev/null +++ b/help/lib_routines.htm @@ -0,0 +1,1748 @@ + + + + + +

+Routines exported by paxcompilerlib.dll +

+
+ +

LoadPaxCompilerLib

 + +
+Loads paxcompilerlib.dll +
+HMODULE LoadPaxCompilerLib()
+
+

+

+Example +

+
+#include "stdafx.h"
+#include "paxcompilerlib.h"
+
+int main(int argc, char* argv[])
+{
+        HMODULE h_lib = LoadPaxCompilerLib();
+        if (h_lib != 0)
+        {
+                DWORD hc = PaxCompiler_Create();
+                DWORD hl = PaxPascalLanguage_Create();
+                DWORD hp = PaxProgram_Create();
+
+                PaxCompiler_Reset(hc);
+                PaxCompiler_RegisterLanguage(hc, hl);
+
+                PaxCompiler_AddModule(hc, "1", "Pascal");
+                PaxCompiler_AddCode(hc, "1", "begin");
+                PaxCompiler_AddCode(hc, "1", "  writeln('Hello');");
+                PaxCompiler_AddCode(hc, "1", "end.");
+
+                if (PaxCompiler_Compile(hc, hp))
+                {
+                        PaxProgram_Run(hp);
+                }
+                else
+                {
+                        printf("there are errors:\n");
+                        for (int i = 0; i < PaxCompiler_GetErrorCount(hc); i++)
+                        {
+                                printf(PaxCompiler_GetErrorMessage(hc, i));
+                        }
+                }
+
+                PaxProgram_Destroy(hp);
+                PaxPascalLanguage_Destroy(hl);
+                PaxCompiler_Destroy(hc);
+        }
+        FreePaxCompilerLib(h_lib);
+
+        getchar();
+        return 0;
+}
+
+

+
+

FreePaxCompilerLib

 + +
+Unloads paxcompilerlib.dll +
+long FreePaxCompilerLib(HMODULE h_lib);
+
+

+Arguments +

+
+h_lib +
+Handle of library. +
+
+
+

PaxCompiler_Create

 + +
+paxCompiler constructor. Returns handle of paxCompiler object. +
+DWORD __stdcall PaxCompiler_Create();
+
+
+

PaxCompiler_Destroy

 + +
+paxCompiler destructor. Destroyes paxCompiler object. +
+void __stdcall PaxCompiler_Destroy(DWORD HCompiler);
+
+
+

PaxCompiler_Reset

 + +
+Removes all source code modules and registered items from compiler. +
+void __stdcall PaxCompiler_Reset(DWORD HCompiler);
+
+
+

PaxCompiler_AddModule

 + +
+Adds source code module to compiler. +
+void __stdcall PaxCompiler_AddModule(DWORD HCompiler, char * Name, char * LanguageName);
+
+

+Arguments +

+
+HCompiler +
+Handle of compiler. +
+
+
+Name +
+Name of module. +
+
+
+LanguageName +
+Name of programming language supported by compiler. +
+
+

+

+Example +

+
+DWORD hc = PaxCompiler_Create();
+PaxCompiler_AddModule(hc, "1", "Pascal");
+
+

+
+

PaxCompiler_AddCode

 + +
+Adds source code to source code module. +
+void __stdcall PaxCompiler_AddCode(DWORD HCompiler, char * ModuleName, char * Text);
+
+

+Arguments +

+
+HCompiler +
+Handle of compiler. +
+
+
+ModuleName +
+Name of module. +
+
+
+Text +
+Source code added to module. +
+
+

+

+Example +

+
+DWORD hc = PaxCompiler_Create();
+PaxCompiler_AddModule(hc, "1", "Pascal");
+PaxCompiler_AddCode(hc, "1", "begin");
+PaxCompiler_AddCode(hc, "1", "  MyPoint.Y := 8;");
+PaxCompiler_AddCode(hc, "1", "end.");
+
+

+
+

PaxCompiler_AddCodeFromFile

 + +
+Adds source code from text file to module. +
+void __stdcall PaxCompiler_AddCodeFromFile(DWORD HCompiler, char * ModuleName, char * FileName);
+
+

+Arguments +

+
+HCompiler +
+Handle of compiler. +
+
+
+ModuleName +
+Name of module. +
+
+
+FileName +
+Name of text file. +
+
+

+

+Example +

+
+DWORD hc = PaxCompiler_Create();
+PaxCompiler_AddModule(hc, "1", "Pascal");
+PaxCompiler_AddCodeFromFile(hc, "1", "MyFile.pas");
+
+

+
+

PaxCompiler_RegisterLanguage

 + +
+Registeres paxCompiler language object for compiler. +
+void __stdcall PaxCompiler_RegisterLanguage(DWORD HCompiler, DWORD HLanguage);
+
+

+Arguments +

+
+HCompiler +
+Handle of compiler. +
+
+
+HLanguage +
+Handle of paxCompiler language. +
+
+

+

+Example +

+
+DWORD hc = PaxCompiler_Create();
+DWORD hl = PaxPascalLanguage_Create();
+PaxCompiler_RegisterLanguage(hc, hl);
+
+

+
+

PaxCompiler_RegisterNamespace

 + +
+Registeres host-defined namespace for compiler. Returns id of namespace. +
+DWORD __stdcall PaxCompiler_RegisterNamespace(DWORD HCompiler, DWORD LevelId, char * NamespaceName);
+
+

+Arguments +

+
+HCompiler +
+Handle of compiler. +
+
+
+LevelId +
+Id of owner namespace. If LevelId = 0, the owner is root namespace. +
+
+
+

PaxCompiler_RegisterRecordType

 + +
+Registeres a record type (structure type) for compiler. Returns id of type. +
+DWORD __stdcall PaxCompiler_RegisterRecordType(DWORD HCompiler, DWORD LevelId, char * TypeName);
+
+

+Arguments +

+
+HCompiler +
+Handle of compiler. +
+
+
+LevelId +
+Id of owner namespace or owner record type. +
+
+
+TypeName +
+Name of type. +
+
+

+

+Example +

+
+struct TMyPoint
+{
+  long  x;
+  long  y;
+};
+.....................................
+
+DWORD hc = PaxCompiler_Create();
+DWORD hl = PaxPascalLanguage_Create();
+PaxCompiler_RegisterLanguage(hc, hl);
+
+// register host-defined type
+DWORD H_TMyPoint = PaxCompiler_RegisterRecordType(hc, 0, "TMyPoint");
+PaxCompiler_RegisterRecordTypeField(hc, H_TMyPoint, "X", PaxTypeLONG);
+PaxCompiler_RegisterRecordTypeField(hc, H_TMyPoint, "Y", PaxTypeLONG);
+
+

+
+

PaxCompiler_RegisterRecordTypeField

 + +
+Registeres field of record (structure) type. Returns id of type. +
+DWORD __stdcall PaxCompiler_RegisterRecordTypeField(DWORD HCompiler, DWORD RecordTypeId, char * FieldName, DWORD FieldTypeID);
+
+

+Arguments +

+
+HCompiler +
+Handle of compiler. +
+
+
+RecordTypeId +
+Id of record type. +
+
+
+FieldName +
+Name of field. +
+
+
+FieldTypeID +
+Id of type of field. +
+
+

+

+Example +

+
+struct TMyPoint
+{
+  long  x;
+  long  y;
+};
+.....................................
+
+DWORD hc = PaxCompiler_Create();
+DWORD hl = PaxPascalLanguage_Create();
+PaxCompiler_RegisterLanguage(hc, hl);
+
+// register host-defined type
+DWORD H_TMyPoint = PaxCompiler_RegisterRecordType(hc, 0, "TMyPoint");
+PaxCompiler_RegisterRecordTypeField(hc, H_TMyPoint, "X", PaxTypeLONG);
+PaxCompiler_RegisterRecordTypeField(hc, H_TMyPoint, "Y", PaxTypeLONG);
+
+

+
+

PaxCompiler_RegisterSubrangeType

 + +
+Registeres a subrange type for compiler. Returns id of type. +
+DWORD __stdcall PaxCompiler_RegisterSubrangeType(DWORD HCompiler, DWORD LevelId, char * TypeName, DWORD TypeBaseId, long B1, long B2);
+
+

+Arguments +

+
+HCompiler +
+Handle of compiler. +
+
+
+LevelId +
+Id of namespace or owner record type. +
+
+
+TypeName +
+Name of type. +
+
+
+B1 +
+Low bound of the subrange type. +
+
+
+B2 +
+High bound of the subrange type. +
+
+

+

+Example +

+
+DWORD h_subrange = PaxCompiler_RegisterSubrangeType(hc, 0, "Subrange", PaxTypeLONG, 0, 9);
+
+

+
+

PaxCompiler_RegisterArrayType

 + +
+Registeres an array type for compiler. Returns id of type. +
+DWORD __stdcall PaxCompiler_RegisterArrayType(DWORD HCompiler, DWORD LevelId, char * TypeName, DWORD RangeTypeId, DWORD ElemTypeId);
+
+

+Arguments +

+
+HCompiler +
+Handle of compiler. +
+
+
+LevelId +
+Id of namespace or owner record type. +
+
+
+TypeName +
+Name of type. +
+
+
+RangeTypeId +
+Id of subrange type. +
+
+
+ElemTypeId +
+Id of array element type. +
+
+

+

+Example +

+
+typedef double MyArray[10];
+......................................................
+
+DWORD h_subrange = PaxCompiler_RegisterSubrangeType(hc, 0, "Subrange", PaxTypeLONG, 0, 9);
+DWORD h_arr = PaxCompiler_RegisterArrayType) (hc, 0, "MyArray", h_subrange, PaxTypeDOUBLE);
+
+

+
+

PaxCompiler_RegisterPointerType

 + +
+Registeres a pointer type for compiler. Returns id of type. +
+DWORD __stdcall PaxCompiler_RegisterPointerType(DWORD HCompiler,
+DWORD LevelId, char * TypeName, DWORD OriginTypeId);
+
+

+Arguments +

+
+HCompiler +
+Handler of compiler. +
+
+
+LevelId +
+Id of namespace or owner record type. +
+
+
+TypeName +
+Name of type. +
+
+
+OriginTypeId +
+Id of origin type. +
+
+

+

+Example +

+
+struct TMyPoint
+{
+  long  x;
+  long  y;
+};
+typedef struct TMyPoint * PMyPoint;
+.....................................
+
+DWORD hc = PaxCompiler_Create();
+DWORD hl = PaxPascalLanguage_Create();
+PaxCompiler_RegisterLanguage(hc, hl);
+
+// register host-defined type
+DWORD H_TMyPoint = PaxCompiler_RegisterRecordType(hc, 0, "TMyPoint");
+PaxCompiler_RegisterRecordTypeField(hc, H_TMyPoint, "X", PaxTypeLONG);
+PaxCompiler_RegisterRecordTypeField(hc, H_TMyPoint, "Y", PaxTypeLONG);
+DWORD P_TMyPoint = PaxCompiler_RegisterPointerType(hc, 0, "PMyPoint", H_TMyPoint);
+
+

+
+

PaxCompiler_RegisterSetType

 + +
+Registeres a set type for compiler. Returns id of type. +
+DWORD __stdcall PaxCompiler_RegisterSetType(DWORD HCompiler, DWORD LevelId, char * TypeName, DWORD OriginTypeId);
+
+

+Arguments +

+
+HCompiler +
+Handle of compiler. +
+
+
+LevelId +
+Id of namespace or owner record type. +
+
+
+TypeName +
+Name of type. +
+
+
+OriginTypeId +
+Id of origin type. +
+
+

+

+Example +

+
+DWORD h_myset = PaxCompiler_RegisterSetType(hc, 0, "MySet", PaxTypeCHAR);
+
+

+
+

PaxCompiler_RegisterProceduralType

 + +
+Registeres a set type for compiler. Returns id of type. +
+DWORD __stdcall PaxCompiler_RegisterProceduralType (DWORD HCompiler, DWORD LevelId, char * TypeName, DWORD SubId);
+
+

+Arguments +

+
+HCompiler +
+Handle of compiler. +
+
+
+LevelId +
+Id of namespace or owner record type. +
+
+
+TypeName +
+Name of type. +
+
+
+SubId +
+Id of registered subroutine. +
+
+
+

PaxCompiler_RegisterVariable

 + +
+Registeres a host-defined variable for compiler. Returns id of the variable. +
+DWORD __stdcall PaxCompiler_RegisterVariable(DWORD HCompiler, DWORD LevelId, char * Name, DWORD TypeId);
+
+

+Arguments +

+
+HCompiler +
+Handle of compiler. +
+
+
+LevelId +
+Id of namespace or owner record type. +
+
+
+Name +
+Name of variable. +
+
+
+TypeId +
+Id of type of the variable. +
+
+

+

+Example +

+
+#include "stdafx.h"
+#include "paxcompilerlib.h"
+
+struct TMyPoint
+{
+  long  x;
+  long  y;
+};
+
+int main(int argc, char* argv[])
+{
+        HMODULE h_lib = LoadPaxCompilerLib();
+        if (h_lib != 0)
+        {
+		TMyPoint MyPoint;
+
+		MyPoint.x = 60;
+		MyPoint.y = 23;
+
+                DWORD hc = PaxCompiler_Create();
+                DWORD hl = PaxPascalLanguage_Create();
+                DWORD hp = PaxProgram_Create();
+
+                PaxCompiler_Reset(hc);
+                PaxCompiler_RegisterLanguage(hc, hl);
+
+		// register host-defined type
+		DWORD H_TMyPoint = PaxCompiler_RegisterRecordType(hc, 0, "TMyPoint");
+		PaxCompiler_RegisterRecordTypeField(hc, H_TMyPoint, "X", PaxTypeLONG);
+		PaxCompiler_RegisterRecordTypeField(hc, H_TMyPoint, "Y", PaxTypeLONG);
+
+		// register host-defined variable
+		DWORD H_MyPoint = PaxCompiler_RegisterVariable(hc, 0, "MyPoint", H_TMyPoint);
+
+                PaxCompiler_AddModule(hc, "1", "Pascal");
+                PaxCompiler_AddCode(hc, "1", "begin");
+                PaxCompiler_AddCode(hc, "1", "  MyPoint.Y := 8;");
+                PaxCompiler_AddCode(hc, "1", "end.");
+
+                if (PaxCompiler_Compile(hc, hp))
+                {
+         		// set address of the variable
+			PaxProgram_SetAddress(hp, H_MyPoint, &MyPoint);
+                        PaxProgram_Run(hp);
+			printf("MyPoint.y = %d\n", MyPoint.y);
+                }
+                else
+                {
+                        printf("there are errors:\n");
+                        for (int i = 0; i < PaxCompiler_GetErrorCount(hc); i++)
+                        {
+                                printf(PaxCompiler_GetErrorMessage(hc, i));
+                        }
+                }
+
+                PaxProgram_Destroy(hp);
+                PaxPascalLanguage_Destroy(hl);
+                PaxCompiler_Destroy(hc);
+        }
+        FreePaxCompilerLib(h_lib);
+
+        getchar();
+        return 0;
+}
+
+

+
+

PaxCompiler_RegisterRoutine

 + +
+Registeres a host-defined routine for compiler. Returns id of routine. +
+DWORD __stdcall PaxCompiler_RegisterRoutine(DWORD HCompiler, WORD LevelId, char * Name, DWORD ResultTypeID);
+
+

+Arguments +

+
+HCompiler +
+Handle of compiler. +
+
+
+LevelId +
+Id of namespace. +
+
+
+Name +
+Name of routine. +
+
+
+ResultTypeId +
+Id of result type. +
+
+

+The registered routine must have __stdcall calling convention. Use PaxCompiler_RegisterRoutineEx to register routine with __cdecl calling convention. +

+Example +

+
+void __stdcall show_message(char * s)
+{
+	printf(s);
+}
+............................................
+DWORD hc = PaxCompiler_Create();
+DWORD hl = PaxPascalLanguage_Create();
+DWORD hp = PaxProgram_Create();
+
+PaxCompiler_Reset(hc);
+PaxCompiler_RegisterLanguage(hc, hl);
+
+DWORD h_show_message = PaxCompiler_RegisterRoutine(hc, 0, "ShowMessage", PaxTypeVOID);
+PaxCompiler_RegisterParameter(hc, h_show_message, PaxTypePCHAR, false);
+
+PaxCompiler_AddModule(hc, "1", "Pascal");
+PaxCompiler_AddCode(hc, "1", "begin");
+PaxCompiler_AddCode(hc, "1", "  ShowMessage('Hello');");
+PaxCompiler_AddCode(hc, "1", "end.");
+
+if (PaxCompiler_Compile(hc, hp))
+{
+      PaxProgram_SetAddress(hp, h_show_message, & show_message);
+      PaxProgram_Run(hp);
+}
+
+

+
+

PaxCompiler_RegisterRoutineEx

 + +
+Registeres a host-defined routine for compiler. +
+DWORD __stdcall PaxCompiler_RegisterRoutineEx(DWORD HCompiler, DWORD LevelId, char * Name, DWORD ResultTypeID, long CallConvention);
+
+

+Arguments +

+
+HCompiler +
+Handle of compiler. +
+
+
+LevelId +
+Id of namespace. +
+
+
+Name +
+Name of routine. +
+
+
+ResultTypeId +
+Id of result type. +
+
+
+CallingConvention +
+CallingConvention: +ccSTDCALL = 1; +ccCDECL = 3; +
+
+

+

+Example +

+
+void show_message(char * s)
+{
+	printf(s);
+}
+............................................
+DWORD hc = PaxCompiler_Create();
+DWORD hl = PaxPascalLanguage_Create();
+DWORD hp = PaxProgram_Create();
+
+PaxCompiler_Reset(hc);
+PaxCompiler_RegisterLanguage(hc, hl);
+
+DWORD h_show_message = PaxCompiler_RegisterRoutineEx(hc, 0, "ShowMessage", PaxTypeVOID, ccCDECL);
+PaxCompiler_RegisterParameter(hc, h_show_message, PaxTypePCHAR, false);
+
+PaxCompiler_AddModule(hc, "1", "Pascal");
+PaxCompiler_AddCode(hc, "1", "begin");
+PaxCompiler_AddCode(hc, "1", "  ShowMessage('Hello');");
+PaxCompiler_AddCode(hc, "1", "end.");
+
+if (PaxCompiler_Compile(hc, hp))
+{
+      PaxProgram_SetAddress(hp, h_show_message, & show_message);
+      PaxProgram_Run(hp);
+}
+
+

+
+

PaxCompiler_RegisterParameter

 + +
+Registeres parameter for compiler. +
+DWORD __stdcall PaxCompiler_RegisterParameter(DWORD HCompiler,
+DWORD HSub, DWORD ParamTypeID, bool ByRef);
+
+

+Arguments +

+
+HCompiler +
+Handle of compiler. +
+
+
+HSub +
+Id of routine. +
+
+
+ParamTypeId +
+Id of type of the parameter. +
+
+
+ByRef +
+If 'true', this is a 'byref' parameter, otherwise, this is a 'byval' parameter. +
+
+
+

PaxCompiler_Compile

 + +
+Creates compiled program. +
+DWORD __stdcall PaxCompiler_Compile(DWORD HCompiler, DWORD HProgram);
+
+

+Arguments +

+
+HCompiler +
+Handle of compiler. +
+
+
+HProgram +
+Handle of compiled program. +
+
+

+

+Example +

+
+DWORD hc = PaxCompiler_Create();
+DWORD hl = PaxPascalLanguage_Create();
+DWORD hp = PaxProgram_Create();
+
+PaxCompiler_Reset(hc);
+PaxCompiler_RegisterLanguage(hc, hl);
+
+PaxCompiler_AddModule(hc, "1", "Pascal");
+PaxCompiler_AddCode(hc, "1", "begin");
+PaxCompiler_AddCode(hc, "1", " writeln('Hello');");
+PaxCompiler_AddCode(hc, "1", "end.");
+
+if (PaxCompiler_Compile(hc, hp))
+{
+     PaxProgram_Run(hp);
+}
+
+

+
+

PaxCompiler_GetErrorCount

 + +
+Returns number of compile-time error count. +
+DWORD __stdcall PaxCompiler_GetErrorCount(DWORD HCompiler);
+
+

+Arguments +

+
+HCompiler +
+Handle of compiler. +
+
+

+

+Example +

+
+if (PaxCompiler_Compile(hc, hp))
+{
+     PaxProgram_Run(hp);
+}
+else
+{
+     printf("there are errors:\n");
+     for (int i = 0; i < PaxCompiler_GetErrorCount(hc); i++)
+     {
+          printf(PaxCompiler_GetErrorMessage(hc, i));
+     }
+}
+
+

+
+

PaxCompiler_GetErrorMessage

 + +
+Returns error message of i-th compile-time error in the error list. +
+char * __stdcall PaxCompiler_GetErrorMessage(DWORD HCompiler, long i);
+
+

+Arguments +

+
+HCompiler +
+Handle of compiler. +
+
+
+i +
+Index of error. +
+
+

+

+Example +

+
+if (PaxCompiler_Compile(hc, hp))
+{
+     PaxProgram_Run(hp);
+}
+else
+{
+     printf("there are errors:\n");
+     for (int i = 0; i < PaxCompiler_GetErrorCount(hc); i++)
+     {
+          printf(PaxCompiler_GetErrorMessage(hc, i));
+     }
+}
+
+

+
+

PaxCompiler_GetErrorModuleName

 + +
+Returns name of module which contains i-th error in the error list. +
+char * __stdcall PaxCompiler_GetErrorModuleName (DWORD HCompiler, long i);
+
+

+Arguments +

+
+HCompiler +
+Handle of compiler. +
+
+
+i +
+Index of error. +
+
+

+

+Example +

+
+if (PaxCompiler_Compile(hc, hp))
+{
+     PaxProgram_Run(hp);
+}
+else
+{
+     printf("there are errors:\n");
+     for (int i = 0; i < PaxCompiler_GetErrorCount(hc); i++)
+     {
+          printf("Message: %s\n", PaxCompiler_GetErrorMessage(hc, i));
+          printf("Module: %s\n", PaxCompiler_GetErrorModuleName(hc, i));
+     }
+}
+
+

+
+

PaxCompiler_GetErrorLine

 + +
+Returns line of source code module which contains i-th error in the error list. +
+char * __stdcall PaxCompiler_GetErrorLine(DWORD HCompiler, long i);
+
+

+Arguments +

+
+HCompiler +
+Handle of compiler. +
+
+
+i +
+Index of error. +
+
+

+

+Example +

+
+if (PaxCompiler_Compile(hc, hp))
+{
+     PaxProgram_Run(hp);
+}
+else
+{
+     printf("there are errors:\n");
+     for (int i = 0; i < PaxCompiler_GetErrorCount(hc); i++)
+     {
+          printf("Message: %s\n", PaxCompiler_GetErrorMessage(hc, i));
+          printf("Module: %s\n", PaxCompiler_GetErrorModuleName(hc, i));
+          printf("Line: %s\n", PaxCompiler_GetErrorLine(hc, i));
+     }
+}
+
+

+
+

PaxCompiler_GetErrorLineNumber

 + +
+Returns line number of source code module which contains i-th error in the error list. +
+DWORD __stdcall PaxCompiler_GetErrorLineNumber(DWORD HCompiler, long i);
+
+

+Arguments +

+
+HCompiler +
+Handle of compiler. +
+
+
+i +
+Index of error. +
+
+

+

+Example +

+
+if (PaxCompiler_Compile(hc, hp))
+{
+     PaxProgram_Run(hp);
+}
+else
+{
+     printf("there are errors:\n");
+     for (int i = 0; i < PaxCompiler_GetErrorCount(hc); i++)
+     {
+          printf("Message: %s\n", PaxCompiler_GetErrorMessage(hc, i));
+          printf("Module: %s\n", PaxCompiler_GetErrorModuleName(hc, i));
+          printf("Line: %s\n", PaxCompiler_GetErrorLine(hc, i));
+          printf("Line number: %d\n", PaxCompiler_GetErrorLineNumber(hc, i));
+     }
+}
+
+

+
+

PaxCompiler_GetHandle

 + +
+Returnd id of script-defined routine or variable. +
+DWORD __stdcall PaxCompiler_GetHandle(DWORD HCompiler, DWORD LevelId, char * Name, DWORD Upcase);
+
+

+Arguments +

+
+HCompiler +
+Handle of compiler. +
+
+
+Name +
+Name of variable or routine. +
+
+
+Upcase +
+If 'false', the search of id will case sensitive. +
+
+

+

+Example +

+
+#include "stdafx.h"
+#include "paxcompilerlib.h"
+
+int main(int argc, char* argv[])
+{
+        HMODULE h_lib = LoadPaxCompilerLib();
+        if (h_lib != 0)
+        {
+                DWORD hc = PaxCompiler_Create();
+                DWORD hl = PaxPascalLanguage_Create();
+                DWORD hp = PaxProgram_Create();
+
+                PaxCompiler_Reset(hc);
+                PaxCompiler_RegisterLanguage(hc, hl);
+
+                PaxCompiler_AddModule(hc, "1", "Pascal");
+                PaxCompiler_AddCode(hc, "1", "var x: Integer = 5;");
+                PaxCompiler_AddCode(hc, "1", "begin");
+                PaxCompiler_AddCode(hc, "1", " writeln('script:', x);");
+                PaxCompiler_AddCode(hc, "1", "end.");
+
+                if (PaxCompiler_Compile(hc, hp))
+                {
+      		        DWORD h_x = PaxCompiler_GetHandle(hc, 0, "x", true);
+
+			printf("the first run\n");
+                        PaxProgram_Run(hp);       
+
+         		int * p = (int*) PaxProgram_GetAddress(hp, h_x);
+			printf("host: %d\n", *p); // show script-defined var
+         		*p = 30;                  // change script-defind variable
+
+			printf("the second run\n");
+                        PaxProgram_Run(hp);      
+                }
+                else
+                {
+                        printf("there are errors:\n");
+                        for (int i = 0; i < PaxCompiler_GetErrorCount(hc); i++)
+                        {
+                                printf(PaxCompiler_GetErrorMessage(hc, i));
+                        }
+                }
+
+                PaxProgram_Destroy(hp);
+                PaxPascalLanguage_Destroy(hl);
+                PaxCompiler_Destroy(hc);
+        }
+        FreePaxCompilerLib(h_lib);
+
+        getchar();
+        return 0;
+}
+
+

+
+

PaxProgram_Create

 + +
+Constructor of compiled program object. Returns handle of the compiled program. +
+DWORD __stdcall PaxProgram_Create();
+
+
+

PaxProgram_Destroy

 + +
+Destructor of compiled program. +
+void __stdcall PaxProgram_Destroy(DWORD HProgram);
+
+

+Arguments +

+
+HProgram +
+Handle of compiled program. +
+
+
+

PaxProgram_Run

 + +
+Executes compiled program. +
+void __stdcall PaxProgram_Run(DWORD HProgram);
+
+

+Arguments +

+
+HProgram +
+Handle of compiled program. +
+
+

+

+Example +

+
+DWORD hp = PaxProgram_Create();
+PaxProgram_LoadFromFile(hp, "1.bin");
+PaxProgram_Run(hp);
+PaxProgram_Destroy(hp);
+
+

+
+

PaxProgram_SaveToFile

 + +
+Saves compiled program to file. +
+void __stdcall PaxProgram_SaveToFile(DWORD HProgram, char * Path);
+
+

+Arguments +

+
+HProgram +
+Handle of compiled program. +
+
+
+Path +
+File name. +
+
+

+

+Example +

+
+DWORD hc = PaxCompiler_Create();
+DWORD hl = PaxPascalLanguage_Create();
+DWORD hp = PaxProgram_Create();
+
+PaxCompiler_Reset(hc);
+PaxCompiler_RegisterLanguage(hc, hl);
+
+h_show_message = PaxCompiler_RegisterRoutineEx(hc, 0, "ShowMessage", PaxTypeVOID, ccCDECL);
+PaxCompiler_RegisterParameter(hc, h_show_message, PaxTypePCHAR, false);
+
+PaxCompiler_AddModule(hc, "1", "Pascal");
+PaxCompiler_AddCode(hc, "1", "begin");
+PaxCompiler_AddCode(hc, "1", "  ShowMessage('Hello');");
+PaxCompiler_AddCode(hc, "1", "end.");
+
+if (PaxCompiler_Compile(hc, hp))
+{
+     PaxProgram_SaveToFile(hp, "1.bin");
+     printf("Compiled script has been created!\n");
+}
+
+

+
+

PaxProgram_LoadFromFile

 + +
+Loads compiled program from file. +
+void __stdcall PaxProgram_LoadFromFile(DWORD HProgram, char * Path);
+
+

+Arguments +

+
+HProgram +
+Handle of compiled program. +
+
+
+Path +
+File name. +
+
+

+

+Example +

+
+DWORD hp = PaxProgram_Create();
+PaxProgram_LoadFromFile(hp, "1.bin");
+PaxProgram_Run(hp);
+PaxProgram_Destroy(hp);
+
+

+
+

PaxProgram_GetAddress

 + +
+Returns address of script-defined variable or routine. +
+void __stdcall PaxProgram_GetAddress(DWORD HProgram, DWORD Handle);
+
+

+Arguments +

+
+HProgram +
+Handle of compiled program. +
+
+
+Handle +
+Id of script-defined variable or routine. +
+
+

+

+Example +

+
+#include "stdafx.h"
+#include "paxcompilerlib.h"
+
+int main(int argc, char* argv[])
+{
+        HMODULE h_lib = LoadPaxCompilerLib();
+        if (h_lib != 0)
+        {
+                DWORD hc = PaxCompiler_Create();
+                DWORD hl = PaxPascalLanguage_Create();
+                DWORD hp = PaxProgram_Create();
+
+                PaxCompiler_Reset(hc);
+                PaxCompiler_RegisterLanguage(hc, hl);
+
+                PaxCompiler_AddModule(hc, "1", "Pascal");
+                PaxCompiler_AddCode(hc, "1", "var x: Integer = 5;");
+                PaxCompiler_AddCode(hc, "1", "begin");
+                PaxCompiler_AddCode(hc, "1", " writeln('script:', x);");
+                PaxCompiler_AddCode(hc, "1", "end.");
+
+                if (PaxCompiler_Compile(hc, hp))
+                {
+      		        DWORD h_x = PaxCompiler_GetHandle(hc, 0, "x", true);
+
+			printf("the first run\n");
+                        PaxProgram_Run(hp);       
+
+         		int * p = (int*) PaxProgram_GetAddress(hp, h_x);
+			printf("host: %d\n", *p); // show script-defined var
+         		*p = 30;                  // change script-defind variable
+
+			printf("the second run\n");
+                        PaxProgram_Run(hp);      
+                }
+                else
+                {
+                        printf("there are errors:\n");
+                        for (int i = 0; i < PaxCompiler_GetErrorCount(hc); i++)
+                        {
+                                printf(PaxCompiler_GetErrorMessage(hc, i));
+                        }
+                }
+
+                PaxProgram_Destroy(hp);
+                PaxPascalLanguage_Destroy(hl);
+                PaxCompiler_Destroy(hc);
+        }
+        FreePaxCompilerLib(h_lib);
+
+        getchar();
+        return 0;
+}
+
+

+
+

PaxProgram_SetAddress

 + +
+Sets address of host-defined variable or routine. +
+void __stdcall PaxProgram_SetAddress(DWORD HProgram, DWORD Handle, void * p);
+
+

+Arguments +

+
+HProgram +
+Handle of compiled program. +
+
+
+Handle +
+Handle of host-defined variable or routine. +
+
+
+p +
+Address of host-defined variable or routine. +
+
+

+

+Example +

+
+void __stdcall show_message(char * s)
+{
+	printf(s);
+}
+............................................
+DWORD hc = PaxCompiler_Create();
+DWORD hl = PaxPascalLanguage_Create();
+DWORD hp = PaxProgram_Create();
+
+PaxCompiler_Reset(hc);
+PaxCompiler_RegisterLanguage(hc, hl);
+
+DWORD h_show_message = PaxCompiler_RegisterRoutine(hc, 0, "ShowMessage", PaxTypeVOID);
+PaxCompiler_RegisterParameter(hc, h_show_message, PaxTypePCHAR, false);
+
+PaxCompiler_AddModule(hc, "1", "Pascal");
+PaxCompiler_AddCode(hc, "1", "begin");
+PaxCompiler_AddCode(hc, "1", "  ShowMessage('Hello');");
+PaxCompiler_AddCode(hc, "1", "end.");
+
+if (PaxCompiler_Compile(hc, hp))
+{
+      PaxProgram_SetAddress(hp, h_show_message, & show_message);
+      PaxProgram_Run(hp);
+}
+
+

+
+

PaxProgram_GetDataPtr

 + +
+Returns address of data segment of compiled program. +
+void * __stdcall PaxProgram_GetDataPtr(DWORD HProgram);
+
+

+Arguments +

+
+HProgram +
+Handle of compiled program. +
+
+

+

+Example +

+
+#include "stdafx.h"
+#include "paxcompilerlib.h"
+
+long y = 5;
+
+int main(int argc, char* argv[])
+{
+        HMODULE h_lib = LoadPaxCompilerLib();
+        if (h_lib != 0)
+        {
+                DWORD hc = PaxCompiler_Create();
+                DWORD hl = PaxPascalLanguage_Create();
+                DWORD hp = PaxProgram_Create();
+
+                PaxCompiler_Reset(hc);
+                PaxCompiler_RegisterLanguage(hc, hl);
+
+		DWORD h_y = PaxCompiler_RegisterVariable(hc, 0, "Y", PaxTypeLONG);
+
+                PaxCompiler_AddModule(hc, "1", "Pascal");
+                PaxCompiler_AddCode(hc, "1", "procedure ScriptProc(X: Integer);");
+                PaxCompiler_AddCode(hc, "1", "begin");
+                PaxCompiler_AddCode(hc, "1", "  Y := Y + X;");
+                PaxCompiler_AddCode(hc, "1", "end;");
+                PaxCompiler_AddCode(hc, "1", "begin");
+                PaxCompiler_AddCode(hc, "1", "end.");
+
+                if (PaxCompiler_Compile(hc, hp))
+                {
+
+	  	        DWORD h_ScriptProc = PaxCompiler_GetHandle(hc, 0, "ScriptProc", true);
+			void * p = PaxProgram_GetAddress(hp, h_ScriptProc); // get address of script-defined procedure
+
+    			PaxProgram_SetAddress(hp, h_y, &y);
+
+			void * data_ptr = PaxProgram_GetDataPtr(hp);
+			void * code_ptr = PaxProgram_GetCodePtr(hp);
+
+			__asm
+			{
+				// save registers 
+				push esi
+				push edi
+				push ebp
+
+				// push data & code segment pointers
+				push data_ptr
+				push code_ptr
+
+                                push 10 // push parameter
+
+				call p // call script-defined procedure
+
+				pop eax // pop code segment pointer
+				pop eax // pop data segment pointer 
+
+				// restore registers
+				pop ebp
+				pop edi
+				pop esi
+			}
+
+			printf("y = %d", y);
+
+                }
+                else
+                {
+                        printf("there are errors:\n");
+                        for (int i = 0; i < PaxCompiler_GetErrorCount(hc); i++)
+                        {
+                                printf(PaxCompiler_GetErrorMessage(hc, i));
+                        }
+                }
+
+                PaxProgram_Destroy(hp);
+                PaxPascalLanguage_Destroy(hl);
+                PaxCompiler_Destroy(hc);
+        }
+        FreePaxCompilerLib(h_lib);
+
+        getchar();
+        return 0;
+}
+
+

+
+

PaxProgram_GetCodePtr

 + +
+Returns address of data segment of compiled program. +
+void * __stdcall PaxProgram_GetCodePtr(DWORD HProgram);
+
+

+Arguments +

+
+HProgram +
+Handle of compiled program. +
+
+
+

PaxPascalLanguage_Create

 + +
+Constructor of PaxPascal language object. Returns handle of object. +
+DWORD __stdcall PaxPascalLanguage_Create();
+
+

+

+Example +

+
+DWORD hc = PaxCompiler_Create();
+DWORD hl = PaxPascalLanguage_Create();
+PaxCompiler_RegisterLanguage(hc, hl);
+
+

+
+

PaxPascalLanguage_Destroy

 + +
+Destructor of PaxPascal language object. +
+void __stdcall PaxPascalLanguage_Destroy(DWORD HPaxPascalLanguage);
+
+

+Arguments +

+
+HPaxPascalLanguage +
+Handle of PaxPascal language object. +
+
+
+

+

+ +Copyright © 2006-2009 +VIRT Laboratory. All rights reserved. + + + diff --git a/help/logo_embarcadero.jpg b/help/logo_embarcadero.jpg new file mode 100644 index 0000000..e92daef Binary files /dev/null and b/help/logo_embarcadero.jpg differ diff --git a/help/news.htm b/help/news.htm new file mode 100644 index 0000000..ac6b4cd --- /dev/null +++ b/help/news.htm @@ -0,0 +1,353 @@ + + + + + + + + + +

+What's New +

+
+ +
    + +
  • +21 November 2012. paxCompiler, v3.1. +
      +
    • Anonymous functions and lambda expressions in Pascal and Basic. +
    • Support for uint64 type. +
    • Beta version of 64-bit compiler. +
    + + +
  • +14 October 2011. paxCompiler, v3.0. +
      +
    • Increased speed of compilation. +
    • Support of generic types in Pascal and Basic. +
    + + +
  • +14 April 2011. paxCompiler, v2.9. +
      +
    • Improved support of Free Pascal and Lazarus. +
    • New implementation of open arrays. +
    • Implementation of "go to definition" functionality. +
    • Comments of script members can be accessible in code explorer. +
    + + +
  • +30 November 2010. paxCompiler, v2.8. +
      +
    • Support of operator overloading. +
    • Import via Delphi 2010 RTTI. +
    • Embedding scripts into html pages. +
    + + +
  • +1 September 2010. Support of Embarcadero RAD Studio XE. + + +
  • +19 May 2010. paxCompiler, v2.7. +
      +
    • Generation of dll files. +
    • Speed of compilation has been increased in 2 times. +
    + + +
  • +3 March 2010. paxCompiler, v2.6. Native implementation of Windows SEH. + + +
  • +2 October 2009. paxCompiler, v2.5. JavaScript compiler. + + +
  • +28 August 2009. Support of Delphi 2010 + + +
  • +2 July 2009. paxCompiler, v2.4 + +Support of compiled units and run-time packages. + +
      +
    • paxCompiler uses unified format of storage of compiled scripts, compiled units and run-time packages - PCU. +
    • Functionality of PCU-files is similar to DCU-files and BPL-files in Delphi, so you can use PCU-files both +at compile time and run-time. +
    • Events TPaxCompiler.OnSavePCU, TPaxCompiler.OnLoadPCU allows you to save/load pcu-s to/from a stream at +compile-time. Event TPaxProgram.OnLoadPCU provides you with a possibility to load pcu-s at run-time. +So, you can avoid disk operations at run-time. +
    + + +
  • +23 March 2009. paxCompiler, v2.3 + +
      +
    • Basic compiler. +
    • Cross-language programming. +
    + + + +
  • +3 March 2009. Basic compiler, beta version + +
      + +
    • Basic is the second programming language supported by paxCompiler. +
    • Syntax of Basic language is similar to VB.NET. +
    • Supported types are: standard, enum, array, structure, class, interface. +
    • Cross-language programming is allowed. You can use Pascal units in Basic scripts and vice versa. +
    • You can bind instances of Basic classes with dfm files. +
    • Basic types support RTTI, published properties of class types are allowed. + +
    + + +
  • +2 March 2009. paxCompiler forum has been reloacated: +news://216.75.1.194/virtlabs.public.paxcompiler + + +
  • +22 December 2008. paxCompiler v2.2. + +New: + +
      +
    • RTTI of script-defined types. +
    • Published script-defined fields, methods and properties. +
    • Binding dfm-files. +
    + + +
  • +23 November 2008. paxCompiler v2.1. +
      +
    • Support of Delphi 2009. +
    • Internal representation of script-defined class types coincides with representation +of Delphi classes, so you can create new native Delphi classes in a script. +
    + + +
  • +27 May 2008. paxCompiler v2.0. + +New: + +
      +
    • Script-defined interface types. +
    • Code completion. +
    • Evaluation of expressions at run-time. +
    + + +
  • +1 February 2008. paxCompiler v1.9. + +New: + +
      +
    • OleVariant, ShortInt, SmallInt, ByteBool, WordBool, LongBool types. +
    • Conditional compilation directives. +
    • Included files. +
    • Unpacked record and array types, alignment directive. +
    • Variant parts in records. +
    • Precompiled import units. +
    • Dynamic registration of import units. +
    • You can load precompiled import units from a stream. +
    • Increased speed of compilation. +
    • Decreased size of compiled script. +
    • Extended set of type registration routines. +
    • You can extract from compiled script address of any script-defined varible, + function or method by its name. +
    + + +
  • +16 October 2007. paxCompiler v1.8. Generation of stand alone executable files: Win32 console and GUI applications. +Click here to download a test application (pascal_tester.zip, 1.2 MB). + + +
  • +26 September 2007. paxCompiler v1.7. Support of host-defined interface types. + +
  • +24 September 2007. paxCompiler forum has been relocated. Please use link +news://216.55.137.150/virtlabs.public.paxcompiler + + +
  • +24 September 2007. paxCompiler Importer of Ivan Dyachenko. Thanks for this contribution! +Click here to download the importer. + + +
  • +20 September 2007. Smart paxCompiler Importer. Thanks to Joe Oszlanczi for this contribution! +Click here to download the importer. + + + +
  • +21 August 2007. TPaxInvoke component, v1.0 +
    + +The TPaxInvoke component for Delphi and C++ Builder allows you to dynamically invoke both script-defined (created with paxCompiler) and host-defined methods +and global functions. +The supported calling conventions are: register (Borland fastcall), cdecl, stdcall, safecall, pascal + and msfastcall (Microsoft fastcall). + +The TPaxInvoke is a part of paxCompiler package, but you can also use it as a stand alone component to invoke any host-defined or +dll-defined function. In particular, the component gives you a flexible way to invoke functions with msfastcall convention. + +
    + + +
  • +21 August 2007. paxCompiler v1.6. +
    + + + + +
    + + + + +
  • +7 June 2007. paxCompiler v1.5. +
    + +
      +
    • TPaxCompilerExplorer and TPaxCompilerDebugger components. +
    • Array and record initializers. +
    • Increased speed of compilation. +
    • Support of Delphi 2007. +
    + +
    +
    • + + + +
  • +17 April 2007. paxCompiler importer, v1.0. +
    +The importer allows you to convert units written in Delphi into imp-files, so types defined in a source unit can be used in your scripts. +
    +
    • + +
  • +18 December 2006. paxCompiler v1.4. +
    + +
      +
    • Support of script-defined class types: +
        +
      • you can create script-defined classes that inherit host-defined classes. +
      • it is possible to create script-defined event handlers for host-defined events and vice versa. +
      • virtual and abstract methods are allowed. +
      +
    • stdcall, cdecl, pascal, register calling conventions. +
    • Increased speed of compilation. +
    + +
    +
    • + + +
  • +17 October 2006. paxCompiler v1.3. +
    + +
      +
    • You can pause, resume and terminate scripts. +
    • Run-time line error reporting. +
    • Support of Int64 type. +
    • Support of OLE Automation. +
    + +

    +New methods and events: + +

      +
    • TPaxProgram.OnPause event +
    • TPaxProgram.OnHalt event +
    • TPaxProgram.OnException event +
    • TPaxProgram.OnUnhandledException event +
    • TPaxProgram.Pause method +
    • TPaxProgram.IsPaused method +
    • TPaxProgram.Resume method + +
    • TPaxCompiler.OnUsedUnit event +
    • TPaxCompiler.Modules property +
    • TPaxCompiler.DebugMode property + +
    • Pause standard Pascal function +
    • Halt standard Pascal function +
    + +
    +
    • + + +
  • +22 September 2006. paxCompiler, v1.2 +
    +
      +
    • WideChar, WideString and Variant types. +
    • Dynamic arrays. +
    • Exception handling. +
    +
    +
    • + +
  • +22 July 2006. paxCompiler, v1.1 +
    +New: Importing Delphi class types and class reference types. You can register host-defined public constructors, methods, fields and properties +for paxCompiler. Published properties are registered automatically. Using global registration routines +allows you to share registered items with all paxCompiler instances and to decrease footprint of each paxCompiler instance. These +routines provide an easy way to create +import units (see IMPORT_SysUtils.pas, IMPORT_Classes.pas). +
    +
    • + +
  • +5 June 2006. paxCompiler, v1.0. +
    • + +
  • +11 May 2006. paxCompiler, beta version. +
    • + +
+ + + +

+

+ +Copyright © 2006-2011 +VIRT Laboratory. All rights reserved. + + + diff --git a/help/news.jpg b/help/news.jpg new file mode 100644 index 0000000..58e11ec Binary files /dev/null and b/help/news.jpg differ diff --git a/help/pascal_callback.htm b/help/pascal_callback.htm new file mode 100644 index 0000000..e6063f8 --- /dev/null +++ b/help/pascal_callback.htm @@ -0,0 +1,53 @@ + + + + + +

+Pascal samples. Script-defined callback functions. +

+
+ +
+ +
+uses Classes;
+
+function Compare(Item1, Item2: Pointer): Integer; register;
+begin
+  if Integer(Item1) > Integer(Item2) then
+    result := 1
+  else if Integer(Item1) < Integer(Item2) then
+    result := -1
+  else
+   result := 0;
+end;
+
+var
+  L: TList;
+  I: Integer;
+begin
+  L := TList.Create;
+  L.Add(Pointer(3));
+  L.Add(Pointer(1));
+  L.Add(Pointer(2));
+  L.Add(Pointer(6));
+  L.Add(Pointer(4));
+  L.Add(Pointer(5));
+  L.Sort(@Compare);
+  for I:=0 to L.Count - 1 do
+    writeln(Integer(L[I]));
+  L.Free;
+end.
+
+
+ + +

+

+ +Copyright © 2006-2009 +VIRT Laboratory. All rights reserved. + + + diff --git a/help/pascal_class_types.htm b/help/pascal_class_types.htm new file mode 100644 index 0000000..60329cd --- /dev/null +++ b/help/pascal_class_types.htm @@ -0,0 +1,37 @@ + + + + + +

+Pascal samples. Class types. +

+
+ + +
+
+uses 
+  Classes;
+var
+  l: TStringList;
+begin
+  l := TStringList.Create;
+  l.Add('abc');
+  writeln(l[0]);
+  writeln(l.Text);
+  L.Text := 'pqr';
+  writeln(l.Text);
+end.
+
+
+ + +

+

+ +Copyright © 2006-2009 +VIRT Laboratory. All rights reserved. + + + diff --git a/help/pascal_classref_types.htm b/help/pascal_classref_types.htm new file mode 100644 index 0000000..e35b73c --- /dev/null +++ b/help/pascal_classref_types.htm @@ -0,0 +1,46 @@ + + + + + +

+Pascal samples. Class reference types. +

+
+ + +
+
+uses 
+  Classes;
+var
+  X: TCollectionItemClass;
+  Z: TCollectionItem;
+  Y: TCollection;
+  C: TClass;
+begin
+  X := TCollectionItem;
+  writeln(X.ClassName);
+  Y := TCollection.Create(X);
+  writeln(Y.ClassName);
+  Z := TCollectionItem.Create(Y);
+  writeln(Z.ClassName);
+  Z := X.Create(Y);
+  writeln(Z.ClassName);
+  C := Z.ClassType;
+  writeln(C.ClassName);
+  writeln(nil = Z);
+  writeln(X = TCollectionItem);
+end.
+
+
+ + +

+

+ +Copyright © 2006-2009 +VIRT Laboratory. All rights reserved. + + + diff --git a/help/pascal_default.htm b/help/pascal_default.htm new file mode 100644 index 0000000..4cdd369 --- /dev/null +++ b/help/pascal_default.htm @@ -0,0 +1,39 @@ + + + + + +

+Pascal samples. Default parameters. +

+
+ +
+ +
+program Demo;
+
+procedure Test(X: Integer; S: Single = 12.5; 
+               C: Char = 'W'; Str: String = 'abc');
+begin
+  writeln(X:10, S:10:2, ' ', C, ' ', Str);
+end;
+
+begin
+  Test(5, 5, 'a', 'a');
+  Test(5, 5, 'a');
+  Test(5, 5);
+  Test(5);
+end.
+
+
+ + +

+

+ +Copyright © 2006-2009 +VIRT Laboratory. All rights reserved. + + + diff --git a/help/pascal_enum_types.htm b/help/pascal_enum_types.htm new file mode 100644 index 0000000..453d180 --- /dev/null +++ b/help/pascal_enum_types.htm @@ -0,0 +1,36 @@ + + + + + +

+Pascal samples. Enumeration types. +

+
+ +
+ +
+program Demo;
+type
+  TMyEnum = (red = 2, blue, green, black);
+var
+  x, y: TMyEnum;
+begin
+  x := blue;
+  writeln(Integer(x));
+  y := Pred(x); 
+  writeln(Integer(y));
+  writeln(Integer(Succ(y)));
+end.
+
+
+ +

+

+ +Copyright © 2006-2009 +VIRT Laboratory. All rights reserved. + + + diff --git a/help/pascal_except.htm b/help/pascal_except.htm new file mode 100644 index 0000000..6e207f1 --- /dev/null +++ b/help/pascal_except.htm @@ -0,0 +1,104 @@ + + + + + +

+Pascal samples. Exception handling. +

+
+ +

+Example 1 +

+
+
+uses
+  SysUtils;
+
+procedure ErrorProc;
+var
+  I: Integer;
+begin
+  I := 0;
+  I := I div I;
+end;
+
+procedure TestExcept;
+var
+  S: String;
+  I: Integer;
+begin
+  S := 'abc';
+  try
+    ErrorProc;
+  except
+    on E:EDivByZero do
+    begin
+      writeln(S);
+      S := E.Message;
+      writeln(S);
+    end;
+    else
+    begin
+      writeln(456);
+    end;
+  end;
+end;
+
+begin
+  TestExcept;
+  writeln('ok');
+end.
+
+
+ +

+Example 2 +

+
+
+uses
+  SysUtils;
+
+procedure ErrorProc;
+var
+  I: Integer;
+begin
+  I := 0;
+  I := I div I;
+end;
+
+procedure TestFinally;
+var
+  S: String;
+  I: Integer;
+begin
+  S := 'abc';
+  try
+    ErrorProc;
+  finally
+    writeln(S);
+  end;
+  writeln('not executed');
+end;
+
+begin
+  try
+    TestFinally;
+  except
+    writeln('ok');
+  end;
+end.
+
+
+ + +

+

+ +Copyright © 2006-2009 +VIRT Laboratory. All rights reserved. + + + diff --git a/help/pascal_init.htm b/help/pascal_init.htm new file mode 100644 index 0000000..b388f97 --- /dev/null +++ b/help/pascal_init.htm @@ -0,0 +1,34 @@ + + + + + +

+Pascal samples. Array initializers. +

+
+ +
+
+type
+  TPoint = record
+    X, Y: Single;
+  end;
+  TVector = array[0..1] of TPoint;
+const
+  Line: TVector = ((X: -3.1; Y: 1.5), (X: 5.8; Y: 3.0));
+begin
+  writeln(Line[1].X);
+end.
+
+
+ + +

+

+ +Copyright © 2006-2009 +VIRT Laboratory. All rights reserved. + + + diff --git a/help/pascal_interface1.htm b/help/pascal_interface1.htm new file mode 100644 index 0000000..25993f6 --- /dev/null +++ b/help/pascal_interface1.htm @@ -0,0 +1,52 @@ + + + + + +

+Pascal samples. Script-defined interface types. +

+
+ +
+
+program Test;
+type
+  IMyInterface = interface(IUnknown)
+  ['{E7AA427A-0F4D-4A96-A914-FAB1CA336337}']
+    procedure P(X, Y: Integer); cdecl;
+  end;
+  TMyClass = class(TInterfacedObject, IMyInterface)
+    procedure P(X, Y: Integer); cdecl;
+    destructor Destroy; override;
+  end;
+procedure TMyClass.P(X, Y: Integer); 
+begin
+  writeln(Self.ClassName);
+  writeln(X, ' ', Y);
+end;
+destructor TMyClass.Destroy;
+begin
+  writeln('Done');
+  inherited;
+end;
+var
+  I: IMyInterface;
+  X: TMyClass;
+begin
+  X := TMyClass.Create;
+  I := X;
+  I.P(3, 4);
+end.
+
+
+ + +

+

+ +Copyright © 2006-2009 +VIRT Laboratory. All rights reserved. + + + diff --git a/help/pascal_interface2.htm b/help/pascal_interface2.htm new file mode 100644 index 0000000..5314954 --- /dev/null +++ b/help/pascal_interface2.htm @@ -0,0 +1,64 @@ + + + + + +

+Pascal samples. Directive IMPLEMENTS. +

+
+ +
+
+program P;
+type
+  IMyPropInterface = interface
+    function GetName: String;
+  end; 
+
+  TMyPropInterface = class
+    function GetName: String;
+  end; 
+
+  TMyClass = class(TInterfacedObject, IMyPropInterface)
+  private
+    fMyPropInterface: TMyPropInterface;
+  public
+    constructor Create;
+    property MyPropInterface: TMyPropInterface
+      read fMyPropInterface
+      write fMyPropInterface
+      implements IMyPropInterface;   
+  end;  
+
+function TMyPropInterface.GetName: String;
+begin
+  result := 'abc';
+end;
+
+constructor TMyClass.Create;
+begin
+  inherited;
+  MyPropInterface := TMyPropInterface.Create; 
+end;
+
+var 
+  X: TMyClass;
+  I: IMyPropInterface;
+begin
+  X := TMyClass.Create;
+  I := X;
+  writeln(I.GetName());
+end.
+
+
+ + +

+

+ +Copyright © 2006-2009 +VIRT Laboratory. All rights reserved. + + + diff --git a/help/pascal_namespaces.htm b/help/pascal_namespaces.htm new file mode 100644 index 0000000..a6eb115 --- /dev/null +++ b/help/pascal_namespaces.htm @@ -0,0 +1,48 @@ + + + + + +

+Pascal samples. Namespaces. +

+
+ +
+ +
+program Demo;
+namespace A
+  procedure G;
+  begin
+    P;
+  end;
+  procedure P;
+  begin
+    writeln(123);
+  end;
+end;
+
+namespace A
+  procedure V;
+  begin
+    writeln('V');
+  end;
+end;
+
+begin
+  A.G;
+  A.V;
+end.
+
+
+ + +

+

+ +Copyright © 2006-2009 +VIRT Laboratory. All rights reserved. + + + diff --git a/help/pascal_nested.htm b/help/pascal_nested.htm new file mode 100644 index 0000000..b79e2f4 --- /dev/null +++ b/help/pascal_nested.htm @@ -0,0 +1,42 @@ + + + + + +

+Pascal samples. Nested routines. +

+
+ +
+ +
+program Demo;
+
+procedure Outer(X: Integer);
+
+procedure Inner(P, Q: Double);
+begin
+  X := X + 10;
+  writeln(X, ' ', P, ' ', Q);
+end;
+
+begin
+  Inner(3, 5.7);
+end;
+
+begin
+  Outer(10);
+end.
+
+
+ + +

+

+ +Copyright © 2006-2009 +VIRT Laboratory. All rights reserved. + + + diff --git a/help/pascal_ole.htm b/help/pascal_ole.htm new file mode 100644 index 0000000..1a3297e --- /dev/null +++ b/help/pascal_ole.htm @@ -0,0 +1,38 @@ + + + + + +

+Pascal samples. Support of OLE Automation. +

+
+ +
+
+var
+  WordApp, Range: Variant;
+  I: Integer;
+begin
+  WordApp := CreateOleObject('Word.Application');
+  WordApp.Visible := true;
+  WordApp.Documents.Add;
+  Range := WordApp.Documents.Item[1].Range;
+  Range.Text := 'This is a column from a spreadsheet: ';
+  for I:= 0 to 3 do
+    WordApp.Documents.Item[1].Paragraphs.Add;
+  Range := WordApp.Documents.Item[1].Range[WordApp.Documents.Item[1].Paragraphs.Item[3].Range.Start];
+  Range.Paste;
+end.
+
+
+ + +

+

+ +Copyright © 2006-2009 +VIRT Laboratory. All rights reserved. + + + diff --git a/help/pascal_overloaded.htm b/help/pascal_overloaded.htm new file mode 100644 index 0000000..5fe82d1 --- /dev/null +++ b/help/pascal_overloaded.htm @@ -0,0 +1,47 @@ + + + + + +

+Pascal samples. Overloaded routines. +

+
+ +
+ +
+program Demo;
+
+procedure Test(I: Integer; D: Double);
+begin
+  writeln(I:10, D:10:2);
+end;
+
+procedure Test(S: String);
+begin
+  writeln(S);
+end;
+
+procedure Test(D: Double);
+begin
+  writeln(D:10:2);
+end;
+
+begin
+  Test('abc');
+  Test(12.3);
+  Test(5, 12.3);
+end.
+
+
+ + +

+

+ +Copyright © 2006-2009 +VIRT Laboratory. All rights reserved. + + + diff --git a/help/pascal_script_classes.htm b/help/pascal_script_classes.htm new file mode 100644 index 0000000..fd67b51 --- /dev/null +++ b/help/pascal_script_classes.htm @@ -0,0 +1,49 @@ + + + + + +

+Pascal samples. Script-defined class types. +

+
+ +
+
+uses
+  Classes;
+type
+  TMyComponent = class(TComponent)
+    procedure Show; virtual; abstract; 
+  end;
+
+  TMyClass = class(TMyComponent)
+    procedure Show; override;
+  end;
+
+procedure TMyClass.Show;
+begin
+  writeln('TMyClass');
+end;
+
+var
+  X: TMyComponent;
+begin
+  X := TMyClass.Create(nil);
+  X.Name := 'abc';
+  writeln(X.Name);
+  X.Show;
+  X.Free;
+end.
+
+
+ + +

+

+ +Copyright © 2006-2009 +VIRT Laboratory. All rights reserved. + + + diff --git a/help/pascal_type_array.htm b/help/pascal_type_array.htm new file mode 100644 index 0000000..63a9eb8 --- /dev/null +++ b/help/pascal_type_array.htm @@ -0,0 +1,39 @@ + + + + + +

+Pascal samples. Static array types. +

+
+ +
+ +
+program Demo;
+type
+  TMyPoint = record
+    X, Y: Single;
+  end; 
+  TMyArray = array [false..true] of TMyPoint;
+var
+  a: TMyArray;
+  b: array['a'..'z'] of Integer;
+begin
+  b['s'] := 47;
+  writeln(b['s']);
+  a[true].Y := 5.5;
+  writeln(a[true].Y);
+end.
+
+
+ +

+

+ +Copyright © 2006-2009 +VIRT Laboratory. All rights reserved. + + + diff --git a/help/pascal_type_dynarray.htm b/help/pascal_type_dynarray.htm new file mode 100644 index 0000000..bec60c9 --- /dev/null +++ b/help/pascal_type_dynarray.htm @@ -0,0 +1,75 @@ + + + + + +

+Pascal samples. Dynamic array types. +

+
+ +

+Example 1 +

+
+
+type
+  TArrInt = array of Integer;
+
+procedure TestDynArrayProc(A: array of Integer);
+begin
+  writeln(Length(A));
+  writeln(A[3]);
+end;
+
+function RetDynArray: TArrInt;
+begin
+  SetLength(result, 7);
+  result[5] := 2;
+end;
+
+var
+  A: array of Integer;
+  B: array of Integer;
+begin
+  SetLength(A, 10);
+  A[3] := 3;
+
+  TestDynArrayProc(A);
+
+  A := RetDynArray();
+  writeln(Length(A));
+  writeln(A[5]);
+
+  B := A;
+
+  writeln(B[5]);
+end.
+
+
+ +

+Example 2 +

+
+
+uses 
+  SysUtils;
+var
+  S: String;
+begin
+  S := Format('abc %s pqr', ['xyz']);
+  writeln(S);
+end.
+
+
+ + +

+

+ +Copyright © 2006-2009 +VIRT Laboratory. All rights reserved. + + + diff --git a/help/pascal_units.htm b/help/pascal_units.htm new file mode 100644 index 0000000..5b109e3 --- /dev/null +++ b/help/pascal_units.htm @@ -0,0 +1,68 @@ + + + + + +

+Pascal samples. Units. +

+
+ + +
+ +
+unit MyUnit;
+interface
+var
+  I: Integer = 4;
+const 
+  S = 'abc';
+
+procedure Proc(X: Integer);
+
+implementation
+
+var
+  J: Integer = 10;
+
+procedure Proc(X: Integer);
+begin
+  writeln(X);
+end;
+
+initialization
+  writeln('Initialization');
+  I := 10;
+finalization
+  writeln('finalization');
+
+end.
+
+
+ +Main program: + +
+ +
+program Demo;
+uses MyUnit;
+begin
+  writeln(I);
+  writeln(S);
+  Proc(123);
+end.
+
+
+ + + +

+

+ +Copyright © 2006-2009 +VIRT Laboratory. All rights reserved. + + + diff --git a/help/pascal_variant_types.htm b/help/pascal_variant_types.htm new file mode 100644 index 0000000..d0950d5 --- /dev/null +++ b/help/pascal_variant_types.htm @@ -0,0 +1,91 @@ + + + + + +

+Pascal samples. Variant types. +

+
+ +

+Example 1 +

+
+
+uses
+  Variants;
+var
+  V1, V2: Variant;
+  I: Integer;
+  S: String;
+  WS: WideString;
+  c: Char;
+  D: Double;
+begin
+  V1 := 'abc';
+  writeln(V1);
+  S := 'pqr';
+  V1 := S;
+  writeln(V1);
+  WS := 'xyz';
+  V1 := WS;
+  writeln(V1);
+  V2 := V1;
+  writeln(V2);
+  c := 'g';
+  V1 := c;
+  writeln(V1);
+  I := 5;
+  V1 := I;
+  writeln(V1);
+  V1 := 0.5;
+  writeln(V1);
+  D := 0.3;
+  V1 := D;
+  writeln(V1);
+  S := V2;
+  writeln(S);
+  WS := V2;
+  writeln(S);
+  D := V1;
+  writeln(D);
+  V1 := 3;
+  I := V1;
+  writeln(I);
+  V1 := true;
+  writeln(V1);
+  writeln(VarType(V1));
+end.
+
+
+ + +

+Example 2 +

+
+
+uses
+  Variants;
+var
+  V: Variant;
+begin
+  V := VarArrayOf([10, 20, 30]);
+  writeln(V[1]);
+
+  V := VarArrayCreate([0, 5], varInteger);
+  V[2] := 5;
+  writeln(V[2]);
+end.
+
+
+ +

+

+ +Copyright © 2006-2009 +VIRT Laboratory. All rights reserved. + + + diff --git a/help/paxcompiler.gif b/help/paxcompiler.gif new file mode 100644 index 0000000..3923e73 Binary files /dev/null and b/help/paxcompiler.gif differ diff --git a/help/paxcompiler.jpg b/help/paxcompiler.jpg new file mode 100644 index 0000000..89e569b Binary files /dev/null and b/help/paxcompiler.jpg differ diff --git a/help/paxinvoke.htm b/help/paxinvoke.htm new file mode 100644 index 0000000..ff9e158 --- /dev/null +++ b/help/paxinvoke.htm @@ -0,0 +1,200 @@ + + + + + +

+TPaxInvoke component for Delphi and Borland C++ Builder. +

+
+ + +The TPaxInvoke component allows you to dynamically invoke both script-defined (created with paxCompiler) and host-defined methods +and global functions. +The supported calling conventions are: register (Borland fastcall), cdecl, stdcall, safecall, pascal + and msfastcall (Microsoft fastcall). + + + +The TPaxInvoke is a part of paxCompiler package, but you can also use it as a stand alone component to call any host-defined or +dll-defined function. In particular, the component gives you a flexible way to invoke functions with msfastcall convention. + +

+Demos. +

+ +
    + +
  1. Invoke a host-defined function. +
    + +
    +type
+  TCharRec = record
+    X, Y: Char;
+  end;
+
+function MyHostFunc(const U, V: TCharRec): String; stdcall;
+begin
+  result := U.X + V.Y;
+end;
+
+var
+  R: TCharRec;
+  S: String;
+begin
+  R.X := 'a';
+  R.Y := 'b';
+
+  PaxInvoke1.Address := @ MyHostFunc;
+  PaxInvoke1.This := nil; // this is not a method
+  PaxInvoke1.ClearArguments;
+  PaxInvoke1.AddArgAsRecord(R, SizeOf(R));
+  PaxInvoke1.AddArgAsRecord(R, SizeOf(R));
+  PaxInvoke1.SetResultAsAnsiString;
+  PaxInvoke1.CallConv := _ccSTDCALL;
+  PaxInvoke1.CallHost; // call host-defined function
+  S := String(PaxInvoke1.GetResultPtr^);
+  ShowMessage(S);
+
+  PaxInvoke1.ClearResult;
+
    +
    + +
  2. Invoke a host-defined method. +
    + +
    +function TForm1.MyHostMethod(const X, Y: ShortString; Z: Integer): String;
+begin
+  result := X + Y + IntToStr(Z);
+end;
+
+procedure TForm1.Button3Click(Sender: TObject);
+begin
+  PaxInvoke1.Address := @ TForm1.MyHostMethod;
+  PaxInvoke1.This := Self; // we call a method
+  PaxInvoke1.ClearArguments;
+  PaxInvoke1.AddArgAsShortString('xyz');
+  PaxInvoke1.AddArgAsShortString('uv');
+  PaxInvoke1.AddArgAsInteger(8);
+  PaxInvoke1.SetResultAsAnsiString;
+  PaxInvoke1.CallConv := _ccREGISTER;
+  PaxInvoke1.CallHost; 
+  ShowMessage(String(PaxInvoke1.GetResultPtr^));
+
+  PaxInvoke1.ClearResult;
+end;
+
    +
    + +
  3. Invoke a dll-defined function. +
    + +
    +// Point  __msfastcall ret_struct(int x, int y, int z);
+
+type
+  TMyPoint = record
+    x, y, z: Integer;
+  end;
+var
+  r: TMyPoint;
+begin
+  PaxInvoke1.This := nil; // this is not a method
+  PaxInvoke1.CallConv := _ccMSFASTCALL;
+
+  PaxInvoke1.LoadAddress('CppDll.dll', 'ret_struct');
+  PaxInvoke1.ClearArguments;
+  PaxInvoke1.AddArgAsInteger(2);
+  PaxInvoke1.AddArgAsInteger(3);
+  PaxInvoke1.AddArgAsInteger(5);
+  PaxInvoke1.SetResultAsRecord(SizeOf(TMyPoint));
+  PaxInvoke1.CallHost; // call dll-defined function
+  r := TMyPoint(PaxInvoke1.GetResultPtr^);
+  ShowMessage(IntToStr(r.x) + ' ' + IntToStr(r.y) + ' ' + IntToStr(r.z));
+end;
+
    +
    + +
  4. Invoke a script-defined function. +
    + +
    +uses
+  IMPORT_SysUtils;
+
+procedure Print(const S: String);
+begin
+  ShowMessage(S);
+end;
+
+var
+  H_MyFunc: Integer;
+  I: Integer;
+  P: Pointer;
+begin
+{$O-}
+  PaxCompiler1.Reset;
+  PaxCompiler1.RegisterLanguage(PaxPascalLanguage1);
+  PaxCompiler1.RegisterHeader(0, 'procedure Print(const S: String);', @Print);
+
+  PaxCompiler1.AddModule('1', PaxPascalLanguage1.LanguageName);
+  PaxCompiler1.AddCode('1', 'uses SysUtils;');
+  PaxCompiler1.AddCode('1', 'function MyFunc(U, V: Integer): Currency; cdecl;');
+  PaxCompiler1.AddCode('1', 'begin');
+  PaxCompiler1.AddCode('1', '  try');
+  PaxCompiler1.AddCode('1', '    result := U / V;');
+  PaxCompiler1.AddCode('1', '  except');
+  PaxCompiler1.AddCode('1', '    on E: Exception do');
+  PaxCompiler1.AddCode('1', '    begin');
+  PaxCompiler1.AddCode('1', '      print(E.Message);');
+  PaxCompiler1.AddCode('1', '      result := 7;');
+  PaxCompiler1.AddCode('1', '    end;');
+  PaxCompiler1.AddCode('1', '  end;');
+  PaxCompiler1.AddCode('1', 'end;');
+  PaxCompiler1.AddCode('1', 'begin');
+  PaxCompiler1.AddCode('1', 'end.');
+
+  if PaxCompiler1.Compile(PaxProgram1) then
+  begin
+    H_MyFunc := PaxCompiler1.GetHandle(0, 'MyFunc', true);
+
+    P := PaxProgram1.GetAddress(H_MyFunc); // get address of script-defined function
+
+    PaxInvoke1.Address := P;
+    PaxInvoke1.This := nil; // this is not a method, but global function.
+    PaxInvoke1.ClearArguments;
+    PaxInvoke1.AddArgAsInteger(8);
+    PaxInvoke1.AddArgAsInteger(2); 
+    PaxInvoke1.SetResultAsCurrency;
+    PaxInvoke1.CallConv := _ccCDECL;
+
+    PaxProgram1.SetEntryPoint(PaxInvoke1);
+    PaxProgram1.Run;
+
+    ShowMessage(CurrToStr(Currency(PaxInvoke1.GetResultPtr^)));
+  end
+  else
+    for I:=0 to PaxCompiler1.ErrorCount do
+      ShowMessage(PaxCompiler1.ErrorMessage[I]);
+end;
+
    +
    + + +
+ +

+

+ +Copyright © 2006-2009 +VIRT Laboratory. All rights reserved. + + + diff --git a/help/references.htm b/help/references.htm new file mode 100644 index 0000000..7a64a25 --- /dev/null +++ b/help/references.htm @@ -0,0 +1,206 @@ + + + + + +

+References +

+
+ +

paxCompiler for Delphi, C++ Builder and Lazarus

 +
+ +TPaxCompiler, TPaxProgram and TPaxPascalLanguages are Delphi components that allows you to embed the paxCompiler into Delphi, +C++ Builder and Lazarus applications so you can customize and extend the application without having to recompile it. + +
    + + + + + +
      +TPaxPascalLanguage represents parser of Pascal language. +
      +
    • Methods +
      • +
    + + + + +
      +TPaxCompilerExplorer allows you to explore compiled scripts. +
      +
    • Methods +
    • Properties +
      • +
    + +
      +
    • TPaxInvoke allows you to dynamically invoke a global function or a method of object. +
    + +
      +
    • Procedure + +
      + +
      +procedure CreateExeFile(const ExeName: String;
+                        PaxProgram: TPaxProgram;
+                        const DllName: String;
+                        const ProcName: String);
+
      +
      + +allows you to create stand alone executable files. +Click here to download a test application (pascal_tester.zip, 1.2 MB). + + +
    + + + +
+ +

PaxCompiler registration routines

+Using global registration routines (see PaxRegister.pas) allows you to share registered +items with all paxCompiler instances and to decrease footprint of each paxCompiler instance. +These routines provide an easy way to create +import units (see IMPORT_SysUtils.pas, IMPORT_Classes.pas)). + + +

Demos

+ +
+ +

paxCompiler for Microsoft Visual Studio C++

 +
+ + +paxCompiler, implemented as paxcompilerlib.dll, can be used for scripting MS VC++ applications. + + + +

Routines exported by paxcompilerlib.dll

+ + +

Demos

+ +
+ + + +

Pascal samples

+ + + +

Basic samples

+ + + +

JavaScript samples

+ + + + + +
+ + + + + + +

paxCompiler Importer

 + +paxCompiler importer (paxImp.exe) is a +freeware program for generation +of import units from source code inits of your application, +so all members defined in your (host) applacation become accessible +for your paxCompiler scripts. You can create import files for all Delphi +versions starting with Delphi 5 (D5-XE6). (More...) + + +

+

+ +Copyright © 2006-2012 +VIRT Laboratory. All rights reserved. + + + diff --git a/help/references.jpg b/help/references.jpg new file mode 100644 index 0000000..ffc92d1 Binary files /dev/null and b/help/references.jpg differ diff --git a/help/single_lic.htm b/help/single_lic.htm new file mode 100644 index 0000000..0616a8e --- /dev/null +++ b/help/single_lic.htm @@ -0,0 +1,159 @@ + + + + + + + +

+paxCompiler Single Developer License +

+
+ +

+DEFINITIONS +

+ +

+"Software" means paxCompiler compiler in any form (source code, object code, dcu-s, dll, or other). The Software +is the sole property of Alexander Baranovsky (hereinafter "Author"). +

+ +

+"Source Code" means all source of the paxCompiler. +

+ +

+"You" means the organization or individual that purchases the Source License +Agreement. +

+ +

+LICENSE +

+ +

+This is a non-exclusive, non-transferable, non-sublicensable license for the +Source Code. You may not use the Software for any purpose other than stated +in this license. +

+ +

+You may integrate the Source Code with your applications and distribute these +applications (executable programs) royalty free. +

+ +

+You may not distribute any part of the paxCompiler source code, object files, +dcu-s, under any circumstances. +

+ +

+The Source Code may be used only by You. You may install and use one copy of +the Source Code on any computer system you operate, as long as you can be sure +that you are the sole user and that you only use the Source Code from one +machine at a time. +

+ +

+DELIVERY +

+ +

+Software and any updates will be delivered electronically. You acknowledges +delivery by downloading. +

+ +

+COPYRIGHT NOTICE +

+ +

+You agree not to remove or alter any of Author's copyright notices in the +Source Code. +

+ + +

+NON-COMPETITION +

+ +

+You agree not to create any software component product(s) that directly +competes with paxCompiler, which utilizes all or any portion of paxCompiler +and its related source code. +

+ +

+CONFIDENTIALITY +

+ +

+You agrees not to disclose the Source Code to any third party for any reason. +

+ +

+UPDATES AND UPGRADES +

+ +

+Author will make available to You the Source Code corresponding to any updates +and upgrades to the Source Code released by Author during 15 monthes +following the effective date of this agreement. You is responsible to integrate +any updates to the Source Code into modified versions that You have developed. +

+ +

+SUPPORT +

+ +

+Author will provide e-mail support to You for general questions about the +Source Code for 15 monthes after the Effective Date. Author is not responsible +for developing or debugging code. +

+ +

+TERMINATION +

+ +

+Author may terminate Yours license if You fails to comply with any of the terms +and conditions of this Agreement. On termination all copies of the Software +and all of its component parts must be destroyed. +

+ +

+DISCLAIMERS +

+ +

+The Software is provided "as is" without any warranty of any kind, either +expressed or implied. In no event will Author be liable for any loss of profit +or any other commercial damage, including but not limited to special, +incidental, consequential or other damages. +

+ +

+The Effective Date of this Agreement is the date You receives access to the +source code. +

+ +

+If you have any questions regarding this Agreement, please contact to Author +at the e-mail addresses: +

+ +

+ab@cable.netlux.org +

+ + +

+

+ +Copyright © 2006-2009 +VIRT Laboratory. All rights reserved. + + + diff --git a/help/site_lic.htm b/help/site_lic.htm new file mode 100644 index 0000000..a497758 --- /dev/null +++ b/help/site_lic.htm @@ -0,0 +1,158 @@ + + + + + + + +

+paxCompiler Site License +

+
+ +

+DEFINITIONS +

+ +

+"Software" means paxCompiler compiler in any form (source code, object code, dcu-s, dll, or other). The Software +is the sole property of Alexander Baranovsky (hereinafter "Author"). +

+ +

+"Source Code" means all source of the paxCompiler. +

+ +

+"You" means the organization or individual that purchases the Source License +Agreement. +

+ +

+LICENSE +

+ +

+This is a non-exclusive, non-transferable, non-sublicensable license for the +Source Code. You may not use the Software for any purpose other than stated +in this license. +

+ +

+You may integrate the Source Code with your applications and distribute these +applications (executable programs) royalty free. +

+ +

+You may not distribute any part of the paxCompiler source code, object files, +dcu-s, under any circumstances. +

+ +

+The Source Code may be used an unlimited number of developers to use the Source Code +for commercial application development and apply for support within the company +holding the license. The number of developers can be changed at any time. +

+ +

+DELIVERY +

+ +

+Software and any updates will be delivered electronically. You acknowledges +delivery by downloading. +

+ +

+COPYRIGHT NOTICE +

+ +

+You agree not to remove or alter any of Author's copyright notices in the +Source Code. +

+ + +

+NON-COMPETITION +

+ +

+You agree not to create any software component product(s) that directly +competes with paxCompiler, which utilizes all or any portion of paxCompiler +and its related source code. +

+ +

+CONFIDENTIALITY +

+ +

+You agrees not to disclose the Source Code to any third party for any reason. +

+ +

+UPDATES AND UPGRADES +

+ +

+Author will make available to You the Source Code corresponding to any updates +and upgrades to the Source Code released by Author during 15 monthes +following the effective date of this agreement. You is responsible to integrate +any updates to the Source Code into modified versions that You have developed. +

+ +

+SUPPORT +

+ +

+Author will provide e-mail support to You for general questions about the +Source Code for 15 monthes after the Effective Date. Author is not responsible +for developing or debugging code. +

+ +

+TERMINATION +

+ +

+Author may terminate Yours license if You fails to comply with any of the terms +and conditions of this Agreement. On termination all copies of the Software +and all of its component parts must be destroyed. +

+ +

+DISCLAIMERS +

+ +

+The Software is provided "as is" without any warranty of any kind, either +expressed or implied. In no event will Author be liable for any loss of profit +or any other commercial damage, including but not limited to special, +incidental, consequential or other damages. +

+ +

+The Effective Date of this Agreement is the date You receives access to the +source code. +

+ +

+If you have any questions regarding this Agreement, please contact to Author +at the e-mail addresses: +

+ +

+ab@cable.netlux.org +

+ + +

+

+ +Copyright © 2006-2009 +VIRT Laboratory. All rights reserved. + + + diff --git a/help/styles.css b/help/styles.css new file mode 100644 index 0000000..387e166 --- /dev/null +++ b/help/styles.css @@ -0,0 +1,6 @@ +body {background:white;font-family:helvetica;font-size:11pt} +td {background:#dddddd;font-family:helvetica;font-size:11pt} +td.white {background:white;font-family:helvetica;font-size:11pt} +table {background:#dddddd;font-family:helvetica} +table.white {background:white;font-family:helvetica} +pre {background:#dddddd} diff --git a/help/third-party.htm b/help/third-party.htm new file mode 100644 index 0000000..6ef375c --- /dev/null +++ b/help/third-party.htm @@ -0,0 +1,62 @@ + + + + + + + + + +

+paxCompiler Third-party Tools +

+
+ +
    + + +
  • +paxCompiler Importer. Author: Serge Voloshenyuk. + + + + +
  • +paxCompiler Importer. Author: Ivan Dyachenko. + +
    + +Features: + +
      +
    • Create the list of imported modules, classes, variable etc. +
    • Remembers all changes. +
    • Remembers the list of all imported types from all imported +modules. +
    • Allows to edit a pattern of an imported file (IMPORT.tpl). +
    + +
    + + +
  • +Smart paxCompiler Importer. Author: Joe Oszlanczi. + +
    +
    + + + +
+ +

+

+ +Copyright © 2006-2009 +VIRT Laboratory. All rights reserved. + + + diff --git a/help/title.htm b/help/title.htm new file mode 100644 index 0000000..a59b503 --- /dev/null +++ b/help/title.htm @@ -0,0 +1,30 @@ + + + + + + + + + + + + +
+paxcompiler.jpg +
+ + +

+ + +About paxCompiler +References +paxCompiler FAQ + +

+

+ + + + diff --git a/help/tpaxcompiler_events.htm b/help/tpaxcompiler_events.htm new file mode 100644 index 0000000..989907f --- /dev/null +++ b/help/tpaxcompiler_events.htm @@ -0,0 +1,206 @@ + + + + +

+TPaxCompiler Events +

+
+ +

TPaxCompiler.OnCompilerProgress

 + +
+Occurs at compile-time. +
+property OnCompilerProgress: TOnCompilerProgress;
+
+where
+
+TPaxCompilerNotifyEvent = procedure (Sender: TPaxCompiler) of object;
+TOnCompilerProgress = TPaxCompilerNotifyEvent;
+
+

+

+Example +

+
+procedure TForm1.PaxCompiler1CompilerProgress(Sender: TPaxCompiler);
+begin
+  Application.ProcessMessages;
+end;
+
+

+
+

TPaxCompiler.OnUsedUnit

 + +
+Occurs when compiler processes the uses clause, it allows you to assign source code of unit at compile-time. +
+property OnUsedUnit: TPaxCompilerUsedUnitEvent
+
+type
+  TPaxCompilerUsedUnitEvent = function (Sender: TPaxCompiler; const UnitName: String; var SourceCode: String): Boolean of object;
+
+

+

+Example +

+
+unit Unit1;
+
+interface
+
+uses
+  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
+  Dialogs, PaxProgram, PaxCompiler, StdCtrls;
+
+type
+  TForm1 = class(TForm)
+    Button1: TButton;
+    PaxCompiler1: TPaxCompiler;
+    PaxPascalLanguage1: TPaxPascalLanguage;
+    PaxProgram1: TPaxProgram;
+    procedure Button1Click(Sender: TObject);
+    function PaxCompiler1UsedUnit(Sender: TPaxCompiler;
+      const UnitName: String; var SourceCode: String): Boolean;
+  private
+    { Private declarations }
+  public
+    { Public declarations }
+  end;
+
+var
+  Form1: TForm1;
+
+implementation
+
+{$R *.dfm}
+
+procedure TForm1.Button1Click(Sender: TObject);
+begin
+  PaxCompiler1.Reset;
+  PaxCompiler1.RegisterLanguage(PaxPascalLanguage1);
+  PaxCompiler1.AddModule('main', 'Pascal');
+  PaxCompiler1.AddCode('main', 'uses SomeUnit;');
+  PaxCompiler1.AddCode('main', 'begin');
+  PaxCompiler1.AddCode('main', '  P;');
+  PaxCompiler1.AddCode('main', 'end.');
+  if PaxCompiler1.Compile(PaxProgram1) then
+  begin
+    PaxProgram1.Run;
+  end
+  else
+    ShowMessage(PaxCompiler1.ErrorMessage[0]);
+end;
+
+function TForm1.PaxCompiler1UsedUnit(Sender: TPaxCompiler;
+  const UnitName: String; var SourceCode: String): Boolean;
+begin
+  if UnitName = 'SomeUnit' then
+  begin
+    result := true;
+    SourceCode :=
+
+    'unit SomeUnit;' + #13#10 +
+    'interface' + #13#10 +
+    'procedure P;' + #13#10 +
+    'implementation' + #13#10 +
+    'procedure P;' + #13#10 +
+    'begin' + #13#10 +
+    '  ShowMessage(''Hello'');' + #13#10 +
+    'end;' + #13#10 +
+    'end.' + #13#10;
+
+  end
+  else
+    result := false; // default processing
+end;
+
+initialization
+  RegisterHeader(0, 'procedure ShowMessage(const Msg: string);', @ShowMessage);
+end.
+
+

+
+

TPaxCompiler.OnSavePCU

 + +
+Occurs when paxCompiler saves compiled unit. +
+property OnSavePCU: TPaxCompilerSavePCUEvent;
+
+TPaxCompilerSavePCUEvent = function (Sender: TPaxCompiler; const UnitName: String
+                              ): TStream of object;
+
+

+By default, paxCompiler saves compiled units on disk. Use this event to redirect saving pcu to a stream to avoid disk operations. +

+
+

TPaxCompiler.OnLoadPCU

 + +
+Occurs when paxCompiler tries to load pcu-file. +
+property OnLoadPCU: TPaxCompilerLoadPCUEvent;
+
+TPaxCompilerLoadPCUEvent = function (Sender: TPaxCompiler; const UnitName: String
+                              ): TStream of object;
+
+

+By default, paxCompiler loads pcu-files from disk. Use this event to load pcu from a stream. +

+
+

TPaxCompiler.OnInclude

 + +
+Occurs when paxCompiler tries to load an included file. +
+property OnInclude: TPaxCompilerIncludeEvent;
+
+TPaxCompilerIncludeEvent = procedure (Sender: TObject; const FileName: String;
+                                var Text: String) of object;
+
+

+By default, paxCompiler loads included files from disk. Use this event to assign content of included file. +

+
+

TPaxCompiler.OnDefineDirective

 + +
+Occurs when paxCompiler processes a define directive. +
+property OnDefineDirective: TPaxCompilerDirectiveEvent;
+
+TPaxCompilerDirectiveEvent = procedure (Sender: TPaxCompiler;
+                          const Directive: String; var ok: Boolean) of object;
+
+
+

TPaxCompiler.OnUndefineDirective

 + +
+Occurs when paxCompiler processes an undefine directive. +
+property OnUndefineDirective: TPaxCompilerDirectiveEvent;
+
+TPaxCompilerDirectiveEvent = procedure (Sender: TPaxCompiler;
+                          const Directive: String; var ok: Boolean) of object;
+
+
+

TPaxCompiler.OnUnknownDirective

 + +
+Occurs when paxCompiler processes an unknown directive. +
+property OnUnknownDirective: TPaxCompilerDirectiveEvent;
+
+
+ diff --git a/help/tpaxcompiler_methods.htm b/help/tpaxcompiler_methods.htm new file mode 100644 index 0000000..cfec31b --- /dev/null +++ b/help/tpaxcompiler_methods.htm @@ -0,0 +1,1227 @@ + + + + +

+TPaxCompiler Methods +

+
+ +

TPaxCompiler.AddCode

 + +
+Adds source code to module. +
+procedure AddCode(const ModuleName, Text: String);
+
+

+

+Example +

+
+AddCode('MyModule', 'begin');
+AddCode('MyModule', 'writeln(123);');
+AddCode('MyModule', 'end.');
+
+

+
+

TPaxCompiler.AddCodeFromFile

 + +
+Adds source code from text file to module. +
+procedure AddCodeFromFile(const ModuleName, FileName: String);
+
+

+

+Example +

+
+AddCodeFromFile('MyModule', 'MyFile.pas');
+
+

+
+

TPaxCompiler.AddModule

 + +
+Adds source code module to compiler. +
+procedure AddModule(const Name, LanguageName: String);
+
+

+

+Example +

+
+AddModule('MyModule', 'Pascal');
+
+

+
+

TPaxCompiler.Compile

 + +
+Compiles program. +
+function Compile(PaxProgram: TPaxProgram;
+                     BuildAll: Boolean = false;
+                     BuildWithRuntimePackages: Boolean = false): boolean; overload;
+
+

+Arguments +

+
+PaxProgram +
+TPaxProgram instance that saves result of compilation. +
+
+
+BuildAll +
+Build all compiled units (pcu-files). +
+
+
+BuildWithRuntimePackages +
+If true, PaxProgram will use pcu-s as run-time packages +
+
+

+

+Example +

+
+procedure TForm1.Button1Click(Sender: TObject);
+var
+  I: Integer;
+  PaxCompiler1: TPaxCompiler;
+  PaxPascalLanguage1: TPaxPascalLanguage;
+  PaxProgram1: TPaxProgram;
+begin
+  PaxCompiler1 := TPaxCompiler.Create(nil);
+  PaxPascalLanguage1 := TPaxPascalLanguage.Create(nil);
+  PaxProgram1 := TPaxProgram.Create(nil);
+
+  try
+    PaxCompiler1.RegisterLanguage(PaxPascalLanguage1);
+
+    // register routine 'ShowMessage'
+    H_ShowMessage := PaxCompiler1.RegisterRoutine(0, 'ShowMessage', _typeVOID, _ccREGISTER);
+    PaxCompiler1.RegisterParameter(H_ShowMessage, _typeSTRING, _Unassigned);
+
+    // register variable 'S'
+    H_S := PaxCompiler1.RegisterVariable(0, 'S', _typeSTRING);
+
+    PaxCompiler1.AddModule('1', PaxPascalLanguage1.LanguageName);
+    PaxCompiler1.AddCode('1', 'begin');
+    PaxCompiler1.AddCode('1', '  ShowMessage(S);');
+    PaxCompiler1.AddCode('1', 'end.');
+
+    if PaxCompiler1.Compile(PaxProgram1) then
+    begin
+      PaxProgram1.SaveToFile('1.bin');
+      ShowMessage('Compiled script has been created!');
+    end
+    else
+      for I:=0 to PaxCompiler1.ErrorCount - 1 do
+        ShowMessage(PaxCompiler1.ErrorMessage[I]);
+  finally
+    PaxCompiler1.Free;
+    PaxPascalLanguage1.Free;
+    PaxProgram1.Free;
+  end;
+end;
+
+

+
+

TPaxCompiler.CompileExpression

 + +
+Compiles expression. +
+function CompileExpression(const Expression: String;
+PaxProgram: TPaxProgram): Boolean;
+
+

+

+Example +

+
+unit Unit1;
+
+interface
+
+uses
+  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
+  Dialogs, StdCtrls, PaxCompiler;
+
+type
+  TForm1 = class(TForm)
+    Button1: TButton;
+    Button2: TButton;
+    procedure Button1Click(Sender: TObject);
+    procedure Button2Click(Sender: TObject);
+    procedure FormCreate(Sender: TObject);
+  private
+    { Private declarations }
+    arr_x, arr_y: array[1..3] of Double;
+    h_norm, h_x, h_y: Integer;
+
+    buff: array[1..4096] of Byte;
+  public
+    { Public declarations }
+  end;
+
+var
+  Form1: TForm1;
+
+implementation
+
+{$R *.dfm}
+
+function Norm(x, y: Double): Double;
+begin
+  result := Sqrt(x * x + y * y);
+end;
+
+procedure TForm1.Button1Click(Sender: TObject);
+var
+  PaxCompiler1: TPaxCompiler;
+  PaxPascalLanguage1: TPaxPascalLanguage;
+  PaxProgram1: TPaxProgram;
+  I: Integer;
+begin
+  PaxCompiler1 := TPaxCompiler.Create(nil);
+  PaxPascalLanguage1 := TPaxPascalLanguage.Create(nil);
+  PaxProgram1 := TPaxProgram.Create(nil);
+
+  try
+    PaxCompiler1.Reset;
+    PaxCompiler1.RegisterLanguage(PaxPascalLanguage1);
+
+    h_norm := PaxCompiler1.RegisterRoutine(0, 'Norm', _typeDOUBLE, _ccREGISTER);
+    PaxCompiler1.RegisterParameter(h_norm, _typeDOUBLE, Unassigned);
+    PaxCompiler1.RegisterParameter(h_norm, _typeDOUBLE, Unassigned);
+
+    h_x := PaxCompiler1.RegisterVariable(0, 'x', _typeDOUBLE);
+    h_y := PaxCompiler1.RegisterVariable(0, 'y', _typeDOUBLE);
+
+    if PaxCompiler1.CompileExpression('Norm(x, y)', PaxProgram1) then
+    begin
+      PaxProgram1.SaveToBuff(buff);
+      ShowMessage('Compiled expression has been created!');
+    end
+    else
+      for I:=0 to PaxCompiler1.ErrorCount - 1 do
+        ShowMessage(PaxCompiler1.ErrorMessage[I]);
+  finally
+    PaxCompiler1.Free;
+    PaxPascalLanguage1.Free;
+    PaxProgram1.Free;
+  end;
+end;
+
+procedure TForm1.Button2Click(Sender: TObject);
+var
+  PaxProgram1: TPaxProgram;
+  ResValue: Double;
+  I: Integer;
+begin
+{$O-}
+  if h_x <> 0 then
+  begin
+    PaxProgram1 := TPaxProgram.Create(nil);
+    try
+      PaxProgram1.LoadFromBuff(buff);
+
+      PaxProgram1.SetAddress(h_norm, @norm);
+
+      for I:=1 to 3 do
+      begin
+        PaxProgram1.SetAddress(h_x, @arr_x[I]);
+        PaxProgram1.SetAddress(h_y, @arr_y[I]);
+
+        PaxProgram1.Run;
+
+        ResValue := Double(PaxProgram1.ResultPtr^);
+        ShowMessage(FloatToStr(ResValue));
+      end;
+
+    finally
+      PaxProgram1.Free;
+    end;
+  end
+  else
+    ShowMessage('Press the first button to create compiled script.');
+end;
+
+procedure TForm1.FormCreate(Sender: TObject);
+begin
+  h_x := 0; h_y := 0; h_norm := 0;
+  arr_x[1] := 4.2;   arr_y[1] := -5.2;
+  arr_x[2] := -0.4;  arr_y[2] := 3.2;
+  arr_x[3] := 2.0;   arr_y[3] := 3;
+end;
+
+end.
+
+

+
+

TPaxCompiler.Create

 + +
+Constructor of TPaxCompiler class. +
+constructor Create(AOwner: TComponent); override;
+
+
+

TPaxCompiler.Destroy

 + +
+Destructor of TPaxCompiler class. +
+destructor Destroy; override;
+
+
+

TPaxCompiler.GetHandle

 + +
+Returns id of a script-defined variable, procedure or function. +
+function GetHandle(LevelId: Integer; const Name: String; Upcase: Boolean): Integer;
+
+

+Arguments +

+
+LevelId +
+Id of namespace. +
+
+
+Name +
+Name of the script-defined variable, procedure or function. +
+
+
+Upcase +
+If 'false', the search of id will be case sensitive. +
+
+

+

+Example +

+
+procedure TForm1.Button1Click(Sender: TObject);
+var
+  H_ShowMessage, H_IntToStr, H_X: Integer;
+  P: Pointer;
+  I: Integer;
+begin
+  PaxCompiler1.Reset;
+  PaxCompiler1.RegisterLanguage(PaxPascalLanguage1);
+
+  H_ShowMessage := PaxCompiler1.RegisterRoutine(0, 'ShowMessage', _typeVOID, _ccREGISTER);
+  PaxCompiler1.RegisterParameter(H_ShowMessage, _typeSTRING, _Unassigned);
+
+  H_IntToStr := PaxCompiler1.RegisterRoutine(0, 'IntToStr', _typeSTRING, _ccREGISTER);
+  PaxCompiler1.RegisterParameter(H_IntToStr, _typeINTEGER, _Unassigned);
+
+  PaxCompiler1.AddModule('1', PaxPascalLanguage1.LanguageName);
+  PaxCompiler1.AddCode('1', 'var x: Integer = 5;');
+  PaxCompiler1.AddCode('1', 'begin');
+  PaxCompiler1.AddCode('1', '  ShowMessage(''script:'' + IntToStr(x));');
+  PaxCompiler1.AddCode('1', 'end.');
+
+  if PaxCompiler1.Compile(PaxProgram1) then
+  begin
+    H_X := PaxCompiler1.GetHandle(0, 'x', true);
+
+    PaxProgram1.SetAddress(H_ShowMessage, @ShowMessage);
+    PaxProgram1.SetAddress(H_IntToStr, @IntToStr);
+    PaxProgram1.Run; // the first run
+    if H_X <> 0 then
+    begin
+      P := PaxProgram1.GetAddress(H_X);
+      ShowMessage('host:' + IntToStr(Integer(P^))); // show script-defined variable
+    end;
+
+    Integer(P^) := 30; // change script-defind variable
+
+    PaxProgram1.Run; // the second run
+  end
+  else
+    for I:=0 to PaxCompiler1.ErrorCount do
+      ShowMessage(PaxCompiler1.ErrorMessage[I]);
+end;
+
+

+
+

TPaxCompiler.RegisterTypeDeclaration

 + +
+Allows you to register enumeration type, subrange type, set type, shortstring type by its declaration. +
+function RegisterTypeDeclaration(LevelId: Integer;
+const Declaration: String): Integer;
+
+

+Arguments +

+
+LevelId +
+Id of namespace. +
+
+
+Declaration +
+Type declaration. +
+
+

+RegisterTypeDeclaration(0, 'TMyEnum = (one, two, three);'); +

+
+

TPaxCompiler.RegisterInterfaceType

 + +
+Registeres an interface type. +
+function RegisterInterfaceType(LevelId: Integer;
+const TypeName: String; const GUID: TGUID): Integer;
+
+

+Arguments +

+
+LevelId +
+Id of namespace. +
+
+
+TypeName +
+Name of type. +
+
+
+GUID +
+GUID of interface type. +
+
+
+

TPaxCompiler.RegisterSupportedInterface

 + +
+Registeres supported interface type. +
+procedure RegisterSupportedInterface(TypeId: Integer;
+const GUID: TGUID);
+
+

+Arguments +

+
+TypeId +
+Id of interface type. +
+
+
+GUID +
+GUID of suppported interface type. +
+
+
+

TPaxCompiler.RegisterClassType

 + +
+Registeres class type for paxCompiler. +
+function RegisterClassType(LevelId: Integer; onst TypeName: String; AncestorId: Integer): Integer; overload;
+function RegisterClassType(LevelId: Integer; C: TClass): Integer; overload;
+
+

+

+Example +

+
+H_HostClass := compiler.RegisterClassType(0, THostClass);
+
+

+
+

TPaxCompiler.RegisterClassReferenceType

 + +
+Registeres class reference type for paxCompiler. +
+function RegisterClassReferenceType(LevelId: Integer; const TypeName: String; OriginClassId: Integer): Integer;
+
+

+

+Example +

+
+H := RegisterNamespace(0, 'Classes');
+G := RegisterClassType(H, TPersistent);
+RegisterClassReferenceType(H, 'TPersistentClass', G);
+
+

+
+

TPaxCompiler.RegisterClassTypeField

 + +
+Registers field of class type for paxCompiler. +
+function RegisterClassTypeField(TypeId: Integer; const FieldName: String; FieldTypeID: Integer; FieldShift: Integer = -1): Integer;
+
+

+

+Example +

+
+type
+  THostClass = class(TComponent)
+    Z: Integer;
+  end;
+
+.............................
+H_HostClass := compiler.RegisterClassType(0, THostClass);
+compiler.RegisterHeader(H_HostClass, 'constructor Create(AOwner: TComponent);', @THostClass.Create);
+H_Z := compiler.RegisterClassTypeField(H_HostClass, 'Z', typeINTEGER, Integer(@THostClass(nil).Z));
+
+

+
+

TPaxCompiler.RegisterProperty

 + +
+Registeres public property for paxCompiler. +
+function RegisterProperty(LevelId: Integer; const PropName: String; PropTypeID, ReadId, WriteId: Integer;IsDefault: Boolean): Integer; overload;
+function RegisterProperty(LevelId: Integer; const Header: String): Integer; overload;
+
+

+

+Example +

+
+H_HostClass := compiler.RegisterClassType(0, THostClass);
+compiler.RegisterHeader(H_HostClass, 'constructor Create(AOwner: TComponent);', @THostClass.Create);
+H_GetItem := compiler.RegisterHeader(H_HostClass, 'function GetItem(I, J: Integer): Integer;', @THostClass.GetItem);
+H_SetItem := compiler.RegisterHeader(H_HostClass, 'procedure SetItem(I, J: Integer; Value: Integer);', @THostClass.SetItem);
+compiler.RegisterProperty(H_HostClass, 'property Items[I, J: Integer]: Integer read GetItem write SetItem; default;');
+
+

+
+

TPaxCompiler.RegisterEnumType

 + +
+Registeres enumeration type for paxCompiler. +
+function RegisterEnumType(LevelId: Integer; const TypeName: String; TypeBaseId: Integer = _typeINTEGER): Integer;
+
+

+

+Example +

+
+H_TMyEnum := RegisterEnumType(0, 'TMyEnum');
+RegisterEnumValue(H_TMyEnum, 'Green', 0);
+RegisterEnumValue(H_TMyEnum, 'Red', 1);
+
+

+
+

TPaxCompiler.RegisterEnumValue

 + +
+Registeres a value of enumeration type. +
+function RegisterEnumValue(EnumTypeId: Integer; const FieldName: String; const Value: Integer): Integer;
+
+

+

+Example +

+
+H_TMyEnum := RegisterEnumType(0, 'TMyEnum');
+RegisterEnumValue(H_TMyEnum, 'Green', 0);
+RegisterEnumValue(H_TMyEnum, 'Red', 1);
+
+

+
+

TPaxCompiler.RegisterRTTIType

 + +
+Registeres a Delphi type that has RTTI (Run time type information) for paxCompiler. +
+function RegisterRTTIType(LevelId: Integer; pti: PTypeInfo): Integer;
+
+

+

+Example +

+
+RegisterRTTIType(TypeInfo(TMyEnum));
+
+

+
+

TPaxCompiler.RegisterTypeAlias

 + +
+Registeres type alias for paxCompiler. +
+function RegisterTypeAlias(LevelId:Integer;
+const TypeName: String; OriginTypeId: Integer): Integer;
+
+

+

+Example +

+
+RegisterTypeAlias(H, 'Longint', _typeINTEGER);
+
+

+
+

TPaxCompiler.RegisterArrayType

 + +
+Registeres array type for paxCompiler. +
+function RegisterArrayType(LevelId: Integer; const TypeName: String; RangeTypeId, ElemTypeId: Integer): Integer;
+
+

+Arguments +

+
+LevelId +
+Id of namespace. +
+
+
+TypeName +
+Name of array type. +
+
+
+RangeTypeId +
+Id of ordinal type that specifies range of array. +
+
+
+ElemType +
+Id of type that specifies type of array element. +
+
+

+

+Example +

+
+H_Range := PaxCompiler1.RegisterSubrangeType(0, 'MySubrangeType', _typeCHAR, ord('A'), ord('Z'));
+H_TMyPoint := PaxCompiler1.RegisterRecordType(0, 'TMyPoint');
+PaxCompiler1.RegisterRecordTypeField(H_TMyPoint, 'X', _typeINTEGER);
+PaxCompiler1.RegisterRecordTypeField(H_TMyPoint, 'Y', _typeINTEGER);
+H_Array := PaxCompiler1.RegisterArrayType(0, 'MyArray', H_Range, H_TMyPoint);
+
+

+
+

TPaxCompiler.RegisterDynamicArrayType

 + +
+Registeres dynamic array type. Returns id of type. +
+function RegisterDynamicArrayType(LevelId: Integer;
+const TypeName: String; ElemTypeId: Integer): Integer;
+
+

+Arguments +

+
+LevelId +
+Id of namespace. +
+
+
+TypeName +
+Name of type. +
+
+
+ElemTypeId +
+Id of type of array element. +
+
+
+

TPaxCompiler.RegisterLanguage

 + +
+Registeres component that represents programming language for paxCompiler. +
+procedure RegisterLanguage(L: TPaxCompilerLanguage);
+
+

+

+Example +

+
+var PaxCompiler1: TPaxCompiler;
+    PaxPascalLanguage1: TPaxPascalLanguage;
+begin
+  PaxCompiler1 := TPaxCompiler.Create(nil);
+  PaxPascalLanguage1 := TPaxPascalLanguage.Create(nil);
+  PaxCompiler1.RegisterLanguage(PaxPascalLanguage1);
+................
+
+

+
+

TPaxCompiler.RegisterNamespace

 + +
+Registeres a namespace for the paxCompiler. +
+function RegisterNamespace(LevelId: Integer; const NamespaceName: String): Integer;
+
+

+Arguments +

+
+LevelId +
+Id of owner namespace. +
+
+
+NamespaceName +
+Name of namespace. +
+
+

+

+Example +

+
+id := RegisterNamespace(0, 'MyNamespace'); // 0 represents noname namespace
+RegisterVariable(id, 'MyVar', _typeINTEGER, @MyVar);
+
+

+
+

TPaxCompiler.RegisterRecordType

 + +
+Registeres a record type. +
+function RegisterRecordType(LevelId: Integer; const TypeName: String): Integer;
+
+

+Arguments +

+
+LevelId +
+Id of owner record type or id of namespace. +
+
+
+TypeName +
+Name of record type. +
+
+

+

+Example +

+
+H_TMyPoint := PaxCompiler1.RegisterRecordType(0, 'TMyPoint');
+PaxCompiler1.RegisterRecordTypeField(H_TMyPoint, 'X', _typeINTEGER);
+PaxCompiler1.RegisterRecordTypeField(H_TMyPoint, 'Y', _typeINTEGER);
+
+

+
+

TPaxCompiler.RegisterRoutine

 + +
+Registeres header of function or procedure for paxCompiler. +
+function RegisterRoutine(LevelId: Integer; const Name: String; ResultTypeID: Integer; CallConvention: Integer): Integer;
+
+

+Arguments +

+
+LevelId +
+Id of owner namespace. +
+
+
+Name +
+Name of procedure or function. +
+
+
+ResultTypeID +
+Id of result type. +
+
+
+CallConvention +
+_ccSTDCALL = 1 +_ccREGISTER = 2 +
+
+

+

+Example +

+
+H_IntToStr := PaxCompiler1.RegisterRoutine(0, 'IntToStr', _typeSTRING, _ccREGISTER);
+PaxCompiler1.RegisterParameter(H_IntToStr, _typeINTEGER, _Unassigned);
+
+

+
+

TPaxCompiler.RegisterMethod

 + +
+Registeres method of Delphi class. +
+function RegisterMethod(LevelId: Integer; const MethodName: String; ResultTypeID: Integer; CallConvention: Integer; Address: Pointer = nil; IsShared: Boolean = false): Integer;
+
+

+Arguments +

+
+LevelId +
+Id of class. +
+
+
+MethodName +
+Name of method. +
+
+
+ResultTypeID +
+Id of type of result. +
+
+
+CallConvention +
+Call convention. +
+
+
+IsShared +
+True, if it is static (shared) method. +
+
+

+

+Example +

+
+compiler.RegisterMethod(H_HostClass, 'MyMethod', _typeINTEGER, ccREGISTER, @THostClass.MyMethod, false);
+
+

+
+

TPaxCompiler.RegisterConstructor

 + +
+Registeres construcor of a Delphi class for paxCompiler. +
+function RegisterConstructor(LevelId: Integer; const SubName: String; Address: Pointer = nil): Integer;
+
+

+

+Example +

+
+H := compiler.RegisterConstructor(H_HostClass, 'Create', @THostClass.Create);
+
+

+
+

TPaxCompiler.RegisterParameter

 + +
+Registeres parameter of a host-defined procedure of function. +
+function RegisterParameter(HSub: Integer; ParamTypeID: Integer; const DefaultValue: Variant; ByRef: Boolean = false): Integer;
+
+

+Arguments +

+
+HSub +
+Id of routine. +
+
+
+ParamTypeId +
+Id of type of parameter. +
+
+
+DefaultValue +
+Default value of parameter. +
+
+
+ByRef +
+If 'true', this is the variable parameter, otherwise this is the value parameter. +
+
+

+

+Example +

+
+H_IntToStr := PaxCompiler1.RegisterRoutine(0, 'IntToStr', _typeSTRING, _ccREGISTER);
+PaxCompiler1.RegisterParameter(H_IntToStr, _typeINTEGER, _Unassigned);
+
+

+
+

TPaxCompiler.RegisterPointerType

 + +
+Registeres a pointer type for paxCompiler. +
+function RegisterPointerType(LevelId: Integer;
+const TypeName: String; OriginTypeId: Integer): Integer;
+
+

+Arguments +

+
+LevelId +
+Id of namespace. +
+
+
+TypeName +
+Name of pointer type. +
+
+
+OriginTypeId +
+Id of origin type. +
+
+

+

+Example +

+
+H_TMyPoint := PaxCompiler1.RegisterRecordType(0, 'TMyPoint');
+PaxCompiler1.RegisterRecordTypeField(H_TMyPoint, 'X', _typeINTEGER);
+PaxCompiler1.RegisterRecordTypeField(H_TMyPoint, 'Y', _typeINTEGER);
+H_PMyPoint := PaxCompiler1.RegisterPointerType(0, 'PMyPoint', H_TMyPoint);
+
+

+
+

TPaxCompiler.RegisterProceduralType

 + +
+Registeres a procedural type for paxCompiler. +
+function RegisterProceduralType(LevelId: Integer; const TypeName: String; SubId: Integer): Integer;
+
+

+Arguments +

+
+LevelId +
+Id of namespace. +
+
+
+TypeName +
+Name of type. +
+
+
+SubId +
+Id of header of a subroutine. +
+
+

+

+Example +

+
+H_IntToStr := PaxCompiler1.RegisterRoutine(0, 'IntToStr', _typeSTRING, _ccREGISTER);
+PaxCompiler1.RegisterParameter(H_IntToStr, _typeINTEGER, _Unassigned);
+H_FuncType := PaxCompiler1.RegisterProceduralType(0, 'TFuncType', H_IntToStr);
+
+

+
+

TPaxCompiler.RegisterSetType

 + +
+Registeres a set type for paxCompiler. +
+function RegisterSetType(LevelId: Integer; const TypeName: String; OriginTypeId: Integer): Integer;
+
+

+Arguments +

+
+LevelId +
+Id of namespace. +
+
+
+TypeName +
+Name of set type. +
+
+
+OriginTypeId +
+Id of origin type. +
+
+

+

+Example +

+
+RegisterSetType(0, 'TMySet', _typeCHAR);
+
+

+
+

TPaxCompiler.RegisterSubrangeType

 + +
+Registeres a subrange type for the paxCompiler. +
+function RegisterSubrangeType(LevelId: Integer; const TypeName: String; TypeBaseId: Integer; const B1, B2: Integer): Integer;
+
+

+Arguments +

+
+LevelId +
+Id of namespace. +
+
+
+TypeName +
+Name of subrange type. +
+
+
+TypeBaseId +
+Id of base type. +
+
+
+B1 +
+Low bound. +
+
+
+B2 +
+High bound. +
+
+

+

+Example +

+
+PaxCompiler1.RegisterSubrangeType(0, 'MySubrangeType', _typeCHAR, ord('A'), ord('Z'));
+
+

+
+

TPaxCompiler.RegisterConstant

 + +
+Registeres a constant for paxCompiler. +
+function RegisterConstant(LevelId: Integer; const ConstName: String; typeID: Integer; const Value: Variant): Integer; overload;
+
+function RegisterConstant(LevelId: Integer; const ConstName: String; const Value: Variant): Integer; overload;
+
+

+

+Example +

+
+RegisterConstant(H, 'fmOpenRead', fmOpenRead);
+
+

+
+

TPaxCompiler.RegisterVariable

 + +
+Registeres a host-defined variable for paxCompiler. +
+function RegisterVariable(LevelId: Integer; const Name: String; TypeId: Integer; Address: Pointer = nil): Integer;
+
+

+Arguments +

+
+LevelId +
+Id of namespace +
+
+
+Name +
+Name of variable. +
+
+
+TypeId +
+Id of variables's type. +
+
+
+Address +
+Optional. Address of variable. +
+
+

+

+Example +

+
+H_MyVar := PaxCompiler1.RegisterVariable(0, 'MyVar', _typeSINGLE);
+
+

+
+

TPaxCompiler.RegisterHeader

 + +
+Registeres header of host-defined procedure, function, constructor or method for paxCompiler. +
+function RegisterHeader(LevelId: Integer; const Header: String; Address: Pointer = nil;
+MethodIndex: Integer = 0): Integer;
+
+

+

+Example 1 +

+
+RegisterHeader(H, 'function UpperCase(const S: string): string;', @UpperCase);
+
+

+

+

+Example 2 +

+
+RegisterHeader(H_TList, 'function Add(Item: Pointer): Integer;', @TList.Add);
+
+

+

+

+Example 3 +

+
+RegisterHeader(H_TList, 'constructor Create;', @TList.Create);
+
+

+
+

TPaxCompiler.Reset

 + +
+Removes all source code modules and registered items from compiler. +
+procedure Reset;
+
+
+

TPaxCompiler.ResetCompilation

 + +
+Removes source code modules. +
+procedure ResetCompilation;
+
+
+ diff --git a/help/tpaxcompiler_properties.htm b/help/tpaxcompiler_properties.htm new file mode 100644 index 0000000..e5e7b1d --- /dev/null +++ b/help/tpaxcompiler_properties.htm @@ -0,0 +1,85 @@ + + + + + +

+TPaxCompiler Properties +

+
+ +

TPaxCompiler.DebugMode

 + +
+Allows you to pause script with TProgram.Pause method. +
+property DebugMode: Boolean;
+
+

+Default value of the property is 'false'. +

+
+

TPaxCompiler.ErrorCount

 + +
+Returns number of compile-time errors. +
+property ErrorCount: Integer
+
+
+

TPaxCompiler.ErrorLine

 + +
+Returns line of source module of an error in the error list. +
+property ErrorLine[I: Integer]: String
+
+
+

TPaxCompiler.ErrorLineNumber

 + +
+Returns line number of source module of an error in the error list. +
+property ErrorLineNumber[I: Integer]: Integer
+
+
+

TPaxCompiler.ErrorModuleName

 + +
+Returns module name of an error in the error list. +
+property ErrorModuleName[I: Integer]: String
+
+
+

TPaxCompiler.ErrorMessage

 + +
+Returns error message of an error in the error list. +
+property ErrorMessage[I: Integer]: String
+
+
+

TPaxCompiler.Modules

 + +
+Returns source code modules as string list. +
+property Modules[const ModuleName: String]: TStringList
+
+
+

+

+ +Copyright © 2006-2009 +VIRT Laboratory. All rights reserved. + + + diff --git a/help/tpaxcompiler_register.htm b/help/tpaxcompiler_register.htm new file mode 100644 index 0000000..e25dbca --- /dev/null +++ b/help/tpaxcompiler_register.htm @@ -0,0 +1,1039 @@ + + + + + + +

+TPaxCompiler Registration Routines +

+
+ +

RegisterTypeDeclaration

 + +
+Registeres set type, enumeration type, subrange type or shortstring type by its declaration. +
+function RegisterTypeDeclaration(LevelId: Integer;
+const Declaration: String): integer;
+
+

+Arguments +

+
+LevelId +
+Id of namespace. +
+
+
+Declaration +
+Declaration of type. +
+
+

+

+Example +

+
+RegisterTypeDeclaration(0, 'TString5 = String[5];');
+
+

+
+

RegisterInterfaceType

 + +
+Registeres an interface type. +
+function RegisterInterfaceType(LevelId: Integer;
+const TypeName: String; const GUID: TGUID): Integer;
+
+

+Arguments +

+
+LevelId +
+Id of namespace. +
+
+
+TypeName +
+Name of interface type. +
+
+
+GUID +
+GUID of interface type. +
+
+
+

RegisterSupportedInterface

 + +
+Registeres supported interface type. +
+procedure RegisterSupportedInterface(TypeId: Integer;
+const GUID: TGUID);
+
+

+Arguments +

+
+TypeId +
+Id of an interface type. +
+
+
+GUID +
+GUID of supported interface type. +
+
+
+

RegisterClassType

 + +
+Registeres class type for paxCompiler. +
+function RegisterClassType(LevelId: Integer; const TypeName: String; AncestorId: Integer): Integer; overload;
+function RegisterClassType(LevelId: Integer; C: TClass): Integer; overload;
+
+

+

+Example +

+
+H_HostClass := RegisterClassType(0, THostClass);
+
+

+
+

RegisterClassReferenceType

 + +
+Registeres class reference type for paxCompiler. +
+function RegisterClassReferenceType(LevelId: Integer; const TypeName: String; OriginClassId: Integer): Integer;
+
+

+

+Example +

+
+H := RegisterNamespace(0, 'Classes');
+G := RegisterClassType(H, TPersistent);
+RegisterClassReferenceType(H, 'TPersistentClass', G);
+
+

+
+

RegisterClassTypeField

 + +
+Registers field of class type for paxCompiler. +
+function RegisterClassTypeField(TypeId: Integer; const FieldName: String; FieldTypeID: Integer; FieldShift: Integer = -1): Integer;
+
+

+

+Example +

+
+type
+  THostClass = class(TComponent)
+    Z: Integer;
+  end;
+
+.............................
+H_HostClass := RegisterClassType(0, THostClass);
+RegisterHeader(H_HostClass, 'constructor Create(AOwner: TComponent);', @THostClass.Create);
+H_Z := RegisterClassTypeField(H_HostClass, 'Z', typeINTEGER, Integer(@THostClass(nil).Z));
+
+

+
+

RegisterProperty

 + +
+Registeres public property for paxCompiler. +
+function RegisterProperty(LevelId: Integer; const PropName: String; PropTypeID, ReadId, WriteId: Integer;IsDefault: Boolean): Integer; overload;
+function RegisterProperty(LevelId: Integer; const Header: String): Integer; overload;
+
+

+

+Example +

+
+H_HostClass := RegisterClassType(0, THostClass);
+RegisterHeader(H_HostClass, 'constructor Create(AOwner: TComponent);', @THostClass.Create);
+H_GetItem := RegisterHeader(H_HostClass, 'function GetItem(I, J: Integer): Integer;', @THostClass.GetItem);
+H_SetItem := RegisterHeader(H_HostClass, 'procedure SetItem(I, J: Integer; Value: Integer);', @THostClass.SetItem);
+RegisterProperty(H_HostClass, 'property Items[I, J: Integer]: Integer read GetItem write SetItem; default;');
+
+

+
+

RegisterEnumType

 + +
+Registeres enumeration type for paxCompiler. +
+function RegisterEnumType(LevelId: Integer; const TypeName: String; TypeBaseId: Integer = _typeINTEGER): Integer;
+
+

+

+Example +

+
+H_TMyEnum := RegisterEnumType(0, 'TMyEnum');
+RegisterEnumValue(H_TMyEnum, 'Green', 0);
+RegisterEnumValue(H_TMyEnum, 'Red', 1);
+
+

+
+

RegisterEnumValue

 + +
+Registeres a value of enumeration type. +
+function RegisterEnumValue(EnumTypeId: Integer; const FieldName: String; const Value: Integer): Integer;
+
+

+

+Example +

+
+H_TMyEnum := RegisterEnumType(0, 'TMyEnum');
+RegisterEnumValue(H_TMyEnum, 'Green', 0);
+RegisterEnumValue(H_TMyEnum, 'Red', 1);
+
+

+
+

RegisterRTTIType

 + +
+Registeres a Delphi type that has RTTI (Run time type information) for paxCompiler. +
+function RegisterRTTIType(LevelId: Integer; pti: PTypeInfo): Integer;
+
+

+

+Example +

+
+RegisterRTTIType(TypeInfo(TMyEnum));
+
+

+
+

RegisterTypeAlias

 + +
+Registeres type alias for paxCompiler. +
+function RegisterTypeAlias(LevelId:Integer;
+const TypeName: String; OriginTypeId: Integer): Integer;
+
+

+

+Example +

+
+RegisterTypeAlias(H, 'Longint', _typeINTEGER);
+
+

+
+

RegisterArrayType

 + +
+Registeres array type for paxCompiler. +
+function RegisterArrayType(LevelId: Integer; const TypeName: String; RangeTypeId, ElemTypeId: Integer): Integer;
+
+

+Arguments +

+
+LevelId +
+Id of namespace. +
+
+
+TypeName +
+Name of array type. +
+
+
+RangeTypeId +
+Id of ordinal type that specifies range of array. +
+
+
+ElemType +
+Id of type that specifies type of array element. +
+
+

+

+Example +

+
+H_Range := RegisterSubrangeType(0, 'MySubrangeType', _typeCHAR, ord('A'), ord('Z'));
+H_TMyPoint := RegisterRecordType(0, 'TMyPoint');
+RegisterRecordTypeField(H_TMyPoint, 'X', _typeINTEGER);
+RegisterRecordTypeField(H_TMyPoint, 'Y', _typeINTEGER);
+H_Array := RegisterArrayType(0, 'MyArray', H_Range, H_TMyPoint);
+
+

+
+

RegisterDynamicArrayType

 + +
+Registeres dynamic array type for paxCompiler. Returns id of type. +
+function RegisterDynamicArrayType(LevelId: Integer;
+const TypeName: String; ElemTypeId: Integer): Integer;
+
+

+Arguments +

+
+LevelId +
+Id of namespace. +
+
+
+TypeName +
+Name of type. +
+
+
+ElemTypeId +
+Id of type of array element. +
+
+
+

RegisterNamespace

 + +
+Registeres a namespace for the paxCompiler. +
+function RegisterNamespace(LevelId: Integer; const NamespaceName: String): Integer;
+
+

+Arguments +

+
+LevelId +
+Id of owner namespace. +
+
+
+NamespaceName +
+Name of namespace. +
+
+

+

+Example +

+
+id := RegisterNamespace(0, 'MyNamespace'); // 0 represents noname namespace
+RegisterVariable(id, 'MyVar', _typeINTEGER, @MyVar);
+
+

+
+

RegisterRecordType

 + +
+Registeres a record type. +
+function RegisterRecordType(LevelId: Integer; const TypeName: String): Integer;
+
+

+Arguments +

+
+LevelId +
+Id of owner record type or id of namespace. +
+
+
+TypeName +
+Name of record type. +
+
+

+

+Example +

+
+H_TMyPoint := RegisterRecordType(0, 'TMyPoint');
+RegisterRecordTypeField(H_TMyPoint, 'X', _typeINTEGER);
+RegisterRecordTypeField(H_TMyPoint, 'Y', _typeINTEGER);
+
+

+
+

RegisterRoutine

 + +
+Registeres header of function or procedure for paxCompiler. +
+function RegisterRoutine(LevelId: Integer; const Name: String; ResultTypeID: Integer; CallConvention: Integer): Integer;
+
+

+Arguments +

+
+LevelId +
+Id of owner namespace. +
+
+
+Name +
+Name of procedure or function. +
+
+
+ResultTypeID +
+Id of result type. +
+
+
+CallConvention +
+_ccSTDCALL = 1 +_ccREGISTER = 2 +
+
+

+

+Example +

+
+H_IntToStr := RegisterRoutine(0, 'IntToStr', _typeSTRING, _ccREGISTER);
+RegisterParameter(H_IntToStr, _typeINTEGER, _Unassigned);
+
+

+
+

RegisterMethod

 + +
+Registeres method of Delphi class. +
+function RegisterMethod(LevelId: Integer; const MethodName: String; ResultTypeID: Integer; CallConvention: Integer; Address: Pointer = nil; IsShared: Boolean = false): Integer;
+
+

+Arguments +

+
+LevelId +
+Id of class. +
+
+
+MethodName +
+Name of method. +
+
+
+ResultTypeID +
+Id of type of result. +
+
+
+CallConvention +
+Call convention. +
+
+
+IsShared +
+True, if it is static (shared) method. +
+
+

+

+Example +

+
+RegisterMethod(H_HostClass, 'MyMethod', _typeINTEGER, ccREGISTER, @THostClass.MyMethod, false);
+
+

+
+

RegisterConstructor

 + +
+Registeres construcor of a Delphi class for paxCompiler. +
+function RegisterConstructor(LevelId: Integer; const SubName: String; Address: Pointer = nil): Integer;
+
+

+

+Example +

+
+H := RegisterConstructor(H_HostClass, 'Create', @THostClass.Create);
+
+

+
+

RegisterParameter

 + +
+Registeres parameter of a host-defined procedure of function. +
+function RegisterParameter(HSub: Integer; ParamTypeID: Integer; const DefaultValue: Variant; ByRef: Boolean = false): Integer;
+
+

+Arguments +

+
+HSub +
+Id of routine. +
+
+
+ParamTypeId +
+Id of type of parameter. +
+
+
+DefaultValue +
+Default value of parameter. +
+
+
+ByRef +
+If 'true', this is the variable parameter, otherwise this is the value parameter. +
+
+

+

+Example +

+
+H_IntToStr := RegisterRoutine(0, 'IntToStr', _typeSTRING, _ccREGISTER);
+RegisterParameter(H_IntToStr, _typeINTEGER, _Unassigned);
+
+

+
+

RegisterPointerType

 + +
+Registeres a pointer type for paxCompiler. +
+function RegisterPointerType(LevelId: Integer;
+const TypeName: String; OriginTypeId: Integer): Integer;
+
+

+Arguments +

+
+LevelId +
+Id of namespace. +
+
+
+TypeName +
+Name of pointer type. +
+
+
+OriginTypeId +
+Id of origin type. +
+
+

+

+Example +

+
+H_TMyPoint := RegisterRecordType(0, 'TMyPoint');
+RegisterRecordTypeField(H_TMyPoint, 'X', _typeINTEGER);
+RegisterRecordTypeField(H_TMyPoint, 'Y', _typeINTEGER);
+H_PMyPoint := RegisterPointerType(0, 'PMyPoint', H_TMyPoint);
+
+

+
+

RegisterProceduralType

 + +
+Registeres a procedural type for paxCompiler. +
+function RegisterProceduralType(LevelId: Integer; const TypeName: String; SubId: Integer): Integer;
+
+

+Arguments +

+
+LevelId +
+Id of namespace. +
+
+
+TypeName +
+Name of type. +
+
+
+SubId +
+Id of header of a subroutine. +
+
+

+

+Example +

+
+H_IntToStr := RegisterRoutine(0, 'IntToStr', _typeSTRING, _ccREGISTER);
+RegisterParameter(H_IntToStr, _typeINTEGER, _Unassigned);
+H_FuncType := RegisterProceduralType(0, 'TFuncType', H_IntToStr);
+
+

+
+

RegisterSetType

 + +
+Registeres a set type for paxCompiler. +
+function RegisterSetType(LevelId: Integer; const TypeName: String; OriginTypeId: Integer): Integer;
+
+

+Arguments +

+
+LevelId +
+Id of namespace. +
+
+
+TypeName +
+Name of set type. +
+
+
+OriginTypeId +
+Id of origin type. +
+
+

+

+Example +

+
+RegisterSetType(0, 'TMySet', _typeCHAR);
+
+

+
+

RegisterSubrangeType

 + +
+Registeres a subrange type for the paxCompiler. +
+function RegisterSubrangeType(LevelId: Integer; const TypeName: String; TypeBaseId: Integer; const B1, B2: Integer): Integer;
+
+

+Arguments +

+
+LevelId +
+Id of namespace. +
+
+
+TypeName +
+Name of subrange type. +
+
+
+TypeBaseId +
+Id of base type. +
+
+
+B1 +
+Low bound. +
+
+
+B2 +
+High bound. +
+
+

+

+Example +

+
+RegisterSubrangeType(0, 'MySubrangeType', _typeCHAR, ord('A'), ord('Z'));
+
+

+
+

RegisterConstant

 + +
+Registeres a constant for paxCompiler. +
+function RegisterConstant(LevelId: Integer; const ConstName: String; typeID: Integer; const Value: Variant): Integer; overload;
+
+function RegisterConstant(LevelId: Integer; const ConstName: String; const Value: Variant): Integer; overload;
+
+

+

+Example +

+
+RegisterConstant(H, 'fmOpenRead', fmOpenRead);
+
+

+
+

RegisterVariable

 + +
+Registeres a host-defined variable for paxCompiler. +
+function RegisterVariable(LevelId: Integer; const Name: String; TypeId: Integer; Address: Pointer = nil): Integer;
+
+

+Arguments +

+
+LevelId +
+Id of namespace +
+
+
+Name +
+Name of variable. +
+
+
+TypeId +
+Id of variables's type. +
+
+
+Address +
+Optional. Address of variable. +
+
+

+

+Example +

+
+H_MyVar := RegisterVariable(0, 'MyVar', _typeSINGLE);
+
+

+
+

RegisterHeader

 + +
+Registeres header of host-defined procedure, function, constructor or method for paxCompiler. +
+function RegisterHeader(LevelId: Integer; const Header: String; Address: Pointer = nil;
+MethodIndex: Integer = 0): Integer;
+
+

+

+Example 1 +

+
+RegisterHeader(H, 'function UpperCase(const S: string): string;', @UpperCase);
+
+

+

+

+Example 2 +

+
+RegisterHeader(H_TList, 'function Add(Item: Pointer): Integer;', @TList.Add);
+
+

+

+

+Example 3 +

+
+RegisterHeader(H_TList, 'constructor Create;', @TList.Create);
+
+

+
+

ForbidPublishedProperty

 + +
+The ForbidPublishedProperty does not allow to use a published property of a host-defined type in scripts. +
+procedure ForbidPublishedProperty(C: TClass; const PropName: String);
+
+
+

ForbidAllPublishedProperties

 + +
+The ForbidAllPublishedProperties does not allow to use published properties of a host-defined type in scripts. +
+procedure ForbidAllPublishedProperties(C: TClass);
+
+
+

LookupTypeId

 + +
+Returns Id of type. +
+function LookupTypeId(const TypeName: String): Integer;
+
+

+Arguments +

+
+TypeName +
+Name of type. +
+
+
+

LookupNamespace

 + +
+Returns Id of namespace. +
+function LookupNamespace(LevelId: Integer; const NamespaceName: String; CaseSensitive: Boolean): Integer;
+
+
+

RegisterUsingNameSpace

 + +
+Includes namespace into scope of type lookup. +
+procedure RegisterUsingNameSpace(const aNameSpaceName: String); overload;
+
+
+

UnregisterUsingNameSpace

 + +
+Removes namespace from the scope of type lookup. +
+procedure UnregisterUsingNameSpace(const aNameSpaceName: String); overload;
+
+
+

UnregisterUsingNameSpaces

 + +
+Removes all namespaces from the scope of type lookup. (These namespaces could be included by RegisterUsingNamespace routine). +
+procedure UnregisterUsingNameSpaces;
+
+
+

RegisterAlignment

 + +
+Registeres default alignment. +
+procedure RegisterAlignment(value: Integer);
+
+

+Arguments +

+
+value +
+1, 2, 4 or 8. +
+
+
+

SetVisibility

 + +
+Sets up visibility of the host-defined class member. +
+procedure SetVisibility(C: TClass; const MemberName: String; value: Integer);
+
+

+Arguments +

+
+value +
+0 - public, 1 - protected, 2 - private. +
+
+
+

SaveNamespaceToStream

 + +
+Saves host-defined namespace (unit) to a stream. +
+procedure SaveNamespaceToStream(const NamespaceName: String; S: TStream);
+
+

+Arguments +

+
+NamespaceName +
+Name of namespace. +
+
+

+See ..\Demos\DemoLoadNamespace in a trial package for Delphi. +

+Example +

+
+SaveNamespaceToStream('SysUtils', Stream);
+
+

+
+

SaveNamespaceToFile

 + +
+Saves a precompiled host-defined namespace (unit) to file. +
+procedure SaveNamespaceToFile(const NamespaceName: String; const FileName: String);
+
+

+See ..\Demos\DemoLoadNamespace in a trial package for Delphi. +

+Example +

+
+SaveNamespaceToFile('SysUtils', 'SysUtils.bin');
+
+

+
+

LoadNamespaceFromStream

 + +
+Loads a precompiled host-defined namespace (unit) from stream. +
+procedure LoadNamespaceFromStream(S: TStream);
+
+

+See ..\Demos\DemoLoadNamespace in a trial package for Delphi. +

+Example +

+
+LoadNamespaceFromStream('SysUtils', Stream);
+
+

+
+

LoadNamespaceFromFile

 + +
+Loads a precompiled host-defined namespace from file. +
+procedure LoadNamespaceFromFile(const FileName: String);
+
+

+See ..\Demos\DemoLoadNamespace in a trial package for Delphi. +

+Example +

+
+LoadNamespaceFromFile('SysUtils', 'SysUtils.bin');
+
+

+
+

EndOfRegistration

 + +
+Notifies paxCompiler that process of registration host-defined types has been finished. +
+procedure EndOfRegistration;
+
+

+The routine forces paxCompiler to perform type checking in all imported members. +

+
+ +

+

+ +Copyright © 2006-2009 +VIRT Laboratory. All rights reserved. + + + diff --git a/help/tpaxcompilerdebugger_methods.htm b/help/tpaxcompilerdebugger_methods.htm new file mode 100644 index 0000000..26169ab --- /dev/null +++ b/help/tpaxcompilerdebugger_methods.htm @@ -0,0 +1,307 @@ + + + + + +

+TPaxCompilerDebugger Methods +

+
+ +

TPaxCompilerDebugger.Create

 + +
+Constructor of the component. +
+constructor Create(AOwner: TComponent); override;
+
+
+

TPaxCompilerDebugger.Destroy

 + +
+Destructor of the component. +
+destructor Destroy; override;
+
+
+

TPaxCompilerDebugger.RegisterCompiler

 + +
+Registeres TPaxCompiler and TPaxProgram instances for debugger. +
+procedure RegisterCompiler(i_compiler: TPaxCompiler;
+i_prog: TPaxProgram);
+
+
+

TPaxCompilerDebugger.Run

 + +
+Runs script. +
+procedure Run;
+
+
+

TPaxCompilerDebugger.IsPaused

 + +
+Returns 'true', if debugger is paused. +
+function IsPaused: Boolean;
+
+
+

TPaxCompilerDebugger.GetValueAsString

 + +
+Returns value of variable as string. +
+function GetValueAsString(StackFrameNumber, Id: Integer): String; overload;
+function GetValueAsString(Id: Integer): String; overload;
+
+

+Arguments +

+
+Id +
+Id of variable. +
+
+
+StackFrameNumber +
+Number of stack frame. +
+
+
+

TPaxCompilerDebugger.GetFieldValueAsString

 + +
+Returns value of a record field or a class instance field as string. +
+function GetFieldValueAsString(StackFrameNumber: Integer; Id, FieldNumber: Integer): String;
+
+

+Arguments +

+
+StackFrameNumber +
+Number of stack frame. +
+
+
+Id +
+Id of variable. +
+
+
+FieldNumber +
+Number of field. +
+
+
+

TPaxCompilerDebugger.GetArrayItemValueAsString

 + +
+Returns value of array element as string. +
+function GetArrayItemValueAsString(StackFrameNumber: Integer; Id, Index: Integer): String;
+
+

+Arguments +

+
+StackFrameNumber +
+Number of stack frame. +
+
+
+Id +
+Id of array variable +
+
+
+Index +
+Index of array element. +
+
+
+

TPaxCompilerDebugger.GetDynArrayLength

 + +
+Returns length of dynamic array. +
+function GetDynArrayLength(StackFrameNumber, Id: Integer): Integer;
+
+

+Arguments +

+
+StackFrameNumber +
+Number of stack frame. +
+
+
+Id +
+Id of dynamic array. +
+
+
+

TPaxCompilerDebugger.GetDynArrayItemValueAsString

 + +
+Returns value of dynamic array as string. +
+function GetDynArrayItemValueAsString(StackFrameNumber: Integer; Id, Index: Integer): String;
+
+

+Arguments +

+
+Stack frame number +
+Number of stack frame. +
+
+
+Id +
+Id of variable. +
+
+
+Index +
+Index of array element. +
+
+
+

TPaxCompilerDebugger.AddBreakpoint

 + +
+Adds breakpoint. +
+procedure AddBreakpoint(const ModuleName: String;
+SourceLine: Integer);
+
+

+Arguments +

+
+ModuleName +
+Name of module. +
+
+
+SourceLine +
+Number of source line. +
+
+
+

TPaxCompilerDebugger.AddTempBreakpoint

 + +
+Adds temporary breakpoint. +
+procedure AddTempBreakpoint(const ModuleName: String;
+                                SourceLine: Integer);
+
+

+Arguments +

+
+ModuleName +
+Name of module. +
+
+
+SourceLine +
+Number of source line. +
+
+

+Use AddTempBreakpoint to implement "Run to Cursor". +

+
+

TPaxCompilerDebugger.RemoveBreakpoint

 + +
+Removes breakpoint. +
+procedure RemoveBreakpoint(const ModuleName: String;
+SourceLine: Integer);
+
+

+Arguments +

+
+ModuleName +
+Name of module. +
+
+
+SourceLine +
+Number of source line. +
+
+
+

TPaxCompilerDebugger.HasBreakpoint

 + +
+Returns 'true', if there is a breakpoint in module 'ModuleName' at line number'SourceLine'. +
+function HasBreakpoint(const ModuleName: String;
+SourceLine: Integer): Boolean;
+
+

+Arguments +

+
+ModuleName +
+Name of module. +
+
+
+SourceLine +
+Number of source line. +
+
+
+

+

+ +Copyright © 2006-2009 +VIRT Laboratory. All rights reserved. + + + diff --git a/help/tpaxcompilerdebugger_properties.htm b/help/tpaxcompilerdebugger_properties.htm new file mode 100644 index 0000000..0ad21cd --- /dev/null +++ b/help/tpaxcompilerdebugger_properties.htm @@ -0,0 +1,109 @@ + + + + + + +

+TPaxCompilerDebugger Properties +

+
+ +

TPaxCompilerDebugger.CallStackCount

 + +
+Count returns the number of items in the call stack. +
+property CallStackCount: Integer;
+
+
+

TPaxCompilerDebugger.CallStack

 + +
+Returns id of function in the call stack. +
+property CallStack[I: Integer]: Integer;
+
+

+Arguments +

+
+I +
+Stack frame number. +
+
+
+

TPaxCompilerDebugger.CallStackLineNumber

 + +
+Returns caller's line number. +
+property CallStackLineNumber[I: Integer]: Integer;
+
+
+

TPaxCompilerDebugger.CallStackModuleName

 + +
+Returns caller's module name. +
+property CallStackModuleName[I: Integer]: String;
+
+
+

TPaxCompilerDebugger.ModuleName

 + +
+Returns name of current module at the paused state of debugger. +
+property ModuleName: String;
+
+
+

TPaxCompilerDebugger.RunMode

 + +
+Determines a run mode. +
+property RunMode: Integer;
+
+

+Accepts the followung values: + _rmRUN = 0; + _rmTRACE_INTO = 1; + _rmSTEP_OVER = 2; + _rmRUN_TO_CURSOR = 3; +

+
+

TPaxCompilerDebugger.SourceLineNumber

 + +
+Returns current source line number at the paused state of debugger. +
+property SourceLineNumber: Integer;
+
+
+

TPaxCompilerDebugger.Valid

 + +
+Returns 'true', if debugger contains valid program. +
+property Valid: Boolean;
+
+
+ +

+

+ +Copyright © 2006-2009 +VIRT Laboratory. All rights reserved. + + + diff --git a/help/tpaxcompilerexplorer_methods.htm b/help/tpaxcompilerexplorer_methods.htm new file mode 100644 index 0000000..5f04932 --- /dev/null +++ b/help/tpaxcompilerexplorer_methods.htm @@ -0,0 +1,690 @@ + + + + + +

+TPaxCompilerExplorer Methods +

+
+ +

TPaxCompilerExplorer.Create

 + +
+Constructor of the component. +
+constructor Create(AOwner: TComponent); override;
+
+
+

TPaxCompilerExplorer.Destroy

 + +
+Destructor of the component. +
+destructor Destroy; override;
+
+
+

TPaxCompilerExplorer.RegisterCompiler

 + +
+Registeres TPaxCompiler component. +
+procedure RegisterCompiler(i_compiler: TPaxCompiler);
+
+
+

TPaxCompilerExplorer.IsExecutableLine

 + +
+Returns 'true', if line is executable. +
+function IsExecutableLine(const ModuleName: String;
+LineNumber: Integer): Boolean;
+
+

+Arguments +

+
+ModuleName +
+Name of module. +
+
+
+LineNumber +
+Number of line. +
+
+
+

TPaxCompilerExplorer.GetParamCount

 + +
+Returns number of parameters of function. +
+function GetParamCount(SubId: Integer): Integer;
+
+

+Arguments +

+
+SubId +
+Id of function. +
+
+
+

TPaxCompilerExplorer.GetParamId

 + +
+Returns Id of parameter of function. +
+function GetParamId(SubId, I: Integer): Integer;
+
+

+Arguments +

+
+SubId +
+Id of function. +
+
+
+I +
+Index of parameter. +
+
+
+

TPaxCompilerExplorer.GetLocalCount

 + +
+Returns number of local variables of function. +
+function GetLocalCount(SubId: Integer): Integer;
+
+

+Arguments +

+
+SubId +
+Id of function. +
+
+
+

TPaxCompilerExplorer.GetGlobalCount

 + +
+Returns number of global variables in a namespace. +
+function GetGlobalCount(NamespaceId: Integer): Integer;
+
+

+Arguments +

+
+NamespaceId +
+Id of namespace. Use Id = 0 for noname namespace. +
+
+
+

TPaxCompilerExplorer.GetGlobalId

 + +
+Returns number of global variables in a namespace. +
+function GetGlobalId(NamespaceId, I: Integer): Integer;
+
+

+Arguments +

+
+NamespaceId +
+Id of namespace. +
+
+
+I +
+Index of variable. +
+
+
+

TPaxCompilerExplorer.HasArrayType

 + +
+Returns 'true', if variable has array type. +
+function HasArrayType(Id: Integer): Boolean;
+
+

+Arguments +

+
+Id +
+Id of variable. +
+
+
+

TPaxCompilerExplorer.HasDynArrayType

 + +
+Returns 'true', if variable has dynamic array type. +
+function HasDynArrayType(Id: Integer): Boolean;
+
+

+Arguments +

+
+Id +
+Id of variable. +
+
+
+

TPaxCompilerExplorer.HasRecordType

 + +
+Returns 'true', if variable has record type. +
+function HasRecordType(Id: Integer): Boolean;
+
+

+Arguments +

+
+Id +
+Id of variable. +
+
+
+

TPaxCompilerExplorer.HasClassType

 + +
+Returns 'true', if variable has class type. +
+function HasClassType(Id: Integer): Boolean;
+
+

+Arguments +

+
+Id +
+Id of variable. +
+
+
+

TPaxCompilerExplorer.IsArrayType

 + +
+Returns 'true', if Id represents array type. +
+function IsArrayType(Id: Integer): Boolean;
+
+

+Arguments +

+
+Id +
+Id of type. +
+
+
+

TPaxCompilerExplorer.IsDynArrayType

 + +
+Returns 'true', if Id represents dynamic array type. +
+function IsDynArrayType(Id: Integer): Boolean;
+
+

+Arguments +

+
+Id +
+Id of type. +
+
+
+

TPaxCompilerExplorer.IsRecordType

 + +
+Returns 'true', if Id represents record type. +
+function IsRecordType(Id: Integer): Boolean;
+
+

+Arguments +

+
+Id +
+Id of type. +
+
+
+

TPaxCompilerExplorer.IsClassType

 + +
+Returns 'true', if Id represents class type. +
+function IsClassType(Id: Integer): Boolean;
+
+

+Arguments +

+
+Id +
+Id of type. +
+
+
+

TPaxCompilerExplorer.Host

 + +
+Returns 'true', if Id represents a host-defined variable, constant, type or function. +
+function Host(Id: Integer): Boolean;
+
+

+Arguments +

+
+Id +
+Id of variable, constant, type or function. +
+
+
+

TPaxCompilerExplorer.GetFieldCount

 + +
+Returns number of fields of variable of class or record type. +
+function GetFieldCount(Id: Integer): Integer;
+
+

+Arguments +

+
+Id +
+Id of variable. +
+
+
+

TPaxCompilerExplorer.GetFieldName

 + +
+Returns name of field. +
+function GetFieldName(Id, FieldNumber: Integer): String;
+
+

+Arguments +

+
+Id +
+Id of variable. +
+
+
+FieldNumber +
+Number of field. +
+
+
+

TPaxCompilerExplorer.GetArrayLowBound

 + +
+Returns low bound of array. +
+function GetArrayLowBound(Id: Integer): Integer;
+
+

+Arguments +

+
+Id +
+Id of array. +
+
+
+

TPaxCompilerExplorer.GetArrayHighBound

 + +
+Returns high bound of array. +
+function GetArrayHighBound(Id: Integer): Integer;
+
+

+Arguments +

+
+Id +
+Id of array. +
+
+
+

TPaxCompilerExplorer.EnumMembers

 + +
+Allows you to enumerate all members of script. +
+procedure EnumMembers(OwnerId: Integer; Host: Boolean; mk: TMemberKind; CallBack: TExplorerEnumProc; Data: Pointer);
+
+

+Arguments +

+
+OwnerId +
+Id of namespace, class type, record type or function. +
+
+
+Host +
+Set it to 'true', if you enumerates host-defined members, or set it to 'false', if you enumerates script-defined members. +
+
+
+mk +
+Kind of member. It has type TMemberKind = (mkNamespace, mkType, mkField, mkProperty, mkProcedure, mkFunction, mkConstructor, mkDestructor, mkParam, mkVar, mkConst); +
+
+
+CallBack +
+Call-back method. It has type TExplorerEnumProc = procedure (Id: Integer; Host: Boolean; Kind: TMemberKind; +Data: Pointer) of object; +
+
+
+Data +
+Pointer to user-defined data. +
+
+
+

TPaxCompilerExplorer.IsConst

 + +
+Returns 'true', if Id represents a constant. +
+function IsConst(LevelId, Id: Integer): Boolean;
+
+

+Arguments +

+
+LevelId +
+Id of namespace. +
+
+
+Id +
+Source Id. +
+
+
+

TPaxCompilerExplorer.IsVar

 + +
+Returns 'true', if Id represents a variable. +
+function IsVar(LevelId, Id: Integer): Boolean;
+
+

+Arguments +

+
+LevelId +
+Id of namespace or function. +
+
+
+Id +
+Source Id. +
+
+
+

TPaxCompilerExplorer.IsProcedure

 + +
+Returns 'true', if Id represents global procedure, nested procedure or method (class procedure). +
+function IsProcedure(LevelId, Id: Integer): Boolean;
+
+

+Arguments +

+
+LevelId +
+Id of namespace, function or class type. +
+
+
+Id +
+Source Id. +
+
+
+

TPaxCompilerExplorer.IsFunction

 + +
+Returns 'true', if Id represents global function, nested function or method (class function). +
+function IsFunction(LevelId, Id: Integer): Boolean;
+
+

+Arguments +

+
+LevelId +
+Id of namespace, function or class type. +
+
+
+Id +
+Source Id. +
+
+
+

TPaxCompilerExplorer.IsNamespace

 + +
+Returns 'true', if Id represents a namespace. +
+function IsNamespace(LevelId, Id: Integer): Boolean;
+
+

+Arguments +

+
+LevelId +
+Id of owner namespace. +
+
+
+Id +
+Source Id. +
+
+
+

TPaxCompilerExplorer.IsType

 + +
+Returns 'true', if Id represents a type. +
+function IsType(LevelId, Id: Integer): Boolean;
+
+

+Arguments +

+
+LevelId +
+Id of namespace or function. +
+
+
+

TPaxCompilerExplorer.IsTypeField

 + +
+Returns 'true', if Id represents a record type field or a class type field. +
+function IsTypeField(TypeId, Id: Integer): Boolean;
+
+

+Arguments +

+
+TypeId +
+Id of type. +
+
+
+Id +
+Source Id. +
+
+
+

TPaxCompilerExplorer.IsProperty

 + +
+Returns 'true', if Id represent a property of type. +
+function IsProperty(TypeId, Id: Integer): Boolean;
+
+

+Arguments +

+
+TypeId +
+Id of type. +
+
+
+Id +
+Source Id. +
+
+
+

TPaxCompilerExplorer.IsConstructor

 + +
+Returns 'true', if Id represent a type constructor. +
+function IsConstructor(TypeId, Id: Integer): Boolean;
+
+

+Arguments +

+
+TypeId +
+Id of type. +
+
+
+Id +
+Source Id. +
+
+
+

TPaxCompilerExplorer.IsDestructor

 + +
+Returns 'true', if Id represents destructor of type. +
+function IsDestructor(TypeId, Id: Integer): Boolean;
+
+

+Arguments +

+
+TypeId +
+Id of type. +
+
+
+Id +
+Source Id. +
+
+
+

+

+ +Copyright © 2006-2009 +VIRT Laboratory. All rights reserved. + + + diff --git a/help/tpaxcompilerexplorer_properties.htm b/help/tpaxcompilerexplorer_properties.htm new file mode 100644 index 0000000..199f8d3 --- /dev/null +++ b/help/tpaxcompilerexplorer_properties.htm @@ -0,0 +1,73 @@ + + + + + +

+TPaxCompilerExplorer Properties +

+
+ +

TPaxCompilerExplorer.Names

 + +
+Returns name of variable represented by id. +
+property Names[Id: Integer]: String;
+
+

+Arguments +

+
+Id +
+Id of variable. +
+
+
+

TPaxCompilerExplorer.TypeNames

 + +
+Returns type name of variable represented by id. +
+property TypeNames[Id: Integer]: String;
+
+

+Arguments +

+
+Id +
+Id of variable. +
+
+
+

TPaxCompilerExplorer.Positions

 + +
+Returns position variable in source code. +
+property Positions[Id: Integer]: Integer;
+
+

+Arguments +

+
+Id +
+Id of variable. +
+
+
+

+

+ +Copyright © 2006-2009 +VIRT Laboratory. All rights reserved. + + + diff --git a/help/tpaxinvoke_methods.htm b/help/tpaxinvoke_methods.htm new file mode 100644 index 0000000..95b7743 --- /dev/null +++ b/help/tpaxinvoke_methods.htm @@ -0,0 +1,771 @@ + + + + + + +

+TPaxInvoke Methods +

+
+ +

TPaxInvoke.Create

 + +
+Constructor of TPaxInvoke class. +
+constructor Create(AOwner: TComponent); override;
+
+
+

TPaxInvoke.Destroy

 + +
+Destructor of TPaxInvoke class. +
+destructor Destroy; override;
+
+
+

TPaxInvoke.LoadAddress

 + +
+Loads dll and assigns address of a dll-defind functions to Address property. +
+procedure LoadAddress(const DllName, ProcName: String);
+
+

+

+Example +

+
+PaxInvoke1.This := nil;
+PaxInvoke1.CallConv := _ccMSFASTCALL;
+PaxInvoke1.LoadAddress('CppDll.dll', 'cube');
+PaxInvoke1.ClearArguments;
+PaxInvoke1.AddArgAsInteger(2);
+PaxInvoke1.SetResultAsInteger;
+PaxInvoke1.CallHost; 
+ShowMessage(IntToStr(Integer(PaxInvoke1.GetResultPtr^)));
+
+

+
+

TPaxInvoke.ClearArguments

 + +
+Clears arguments. +
+procedure ClearArguments;
+
+

+

+Example +

+
+function TForm1.Test(X, Y: Integer): Integer; stdcall;
+begin
+  result := X + Y;
+end;
+
+procedure TForm1.Button7Click(Sender: TObject);
+
+function P(X, Y: Currency): String; stdcall;
+begin
+  result := CurrToStr(X + Y);
+end;
+
+begin
+  PaxInvoke1.This := nil; // this is not a method
+  PaxInvoke1.CallConv := _ccSTDCALL;
+  PaxInvoke1.Address := @P;
+  PaxInvoke1.ClearArguments;
+  PaxInvoke1.AddArgAsCurrency(2.2);
+  PaxInvoke1.AddArgAsCurrency(3.4);
+  PaxInvoke1.SetResultAsAnsiString;
+  PaxInvoke1.CallHost; // call host-defined function
+  ShowMessage(String(PaxInvoke1.GetResultPtr^));
+  PaxInvoke1.ClearResult;
+
+  PaxInvoke1.This := Self; // this is a method
+  PaxInvoke1.CallConv := _ccSTDCALL;
+  PaxInvoke1.Address := @TForm1.Test;
+  PaxInvoke1.ClearArguments;
+  PaxInvoke1.AddArgAsInteger(2);
+  PaxInvoke1.AddArgAsInteger(3);
+  PaxInvoke1.SetResultAsInteger;
+  PaxInvoke1.CallHost; 
+  ShowMessage(IntToStr(Integer(PaxInvoke1.GetResultPtr^)));
+end;
+
+

+
+

TPaxInvoke.AddArgAsByte

 + +
+Adds argument of Byte type. +
+procedure AddArgAsByte(value: Byte);
+
+
+

TPaxInvoke.AddArgAsWord

 + +
+Adds argument of Word type. +
+procedure AddArgAsWord(value: Word);
+
+
+

TPaxInvoke.AddArgAsCardinal

 + +
+Adds argument of Cardinal type. +
+procedure AddArgAsCardinal(value: Cardinal);
+
+
+

TPaxInvoke.AddArgAsShortInt

 + +
+Adds argument of ShortInt type. +
+procedure AddArgAsShortInt(value: ShortInt);
+
+
+

TPaxInvoke.AddArgAsSmallInt

 + +
+Adds argument of SmallInt type. +
+procedure AddArgAsSmallInt(value: SmallInt);
+
+
+

TPaxInvoke.AddArgAsInteger

 + +
+Adds argument of Integer type. +
+procedure AddArgAsInteger(value: Integer);
+
+
+

TPaxInvoke.AddArgAsInt64

 + +
+Adds argument of Int64 type. +
+procedure AddArgAsInt64(value: Int64);
+
+
+

TPaxInvoke.AddArgAsLongBool

 + +
+Adds argument of LongBool type. +
+procedure AddArgAsLongBool(value: LongBool);
+
+
+

TPaxInvoke.AddArgAsWordBool

 + +
+Adds argument of WordBool type. +
+procedure AddArgAsWordBool(value: WordBool);
+
+
+

TPaxInvoke.AddArgAsBoolean

 + +
+Adds argument of Boolean type. +
+procedure AddArgAsBoolean(value: Boolean);
+
+
+

TPaxInvoke.AddArgAsChar

 + +
+Adds argument of Char type. +
+procedure AddArgAsChar(value: Char);
+
+
+

TPaxInvoke.AddArgAsWideChar

 + +
+Adds argument of WideChar type. +
+procedure AddArgAsWideChar(value: WideChar);
+
+
+

TPaxInvoke.AddArgAsDouble

 + +
+Adds argument of Double type. +
+procedure AddArgAsDouble(value: Double);
+
+
+

TPaxInvoke.AddArgAsSingle

 + +
+Adds argument of Single type. +
+procedure AddArgAsSingle(value: Single);
+
+
+

TPaxInvoke.AddArgAsExtended

 + +
+Adds argument of Extended type. +
+procedure AddArgAsExtended(value: Extended);
+
+
+

TPaxInvoke.AddArgAsCurrency

 + +
+Adds argument of Currency type. +
+procedure AddArgAsCurrency(value: Currency);
+
+
+

TPaxInvoke.AddArgAsAnsiString

 + +
+Adds argument of AnsiString type. +
+procedure AddArgAsAnsiString(const value: AnsiString);
+
+
+

TPaxInvoke.AddArgAsWideString

 + +
+Adds argument of WideString type. +
+procedure AddArgAsWideString(const value: WideString);
+
+
+

TPaxInvoke.AddArgAsShortString

 + +
+Adds argument of ShortString type. +
+procedure AddArgAsShortString(const value: ShortString);
+
+
+

TPaxInvoke.AddArgAsPChar

 + +
+Adds argument of PChar type. +
+procedure AddArgAsPChar(value: PChar);
+
+
+

TPaxInvoke.AddArgAsPWideChar

 + +
+Adds argument of PWideChar type. +
+procedure AddArgAsPWideChar(value: PWideChar);
+
+
+

TPaxInvoke.AddArgAsPointer

 + +
+Adds argument of Pointer type. +
+procedure AddArgAsPointer(value: Pointer);
+
+
+

TPaxInvoke.AddArgAsRecord

 + +
+Adds argument of a Record type. +
+procedure AddArgAsRecord(var value; Size: Integer);
+
+
+

TPaxInvoke.AddArgAsRecordByVal

 + +
+Adds argument of a record type. Argument is passed by value. +
+procedure AddArgAsRecordByVal(var value; Size: Integer);
+
+
+

TPaxInvoke.AddArgAsArray

 + +
+Adds argument of array type. +
+procedure AddArgAsArray(var value; Size: Integer);
+
+
+

TPaxInvoke.AddArgAsArrayByVal

 + +
+Adds argument of array type. Argument is passed by value. +
+procedure AddArgAsArrayByVal(var value; Size: Integer);
+
+
+

TPaxInvoke.AddArgAsDynArray

 + +
+Adds argument of a dynamic array type. +
+procedure AddArgAsDynArray(var value);
+
+
+

TPaxInvoke.AddArgAsObject

 + +
+Adds argument of a class type. +
+procedure AddArgAsObject(value: TObject);
+
+
+

TPaxInvoke.AddArgAsClassRef

 + +
+Adds argument of a class reference type. +
+procedure AddArgAsClassRef(value: TClass);
+
+
+

TPaxInvoke.AddArgAsVariant

 + +
+Adds argument of Variant type. +
+procedure AddArgAsVariant(const value: Variant);
+
+
+

TPaxInvoke.AddArgAsSet

 + +
+Adds argument of a set type. +
+procedure AddArgAsSet(var value; Size: Integer);
+
+
+

TPaxInvoke.AddArgAsInterface

 + +
+Adds argument of an interface type. +
+procedure AddArgAsInterface(const value: IUnknown);
+
+
+

TPaxInvoke.SetResultAsVoid

 + +
+Sets result type as void type (for procedures). +
+procedure SetResultAsVoid;
+
+
+

TPaxInvoke.SetResultAsByte

 + +
+Sets result type as Byte type. +
+procedure SetResultAsByte;
+
+
+

TPaxInvoke.SetResultAsWord

 + +
+Sets result type as Word type. +
+procedure SetResultAsWord;
+
+
+

TPaxInvoke.SetResultAsCardinal

 + +
+Sets result type as Cardinal type. +
+procedure SetResultAsCardinal;
+
+
+

TPaxInvoke.SetResultAsShortInt

 + +
+Sets result type as ShortInt type. +
+procedure SetResultAsShortInt;
+
+
+

TPaxInvoke.SetResultAsSmallInt

 + +
+Sets result type as SmallInt type. +
+procedure SetResultAsSmallInt;
+
+
+

TPaxInvoke.SetResultAsInteger

 + +
+Sets result type as Integer type. +
+procedure SetResultAsInteger;
+
+
+

TPaxInvoke.SetResultAsBoolean

 + +
+Sets result type as Boolean type. +
+procedure SetResultAsBoolean;
+
+
+

TPaxInvoke.SetResultAsWordBool

 + +
+Sets result type as WordBool type. +
+procedure SetResultAsWordBool;
+
+
+

TPaxInvoke.SetResultAsLongBool

 + +
+Sets result type as LongBool type. +
+procedure SetResultAsLongBool;
+
+
+

TPaxInvoke.SetResultAsChar

 + +
+Sets result type as Char type. +
+procedure SetResultAsChar;
+
+
+

TPaxInvoke.SetResultAsWideChar

 + +
+Sets result type as WideChar type. +
+procedure SetResultAsWideChar;
+
+
+

TPaxInvoke.SetResultAsDouble

 + +
+Sets result type as Double type. +
+procedure SetResultAsDouble;
+
+
+

TPaxInvoke.SetResultAsSingle

 + +
+Sets result type as Single type. +
+procedure SetResultAsSingle;
+
+
+

TPaxInvoke.SetResultAsExtended

 + +
+Sets result type as Extended type. +
+procedure SetResultAsExtended;
+
+
+

TPaxInvoke.SetResultAsCurrency

 + +
+Sets result type as Currency type. +
+procedure SetResultAsCurrency;
+
+
+

TPaxInvoke.SetResultAsAnsiString

 + +
+Sets result type as AnsiString type. +
+procedure SetResultAsAnsiString;
+
+
+

TPaxInvoke.SetResultAsWideString

 + +
+Sets result type as WideString type. +
+procedure SetResultAsWideString;
+
+
+

TPaxInvoke.SetResultAsShortString

 + +
+Sets result type as ShortString type. +
+procedure SetResultAsShortString;
+
+
+

TPaxInvoke.SetResultAsPChar

 + +
+Sets result type as PChar type. +
+procedure SetResultAsPChar;
+
+
+

TPaxInvoke.SetResultAsPWideChar

 + +
+Sets result type as PWideChar type. +
+procedure SetResultAsPWideChar;
+
+
+

TPaxInvoke.SetResultAsPointer

 + +
+Sets result type as a pointer type. +
+procedure SetResultAsPointer;
+
+
+

TPaxInvoke.SetResultAsArray

 + +
+Sets result type as an array type. +
+procedure SetResultAsArray(Size: Integer);
+
+
+

TPaxInvoke.SetResultAsDynArray

 + +
+Sets result type as a dynamic array type. +
+procedure SetResultAsDynArray;
+
+
+

TPaxInvoke.SetResultAsRecord

 + +
+Sets result type as a record type. +
+procedure SetResultAsRecord(Size: Integer);
+
+
+

TPaxInvoke.SetResultAsObject

 + +
+Sets result type as a class type. +
+procedure SetResultAsObject;
+
+
+

TPaxInvoke.SetResultAsClassRef

 + +
+Sets result type as a class reference type. +
+procedure SetResultAsClassRef;
+
+
+

TPaxInvoke.SetResultAsInterface

 + +
+Sets result type as an interface type. +
+procedure SetResultAsInterface;
+
+
+

TPaxInvoke.SetResultAsInt64

 + +
+Sets result type as Int64 type. +
+procedure SetResultAsInt64;
+
+
+

TPaxInvoke.CallHost

 + +
+Calls a host-defined function or method. +
+procedure CallHost;
+
+
+

TPaxInvoke.GetResultPtr

 + +
+Returns pointer to a result value. +
+function GetResultPtr: Pointer;
+
+

+You have to apply the type cast to extract a result value. +

+Example +

+
+type
+  TCharRec = record
+    X, Y: Char;
+  end;
+
+function MyHostFunc(const U, V: TCharRec): String; stdcall;
+begin
+  result := U.X + V.Y;
+end;
+
+var
+  R: TCharRec;
+  S: String;
+begin
+  R.X := 'a';
+  R.Y := 'b';
+
+  PaxInvoke1.Address := @ MyHostFunc;
+  PaxInvoke1.This := nil; // this is not a method, but global function
+  PaxInvoke1.ClearArguments;
+  PaxInvoke1.AddArgAsRecord(R, SizeOf(R));
+  PaxInvoke1.AddArgAsRecord(R, SizeOf(R));
+  PaxInvoke1.SetResultAsAnsiString;
+  PaxInvoke1.CallConv := _ccSTDCALL;
+  PaxInvoke1.CallHost; // call host-defined function
+  S := String(PaxInvoke1.GetResultPtr^);
+  ShowMessage(S);
+
+

+
+

TPaxInvoke.ClearResult

 + +
+If result type is a dynamic type such as AnsiString, Interface, Variant or dynamic array, you have to apply the ClearResult method to avoid a memory leak. +
+procedure ClearResult;
+
+

+

+Example +

+
+type
+  ITest = interface
+  ['{E7AA427A-0F4D-4A96-A914-FAB1CA336337}']
+    procedure Proc(const S: String);
+  end;
+
+  TTest = class(TInterfacedObject, ITest)
+  public
+    procedure Proc(const S: String);
+  end;
+
+procedure TTest.Proc(const S: String);
+begin
+  ShowMessage(S);
+end;
+
+function GetIntf(I: ITest): ITest;
+begin
+  if Assigned(I) then
+    result := I
+  else
+    result := TTest.Create;
+end;
+
+var
+  I, J: ITest;
+begin
+  J := TTest.Create;
+  
+  PaxInvoke1.This := nil; // this is not a method
+  PaxInvoke1.CallConv := _ccREGISTER;
+  PaxInvoke1.Address := @GetIntf;
+  PaxInvoke1.ClearArguments;
+  PaxInvoke1.AddArgAsInterface(J);
+  PaxInvoke1.SetResultAsInterface;
+  PaxInvoke1.CallHost; // call host-defined function
+  IUnknown(I) := IUnknown(PaxInvoke1.GetResultPtr^);
+  I.Proc('hello');
+
+  PaxInvoke1.ClearResult; // IUnknown(PaxInvoke1.GetResultPtr^)._Release;
+end;
+
+

+
+

+

+ +Copyright © 2006-2009 +VIRT Laboratory. All rights reserved. + + + diff --git a/help/tpaxinvoke_properties.htm b/help/tpaxinvoke_properties.htm new file mode 100644 index 0000000..f16f3d6 --- /dev/null +++ b/help/tpaxinvoke_properties.htm @@ -0,0 +1,112 @@ + + + + + + +

+TPaxInvoke Properties +

+
+ +

TPaxInvoke.Address

 + +
+Address of a function or method +
+property Address: Pointer;
+
+

+

+Example +

+
+type
+  TCharRec = record
+    X, Y: Char;
+  end;
+
+function MyHostFunc(const U, V: TCharRec): String; stdcall;
+begin
+  result := U.X + V.Y;
+end;
+
+var
+  R: TCharRec;
+  S: String;
+begin
+  R.X := 'a';
+  R.Y := 'b';
+
+  PaxInvoke1.Address := @ MyHostFunc;
+  PaxInvoke1.This := nil; // this is not a method
+  PaxInvoke1.ClearArguments;
+  PaxInvoke1.AddArgAsRecord(R, SizeOf(R));
+  PaxInvoke1.AddArgAsRecord(R, SizeOf(R));
+  PaxInvoke1.SetResultAsAnsiString;
+  PaxInvoke1.CallConv := _ccSTDCALL;
+  PaxInvoke1.CallHost; // call host-defined function
+  S := String(PaxInvoke1.GetResultPtr^);
+  ShowMessage(S);
+  PaxInvoke1.ClearResult;
+
+

+
+

TPaxInvoke.CallConv

 + +
+Call convention of function or method. +
+property CallConv: Integer;
+
+

+STDCALL = 1, REGISTER = 2, CDECL = 3, PASCAL = 4, SAFECALL = 5, MSFASTCALL = 6. +

+
+

TPaxInvoke.This

 + +
+If you call method of object, you have to assign This property with the object value. +
+property This: Pointer;
+
+

+

+Example +

+
+function TForm1.MyHostMethod(const X, Y: ShortString; Z: Integer): String;
+begin
+  result := X + Y + IntToStr(z);
+end;
+
+procedure TForm1.Button3Click(Sender: TObject);
+begin
+  PaxInvoke1.Address := @ TForm1.MyHostMethod;
+  PaxInvoke1.This := Self; // we call a method
+  PaxInvoke1.ClearArguments;
+  PaxInvoke1.AddArgAsShortString('xyz');
+  PaxInvoke1.AddArgAsShortString('uv');
+  PaxInvoke1.AddArgAsInteger(8);
+  PaxInvoke1.SetResultAsAnsiString;
+  PaxInvoke1.CallConv := _ccREGISTER;
+  PaxInvoke1.CallHost; // call host-defined function
+  ShowMessage(String(PaxInvoke1.GetResultPtr^));
+
+  PaxInvoke1.ClearResult;
+end;
+
+

+
+

+

+ +Copyright © 2006-2009 +VIRT Laboratory. All rights reserved. + + + diff --git a/help/tpaxpascallanguage_methods.htm b/help/tpaxpascallanguage_methods.htm new file mode 100644 index 0000000..3cfa6be --- /dev/null +++ b/help/tpaxpascallanguage_methods.htm @@ -0,0 +1,38 @@ + + + + + +

+TPaxPascalLanguage Methods +

+
+ +

TPaxPascalLanguage.Create

 + +
+Constructor of TPaxPascalLanguage class. +
+constructor Create(AOwner: TComponent); override;
+
+
+

TPaxPascalLanguage.Destroy

 + +
+Destructor of TPaxPascalLanguage class. +
+destructor Destroy; override;
+
+
+ +

+

+ +Copyright © 2006-2009 +VIRT Laboratory. All rights reserved. + + + diff --git a/help/tpaxprogram_events.htm b/help/tpaxprogram_events.htm new file mode 100644 index 0000000..102eb43 --- /dev/null +++ b/help/tpaxprogram_events.htm @@ -0,0 +1,182 @@ + + + + +

+TPaxProgram Events +

+
+ +

TPaxProgram.OnPauseUpdated

 + +
+Occurs when TPaxProgram instance is in paused state. +
+property OnPauseUpdated: TPaxPauseNotifyEvent;
+
+

+The OnPause event occurs when an attempt is made to call Pause procedure in script or to call TPaxProgram.Pause method. +

+
+

TPaxProgram.OnPause (obsolete)

 + +
+Occurs when TPaxProgram instance is in paused state. +
+property OnPause: TPaxPauseNotifyEvent;
+
+

+The OnPause event occurs when an attempt is made to call Pause procedure in script or to call TPaxProgram.Pause method. +

+
+

TPaxProgram.OnHalt

 + +
+Occurs when program is terminated with Halt procedure call. +
+property OnHalt: TPaxHaltNotifyEvent
+
+

+The OnHalt event ccurs when an attempt is made to call Halt procedure in script. +

+
+

TPaxProgram.OnException

 + +
+Occurs on handled exception. +
+property OnException: TPaxErrNotifyEvent
+
+
+

TPaxProgram.OnUnhandledException

 + +
+Occurs on unhandled exeption. +
+property OnUnhandledException: TPaxErrNotifyEvent
+
+
+

TPaxProgram.OnLoadProc

 + +
+Occurs when program tries to load a dll-defined function. +
+property OnLoadProc: TPaxLoadProcEvent;
+
+TPaxLoadProcEvent = procedure (Sender: TObject;
+const ProcName, DllName: String; var Address: Pointer) of object;
+
+
+

TPaxProgram.OnCreateObject

 + +
+Occurs when program creates an instance of script-defined class. +
+property OnCreateObject: TPaxObjectNotifyEvent;
+
+TPaxObjectNotifyEvent = procedure (Sender: TPaxProgram; Instance: TObject) of object;
+
+
+

TPaxProgram.OnDestroyObject

 + +
+Occurs when program destroys an instance of script-defined class. +
+property OnDestroyObject: TPaxObjectNotifyEvent;
+
+TPaxObjectNotifyEvent = procedure (Sender: TPaxProgram; Instance: TObject) of object;
+
+
+

TPaxProgram.OnPrintEvent

 + +
+Occurs when program implements Print statement. +
+property OnPrintEvent: TPaxPrintEvent;
+
+TPaxPrintEvent = procedure (Sender: TPaxProgram;
+const Text: String) of object;
+
+
+

TPaxProgram.OnMapTableNamespace

 + +
+Occurs when program is initializing host-defined namespace. +
+property OnMapTableNamespace: TPaxMapTableNamespaceEvent;
+
+TPaxMapTableNamespaceEvent = procedure (Sender: TPaxProgram; const FullName: String; Global: Boolean) of object;
+
+

+See ..\Demos\DemoLoadNamespace in a trial package for Delphi. +

+
+

TPaxProgram.OnMapTableVarAddress

 + +
+Occurs when program is initializing a host-defined variable. +
+property OnMapTableVarAddress: TPaxMapTableVarAddressEvent;
+
+TPaxMapTableVarAddressEvent = procedure (Sender: TPaxProgram; const FullName: String; Global: Boolean; var Address: Pointer) of object;
+
+

+See ..\Demos\DemoLoadNamespace in a trial package for Delphi. +

+
+

TPaxProgram.OnMapTableProcAddress

 + +
+Occurs when program is initializing host-defined function or method. +
+property OnMapTableProcAddress: TPaxMapTableProcAddressEvent;
+
+TPaxMapTableProcAddressEvent = procedure (Sender: TPaxProgram; const FullName: String; OverCount: Byte; Global: Boolean; var Address: Pointer) of object;
+
+

+See ..\Demos\DemoLoadNamespace in a trial package for Delphi. +

+
+

TPaxProgram.OnMapTableClassRef

 + +
+Occurs when program is initializing hos-defined class reference. +
+property OnMapTableClassRef: TPaxMapTableClassRefEvent;
+
+TPaxMapTableClassRefEvent = procedure (Sender: TPaxProgram; const FullName: String; Global: Boolean; var ClassRef: TClass) of object;
+
+

+See ..\Demos\DemoLoadNamespace in a trial package for Delphi. +

+
+

TPaxProgram.OnLoadPCU

 + +
+Occurs when TPaxProgram instance tries to load a run-time package (pcu-file). +
+property OnLoadPCU: TPaxProgramLoadPCUEvent;
+
+TPaxProgramLoadPCUEvent = function (Sender: TPaxProgram; const UnitName: String
+                              ): TStream of object;
+
+

+By default, TPaxProgram instance loads pcu files from disk. Use this event to load pcu-s from a stream to avoid disk operations. +

+
+ diff --git a/help/tpaxprogram_methods.htm b/help/tpaxprogram_methods.htm new file mode 100644 index 0000000..7563bef --- /dev/null +++ b/help/tpaxprogram_methods.htm @@ -0,0 +1,534 @@ + + + + +

+TPaxProgram Methods +

+
+ +

TPaxProgram.CallClassMethod

 + +
+Allows you to call a shared method of a script-defined class. +
+function CallClassMethod(const FullName: String;
+Instance: TClass; const ParamList: array of OleVariant): OleVariant;
+
+
+

TPaxProgram.CallMethod

 + +
+Allows you to invoke an instance method of a script-defined class. +
+function CallMethod(const FullName: String;
+Instance: TObject; const ParamList: array of OleVariant): OleVariant;
+
+
+

TPaxProgram.CallRoutine

 + +
+Allows you to invoke a script-defined routine. +
+function CallRoutine(const FullName: String;
+const ParamList: array of OleVariant): OleVariant;
+
+
+

TPaxProgram.Create

 + +
+Constructor of TPaxProgram class. +
+constructor Create(AOwner: TComponent); override;
+
+
+

TPaxProgram.Destroy

 + +
+Destructor of TPaxProgram class. +
+destructor Destroy; override;
+
+
+

TPaxProgram.DiscardPause

 + +
+Terminates a paused program. +
+procedure DiscardPause;
+
+
+

TPaxProgram.GetAddress

 + +
+Returns address of a script-defined variable, procedure or function. +
+function GetAddress(Handle: Integer): Pointer;
+function GetAddress(const FullName: String): Pointer;
+
+

+Arguments +

+
+Handle +
+Id of a a script-defined variable, procedure or function. +
+
+

+

+Example +

+
+// declare procedural type that conforms to a script-defined procedure
+type
+  TProcP = procedure (X: Integer); stdcall;
+
+procedure TForm1.Button1Click(Sender: TObject);
+var
+  H_Y, H_P: Integer;
+  I: Integer;
+  P: Pointer;
+begin
+  PaxCompiler1.Reset;
+  PaxCompiler1.RegisterLanguage(PaxPascalLanguage1);
+
+  H_Y := PaxCompiler1.RegisterVariable(0, 'Y', _typeINTEGER);
+
+  PaxCompiler1.AddModule('1', PaxPascalLanguage1.LanguageName);
+  PaxCompiler1.AddCode('1', 'procedure P(X: Integer);');
+  PaxCompiler1.AddCode('1', 'begin');
+  PaxCompiler1.AddCode('1', '  Y := Y + X;');
+  PaxCompiler1.AddCode('1', 'end;');
+  PaxCompiler1.AddCode('1', 'begin');
+  PaxCompiler1.AddCode('1', 'end.');
+
+  if PaxCompiler1.Compile(PaxProgram1) then
+  begin
+    H_P := PaxCompiler1.GetHandle(0, 'P', true);
+    P := PaxProgram1.GetAddress(H_P); // get address of script-defind procedure
+    PaxProgram1.SetAddress(H_Y, @Y);
+
+    PaxProgram1.Init; // init procedure call
+    TProcP(P)(10); // call it
+    ShowMessage(IntToStr(Y));
+  end
+  else
+    for I:=0 to PaxCompiler1.ErrorCount do
+      ShowMessage(PaxCompiler1.ErrorMessage[I]);
+end;
+
+

+
+

TPaxProgram.GetImageSize

 + +
+Returns size of image of compiled program. +
+function GetImageSize: Integer;
+
+
+

TPaxProgram.GetTypeInfo

 + +
+Returns type information of a script-defined type. +
+function GetTypeInfo(const FullTypeName: String): PTypeInfo;
+
+
+

TPaxProgram.IsPaused

 + +
+Returns 'true', if script is in the paused state. +
+function IsPaused: Boolean;
+
+
+

TPaxProgram.IsRunning

 + +
+Returns 'true', if component runs a program. +
+function IsRunning: Boolean;
+
+
+

TPaxProgram.LoadDFMFile

 + +
+Binds an instance of script-defined class with dfm file. +
+procedure LoadDFMFile(Instance: TObject; const FileName: String);
+
+
+

TPaxProgram.LoadDFMStream

 + +
+Binds an instance of a script-defined class with dfm stream. +
+procedure LoadDFMStream(Instance: TObject; S: TStream);
+
+
+

TPaxProgram.LoadFromFile

 + +
+Loads program from a file. +
+procedure LoadFromFile(const Path: String);
+
+

+

+Example +

+
+var
+  PaxProgram1: TPaxProgram;
+begin
+  if FileExists('1.bin') then
+  begin
+    PaxProgram1 := TPaxProgram.Create(nil);
+    try
+      PaxProgram1.LoadFromFile('1.bin');
+      PaxProgram1.Run;
+    finally
+      PaxProgram1.Free;
+    end;
+  end;
+end;
+
+

+
+

TPaxProgram.LoadFromStream

 + +
+Loads program from a stream. +
+procedure LoadFromStream(S: TStream);
+
+
+

TPaxProgram.Pause

 + +
+Pauses script. +
+procedure Pause;
+
+
+

TPaxProgram.Resume

 + +
+Resumes a paused script. +
+procedure Resume;
+
+
+

TPaxProgram.Run

 + +
+Executes program. +
+procedure Run;
+
+

+

+Example +

+
+procedure TForm1.Button1Click(Sender: TObject);
+var
+  H_ShowMessage: Integer;
+  I: Integer;
+begin
+  PaxCompiler1.Reset;
+  PaxCompiler1.RegisterLanguage(PaxPascalLanguage1);
+
+  // register routine 'ShowMessage'
+  H_ShowMessage := PaxCompiler1.RegisterRoutine(0, 'ShowMessage', _typeVOID, _ccREGISTER);
+  PaxCompiler1.RegisterParameter(H_ShowMessage, _typeSTRING, _Unassigned);
+
+  PaxCompiler1.AddModule('1', PaxPascalLanguage1.LanguageName);
+  PaxCompiler1.AddCode('1', 'begin');
+  PaxCompiler1.AddCode('1', '  ShowMessage(''Hello'');');
+  PaxCompiler1.AddCode('1', 'end.');
+
+  if PaxCompiler1.Compile(PaxProgram1) then
+  begin
+    // set address of routine 'ShowMessage'
+    PaxProgram1.SetAddress(H_ShowMessage, @ShowMessage);
+    PaxProgram1.Run;
+  end
+  else
+    for I:=0 to PaxCompiler1.ErrorCount - 1 do
+      ShowMessage(PaxCompiler1.ErrorMessage[I]);
+end;
+
+

+
+

TPaxProgram.SaveToFile

 + +
+Saves program to a binary file. +
+procedure SaveToFile(const Path: String);
+
+
+

TPaxProgram.SaveToStream

 + +
+Saves program to a stream. +
+procedure SaveToStream(S: TStream);
+
+
+

TPaxProgram.SetAddress

 + +
+Sets address of a host-defined variable, procedure or function. +
+procedure SetAddress(Handle: Integer; P: Pointer);
+
+

+Arguments +

+
+Handle +
+Id of a host-defined variable, procedure or function. +
+
+
+P +
+Address +
+
+

+

+Example +

+
+type
+  TMyPoint = packed record
+    x, y: Integer;
+  end;
+
+procedure TForm1.Button1Click(Sender: TObject);
+var
+  H_TMyPoint, H_MyPoint: Integer;
+  MyPoint: TMyPoint;
+  I: Integer;
+begin
+  MyPoint.X := 60;
+  MyPoint.Y := 23;
+
+  PaxCompiler1.Reset;
+  PaxCompiler1.RegisterLanguage(PaxPascalLanguage1);
+
+  // register host-defined type
+  H_TMyPoint := PaxCompiler1.RegisterRecordType(0, 'TMyPoint');
+  PaxCompiler1.RegisterRecordTypeField(H_TMyPoint, 'X', _typeINTEGER);
+  PaxCompiler1.RegisterRecordTypeField(H_TMyPoint, 'Y', _typeINTEGER);
+
+  // register host-defined variable
+  H_MyPoint := PaxCompiler1.RegisterVariable(0, 'MyPoint', H_TMyPoint);
+
+  PaxCompiler1.AddModule('1', PaxPascalLanguage1.LanguageName);
+  PaxCompiler1.AddCode('1', 'begin');
+  PaxCompiler1.AddCode('1', '  MyPoint.Y := 8;');
+  PaxCompiler1.AddCode('1', 'end.');
+
+  if PaxCompiler1.Compile(PaxProgram1) then
+  begin
+    PaxProgram1.SetAddress(H_MyPoint, @MyPoint);
+    PaxProgram1.Run;
+
+    ShowMessage(IntToStr(MyPoint.Y));
+  end
+  else
+    for I:=0 to PaxCompiler1.ErrorCount do
+      ShowMessage(PaxCompiler1.ErrorMessage[I]);
+end;
+
+

+
+

TPaxProgram.SetEntryPoint

 + +
+Assigns entry point to a program. Allows to call a script-defined function. +
+procedure SetEntryPoint(EntryPoint: TPaxInvoke);
+
+

+

+Example +

+
+procedure TTest.Proc(const S: String);
+begin
+  ShowMessage(S);
+end;
+
+procedure TForm1.Button1Click(Sender: TObject);
+
+procedure Print(const S: String);
+begin
+  ShowMessage(S);
+end;
+
+var
+  H_MyFunc: Integer;
+  I: Integer;
+  P: Pointer;
+begin
+{$O-}
+  PaxCompiler1.Reset;
+  PaxCompiler1.RegisterLanguage(PaxPascalLanguage1);
+  PaxCompiler1.RegisterHeader(0, 'procedure Print(const S: String);', @Print);
+
+  PaxCompiler1.AddModule('1', PaxPascalLanguage1.LanguageName);
+  PaxCompiler1.AddCode('1', 'uses SysUtils;');
+  PaxCompiler1.AddCode('1', 'function MyFunc(U, V: Integer): Currency; cdecl;');
+  PaxCompiler1.AddCode('1', 'begin');
+  PaxCompiler1.AddCode('1', '  try');
+  PaxCompiler1.AddCode('1', '    result := U / V;');
+  PaxCompiler1.AddCode('1', '  except');
+  PaxCompiler1.AddCode('1', '    on E: Exception do');
+  PaxCompiler1.AddCode('1', '    begin');
+  PaxCompiler1.AddCode('1', '      print(E.Message);');
+  PaxCompiler1.AddCode('1', '      result := 7;');
+  PaxCompiler1.AddCode('1', '    end;');
+  PaxCompiler1.AddCode('1', '  end;');
+  PaxCompiler1.AddCode('1', 'end;');
+  PaxCompiler1.AddCode('1', 'begin');
+  PaxCompiler1.AddCode('1', 'end.');
+
+  if PaxCompiler1.Compile(PaxProgram1) then
+  begin
+    H_MyFunc := PaxCompiler1.GetHandle(0, 'MyFunc', true);
+
+    P := PaxProgram1.GetAddress(H_MyFunc); // get address of script-defined function
+
+    PaxInvoke1.Address := P;
+    PaxInvoke1.This := nil; // this is not a method, but global function.
+    PaxInvoke1.ClearArguments;
+    PaxInvoke1.AddArgAsInteger(8);
+    PaxInvoke1.AddArgAsInteger(2);
+    PaxInvoke1.SetResultAsCurrency;
+    PaxInvoke1.CallConv := _ccCDECL;
+
+    PaxProgram1.SetEntryPoint(PaxInvoke1);
+    PaxProgram1.Run;
+
+    ShowMessage(CurrToStr(Currency(PaxInvoke1.GetResultPtr^)));
+  end
+  else
+    for I:=0 to PaxCompiler1.ErrorCount do
+      ShowMessage(PaxCompiler1.ErrorMessage[I]);
+end;
+
+

+
+

TPaxProgram.CreateScriptObject

 + +
+Creates instace of script-defined class at run-time. +
+function CreateScriptObject(const ScriptClassName: String): TObject;
+
+

+Arguments +

+
+ScriptClassName +
+Name of a script-defined class. +
+
+
+

TPaxProgram.DestroyScriptObject

 + +
+Destroys object of a script-defined class at run-time. +
+procedure DestroyScriptObject(X: TObject);
+
+
+

TPaxProgram.MapGlobal

 + +
+Forces OnMapTableNamespace, OnMapTableVarAddress, OnMapTableProcAddress, OnMapTableClassRef events for all members registered with global registration routines. +
+procedure MapGlobal;
+
+

+The events allows you to assign addresses and class references of imported host members. See ..\Demos\DemoLoadNamespace in a trial package for Delphi. +

+
+

TPaxProgram.MapLocal

 + +
+Forces OnMapTableNamespace, OnMapTableVarAddress, OnMapTableProcAddress, OnMapTableClassRef events for all members registered with TPaxCompiler registration methods. +
+procedure MapLocal;
+
+

+The events allows you to assign addresses and class references of imported host members. See ..\Demos\DemoLoadNamespace in a trial package for Delphi. +

+
+

TPaxProgram.RegisterNamespace

 + +
+Registeres a namespace. +
+function RegisterNamespace(LevelId: Integer; const Name: String): Integer;
+
+

+This method is used together with RegisterClassType and RegisterAddress and allows you to assign addresses of host-defined members and class references of hos-defined classes to compiled script. +

+
+

TPaxProgram.RegisterClassType

 + +
+Registeres class type for compiled script. +
+function RegisterClassType(LevelId: Integer; C: TClass): Integer;
+
+
+

TPaxProgram.RegisterMember

 + +
+Registeres address of host-defined member for compiled script. +
+procedure RegisterMember(LevelId: Integer; const Name: String; Address: Pointer);
+
+
+ diff --git a/help/tpaxprogram_properties.htm b/help/tpaxprogram_properties.htm new file mode 100644 index 0000000..dcbae1a --- /dev/null +++ b/help/tpaxprogram_properties.htm @@ -0,0 +1,101 @@ + + + + +

+TPaxProgram Properties +

+
+ +

TPaxProgram.DataPtr

 + +
+Returns address of DATA segment of paxCompiler program. +
+property DataPtr: Pointer read GetDataPtr;
+
+
+

TPaxProgram.CodePtr

 + +
+Returns address of CODE segment of paxCompiler program. +
+property CodePtr: Pointer read GetCodePtr;
+
+
+

TPaxProgram.DataSize

 + +
+Returns size of DATA segment of paxCompiler program. +
+property DataSize: Integer read GetDataSize;
+
+
+

TPaxProgram.CodeSize

 + +
+Returns size of cCODE segment of paxCompiler program. +
+property CodeSize: Integer read GetCodeSize;
+
+
+

TPaxProgram.ProgramSize

 + +
+Returns size of paxCompiler program. +
+property ProgramSize: Integer read GetProgramSize;
+
+
+

TPaxProgram.ResultPtr

 + +
+Returns address of result of expression. +
+property ResultPtr: Pointer read GetResultPtr;
+
+
+

TPaxProgram.ExitCode

 + +
+Returns exit code. +
+property ExitCode: Integer read GetExitCode;
+
+
+

TPaxProgram.IsEvent

 + +
+Returns "true", if program currently executes event handler body. +
+property IsEvent: Boolean read GetIsEvent;
+
+
+

TPaxProgram.SourceLine

 + +
+Returns current executed line. +
+property SourceLine: Integer read GetSourceLine;
+
+
+

TPaxProgram.ModuleName

 + +
+Returns current executed module name. +
+property ModuleName: String read GetModuleName;
+
+
+